      DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,Ak,Ag,B,D)
      IMPLICIT NONE
      DOUBLE PRECISION Ag , Ak , B , D , dx , N , X
      SAVE
      dx = SQRT(X)
      PHO_DOR92FV = N*X**Ak*(1.+Ag*dx+B*X)*(1.-X)**D

      END FUNCTION


C     LAST UPDATE 14/02/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FTOSTD
      IMPLICIT NONE
C
C Purpose: Converts coordinates from filespace to centred, rotated
C          (standard) coordinates.
C
C Calls   0:
C Called by: ROTATE
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file:
C
      INCLUDE 'FIXPAR.COM'
C
C Local variables:
C
      REAL D(3),DR(3),PHI(3,3)
      REAL CRX,SRX,CRY,SRY,CRZ,SRZ
      INTEGER I,J,K
C
C-----------------------------------------------------------------------
C
C========Form sines and cosines of detector rotation angles
C
      CRX = COS(ROTX)
      SRX = SIN(ROTX)
      CRY = COS(ROTY)
      SRY = SIN(ROTY)
      CRZ = COS(ROTZ)
      SRZ = SIN(ROTZ)
C
C========Form detector rotation matrix RzRyRx
C
      PHI(1,1) = CRZ*CRY
      PHI(1,2) = CRZ*SRY*SRX + SRZ*CRX
      PHI(1,3) = -CRZ*SRY*CRX + SRZ*SRX
      PHI(2,1) = -SRZ*CRY
      PHI(2,2) = -SRZ*SRY*SRX + CRZ*CRX
      PHI(2,3) = SRZ*SRY*CRX + CRZ*SRX
      PHI(3,1) = SRY
      PHI(3,2) = -CRY*SRX
      PHI(3,3) = CRY*CRX
C
C========Apply matrix to each point in the buffer
C
      DO 30 I=1,NPTS
         D(1) = SDD
         D(2) = FXY(1,I) - XC
         D(3) = FXY(2,I) - YC
         DO 20 J=1,3
            DR(J) = 0.0
            DO 10 K=1,3
               DR(J) = DR(J) + PHI(J,K)*D(K)
 10         CONTINUE
 20      CONTINUE
C
C========Scale coordinates to be on a plane passing through (SDD,0,0)
C
         IF(DR(1).GT.0.0)THEN
            SXY(1,I) = DR(2)*SDD/DR(1)
            SXY(2,I) = DR(3)*SDD/DR(1)
         ENDIF
 30   CONTINUE
C
C========Calculate centre beam position in detector space
C
      XCB = PHI(1,2)*SDD/PHI(1,1) + XC
      YCB = PHI(1,3)*SDD/PHI(1,1) + YC
      RETURN
C
      END


!********************  DIRECT POISSON SOLVER **********************
!*****                                                        *****
!***               p_xx + p_yy + p_zz  = f(x,y,z)               ***
!****                                                         *****
!******************************************************************
! Fourier Transforms of the Poisson equation in the x and y
! directions yield:
!
! FFT_j[FTT_i[ p_xx + p_yy + p_zz ]] = FFT_j[FTT_i[ f(x,y,z) ]],
! a^2 p' + b^2 p' + p'_zz = f'(kx,ky,z),
!
! where a and b are the known eigenvalues, kx and ky are the
! wavenumbers in the x and y direction, and p'_zz is given by:
!
! p'_zz =[p'_{kx,ky,k+1} -2*p'_{kx,ky,k} +p'_{kx,ky,k-1}]/(dz*dz).
!
! The equation above results in a tridiagonal system in k:
!
! a^2 p' + b^2 p' + p'_zz =
! [p'_{kx,ky,k+1}-(2+a^2+b^2)*p'_{kx,ky,k}+p'_{kx,ky,k-1}]/(dz*dz)
! =f'(kx,ky,z).
!
! This can be solved with Gaussian elimination. The pressure p in
! physical space is obtained from 2 inverse Fourier Transforms
! according to: p = iFFT_j[ iFFT_i[ p' ] ].
!
!******************************************************************
!****   Programmers: Bendiks Jan Boersma                     ******
!****                Wim-Paul Breugem (1D parallellisation)  ******
!****                Pedro Costa (2D parallelisation)        ******
!****   email      : w.p.breugem@tudelft.nl                  ******
!****   Modified by: Anthony Ge (KTH) on 25 Jan 2017         ******
!****   USES       : VFFTPACK   (netlib)                     ******
!****                2DECOMP&FFT (www.2decomp.org)           ******
!******************************************************************

module mod_solver_common

  use mod_param

  implicit none

  real(mytype) :: wi(itot+15), wj(jtot+15), wk(2*kmax+15)
  real, dimension(imax,jmax) :: xyrt
  real, dimension(imax,jmax,kmax) :: xzrt

  real, dimension(:), allocatable :: a,b,c

end module mod_solver_common

!------------------------------------------------------------

module mod_solver

  use mod_param
  use mod_solver_common

  implicit none

  private
  public solver2d, solver2d_cos, solver1d

contains

  subroutine solver2d(pz)

    use decomp_2d

    real, intent(inout), dimension(1:,1:,1:) :: pz
    real, dimension(itot/dims(1),jtot,ktot/dims(2)) :: py
    real, dimension(itot,jtot/dims(1),ktot/dims(2)) :: px
    real :: bb
    real :: z,d(imax,jmax,kmax)
    real :: di(itot),dj(jtot)
    integer :: i,j,k

    !-- forward FFT in the x direction --!

    call transpose_z_to_y(pz,py)
    call transpose_y_to_x(py,px)

    !$omp parallel default(none) &
    !$omp& shared(px,xsize) private(i,j,k,di) &
    !$omp&firstprivate(wi)
    !$omp do
    do k=1,xsize(3)
       do j=1,xsize(2)
          call vrfftf(1,itot,px(1:itot,j,k),di,1,wi)
       enddo
    enddo
    !$omp end parallel

    !-- forward FFT in the y direction --!

    call transpose_x_to_y(px,py)

    !$omp parallel default(none) &
    !$omp& shared(py,ysize) private(i,j,k,dj) &
    !$omp&firstprivate(wj)
    !$omp do
    do k=1,ysize(3)
       do i=1,ysize(1)
          call vrfftf(1,jtot,py(i,1:jtot,k),dj,1,wj)
       enddo
    enddo
    !$omp end parallel

    !-- Gauss elimination in the z direction --!

    call transpose_y_to_z(py,pz)

    !$omp parallel default(none) &
    !$omp&shared(pz,d,a,b,c,xyrt) &
    !$omp&private(i,j,k,z,bb)
    !$omp do
    do j=1,jmax
       do i=1,imax
          z        = 1./(b(1)+xyrt(i,j))
          d(i,j,1) = c(1)*z
          pz(i,j,1) = pz(i,j,1)*z
       enddo
    enddo
    !$omp barrier
    do k=2,kmax-1
       !$omp do
       do j=1,jmax
          do i=1,imax
             bb       = b(k)+xyrt(i,j)
             z        = 1./(bb-a(k)*d(i,j,k-1))
             d(i,j,k) = c(k)*z
             pz(i,j,k) = (pz(i,j,k)-a(k)*pz(i,j,k-1))*z
          enddo
       enddo
       !$omp barrier
    enddo
    !$omp do
    do j=1,jmax
       do i=1,imax
          bb       = b(kmax)+xyrt(i,j)
          z        = bb-a(kmax)*d(i,j,kmax-1)
          if(z.ne.0.) then
             pz(i,j,kmax) = (pz(i,j,kmax)-a(kmax)*pz(i,j,kmax-1))/z
          else
             pz(i,j,kmax) =0.
          endif
       enddo
    enddo

    do k=kmax-1,1,-1
       !$omp do
       do j=1,jmax
          do i=1,imax
             pz(i,j,k) = pz(i,j,k)-d(i,j,k)*pz(i,j,k+1)
          enddo
       enddo
       !$omp barrier
    enddo
    !$omp end parallel

    !-- backward FFT in the y direction --!

    call transpose_z_to_y(pz,py)
    !$omp parallel default(none) &
    !$omp& shared(py,ysize) private(i,j,k,dj) &
    !$omp&firstprivate(wj)
    !$omp do
    do k=1,ysize(3)
       do i=1,ysize(1)
          call vrfftb(1,jtot,py(i,1:jtot,k),dj,1,wj)
       enddo
    enddo
    !$omp end parallel

    !-- backward FFT in the x direction --!

    call transpose_y_to_x(py,px)

    !$omp parallel default(none) &
    !$omp& shared(px,xsize) private(i,j,k,di) &
    !$omp&firstprivate(wi)
    !$omp do
    do k=1,xsize(3)
       do j=1,xsize(2)
          call vrfftb(1,itot,px(1:itot,j,k),di,1,wi)
       enddo
    enddo
    !$omp end parallel

    call transpose_x_to_y(px,py)
    call transpose_y_to_z(py,pz)

    return
  end subroutine solver2d

  !------------------------------------------------------------

  subroutine solver2d_cos(pz)

    use decomp_2d

    real, intent(inout), dimension(1:,1:,1:) :: pz
    real, dimension(itot/dims(1),jtot,ktot/dims(2)) :: py
    real, dimension(itot/dims(1),jtot,ktot/dims(2)) :: xzrt_y
    real, dimension(itot,jtot/dims(1),ktot/dims(2)) :: px
    real :: bb, z
    real, dimension(itot/dims(1),jtot,ktot/dims(2)) :: d
    real :: di(itot),dk(kmax)
    integer :: i,j,k

    !-- forward FFT in the x direction --!

    call transpose_z_to_y(pz,py)
    call transpose_y_to_x(py,px)

    !$omp parallel default(none) &
    !$omp& shared(px,xsize) private(i,j,k,di) &
    !$omp&firstprivate(wi)
    !$omp do
    do k=1,ktot/dims(2)
       do j=1,jtot/dims(1)
          call vrfftf(1,itot,px(1:itot,j,k),di,1,wi)
       enddo
    enddo
    !$omp end parallel

    !-- forward cosine transform in the z direction --!

    call transpose_x_to_y(px,py)
    call transpose_y_to_z(py,pz)

    !$omp parallel default(none) &
    !$omp& shared(py,ysize) private(i,j,k,dj) &
    !$omp&firstprivate(wj)
    !$omp do
    do j=1,jmax
       do i=1,imax
          call vcosqb(1,kmax,pz(i,j,1:kmax),dk,1,wk)
       enddo
    enddo
    !$omp end parallel

    !-- Gauss elimination in the y direction --!

    call transpose_z_to_y(pz,py)
    call transpose_z_to_y(xzrt,xzrt_y)

    do k=1,ktot/dims(2)
       do i=1,imax
          z        = 1./(b(1)+xzrt_y(i,1,k))
          d(i,1,k) = c(1)*z
          py(i,1,k) = py(i,1,k)*z
       enddo
    enddo

    do j=2,jtot-1
       do k=1,ktot/dims(2)
          do i=1,imax
             bb       = b(j)+xzrt_y(i,1,k)
             z        = 1./(bb-a(j)*d(i,j-1,k))
             d(i,j,k) = c(j)*z
             py(i,j,k) = (py(i,j,k)-a(j)*py(i,j-1,k))*z
          enddo
       enddo
    enddo

    do k=1,ktot/dims(2)
       do i=1,imax
          bb       = b(jtot)+xzrt_y(i,1,k)
          z        = bb-a(jtot)*d(i,jtot-1,k)
          if(z.ne.0.) then
             py(i,jtot,k) = (py(i,jtot,k)-a(jtot)*py(i,jtot-1,k))/z
          else
             py(i,jtot,k) =0.
          endif
       enddo
    enddo

    do j=jtot-1,1,-1
       do k=1,ktot/dims(2)
          do i=1,imax
             py(i,j,k) = py(i,j,k)-d(i,j,k)*py(i,j+1,k)
          enddo
       enddo
    enddo

    !-- backward cosine transform in the z direction --!

    call transpose_y_to_z(py,pz)

    do j=1,jmax
       do i=1,imax
          call vcosqf(1,kmax,pz(i,j,1:kmax),dk,1,wk)
       enddo
    enddo

    !-- backward FFT in the x direction --!

    call transpose_z_to_y(pz,py)
    call transpose_y_to_x(py,px)

    do k=1,ktot/dims(2)
       do j=1,jtot/dims(1)
          call vrfftb(1,itot,px(1:itot,j,k),di,1,wi)
       enddo
    enddo

    call transpose_x_to_y(px,py)
    call transpose_y_to_z(py,pz)

    return
  end subroutine solver2d_cos

  !------------------------------------------------------------

subroutine solver1d(p)
use mod_zredistribute
implicit none
integer, parameter :: nprocs = dims(1)*dims(2)
integer, parameter :: ksol = kmax/nprocs
real, intent(inout) :: p(0:,0:,0:)
real,dimension(itot,jtot,ksol) :: p2
real :: bb
real :: z,d(imax,jmax,kmax)
real :: di(itot),dj(jtot)
integer i,j,k
!
! Redistribute the pressure so that it is only distributed
! in the z-direction (starting from 0 to nprocs)
!
call zredistribute(p,p2,0)
!$omp parallel default(none) &
!$omp&shared(p2) &
!$omp&private(i,j,k,di,dj) &
!$omp&firstprivate(wi,wj)
!$omp do
do k=1,ksol
  !  FFT  ---> I direction
  do j=1,jtot
    call vrfftf(1,itot,p2(1:itot,j,k),di,1,wi)
  enddo
  !  FFT  ---> J direction
  do i=1,itot
    call vrfftf(1,jtot,p2(i,1:jtot,k),dj,1,wj)
  enddo
enddo
!$omp end parallel
!
! Redistribute the pressure so that it is distributed
! on the cartesian grid
!
call zredistribute(p,p2,1)
!$omp parallel default(none) &
!$omp&shared(a,p,b,c,d,xyrt) &
!$omp&private(i,j,k,z,bb)
k=1
!$omp do
do j=1,jmax
  do i=1,imax
    z        = 1./(b(1)+xyrt(i,j))
    d(i,j,1) = c(1)*z
    p(i,j,1) = p(i,j,1)*z
  enddo
enddo
!$omp barrier
do k=2,kmax-1
!$omp do
  do j=1,jmax
    do i=1,imax
      bb       = b(k)+xyrt(i,j)
      z        = 1./(bb-a(k)*d(i,j,k-1))
      d(i,j,k) = c(k)*z
      p(i,j,k) = (p(i,j,k)-a(k)*p(i,j,k-1))*z
    enddo
  enddo
!$omp barrier
enddo
k = kmax
!$omp do
do j=1,jmax
  do i=1,imax
    bb       = b(kmax)+xyrt(i,j)
    z        = bb-a(kmax)*d(i,j,kmax-1)
    if(z.ne.0.) then
      p(i,j,kmax) = (p(i,j,kmax)-a(kmax)*p(i,j,kmax-1))/z
    else
      p(i,j,kmax) =0.
    endif
  enddo
enddo
do k=kmax-1,1,-1
!$omp do
  do j=1,jmax
    do i=1,imax
      p(i,j,k) = p(i,j,k)-d(i,j,k)*p(i,j,k+1)
    enddo
  enddo
!$omp barrier
enddo
!$omp end parallel
!
call zredistribute(p,p2,0)
!
!$omp parallel default(none) &
!$omp&shared(p2) &
!$omp&private(i,j,k,di,dj) &
!$omp&firstprivate(wi,wj)
!$omp do
do k=1,ksol
  ! BACKWARD FFT ---> J direction
  do i=1,itot
    call vrfftb(1,jtot,p2(i,1:jtot,k),dj,1,wj)
  enddo
  ! BACKWARD FFT ---> I direction
  do j=1,jtot
    call vrfftb(1,itot,p2(1:itot,j,k),di,1,wi)
  enddo
enddo
!$omp end parallel
call zredistribute(p,p2,1)
!
return
end subroutine solver1d

end module mod_solver


subroutine  sslope(sinsolelslope,solelslope,effdec,slb,hrangl)
  use simsphere_mod
  implicit none

  real :: effdec, slb, hrangl
  real :: sinsolelslope,solelslope,dipan,dipaz

!      INCLUDE 'modvars.h'

! subroutine calculates solar elevation angle and azimuth
! for sloping terrain when slope is non-zero.
! elevation for northwest corner of square box is ZNW, etc.
! grid size (called xmeshl) is in same units as ZNW

! calculate dip angle and azimuth angle of sloping surface plane

!      dipaz = 0.0
!      dipan = 0.0

!      edip = (ZNW + ZSW - ZNE - ZSE)/2.0
!      sdip = (ZNW - ZSW + ZNE - ZSE)/2.0

!      if ( edip. ne. 0 ) then

! dipan = abs (atan (edip / xmeshl / (cos(atan(sdip/edip)))))
! dipaz = 3. * 3.14159/ 2. + atan( sdip / edip)

! if ( edip. lt. 0. ) then
!   dipaz = dipaz - 3.14159
! end if

!      else

! dipan = abs (atan (sdip / xmeshl ))
! dipaz = 3.14159

!   if ( sdip. gt. 0. ) then
!     dipaz = 0.0
!   end if

! end if

  dipaz = ASPECT / 57.2958

! if (dipaz. gt. 6.2835) then
!   azimuthangle = azimuthangle  - 360.
! endif

  dipan = SLOPE / 57.2958

!  compute solar elevation angle function for sloping terrain

  sinsolelslope = cos(dipan) * ( sin(slb) * sin(effdec) + cos(slb) *    &
                  cos(effdec) * cos(hrangl)) + sin(dipan) *             &
                  ( cos(dipaz) * ( tan(slb) * ( sin(slb) * sin(effdec) +&
                  cos(slb) * cos(effdec) * cos(hrangl)) - sin(effdec) / &
                  cos(slb)) + sin(dipaz) * cos(effdec) * sin(hrangl))

  solelslope = asin(sinsolelslope)

  if ( solelslope <= 0.01) then
    solelslope = 0.01
  end if

  call albedo(sinsolelslope)

!   note that solar elevation can be less than zero for non-zero slope
!   although greater than zero for flat slope.
!   we use solar elevation for slope in albedo but not for path
!   which depends on solar angle with respect to flat plane

  return
end


subroutine jacobian(r1, ru, z1, zu, &
                    zu12, ru12, zs, rs, gsqrt, r12, tau)

      use stel_kinds, only: dp
      use name0, only: czero, cp25, cp5
      use scalars, only: nrzt, meven, modd, ohs, irst
      use scalefac, only: shalf, wint

      implicit none

      real(kind=dp), intent(in)  :: r1   (nrzt,0:1)
      real(kind=dp), intent(in)  :: ru   (nrzt,0:1)
      real(kind=dp), intent(in)  :: z1   (nrzt,0:1)
      real(kind=dp), intent(in)  :: zu   (nrzt,0:1)
      real(kind=dp), intent(out) :: ru12 (nrzt)
      real(kind=dp), intent(out) :: zu12 (nrzt)
      real(kind=dp), intent(out) :: rs   (nrzt)
      real(kind=dp), intent(out) :: zs   (nrzt)
      real(kind=dp), intent(out) :: r12  (nrzt)
      real(kind=dp), intent(out) :: gsqrt(nrzt)
      real(kind=dp), intent(out) :: tau  (nrzt)

      integer       :: l, lm
      real(kind=dp) :: taumin, taumax

      ! (RS, ZS)=(R, Z) SUB S, (RU12, ZU12)=(R, Z) SUB THETA(=U) AND GSQRT=SQRT(G)
      ! ARE DIFFERENCED ON HALF MESH
      do l = 2, nrzt
        lm = l-1

        ! dr/du, dz/du on half grid
        ru12(l) = cp5*(ru(l, meven) + ru(lm, meven) + shalf(l)*(ru(l, modd) + ru(lm, modd)))
        zu12(l) = cp5*(zu(l, meven) + zu(lm, meven) + shalf(l)*(zu(l, modd) + zu(lm, modd)))

        ! dr/ds, dz/ds on half grid
        rs(l)   = ohs*(r1(l, meven) - r1(lm, meven) + shalf(l)*(r1(l, modd) - r1(lm, modd)))
        zs(l)   = ohs*(z1(l, meven) - z1(lm, meven) + shalf(l)*(z1(l, modd) - z1(lm, modd)))

        ! r1 (=R) on half grid
        r12(l)  = cp5*(r1(l, meven) + r1(lm, meven) + shalf(l)*(r1(l, modd) + r1(lm, modd)))

        ! Jacobian
        gsqrt(l)= r12(l) * (  ru12(l)*zs(l) - rs(l)*zu12(l)                                                &
                            + cp25 * (     ru(l,modd )*z1(l,modd) + ru(lm,modd )*z1(lm,modd)               &
                                         - zu(l,modd )*r1(l,modd) - zu(lm,modd )*r1(lm,modd)               &
                                      + (  ru(l,meven)*z1(l,modd) + ru(lm,meven)*z1(lm,modd)               &
                                         - zu(l,meven)*r1(l,modd) - zu(lm,meven)*r1(lm,modd))/shalf(l) ) )

        ! TODO; in newer VMEC: gsqrt = R*tau
        tau(l) = wint(l)*gsqrt(l)
      end do

      ! TEST FOR SIGN CHANGE IN JACOBIAN
      taumin = czero
      taumax = czero
      do l = 2, nrzt
        taumin = min(tau(l), taumin)
        taumax = max(tau(l), taumax)
      end do
      if (taumin*taumax.lt.czero) then
        ! if product of min and max is less than zero,
        ! taumin and taumax have different signs
        irst=2
      end if

      return
end


program MIROIRS

    integer, parameter :: wp = kind(1.q0)       !precision des nombres reels du code

!local variables
        character(len=80) :: chaine, mot
        integer :: err, debut, fin

        integer :: nb_miroirs
        real (kind=wp) :: focale
        real (kind=wp), dimension(:), allocatable :: r
        real (kind=wp) :: inc
        integer :: i, n

!parametres de sortie miroirs paraboliques
        real (kind=wp) :: rayon_entree
        real (kind=wp) :: p_para
        real (kind=wp) :: df_p

!parametres de sortie miroirs hyperboliques
        real (kind=wp) :: p_hyper
        real (kind=wp) :: df_h
        real (kind=wp) :: e2

!initialisation des parametres par lecture du fichier parametres.par
    open(1,file='parametres.par')
    err = 0
    do while (err.eq.0)

       read(1,'(A)',iostat=err) chaine

       if ((chaine(1:1).ne.'#') .and. (err.eq.0)) then
          mot=chaine(1:(index(chaine,':'))-1)
          debut=index(chaine,'[')+1
          fin=index(chaine,']')-1

          select case (mot)
            !lecture des parametres de l'observation
             case ('nombres de miroirs')
                read(chaine(debut:fin),*) nb_miroirs
             case ('focale')
                read(chaine(debut:fin),*) focale

          end select

       end if

    end do
    close(1)

!initialisation des rayons des coquilles miroirs
    open(1,file='modeles/input/mirrors.par')
    allocate(r(1:nb_miroirs))
    read(1,*) r !r en mm dans fichier input
    r=r/1000    !r en metres (simu fonctionne avec des metres)
    close(1)

!initialisation des parametres miroirs

        df_h=focale
        !on calcul les inclinaisons des miroirs a partir de la focale du miroir exterieur
        !on se place a la jointure des 2 types de miroirs qui possede une solution
        !sur la parabole et sur l'hyperbole

open(1,file='input/mirrors_para.par')
open(2,file='input/mirrors_hyper.par')
open(3,file='input/mirrors_entree.par')

do i=nb_miroirs,1,-1

   !si on veut etudier une coquille en particulier
   !n=100
   n=i
   !on veut df_h constante donc on calcul inc en fonction de df_h et du rayon de la coquille
   inc=ATAND(r(n)/df_h)/4
   !puis on calcul la df_p correspondante
   df_p=r(n)/TAND(2*inc)

   p_para=r(n)*TAND(inc)

   p_hyper=(r(n)**2-r(n)*df_h*TAND(3*inc))/(df_h+r(n)*TAND(3*inc))

   e2=(TAND(3*inc)*r(n) - p_hyper)/(df_h+p_hyper) +1

   rayon_entree=SQRT(2*(df_p+p_para+0.3)*p_para-p_para**2)

   write(1,*) p_para, df_p+p_para, df_p
   write(2,*) p_hyper, df_h+p_hyper, df_h, e2
   write(3,*) rayon_entree

enddo

close(1)
close(2)
close(3)

end program MIROIRS


! fit with errors
subroutine fitlinesigma(xdata, ydata, n, sigma, a, b, sa, sb)
  real(rk), allocatable :: xdata(:)
  real(rk), allocatable :: ydata(:)

  integer :: n, i
  real(rk) :: a, b, sa, sb
  real(rk) :: d, sx2, sx, sy, sxy, ss, s2, sigma

  s2 = sigma**2

  d = 0.0
  sx2 = 0.0
  sx = 0.0
  sy = 0.0
  sxy = 0.0
  ss = 0.0

  i = 1
  do while (i <= n)
     sx2 = sx2 + (xdata(i)**2)/s2

     ss = ss + 1.0/s2

     sx = sx + xdata(i)/s2
     sy = sy + ydata(i)/s2
     sxy = sxy + (xdata(i) * ydata(i))/s2

     i = i + 1
  end do

  d = ss*sx2 - sx**2

  a = (sx2 * sy - sx * sxy) / d
  b = (ss * sxy - sx * sy) / d

  sa = sqrt((sx2) / d)
  sb = sqrt((ss) / d)
end subroutine fitlinesigma


!> \file multivariate_random.f90
!! Defines tools to sample multivariate random variables
!<

!> Module defining procedure to sample multivariate random variables
!!
!<
module multivariate_random
  use general_constant
  use evd_covariance
  use random
implicit none

  !> Interface for multivariate normal variables
  interface sample_normal
    module procedure sample_evd_normal_zero_mean
    module procedure sample_evd_normal_constant_mean
    module procedure sample_evd_normal_variable_mean
    !2D array
    module procedure sample_evd_normal2D_zero_mean
    !3D array
    module procedure sample_evd_normal3D_zero_mean
  end interface sample_normal

contains

  !> Samples a multivariate random variable \a x of mean 0 and covariance matrix \a C
  !! @param [out] x is a real vector that contains in returns the random (vector) variable
  !! @param [in] C is a \a evd_cov_matrix that gives the covariance matrix
  !!
  !! \details The subroutine assumes that all variable are of the proper shape and size
  !!
  !<
  subroutine sample_evd_normal_zero_mean(x, C)
    real(dp), dimension(:), intent(out) :: x
    type(evd_cov_matrix), intent(in) :: C
    !local variables
    real(dp), dimension(:), allocatable :: rla_rand

    allocate( rla_rand(get_evd_cov_nsv(C)) )
    !samples a vector of independent standard normal random variables
    call sd_rnormal( rla_rand )
    call apply_evd_square_cov(C, rla_rand, x)
    deallocate(rla_rand)
  end subroutine sample_evd_normal_zero_mean

  !> Samples a multivariate random 2D array variable \a x of mean 0 and
  !! covariance matrix \a C
  !! @param [out] x is a real 2D array that contains in returns the
  !!   random (vector) variable
  !! @param [in] C is a \a evd_cov_matrix that gives the covariance matrix
  !!
  !! @details This subroutine assumes that all variables are of the proper
  !!   shape and size
  !!
  !<
  subroutine sample_evd_normal2D_zero_mean(x, C)
    use general_tools, only: vec2mat

    real(dp), dimension(:,:), intent(out) :: x
    type(evd_cov_matrix), intent(in) :: C
    !local variables
    real(dp), dimension(:), allocatable :: rla_rand, x_vec
    integer :: vSize

    vSize = get_evd_cov_nRow(C)
    if( vSize/=size(x) )then
        write(*,*) "In sample_normal for 2D array variable: uncompatible size"
        write(*,*) "The size of the variable does not match the sixe of the cov"
        write(*,*) "Expected size: ", vSize
        write(*,*) "Got: ", size(x)
        stop
    end if
    allocate( rla_rand(get_evd_cov_nsv(C)), x_vec(vSize) )
    !samples a vector of independent standard normal random variables
    CALL sd_rnormal( rla_rand )
    call apply_evd_square_cov( C, rla_rand, x_vec )
    !
    call vec2mat( x_vec, x )
    !
    deallocate( rla_rand, x_vec )
  end subroutine sample_evd_normal2D_zero_mean

  !> Samples a multivariate random 3D array variable \a x of mean 0 and
  !! covariance matrix \a C
  !! @param [out] x is a real 3D array that contains in returns the
  !!   random (vector) variable
  !! @param [in] C is a \a evd_cov_matrix that gives the covariance matrix
  !!
  !! @details This subroutine assumes that all variables are of the proper
  !!   shape and size
  !!
  !<
  subroutine sample_evd_normal3D_zero_mean(x, C)
    use general_tools, only: vec2mat

    real(dp), dimension(:,:,:), intent(out) :: x
    type(evd_cov_matrix), intent(in) :: C
    !local variables
    real(dp), dimension(:), allocatable :: rla_rand, x_vec
    integer :: vSize

    vSize = get_evd_cov_nRow(C)
    if( vSize/=size(x) )then
        write(*,*) "In sample_normal for 3D array variable: uncompatible size"
        write(*,*) "The size of the variable does not match the sixe of the cov"
        write(*,*) "Expected size: ", vSize
        write(*,*) "Got: ", size(x)
        stop
    end if
    allocate( rla_rand(get_evd_cov_nsv(C)), x_vec(vSize) )
    !samples a vector of independent standard normal random variables
    CALL sd_rnormal( rla_rand )
    call apply_evd_square_cov( C, rla_rand, x_vec )
    !
    call vec2mat( x_vec, x )
    !
    deallocate( rla_rand, x_vec )
  end subroutine sample_evd_normal3D_zero_mean

  !> Samples a multivariate random variable \a x of constant scalar mean \a mean and covariance matrix \a C
  !! @param [out] x is a real vector that contains in returns the random (vector) variable
  !! @param [in] mean is a real number that gives the mean of the distribution
  !! @param [in] C is a \a evd_cov_matrix that gives the covariance matrix
  !!
  !! \details The subroutine assumes that all variable are of the proper shape and size
  !!
  !<
  subroutine sample_evd_normal_constant_mean(x, mean, C)
    real(dp), dimension(:), intent(out) :: x
    real(dp), intent(in) :: mean
    type(evd_cov_matrix), intent(in) :: C
    !local variables
    real(dp), dimension(:), allocatable :: rla_rand

    call sample_evd_normal_zero_mean(x, C)
    x = x + mean
    deallocate(rla_rand)
  end subroutine sample_evd_normal_constant_mean

  !> Samples a multivariate random variable \a x of mean \a mean and covariance matrix \a C
  !! @param [out] x is a real vector that contains in returns the random (vector) variable
  !! @param [in] mean is a real number that gives the mean of the distribution
  !! @param [in] C is a \a evd_cov_matrix that gives the covariance matrix
  !!
  !! \details The subroutine assumes that all variable are of the proper shape and size
  !!
  !<
  subroutine sample_evd_normal_variable_mean(x, mean, C)
    real(dp), dimension(:), intent(out) :: x
    real(dp), dimension(:), intent(in)  :: mean
    type(evd_cov_matrix), intent(in) :: C
    !local variables
    real(dp), dimension(:), allocatable :: rla_rand

    call sample_evd_normal_zero_mean(x, C)
    x = x + mean
    deallocate(rla_rand)
  end subroutine sample_evd_normal_variable_mean
end module multivariate_random


subroutine calc_eigenvalues
  !
  ! Subroutine calculates the tensor eigenvalues/eigenvectors
  ! Of each element
  !

  use tachedata
  use sphdata, only:iphase

  implicit none

  integer, parameter :: it_max = 10
  integer :: it_num,rot_num

  real :: percentcount,increment

  real, dimension(3,3) :: tensor_element,eigenvec
  real, dimension(3) :: eigen

  print*, "Calculating Tensor Eigenvalues"

  percentcount = 0.0
  increment = 10.0

  allocate(eigenvalues(3,nelement))
  allocate(eigenvectors(3,3,nelement))

  if(filetype=='SPH') then

     do ielement = 1,nelement

        call element_percent_complete(ielement,nelement,percentcount,increment)

        tensor_element(:,:) = tensor(:,:,ielement)
        eigen(:) = 0.0
        eigenvalues(:,ielement) = 0.0

        if(iphase(ielement)/=0) cycle

        it_num = 0
        rot_num = 0

        ! Find eigenvalues/eigenvectors using Jacobi method
        call jacobi_eigenvalue(3,tensor_element, it_max, eigenvec, eigen,it_num, rot_num)

        ! Return this to holding arrays
        eigenvalues(:,ielement) = eigen(:)
        eigenvectors(:,:,ielement) = eigenvec(:,:)
     enddo

     print*, 'Eigenvalues calculated'

  endif

end subroutine calc_eigenvalues


c/* ********************************************************* */
c/*  Equivalent photon approximation structure function.   * */
c/*     Improved Weizsaecker-Williams formula              * */
c/*   V.M.Budnev et al., Phys.Rep. 15C (1975) 181          * */
c/* ********************************************************* */
c   provided by Tomasz Pierzchala - UCL

      real*8 function epa_electron(x,q2max)
      integer i
      real*8 x,phi_f
      real*8 xin
      real*8 alpha
      real*8 f, q2min,q2max
      real*8 PI
      data PI/3.14159265358979323846/

      data xin/0.511d-3/ !electron mass in GeV

      alpha = .0072992701

C     // x = omega/E = (E-E')/E
      if (x.lt.1) then
         q2min= xin*xin*x*x/(1-x)
         if(q2min.lt.q2max) then
            f = alpha/2d0/PI*
     &           (2d0*xin*xin*x*(-1/q2min+1/q2max)+
     &           (2-2d0*x+x*x)/x*dlog(q2max/q2min))

         else
           f = 0.
         endif
      else
         f= 0.
      endif
c      write (*,*) x,dsqrt(q2min),dsqrt(q2max),f
      if (f .lt. 0) f = 0
      epa_electron= f

      end

      real*8 function epa_proton(x,q2max)
      integer i
      real*8 x,phi_f
      real*8 xin
      real*8 alpha,qz
      real*8 f, qmi,qma, q2max
      real*8 PI
      data PI/3.14159265358979323846/

      data xin/0.938/ ! proton mass in GeV

      alpha = .0072992701
      qz = 0.71

C     // x = omega/E = (E-E')/E
      if (x.lt.1) then
         qmi= xin*xin*x*x/(1-x)
         if(qmi.lt.q2max) then
            f = alpha/PI*(phi_f(x,q2max/qz)-phi_f(x,qmi/qz))*(1-x)/x
         else
            f=0.
         endif
      else
         f= 0.
      endif
      if (f .lt. 0) f = 0
      epa_proton= f
      end

      real*8 function phi_f(x,qq)
      real*8 x, qq
      real*8 y,qq1,f
      real*8 a,b,c

       a = 7.16
       b = -3.96
       c = .028

      qq1=1+qq
      y= x*x/(1-x)
      f=(1+a*y)*(-log(qq1/qq)+1/qq1+1/(2*qq1*qq1)+1/(3*qq1*qq1*qq1))
      f=f + (1-b)*y/(4*qq*qq1*qq1*qq1);
      f=f+ c*(1+y/4)*(log((qq1-b)/qq1)+b/qq1+b*b/(2*qq1*qq1)+
     $b*b*b/(3*qq1*qq1*qq1))
      phi_f= f
      end

      double precision function get_ion_pdf(pdf, pdg, nb_proton, nb_neutron)
C***********************************************************************
C     computing (heavy) ion contribution from proton PDF
C***********************************************************************
      double precision pdf(-7:7)
      double precision tmppdf(-2:2)
      integer pdg
      integer nb_proton
      integer nb_neutron
      double precision tmp1, tmp2

      if (nb_proton.eq.1.and.nb_neutron.eq.0)then
         get_ion_pdf = pdf(pdg)
         return
      endif

      if (pdg.eq.1.or.pdg.eq.2) then
         tmp1 = pdf(1)
         tmp2 = pdf(2)
         tmppdf(1) = nb_proton * tmp1 + nb_neutron * tmp2
         tmppdf(2) = nb_proton * tmp2 + nb_neutron * tmp1
         get_ion_pdf = tmppdf(pdg)
      else if (pdg.eq.-1.or.pdg.eq.-2) then
         tmp1 = pdf(-1)
         tmp2 = pdf(-2)
         tmppdf(-1) = nb_proton * tmp1 + nb_neutron * tmp2
         tmppdf(-2) = nb_proton * tmp2 + nb_neutron * tmp1
         get_ion_pdf = tmppdf(pdg)
      else
         get_ion_pdf = pdf(pdg)*(nb_proton+nb_neutron)
      endif

C     set correct PDF normalisation
      get_ion_pdf = get_ion_pdf * (nb_proton+nb_neutron)
      return
      end


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file idvtes.f
c
c     this file includes documentation and code for
c     subroutine idvtes         i
c
c ... files which must be loaded with idvtes.f
c
c     sphcom.f, hrfft.f, vhses.f,shaes.f
c
c
c     subroutine idvtes(nlat,nlon,isym,nt,v,w,idvw,jdvw,ad,bd,av,bv,
c    +mdab,ndab,wvhses,lvhses,work,lwork,pertbd,pertbv,ierror)
c
c     given the scalar spherical harmonic coefficients ad,bd precomputed
C*PL*ERROR* Comment line too long
c     by subroutine shaes for the scalar field divg and coefficients av,bv
C*PL*ERROR* Comment line too long
c     precomputed by subroutine shaes for the scalar field vort, subroutine
C*PL*ERROR* Comment line too long
c     idvtes computes a vector field (v,w) whose divergence is divg - pertbd
C*PL*ERROR* Comment line too long
c     and whose vorticity is vort - pertbv.  w the is east longitude component
C*PL*ERROR* Comment line too long
c     and v is the colatitudinal component of the velocity.  if nt=1 (see nt
C*PL*ERROR* Comment line too long
c     below) pertrbd and pertbv are constants which must be subtracted from
C*PL*ERROR* Comment line too long
c     divg and vort for (v,w) to exist (see the description of pertbd and
C*PL*ERROR* Comment line too long
c     pertrbv below).  usually pertbd and pertbv are zero or small relative
C*PL*ERROR* Comment line too long
c     to divg and vort.  w(i,j) and v(i,j) are the velocity components at
c     colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     the
c
c            divergence(v(i,j),w(i,j))
c
c         =  [d(sint*v)/dtheta + dw/dlambda]/sint
c
c         =  divg(i,j) - pertbd
c
c     and
c
c            vorticity(v(i,j),w(i,j))
c
c         =  [-dv/dlambda + d(sint*w)/dtheta]/sint
c
c         =  vort(i,j) - pertbv
c
c     where
c
c            sint = cos(theta(i)).
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than 3. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
C*PL*ERROR* Comment line too long
c     isym   isym determines whether (v,w) are computed on the full or half
c            sphere as follows:
c
c      = 0
c            divg,vort are neither pairwise symmetric/antisymmetric nor
c            antisymmetric/symmetric about the equator as described for
C*PL*ERROR* Comment line too long
c            isym = 1 or isym = 2  below.  in this case, the vector field
C*PL*ERROR* Comment line too long
c            (v,w) is computed on the entire sphere.  i.e., in the arrays
c            w(i,j) and v(i,j) i=1,...,nlat and j=1,...,nlon.
c
c      = 1
c
C*PL*ERROR* Comment line too long
c            divg is antisymmetric and vort is symmetric about the equator.
C*PL*ERROR* Comment line too long
c            in this case w is antisymmetric and v is symmetric about the
C*PL*ERROR* Comment line too long
c            equator.  w and v are computed on the northern hemisphere only.
c            if nlat is odd they are computed for i=1,...,(nlat+1)/2
c            and j=1,...,nlon.  if nlat is even they are computed for
c            i=1,...,nlat/2 and j=1,...,nlon.
c
c      = 2
c
C*PL*ERROR* Comment line too long
c            divg is symmetric and vort is antisymmetric about the equator.
C*PL*ERROR* Comment line too long
c            in this case w is symmetric and v is antisymmetric about the
C*PL*ERROR* Comment line too long
c            equator.  w and v are computed on the northern hemisphere only.
c            if nlat is odd they are computed for i=1,...,(nlat+1)/2
c            and j=1,...,nlon.  if nlat is even they are computed for
c            i=1,...,nlat/2 and j=1,...,nlon.
c
c
C*PL*ERROR* Comment line too long
c     nt     in the program that calls idvtes, nt is the number of scalar
C*PL*ERROR* Comment line too long
c            and vector fields.  some computational efficiency is obtained
C*PL*ERROR* Comment line too long
c            for multiple fields.  the arrays ad,bd,av,bv,u, and v can be
c            three dimensional and pertbd,pertbv can be one dimensional
C*PL*ERROR* Comment line too long
c            corresponding to indexed multiple arrays divg, vort.  in this
c            case, multiple synthesis will be performed to compute each
C*PL*ERROR* Comment line too long
c            vector field.  the third index for ad,bd,av,bv,v,w and first
C*PL*ERROR* Comment line too long
c            pertrbd,pertbv is the synthesis index which assumes the values
C*PL*ERROR* Comment line too long
c            k=1,...,nt.  for a single synthesis set nt=1. the description of
C*PL*ERROR* Comment line too long
c            remaining parameters is simplified by assuming that nt=1 or that
c            ad,bd,av,bv,v,w are two dimensional and pertbd,pertbv are
c            constants.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls idvtes. if isym = 0 then idvw
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idvw must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls idvtes. jdvw must be at least nlon.
c
c     ad,bd  two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
C*PL*ERROR* Comment line too long
c            of the divergence array divg as computed by subroutine shaes.
c
c     av,bv  two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
C*PL*ERROR* Comment line too long
c            of the vorticity array vort as computed by subroutine shaes.
C*PL*ERROR* Comment line too long
c     ***    ad,bd,av,bv must be computed by shaes prior to calling idvtes.
c
c     mdab   the first dimension of the arrays ad,bd,av,bv as it appears
C*PL*ERROR* Comment line too long
c            in the program that calls idvtes (and shaes). mdab must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
C*PL*ERROR* Comment line too long
c     ndab   the second dimension of the arrays ad,bd,av,bv as it appears in
c            the program that calls idvtes (and shaes). ndab must be at
c            least nlat.
c
c  wvhses    an array which must be initialized by subroutine vhsesi.
c            wvhses can be used repeatedly by idvtes as long as nlon
c            and nlat remain unchanged.  wvhses must not be altered
c            between calls of idvtes.
c
c
c  lvhses    the dimension of the array wvhses as it appears in the
c            program that calls idvtes. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhses must be at least
c
c               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls idvtes. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,nlon/2)       if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2)   if nlon is odd
c
c            if isym = 0 then lwork must be at least
c
c                       nlat*((2*nt+1)*nlon+4*nt*l1+1)
c
c            if isym = 1 or 2 then lwork must be at least
c
c                       (2*nt+1)*l2*nlon+nlat*(4*nt*l1+1)
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c     v,w   two or three dimensional arrays (see input parameter nt) that
c           contain a vector field whose divergence is divg - pertbd and
C*PL*ERROR* Comment line too long
c           whose vorticity is vort - pertbv.  w(i,j) is the east longitude
C*PL*ERROR* Comment line too long
c           component and v(i,j) is the colatitudinal component of velocity
c           at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude
C*PL*ERROR* Comment line too long
c           lambda(j) = (j-1)*2*pi/nlon for i=1,...,nlat and j=1,...,nlon.
c
C*PL*ERROR* Comment line too long
c   pertbd  a nt dimensional array (see input parameter nt and assume nt=1
C*PL*ERROR* Comment line too long
c           for the description that follows).  divg - pertbd is a scalar
c           field which can be the divergence of a vector field (v,w).
c           pertbd is related to the scalar harmonic coefficients ad,bd
c           of divg (computed by shaes) by the formula
c
c                pertbd = ad(1,1)/(2.*sqrt(2.))
c
c           an unperturbed divg can be the divergence of a vector field
c           only if ad(1,1) is zero.  if ad(1,1) is nonzero (flagged by
c           pertbd nonzero) then subtracting pertbd from divg yields a
c           scalar field for which ad(1,1) is zero.  usually pertbd is
c           zero or small relative to divg.
c
C*PL*ERROR* Comment line too long
c   pertbv a nt dimensional array (see input parameter nt and assume nt=1
C*PL*ERROR* Comment line too long
c           for the description that follows).  vort - pertbv is a scalar
c           field which can be the vorticity of a vector field (v,w).
c           pertbv is related to the scalar harmonic coefficients av,bv
c           of vort (computed by shaes) by the formula
c
c                pertbv = av(1,1)/(2.*sqrt(2.))
c
c           an unperturbed vort can be the vorticity of a vector field
c           only if av(1,1) is zero.  if av(1,1) is nonzero (flagged by
c           pertbv nonzero) then subtracting pertbv from vort yields a
c           scalar field for which av(1,1) is zero.  usually pertbv is
c           zero or small relative to vort.
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idvw
c           = 6  error in the specification of jdvw
c           = 7  error in the specification of mdab
c           = 8  error in the specification of ndab
c           = 9  error in the specification of lvhses
c           = 10 error in the specification of lwork
c **********************************************************************
c
c
      SUBROUTINE DIDVTES(NLAT,NLON,ISYM,NT,V,W,IDVW,JDVW,AD,BD,AV,BV,
     +                  MDAB,NDAB,WVHSES,LVHSES,WORK,LWORK,PERTBD,
     +                  PERTBV,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION AD
      DOUBLE PRECISION BD
      DOUBLE PRECISION AV
      DOUBLE PRECISION BV
      DOUBLE PRECISION WVHSES
      DOUBLE PRECISION WORK
      DOUBLE PRECISION PERTBD
      DOUBLE PRECISION PERTBV
      DIMENSION W(IDVW,JDVW,NT),V(IDVW,JDVW,NT),PERTBD(NT),PERTBV(NT)
      DIMENSION AD(MDAB,NDAB,NT),BD(MDAB,NDAB,NT)
      DIMENSION AV(MDAB,NDAB,NT),BV(MDAB,NDAB,NT)
      DIMENSION WVHSES(LVHSES),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDVW.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MIN0(NLAT, (NLON+2)/2)) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      IF (LVHSES.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 10
c
c     verify unsaved work space length
c
      MN = MMAX*NLAT*NT
      IF (ISYM.NE.0 .AND. LWORK.LT.NLAT* (2*NT*NLON+MAX0(6*IMID,NLON))+
     +    4*MN+NLAT) RETURN
      IF (ISYM.EQ.0 .AND. LWORK.LT.IMID* (2*NT*NLON+MAX0(6*NLAT,NLON))+
     +    4*MN+NLAT) RETURN
      IERROR = 0
c
c     set work space pointers
c
      IBR = 1
      IBI = IBR + MN
      ICR = IBI + MN
      ICI = ICR + MN
      IS = ICI + MN
      IWK = IS + NLAT
      LIWK = LWORK - 4*MN - NLAT
      CALL DIDVTES1(NLAT,NLON,ISYM,NT,V,W,IDVW,JDVW,WORK(IBR),WORK(IBI),
     +             WORK(ICR),WORK(ICI),MMAX,WORK(IS),MDAB,NDAB,AD,BD,AV,
     +             BV,WVHSES,LVHSES,WORK(IWK),LIWK,PERTBD,PERTBV,IERROR)
      RETURN
      END

      SUBROUTINE DIDVTES1(NLAT,NLON,ISYM,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,
     +                   MMAX,SQNN,MDAB,NDAB,AD,BD,AV,BV,WIDVTES,
     +                   LIDVTES,WK,LWK,PERTBD,PERTBV,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION SQNN
      DOUBLE PRECISION AD
      DOUBLE PRECISION BD
      DOUBLE PRECISION AV
      DOUBLE PRECISION BV
      DOUBLE PRECISION WIDVTES
      DOUBLE PRECISION WK
      DOUBLE PRECISION PERTBD
      DOUBLE PRECISION PERTBV
      DOUBLE PRECISION FN
      DIMENSION W(IDVW,JDVW,NT),V(IDVW,JDVW,NT)
      DIMENSION BR(MMAX,NLAT,NT),BI(MMAX,NLAT,NT),SQNN(NLAT)
      DIMENSION CR(MMAX,NLAT,NT),CI(MMAX,NLAT,NT)
      DIMENSION AD(MDAB,NDAB,NT),BD(MDAB,NDAB,NT)
      DIMENSION AV(MDAB,NDAB,NT),BV(MDAB,NDAB,NT)
      DIMENSION WIDVTES(LIDVTES),WK(LWK)
      DIMENSION PERTBD(NT),PERTBV(NT)
c
c     preset coefficient multiplyers in vector
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          SQNN(N) = SQRT(FN* (FN+1.D0))
    1 CONTINUE
c
c     compute multiple vector fields coefficients
c
      DO 2 K = 1,NT
c
c     set divergence,vorticity perturbation constants
c
          PERTBD(K) = AD(1,1,K)/ (2.D0*SQRT(2.D0))
          PERTBV(K) = AV(1,1,K)/ (2.D0*SQRT(2.D0))
c
c     preset br,bi,cr,ci to 0.0
c
          DO 3 N = 1,NLAT
              DO 4 M = 1,MMAX
                  BR(M,N,K) = 0.0D0
                  BI(M,N,K) = 0.0D0
                  CR(M,N,K) = 0.0D0
                  CI(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              BR(1,N,K) = -AD(1,N,K)/SQNN(N)
              BI(1,N,K) = -BD(1,N,K)/SQNN(N)
              CR(1,N,K) = AV(1,N,K)/SQNN(N)
              CI(1,N,K) = BV(1,N,K)/SQNN(N)
    5     CONTINUE
c
c     compute m>0 coefficients
c
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  BR(M,N,K) = -AD(M,N,K)/SQNN(N)
                  BI(M,N,K) = -BD(M,N,K)/SQNN(N)
                  CR(M,N,K) = AV(M,N,K)/SQNN(N)
                  CI(M,N,K) = BV(M,N,K)/SQNN(N)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     set ityp for vector synthesis without assuming div=0 or curl=0
c
      IF (ISYM.EQ.0) THEN
          ITYP = 0
      ELSE IF (ISYM.EQ.1) THEN
          ITYP = 3
      ELSE IF (ISYM.EQ.2) THEN
          ITYP = 6
      END IF
c
c     sythesize br,bi,cr,ci into the vector field (v,w)
c
      CALL DVHSES(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,MMAX,NLAT,
     +           WIDVTES,LIDVTES,WK,LWK,IERROR)
      RETURN
      END


      SUBROUTINE matsub(a,b,c,n)
      INTEGER n
      DOUBLE PRECISION a(n,n),b(n,n),c(n,n)
      INTEGER i,j
      do 12 j=1,n
        do 11 i=1,n
          c(i,j)=a(i,j)-b(i,j)
11      continue
12    continue
      return
      END

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


program pol_raman
!
! This program reads in the Raman tensors from the file
! 'Raman-Tensors.yaml', which is output from Jonathan Skelton's
! python code Phonopy-Spectroscopy used to calculate Raman
! intensities (among other stuff!). For each Raman
! active mode, the intensity vs angle theta (t) is calculated for
! incident and reflected light polarised parallel to a user-
! defined plane. That is, we model a back-scattering Raman
! experiment where the plane defined by the user is the reflection
! plane. The intensities are calculated for the polarisation
! direction varied through 360 degrees
!
! I proportional | [a,b,c] R(omega) [a] |^2
!                |                  [b] |
!                |                  [c] |
!
! where [a,b,c] is a vector parallel to the plane (hkl)
! i.e. perpendicular to [h,k,l]. [a,b,c] is normalised.
! We can then work out values for a,b,c and set an angle
! that is varied (see my logbook 18-12-18 for the algebra).
!
! If h^2 + l^2 = 0, then we set b=0 and a=cos(t), c=sin(t)
! etc
!
! Otherwise, c = cos(t) h / sqrt(h^2 + l^2);
!
! b = (-2hklcos(t)/sqrt(h^2+l^2)
!             - sqrt( 4h^2k^2l^2cos^2(t)/(l^2+h^2) -
!            4(k^2+h^2)h^2(cos^2(t)-1)) ) / 2(k^2+h^2);
!
! a = sqrt(1 - b^2 - c^2)
!
! The sign of a must be chosen to make sure the vector is
! parallel to (hkl). Note that the minus sign has been chosen
! preceding the sqrt in the denominator of b.
!
! Also, if h = 0, then we need to redo the derivation, so
! that b is in terms of a, not c. We then have:
!
! a = cos(t) l / sqrt(h^2 + l^2);
!
! b = (-2hklcos(t)/sqrt(h^2+l^2)
!             - sqrt( 4h^2k^2l^2cos^2(t)/(l^2+h^2) -
!            4(k^2+l^2)l^2(cos^2(t)-1)) ) / 2(k^2+l^2);
!
! c = sqrt(1 - b^2 - a^2)
!
!
!
! J. Buckeridge Dec. 2018
!
  implicit none
!
  integer, parameter :: nmax = 500
  integer, parameter :: maxang = 360
  real*8, parameter :: small = 1.d-12
  integer i, j, k, band(nmax)
  integer stat, nbands
  integer hi, ki, li
  real*8 pi, ram(nmax,3,3), freq(nmax), intens, theta
  real*8 hval, kval, lval, aval(nmax), bval(nmax), cval(nmax)
  real*8 test1, test2, test3, test4
  character*11 tmpstr1
  character*12 raman1, raman2
  character*10 tmpstr2
  character*1 tmpstr3
  character*2 tmpstr4
  character*3 tmpstr5
  character*20 filename
!
  pi = acos(-1.d0)
!
  write(*,'(a)') "**************************************************************"
  write(*,'(a)')
  write(*,'(a)') "    PPP          L    RRR   "
  write(*,'(a)') "    P   P        L    R   R  "
  write(*,'(a)') "    PP  P        L    RR  R  "
  write(*,'(a)') "    PPPP  OOOOO  LL   RRRR   AAAAA  MM   MM  AAAAA  NNNNN "
  write(*,'(a)') "    PP    O   O  LL   RR  R     AA  M M M M     AA  N   N "
  write(*,'(a)') "    PP    OO  O  LL   RR  R  AA  A  MM M  M  AA  A  NN  N "
  write(*,'(a)') "    PP    OOOOO  LLLL RR  R  AAAAA  MM    M  AAAAA  NN  N "
  write(*,'(a)')
  write(*,'(a)')
  write(*,'(a)') "j.buckeridge@ucl.ac.uk 2018"
  write(*,'(a)') "**************************************************************"
  write(*,'(a)')
!
  open(unit=11,file="Raman-Tensors.yaml",status="old",iostat=stat)
!
  if(stat /= 0) then
     write(*,'(a)') "ERROR: cannot find Raman-Tensors.yaml file!!"
     stop
  else
     write(*,'(a)') "Found Raman-Tensors.yaml. Reading in tensors ..."
  endif
!
! Skip first four lines of file
!
  do i=1,4
     read(11,*)
  enddo
!
! Use a loop to read in each active mode and its Raman tensor
!
  i=0
  do
     i = i+1
     read(11,*,end=101)
     read(11,*) tmpstr1, band(i)
     read(11,*) tmpstr2, freq(i)
     read(11,*)
     do j=1,3
        read(11,*) tmpstr3, tmpstr3, raman1, raman2, ram(i,j,3)
        if(raman1(1:1) == "-") then
           read(raman1(1:11),*) ram(i,j,1)
        else
           read(raman1(1:10),*) ram(i,j,1)
        endif
        if(raman2(1:1) == "-") then
           read(raman2(1:11),*) ram(i,j,2)
        else
           read(raman2(1:10),*) ram(i,j,2)
        endif
     enddo
  enddo
101 nbands = i-1
  close(unit=11)
  write(*,'(a5,x,i3,x,a21)') "Found", nbands, "Raman-active modes..."
  write(*,*)
!
! Now ask for miller indices of plane of interest
!
  write(*,'(a)') "Please enter the miller indices of the plane of interest &
       &(as 3 integers, e.g. 1 0 0 or -1 -1 2 etc):"
  read(*,*,iostat=stat) hi, ki, li
  if(stat /= 0) then
     write(*,'(a)') "ERROR reading in miller indices!"
     stop
  endif
  if( hi == 0 .and. ki == 0 .and. li == 0 ) then
     write(*,'(a)') "ERROR: (000) is not a valid set of planes!"
     stop
  endif
  write(*,*)
  hval=real(hi)
  kval=real(ki)
  lval=real(li)
!
! Calculate the a,b,c parameters for t=0 first and report the polarisation
! diretion that corresponds to t=0 and t=90
!
  test1 = hval**2 + lval**2
  test2 = hval**2 + kval**2
  test3 = kval**2 + lval**2
  if( abs(test1) < small ) then
     bval = 0.d0
     do i=1,maxang+1
        theta = real(i-1) * pi / 180.d0
        aval(i) = cos(theta)
        cval(i) = -sin(theta)
     enddo
     write(*,'(a)') "Polarisation direction at theta = 0 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(1), bval(1), cval(1), "]"
     write(*,'(a)') "Polarisation direction at theta = pi/2 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(91), bval(91), cval(91), "]"
  elseif( abs(test2) < small ) then
     cval = 0.d0
     do i=1,maxang+1
        theta = real(i-1) * pi / 180.d0
        aval(i) = cos(theta)
        bval(i) = sin(theta)
     enddo
     write(*,'(a)') "Polarisation direction at theta = 0 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(1), bval(1), cval(1), "]"
     write(*,'(a)') "Polarisation direction at theta = pi/2 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(91), bval(91), cval(91), "]"
  elseif( abs(test3) < small ) then
     aval = 0.d0
     do i=1,maxang+1
        theta = real(i-1) * pi / 180.d0
        bval(i) = cos(theta)
        cval(i) = sin(theta)
     enddo
     write(*,'(a)') "Polarisation direction at theta = 0 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(1), bval(1), cval(1), "]"
     write(*,'(a)') "Polarisation direction at theta = pi/2 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(91), bval(91), cval(91), "]"
  else
     do i=1,maxang+1
        theta = real(i-1) * pi / 180.d0
!
! Check if h = 0
!
        if( abs(hval) > small ) then
           cval(i) = hval * cos(theta) / sqrt(hval**2 + lval**2)
           bval(i) = 4.d0 * hval**2 * kval**2 * lval**2 * cos(theta)**2 / (hval**2 + lval**2)
           bval(i) = bval(i) - 4.d0 * (hval**2 + kval**2) * hval**2 * (cos(theta)**2 - 1.d0)
           if(abs(bval(i)) < small) bval(i) = 0.d0
           bval(i) = sqrt(bval(i))
           bval(i) = -2.d0 * hval * kval * lval * cos(theta) / sqrt(hval**2 + lval**2) - bval(i)
           bval(i) = bval(i) / (2.d0 * (kval**2 + hval**2))
           aval(i) = 1.d0 - bval(i)**2 - cval(i)**2
           if(abs(aval(i)) < small) aval(i) = 0.d0
           aval(i) = sqrt(aval(i))
!
! Need to check that the aval is correct - it may need a minus sign
!
           test4 = hval * aval(i) + kval * bval(i) + lval * cval(i)
           if( abs(test4) > small ) then
              aval(i) = -aval(i)
           endif
           test4 = hval * aval(i) + kval * bval(i) + lval * cval(i)
           if( abs(test4) > small ) then
              write(*,'(a19,i4,x,a32)') "Hmmm, odd vector at", i-1, &
                   &"degrees, results should be ok..."
           endif
        else
!
! H = 0, then we need to define b in terms of a, not c and set a
!
           aval(i) = lval * cos(theta) / sqrt(hval**2 + lval**2)
           bval(i) = 4.d0 * hval**2 * kval**2 * lval**2 * cos(theta)**2 / (hval**2 + lval**2)
           bval(i) = bval(i) - 4.d0 * (kval**2 + lval**2) * lval**2 * (cos(theta)**2 - 1.d0)
           if(abs(bval(i)) < small) bval(i) = 0.d0
           bval(i) = sqrt(bval(i))
           bval(i) = -2.d0 * hval * kval * lval * cos(theta) / sqrt(hval**2 + lval**2) - bval(i)
           bval(i) = bval(i) / (2.d0 * (kval**2 + lval**2))
           cval(i) = 1.d0 - bval(i)**2 - aval(i)**2
           if(abs(cval(i)) < small) cval(i) = 0.d0
           cval(i) = sqrt(cval(i))
!
! Need to check that the aval is correct - it may need a minus sign
!
           test4 = hval * aval(i) + kval * bval(i) + lval * cval(i)
           if( abs(test4) > small ) then
              cval(i) = -cval(i)
           endif
           test4 = hval * aval(i) + kval * bval(i) + lval * cval(i)
           if( abs(test4) > small ) then
              write(*,'(a19,i4,x,a32)') "Hmmm, odd vector at", i-1, &
                   &"degrees, results should be ok..."
           endif
        endif
     enddo
     write(*,'(a)') "Polarisation direction at theta = 0 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(1), bval(1), cval(1), "]"
     write(*,'(a)') "Polarisation direction at theta = pi/2 :"
     write(*,'(a1,2x,3(f13.6,2x),a1)') "[", aval(91), bval(91), cval(91), "]"
  endif
!
! Now calculate intensities for reflections from user-defined plane as a function
! of angle
!
  write(*,*)
  write(*,'(a)') "Writing intensity vs angle output to files titled 'modeXX.dat', where XX is the mode index..."
  do i=1,nbands
     if( band(i) < 10 ) then
        write(tmpstr3,'(i1)') band(i)
        tmpstr3 = trim(tmpstr3)
        filename = "mode"//tmpstr3//".dat"
     elseif (band(i) < 100 ) then
        write(tmpstr4,'(i2)') band(i)
        tmpstr4 = trim(tmpstr4)
        filename = "mode"//tmpstr4//".dat"
     else
        write(tmpstr5,'(i3)') band(i)
        tmpstr5 = trim(tmpstr5)
        filename = "mode"//tmpstr5//".dat"
     endif
     open(unit=11,file=filename,status="replace",iostat=stat)
     write(11,*) "# band", band(i), "freq", freq(i)
     write(11,*) "# theta (deg), intensity"
     do j=1,maxang+1
        intens = aval(j)**2 * ram(i,1,1) + aval(j) * bval(j) * ram(i,2,1) + aval(j) * cval(j) * ram(i,3,1) &
             + aval(j) * bval(j) * ram(i,1,2) + bval(j)**2 * ram(i,2,2) + bval(j) * cval(j) * ram(i,3,2) &
             + aval(j) * cval(j) * ram(i,1,3) + bval(j) * cval(j) * ram(i,2,3) + cval(j)**2 * ram(i,3,3)
        intens = intens * intens
        write(11,'(f12.5,3x,e20.13)') real(j-1), intens
     enddo
     close(unit=11)
  enddo
  write(*,'(a)') "...done"
!
end program pol_raman


subroutine get_backward_euler_lhs(t, dt, r, p, output)

!----------------------------------------------------------------
! Calculates
!     m'[r](p) = p + dt * g'[r](p),
! as appears on the left-hand side of Newton's method.
!
! Args:
!   t: Most recent time value.
!   dt: Time step size.
!   r: Current Newton iterate.
!   p: Current Newton perturbation.
!   output: Result of the operation.
!----------------------------------------------------------------

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t, dt
    double precision, intent(in), dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: r, p
    double precision, intent(out), dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: output

    integer :: ix, iy, ieqn

    call apply_linearized_bcs(r, p)
    call apply_linearized_pde_operator(t, r, p, output)

    do ieqn = 1, meqn
        !$omp parallel do private(ix)
        do iy = 1, my
            do ix = 1,mx
                output(ix, iy, ieqn) = p(ix, iy, ieqn) - dt * output(ix, iy, ieqn)
            end do
        end do
    end do

end subroutine get_backward_euler_lhs


! Flows-to example
!
! This is a three point stencil (centred, depth 1) which has been
! decomposed. CamFort will infer a single specification for the loop.
program decomposedthreepoint
implicit none

integer i
parameter (n=10)
real a(0:imax)
real b(0:imax)

do i = 1, n
 x = a(i)
 y = a(i+1)
 != stencil readOnce, centered(depth=1, dim=1) :: a
 b(i) = (a(i-1) + x + y)/3.0
end do

end


FUNCTION wkjday(jday)
!
IMPLICIT NONE
!
! Function arguments
!
INTEGER :: jday
INTEGER :: wkjday
!
!     + + + purpose + + +
!     given a date in julian day format
!     wkjday will give the day of the week.
!     0 = monday
!     1 = tuesday
!     2 = wednesday
!     3 = thursday
!     4 = friday
!     5 = saturday
!     6 = sunday
!
!     + + + keywords + + +
!     date, utility
!
!     + + + argument declarations + + +
!
!     + + + argument definitions + + +
!     jday   - julian day
!
!     + + + end specifications + + +
!
!     we simply take the julian day and do a modulo of the value
!
wkjday = mod(jday,7)
!
END FUNCTION wkjday

Project Documents/Source Code Original/Wkjday.f90


program test_basis
use basis, only: get_cartesian_shell, getstart, get_2ints_size
use utils, only: assert
implicit none

integer :: l, m, n
integer, allocatable, dimension(:) :: lpower, mpower, npower
l = 0
allocate(lpower((l+1)*(l+2)/2), mpower((l+1)*(l+2)/2), npower((l+1)*(l+2)/2))
call get_cartesian_shell(l, lpower, mpower, npower)
call assert(all(lpower == [0]))
call assert(all(mpower == [0]))
call assert(all(npower == [0]))
deallocate(lpower, mpower, npower)

l = 1
allocate(lpower((l+1)*(l+2)/2), mpower((l+1)*(l+2)/2), npower((l+1)*(l+2)/2))
call get_cartesian_shell(l, lpower, mpower, npower)
call assert(all(lpower == [1, 0, 0]))
call assert(all(mpower == [0, 1, 0]))
call assert(all(npower == [0, 0, 1]))
deallocate(lpower, mpower, npower)

l = 2
allocate(lpower((l+1)*(l+2)/2), mpower((l+1)*(l+2)/2), npower((l+1)*(l+2)/2))
call get_cartesian_shell(l, lpower, mpower, npower)
call assert(all(lpower == [2, 1, 1, 0, 0, 0]))
call assert(all(mpower == [0, 1, 0, 2, 1, 0]))
call assert(all(npower == [0, 0, 1, 0, 1, 2]))
deallocate(lpower, mpower, npower)

l = 3
allocate(lpower((l+1)*(l+2)/2), mpower((l+1)*(l+2)/2), npower((l+1)*(l+2)/2))
call get_cartesian_shell(l, lpower, mpower, npower)
call assert(all(lpower == [3, 2, 2, 1, 1, 1, 0, 0, 0, 0]))
call assert(all(mpower == [0, 1, 0, 2, 1, 0, 3, 2, 1, 0]))
call assert(all(npower == [0, 0, 1, 0, 1, 2, 0, 1, 2, 3]))
deallocate(lpower, mpower, npower)

l = 4
allocate(lpower((l+1)*(l+2)/2), mpower((l+1)*(l+2)/2), npower((l+1)*(l+2)/2))
call get_cartesian_shell(l, lpower, mpower, npower)
call assert(all(lpower == [4, 3, 3, 2, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0]))
call assert(all(mpower == [0, 1, 0, 2, 1, 0, 3, 2, 1, 0, 4, 3, 2, 1, 0]))
call assert(all(npower == [0, 0, 1, 0, 1, 2, 0, 1, 2, 3, 0, 1, 2, 3, 4]))
deallocate(lpower, mpower, npower)

! -------------------------------------------------------
call assert(all(getstart([6, 3, 3, 1, 1, 1]) == [1, 7, 10, 13, 14, 15]))
call assert(all(getstart([6, 6, 6, 3, 3, 1, 1, 1]) == &
    [1, 7, 13, 19, 22, 25, 26, 27]))

! -------------------------------------------------------
n = 15
m = n*16/2
call assert(get_2ints_size(n) == m*(m+1)/2)

end program


! This module contains basic functions
MODULE Functions

USE Constants
IMPLICIT NONE

CONTAINS
    !-------------------------------------------------------------------------------------------------------------------------------
    ! Saturates inputValue. Makes sure it is not smaller than minValue and not larger than maxValue
    REAL FUNCTION saturate(inputValue, minValue, maxValue)
    !

        IMPLICIT NONE

        REAL(4), INTENT(IN)     :: inputValue
        REAL(4), INTENT(IN)     :: minValue
        REAL(4), INTENT(IN)     :: maxValue

        saturate = MIN(MAX(inputValue,minValue), maxValue)

    END FUNCTION saturate
    !-------------------------------------------------------------------------------------------------------------------------------
    ! Saturates inputValue. Makes sure it is not smaller than minValue and not larger than maxValue
    REAL FUNCTION ratelimit(inputSignal, inputSignalPrev, minRate, maxRate, DT)
    !
        IMPLICIT NONE

        REAL(4), INTENT(IN)     :: inputSignal
        REAL(4), INTENT(IN)     :: inputSignalPrev
        REAL(4), INTENT(IN)     :: minRate
        REAL(4), INTENT(IN)     :: maxRate
        REAL(4), INTENT(IN)     :: DT

        ! Local variables
        REAL(4)                 :: rate

        rate = (inputSignal - inputSignalPrev)/DT                       ! Signal rate (unsaturated)
        rate = saturate(rate, minRate, maxRate)                 ! Saturate the signal rate
        ratelimit = inputSignalPrev + rate*DT                       ! Saturate the overall command using the rate limit

    END FUNCTION ratelimit
    !-------------------------------------------------------------------------------------------------------------------------------
    ! PI controller, with output saturation
    REAL FUNCTION PIController(error, kp, ki, minValue, maxValue, DT, I0, reset, inst)
    !
        IMPLICIT NONE

        ! Inputs
        REAL(4), INTENT(IN)         :: error
        REAL(4), INTENT(IN)         :: kp
        REAL(4), INTENT(IN)         :: ki
        REAL(4), INTENT(IN)         :: minValue
        REAL(4), INTENT(IN)         :: maxValue
        REAL(4), INTENT(IN)         :: DT
        INTEGER(4), INTENT(INOUT)   :: inst
        REAL(4), INTENT(IN)         :: I0
        LOGICAL, INTENT(IN)         :: reset

        ! Local
        INTEGER(4)                      :: i                                            ! Counter for making arrays
        REAL(4)                         :: PTerm                                        ! Proportional term
        REAL(4), DIMENSION(99), SAVE    :: ITerm = (/ (real(9999.9), i = 1,99) /)       ! Integral term, current.
        REAL(4), DIMENSION(99), SAVE    :: ITermLast = (/ (real(9999.9), i = 1,99) /)   ! Integral term, the last time this controller was called. Supports 99 separate instances.
        INTEGER(4), DIMENSION(99), SAVE :: FirstCall = (/ (1, i=1,99) /)                ! First call of this function?

        ! Initialize persistent variables/arrays, and set inital condition for integrator term
        IF ((FirstCall(inst) == 1) .OR. reset) THEN
            ITerm(inst) = I0
            ITermLast(inst) = I0

            FirstCall(inst) = 0
            PIController = I0
        ELSE
            PTerm = kp*error
            ITerm(inst) = ITerm(inst) + DT*ki*error
            ITerm(inst) = saturate(ITerm(inst), minValue, maxValue)
            PIController = PTerm + ITerm(inst)
            PIController = saturate(PIController, minValue, maxValue)

            ITermLast(inst) = ITerm(inst)
        END IF
        inst = inst + 1

    END FUNCTION PIController
    !-------------------------------------------------------------------------------------------------------------------------------
    ! interp1 1-D interpolation (table lookup), xData and yData should be monotonically increasing
    REAL FUNCTION interp1d(xData, yData, xq)
    !
        IMPLICIT NONE
            ! Inputs
        REAL(4), DIMENSION(:), INTENT(IN)       :: xData        ! Provided x data (vector), to be interpolated
        REAL(4), DIMENSION(:), INTENT(IN)       :: yData        ! Provided y data (vector), to be interpolated
        REAL(4), INTENT(IN)                     :: xq           ! x-value for which the y value has to be interpolated
        INTEGER(4)                              :: I            ! Iteration index

        IF (xq <= MINVAL(xData)) THEN
            interp1d = yData(1)
        ELSEIF (xq >= MAXVAL(xData)) THEN
            interp1d = yData(SIZE(xData))
        ELSE
            DO I = 1, SIZE(xData)
                IF (xq <= xData(I)) THEN
                    interp1d = yData(I-1) + (yData(I) - yData(I-1))/(xData(I) - xData(I-1))*(xq - xData(I-1))
                    EXIT
                ELSE
                    CONTINUE
                END IF
            END DO
        END IF

    END FUNCTION interp1d
    !-------------------------------------------------------------------------------------------------------------------------------
    ! DF controller, with output saturation
    REAL FUNCTION DFController(error, Kd, Tf, DT, inst)
    !
        IMPLICIT NONE

            ! Inputs
        REAL(4), INTENT(IN)     :: error
        REAL(4), INTENT(IN)     :: kd
        REAL(4), INTENT(IN)     :: tf
        REAL(4), INTENT(IN)     :: DT
        INTEGER(4), INTENT(IN)  :: inst

            ! Local
        REAL(4)                         :: B                                    !
        INTEGER(4)                      :: i                                    ! Counter for making arrays
        REAL(4), DIMENSION(99), SAVE    :: errorLast = (/ (0, i=1,99) /)        !
        REAL(4), DIMENSION(99), SAVE    :: DFControllerLast = (/ (0, i=1,99) /) !
        INTEGER(4), DIMENSION(99), SAVE :: FirstCall = (/ (1, i=1,99) /)        ! First call of this function?

            ! Initialize persistent variables/arrays, and set inital condition for integrator term
        ! IF (FirstCall(inst) == 1) THEN
            ! FirstCall(inst) = 0
        ! END IF

        B = 2.0/DT
        DFController = (Kd*B)/(B*Tf+1.0)*error - (Kd*B)/(B*Tf+1.0)*errorLast(inst) - (1.0-B*Tf)/(B*Tf+1.0)*DFControllerLast(inst)

        errorLast(inst) = error
        DFControllerLast(inst) = DFController
    END FUNCTION DFController
    !-------------------------------------------------------------------------------------------------------------------------------
    ! State machines, determines the state of the wind turbine to determine the corresponding control actions
    ! States:
    ! - VS/PC_State = 0, Error state, for debugging purposes (VS) / No pitch control active, pitch constant at fine-pitch (PC)
    ! - VS_State = 1, Region 1(.5) operation, torque control to keep the rotor at cut-in speed towards the Cp-max operational curve
    ! - VS_State = 2, Region 2, operation, maximum rotor power efficiency (Cp-max) tracking, keep TSR constant at a fixed fine-pitch angle
    ! - VS_State = 3, Region 2.5, transition between below and above-rated operating conditions (near-rated region) using PI torque control
    ! - VS_State = 4 + PC_State = 1, above-rated operation using pitch control (constant torque mode)
    ! - VS_State = 5 + PC_State = 2, above-rated operation using pitch and torque control (constant power mode)
    SUBROUTINE StateMachine(CntrPar, LocalVar)
        USE DRC_Types, ONLY : LocalVariables, ControlParameters
        IMPLICIT NONE

            ! Inputs
        TYPE(ControlParameters), INTENT(IN)     :: CntrPar
        TYPE(LocalVariables), INTENT(INOUT)     :: LocalVar

            ! Local
            ! Pitch control state machine
        IF (LocalVar%iStatus == 0) THEN
            IF (LocalVar%PitCom(1) >= CntrPar%VS_Rgn3Pitch) THEN ! We are in region 3
                IF (CntrPar%VS_ControlMode == 1) THEN ! Constant power tracking
                    LocalVar%VS_State = 5
                    LocalVar%PC_State = 2
                ELSE ! Constant torque tracking
                    LocalVar%VS_State = 4
                    LocalVar%PC_State = 1
                END IF
            ELSE
                LocalVar%VS_State = 2
                LocalVar%PC_State = 0
            END IF
        ELSE
            IF ((CntrPar%VS_ControlMode == 0) .AND. (LocalVar%GenTq >= CntrPar%PC_RtTq99)) THEN
                LocalVar%PC_State = 1
            ELSEIF ((CntrPar%VS_ControlMode == 1) .AND. (LocalVar%GenArTq >= CntrPar%VS_ArSatTq*0.99)) THEN
                LocalVar%PC_State = 2
            ELSE
                LocalVar%PC_State = 0
            END IF

                ! Torque control state machine
            IF (LocalVar%PC_PitComT >= CntrPar%VS_Rgn3Pitch) THEN ! We are in region 3 !
                IF (CntrPar%VS_ControlMode == 1) THEN ! Constant power tracking
                    LocalVar%VS_State = 5
                ELSE ! Constant torque tracking
                    LocalVar%VS_State = 4
                END IF
            ELSE
                IF (LocalVar%GenArTq >= CntrPar%VS_MaxOMTq*1.01) THEN ! We are in region 2 1/2 - active PI torque control
                    LocalVar%VS_State = 3
                ELSEIF (LocalVar%GenBrTq <= CntrPar%VS_MinOMTq*0.99) THEN ! We are in region 1 1/2
                    LocalVar%VS_State = 1
                ELSEIF (LocalVar%GenSpeedF < CntrPar%VS_RefSpd)  THEN ! We are in region 2 - optimal torque is proportional to the square of the generator speed
                    LocalVar%VS_State = 2
                ELSE ! Error state, for debugging purposes
                    LocalVar%VS_State = 0
                END IF
            END IF
        END IF
    END SUBROUTINE StateMachine
    !-------------------------------------------------------------------------------------------------------------------------------
    SUBROUTINE Debug(LocalVar, CntrPar, avrSWAP, RootName, size_avcOUTNAME)
        USE, INTRINSIC  :: ISO_C_Binding
        USE DRC_Types, ONLY : LocalVariables, ControlParameters

        IMPLICIT NONE

        TYPE(ControlParameters), INTENT(IN)     :: CntrPar
        TYPE(LocalVariables), INTENT(IN)        :: LocalVar

        INTEGER(4), INTENT(IN)                      :: size_avcOUTNAME
        INTEGER(4)                                  :: I                ! Generic index.
        CHARACTER(1), PARAMETER                     :: Tab = CHAR(9)                        ! The tab character.
        CHARACTER(25), PARAMETER                    :: FmtDat = "(F8.3,99('"//Tab//"',ES10.3E2,:))  "   ! The format of the debugging data
        INTEGER(4), PARAMETER                       :: UnDb = 85        ! I/O unit for the debugging information
        INTEGER(4), PARAMETER                       :: UnDb2 = 86       ! I/O unit for the debugging information, avrSWAP
        REAL(C_FLOAT), INTENT(INOUT)                :: avrSWAP(*)   ! The swap array, used to pass data to, and receive data from, the DLL controller.
        CHARACTER(size_avcOUTNAME-1), INTENT(IN)    :: RootName     ! a Fortran version of the input C string (not considered an array here)    [subtract 1 for the C null-character]

        !..............................................................................................................................
        ! Initializing debug file
        !..............................................................................................................................
        IF (LocalVar%iStatus == 0)  THEN  ! .TRUE. if we're on the first call to the DLL
        ! If we're debugging, open the debug file and write the header:
            IF (CntrPar%LoggingLevel > 0) THEN
                !OPEN(unit=UnDb, FILE=TRIM(RootName)//'.dbg', STATUS='NEW')
                OPEN(unit=UnDb, FILE='DEBUG.dbg')
                WRITE (UnDb,'(A)')  '   LocalVar%Time '  //Tab//'LocalVar%FA_Acc  '//Tab//'LocalVar%FA_AccHPF  '//Tab//'LocalVar%FA_AccHPFI  '//Tab//'LocalVar%PitCom  '
                WRITE (UnDb,'(A)')  '   (sec) ' //Tab//'(m/s^2)    ' //Tab//'(m/s^2)    ' //Tab//'(m/s)    ' //Tab//'(rad)    '
                !WRITE (UnDb,'(A)') '   LocalVar%Time '  //Tab//'LocalVar%PC_PitComT  ' //Tab//'LocalVar%PC_SpdErr  ' //Tab//'LocalVar%PC_KP ' //Tab//'LocalVar%PC_KI  ' //Tab//'LocalVar%Y_M  ' //Tab//'LocalVar%rootMOOP(1)  '//Tab//'VS_RtPwr  '//Tab//'LocalVar%GenTq'
                !WRITE (UnDb,'(A)') '   (sec) ' //Tab//'(rad)    '  //Tab//'(rad/s) '//Tab//'(-) ' //Tab//'(-)   ' //Tab//'(rad)   ' //Tab//'(?)   ' //Tab//'(W)   '//Tab//'(Nm)  '
            END IF

            IF (CntrPar%LoggingLevel > 1) THEN
                !OPEN(UnDb2, FILE=TRIM(RootName)//'.dbg2', STATUS='REPLACE')
                OPEN(unit=UnDb2, FILE='DEBUG2.dbg')
                WRITE(UnDb2,'(/////)')
                WRITE(UnDb2,'(A,85("'//Tab//'AvrSWAP(",I2,")"))')  'LocalVar%Time ', (i,i=1,85)
                WRITE(UnDb2,'(A,85("'//Tab//'(-)"))')  '(s)'
            END IF
        ELSE
            ! Print simulation status, every 10 seconds
            IF (MODULO(LocalVar%Time, 10.0) == 0) THEN
                WRITE(*, 100) LocalVar%GenSpeedF*RPS2RPM, LocalVar%BlPitch(1)*R2D, avrSWAP(15)/1000.0, LocalVar%WE_Vw ! LocalVar%Time !/1000.0
                100 FORMAT('Generator speed: ', f6.1, ' RPM, Pitch angle: ', f5.1, ' deg, Power: ', f7.1, ' kW, Est. wind Speed: ', f5.1, ' m/s')
                ! PRINT *, LocalVar%PC_State, LocalVar%VS_State, CntrPar%VS_Rgn3Pitch, CntrPar%PC_FinePit, CntrPar%PC_Switch, LocalVar%BlPitch(1) ! Additional debug info
                ! PRINT *, LocalVar%RotSpeed
            END IF

            ! Output debugging information if requested:
            IF (CntrPar%LoggingLevel > 0) THEN
                WRITE (UnDb,FmtDat)     LocalVar%Time, LocalVar%FA_Acc, LocalVar%FA_AccHPF, LocalVar%FA_AccHPFI, LocalVar%PitCom
            END IF

            IF (CntrPar%LoggingLevel > 1) THEN
                WRITE (UnDb2,FmtDat)    LocalVar%Time, avrSWAP(1:85)
            END IF
        END IF

        IF (MODULO(LocalVar%Time, 10.0) == 0.0) THEN
            !LocalVar%TestType = LocalVar%TestType + 10
            !PRINT *, LocalVar%TestType
        END IF
    END SUBROUTINE Debug
    !-------------------------------------------------------------------------------------------------------------------------------
    !The Coleman or d-q axis transformation transforms the root out of plane bending moments of each turbine blade
    !to a direct axis and a quadrature axis
    SUBROUTINE ColemanTransform(rootMOOP, aziAngle, nHarmonic, axTOut, axYOut)
    !...............................................................................................................................

        IMPLICIT NONE

            ! Inputs

        REAL(4), INTENT(IN)     :: rootMOOP(3)                      ! Root out of plane bending moments of each blade
        REAL(4), INTENT(IN)     :: aziAngle                         ! Rotor azimuth angle
        INTEGER(4), INTENT(IN)  :: nHarmonic                        ! The harmonic number, nP

            ! Outputs

        REAL(4), INTENT(OUT)    :: axTOut, axYOut               ! Direct axis and quadrature axis outputted by this transform

            ! Local

        REAL(4), PARAMETER      :: phi2 = 2.0/3.0*PI                ! Phase difference from first to second blade
        REAL(4), PARAMETER      :: phi3 = 4.0/3.0*PI                ! Phase difference from first to third blade

            ! Body

        axTOut  = 2.0/3.0 * (cos(nHarmonic*(aziAngle))*rootMOOP(1) + cos(nHarmonic*(aziAngle+phi2))*rootMOOP(2) + cos(nHarmonic*(aziAngle+phi3))*rootMOOP(3))
        axYOut  = 2.0/3.0 * (sin(nHarmonic*(aziAngle))*rootMOOP(1) + sin(nHarmonic*(aziAngle+phi2))*rootMOOP(2) + sin(nHarmonic*(aziAngle+phi3))*rootMOOP(3))

    END SUBROUTINE ColemanTransform
    !-------------------------------------------------------------------------------------------------------------------------------
    !The inverse Coleman or d-q axis transformation transforms the direct axis and quadrature axis
    !back to root out of plane bending moments of each turbine blade
    SUBROUTINE ColemanTransformInverse(axTIn, axYIn, aziAngle, nHarmonic, aziOffset, PitComIPC)
    !...............................................................................................................................

        IMPLICIT NONE

            ! Inputs

        REAL(4), INTENT(IN)     :: axTIn, axYIn         ! Direct axis and quadrature axis
        REAL(4), INTENT(IN)     :: aziAngle                     ! Rotor azimuth angle
        REAL(4), INTENT(IN)     :: aziOffset                    ! Phase shift added to the azimuth angle
        INTEGER(4), INTENT(IN)  :: nHarmonic                    ! The harmonic number, nP

            ! Outputs

        REAL(4), INTENT(OUT)    :: PitComIPC(3)                 ! Root out of plane bending moments of each blade

            ! Local

        REAL(4), PARAMETER      :: phi2 = 2.0/3.0*PI                ! Phase difference from first to second blade
        REAL(4), PARAMETER      :: phi3 = 4.0/3.0*PI                ! Phase difference from first to third blade

            ! Body

        PitComIPC(1) = cos(nHarmonic*(aziAngle+aziOffset))*axTIn + sin(nHarmonic*(aziAngle+aziOffset))*axYIn
        PitComIPC(2) = cos(nHarmonic*(aziAngle+aziOffset+phi2))*axTIn + sin(nHarmonic*(aziAngle+aziOffset+phi2))*axYIn
        PitComIPC(3) = cos(nHarmonic*(aziAngle+aziOffset+phi3))*axTIn + sin(nHarmonic*(aziAngle+aziOffset+phi3))*axYIn

    END SUBROUTINE ColemanTransformInverse
    !-------------------------------------------------------------------------------------------------------------------------------
    !Paremeterized Cp(lambda) function for a fixed pitch angle. Circumvents the need of importing a look-up table
    REAL FUNCTION CPfunction(CP, lambda)
        IMPLICIT NONE

        ! Inputs
        REAL(4), INTENT(IN) :: CP(4)    ! Parameters defining the parameterizable Cp(lambda) function
        REAL(4), INTENT(IN) :: lambda    ! Estimated or measured tip-speed ratio input

        CPfunction = exp(-CP(1)/lambda)*(CP(2)/lambda-CP(3))+CP(4)*lambda
        CPfunction = saturate(CPfunction, 0.001, 1.0)

    END FUNCTION CPfunction
    !-------------------------------------------------------------------------------------------------------------------------------
    !Function for computing the aerodynamic torque, divided by the effective rotor torque of the turbine, for use in wind speed estimation
    REAL FUNCTION AeroDynTorque(LocalVar, CntrPar)
        USE DRC_Types, ONLY : LocalVariables, ControlParameters
        IMPLICIT NONE

            ! Inputs
        TYPE(ControlParameters), INTENT(IN) :: CntrPar
        TYPE(LocalVariables), INTENT(IN) :: LocalVar

            ! Local
        REAL(4) :: RotorArea
        REAL(4) :: Cp
        REAL(4) :: Lambda

        RotorArea = PI*CntrPar%WE_BladeRadius**2
        Lambda = LocalVar%RotSpeed*CntrPar%WE_BladeRadius/LocalVar%WE_Vw
        Cp = CPfunction(CntrPar%WE_CP, Lambda)

        AeroDynTorque = 0.5*(CntrPar%WE_RhoAir*RotorArea)*(LocalVar%WE_Vw**3/LocalVar%RotSpeed)*Cp
        AeroDynTorque = MAX(AeroDynTorque, 0.0)

    END FUNCTION AeroDynTorque
    !-------------------------------------------------------------------------------------------------------------------------------
    SUBROUTINE WindSpeedEstimator(LocalVar, CntrPar)
        USE DRC_Types, ONLY : LocalVariables, ControlParameters
        IMPLICIT NONE

        ! Inputs
        TYPE(ControlParameters), INTENT(IN) :: CntrPar
        TYPE(LocalVariables), INTENT(INOUT) :: LocalVar

        ! Body
        LocalVar%WE_VwIdot = CntrPar%WE_Gamma/CntrPar%WE_Jtot*(LocalVar%VS_LastGenTrq*CntrPar%WE_GearboxRatio - AeroDynTorque(LocalVar, CntrPar))

        LocalVar%WE_VwI = LocalVar%WE_VwI + LocalVar%WE_VwIdot*LocalVar%DT
        LocalVar%WE_Vw = LocalVar%WE_VwI + CntrPar%WE_Gamma*LocalVar%RotSpeed

    END SUBROUTINE WindSpeedEstimator
    !-------------------------------------------------------------------------------------------------------------------------------
END MODULE Functions


SUBROUTINE getgrid(myid,Nx,Ny,Nz,Lx,Ly,Lz,pi,name,x,y,z,kx,ky,kz,decomp)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets grid points and fourier frequencies for a
	! pseudospectral simulation of the Brusselator equations
	!
	! u_t = a + u^2v - (b+1)u + Du (u_{xx} + u_{yy} + u_{zz})
    ! v_t = bu - u^2v + Dv (v_{xx} + v_{yy} + v_{zz})
	!
	! The boundary conditions are
	!   u(x=-Lx*pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*pi,z)=u(x,y=Ly*pi,z),
	!   u(x,y,z=-Ly*pi)=u(x,y,z=Ly*pi),
	!   v(x=-Lx*pi,y,z)=v(x=Lx*\pi,y,z),
	!	v(x,y=-Ly*pi,z)=v(x,y=Ly*pi,z),
	!   v(x,y,z=-Ly*pi)=v(x,y,z=Ly*pi),
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Ny				= number of modes in z - power of 2 for FFT
	!  pi				= 3.142....
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  myid				= processor id
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	!
	! OUTPUT
	!
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library
	USE decomp_2d
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: myid,Nx,Ny,Nz
	REAL(kind=8), INTENT(IN)							:: Lx,Ly,Lz,pi
	TYPE(DECOMP_INFO), INTENT(IN)						::  decomp
	REAL(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1)), INTENT(OUT) 	:: x
	REAL(KIND=8), DIMENSION(decomp%xst(2):decomp%xen(2)), INTENT(OUT) 	:: y
	REAL(KIND=8), DIMENSION(decomp%xst(3):decomp%xen(3)), INTENT(OUT) 	:: z
	COMPLEX(KIND=8), DIMENSION(decomp%zst(1):decomp%zen(1)), INTENT(OUT):: kx
	COMPLEX(KIND=8), DIMENSION(decomp%zst(2):decomp%zen(2)), INTENT(OUT):: ky
	COMPLEX(KIND=8), DIMENSION(decomp%zst(3):decomp%zen(3)), INTENT(OUT):: kz
	CHARACTER*100, INTENT(IN)							:: name
	CHARACTER*200                                       :: name_config
	INTEGER(kind=4)										:: i,j,k,ind

	DO i = 1,1+ Nx/2
	 IF ((i.GE.decomp%zst(1)).AND.(i.LE.decomp%zen(1))) THEN
	  kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	 END IF
	END DO
	IF ((Nx/2 + 1 .GE.decomp%zst(1)).AND.(Nx/2 + 1 .LE.decomp%zen(1))) THEN
	 kx( Nx/2 + 1 ) = 0.0d0
	ENDIF
	DO i = Nx/2+2, Nx
	 IF ((i.GE.decomp%zst(1)).AND.(i.LE.decomp%zen(1))) THEN
	  Kx( i) = cmplx(0.0d0,-1.0d0)*REAL(1-i+Nx,KIND(0d0))/Lx
	 ENDIF
	END DO
	DO i=decomp%xst(1),decomp%xen(1)
	 x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	END DO

	DO j = 1,1+ Ny/2
	 IF ((j.GE.decomp%zst(2)).AND.(j.LE.decomp%zen(2))) THEN
	  ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	 END IF
	END DO
	IF ((Ny/2 + 1 .GE.decomp%zst(2)).AND.(Ny/2 + 1 .LE.decomp%zen(2))) THEN
	 ky( Ny/2 + 1 ) = 0.0d0
	ENDIF
	DO j = Ny/2+2, Ny
	 IF ((j.GE.decomp%zst(2)).AND.(j.LE.decomp%zen(2))) THEN
	  ky(j) = cmplx(0.0d0,-1.0d0)*REAL(1-j+Ny,KIND(0d0))/Ly
	 ENDIF
	END DO
	DO j=decomp%xst(2),decomp%xen(2)
	 y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
	END DO

	DO k = 1,1+ Nz/2
	 IF ((k.GE.decomp%zst(3)).AND.(k.LE.decomp%zen(3))) THEN
	  kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
	 END IF
	END DO
	IF ((Nz/2 + 1 .GE.decomp%zst(3)).AND.(Nz/2 + 1 .LE.decomp%zen(3))) THEN
	 kz( Nz/2 + 1 ) = 0.0d0
	ENDIF
	DO k = Nz/2+2, Nz
	 IF ((k.GE.decomp%zst(3)).AND.(k.LE.decomp%zen(3))) THEN
	  kz(k) = cmplx(0.0d0,-1.0d0)*REAL(1-k+Nz,KIND(0d0))/Lz
	 ENDIF
	END DO
	DO k=decomp%xst(3),decomp%xen(3)
	 z(k)=(-1.0d0 + 2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)))*pi*Lz
	END DO

	IF (myid.eq.0) THEN
	 ! Save x grid points in text format
	 ind=index(name,' ') -1
     name_config=name(1:ind)//'xcoord.dat'
	 OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	 REWIND(11)
	 DO i=1,Nx
	  WRITE(11,*) (-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	 END DO
	 CLOSE(11)
	 ! Save y grid points in text format
	 ind=index(name,' ') -1
     name_config=name(1:ind)//'ycoord.dat'
	 OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	 REWIND(11)
	 DO j=1,Ny
	  WRITE(11,*) (-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
	 END DO
	 CLOSE(11)
	 ! Save z grid points in text format
	 ind=index(name,' ') -1
     name_config=name(1:ind)// 'zcoord.dat'
	 OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	 REWIND(11)
	 DO k=1,Nz
	  WRITE(11,*) (-1.0d0 + 2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)))*pi*Lz
	 END DO
	 CLOSE(11)
	END IF

	END SUBROUTINE getgrid


program playground
real :: x, y, result
character :: operation
integer :: valid_operation

valid_operation = 1

print*, "value 1: "
read *, x

print*, "value 2: "
read *, y

print*, "operation: "
read *, operation

if(operation=='+') then
    result = x+y
elseif(operation=='-') then
    result = x-y
elseif(operation=='/') then
    if(y/=0) then
        result = x/y
    else
        result = 0
        valid_operation = 0
    end if
elseif(operation=='*') then
    result = x*y
else
    result = 0
    valid_operation = 0
    print *, "invalid operation"
end if

if(valid_operation/=0) then
    print *, result
end if
end program playground


#include "scalar.fpp"
!=====================================================================!
! Module that contains functions related to spring mass damper system
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module smd_functions_class

  use function_class, only  : abstract_function

  implicit none

  private
  public :: kinetic_energy

  !-------------------------------------------------------------------!
  ! Type that models any physical phenomenon
  !-------------------------------------------------------------------!

  type, extends(abstract_function) :: kinetic_energy

   contains

     procedure :: getFunctionValue
     procedure :: addFuncDVSens
     procedure :: addFuncSVSens
     procedure :: addDFdU
     procedure :: addDFdUDot
     procedure :: addDFdUDDot

  end type kinetic_energy

contains

  !-------------------------------------------------------------------!
  ! Evaluate the kinetic energy for the supplied state and design
  ! variables KE = 0.5 m v^2
  ! -------------------------------------------------------------------!

  pure subroutine getFunctionValue(this, f, time, x, u, udot, uddot)

    class(kinetic_energy), intent(inout)   :: this
    type(scalar), intent(inout)            :: f
    type(scalar), intent(in), dimension(:) :: x, u, udot, uddot
    real(dp), intent(in)                   :: time

    if (size(x) .eq. 3) then
       f = 0.5d0*x(1)*uddot(1)**2 + 0.5d0*x(2)*udot(1)**2 + 0.5d0*x(3)*u(1)**2
    else if (size(x) .eq. 2) then
       f = 0.0d0
    else if (size(x) .eq. 1) then
       !f = uddot(1)**2 + udot(1)**2 + u(1)**2 + x(1)**2 ! Optimal control problem
       f = 0.5d0*udot(1)*udot(1)
    end if
    !f = 0.5d0*x(3)*u(1)**2

  end subroutine getFunctionValue

  !-------------------------------------------------------------------!
  ! Evaluate  dF/dX
  ! -------------------------------------------------------------------!

  subroutine addFuncDVSens(this, res, scale, time, x, u, udot, uddot)

    class(kinetic_energy)                     :: this
    type(scalar), intent(inout), dimension(:) :: res
    type(scalar), intent(in), dimension(:)    :: x, u, udot, uddot
    real(dp), intent(in)                      :: time
    type(scalar)                              :: scale

    if (size(x).eq.3) then
       res(1) = res(1) + scale*0.5d0*uddot(1)**2 ! wrt to m
       res(2) = res(2) + scale*0.5d0*udot(1)**2 ! wrt to c
       res(3) = res(3) + scale*0.5d0*u(1)**2 ! wrt to k
    else if (size(x) .eq. 1) then
!       res(1) = res(1) + scale*2.0d0*x(1)
    end if

  end subroutine addFuncDVSens

  !-------------------------------------------------------------------!
  ! Evaluate alpha dF/dU + beta dF/dUDot + gamma dF/dUDDOT
  ! -------------------------------------------------------------------!

  subroutine addFuncSVSens(this, res, alpha, beta, gamma, &
       & time, x, u, udot, uddot)

    class(kinetic_energy)                     :: this
    type(scalar), intent(inout), dimension(:) :: res
    real(dp), intent(in)                      :: time
    type(scalar), intent(in), dimension(:)    :: x, u, udot, uddot
    type(scalar), intent(in)                  :: alpha, beta, gamma

    if (size(x) .eq. 3) then
       res(1) = res(1) + alpha*x(3)*u(1) + beta*x(2)*udot(1) + gamma*x(1)*uddot(1)
    else if (size(x) .eq. 1) then
       res(1) = res(1) +  beta*udot(1)
    end  if

  end subroutine addFuncSVSens

  !-------------------------------------------------------------------!
  ! Evaluate  dF/dU
  ! -------------------------------------------------------------------!

  subroutine addDfdU(this, res, scale, time, x, u, udot, uddot)

    class(kinetic_energy)                     :: this
    type(scalar), intent(inout), dimension(:) :: res
    real(dp), intent(in)                      :: time
    type(scalar), intent(in), dimension(:)    :: x, u, udot, uddot
    type(scalar)                              :: scale

    if (size(x) .eq. 3) then
       res(1) = res(1) + scale*x(3)*u(1) ! to u(1)
    else if (size(x) .eq. 1) then
       res(1) = res(1) + scale*2.0d0*u(1)
    end if

  end subroutine addDfdU

  !-------------------------------------------------------------------!
  ! Evaluate  dF/dUdot
  ! -------------------------------------------------------------------!

  subroutine addDfdUDot(this, res, scale, time, x, u, udot, uddot)

    class(kinetic_energy)                     :: this
    type(scalar), intent(inout), dimension(:) :: res
    type(scalar), intent(in), dimension(:)    :: x, u, udot, uddot
    real(dp), intent(in)                      :: time
    type(scalar)                              :: scale

    if (size(x) .eq. 3) then
       res(1) = res(1) + scale*x(2)*udot(1) ! wrt to udot(1)
    else if (size(x) .eq. 1) then
       res(1) = res(1) + scale*2.0d0*udot(1)
    end if

  end subroutine addDFdUDot

  !-------------------------------------------------------------------!
  ! Evaluate  dF/dUDDot
  ! -------------------------------------------------------------------!

  subroutine addDfdUDDot(this, res, scale, time, x, u, udot, uddot)

    class(kinetic_energy)                     :: this
    type(scalar), intent(inout), dimension(:) :: res
    type(scalar), intent(in), dimension(:)    :: x, u, udot, uddot
    real(dp), intent(in)                      :: time
    type(scalar)                              :: scale

    if (size(x) .eq. 3) then
       res(1) = res(1) + scale*x(1)*uddot(1) ! wrt to uddot(1)
    else if (size(x) .eq. 1) then
       res(1) = res(1) + scale*2.0d0*uddot(1)
    end if

  end subroutine addDfdUDDot

end module smd_functions_class


PROGRAM test_shape
!
!  This program tests polymorphism using the shape class
!  and its subclasses.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
USE circle_class                 ! Import circle class
USE square_class                 ! Import square class
USE rectangle_class              ! Import rectangle class
USE triangle_class               ! Import triangle class
USE pentagon_class               ! Import pentagon class
IMPLICIT NONE

! Declare variables
TYPE(circle),POINTER :: cir      ! Circle object
TYPE(square),POINTER :: squ      ! Square object
TYPE(rectangle),POINTER :: rec   ! Rectangle object
TYPE(triangle),POINTER :: tri    ! Triangle object
TYPE(pentagon),POINTER :: pen    ! Pentagon object
INTEGER :: i                     ! Loop index
CHARACTER(len=50) :: id_string   ! ID string
INTEGER :: istat                 ! Allocate status

! Create an array of shape pointers
TYPE :: shape_ptr
   CLASS(shape),POINTER :: p     ! Pointer to shapes
END TYPE shape_ptr
TYPE(shape_ptr),DIMENSION(5) :: shapes

! Create and initialize circle
ALLOCATE( cir, STAT=istat )
CALL cir%initialize(2.0)

! Create and initialize square
ALLOCATE( squ, STAT=istat )
CALL squ%initialize(2.0,2.0)

! Create and initialize rectangle
ALLOCATE( rec, STAT=istat )
CALL rec%initialize(2.0,1.0)

! Create and initialize triangle
ALLOCATE( tri, STAT=istat )
CALL tri%initialize(2.0)

! Create and initialize pentagon
ALLOCATE( pen, STAT=istat )
CALL pen%initialize(2.0)

! Create the array of shape pointers
shapes(1)%p => cir
shapes(2)%p => squ
shapes(3)%p => rec
shapes(4)%p => tri
shapes(5)%p => pen

! Now display the results using the array of
! shape pointers.
DO i = 1, 5

    ! Get ID string
    id_string = shapes(i)%p%to_string()
    WRITE (*,'(/A)') id_string

    ! Get the area and perimeter
    WRITE (*,'(A,F8.4)') 'Area      = ', shapes(i)%p%area()
    WRITE (*,'(A,F8.4)') 'Perimeter = ', shapes(i)%p%perimeter()
END DO

END PROGRAM test_shape


module problem_description

    implicit none
    real(kind=8), parameter :: ax = 0.0d0
    real(kind=8), parameter :: bx = 1.0d0
    real(kind=8), parameter :: ay = 0.4d0
    real(kind=8), parameter :: by = 1.0d0
    integer, parameter :: nx = 19
    integer, parameter :: ny = 11
    real(kind=8), parameter :: dx = (bx - ax) / (nx+1)
    real(kind=8), parameter :: dy = (by - ay) / (ny+1)

contains

function utrue(x, y)

    ! True solution for comparison, if known.

    implicit none
    real(kind=8), intent(in) :: x,y
    real(kind=8) :: utrue

    utrue = x**2 - y**2

end function utrue

function uboundary(x, y)

    ! Return u(x,y) assuming (x,y) is a boundary point.

    implicit none
    real(kind=8), intent(in) :: x,y
    real(kind=8) :: uboundary

    if ((x-ax)*(x-bx)*(y-ay)*(y-by) .ne. 0.d0) then
        print *, "*** Error -- called uboundary at non-boundary point"
        stop
        endif

    uboundary = utrue(x,y)   ! assuming we know this

end function uboundary

end module problem_description