! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> This module contains routines and functions
!> to construct various masks used in the simulation
!> of the absorbing boundaries used in the FEL
!> simulation code Puffin.
!>
!> A useful reference for the boundaries employed
!> here is REF.

MODULE masks

USE paratype
USE typesAndConstants
USE Functions

IMPLICIT NONE

CONTAINS

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Construct the mask for use in the absorption
!> step. This outputs a 2D mask (in the transverse
!> plane) in a 1D array.
!> @param[in] nX Number of nodes in mesh in x
!> @param[in] nY Number of nodes in mesh in y
!> @param[in] dx Distance between nodes in mesh in x
!> @param[in] dy Distance between nodes in mesh in y
!> @param[in] nbx Number of nodes to be used for mask in x
!> @param[in] nby Number of nodes to be used for mask in y
!> @param[out] Transverse 'mask', defining the boundaries to slow the
!> diffraction in.

SUBROUTINE getMask(nX,nY,dx,dy,nbx,nby,mask)

!
!                ARGUMENTS

  INTEGER(KIND=IP), INTENT(IN) :: nX,nY,nbx,nby
  REAL(KIND=WP), INTENT(IN) :: dx,dy

  REAL(KIND=WP), INTENT(OUT) :: mask(nX*nY)

!                LOCAL ARGS

  REAL(KIND=WP) :: lenx, leny
  REAL(KIND=WP) :: x(nx), y(ny), maskt(nx,ny)

!                  Begin

  lenx  = (nX-1) * dx
  leny  = (nY-1) * dy

  x  = linspace(-lenx/2,lenx/2,nx)
  y  = linspace(-leny/2,leny/2,ny)

  maskt = Mask2D(x,y,dx,dy,nX,nY,nbx,nby)

  !IF (tProcInfo_G%qRoot) PRINT*, maskt(32,:)

  mask = RESHAPE( maskt, (/ nx*ny /))

  !IF (tProcInfo_G%qRoot) PRINT*, '  '

!  IF (tProcInfo_G%qRoot) PRINT*, mask

END SUBROUTINE getMask

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

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> This function calculates a simple 1D mask
!> to define the absorbing boundary in Puffin.
!> @param[in] x (1D array) Coordinates of nodes
!> @param[in] dx Distance between nodes in mesh
!> @param[in] nx Number of nodes in mesh
!> @param[in] nb Number of nodes to be used for mask in x

FUNCTION Mask1D(x,dx,nx,nb)

  REAL(KIND=WP), INTENT(IN) :: x(:), dx
  INTEGER(KIND=IP), INTENT(IN) :: nb, nx
  REAL(KIND=WP) :: Mask1D(nx)

  REAL(KIND=WP) :: Lb, x0

!     Get the length of the boundary, Lb

  Lb = (nb-1) * dx

!     Get the center if of the boundary, x0

  x0 = x(nx) - Lb/2.0_WP

!     Mask initialized as a cos^2 at each end

  Mask1D(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x0) / Lb) ** 2.0_WP

  Mask1D(1_IP:nb) = cos(pi * (x(1_IP:nb) + x0) / Lb) ** 2.0_WP

  Mask1D( nb + 1_IP : nx-nb ) = 0.0_WP   !   Should now have 1D mask

END FUNCTION Mask1D

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

FUNCTION Mask2D(x,y,dx,dy,nx,ny,nbx,nby)

! This function constructs the 2D mask to be applied
! to the absorbing boundary of the radiation field nodes
! in the transverse plane. The mask should decrease from
! unity at the center of the transverse boundaries
! to zero at the edges of the boundary. Here, a cos^2
! function peaked at the center of the boundary is used.
!
!                ARGUMENTS
!
!    x, y             Coordinates of each node in x and y (1D)
!
!    nx, ny           Num of nodes in x and y
!
!    nbx, nby         Num of nodes to be used in the transverse
!                     boundary
!
!    Mask2D           The 2D mask

  REAL(KIND=WP), INTENT(IN) :: x(:), y(:), dx, dy
  INTEGER(KIND=IP), INTENT(IN) :: nbx, nby
  INTEGER(KIND=IP), INTENT(IN) :: nx ,ny
  REAL(KIND=WP) :: Mask2D(nx,ny)

  REAL(KIND=WP) :: maskx(nx), masky(ny), maskx2(nx), masky2(ny)
  INTEGER(KIND=IP) :: ix, iy

!     Mask1D for x and y

  maskx = Mask1D2(x,dx,nx,nbx)
  masky = Mask1D2(y,dy,ny,nby)

! IF (tProcInfo_G%qRoot) PRINT*, masky

!     Maskf1 for y

  masky2 = Maskf3(y,dy,ny,nby)

!     maskf2 for x

  maskx2 = Maskf4(x,dx,nx,nbx)

!     Combine in some cunning way

  DO iy = 1,ny
  	DO ix = 1,nx

  	  Mask2D(ix,iy) = masky2(iy)*maskx(ix) + maskx2(ix)*masky(iy)

    END DO
  END DO

END FUNCTION Mask2D

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

FUNCTION Maskf1(x,dx,nx,nb)

! Constructs a prticular kind of mask, more
! an envelope for the mask which is eventually used.
!
!               ARGUMENTS:-

  REAL(KIND=WP), INTENT(IN) :: x(:), dx
  INTEGER(KIND=IP), INTENT(IN) :: nb,nx

  REAL(KIND=WP) :: Maskf1(nx)

  REAL(KIND=WP) :: Lb, x0

!     Get the length of the boundary, Lb

  Lb = (nb-1) * dx

!     Get the center if of the boundary, x0

  x0 = x(nx) - Lb/2.0_WP

!     Mask initialized as a cos^2 at each end

  Maskf1(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x0) / Lb) ** 2.0_WP

  Maskf1(1_IP:nb) = cos(pi * (x(1_IP:nb) + x0) / Lb) ** 2.0_WP

  Maskf1( nb/2 + 1_IP : nx - nb/2 ) = 1.0_WP   !   Should now have mask type 1

END FUNCTION Maskf1

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

FUNCTION Maskf2(x,dx,nx,nb)

! Constructs a prticular kind of mask, more
! an envelope for the mask which is eventually used.
!
!               ARGUMENTS:-

  REAL(KIND=WP), INTENT(IN) :: x(:), dx
  INTEGER(KIND=IP), INTENT(IN) :: nb,nx

  REAL(KIND=WP) :: Maskf2(nx)

  REAL(KIND=WP) :: Lb, x0

!     Get the length of the boundary, Lb

  Lb = (nb-1) * dx

!     Get the center if of the boundary, x0

  x0 = x(nx) - Lb/2.0_WP

!     Mask initialized as a cos^2 at each end

  Maskf2(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x0) / Lb + pi/2.0_WP) ** 2.0_WP
  Maskf2(1_IP:nb) = cos(pi * (x(1_IP:nb) + x0) / Lb + pi/2.0_WP) ** 2.0_WP

  Maskf2( 1_IP : nb/2 ) = 0.0_WP
  Maskf2(nx - nb/2 + 1_IP : nx) = 0.0_WP
  Maskf2( nb + 1_IP : nx-nb ) = 1.0_WP   !   Should now have mask type 2

END FUNCTION Maskf2

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

FUNCTION Mask1D2(x,dx,nx,nb)

! This function calculates a simple 1D mask
! to define the absoribing boundary in Puffin.
!
!                Author:
!            Lawrence Campbell
!       University of Hamburg / DESY
!                  2013
!

  REAL(KIND=WP), INTENT(IN) :: x(:), dx
  INTEGER(KIND=IP), INTENT(IN) :: nb, nx
  REAL(KIND=WP) :: Mask1D2(nx)

  REAL(KIND=WP) :: Lb, x0, x01, x02

!     Get the length of the boundary, Lb

  Lb = (nb-1) * dx

!     Get the center if of the boundary, x0

!  x0 = x(nx) - Lb/2.0_WP
   x01 = x(nx)
   x02 = x(1)

!     Mask initialized as a cos^2 at each end

  Mask1D2(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x01) / (2.0_WP * Lb)) ** 2.0_WP

  Mask1D2(1_IP:nb) = cos(pi * (x(1_IP:nb) - x02) / (2.0_WP * Lb)) ** 2.0_WP

  Mask1D2( nb + 1_IP : nx-nb ) = 0.0_WP   !   Should now have 1D mask

END FUNCTION Mask1D2

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

FUNCTION Maskf3(x,dx,nx,nb)

! Constructs a prticular kind of mask, more
! an envelope for the mask which is eventually used.
!
!               ARGUMENTS:-

  REAL(KIND=WP), INTENT(IN) :: x(:), dx
  INTEGER(KIND=IP), INTENT(IN) :: nb,nx

  REAL(KIND=WP) :: Maskf3(nx)

!     Mask initialized as unity everywhere

  Maskf3(:) = 1.0_WP

END FUNCTION Maskf3

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

FUNCTION Maskf4(x,dx,nx,nb)

! Constructs a prticular kind of mask, more
! an envelope for the mask which is eventually used.
!
!               ARGUMENTS:-

  REAL(KIND=WP), INTENT(IN) :: x(:), dx
  INTEGER(KIND=IP), INTENT(IN) :: nb,nx

  REAL(KIND=WP) :: Maskf4(nx)

  REAL(KIND=WP) :: Lb, x01, x02

!     Get the length of the boundary, Lb

  Lb = (nb-1) * dx

!     Get the center if of the boundary, x0

  x01 = x(nx - nb + 1_IP)
  x02 = x(nb)

!     Mask initialized as a cos^2 at each end

  Maskf4(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x01) / (2.0_WP * Lb)) ** 2.0_WP
  Maskf4(1_IP:nb) = cos(pi * (x(1_IP:nb) - x02) / (2.0_WP * Lb)) ** 2.0_WP

  Maskf4( nb + 1_IP : nx-nb ) = 1.0_WP   !   Should now have mask type 2

END FUNCTION Maskf4

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

FUNCTION getZ2Mask(dx,nx,loc_nx,nb,loc_start)

! This function calculates a simple 1D mask
! to define the absoribing boundary in Puffin.
!
! This particular function should only be used
! in the z2 direction, and uses the parallelism
! as dictated by the fftw 2.1.5 functions.
!
!                Author:
!            Lawrence Campbell
!       University of Hamburg / DESY
!                  2013
!

  REAL(KIND=WP), INTENT(IN) :: dx
  INTEGER(KIND=IP), INTENT(IN) :: nb, nx, loc_nx, loc_start
  REAL(KIND=WP) :: getZ2Mask(loc_nx)

  REAL(KIND=WP) :: Lb, x0, Lf, fbn, x(loc_nx)
  integer(kind=ip) :: ind

  x = linspace(real(loc_start,kind=wp) * dx, &
          real(loc_start+loc_nx-1,kind=wp) * dx, &
                   loc_nx) ! Values in space

  !x = (/loc_start:loc_start+loc_nx-1:1/) * dx  ! Values in space

!     Get the length of the boundary, Lb

  Lb = (nb-1) * dx

!     Get total length of modelled field domain (in z2)

  Lf = (nx-1*dx)

!     Get the center if of the boundary, x0

  x0 = Lf - Lb/2.0_WP

  fbn = nx - nb + 1 ! 1st boundary node

!     Mask initialized as a cos^2 at one end

  getZ2Mask(1:loc_nx) = 0.0_WP   !   Init all to zero

!    getZ2Mask(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x0) / Lb) ** 2.0_WP
  do ind = 1,loc_nx

    if (  loc_start + ind >= fbn ) getZ2Mask(ind) = cos(pi * (x(ind)-x0) / Lb) ** 2.0_WP

  end do

  !getZ2Mask(nx-nb+1_IP:nx) = cos(pi * (x(nx-nb+1_IP:nx)-x0) / Lb) ** 2.0_WP

  !getZ2Mask(1_IP:nb) = cos(pi * (x(1_IP:nb) + x0) / Lb) ** 2.0_WP

END FUNCTION getZ2Mask

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

END MODULE masks


! ( Last modified on 21 Dec 2000 at 23:46:51 )

!-*-*-*-*-*-*-*-*-*-*-*-  VE12_main  *-*-*-*-*-*-*-*-*-*-*-*-*-*

!  Nick Gould
!  Copyright reserved
!  June 12th 1995

PROGRAM VE12_main

  !  Main program for HSL_VE12, an algorithm to solve quadratic programs
  !  using a primal-dual interior-point trust-region iteration

  USE CUTEr_interfaces
  USE READ_input
!S    USE HSL_VE12_single
!D    USE HSL_VE12_double

  IMPLICIT NONE

  !  --------------------------------------------------------------------
  !  Solve the quadratic program
  !
  !     minimize     1/2 x(T) H x + g(T) x
  !
  !     subject to     c_l <= A x <= c_u
  !                    x_l <=  x <= x_u
  !
  !  using VE12
  !
  !  --------------------------------------------------------------------

  !  Parameters

  INTEGER, PARAMETER :: out  = 6
  INTEGER, PARAMETER :: input = 55, inputd = 33
  REAL ( KIND = wp ), PARAMETER :: zero = 0.0_wp
  REAL ( KIND = wp ), PARAMETER :: one = 1.0_wp
  REAL ( KIND = wp ), PARAMETER :: ten = 10.0_wp

  !  Scalars

  INTEGER :: n, m, ir, ic, nmax, mmax, la, lh, liw
  INTEGER :: i, j, l, neh, nea, factorization_integer, factorization_real
  INTEGER :: status, mfixed, mdegen, iter, nfacts, nfixed, ndegen, mequal
  INTEGER :: alloc_stat, A_ne, H_ne
  REAL :: CPU( 2 ), CALLS( 7 )
  REAL :: time, timeo, times, timet
  REAL ( KIND = wp ) :: objf, qfval, qfvalt, stopr
  LOGICAL :: fulsol

  CHARACTER ( LEN =  5 ) :: state, solv
  CHARACTER ( LEN = 10 ) :: pname

  !  Arrays

  TYPE ( VE12_data_type ) :: data
  TYPE ( VE12_control_type ) :: VE12_control
  TYPE ( VE12_inform_type ) :: VE12_inform
  TYPE ( ZD02_problem_type ) :: prob

  !  Allocatable arrays

  CHARACTER ( LEN = 10 ), ALLOCATABLE, DIMENSION( : ) :: VNAME, CNAME
  REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: X0, C
  LOGICAL, ALLOCATABLE, DIMENSION( : ) :: EQUATN, LINEAR
  INTEGER, ALLOCATABLE, DIMENSION( : ) :: IW

  !  Open the relevant file.

  OPEN( input, FILE = 'OUTSDIF.d', FORM = 'FORMATTED', STATUS = 'OLD'  )
  REWIND input

  CALL CPU_TIME( time )

  !  Determine the number of variables and constraints

  CALL CDIMEN( input, nmax, mmax )
  nmax = MAX( nmax, 1 ) ; mmax = MAX( mmax, 1 ) ! for fortran 77 CUTEr tools

  !  Allocate suitable arrays

  ALLOCATE( prob%X( nmax ), prob%X_l( nmax ), prob%X_u( nmax ),            &
       prob%G( nmax ), VNAME( nmax ), STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'X', alloc_stat ; STOP
  END IF

  ALLOCATE( prob%C_l( mmax ), prob%C_u( mmax ), prob%Y( mmax ), &
       CNAME( mmax ), EQUATN( mmax ), LINEAR( mmax ),                 &
       STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'C', alloc_stat ; STOP
  END IF

  !  Set up the data structures necessary to hold the group partially
  !  separable function.

  CALL CSETUP( input, out, n, m, prob%X, prob%X_l, prob%X_u, nmax, EQUATN, &
       LINEAR, prob%Y, prob%C_l, prob%C_u, mmax, .FALSE.,          &
       .FALSE., .FALSE. )

  DEALLOCATE( LINEAR )

  !  Allocate derived types

  ALLOCATE( X0( n ), STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'X0', alloc_stat
     STOP
  END IF

  ALLOCATE( prob%C( m ), C( m ), STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'C', alloc_stat
     STOP
  END IF

  !  Determine the names of the problem, variables and constraints.

  CALL CNAMES( n, m, pname, VNAME, CNAME )
  WRITE( out, 2020 ) pname
  WRITE( out, "( /, ' n   = ', i8, ' nmax = ', i8,                         &
       & ' m    = ', i8, ' mmax = ', i8 )" ) n, nmax, m, mmax

  !  Set up the initial estimate of the solution and
  !  right-hand-side of the Kuhn-Tucker system.

  !  Determine the constant terms for the problem functions.

  prob%X( : n ) = MIN( prob%X_u( : n ),                                    &
       MAX( prob%X_l( : n ), prob%X( : n ) ) )

  !  Set X0 to zero to determine the constant terms for the problem functions

  X0 = zero

  !  Evaluate the constant terms of the objective (objf) and constraint
  !  functions (C)

  CALL CFN( n, m, X0, objf, m, C( : m ) )
  DO i = 1, m
     IF ( EQUATN( i ) ) THEN
        prob%C_l( i ) = prob%C_l( i ) - C( i )
        prob%C_u( i ) = prob%C_l( i )
     ELSE
        prob%C_l( i ) = prob%C_l( i ) - C( i )
        prob%C_u( i ) = prob%C_u( i ) - C( i )
     END IF
  END DO

  !  Determine the number of nonzeros in the Jacobian

  CALL CDIMSJ( la ) ; la = MAX( la, 1 )

  !  Allocate arrays to hold the Jacobian

  ALLOCATE( prob%A_row( la ), prob%A_col( la ), prob%A_val( la ),          &
       STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'A', alloc_stat ; STOP
  END IF

  !  Evaluate the linear terms of the constraint functions

  CALL CSGR( n, m, .FALSE., mmax, prob%Y, X0, nea, la, prob%A_val,         &
       prob%A_col, prob%A_row )
  WRITE( out, "( ' nea = ', i8, ' la   = ', i8 )", ADVANCE = 'no' ) &
       nea, la

  DEALLOCATE( X0 )

  !  Exclude zeros; set the linear term for the objective function

  A_ne = 0
  prob%G( : n ) = zero
  DO i = 1, nea
     IF ( prob%A_val( i ) /= zero ) THEN
        IF ( prob%A_row( i ) > 0 ) THEN
           A_ne = A_ne + 1
           prob%A_row( A_ne ) = prob%A_row( i )
           prob%A_col( A_ne ) = prob%A_col( i )
           prob%A_val( A_ne ) = prob%A_val( i )
        ELSE
           prob%G( prob%A_col( i ) ) = prob%A_val( i )
        END IF
     END IF
  END DO

  !  Determine the number of nonzeros in the Hessian

  CALL CDIMSH( lh ) ; lh = MAX( lh, 1 )

  !  Allocate arrays to hold the Hessian

  ALLOCATE( prob%H_row( lh ), prob%H_col( lh ), prob%H_val( lh ),          &
       STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'H', alloc_stat
     STOP
  END IF

  !  Evaluate the Hessian of the Lagrangian function at the initial point.

  CALL CSH( n, m, prob%X, mmax, prob%Y, neh, lh, prob%H_val, prob%H_row,   &
       prob%H_col )
  WRITE( out, "( ' neh  = ', i8, ' lh   = ', i8 )" ) neh, lh

  !  Remove Hessian out of range

  H_ne = 0
  DO l = 1, neh
     i = prob%H_row( l ) ; j = prob%H_col( l )
     IF ( i < 1 .OR. i > n .OR. j < 1 .OR. j > n ) CYCLE
     H_ne = H_ne + 1 ; prob%H_val( H_ne ) = prob%H_val( l )
     IF ( i >= j ) THEN
        prob%H_row( H_ne ) = i
        prob%H_col( H_ne ) = j
     ELSE
        prob%H_row( H_ne ) = j
        prob%H_col( H_ne ) = i
     END IF
  END DO

  !  Allocate and initialize dual variables.

  ALLOCATE( prob%Z( nmax ), STAT = alloc_stat )
  IF ( alloc_stat /= 0 ) THEN
     WRITE( out, 2150 ) 'Z', alloc_stat
     STOP
  END IF
  prob%Z( : n ) = one

  liw = MAX( m, n ) + 1
  ALLOCATE( prob%A_ptr( m + 1 ), prob%H_ptr( n + 1 ) )
  ALLOCATE( IW( liw ) )

  !  Transform A to row storage format

  IF ( A_ne /= 0 ) THEN
     CALL REORDER_by_rows( m, n, A_ne, prob%A_row, prob%A_col, A_ne,       &
          prob%A_val, prob%A_ptr, m + 1, IW, liw, i )
  ELSE
     prob%A_ptr = 0
  END IF

  !  Same for H

  IF ( H_ne /= 0 ) THEN
     CALL REORDER_by_rows( n, n, H_ne, prob%H_row, prob%H_col, H_ne,        &
          prob%H_val, prob%H_ptr, n + 1, IW, liw, i )
  ELSE
     prob%H_ptr = 0
  END IF

  !  Deallocate arrays holding matrix row indices

  DEALLOCATE( prob%A_row, prob%H_row )
  DEALLOCATE( IW )
  ALLOCATE( prob%A_row( 0 ), prob%H_row( 0 ) )

  prob%new_problem_structure = .TRUE.

  !  Store the problem dimensions

  prob%n = n
  prob%m = m
  prob%a_ne = - 1
  prob%h_ne = - 1
  prob%f = objf

  !  ------------------- problem set-up complete ----------------------

  CALL CPU_TIME( times )

  !  Open the spec file

  OPEN( inputd, FILE = 'VE12.SPC', FORM = 'FORMATTED', STATUS = 'OLD' )
  REWIND inputd

  !  Update control parameters if required.

  CALL VE12_initialize( data, VE12_control )

  CALL OVERIDE_control( VE12_control%infinity, inputd )
  CALL OVERIDE_control( VE12_control%stop_p , inputd )
  CALL OVERIDE_control( VE12_control%stop_d , inputd )
  CALL OVERIDE_control( VE12_control%stop_c , inputd )
  CALL OVERIDE_control( VE12_control%prfeas, inputd )
  CALL OVERIDE_control( VE12_control%dufeas, inputd )
  CALL OVERIDE_control( VE12_control%muzero, inputd )
  CALL OVERIDE_control( VE12_control%inner_stop_absolute, inputd )
  CALL OVERIDE_control( VE12_control%inner_stop_relative, inputd )
  CALL OVERIDE_control( VE12_control%inner_fraction_opt, inputd )
  CALL OVERIDE_control( VE12_control%pivot_tol, inputd )
  CALL OVERIDE_control( VE12_control%pivot_tol_for_dependencies, inputd )
  CALL OVERIDE_control( VE12_control%initial_radius, inputd )
  CALL OVERIDE_control( VE12_control%VE13_control%reduce_infeas, inputd )

  CALL OVERIDE_control( VE12_control%maxit, inputd )
  CALL OVERIDE_control( VE12_control%print_level, inputd )
  CALL OVERIDE_control( VE12_control%out, inputd )
  CALL OVERIDE_control( VE12_control%error, inputd )
  CALL OVERIDE_control( VE12_control%itrmax, inputd )
  CALL OVERIDE_control( VE12_control%cg_maxit, inputd )
  CALL OVERIDE_control( VE12_control%factor, inputd )
  CALL OVERIDE_control( VE12_control%max_col, inputd )
  CALL OVERIDE_control( VE12_control%precon, inputd )
  CALL OVERIDE_control( VE12_control%nsemib, inputd )
  CALL OVERIDE_control( VE12_control%indmin, inputd )
  CALL OVERIDE_control( VE12_control%valmin, inputd )
  CALL OVERIDE_control( VE12_control%VE13_control%infeas_max, inputd )

  CALL OVERIDE_control( VE12_control%feasol, inputd )
  CALL OVERIDE_control( fulsol, inputd )
  CALL OVERIDE_control( VE12_control%primal, inputd )
  CALL OVERIDE_control( VE12_control%center, inputd )

  VE12_control%restore_problem = 1

  CLOSE( inputd )

  !  Call the optimizer

  qfval = objf

  CALL CPU_TIME( timeo )

  prob%m = m
  prob%n = n

  solv = ' VE12'
  CALL VE12_solve( prob, data, VE12_control, VE12_inform )
  qfval = VE12_inform%obj

  CALL CREPRT( CALLS, CPU )
  CALL CPU_TIME( timet )

  !  Deallocate arrays from the minimization

  status = VE12_inform%status ; iter = VE12_inform%iter
  nfacts = VE12_inform%nfacts ; stopr = VE12_control%stop_d
  factorization_integer = VE12_inform%factorization_integer
  factorization_real = VE12_inform%factorization_real
  CALL VE12_terminate( data, VE12_control, VE12_inform )

  !  Print details of the solution obtained

  WRITE( out, 2010 ) status
  IF ( status >= 0 .AND. status <= 5 ) THEN
     l = 4 ; IF ( fulsol ) l = n

     !  Print details of the primal and dual variables

     WRITE( out, 2090 )
     DO j = 1, 2
        IF ( j == 1 ) THEN
           ir = 1 ; ic = MIN( l, n )
        ELSE
           IF ( ic < n - l ) WRITE( out, 2000 )
           ir = MAX( ic + 1, n - ic + 1 ) ; ic = n
        END IF
        DO i = ir, ic
           state = ' FREE'
           IF ( ABS( prob%X  ( i ) - prob%X_l( i ) ) < ten * stopr )          &
                state = 'LOWER'
           IF ( ABS( prob%X  ( i ) - prob%X_u( i ) ) < ten * stopr )          &
                state = 'UPPER'
           IF ( ABS( prob%X_l( i ) - prob%X_u( i ) ) <     1.0D-10 )          &
                state = 'FIXED'
           WRITE( out, 2050 ) VNAME( i ), state, prob%X( i ),                 &
                prob%X_l( i ), prob%X_u( i ), prob%Z( i )
        END DO
     END DO

     !  Compute the number of fixed and degenerate variables.

     nfixed = 0 ; ndegen = 0
     DO i = 1, n
        IF ( ABS( prob%X( i ) - prob%X_l( i ) ) < stopr ) THEN
           nfixed = nfixed + 1
           IF ( ABS( prob%Z( i ) ) < ten * stopr ) ndegen = ndegen + 1
        ELSE IF ( ABS( prob%X( i ) - prob%X_u( i ) ) < ten * stopr ) THEN
           nfixed = nfixed + 1
           IF ( ABS( prob%Z( i ) ) < ten * stopr ) ndegen = ndegen + 1
        END IF
     END DO

     !  Print details of the constraints.

     IF ( m > 0 ) THEN

        WRITE( out, 2040 )
        l = 2  ; IF ( fulsol ) l = m
        DO j = 1, 2
           IF ( j == 1 ) THEN
              ir = 1 ; ic = MIN( l, m )
           ELSE
              IF ( ic < m - l ) WRITE( out, 2000 )
              ir = MAX( ic + 1, m - ic + 1 ) ; ic = m
           END IF
           DO i = ir, ic
              state = ' FREE'
              IF ( ABS( prob%C( I )   - prob%C_l( i ) ) < ten * stopr )        &
                   state = 'LOWER'
              IF ( ABS( prob%C( I )   - prob%C_u( i ) ) < ten * stopr )        &
                   state = 'UPPER'
              IF ( ABS( prob%C_l( i ) - prob%C_u( i ) ) <       stopr )        &
                   state = 'EQUAL'
              WRITE( out, 2130 ) CNAME( i ), STATE, prob%C( i ),               &
                   prob%C_l( i ), prob%C_u( i ), prob%Y( i )
           END DO
        END DO

        !  Compute the number of equality, fixed inequality and degenerate constraints

        mequal = 0 ; mfixed = 0 ; mdegen = 0
        DO i = 1, m
           IF ( ABS( prob%C( i ) - prob%C_l( i ) ) < ten * stopr .OR.         &
                ABS( prob%C( i ) - prob%C_u( i ) ) < ten * stopr ) THEN
              IF ( ABS( prob%C_l( i ) - prob%C_u( i ) ) < ten * stopr ) THEN
                 mequal = mequal + 1
              ELSE
                 mfixed = mfixed + 1
              END IF
              IF ( ABS( prob%Y( i ) ) < stopr ) mdegen = mdegen + 1
           END IF
        END DO
     END IF
     WRITE( out, 2100 ) n, nfixed, ndegen
     IF ( m > 0 ) THEN
        WRITE( out, 2110 ) m, mequal, mdegen
        IF ( m /= mequal ) WRITE( out, 2120 ) mfixed
     END IF
     WRITE( out, 2030 ) qfval, iter, nfacts, factorization_integer,         &
          factorization_real
  END IF

  times = times - time ; timet = timet - timeo
  WRITE( out, 2060 ) times + timet
  qfvalt = qfval
  WRITE( out, 2070 ) pname

  !  Compare the variants used so far

  WRITE( out, 2080 ) solv, iter, nfacts, qfvalt, status, times, timet,     &
       times + timet

  DEALLOCATE( VNAME, CNAME, C )
  CLOSE( input  )

  WRITE ( out, 3000 ) pname, n, m, status, qfval, CPU( 1 ), CPU( 2 )

  STOP

  !  Non-executable statements

2000 FORMAT( ' .          .....  ..........',                                &
          '  ..........  ..........  .......... ' )
2010 FORMAT( /,' Stopping with inform%status = ', I3, / )
2020 FORMAT( /, ' Problem: ', A10 )
2030 FORMAT( /,' Final objective function value ', ES22.14, /,               &
          ' Total number of iterations = ',I6,' Number of factorizations = ', &
          I6, //, I10, ' integer and ', I10, ' real words required',          &
          ' for the factorization' )
2040 FORMAT( /,' Constraints : ', //, ' name       state    value  ',        &
          '  Lower bound Upper bound  Multiplier ' )
2050 FORMAT( 1X, A10, A6, 4ES12.4 )
2060 FORMAT( /, ' Total time = ', 0P, F12.2 )
2070 FORMAT( /, ' Problem: ', A10, //,                                       &
          '                                 objective',                   &
          '          < ------ time ----- > ', /,                          &
          ' Method  iterations   factors      value  ',                   &
          '   status setup    VE12   total', /,                           &
          ' ------  ----------   -------    ---------',                   &
          '   ------ -----    ----   -----  ' )
2080 FORMAT( A5, 2I10, 6X, ES12.4, I6, 0P, 3F8.2 )
2090 FORMAT( /,' Solution : ', //,'                              ',          &
          ' <------ Bounds ------> ', /           &
          ' name       state     value   ',                             &
          '    Lower       Upper      Dual ' )
2100 FORMAT( /, ' Of the ', I6, ' variables, ', 2X, I6,                      &
          ' are on bounds, and ', I6, ' are dual degenerate' )
2110 FORMAT( ' Of the ',I6,' constraints, ',I6,' are equations, and ',I6,    &
          ' are degenerate' )
2120 FORMAT( ' Of the inequality constraints ', I6, ' are on bounds' )
2130 FORMAT( 1X, A10, A6, 4ES12.4 )
2150 FORMAT( ' Allocation error, variable ', A8, ' status = ', I6 )
2160 FORMAT( ' IOSTAT = ', I6, ' when opening file ', A9, '. Stopping ' )
2180 FORMAT( A10 )
2190 FORMAT( A10, 2I7, 3I6, ES13.4, I6, 0P, F8.2 )
3000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //                    &
          ,' Code used               :  VE12',    /                           &
          ,' Problem                 :  ', A10,    /                          &
          ,' # variables             =      ', I10 /                          &
          ,' # constraints           =      ', I10 /                          &
          ' Exit code               =      ', I10 /                          &
          ,' Final f                 = ', E15.7 /                             &
          ,' Set up time             =      ', 0P, F10.2, ' seconds' /        &
          ' Solve time              =      ', 0P, F10.2, ' seconds' //       &
          66('*') / )

CONTAINS

  SUBROUTINE REORDER_by_rows( nr, nc, nnz, A_row, A_col, la, A_val,      &
       A_ptr, lptr, IW, liw, iflag )

    !  Reorder a sparse matrix from arbitary coordinate order to row order

    !  Dummy arguments

    INTEGER, INTENT( IN ) :: nr, nc, nnz, la, lptr, liw
    INTEGER, INTENT( OUT ) :: iflag
    REAL ( KIND = wp ), INTENT( INOUT ), DIMENSION( la ) :: A_val
    INTEGER, INTENT( INOUT ), DIMENSION( nnz ) :: A_row, A_col
    INTEGER, INTENT( OUT ), DIMENSION( lptr ) :: A_ptr
    INTEGER, INTENT( OUT ), DIMENSION( liw ) :: IW

    !  Local variables

    INTEGER :: i, j, k, k1, k2, l, nzi, ie, iep, je, jep
    INTEGER :: loc, idup, iout, jout, nzout
    INTEGER :: lp = 6, mp = 6
    REAL ( KIND = wp ) :: ae, aep
    SAVE lp, mp

    ! Initialize data

    iflag = 0
    nzout = 0 ; iout = 0 ; jout = 0 ; idup = 0

    !  Check for faulty input data

    IF ( nr < 1 .OR. nc < 1 .OR. nnz < 1 ) THEN
       iflag = - 1
       IF ( LP > 0 ) THEN
          WRITE( lp, 2000 ) iflag
          WRITE( lp, "( 1X, ' nr, nc, or nnz is out of range', /, &
               &           ' nc = ',I6,' nr = ',I6,' nnz = ', I10 )" ) nr, nc, nnz
       END IF
       RETURN
    END IF

    IF ( la < nnz ) THEN
       iflag = - 2
       IF ( lp > 0 ) THEN
          WRITE( lp, 2000 ) iflag
          WRITE( lp, "( 1X, ' increase la from', I8, ' to at least ', I8 )" )&
               la, nnz
       END IF
       RETURN
    END IF

    IF ( liw < MAX( nr, nc ) + 1 ) THEN
       iflag = - 3
       IF ( lp > 0 ) THEN
          WRITE( lp, 2000) iflag
          WRITE( lp, 2020) 'liw ', liw, MAX( nr, nc ) + 1
       END IF
       RETURN
    END IF

    IF ( lptr < nr + 1 ) THEN
       iflag = - 4
       IF ( lp > 0 ) THEN
          WRITE( lp, 2000 ) iflag
          WRITE( lp, 2020 ) 'lptr', lptr, nc + 1
       END IF
       RETURN
    END IF

    !  Record the number of column and row indices out of order in iout and jout
    !  and then remove them from consideration

    DO k = 1,nnz
       i = A_row( k ); j = A_col( k )
       IF ( i > nr .OR. i < 1 ) THEN
          iout = iout + 1
       ELSE IF ( j > nc .OR. j < 1 ) THEN
          jout = jout + 1
       ELSE
          nzout = nzout + 1
          A_row( nzout ) = i ; A_col( nzout ) = j
          A_val( nzout ) = A_val( k )
       END IF
    END DO

    !  Inform the user if there has been faulty data

    IF ( iout > 0 ) THEN
       iflag = 2
       IF ( mp > 0 ) THEN
          WRITE( mp, 2010 ) iflag
          WRITE( mp, "( 1X, I6,' entries input in A_row were out of',        &
               &              ' range and have been ignored by the routine')" ) iout
       END IF
    END IF

    IF ( jout > 0 ) THEN
       iflag = 3
       IF ( mp > 0 ) THEN
          WRITE( mp, 2010 ) iflag
          WRITE( mp, "( 1X, I6,' entries input in A_col were out of',        &
               &              ' range and have been ignored by the routine')" ) jout
       END IF
    END IF

    !  If all the data is faulty, exit

    IF ( iout + jout == nnz ) THEN
       nzout = 0
       RETURN
    END IF

    !  nzout gives the number of nonzero entries following removals. Now sort the
    !  pattern of a sparse matrix from arbitary order to row order. The
    !  order within each row is unimportant

    !  Record the number of elements in each row in IW

    IW( : nr + 1 ) = 0
    DO k = 1, nzout
       i = A_row( k )
       IW( i ) = IW( i ) + 1
    END DO

    !  Record the positions where each row would begin, in a compressed format
    !  with the rows in natural order, in A_ptr and IW

    A_ptr( 1 ) = 1
    DO i = 2, nr + 1
       A_ptr( i ) = IW( i - 1 ) + A_ptr( i - 1 )
       IW( i - 1 ) = A_ptr( i - 1 )
    END DO

    !  Reorder the elements into row order. Fill in each row from the front,
    !  and increase the pointer IW( k ) by 1 as a new entry is placed in row k

    DO l = 1, nr
       DO k = IW( l ), A_ptr( l + 1 ) - 1
          ie = A_row( k )
          je = A_col( k )
          ae = A_val( k )
          DO j = 1, nzout
             IF ( ie == l ) EXIT
             loc = IW( ie )
             iep = A_row( loc )
             jep = A_col( loc )
             aep = A_val( loc )
             IW( ie ) = loc + 1
             A_row( loc ) = ie
             A_col( loc ) = je
             A_val( loc ) = ae
             ie = iep
             je = jep
             ae = aep
          END DO
          A_row( k ) = ie
          A_col( k ) = je
          A_val( k ) = ae
       END DO
    END DO

    !  Check for duplicates

    nzout = 0
    k1 = 1
    nzi = 0
    IW( : nc ) = 0
    DO i = 1, nr
       k2 = A_ptr( i + 1 ) - 1
       A_ptr( i + 1 ) = A_ptr( i )
       DO K = k1, k2
          j = A_col( k )
          IF ( IW( j ) <= nzi ) THEN
             nzout = nzout + 1
             A_col( nzout ) = j
             A_val( nzout ) = A_val( k )
             A_ptr( i + 1 ) = A_ptr( i + 1 ) + 1
             IW( j ) = nzout

             !  There is a duplicate in row i; sum the values

          ELSE
             idup = idup + 1
             A_val( IW( j ) ) = A_val( IW( j ) ) + A_val( k )
          END IF
       END DO
       k1 = k2 + 1
       nzi = nzout
    END DO
    IF ( idup > 0 ) THEN
       iflag = 1
       IF ( mp > 0 ) THEN
          WRITE( mp, 2010 ) iflag
          WRITE( mp, "( 1X, I6,' Duplicate entries input ' )" ) idup
       END IF
    END IF

    !  Non-executable statements

2000 FORMAT (/,' -- Error return from REORDER_by_rows -- iflag = ', I2 )
2010 FORMAT (/,' -- Warning message from REORDER_by_rows -- iflag = ', I2)
2020 FORMAT (1X, ' increase', A4, ' from', I8,' to at least ', I8 )

    !  End of subroutine REORDER_by_rows

  END SUBROUTINE REORDER_by_rows

  !-*-*-*-*-*-*-*-*-*-  C P U _ T I M E  S U B R O U T I N E   -*-*-*-*-*-*-*-*

  SUBROUTINE CPU_TIME( time )

    !=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Return the cpu time (to be replaced in fortran 95 by a Fortran intrinsic)
    !=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    !  Dummy arguments

    REAL, INTENT( OUT ) :: time

    !  Local variables

    REAL :: ZA02AS, dum
    time = ZA02AS( dum )

    !  End of subroutine CPU_TIME

  END SUBROUTINE CPU_TIME

  !  End of program VE12_main

END PROGRAM VE12_main


      PROGRAM CFDF

      PARAMETER         ( N = 50, niters = 10 )

      REAL VX(N,N,N), VY(N,N,N), VZ(N,N,N)
      REAL VX2(N,N,N), VY2(N,N,N), VZ2(N,N,N)
      REAL P(N,N,N)
      REAL FX(N,N,N), FY(N,N,N), FZ(N,N,N)
      REAL AX(N,N,N), AY(N,N,N), AZ(N,N,N)

      INTEGER iter

C     Initialize arrays

      CALL initialize(N, VX, VY, VZ, VX2, VY2, VZ2, P, FX, FY, FZ,
     .  AX, AY, AZ)

C     Apply the stencil a few times

      DO iter=1,niters
        CALL cfdStencil(N, VX, VY, VZ, VX2, VY2, VZ2, P,
     .    FX, FY, FZ, AX, AY, AZ)
      END DO

      STOP
      END

      SUBROUTINE cfdStencil(N, VX, VY, VZ, VX2, VY2, VZ2, P,
     .  FX, FY, FZ, AX, AY, AZ)

      INTEGER N
      REAL VX(N,N,N), VY(N,N,N), VZ(N,N,N)
      REAL VX2(N,N,N), VY2(N,N,N), VZ2(N,N,N)
      REAL P(N,N,N)
      REAL FX(N,N,N), FY(N,N,N), FZ(N,N,N)
      REAL AX(N,N,N), AY(N,N,N), AZ(N,N,N)

      PARAMETER ( delta_t = 0.001, recip_rho = 1.0e-3,
     .                    eta = 1.0e-6, c1 = 0.1, c2 = 0.1 )

      DO i=3,N-2
       DO j=3,N-2
        DO k=3,N-2
         VX2(i,j,k) = VX(i,j,k)+delta_t*(recip_rho*(eta*
     .    c1 * (-90*VX(i,j,k)-VX(i-2,j,k)+16*VX(i-1,j,k)
     .    +16*VX(i+1,j,k)-VX(i+2,j,k)-VX(i,j-2,k)+16*VX(i,j-1,k)
     .    +16*VX(i,j+1,k)-VX(i,j+2,k)-VX(i,j,k-2)+16*VX(i,j,k-1)
     .    +16*VX(i,j,k+1)-VX(i,j,k+2))+c2*(P(i-2,j,k)
     .    -8*P(i-1,j,k)+8*P(i+1,j,k)+P(i+2,j,k))+FX(i,j,k))
     .    -AX(i,j,k))
         VY2(i,j,k) = VY(i,j,k)+delta_t*(recip_rho*(eta*
     .    c1 * (-90*VY(i,j,k)-VY(i-2,j,k)+16*VY(i-1,j,k)
     .    +16*VY(i+1,j,k)-VY(i+2,j,k)-VY(i,j-2,k)+16*VY(i,j-1,k)
     .    +16*VY(i,j+1,k)-VY(i,j+2,k)-VY(i,j,k-2)+16*VY(i,j,k-1)
     .    +16*VY(i,j,k+1)-VY(i,j,k+2))+c2*(P(i,j-2,k)
     .    -8*P(i,j-1,k)+8*P(i,j+1,k)+P(i,j+2,k))+FY(i,j,k))
     .    -AY(i,j,k))
         VZ2(i,j,k) = VZ(i,j,k)+delta_t*(recip_rho*(eta*
     .    c1 * (-90*VZ(i,j,k)-VZ(i-2,j,k)+16*VZ(i-1,j,k)
     .    +16*VZ(i+1,j,k)-VZ(i+2,j,k)-VZ(i,j-2,k)+16*VZ(i,j-1,k)
     .    +16*VZ(i,j+1,k)-VZ(i,j+2,k)-VZ(i,j,k-2)+16*VZ(i,j,k-1)
     .    +16*VZ(i,j,k+1)-VZ(i,j,k+2))+c2*(P(i,j,k-2)
     .    -8*P(i,j,k-1)+8*P(i,j,k+1)+P(i,j,k+2))+FZ(i,j,k))
     .    -AZ(i,j,k))
        END DO
       END DO
      END DO

      RETURN
      END

      SUBROUTINE initialize(N, VX, VY, VZ, VX2, VY2, VZ2, P,
     .  FX, FY, FZ, AX, AY, AZ)

      INTEGER N
      REAL VX(N,N,N), VY(N,N,N), VZ(N,N,N)
      REAL VX2(N,N,N), VY2(N,N,N), VZ2(N,N,N)
      REAL P(N,N,N)
      REAL FX(N,N,N), FY(N,N,N), FZ(N,N,N)
      REAL AX(N,N,N), AY(N,N,N), AZ(N,N,N)

      DO i=3,N-2
       DO j=3,N-2
        DO k=3,N-2
         VX(i,j,k) = 0
         VY(i,j,k) = 0
         VZ(i,j,k) = 0
         P(i,j,k) = 0
         FX(i,j,k) = 0
         FY(i,j,k) = 0
         FZ(i,j,k) = 0
         AX(i,j,k) = 0
         AY(i,j,k) = 0
         AZ(i,j,k) = 0
        END DO
       END DO
      END DO

      END


MODULE lattice_module

  use io_tools_module

  implicit none

  PRIVATE
  PUBLIC :: lattice
  PUBLIC :: init_lattice
  PUBLIC :: get_reciprocal_lattice
  PUBLIC :: construct_lattice
  PUBLIC :: read_lattice
  PUBLIC :: get_inverse_lattice
  PUBLIC :: backup_aa_lattice
  PUBLIC :: get_aa_lattice
  PUBLIC :: check_lattice
  PUBLIC :: calc_volume_lattice

  type lattice
     real(8) :: LatticeConstant
     real(8) :: LatticeVector(3,3)
     real(8) :: Length(3)
     real(8) :: Volume
  end type lattice

  real(8) :: ax, av(3,3)

  type(lattice) :: aa_backup

CONTAINS

  SUBROUTINE read_lattice( aa, unit )
    implicit none
    type(lattice),intent(INOUT) :: aa
    integer,optional,intent(IN) :: unit
    if ( present(unit) ) then
       call IOTools_readReal8Keyword( "AX", aa%LatticeConstant, unit )
       call IOTools_readReal8Keyword( "A1", aa%LatticeVector(:,1), unit )
       call IOTools_readReal8Keyword( "A2", aa%LatticeVector(:,2), unit )
       call IOTools_readReal8Keyword( "A3", aa%LatticeVector(:,3), unit )
    else
       call IOTools_readReal8Keyword( "AX", aa%LatticeConstant )
       call IOTools_readReal8Keyword( "A1", aa%LatticeVector(:,1) )
       call IOTools_readReal8Keyword( "A2", aa%LatticeVector(:,2) )
       call IOTools_readReal8Keyword( "A3", aa%LatticeVector(:,3) )
    end if
  END SUBROUTINE read_lattice

  SUBROUTINE init_lattice( ax_in, av_in )
    implicit none
    real(8),intent(IN) :: ax_in, av_in(3,3)
    ax = ax_in
    av = av_in
  END SUBROUTINE init_lattice

  SUBROUTINE construct_lattice( aa )
    implicit none
    type(lattice),intent(INOUT) :: aa
    aa%LatticeVector(:,:) = aa%LatticeConstant * aa%LatticeVector(:,:)
    call calc_VectorLength( aa%LatticeVector, aa%Length )
    call calc_volume_lattice( aa%LatticeVector, aa%Volume )
  END SUBROUTINE construct_lattice

  SUBROUTINE calc_VectorLength( aa, aal )
    implicit none
    real(8),intent(IN)  :: aa(3,3)
    real(8),intent(OUT) :: aal(3)
    aal(1) = sqrt( sum(aa(1:3,1)**2) )
    aal(2) = sqrt( sum(aa(1:3,2)**2) )
    aal(3) = sqrt( sum(aa(1:3,3)**2) )
  END SUBROUTINE calc_VectorLength

  SUBROUTINE calc_volume_lattice( aa, Va )
    implicit none
    real(8),intent(IN)  :: aa(3,3)
    real(8),intent(OUT) :: Va
    Va = aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1) &
        +aa(1,3)*aa(2,1)*aa(3,2)-aa(1,3)*aa(2,2)*aa(3,1) &
        -aa(1,2)*aa(2,1)*aa(3,3)-aa(1,1)*aa(2,3)*aa(3,2)
  END SUBROUTINE calc_volume_lattice

  SUBROUTINE get_reciprocal_lattice( aa, bb )
    implicit none
    type(lattice),intent(IN)  :: aa
    type(lattice),intent(OUT) :: bb
    real(8) :: a(3,3), b(3,3), pi2
    pi2 = 2.0d0*acos(-1.0d0)
    a(:,:) = aa%LatticeVector(:,:)
    b(1,1) = a(2,2)*a(3,3) - a(3,2)*a(2,3)
    b(2,1) = a(3,2)*a(1,3) - a(1,2)*a(3,3)
    b(3,1) = a(1,2)*a(2,3) - a(2,2)*a(1,3)
    b(1,2) = a(2,3)*a(3,1) - a(3,3)*a(2,1)
    b(2,2) = a(3,3)*a(1,1) - a(1,3)*a(3,1)
    b(3,2) = a(1,3)*a(2,1) - a(2,3)*a(1,1)
    b(1,3) = a(2,1)*a(3,2) - a(3,1)*a(2,2)
    b(2,3) = a(3,1)*a(1,2) - a(1,1)*a(3,2)
    b(3,3) = a(1,1)*a(2,2) - a(2,1)*a(1,2)
    b(:,:) = b(:,:)*pi2/aa%Volume
    bb%LatticeVector(:,:) = b(:,:)
    call calc_VectorLength( bb%LatticeVector, bb%Length )
    call calc_volume_lattice( bb%LatticeVector, bb%Volume )
    bb%LatticeConstant = pi2/aa%LatticeConstant
 END SUBROUTINE get_reciprocal_lattice

  SUBROUTINE get_inverse_lattice( a, ainv )
    implicit none
    real(8),intent(IN)  :: a(3,3)
    real(8),intent(OUT) :: ainv(3,3)
    real(8) :: b(3,3), v
    b(1,1) = a(2,2)*a(3,3) - a(3,2)*a(2,3)
    b(2,1) = a(3,2)*a(1,3) - a(1,2)*a(3,3)
    b(3,1) = a(1,2)*a(2,3) - a(2,2)*a(1,3)
    b(1,2) = a(2,3)*a(3,1) - a(3,3)*a(2,1)
    b(2,2) = a(3,3)*a(1,1) - a(1,3)*a(3,1)
    b(3,2) = a(1,3)*a(2,1) - a(2,3)*a(1,1)
    b(1,3) = a(2,1)*a(3,2) - a(3,1)*a(2,2)
    b(2,3) = a(3,1)*a(1,2) - a(1,1)*a(3,2)
    b(3,3) = a(1,1)*a(2,2) - a(2,1)*a(1,2)
    call calc_volume_lattice( a, v )
    ainv(:,:) = transpose( b(:,:) )/v
  END SUBROUTINE get_inverse_lattice

  SUBROUTINE backup_aa_lattice( aa )
    implicit none
    type(lattice),intent(IN) :: aa
    aa_backup = aa
  END SUBROUTINE backup_aa_lattice

  SUBROUTINE get_aa_lattice( aa )
    implicit none
    type(lattice),intent(OUT) :: aa
    aa = aa_backup
  END SUBROUTINE get_aa_lattice

  SUBROUTINE check_lattice( a, indx )
    implicit none
    real(8),intent(IN) :: a(3,3)
    character(*),optional,intent(OUT) :: indx
    real(8) :: al(3), theta23, theta31, theta12, cos23, cos31, cos12
    real(8) :: cosines(3)
    logical :: disp
    al(1) = sqrt( sum(a(:,1)**2) )
    al(2) = sqrt( sum(a(:,2)**2) )
    al(3) = sqrt( sum(a(:,3)**2) )
    cos23 = sum( a(:,2)*a(:,3) )/(al(2)*al(3))
    cos31 = sum( a(:,3)*a(:,1) )/(al(3)*al(1))
    cos12 = sum( a(:,1)*a(:,2) )/(al(1)*al(2))
    theta23 = acos( cos23 )*180.0d0/acos(-1.0d0)
    theta31 = acos( cos31 )*180.0d0/acos(-1.0d0)
    theta12 = acos( cos12 )*180.0d0/acos(-1.0d0)
    call check_disp_switch( disp, 0 )
    if ( disp ) then
       write(*,'(1x,"V1",3f12.5,2x,f12.5)') a(:,1), al(1)
       write(*,'(1x,"V2",3f12.5,2x,f12.5)') a(:,2), al(2)
       write(*,'(1x,"V3",3f12.5,2x,f12.5)') a(:,3), al(3)
       write(*,'(1x,"cos23  ,cos31  ,cos12  :",3f10.5)') cos23,cos31,cos12
       write(*,'(1x,"theta23,theta31,theta12:",3f10.5)') theta23,theta31,theta12
    end if
    if ( present(indx) ) then
       indx=""
       cosines=(/cos23,cos31,cos12/)
       call check_cubic( al, cosines, indx )
       call check_hexagonal( al, cosines, indx )
       call check_fcc( al, cosines, indx )
    end if
  END SUBROUTINE check_lattice

  SUBROUTINE check_cubic( al, cosines, indx )
    implicit none
    real(8),intent(IN) :: al(3), cosines(3)
    character(*),intent(INOUT) :: indx
    real(8),parameter :: eps=1.d-3
    if ( abs(al(1)-al(2)) < eps ) then
       if ( abs(al(2)-al(3)) < eps ) then
          if ( all( abs(cosines) < eps ) ) indx = "CUBIC"
       end if
    end if
  END SUBROUTINE check_cubic

  SUBROUTINE check_hexagonal( al, cosines, indx )
    implicit none
    real(8),intent(IN) :: al(3), cosines(3)
    character(*),intent(INOUT) :: indx
    real(8),parameter :: eps=1.d-3
    if ( abs(al(1)-al(2)) < eps ) then
       if ( abs(cosines(3)-0.5d0)<eps .or. abs(cosines(3)+0.5d0)<eps ) then
          if ( abs(cosines(1))<eps .and. abs(cosines(2))<eps ) indx="HEXAGONAL"
       end if
    else if ( abs(al(2)-al(3)) < eps ) then
       if ( abs(cosines(1)-0.5d0)<eps .or. abs(cosines(1)+0.5d0)<eps ) then
          if ( abs(cosines(2))<eps .and. abs(cosines(3))<eps ) indx="HEXAGONAL"
       end if
    else if ( abs(al(3)-al(1)) < eps ) then
       if ( abs(cosines(2)-0.5d0)<eps .or. abs(cosines(2)+0.5d0)<eps ) then
          if ( abs(cosines(3))<eps .and. abs(cosines(1))<eps ) indx="HEXAGONAL"
       end if
    end if
  END SUBROUTINE check_hexagonal

  SUBROUTINE check_fcc( al, cosines, indx )
    implicit none
    real(8),intent(IN) :: al(3), cosines(3)
    character(*),intent(INOUT) :: indx
    real(8),parameter :: eps=1.d-3
    if ( abs(al(1)-al(2)) < eps ) then
       if ( abs(al(2)-al(3)) < eps ) then
          if ( all( abs(cosines-0.5d0) < eps ) ) indx = "FCC"
       end if
    end if
  END SUBROUTINE check_fcc

END MODULE lattice_module


program ssrfpacktest

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule
use SSRFPACKInterfaceModule

implicit none

include 'mpif.h'

! mesh variables
type(PolyMesh2d) :: sphere
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: meshSeed
integer(kint) :: amrLimit
real(kreal) :: radius

! field tests
type(Field) :: constantScalar
type(Field) :: estGradConst
type(Field) :: estLapConst
type(Field) :: sphHarm
type(Field) :: estGradSphHarm
type(Field) :: estLapSphHarm
type(Field) :: exactGradHarm
type(Field) :: lapSphHarmError
type(Field) :: gradHarmError
real(kreal) :: maxGradMag
real(kreal) :: maxLapMag

! interpolation
type(DelaunayTriangulation) :: delTri
type(SSRFPACKInterface) :: ssrfConst, ssrfHarm, ssrfLagParam

! uniform grid
real(kreal) :: lons(360), lats(181)
real(kreal) :: interp(181,360)
real(kreal) :: harmInterp(181,360)
real(kreal) :: exactHarm(181,360)
real(kreal) :: xInterp(3)
integer(kint), parameter :: nLat = 181
integer(kint), parameter :: nLon = 360

! environment / machine variables
type(MPISetup) :: particlesMPI
type(MPISetup) :: unifGridMPI
integer(kint) :: mpiErrCode, narg
character(len=100) :: arg
type(Logger) :: exeLog
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=MAX_STRING_LENGTH) :: logString
character(len=15) :: logKey = "ssrfTest"
real(kreal) :: programStart, programEnd
real(kreal) :: interpErr
real(kreal), parameter :: errTol = 0.0002_kreal

! output variables
character(len=100) :: matlabFilename
character(len=100) :: paraviewFilename

! general
integer(kint) :: i, j
real(kreal) :: xi(3), vecA(3), vecB(3)

!
!----------------
! PROGRAM START
!----------------
!
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)

programStart = MPI_WTIME()

call InitLogger(exeLog, procRank)

if ( procRank == 0 ) then
	narg = IARGC()
	if ( narg /= 2 ) then
		stop "usage : ssrfpackTest.exe meshType initNest"
	else
		call GETARG(1, arg)
		read(arg, *) meshSeed
		if ( meshSeed == 3 ) then
			meshSeed = ICOS_TRI_SPHERE_SEED
		elseif (meshSeed == 4) then
			meshSeed = CUBED_SPHERE_SEED
		else
			stop "invalid arg1: meshType must be 3 or 4"
		endif
		call GETARG(2, arg)
		read(arg, *) initNest
	endif
endif
call MPI_BCAST(meshSeed, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)
call MPI_BCAST(initNest, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)

if ( meshSeed == ICOS_TRI_SPHERE_SEED ) then
	write(logString,'(A,I1,A)') "building icos tri mesh to initNest = ", initNest, "..."
	write(paraviewFilename,'(A,I1,A)') "icosTriSSRFPACK_", initNest, ".vtk"
	write(matlabFilename,'(A,I1,A)') "icosTriSSRFPACK_", initNest, ".m"
else
	write(logString,'(A,I1,A)') "building cubed sphere mesh to initNest = ", initNest, "..."
	write(paraviewFilename,'(A,I1,A)') "cubedSphereSSRFPACK_", initNest, ".vtk"
	write(matlabFilename,'(A,I1,A)') "cubedSphereSSRFPACK_", initNest, ".m"
endif
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, logKey, logString )

!
!----------------
! build mesh
!----------------
!
maxNest = initNest
amrLimit = 0
radius = 1.0_kreal
call New( sphere, meshSeed, initNest, maxNest, amrLimit, radius )
call LogStats( sphere, exeLog )

call New( particlesMPI, sphere%particles%N, numProcs)

do j = 1, 360
	lons(j) = (j-1) * DEG_2_RAD
enddo
do i = 1, 181
	lats(i) = -PI/2.0_kreal + (i-1) * DEG_2_RAD
enddo
do j = 1, 360
	do i = 1, 181
		exactHarm(i,j) = SphereHarm54LatLon(lons(j), lats(i))
	enddo
enddo

call New( unifGridMPI, 360, numProcs )

!
!----------------
! set up source field data
!----------------
!
call New(constantScalar, 1, sphere%particles%N, "const", "n/a")

call New( sphHarm, 1, sphere%particles%N, "sphHarm54", "n/a")
call New( exactGradHarm, 3, sphere%particles%N, "gradSphHarm", "n/a")

do i = 1, sphere%particles%N
	xi = [sphere%particles%x(i), sphere%particles%y(i), sphere%particles%z(i)]
	call InsertScalarToField( constantScalar, 1.0_kreal )
	call InsertScalarToField( sphHarm, SphereHarmonic54( xi ))
	call InsertVectorToField( exactGradHarm, HarmGradient(xi) )
enddo

!
!----------------
! interpolate
!----------------
!
call New(delTri, sphere)
call New(ssrfConst, sphere, 1)
call New(ssrfHarm, sphere, 1)
call New(ssrfLagParam, sphere, 3)

call SetScalarSourceData(ssrfConst, sphere, delTri, constantScalar)
call SetScalarSourceData(ssrfHarm, sphere, delTri, sphHarm)
call SetSourceLagrangianParameter( ssrfLagParam, sphere, delTri)

do j = unifGridMPI%indexStart(procRank), unifGridMPI%indexEnd(procRank)
	do i = 1, 181
		interp(i,j) = InterpolateScalar( lons(j), lats(i), ssrfConst, sphere, delTri, constantScalar)
		harmInterp(i,j) = InterpolateScalar(lons(j), lats(i), ssrfHarm, sphere, delTri, sphHarm)
	enddo
enddo

do i = 0, numProcs - 1
	call MPI_BCAST( interp(:,unifGridMPI%indexStart(i):unifGridMPI%indexEnd(i)), 181 * unifGridMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( harmInterp(:,unifGridMPI%indexStart(i):unifGridMPI%indexEnd(i)), 181 * unifGridMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
enddo

interpErr = maxval(abs(harmInterp-exactHarm))/maxval(abs(exactHarm))

call LogMessage(exeLog,TRACE_LOGGING_LEVEL,trim(logkey)//" interp err = ", interpErr)

if ( interpErr > errTol ) stop "TEST FAILED."

!
!----------------
! write output
!----------------
!
if ( procRank == 0 ) then
	open(unit=WRITE_UNIT_2, file=matlabFilename, action='WRITE',status='REPLACE')
		call WriteToMatlab( lons, WRITE_UNIT_2, "lons")
		call WriteToMatlab( lats, WRITE_UNIT_2, "lats")
		call WriteToMatlab( interp, WRITE_UNIT_2, "constScalarInterp")
		call WriteToMatlab( harmInterp, WRITE_UNIT_2, "sphHarmInterp")
		call WriteToMatlab( exactHarm, WRITE_UNIT_2, "exactHarm")
	close(WRITE_UNIT_2)
endif

!
!----------------
! PROGRAM END
!----------------
!
programEnd = MPI_WTIME()

write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", programEnd - programStart, " seconds."
call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", logString)

call Delete(ssrfConst)
call Delete(ssrfHarm)
call Delete(ssrfLagParam)
call Delete(delTri)
call Delete(sphHarm)
call Delete(constantScalar)
call Delete(unifGridMPI)
call Delete(particlesMPI)
call Delete(sphere)
call Delete(exeLog)

call MPI_Finalize(mpiErrCode)

contains

pure function SphereHarmonic54(xyz)
	real(kreal) :: SphereHarmonic54
	real(kreal), intent(in) :: xyz(3)
	SphereHarmonic54 = 3.0_kreal * sqrt(35.0_kreal) * cos( 4.0_kreal * Longitude(xyz)) * sin(Latitude(xyz)) * &
					   (-1.0_kreal + sin(Latitude(xyz)) * sin(Latitude(xyz)))**2
end function

pure function SphereHarm54LatLon( lon, lat )
	real(kreal) :: SphereHarm54LatLon
	real(kreal), intent(in) :: lon, lat
	SphereHarm54LatLon = 3.0_kreal * sqrt(35.0_kreal) * cos(4.0_kreal * lon) * sin(lat) * &
			(-1.0_kreal + sin(lat)*sin(lat) )**2
end function

pure function HarmGradient( xyz )
	real(kreal) :: HarmGradient(3)
	real(kreal), intent(in) :: xyz(3)
	!
	real(kreal) :: lon, lat, u, v

	lat = Latitude(xyz)
	lon = Longitude(xyz)

	u = -12.0_kreal*sqrt(35.0_kreal)*sin(4.0_kreal * lon)*(-1.0_kreal + sin(lat)*sin(lat))**2 * tan(lat)
	v =  12.0_kreal*sqrt(35.0_kreal)*cos(4.0_kreal * lon)*cos(lat)*sin(lat)*sin(lat)*(-1.0_kreal + sin(lat)*sin(lat)) + &
		 3.0_kreal*sqrt(35.0_kreal) * cos(4.0_kreal * lon)*cos(lat)*(-1.0_kreal + sin(lat)*sin(lat))**2

	HarmGradient(1) =-u * sin(lon) - v * sin(lat)*cos(lon)
	HarmGradient(2) = u * cos(lon) - v * sin(lat)*sin(lon)
	HarmGradient(3) = v * cos(lat)
end function

subroutine InitLogger(aLog,rank)
! Initialize a logger for this processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
end subroutine

end program


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

! RUN: %flang -S -emit-llvm %s -o - 2>&1 | FileCheck %s

program shift64
  integer(8) :: x, y

  ! CHECK: sext i32 3 to i64
  ! CHECK-NEXT: shl
  x = ishft(x, 3)
  ! CHECK: sext i32 5 to i64
  ! CHECK-NEXT: lshr
  x = ishft(x, -5)
  ! CHECK: @ftn_i_kishft
  y = ishft(x, y)
end program


      double precision function dpmeps()
c     **********
c
c     Subroutine dpeps
c
c     This subroutine computes the machine precision parameter
c     dpmeps as the smallest floating point number such that
c     1 + dpmeps differs from 1.
c
c     This subroutine is based on the subroutine machar described in
c
c     W. J. Cody,
c     MACHAR: A subroutine to dynamically determine machine parameters,
c     ACM Trans. Math. Soft., 14, 1988, pages 303-311.
c
c     The subroutine statement is:
c
c       subroutine dpeps(dpmeps)
c
c     where
c
c       dpmeps is a double precision variable.
c         On entry dpmeps need not be specified.
c         On exit dpmeps is the machine precision.
c
c     MINPACK-2 Project. February 1991.
c     Argonne National Laboratory and University of Minnesota.
c     Brett M. Averick.
c
c     *******
      integer i,ibeta,irnd,it,itemp,negep
      double precision a,b,beta,betain,betah,temp,tempa,temp1,
     +       zero,one,two
      data zero,one,two /0.0d0,1.0d0,2.0d0/

c     determine ibeta, beta ala malcolm.

      a = one
      b = one
   10 continue
         a = a + a
         temp = a + one
         temp1 = temp - a
      if (temp1 - one .eq. zero) go to 10
   20 continue
         b = b + b
         temp = a + b
         itemp = int(temp - a)
      if (itemp .eq. 0) go to 20
      ibeta = itemp
      beta = dble(ibeta)

c     determine it, irnd.

      it = 0
      b = one
   30 continue
         it = it + 1
         b = b * beta
         temp = b + one
         temp1 = temp - b
      if (temp1 - one .eq. zero) go to 30
      irnd = 0
      betah = beta/two
      temp = a + betah
      if (temp - a .ne. zero) irnd = 1
      tempa = a + beta
      temp = tempa + betah
      if ((irnd .eq. 0) .and. (temp - tempa .ne. zero)) irnd = 2

c     determine dpmeps.

      negep = it + 3
      betain = one/beta
      a = one
      do 40 i = 1, negep
         a = a*betain
   40 continue
   50 continue
        temp = one + a
        if (temp - one .ne. zero) go to 60
        a = a*beta
        go to  50
   60 continue
      dpmeps = a
      if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 70
      a = (a*(one + a))/two
      temp = one + a
      if (temp - one .ne. zero) dpmeps = a

   70 return

      end

c====================== The end of dpmeps ==============================


c  main program for example in chapter xv.
c  from  * a practical guide to splines *  by c. de boor
c  solution of a second order nonlinear two point boundary value
c  problem  on (0., 1.) , by collocation with pp functions having  4
c  pieces of order  6 .  2  passes through newnot are to be made,
c  without any knots being added. newton iteration is to be stopped
c  when two iterates agree to  6  decimal places.
       call colloc(0.,1.,4,6,2,0.,1.e-6)
					stop
       end


C***********************************************************************
C***********************************************************************
C
C   Version:        0.3
C   Last modified:  December 27, 1994
C   Authors:        Esmond G. Ng and Barry W. Peyton
C
C   Mathematical Sciences Section, Oak Ridge National Laboratory
C
C***********************************************************************
C***********************************************************************
C
C     ------------------------------------
C     CONSTRUCT RIGHT HAND SIDE VECTOR ...
C     ------------------------------------
C
      SUBROUTINE  GETRHS (  N, XADJF, ADJF, ANZF, SOL, RHS )
C
        INTEGER             N
        INTEGER             XADJF(*), ADJF(*)
        DOUBLE PRECISION    ANZF(*), SOL(*), RHS(*)
C
        INTEGER             II, J
        DOUBLE PRECISION    T
C
C       ---------------
C       INITIALIZATION.
C       ---------------
        DO  100  J = 1, N
            RHS(J) = 0.0
  100   CONTINUE
C
        DO  300  J = 1, N
C           -------------------
C           FOR EACH COLUMN ...
C           -------------------
            T = SOL(J)
            DO  200  II = XADJF(J), XADJF(J+1)-1
                RHS(ADJF(II)) = RHS(ADJF(II)) + T*ANZF(II)
  200       CONTINUE
  300   CONTINUE
C
        RETURN
      END


module sphfinrot

    character(len=512) :: input_file
    character(len=512) :: output_file

    double precision :: pole_lon
    double precision :: pole_lat
    double precision :: rotation_angle

end module

!==================================================================================================!

program main
!----
! Given a point (ilon,ilat), a pole of rotation (plon,plat), and a finite angle of rotation
! (degrees), calculate the rotated point (olon,olat).
!
! Based on equations shown by Glenn Murray:
! https://sites.google.com/site/glennmurray/Home/rotation-matrices-and-formulas/rotation-about-an-arbitrary-axis-in-3-dimensions
!----

use io, only: stdin, stderr, stdout, fileExists

use sphfinrot, only: input_file, &
                     output_file, &
                     pole_lon, &
                     pole_lat, &
                     rotation_angle

implicit none

! Local variables
integer :: luin, luout, ios
character(len=512) :: line
double precision :: input_lon, input_lat, output_lon, output_lat

call gcmdln()

! Input file
if (input_file.eq.'none'.or.input_file.eq.'stdin') then
    luin = stdin
else
    if (.not.fileExists(input_file)) then
        call usage('sphfinrot: no input file found named '//trim(input_file))
    endif
    luin = 11
    open(luin,file=input_file,status='old')
endif

! Output file
if (output_file.eq.'none'.or.output_file.eq.'stdout') then
    luout = stdout
else
    luout = 12
    open(luout,file=output_file,status='unknown')
endif

! Pole of finite rotation
if (pole_lon.lt.-1.0d9.or.pole_lat.lt.-1.0d9) then
    call usage('sphfinrot: coordinates of rotation pole not defined')
elseif (pole_lon.lt.-180.0d0) then
    call usage('sphfinrot: rotation pole longitude less than -180 degrees')
elseif (pole_lon.gt.360.0d0) then
    call usage('sphfinrot: rotation pole longitude greater than 360 degrees')
elseif (pole_lat.lt.-90.0d0) then
    call usage('sphfinrot: rotation pole latitude less than -90 degrees')
elseif (pole_lat.gt.90.0d0) then
    call usage('sphfinrot: rotation pole latitude greater than 90 degrees')
endif

! Angle
if (rotation_angle.lt.-1.0d9) then
    call usage('sphfinrot: rotation angle not defined')
endif

do
    read(luin,'(A)',iostat=ios) line
    if (ios.ne.0) then
        exit
    endif
    read(line,*,iostat=ios) input_lon,input_lat
    if (ios.ne.0) then
        write(stderr,*) 'sphfinrot: error parsing input line'
        write(stderr,*) 'Input line: ',trim(line)
        call usage('Expected format: lon lat')
    endif
    call finite_rotate(pole_lon,pole_lat,rotation_angle,input_lon,input_lat,output_lon,output_lat)
    write(luout,1001) output_lon,output_lat
enddo
1001 format(1P2E14.6)

if (input_file.ne.'none'.and.input_file.ne.'stdin') then
    close(luin)
endif
if (output_file.ne.'none'.and.output_file.ne.'stdout') then
    close(luout)
endif

end

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

subroutine finite_rotate(pole_lon,pole_lat,angle,lon_in,lat_in,lon_out,lat_out)

use trig, only: d2r
use earth, only: radius_earth_m, sphere_geo2xyz, sphere_xyz2geo

implicit none

! Arguments
double precision :: pole_lon, pole_lat, angle, lon_in, lat_in, lon_out, lat_out

! Local variables
double precision :: x, y, z, px, py, pz, cosr, sinr, dot, ox, oy, oz

! Convert input point to Cartesian coordinates
call sphere_geo2xyz(lon_in,lat_in,0.0d0,x,y,z,radius_earth_m)

! Convert finite rotation pole to Cartesian coordinates (unit vector)
call sphere_geo2xyz(pole_lon,pole_lat,0.0d0,px,py,pz,1.0d0)

! Compute the rotation with a matrix multiplication
cosr = dcos(angle*d2r)
sinr = dsin(angle*d2r)
dot = px*x + py*y + pz*z
ox = px*dot*(1.0d0-cosr) + x*cosr + (py*z-pz*y)*sinr
oy = py*dot*(1.0d0-cosr) + y*cosr + (pz*x-px*z)*sinr
oz = pz*dot*(1.0d0-cosr) + z*cosr + (px*y-py*x)*sinr

! Convert back to geographic coordinates
call sphere_xyz2geo(ox,oy,oz,lon_out,lat_out,dot,radius_earth_m)

return
end subroutine

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

subroutine gcmdln()

use io, only: stdout, verbosity

use sphfinrot, only: input_file, &
                     output_file, &
                     pole_lon, &
                     pole_lat, &
                     rotation_angle

implicit none

! Local variables
character(len=512) :: tag
integer :: i, narg

input_file = 'none'
output_file = 'none'
pole_lon = -1.0d10
pole_lat = -1.0d10
rotation_angle = -1.0d10

narg = command_argument_count()
if (narg.eq.0) then
    call usage('')
endif

i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-f') then
        i = i + 1
        call get_command_argument(i,input_file)

    elseif (trim(tag).eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)

    elseif (trim(tag).eq.'-pole') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) pole_lon
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) pole_lat

    elseif (trim(tag).eq.'-angle') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) rotation_angle

    elseif (trim(tag).eq.'-v') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) verbosity

    else
        call usage('sphfinrot: no option '//trim(tag))
    endif

    i = i + 1
enddo

if (verbosity.ge.2) then
    write(stdout,*) 'input_file:     ',trim(input_file)
    write(stdout,*) 'output_file:    ',trim(output_file)
    write(stdout,*) 'pole_lon:       ',pole_lon
    write(stdout,*) 'pole_lon:       ',pole_lat
    write(stdout,*) 'rotation_angle: ',rotation_angle
endif

return
end subroutine

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

subroutine usage(str)

use io, only: stderr
implicit none

character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif
write(stderr,*) 'Usage: sphfinrot [-f IFILE] [-o OFILE] -pole PLON PLAT -angle ANGLE'
write(stderr,*)
write(stderr,*) '  -f IFILE         Input longitude and latitude (default: stdin)'
write(stderr,*) '  -o OFILE         Output longitude and latitude (default: stdout)'
write(stderr,*) '  -pole PLON PLAT  Rotation pole location'
write(stderr,*) '  -angle ANGLE     Rotation angle (counter-clockwise)'
write(stderr,*)

call error_exit(1)
end subroutine