module elast

public :: strain2stress
public :: stress2traction
public :: traction_components
public :: max_shear_stress

public :: read_halfspace_file

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

subroutine strain2stress(strain,lame_param,shear_modulus,stress)
!----
! Calculate the stress tensor from the strain tensor and elastic moduli, assuming a linear,
! isotropic medium.
!----

implicit none

! Arguments
double precision :: stress(3,3), strain(3,3), lame_param, shear_modulus

! Local variables
double precision :: diag

diag = strain(1,1) + strain(2,2) + strain(3,3)

! Diagonal terms
stress(1,1) = lame_param*diag + 2.0d0*shear_modulus*strain(1,1)
stress(2,2) = lame_param*diag + 2.0d0*shear_modulus*strain(2,2)
stress(3,3) = lame_param*diag + 2.0d0*shear_modulus*strain(3,3)

! Off-diagonal terms
stress(1,2) = 2.0d0*shear_modulus*strain(1,2)
stress(1,3) = 2.0d0*shear_modulus*strain(1,3)
stress(2,3) = 2.0d0*shear_modulus*strain(2,3)
stress(2,1) = stress(1,2)
stress(3,1) = stress(1,3)
stress(3,2) = stress(2,3)

return
end subroutine

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

subroutine stress2traction(stress_tensor,normal_vector,traction_vector)
!----
! Calculate the traction vector resolved onto a plane from the stress tensor and the normal vector
! to the plane.
!----

use io, only: stderr
implicit none

! Arguments
double precision :: stress_tensor(3,3), normal_vector(3), traction_vector(3)

! Local variables
integer :: i, j
double precision :: magnitude

! Initialize traction vector
traction_vector = 0.0d0

! Normalize the normal vector
magnitude = normal_vector(1)*normal_vector(1) + &
            normal_vector(2)*normal_vector(2) + &
            normal_vector(3)*normal_vector(3)

if (magnitude.lt.1.0d-8) then
    write(stderr,*) 'stress2traction: normal vector magnitude is zero, setting traction to zero'
    return
endif

normal_vector = normal_vector/magnitude

! traction_vector = stress_tensor*normal_vector
do i = 1,3
    do j = 1,3
        traction_vector(i) = traction_vector(i) + stress_tensor(i,j)*normal_vector(j)
    enddo
enddo

return
end subroutine

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

subroutine traction_components(trac_vec,nor_vec,trac_nor,trac_str,trac_dip)
!----
! Calculate the normal, strike-parallel, and up-dip components of the traction vector on a plane
! defined by its normal vector.
!----

use geom, only: normal2strike, normal2updip
use algebra, only: dot_product

implicit none

! Arguments
double precision :: trac_vec(3), nor_vec(3), trac_nor, trac_str, trac_dip

! Local variables
double precision :: str_vec(3), dip_vec(3)

! Calculate unit vectors parallel to strike and up-dip
call normal2strike(nor_vec,str_vec)
call normal2updip(nor_vec,dip_vec)

! Project the traction vector onto normal, along-strike, and horizontal up-dip directions
call dot_product(trac_vec,nor_vec,trac_nor)
call dot_product(trac_vec,str_vec,trac_str)
call dot_product(trac_vec,dip_vec,trac_dip)

return
end subroutine

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

subroutine max_shear_stress(stress,max_shear)
!----
! Calculate maximum shear stress from a stress tensor
!----

implicit none

! Arguments
double precision :: stress(3,3), max_shear

! Local variables
double precision :: s11_s22, s11_s33, s22_s33, s12s12, s13s13, s23s23

s11_s22 = stress(1,1)-stress(2,2)
s11_s33 = stress(1,1)-stress(3,3)
s22_s33 = stress(2,2)-stress(3,3)

s12s12 = stress(1,2)*stress(1,2)
s13s13 = stress(1,3)*stress(1,3)
s23s23 = stress(2,3)*stress(2,3)

max_shear = (1.0d0/6.0d0)*(s11_s22*s11_s22+s11_s33*s11_s33+s22_s33*s22_s33) + s12s12+s13s13+s23s23

! Make sure it has units of Pa
max_shear = dsqrt(max_shear)

return
end subroutine

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

subroutine read_halfspace_file(halfspace_file,poisson,shearmod,lame,ierr)
!----
! Read half-space elastic moduli from file (if provided), in format:
!     lbl1 value1 lbl2 value2 [lbl3 value3]
!
! For example, if you have the shear modulus and Young's modulus, the file would be:
!     shearmod 40e9 young 8e10
!----

use io, only: stderr, line_count, fileExists

implicit none

! Arguments
character(len=*) :: halfspace_file
double precision :: poisson, shearmod, lame

! Local variables
integer :: i, j, ios, ierr
character(len=512) :: input_line
character(len=32) :: lbl(4)
character(len=8) :: halfspace_file_mode
double precision :: val(3)

ierr = 0

! If the file is not defined, use defaults set in gcmdln
if (halfspace_file.eq.'') then
    return
endif

! Check whether the half-space file exists
if (.not.fileExists(halfspace_file)) then
    write(stderr,*) 'read_halfspace: no half-space file named '//trim(halfspace_file)//' found'
    write(stderr,*) 'using default elastic moduli values'
    return
endif

! Initialize modulus variables
lbl = ''
val = 0.0d0

! Open the file and read the half-space elastic moduli
halfspace_file_mode = 'modern'
open(unit=15,file=halfspace_file,status='old')
read(15,'(A)') input_line

! For back-compatibility, can read parameters in these formats (print warning):
!     vp vs dens
!     "lame" lame shear_mod
read(input_line,*,end=1501,err=1500,iostat=ios) lbl(1:4)
1501 if (ios.ne.0) then
    halfspace_file_mode = 'legacy'
    ! Found fewer than 4 inputs
    if (lbl(1).eq.'lame'.or.lbl(1).eq.'Lame') then
        read(lbl(2),*,err=1500,iostat=ios) val(1)
        read(lbl(3),*,err=1500,iostat=ios) val(2)
        lbl(1) = 'lame'
        lbl(2) = 'shearmod'
        lbl(3:4) = ''
        write(stderr,*) 'read_halfspace: WARNING: you are using a legacy half-space format ("lame" lame shear)'
        write(stderr,*) 'In the future, you should use labeled inputs, e.g.: lame 40e9 shearmod 40e9'
    else
        read(lbl(1),*,err=1500,iostat=ios) val(1)
        read(lbl(2),*,err=1500,iostat=ios) val(2)
        read(lbl(3),*,err=1500,iostat=ios) val(3)
        lbl(1) = 'vp'
        lbl(2) = 'vs'
        lbl(3) = 'dens'
        write(stderr,*) 'read_halfspace: WARNING: you are using a legacy half-space format (vp vs dens)'
        write(stderr,*) 'In the future, you should use labeled inputs, e.g.: vp 6800 vs 3926 dens 3000'
    endif
endif

! Read in updated format, which can take three (labeled) inputs for a minimum of 4 items on line
! Examples: shear 40e9 lame 35e9
!           vp 6500 vs 3700 dens 3000
if (halfspace_file_mode.eq.'modern') then
    read(input_line,*,iostat=ios) lbl(1), val(1), lbl(2), val(2), lbl(3), val(3)

    ! Then check for two inputs
    if (ios.ne.0) then
        read(input_line,*,iostat=ios) lbl(1), val(1), lbl(2), val(2)
    endif
endif

1500 if (ios.ne.0) then
    write(stderr,*) 'read_halfspace: error reading modulus labels and values'
    write(stderr,*) 'offending line: '//trim(input_line)
    ierr = 1
    return
endif

close(15)

! Check labels make sense
do i = 1,2
    if (lbl(i).eq.'mu' .or. lbl(i).eq.'shear_modulus' .or. lbl(i).eq.'shear' .or. &
                                                                     lbl(i).eq.'shearmod') then
        lbl(i) = 'shearmod'
    elseif (lbl(i).eq.'lame' .or. lbl(i).eq.'lambda') then
        lbl(i) = 'lame'
    elseif (lbl(i).eq.'poisson' .or. lbl(i).eq.'nu') then
        lbl(i) = 'poisson'
    elseif (lbl(i).eq.'young') then
        lbl(i) = 'young'
    elseif (lbl(i).eq.'vp'.or.lbl(i).eq.'vs'.or.lbl(i).eq.'dens') then
        ! Okay
    else
        write(stderr,*) 'read_halfspace: elastic modulus "',trim(lbl(i)),'" not implemented'
        write(stderr,*) 'specify two of: shear_modulus, lame, poisson, or young OR vp vs dens'
        ierr = 2
        return
    endif
enddo

! Calculate Poisson's ratio, Lame parameter, and shear modulus
do i = 1,2

    j = mod(i,2)+1

    if (lbl(i).eq.'shearmod'.and.lbl(j).eq.'lame') then
        ! Calculate Poisson's ratio from Lame's parameter and shear modulus
        shearmod = val(i)
        lame = val(j)
        poisson = lame/(2.0d0*(lame+shearmod))

    elseif (lbl(i).eq.'shearmod'.and.lbl(j).eq.'poisson') then
        ! Calculate Lame's parameter from Poisson's ratio and shear modulus
        shearmod = val(i)
        poisson = val(j)
        lame = 2.0d0*shearmod*poisson/(1.0d0-2.0d0*poisson)

    elseif (lbl(i).eq.'shearmod'.and.lbl(j).eq.'young') then
        ! Calculate Lame's parameter and Poisson's ratio from Young's modulus and shear modulus
        shearmod = val(i)
        lame = shearmod*(val(j)-2.0d0*shearmod)/(3.0d0*shearmod-val(j))
        poisson = lame/(2.0d0*(lame+shearmod))

    elseif (lbl(i).eq.'lame'.and.lbl(j).eq.'poisson') then
        ! Calculate shear modulus from Lame's parameter and Poisson's ratio
        lame = val(i)
        poisson = val(j)
        shearmod = lame*(1.0d0-2.0d0*poisson)/(2.0d0*poisson)

    elseif (lbl(i).eq.'lame'.and.lbl(j).eq.'young') then
        ! Calculate shear modulus and Poisson's ratio from Lame's parameter and Young's modulus
        lame = val(i)
        poisson = 2.0d0*lame/(val(j)+lame+sqrt(val(j)*val(j)+9.0d0*lame*lame+2.0d0*lame*val(j)))
        shearmod = lame*(1.0d0-2.0d0*poisson)/(2.0d0*poisson)

    elseif (lbl(i).eq.'poisson'.and.lbl(j).eq.'young') then
        ! Calculate shear modulus and Lame's parameter from Poisson's ratio and Young's modulus
        poisson = val(i)
        shearmod = val(j)/(2.0d0*(1.0d0+poisson))
        lame = 2.0d0*shearmod*poisson/(1.0d0-2.0d0*poisson)

    endif
enddo

if (lbl(1).eq.'vp'.and.lbl(2).eq.'vs'.and.lbl(3).eq.'dens') then
    ! Calculate shear modulus, Lame's parameter, and Poisson's ratio from seismic velocities and density
    shearmod = val(2)*val(2)*val(3)
    lame = val(1)*val(1)*val(3) - 2.0d0*shearmod
    poisson = lame/(2.0d0*(lame+shearmod))
endif

return
end subroutine

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

! !--------------------------------------------------------------------------------------------------!
!
!     subroutine calc_traction_components(traction,normal,strike,updip,traction_components)
!     implicit none
!     ! I/O variables
!     double precision :: traction(3), normal(3), strike(3), updip(3), traction_components(3)
!     ! Local variables
!     integer :: i
!
!     ! Project the traction vector on normal, along-strike, and horizontal up-dip directions
!     traction_components = 0.0d0
!     do i = 1,3
!         traction_components(1) = traction_components(1) + traction(i)*normal(i)
!         traction_components(2) = traction_components(2) + traction(i)*strike(i)
!         traction_components(3) = traction_components(3) + traction(i)*updip(i)
!     enddo
!     return
!     end subroutine calc_traction_components
!
!
! !--------------------------------------------------------------------------------------------------!
!
!     subroutine calc_plane_unit_vectors(strike,dip,unit_normal,unit_strike,unit_updip)
!     implicit none
!     ! I/O variables
!     double precision :: strike, dip, unit_normal(3), unit_strike(3), unit_updip(3)
!     ! Local variables
!     double precision, parameter :: pi=datan(1.0d0)*4.0d0, d2r=pi/180.0d0, pi2=pi/2.0d0
!     double precision :: str_rad, dip_rad
!
!     str_rad = strike*d2r
!     dip_rad = dip*d2r
!
!     unit_normal(1) = dsin(dip_rad)*dsin(str_rad+pi2)
!     unit_normal(2) = dsin(dip_rad)*dcos(str_rad+pi2)
!     unit_normal(3) = dcos(dip_rad)
!
!     unit_strike(1) = dsin(str_rad)
!     unit_strike(2) = dcos(str_rad)
!     unit_strike(3) = 0.0d0
!
!     unit_updip(1) = dcos(dip_rad)*dsin(str_rad-pi2)
!     unit_updip(2) = dcos(dip_rad)*dcos(str_rad-pi2)
!     unit_updip(3) = dsin(dip_rad)
!
!     return
!     end
!
! !--------------------------------------------------------------------------------------------------!
!
!     subroutine rotate_strain(strain,strike)
!     !----
!     ! Rotate strain matrix from (x=str, y=updip horizontal, z=up) to (x=E, y=N, z=up)
!     !----
!     implicit none
!     ! I/O variables
!     double precision, dimension(3,3) :: strain
!     double precision :: strike
!     ! Local variables
!     double precision, dimension(3,3) :: rot, rot_transpose, tmp
!     double precision, parameter :: pi=datan(1.0d0)*4.0d0, d2r=pi/180.0d0
!     rot(1,1) = dcos(d2r*strike-pi/2.0d0)
!     rot(2,2) = rot(1,1)
!     rot(1,2) = dsin(d2r*strike-pi/2.0d0)
!     rot(2,1) = -rot(1,2)
!     rot(1,3) = 0.0d0
!     rot(2,3) = 0.0d0
!     rot(3,1) = 0.0d0
!     rot(3,2) = 0.0d0
!     rot(3,3) = 1.0d0
!     call mattr(rot_transpose,rot)
!     call matmult(tmp,rot,strain)
!     call matmult(strain,tmp,rot_transpose)
!     return
!     end
!
! !--------------------------------------------------------------------------------------------------!
!
!     subroutine mattr(matout,matin)
!     !----
!     ! Transpose a 3x3 matrix
!     !----
!     implicit none
!     ! I/O variables
!     double precision, dimension(3,3) :: matout, matin
!     ! Local variables
!     integer :: i, j
!     do i = 1,3
!         do j = 1,3
!             matout(i,j) = matin(j,i)
!         enddo
!     enddo
!     return
!     end
!
! !--------------------------------------------------------------------------------------------------!
!
!     subroutine matmult(matout,mat1,mat2)
!     !----
!     ! Multiply two 3x3 matrices
!     !----
!     implicit none
!     ! I/O variables
!     double precision, dimension(3,3) :: mat1, mat2, matout
!     ! Local variables
!     integer :: i, j, k
!     do i = 1,3
!         do j = 1,3
!             matout(i,j) = 0.0d0
!             do k = 1,3
!                 matout(i,j) = matout(i,j) + mat1(i,k)*mat2(k,j)
!             enddo
!         enddo
!     enddo
!     return
!     end
! !--------------------------------------------------------------------------------------------------!
!
!
!
! subroutine calc_tractions(trac_vector,shear,shearmax,normal,coulomb,stress,trg)
! !----
! ! Calculate various tractions resolved onto a fault geometry from a stress tensor
! !----
!
! use trig, only: pi, d2r
! implicit none
!
! ! Arguments
! double precision :: trac_vector(3), shear, shearmax, normal, coulomb, stress(3,3), trg(4)
!
! ! Local variables
! integer :: i
! double precision :: str, dip, rak, fric
! double precision :: n(3), s(3), r(3)
!
! str = trg(1)*d2r
! dip = trg(2)*d2r
! rak = trg(3)*d2r
! fric = trg(4)
!
! ! Unit normal vector to target plane
! n(1) = dsin(dip)*dsin(str+pi/2.0d0)
! n(2) = dsin(dip)*dcos(str+pi/2.0d0)
! n(3) = dcos(dip)
!
! ! Traction vector is stress matrix times normal vector: t = S*n
! do i = 1,3
!     trac_vector(i) = stress(i,1)*n(1) + stress(i,2)*n(2) + stress(i,3)*n(3)
! enddo
!
! ! Normal component of traction is parallel to unit normal vector; take dot product
! normal = 0.0d0
! do i = 1,3
!     normal = normal + trac_vector(i)*n(i)
! enddo
!
! ! Shear component of traction is difference between total traction vector and normal traction
! s(1) = trac_vector(1) - normal*n(1)
! s(2) = trac_vector(2) - normal*n(2)
! s(3) = trac_vector(3) - normal*n(3)
! shearmax = dsqrt(s(1)*s(1) + s(2)*s(2) + s(3)*s(3))
!
! ! Compute unit slip vector (parallel to rake)
! r(1) =  dcos(str-pi/2.0d0)*dcos(rak) + dsin(str-pi/2.0d0)*dsin(rak)*dcos(dip)
! r(2) = -dsin(str-pi/2.0d0)*dcos(rak) + dcos(str-pi/2.0d0)*dsin(rak)*dcos(dip)
! r(3) =                                                    dsin(rak)*dsin(dip)
!
! ! Project shear component on slip vector
! shear = s(1)*r(1) + s(2)*r(2) + s(3)*r(3)
!
! ! Coulomb stress (recall sign convention: pos = dilation)
! coulomb = shear + fric*normal
!
! return
! end subroutine calc_tractions

end module elast


 MODULE GDSWZD_LAMBERT_CONF_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! MODULE:  GDSWZD_LAMBERT_CONF_MOD  GDS WIZARD MODULE FOR LAMBERT CONFORMAL CONIC
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!           - COMPUTE MAP JACOBIANS.
!           - COMPUTE GRID BOX AREA.
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ03 AND GDSWZD03.
!   2015-09-17  GAYNO   RENAME AS "GDSWZD_LAMBERT_CONF_MOD"
!
! USAGE:  "USE GDSWZD_LAMBERT_CONF_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD_LAMBERT_CONF".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                        :: GDSWZD_LAMBERT_CONF

 REAL,           PARAMETER     :: PI=3.14159265358979
 REAL,           PARAMETER     :: DPR=180./PI

 INTEGER                       :: IROT

 REAL                          :: AN, DXS, DYS, H
 REAL                          :: RERTH

 CONTAINS

 SUBROUTINE GDSWZD_LAMBERT_CONF(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,FILL, &
                                XPTS,YPTS,RLON,RLAT,NRET, &
                                CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD_LAMBERT_CONF   GDS WIZARD FOR LAMBERT CONFORMAL CONICAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB 2 GRID DEFINITION
!           TEMPLATE (PASSED IN INTEGER FORM AS DECODED BY THE
!           NCEP G2 LIBRARY) AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           WORKS FOR LAMBERT CONFORMAL CONICAL PROJECTIONS.
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.
!           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS AND
!           GRID BOX AREAS FOR THIS GRID MAY BE RETURNED AS WELL.
!           TO COMPUTE THE VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS
!           'SROT' AND 'CROT'  MUST BE PRESENT.  TO COMPUTE THE MAP
!           JACOBIANS, THE OPTIONAL ARGUMENTS 'XLON', 'XLAT',
!           'YLON', 'YLAT' MUST BE PRESENT. TO COMPUTE THE GRID BOX
!           AREAS THE OPTIONAL ARGUMENT 'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   96-10-01  IREDELL  PROTECTED AGAINST UNRESOLVABLE POINTS
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
! 1999-04-27  GILBERT  CORRECTED MINOR ERROR CALCULATING VARIABLE AN
!                      FOR THE SECANT PROJECTION CASE (RLATI1.NE.RLATI2).
! 2012-08-14  GAYNO    FIX PROBLEM WITH SH GRIDS.  ENSURE GRID BOX
!                      AREA ALWAYS POSITIVE.
! 2015-01-21  GAYNO    MERGER OF GDSWIZ03 AND GDSWZD03.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAY
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAY.
!                      RENAME ROUTINE AS "GDSWZD_LAMBERT_CONF".
!
! USAGE:    CALL GDSWZD_LAMBERT_CONF(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,
!    &                               FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM  - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                MUST BE "30" FOR LAMBERT CONFORMAL GRIDS.
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE FOR SECTION
!                THREE:
!                 (1):  SHAPE OF EARTH, OCTET 15
!                 (2):  SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3):  SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4):  SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5):  SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6):  SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7):  SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!                 (8):  NUMBER OF POINTS ALONG X-AXIS, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG Y-AXIS, OCTS 35-38
!                 (10): LATITUDE OF FIRST POINT, OCTETS 39-42
!                 (11): LONGITUDE OF FIRST POINT, OCTETS 43-46
!                 (12): RESOLUTION OF COMPONENT FLAG, OCTET 47
!                 (13): LATITUDE WHERE GRID LENGTHS SPECIFIED,
!                       OCTETS 48-51
!                 (14): LONGITUDE OF MERIDIAN THAT IS PARALLEL TO
!                       Y-AXIS, OCTETS 52-55
!                 (15): X-DIRECTION GRID LENGTH, OCTETS 56-59
!                 (16): Y-DIRECTION GRID LENGTH, OCTETS 60-63
!                 (17): PROJECTION CENTER FLAG, OCTET 64
!                 (18): SCANNING MODE, OCTET 65
!                 (19): FIRST TANGENT LATITUDE FROM POLE, OCTETS 66-69
!                 (20): SECOND TANGENT LATITUDE FROM POLE, OCTETS 70-73
!                 (21): LATITUDE OF SOUTH POLE OF PROJECTION,
!                       OCTETS 74-77
!                 (22): LONGITUDE OF SOUTH POLE OF PROJECTION,
!                       OCTETS 78-81
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS (22) OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!                (PROPORTIONAL TO THE SQUARE OF THE MAP FACTOR)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,        INTENT(IN   ) :: IGDTMPL(IGDTLEN)
 INTEGER,        INTENT(IN   ) :: IOPT, NPTS
 INTEGER,        INTENT(  OUT) :: NRET
!
 REAL,           INTENT(IN   ) :: FILL
 REAL,           INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,           INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                       :: IM, JM, IPROJ, N
 INTEGER                       :: ISCAN, JSCAN
!
 LOGICAL                       :: LROT, LMAP, LAREA
!
 REAL                          :: ANTR, DI, DJ
 REAL                          :: DX, DY, DLON1
 REAL                          :: DE, DE2, DR2
 REAL                          :: HI, HJ, ECCEN_SQUARED
 REAL                          :: ORIENT, RLAT1, RLON1
 REAL                          :: RLATI1, RLATI2
 REAL                          :: XMAX, XMIN, YMAX, YMIN, XP, YP
 REAL                          :: DLON, DR
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THIS A LAMBERT CONFORMAL GRID?
 IF(IGDTNUM/=30)THEN
   CALL LAMBERT_CONF_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL EARTH_RADIUS(IGDTMPL,IGDTLEN,RERTH,ECCEN_SQUARED)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! ROUTINE ONLY WORKS FOR SPHERICAL EARTHS.
 IF(RERTH<0..OR.ECCEN_SQUARED/=0.0) THEN
   CALL LAMBERT_CONF_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IM=IGDTMPL(8)
 JM=IGDTMPL(9)
 RLAT1=FLOAT(IGDTMPL(10))*1.0E-6
 RLON1=FLOAT(IGDTMPL(11))*1.0E-6
 IROT=MOD(IGDTMPL(12)/8,2)
 ORIENT=FLOAT(IGDTMPL(14))*1.0E-6
 DX=FLOAT(IGDTMPL(15))*1.0E-3
 DY=FLOAT(IGDTMPL(16))*1.0E-3
 IPROJ=MOD(IGDTMPL(17)/128,2)
 ISCAN=MOD(IGDTMPL(18)/128,2)
 JSCAN=MOD(IGDTMPL(18)/64,2)
 RLATI1=FLOAT(IGDTMPL(19))*1.0E-6
 RLATI2=FLOAT(IGDTMPL(20))*1.0E-6
 H=(-1.)**IPROJ
 HI=(-1.)**ISCAN
 HJ=(-1.)**(1-JSCAN)
 DXS=DX*HI
 DYS=DY*HJ
 IF(RLATI1.EQ.RLATI2) THEN
   AN=SIN(RLATI1/DPR)
 ELSE
   AN=LOG(COS(RLATI1/DPR)/COS(RLATI2/DPR))/ &
      LOG(TAN((90-RLATI1)/2/DPR)/TAN((90-RLATI2)/2/DPR))
 ENDIF
 DE=RERTH*COS(RLATI1/DPR)*TAN((RLATI1+90)/2/DPR)**AN/AN
 IF(H*RLAT1.EQ.90) THEN
   XP=1
   YP=1
 ELSE
   DR=DE/TAN((RLAT1+90)/2/DPR)**AN
   DLON1=MOD(RLON1-ORIENT+180+3600,360.)-180
   XP=1-SIN(AN*DLON1/DPR)*DR/DXS
   YP=1+COS(AN*DLON1/DPR)*DR/DYS
 ENDIF
 ANTR=1/(2*AN)
 DE2=DE**2
 XMIN=0
 XMAX=IM+1
 YMIN=0
 YMAX=JM+1
 NRET=0
 IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
   LROT=.TRUE.
 ELSE
   LROT=.FALSE.
 ENDIF
 IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
   LMAP=.TRUE.
 ELSE
   LMAP=.FALSE.
 ENDIF
 IF(PRESENT(AREA))THEN
   LAREA=.TRUE.
 ELSE
   LAREA=.FALSE.
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! TRANSLATE GRID COORDINATES TO EARTH COORDINATES
 IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
!$OMP PARALLEL DO PRIVATE(N,DI,DJ,DR2,DR,DLON) REDUCTION(+:NRET) SCHEDULE(STATIC)
   DO N=1,NPTS
     IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
        YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
       DI=H*(XPTS(N)-XP)*DXS
       DJ=H*(YPTS(N)-YP)*DYS
       DR2=DI**2+DJ**2
       DR=SQRT(DR2)
       IF(DR2.LT.DE2*1.E-6) THEN
         RLON(N)=0.
         RLAT(N)=H*90.
       ELSE
         RLON(N)=MOD(ORIENT+1./AN*DPR*ATAN2(DI,-DJ)+3600,360.)
         RLAT(N)=(2*DPR*ATAN((DE2/DR2)**ANTR)-90)
       ENDIF
       NRET=NRET+1
       DLON=MOD(RLON(N)-ORIENT+180+3600,360.)-180
       IF(LROT)  CALL LAMBERT_CONF_VECT_ROT(CROT(N),SROT(N),DLON)
       IF(LMAP)  CALL LAMBERT_CONF_MAP_JACOB(RLAT(N),FILL, &
                                         XLON(N),XLAT(N),YLON(N),YLAT(N),DLON,DR)
       IF(LAREA) CALL LAMBERT_CONF_GRID_AREA(RLAT(N),FILL,AREA(N),DR)
     ELSE
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDIF
   ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
 ELSEIF(IOPT.EQ.-1) THEN
!$OMP PARALLEL DO PRIVATE(N,DR,DLON) REDUCTION(+:NRET) SCHEDULE(STATIC)
   DO N=1,NPTS
     IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND. &
                                    H*RLAT(N).NE.-90) THEN
       DR=H*DE*TAN((90-RLAT(N))/2/DPR)**AN
       DLON=MOD(RLON(N)-ORIENT+180+3600,360.)-180
       XPTS(N)=XP+H*SIN(AN*DLON/DPR)*DR/DXS
       YPTS(N)=YP-H*COS(AN*DLON/DPR)*DR/DYS
       IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
          YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
         NRET=NRET+1
         IF(LROT)  CALL LAMBERT_CONF_VECT_ROT(CROT(N),SROT(N),DLON)
         IF(LMAP)  CALL LAMBERT_CONF_MAP_JACOB(RLAT(N),FILL, &
                                           XLON(N),XLAT(N),YLON(N),YLAT(N),DLON,DR)
         IF(LAREA) CALL LAMBERT_CONF_GRID_AREA(RLAT(N),FILL,AREA(N),DR)
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ELSE
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDIF
   ENDDO
!$OMP END PARALLEL DO
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD_LAMBERT_CONF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE LAMBERT_CONF_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  LAMBERT_CONF_ERROR   ERROR HANDLER
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: UPON AN ERROR, THIS SUBPROGRAM ASSIGNS
!           A "FILL" VALUE TO THE OUTPUT FIELDS.

! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:    CALL LAMBERT_CONF_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!
!   INPUT ARGUMENT LIST:
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!   OUTPUT ARGUMENT LIST:
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER, INTENT(IN   ) :: IOPT, NPTS
!
 REAL,    INTENT(IN   ) :: FILL
 REAL,    INTENT(  OUT) :: RLAT(NPTS),RLON(NPTS)
 REAL,    INTENT(  OUT) :: XPTS(NPTS),YPTS(NPTS)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(IOPT>=0) THEN
   RLON=FILL
   RLAT=FILL
 ENDIF
 IF(IOPT<=0) THEN
   XPTS=FILL
   YPTS=FILL
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE LAMBERT_CONF_ERROR
!
 SUBROUTINE LAMBERT_CONF_VECT_ROT(CROT,SROT,DLON)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  LAMBERT_CONF_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                      LAMBERT CONFORMAL CONICAL
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A LAMBERT CONFORMAL CONICAL GRID
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "LAMBERT_CONF_VECT_ROT"
!
! USAGE:    CALL LAMBERT_CONF_VECT_ROT(CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     DLON
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
 REAL,           INTENT(   IN) :: DLON
 REAL,           INTENT(  OUT) :: CROT, SROT

 IF(IROT.EQ.1) THEN
   CROT=COS(AN*DLON/DPR)
   SROT=SIN(AN*DLON/DPR)
 ELSE
   CROT=1.
   SROT=0.
 ENDIF

 END SUBROUTINE LAMBERT_CONF_VECT_ROT
!
 SUBROUTINE LAMBERT_CONF_MAP_JACOB(RLAT,FILL,XLON,XLAT,YLON,YLAT,DLON,DR)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  LAMBERT_CONF_MAP_JACOB  MAP JACOBIANS FOR
!                                      LAMBERT CONFORMAL CONICAL
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A LAMBERT CONFORMAL CONICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "LAMBERT_CONF_MAP_JACOB"
!
! USAGE:  CALL LAMBERT_CONF_MAP_JACOB(RLAT,FILL,XLON,XLAT,YLON,YLAT,DLON,DR)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - GRID POINT LATITUDE IN DEGREES (REAL)
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!     DLON
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 IMPLICIT NONE

 REAL,           INTENT(IN   ) :: RLAT, FILL, DLON, DR
 REAL,           INTENT(  OUT) :: XLON, XLAT, YLON, YLAT
 REAL                          :: CLAT

 CLAT=COS(RLAT/DPR)
 IF(CLAT.LE.0.OR.DR.LE.0) THEN
   XLON=FILL
   XLAT=FILL
   YLON=FILL
   YLAT=FILL
 ELSE
   XLON=H*COS(AN*DLON/DPR)*AN/DPR*DR/DXS
   XLAT=-H*SIN(AN*DLON/DPR)*AN/DPR*DR/DXS/CLAT
   YLON=H*SIN(AN*DLON/DPR)*AN/DPR*DR/DYS
   YLAT=H*COS(AN*DLON/DPR)*AN/DPR*DR/DYS/CLAT
 ENDIF

 END SUBROUTINE LAMBERT_CONF_MAP_JACOB
!
 SUBROUTINE LAMBERT_CONF_GRID_AREA(RLAT,FILL,AREA,DR)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  LAMBERT_CONF_GRID_AREA  GRID BOX AREA FOR
!                                      LAMBERT CONFORMAL CONICAL
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A LAMBERT CONFORMAL CONICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "LAMBERT_CONF_GRID_AREA"
!
! USAGE:  CALL LAMBERT_CONF_GRID_AREA(RLAT,FILL,AREA)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE OF GRID POINT IN DEGREES (REAL)
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 IMPLICIT NONE

 REAL,           INTENT(IN   ) :: RLAT, DR
 REAL,           INTENT(IN   ) :: FILL
 REAL,           INTENT(  OUT) :: AREA

 REAL                          :: CLAT

 CLAT=COS(RLAT/DPR)
 IF(CLAT.LE.0.OR.DR.LE.0) THEN
   AREA=FILL
 ELSE
   AREA=RERTH**2*CLAT**2*ABS(DXS)*ABS(DYS)/(AN*DR)**2
 ENDIF

 END SUBROUTINE LAMBERT_CONF_GRID_AREA

 END MODULE GDSWZD_LAMBERT_CONF_MOD


program test_svd
use types, only: dp
use utils, only: assert
use linalg, only: svd, eye, diag
use constants, only : i_
implicit none

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: B(3, 2), s(2), sc(2), U(3, 3), Vtransp(2, 2), sigma(3, 2)
complex(dp) :: AC(3, 2), Uc(3, 3), Vtranspc(2, 2)

! test if the matrix' reconstruction from the SVD is faithful

AC = reshape([1+i_, i_, 0*i_, -i_, 2*i_, 2+0*i_], shape=[3,2], order=[2,1])
call svd(AC, sc, Uc, Vtranspc)
sigma = 0.0_dp
sigma(:2,:2) = diag(sc)
call assert(maxval(abs(AC - matmul(Uc, matmul(sigma, Vtranspc)))) < eps)

B = reshape([1, 2, 3, 4, 5, 6], shape=[3,2], order=[2,1])
call svd(B, s, U, Vtransp)
sigma(:2,:2) = diag(s)
call assert(maxval(abs(B - matmul(U, matmul(sigma, Vtransp)))) < eps)

end program


module gauss_legendre
!Computes the Gauss-Legendre nodes/weights.

implicit none

    real(8), parameter, private :: pi = 3.141592653589793238462643d0

contains

subroutine gauss_legendre_quadrature(n,a,b,x,w)
!Computes the requested Gauss-Legendre rule.
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    15 September 2010
!
!Author:
!
!    John Burkardt
!
!    Modified 5/14/2012 by Larz White, University of Idaho, Physics Department: Nuclear Theory Group.
!    I made it so when you call the program it outputs the arrays containing the nodes and weights;
!    instead of printing them to a file. I also got ride of all the extra stuff like outputting the
!    CPU time and string manipulation. Also, changed the function name from legendre_handle
!    to gauss_legendre_quadrature.
!
!    Modified 2/1/2013 by Larz White, University of Idaho, Physics Department: Nuclear Theory Group.
!    I went through every routine and made it more "Fortran 90" and less "Fortran 77". Also, the program
!    was using single precision intrinsic functions ( e.g. sin() ) instead of double precision intrinsic
!    functions ( e.g. dsin() ); I fixed that. Finally, I made it so it could be placed inside a module.

implicit none

    !n = Number of nodes/weights.
    !a = The lower integral bound.
    !b = The upper integral bound.
    !x = The nodes.
    !w = The weights.
    integer, intent(in) :: n
    real(8), intent(in) :: a,b
    real(8), dimension(n), intent(out) :: x,w

    call legendre_compute_glr(n,x,w)

    !Rescale the data.
    call rescale(n,a,b,x,w)

end subroutine

subroutine legendre_compute_glr(n,x,w)
!Legendre quadrature by the Glaser-Liu-Rokhlin method.
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    20 October 2009
!
!Author:
!
!    Original MATLAB version by Nick Hale.
!    FORTRAN90 version by John Burkardt.
!
!Reference:
!
!    Andreas Glaser, Xiangtao Liu, Vladimir Rokhlin,
!    A fast algorithm for the calculation of the roots of special functions,
!    SIAM Journal on Scientific Computing,
!    Volume 29, Number 4, pages 1420-1438, 2007.

implicit none

    !n = The order.
    !x,w = The abscissas/weights.
    integer, intent(in) :: n
    real(8), dimension(n), intent(out) :: x,w

    real(8):: p,pp

    !Get the value and derivative of the N-th Legendre polynomial at 0.0
    call legendre_compute_glr0(n,p,pp)

    !If n is odd, then zero is a root.
    if( mod(n,2) == 1 ) then

        x((n+1)/2) = 0.0d0
        w((n+1)/2) = pp

        !If n is even, we have to compute a root.

    else

        call legendre_compute_glr2(p,n,x((n/2)+1),w((n/2)+1))

    end if

    !Get the complete set of roots and derivatives.
    call legendre_compute_glr1(n,x,w)

    !Compute w.
    w(1:n) = 2.0d0/(1.0d0 - x(1:n))/(1.0d0 + x(1:n))/w(1:n)/w(1:n)

    w(1:n) = ( 2.0d0*w(1:n) )/sum(w(1:n))

end subroutine

subroutine legendre_compute_glr0(n,p,pp)
!Gets a starting value for the fast algorithm.
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    16 October 2009
!
!Author:
!
!    Original MATLAB version by Nick Hale.
!    FORTRAN90 version by John Burkardt.
!
!Reference:
!
!    Andreas Glaser, Xiangtao Liu, Vladimir Rokhlin,
!    A fast algorithm for the calculation of the roots of special functions,
!    SIAM Journal on Scientific Computing,
!    Volume 29, Number 4, pages 1420-1438, 2007.

implicit none

    !n = The order of the Legendre polynomial.
    !p,pp = The value of the N-th Legendre polynomial and its derivative at 0.
    integer, intent(in) :: n
    real(8), intent(out) :: p,pp

    integer :: k
    real(8) :: pm1,pm2,ppm1,ppm2,rk

    !Compute coefficients of P_m(0), Pm'(0), m = 0,..,N
    pm2 = 0.0d0
    pm1 = 1.0d0
    ppm2 = 0.0d0
    ppm1 = 0.0d0

    do k = 0,n-1

        rk = dble(k)
        p = (-rk*pm2)/(rk + 1.0d0)
        pp = ( (2.0d0*rk + 1.0d0)*pm1 - rk*ppm2 )/(rk + 1.0d0)
        pm2 = pm1
        pm1 = p
        ppm2 = ppm1
        ppm1 = pp

    enddo

end subroutine

subroutine legendre_compute_glr1(n,x,w)
!Gets the complete set of Legendre points and weights.
!
!Discussion:
!
!    This routine requires that a starting estimate be provided for one
!    root and its derivative.  This information will be stored in entry
!    (n+1)/2 if n is odd, or n/2 if n is even, of x and w.
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    15 November 2009
!
!Author:
!
!    Original C++ version by Nick Hale.
!    FORTRAN90 version by John Burkardt.
!
!Reference:
!
!    Andreas Glaser, Xiangtao Liu, Vladimir Rokhlin,
!    A fast algorithm for the calculation of the roots of special functions,
!    SIAM Journal on Scientific Computing,
!    Volume 29, Number 4, pages 1420-1438, 2007.

implicit none

    !n = The order of the Legendre polynomial.
    !x = On input, a starting value has been set in one entry.
    !    On output, the roots of the Legendre polynomial.
    !w = On input, a starting value has been set in one entry.
    !    On output, the derivatives of the Legendre polynomial at the zeros.
    integer, intent(in) :: n
    real(8), dimension(n), intent(inout) ::x,w

    !m = The number of terms in the Taylor expansion.
    integer, parameter :: m = 30
    integer :: j,k,l,n2,s
    real(8) :: dk,dn,h,xp
    real(8), dimension(m+1) :: up
    real(8), dimension(m+2) :: u

    if( mod(n,2) == 1 ) then

        n2 = ( (n - 1)/2 ) - 1
        s = 1

    else

        n2 = (n/2) - 1
        s = 0

    endif

    dn = dble(n)

    do j = n2+1,n-2

        xp = x(j+1)

        h = rk2_leg(pi/2.0d0,(-pi)/2.0d0,xp,n) - xp

        u(1) = 0.0d0
        u(2) = 0.0d0
        u(3) = w(j+1)

        up(1) = 0.0d0
        up(2) = u(3)

        do k = 0,m-2

            dk = dble(k)

            u(k+4) =(2.0d0*xp*(dk + 1.0d0)*u(k+3) + ( dk*(dk + 1.0d0) - dn*(dn + 1.0d0) )&
            &*u(k+2)/(dk + 1.0d0))/(1.0d0 - xp)/(1.0d0 + xp)/(dk + 2.0d0)

            up(k+3) = (dk + 2.0d0)*u(k+4)

        enddo

        do l = 0,4

            h = h - ( ts_mult(u,h,m)/ts_mult(up,h,m-1) )

        enddo

        x(j+2) = xp + h
        w(j+2) = ts_mult(up,h,m-1)

    end do

    do k = 0,n2+s

        x(k+1) = -x(n-1-k+1)
        w(k+1) = w(n-1-k+1)

    enddo

end subroutine

subroutine legendre_compute_glr2(pn0,n,x1,d1)
!Finds the first real root.
!
!Discussion:
!
!    This routine is only called if n is even.
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    20 October 2009
!
!Author:
!
!    Original MATLAB version by Nick Hale.
!    FORTRAN90 version by John Burkardt.
!
!Reference:
!
!    Andreas Glaser, Xiangtao Liu, Vladimir Rokhlin,
!    A fast algorithm for the calculation of the roots of special functions,
!    SIAM Journal on Scientific Computing,
!    Volume 29, Number 4, pages 1420-1438, 2007.

implicit none

    !n = The order of the Legendre polynomial.
    !pn0 = The value of the N-th Legendre polynomial at 0.
    !x1 = The first real root.
    !d1 = The derivative at x1.
    integer, intent(in) :: n
    real(8), intent(in) :: pn0
    real(8), intent(out) :: x1,d1

    !m = The number of terms in the Taylor expansion.
    integer, parameter :: m = 30
    integer :: i,k,kk,l
    real(8) :: eps,rk,rn,scaling,step,theta
    real(8), dimension(m+1) :: u,up,x1k

    k = (n + 1)/2

    theta = pi*dble(4*k - 1)/dble(4*n + 2)

    x1 = (   1.0d0 - (dble(n - 1)/dble(8*n*n*n)) - (1.0d0/dble(384*n*n*n*n))&
    &*(  39.0d0 - ( 28.0d0/(dsin(theta)*dsin(theta)) )  )   )*dcos(theta)

    !Scaling.
    scaling = 1.0d0/x1

    !Recurrence relation for Legendre polynomials.
    u(1:m+1) = 0.0d0
    up(1:m+1) = 0.0d0

    rn = dble(n)

    u(1) = pn0

    do k = 0,m-2,2

        rk = dble(k)

        u(k+3) = ( rk*(rk + 1.0d0) - rn*(rn + 1.0d0) )*u(k+1)/(rk + 1.0d0)/(rk + 2.0d0)/scaling/scaling
        up(k+2) = (rk + 2.0d0)*u(k+3)*scaling

    enddo

    !Flip for more accuracy in inner product calculation
    u = u(m+1:1:-1)
    up = up(m+1:1:-1)

    x1k(1:m+1) = 1.0d0

    step = huge(0.0d0)
    l = 0

    !Newton iteration.
    eps = epsilon (0.0d0)

    do while ( eps < dabs(step) .and. l < 10 )

        l = l + 1
        step = dot_product(u(1:m+1),x1k(1:m+1))/dot_product(up(1:m+1),x1k(1:m+1))
        x1 = x1 - step
        x1k(1) = 1.0d0
        x1k(2) = scaling*x1

        do kk = 3,m+1

            x1k(kk) = x1k(kk-1)*scaling*x1

        enddo

        x1k(1:m+1) = x1k(m+1:1:-1)

    enddo

    d1 = dot_product(up(1:m+1),x1k(1:m+1))

end subroutine

subroutine rescale(n,a,b,x,w)
!Rescales a Legendre quadrature rule from (-1,1) to (a,b).
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    18 October 2009
!
!Author:
!
!    Original MATLAB version by Nick Hale.
!    FORTRAN90 version by John Burkardt.
!
!Reference:
!
!    Andreas Glaser, Xiangtao Liu, Vladimir Rokhlin,
!    A fast algorithm for the calculation of the roots of special functions,
!    SIAM Journal on Scientific Computing,
!    Volume 29, Number 4, pages 1420-1438, 2007.

implicit none

    !n = The order.
    !a,b = The endpoints of the new interval.
    !x = On input, the abscissas for (-1,1). On output, the abscissas for (a,b).
    !w = On input, the weights for (-1,1). On output, the weights for (a,b).
    integer, intent(in) :: n
    real(8), intent(in) :: a,b
    real(8), dimension(n), intent(inout) :: x,w

    x(1:n) = ( (a + b) + (b - a)*x(1:n) )/2.0d0
    w(1:n) = ( (b - a)*w(1:n) )/2.0d0

end subroutine

real(8) function rk2_leg(t1,t2,x,n)
!Advances the value of x(t) using a Runge-Kutta method. The output is the value of x at t2.
!
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    15 November 2009
!
!Author:
!
!    Original C++ version by Nick Hale.
!    FORTRAN90 version by John Burkardt.

implicit none

    !n = The number of steps to take.
    !t1,t2 = The range of the integration interval.
    !x = The value of x at t1.
    integer, intent(in) :: n
    real(8), intent(in) :: t1,t2,x

    integer, parameter :: m = 10
    integer :: j
    real(8) :: f,h,k1,k2,snn1,t,x2

    x2 = x

    h = (t2 - t1)/dble(m)
    snn1 = dsqrt( dble(n*(n + 1)) )
    t = t1

    do j = 0,m-1

        f = (1.0d0 - x2)*(1.0d0 + x2)
        k1 = (-h*f)/( (snn1*dsqrt(f)) - (0.5d0*x2*dsin(2.0d0*t)) )
        x2 = x2 + k1

        t = t + h

        f = (1.0d0 - x2)*(1.0d0 + x2)
        k2 = (-h*f)/( (snn1*dsqrt(f)) - (0.5d0*x2*dsin(2.0d0*t)) )
        x2 = x2 + 0.5d0*(k2 - k1)

    enddo

    rk2_leg = x2

end function

real(8) function ts_mult(u,h,n)
!Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!Modified:
!
!    15 November 2009
!
!Author:
!
!    Original C++ version by Nick Hale.
!    FORTRAN90 version by John Burkardt.

implicit none

    integer, intent(in) :: n
    real(8), intent(in) :: h
    real(8), dimension(n+1), intent(in) :: u

    integer :: k
    real(8) :: hk,ts

    ts = 0.0d0
    hk = 1.0d0
    do k = 1,n

        ts = ts + ( u(k+1)*hk )
        hk = hk*h

    enddo

    ts_mult = ts

end function

end module


! Daniel R. Reynolds
! SMU Mathematics
! Math 4370/6370
! 7 February 2015
!-----------------------------------------------------------------
! Description:
!    Evolves the first-order 2D wave equations in time.
!=================================================================

program advection
  !===============================================================
  ! inclusions
  implicit none

  ! interfaces
  interface
     subroutine output(u,t,nx,ny,noutput)
       integer, intent(in) :: nx, ny, noutput
       real*8,  intent(in) :: t, u(nx,ny)
     end subroutine output
     subroutine initialize(u,v1,v2,v3,c,dx,dy,nx,ny)
       integer, intent(in)  :: nx, ny
       real*8,  intent(in)  :: c, dx, dy
       real*8, dimension(nx,ny), intent(out) :: u, v1, v2, v3
     end subroutine initialize
  end interface

  ! declarations
  integer :: nx, ny, nt, i, j, noutput, it
  real*8 :: tstop, c, dtoutput, dx, dy, t, toutput, dt
  real*8 :: stime, ftime, v2_E, v2_W, v3_N, v3_S, v1_W, v1_E, v1_S, v1_N
  real*8 :: runtime, iotime, inittime
  real*8, dimension(:,:), allocatable :: u, v1, v2, v3
  namelist /inputs/ nx, ny, nt, tstop, c, dtoutput

  ! internals

  call get_time(stime)
  ! read problem parameters from input file (should be in this order):
  !    nx - number of nodes in x-direction
  !    ny - number of nodes in y-direction
  !    nt - number of time steps
  !    tstop - final time (will stop at nt or stop, whichever is 1st)
  !    c - wave speed
  !    dtoutput - time frequency for outputting solutions
  open(100,file='input.txt')
  read(100,inputs)
  close(100)
  print *, '  '
  print *, 'Running wave problem:'
  print *, '   nx =',nx,',  ny =',ny
  print *, '   nt =',nt,',  tstop =',tstop
  print *, '   c =',c
  print *, '   dtoutput =',dtoutput
  print *, '  '
  call get_time(ftime)
  iotime = ftime-stime

  ! allocate arrays
  call get_time(stime)
  allocate(u(nx,ny),v1(nx,ny),v2(nx,ny),v3(nx,ny))

  ! set grid spacing
  dx = 1.d0/nx
  dy = 1.d0/ny

  ! set initial conditions
  call initialize(u,v1,v2,v3,c,dx,dy,nx,ny)
  call get_time(ftime)
  inittime = ftime-stime

  ! set initial time, output initial solution
  t = 0.d0
  toutput = 0.d0
  noutput = 0
  print '(A,i4,A,i8,A,es9.2)', 'writing output file ',noutput, &
       ', step = ',0,',  t =',t
  call get_time(stime)
  call output(u,t,nx,ny,noutput)
  call get_time(ftime)
  iotime = iotime+ftime-stime

  ! set time step
  dt = min(dx/c/5.d1, dy/c/5.d1)

  ! start time stepping
  runtime = 0.d0
  do it=1,nt

     ! start timer
     call get_time(stime)

     ! first update v1 to get to half time step
     !    get relevant values for this location
     do j=1,ny
        do i=1,nx

           ! access relevant components of v2 and v3
           if (i==nx) then
              v2_E = v2(1,j)
           else
              v2_E = v2(i+1,j)
           end if
           v2_W = v2(i,j)
           if (j==ny) then
              v3_N = v3(i,1)
           else
              v3_N = v3(i,j+1)
           end if
           v3_S = v3(i,j)

           ! update v1
           v1(i,j) = v1(i,j) + c*dt/dx*(v2_E - v2_W) + c*dt/dy*(v3_N - v3_S)

        end do
     end do

     ! next update v2 & v3 to get to full time step
     !    get relevant values for this location
     do j=1,ny
        do i=1,nx

           ! access relevant components of v1
           if (i==1) then
              v1_W = v1(nx,j)
           else
              v1_W = v1(i-1,j)
           end if
           v1_E = v1(i,j)
           if (j==1) then
              v1_S = v1(i,ny)
           else
              v1_S = v1(i,j-1)
           end if
           v1_N = v1(i,j)

           ! update v2 and v3
           v2(i,j) = v2(i,j) + c*dt/dx*(v1_E - v1_W)
           v3(i,j) = v3(i,j) + c*dt/dy*(v1_N - v1_S)

        end do
     end do

     ! update and plot solution
     u = u + dt*v1

     ! update time
     t = t + dt
     call get_time(ftime)
     runtime = runtime+ftime-stime

     ! stop simulation if we've reached tstop
     if (t >= tstop)  exit

     ! output solution periodically
     if (abs(t-toutput-dtoutput) <= 1.e-14) then
        call get_time(stime)
        toutput = t
        noutput = noutput+1
        print '(A,i4,A,i8,A,es9.2)', 'writing output file ',noutput, &
             ', step = ',it,',  t =',t
        call output(u,t,nx,ny,noutput)
        call get_time(ftime)
        iotime = iotime+ftime-stime
     end if

  end do

  ! output final solution
  call get_time(stime)
  toutput = t
  noutput = noutput+1
  print '(A,i4,A,i8,A,es9.2)', 'writing output file ',noutput, &
       ', step = ',it,',  t =',t
  call output(u,t,nx,ny,noutput)
  call get_time(ftime)
  iotime = iotime+ftime-stime

  ! output runtime
  print *, ' total initialization time = ', inittime
  print *, ' total input/output time   = ', iotime
  print *, ' total simulation time     = ', runtime

  ! free memory
  deallocate(u,v1,v2,v3)

  ! end program
end program advection
!=================================================================


! Mikayla Webber
! 4670 Numerical Analysis
! Homework IVP Due 12.6.17

program extrapall
  implicit none
  integer :: i, neq, nsteps
  double precision, allocatable, dimension(:,:) :: archive
  double precision, allocatable, dimension(:) :: f, t, u, yin, yout
  double precision :: tin, tout, dt, a, b, x, y, xactual, yactual, pi
  double precision, allocatable, dimension(:) :: fi, fim1, fim2, fim3, fim4, fip1

  neq = 2
  nsteps = 1000
  pi = acos(-1.0d0)

  allocate(yin(neq), yout(neq), u(neq), t(0:nsteps), f(neq), archive(neq,0:nsteps))
  allocate(fi(neq), fim1(neq), fim2(neq), fim3(neq), fim4(neq), fip1(neq))

  a = 0.0d0
  b = (24.0d0 * pi)
  dt = (b - a) / dble(nsteps)

  print*, 'starting loop'
  do i = 0, nsteps
    t(i) = a + dble(i) * dt
  end do

  archive(:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 0.0d0 /)

  do i = 0, (nsteps - 1)
    tin = t(i)
    tout = t(i + 1)
    yin = archive(:,i)
    call extrapolate(neq, tin, tout, yin, yout)
    archive(:,i+1) = yout
  end do

  print*, 'writing "out4"'
  open(unit=8, file='out4', status='replace')

  do i = 0, nsteps
    write(8,*) 1.0d0 / archive(1,i) * cos(t(i)), 1.0d0 / archive(1,i) * sin(t(i))
  end do

  close(8)

  print*, 'writing "main4error"'
  open(unit=8, file='main4error', status='replace')

  do i = 0, nsteps
    x = archive(1,i)
    y = archive(2,i)
    xactual = cos(t(i))
    yactual = t(i) / (1 + log(t(i)))
    write(8,*) i, sqrt((x - xactual)**2 + (y - yactual)**2)
  end do

  close(8)

  deallocate(yin, yout, u, archive, t, f, fi, fim1, fim2, fim3, fim4, fip1)

  stop
end program extrapall

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

subroutine extrapolate(neq, tin,tout, yin, yout)
  implicit none
  integer, intent(in) :: neq
  integer :: i, k, nrich, nsteps
  double precision :: yout(neq), bot
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision, allocatable, dimension(:,:,:) :: table

  nrich = 10
  nsteps = 1
  allocate(table(0:nrich,0:nrich,neq))

  do i = 0, nrich
    call euler(neq, tin,tout, nsteps, yin, yout)
    table(i,0,:) = yout
    nsteps = (nsteps * 2)
  end do

  do k = 1, nrich
    bot = (2.0d0**k - 1.0d0)
    do i = k, nrich
      table(i,k,:) = table(i,k-1,:) + (table(i,k-1,:) - table(i-1,k-1,:)) / bot
    end do
  end do

  yout = table(nrich,nrich,:)

  return
end

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

subroutine euler(neq, tin, tout, nsteps, yin, yout)
  implicit none
  integer :: i
  integer, intent(in) :: neq, nsteps
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision :: dt, f(neq), yout(neq)

  yout = yin
  dt = ((tout - tin) / dble(nsteps))

  do i = 0, (nsteps - 1)
    call computef(neq, tin + dble(i) * dt, yout, f)
    yout = (yout + dt * f)
  end do

  return
end

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

subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: f(neq)
  double precision, intent(in) :: t, y(neq)

  f(1) = y(2)
  f(2) = -y(1) + 1.0d0

  return
end


!
! 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
!

program test_f90_intrinsics
integer, parameter :: n = 4
integer, parameter :: m = 3
integer, parameter :: l = 5
!
integer, parameter :: ntests = 44
logical, dimension(ntests) :: checks
integer ic
!
integer, dimension(n,m,l) :: ia
logical, dimension(n,m,l) :: la
real,    dimension(n,m,l) :: ra
!
! Answers
logical lan1(m,l), lan2(n,l), lan3(n,m)
logical lal1(m,l), lal2(n,l), lal3(n,m)
integer ico1(m,l), ico2(n,l), ico3(n,m)
integer ima1(m,l), ima2(n,l), ima3(n,m)
integer imi1(m,l), imi2(n,l), imi3(n,m)
real    rma1(m,l), rma2(n,l), rma3(n,m)
real    rmi1(m,l), rmi2(n,l), rmi3(n,m)
integer ipr1(m,l), ipr2(n,l), ipr3(n,m)
real    rpr1(m,l), rpr2(n,l), rpr3(n,m)
integer iad1(m,l), iad2(n,l), iad3(n,m)
real    rad1(m,l), rad2(n,l), rad3(n,m)
!
! Checks
logical clan1(m,l), clan2(n,l), clan3(n,m)
logical clal1(m,l), clal2(n,l), clal3(n,m)
integer cico1(m,l), cico2(n,l), cico3(n,m), cic
integer cima1(m,l), cima2(n,l), cima3(n,m), cma
integer cimi1(m,l), cimi2(n,l), cimi3(n,m), cmi
integer cipr1(m,l), cipr2(n,l), cipr3(n,m), cpr
integer ciad1(m,l), ciad2(n,l), ciad3(n,m), cad

integer iexp(ntests)
!
! Input data
data ia /  1,  4,  7, 10,  2,  5,  8, 11,  3,  6,  9, 12, &
           0,  3,  6,  9,  1,  4,  7, 10,  2,  5,  8, 11, &
          -1,  2,  5,  8,  0,  3,  6,  9,  1,  4,  7, 10, &
          -2,  1,  4,  7, -1,  2,  5,  8,  0,  3,  6,  9, &
          -3,  0,  3,  6, -2,  1,  4,  7, -1,  2,  5,  8 /
!
! Result check data
data clan1 / T, T, T, T, T, T, T, T, T, T, T, T, F, T, T /
data clan2 / F, F, T, T, F, F, T, T, F, F, T, T, F, F, F, T, F, F, F, T /
data clan3 / F, F, T, T, F, F, T, T, F, F, T, T /
!
data clal1 / F, F, F, F, F, F, F, F, F, F, F, F, F, F, F /
data clal2 / F, F, T, T, F, F, F, T, F, F, F, T, F, F, F, T, F, F, F, F /
data clal3 / F, F, F, F, F, F, F, T, F, F, F, T /
!
data cic / 20 /
data cico1 / 2, 2, 2, 1, 2, 2, 1, 1, 2, 1, 1, 1, 0, 1, 1 /
data cico2 / 0, 0, 3, 3, 0, 0, 2, 3, 0, 0, 1, 3, 0, 0, 0, 3, 0, 0, 0, 2 /
data cico3 / 0, 0, 1, 4, 0, 0, 2, 5, 0, 0, 3, 5 /
!
data cma / 12 /
data cima1 /10,11,12, 9,10,11, 8, 9,10, 7, 8, 9, 6, 7, 8 /
data cima2 / 3, 6, 9,12, 2, 5, 8,11, 1, 4, 7,10, 0, 3, 6, 9,-1, 2, 5, 8 /
data cima3 / 1, 4, 7,10, 2, 5, 8,11, 3, 6, 9,12 /
!
data cmi / -3 /
data cimi1 / 1, 2, 3, 0, 1, 2,-1, 0, 1,-2,-1, 0,-3,-2,-1 /
data cimi2 / 1, 4, 7,10, 0, 3, 6, 9,-1, 2, 5, 8,-2, 1, 4, 7,-3, 0, 3, 6 /
data cimi3 /-3, 0, 3, 6,-2, 1, 4, 7,-1, 2, 5, 8 /
!
data cpr / 0 /
data cipr1 / 280, 880, 1944, 0, 280, 880, -80, 0, 280, &
             -56, -80, 0, 0, -56, -80 /
data cipr2 / 6, 120, 504, 1320, 0, 60, 336, 990, 0, 24, 210, 720, &
             0, 6, 120, 504, -6, 0, 60, 336 /
data cipr3 / 0, 0, 2520, 30240, 0, 120, 6720, 55440, 0, 720, 15120, 95040 /
!
data cad / 270 /
data ciad1 / 22, 26, 30, 18, 22, 26, 14, 18, 22, 10, 14, 18, 6, 10, 14 /
data ciad2 / 6, 15, 24, 33, 3, 12, 21, 30, 0, 9, 18, 27, &
             -3, 6, 15, 24, -6, 3, 12, 21 /
data ciad3 / -5, 10, 25, 40, 0, 15, 30, 45, 5, 20, 35, 50 /
!
!
!
! Create real and logical arrays
ra = real(ia)
la = ra .gt. 6.0
ic = 1
!
! Do the tests
lan1 = any(la,dim=1)
lan2 = any(la,dim=2)
lan3 = any(la,dim=3)
checks(ic) = .not. any(la); ic = ic + 1
checks(ic) = any(clan1 .neqv. lan1); ic = ic + 1
checks(ic) = any(clan2 .neqv. lan2); ic = ic + 1
checks(ic) = any(clan3 .neqv. lan3); ic = ic + 1
!
lal1 = all(la,dim=1)
lal2 = all(la,dim=2)
lal3 = all(la,dim=3)
checks(ic) = all(la); ic = ic + 1
checks(ic) = any(clal1 .neqv. lal1); ic = ic + 1
checks(ic) = any(clal2 .neqv. lal2); ic = ic + 1
checks(ic) = any(clal3 .neqv. lal3); ic = ic + 1
!
ico1 = count(la,dim=1)
ico2 = count(la,dim=2)
ico3 = count(la,dim=3)
checks(ic) = ((cic - count(la)) .ne. 0); ic = ic + 1
checks(ic) = any((cico1 - ico1) .ne. 0); ic = ic + 1
checks(ic) = any((cico2 - ico2) .ne. 0); ic = ic + 1
checks(ic) = any((cico3 - ico3) .ne. 0); ic = ic + 1
!
ima1 = maxval(ia,dim=1)
ima2 = maxval(ia,dim=2)
ima3 = maxval(ia,dim=3)
checks(ic) = ((cma - maxval(ia)).ne. 0); ic = ic + 1
checks(ic) = any((cima1 - ima1) .ne. 0); ic = ic + 1
checks(ic) = any((cima2 - ima2) .ne. 0); ic = ic + 1
checks(ic) = any((cima3 - ima3) .ne. 0); ic = ic + 1
!
imi1 = minval(ia,dim=1)
imi2 = minval(ia,dim=2)
imi3 = minval(ia,dim=3)
checks(ic) = ((cmi - minval(ia)).ne. 0); ic = ic + 1
checks(ic) = any((cimi1 - imi1) .ne. 0); ic = ic + 1
checks(ic) = any((cimi2 - imi2) .ne. 0); ic = ic + 1
checks(ic) = any((cimi3 - imi3) .ne. 0); ic = ic + 1
!
rma1 = maxval(ra,dim=1)
rma2 = maxval(ra,dim=2)
rma3 = maxval(ra,dim=3)
checks(ic) = ((real(cma) - maxval(ra)).ne. 0); ic = ic + 1
checks(ic) = any((real(cima1) - rma1) .ne. 0); ic = ic + 1
checks(ic) = any((real(cima2) - rma2) .ne. 0); ic = ic + 1
checks(ic) = any((real(cima3) - rma3) .ne. 0); ic = ic + 1
!
rmi1 = minval(ra,dim=1)
rmi2 = minval(ra,dim=2)
rmi3 = minval(ra,dim=3)
checks(ic) = ((real(cmi) - minval(ra)).ne. 0); ic = ic + 1
checks(ic) = any((real(cimi1) - rmi1) .ne. 0); ic = ic + 1
checks(ic) = any((real(cimi2) - rmi2) .ne. 0); ic = ic + 1
checks(ic) = any((real(cimi3) - rmi3) .ne. 0); ic = ic + 1
!
ipr1 = product(ia,dim=1)
ipr2 = product(ia,dim=2)
ipr3 = product(ia,dim=3)
checks(ic) = ((cpr - product(ia)).ne. 0); ic = ic + 1
checks(ic) = any((cipr1 - ipr1) .ne. 0); ic = ic + 1
checks(ic) = any((cipr2 - ipr2) .ne. 0); ic = ic + 1
checks(ic) = any((cipr3 - ipr3) .ne. 0); ic = ic + 1
!
rpr1 = product(ra,dim=1)
rpr2 = product(ra,dim=2)
rpr3 = product(ra,dim=3)
checks(ic) = ((real(cpr) - product(ra)).ne. 0); ic = ic + 1
checks(ic) = any((real(cipr1) - rpr1) .ne. 0); ic = ic + 1
checks(ic) = any((real(cipr2) - rpr2) .ne. 0); ic = ic + 1
checks(ic) = any((real(cipr3) - rpr3) .ne. 0); ic = ic + 1
!
iad1 = sum(ia,dim=1)
iad2 = sum(ia,dim=2)
iad3 = sum(ia,dim=3)
checks(ic) = ((cad - sum(ia)).ne. 0); ic = ic + 1
checks(ic) = any((ciad1 - iad1) .ne. 0); ic = ic + 1
checks(ic) = any((ciad2 - iad2) .ne. 0); ic = ic + 1
checks(ic) = any((ciad3 - iad3) .ne. 0); ic = ic + 1
!
rad1 = sum(ra,dim=1)
rad2 = sum(ra,dim=2)
rad3 = sum(ra,dim=3)
checks(ic) = ((real(cad) - sum(ra)) .ne. 0.0); ic = ic + 1
checks(ic) = any((real(ciad1) - rad1) .ne. 0.0); ic = ic + 1
checks(ic) = any((real(ciad2) - rad2) .ne. 0.0); ic = ic + 1
checks(ic) = any((real(ciad3) - rad3) .ne. 0.0); ic = ic + 1
!
if ((ic-1) .ne. ntests) print *,"Error in number of tests!"
!
do i = 1, ntests
   iexp(i) = 0
end do

call check(checks,iexp,ntests)

!
end


*----------------------------------------------------------------------*
      subroutine mgs(xmat,smat,ndim,xscr)
*----------------------------------------------------------------------*
*     modified Gram-Schmidt orthonormalization
*     adapted from jeppe olsen's mgs3() routine (LUCIA)
*
*     input:  smat(ndim,ndim) - overlap matrix of vectors <v_i|v_j>
*     output: xmat(ndim,ndim) - orthogonalization matrix:
*                               |w_i> = |v_j> x(j,i)
*     scratch: xscr(2*ndim)   - both S*v and S^T*v needed if S asymm.
*
*     zero column vectors may be returned in case of linear dependency
*
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     ndim
      real(8), intent(in) ::
     &     smat(ndim,ndim)
      real(8), intent(out) ::
     &     xmat(ndim,ndim)
      real(8), intent(inout) ::
     &     xscr(2*ndim)

      integer ::
     &     ii, jj
      real(8) ::
     &     xnorm, factor, xsx

      real(8), external ::
     &     ddot

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'mgs')
        write(lulog,*) 'overlap-matrix:'
        call wrtmat2(smat,ndim,ndim,ndim,ndim)
      end if

      ! set unit matrix
      xmat(1:ndim,1:ndim) = 0d0
      do ii = 1, ndim
        xmat(ii,ii) = 1d0
        ! negative norms are suspicious
        if (smat(ii,ii).lt.0d0) call warn('mgs','negative norm?!')
      end do

      ! loop over vectors
      do ii = 1, ndim
        call dgemv('t',ndim,ndim,1d0,smat,ndim,xmat(1,ii),1,
     &                 0d0,xscr,1)
        call dgemv('n',ndim,ndim,1d0,smat,ndim,xmat(1,ii),1,
     &                 0d0,xscr(ndim+1),1)
        xnorm = ddot(ndim,xmat(1,ii),1,xscr(ndim+1),1)
        if (xnorm.lt.epsilon(1d-6)) then
          xmat(1:ndim,ii) = 0d0
          cycle
        else
          factor = 1d0/sqrt(xnorm)
        end if
        xmat(1:ndim,ii) = factor*xmat(1:ndim,ii)
        xscr(1:ndim) = factor * xscr(1:ndim)

        ! subtract xmat(1:ndim,ii) from all remaining vectors
        do jj = ii+1, ndim
          xsx = ddot(ndim,xscr,1,xmat(1,jj),1)
          xmat(1:ndim,jj) = xmat(1:ndim,jj) - xsx*xmat(1:ndim,ii)
        end do
c dbg
c        write(lulog,*) 'updated X-matrix:'
c        call wrtmat2(xmat,ndim,ndim,ndim,ndim)
c dbg

      end do

      if (ntest.ge.100) then
        write(lulog,*) 'trafo-matrix:'
        call wrtmat2(xmat,ndim,ndim,ndim,ndim)
      end if

      return
      end


*DECK ZBIRY
      SUBROUTINE ZBIRY (ZR, ZI, ID, KODE, BIR, BII, IERR)
C***BEGIN PROLOGUE  ZBIRY
C***PURPOSE  Compute the Airy function Bi(z) or its derivative dBi/dz
C            for complex argument z.  A scaling option is available
C            to help avoid overflow.
C***LIBRARY   SLATEC
C***CATEGORY  C10D
C***TYPE      COMPLEX (CBIRY-C, ZBIRY-C)
C***KEYWORDS  AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD,
C             BESSEL FUNCTION OF ORDER TWO THIRDS
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C                      ***A DOUBLE PRECISION ROUTINE***
C         On KODE=1, ZBIRY computes the complex Airy function Bi(z)
C         or its derivative dBi/dz on ID=0 or ID=1 respectively.
C         On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or
C         exp(abs(Re(zeta)))*dBi/dz is provided to remove the
C         exponential behavior in both the left and right half planes
C         where zeta=(2/3)*z**(3/2).
C
C         The Airy functions Bi(z) and dBi/dz are analytic in the
C         whole z-plane, and the scaling option does not destroy this
C         property.
C
C         Input
C           ZR     - DOUBLE PRECISION real part of argument Z
C           ZI     - DOUBLE PRECISION imag part of argument Z
C           ID     - Order of derivative, ID=0 or ID=1
C           KODE   - A parameter to indicate the scaling option
C                    KODE=1  returns
C                            BI=Bi(z)  on ID=0
C                            BI=dBi/dz on ID=1
C                            at z=Z
C                        =2  returns
C                            BI=exp(abs(Re(zeta)))*Bi(z)  on ID=0
C                            BI=exp(abs(Re(zeta)))*dBi/dz on ID=1
C                            at z=Z where zeta=(2/3)*z**(3/2)
C
C         Output
C           BIR    - DOUBLE PRECISION real part of result
C           BII    - DOUBLE PRECISION imag part of result
C           IERR   - Error flag
C                    IERR=0  Normal return     - COMPUTATION COMPLETED
C                    IERR=1  Input error       - NO COMPUTATION
C                    IERR=2  Overflow          - NO COMPUTATION
C                            (Re(Z) too large with KODE=1)
C                    IERR=3  Precision warning - COMPUTATION COMPLETED
C                            (Result has less than half precision)
C                    IERR=4  Precision error   - NO COMPUTATION
C                            (Result has no precision)
C                    IERR=5  Algorithmic error - NO COMPUTATION
C                            (Termination condition not met)
C
C *Long Description:
C
C         Bi(z) and dBi/dz are computed from I Bessel functions by
C
C                Bi(z) =  c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) )
C               dBi/dz =  c*   z   *( I(-2/3,zeta) + I(2/3,zeta) )
C                    c =  1/sqrt(3)
C                 zeta =  (2/3)*z**(3/2)
C
C         when abs(z)>1 and from power series when abs(z)<=1.
C
C         In most complex variable computation, one must evaluate ele-
C         mentary functions.  When the magnitude of Z is large, losses
C         of significance by argument reduction occur.  Consequently, if
C         the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR),
C         then losses exceeding half precision are likely and an error
C         flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is
C         double precision unit roundoff limited to 18 digits precision.
C         Also, if the magnitude of ZETA is larger than U2=0.5/UR, then
C         all significance is lost and IERR=4.  In order to use the INT
C         function, ZETA must be further restricted not to exceed
C         U3=I1MACH(9)=LARGEST INTEGER.  Thus, the magnitude of ZETA
C         must be restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2,
C         and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single
C         precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision.
C         This makes U2 limiting is single precision and U3 limiting
C         in double precision.  This means that the magnitude of Z
C         cannot exceed approximately 3.4E+4 in single precision and
C         2.1E+6 in double precision.  This also means that one can
C         expect to retain, in the worst cases on 32-bit machines,
C         no digits in single precision and only 6 digits in double
C         precision.
C
C         The approximate relative error in the magnitude of a complex
C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
C         sents the increase in error due to argument reduction in the
C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
C         have only absolute accuracy.  This is most likely to occur
C         when one component (in magnitude) is larger than the other by
C         several orders of magnitude.  If one component is 10**K larger
C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
C         0) significant digits; or, stated another way, when K exceeds
C         the exponent of P, no significant digits remain in the smaller
C         component.  However, the phase angle retains absolute accuracy
C         because, in complex arithmetic with precision P, the smaller
C         component will not (as a rule) decrease below P times the
C         magnitude of the larger component. In these extreme cases,
C         the principal phase angle is on the order of +P, -P, PI/2-P,
C         or -PI/2+P.
C
C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
C                 matical Functions, National Bureau of Standards
C                 Applied Mathematics Series 55, U. S. Department
C                 of Commerce, Tenth Printing (1972) or later.
C               2. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument and Large Order, Report SAND83-0643,
C                 Sandia National Laboratories, Albuquerque, NM, May
C                 1983.
C               3. D. E. Amos, A Subroutine Package for Bessel Functions
C                 of a Complex Argument and Nonnegative Order, Report
C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
C                 NM, May 1985.
C               4. D. E. Amos, A portable package for Bessel functions
C                 of a complex argument and nonnegative order, ACM
C                 Transactions on Mathematical Software, 12 (September
C                 1986), pp. 265-273.
C
C***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZBINU, ZDIV, ZSQRT
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   890801  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   920811  Prologue revised.  (DWL)
C   930122  Added ZSQRT to EXTERNAL statement.  (RWC)
C***END PROLOGUE  ZBIRY
C     COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
      DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR,
     * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2,
     * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5,
     * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I,
     * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS
      INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
      DIMENSION CYR(2), CYI(2)
      EXTERNAL ZABS, ZSQRT
      DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01,
     * 6.14926627446000736D-01,4.48288357353826359D-01,
     * 5.77350269189625765D-01,3.14159265358979324D+00/
      DATA CONER, CONEI /1.0D0,0.0D0/
C***FIRST EXECUTABLE STATEMENT  ZBIRY
      IERR = 0
      NZ=0
      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (IERR.NE.0) RETURN
      AZ = ZABS(ZR,ZI)
      TOL = MAX(D1MACH(4),1.0D-18)
      FID = ID
      IF (AZ.GT.1.0E0) GO TO 70
C-----------------------------------------------------------------------
C     POWER SERIES FOR ABS(Z).LE.1.
C-----------------------------------------------------------------------
      S1R = CONER
      S1I = CONEI
      S2R = CONER
      S2I = CONEI
      IF (AZ.LT.TOL) GO TO 130
      AA = AZ*AZ
      IF (AA.LT.TOL/AZ) GO TO 40
      TRM1R = CONER
      TRM1I = CONEI
      TRM2R = CONER
      TRM2I = CONEI
      ATRM = 1.0D0
      STR = ZR*ZR - ZI*ZI
      STI = ZR*ZI + ZI*ZR
      Z3R = STR*ZR - STI*ZI
      Z3I = STR*ZI + STI*ZR
      AZ3 = AZ*AA
      AK = 2.0D0 + FID
      BK = 3.0D0 - FID - FID
      CK = 4.0D0 - FID
      DK = 3.0D0 + FID + FID
      D1 = AK*DK
      D2 = BK*CK
      AD = MIN(D1,D2)
      AK = 24.0D0 + 9.0D0*FID
      BK = 30.0D0 - 9.0D0*FID
      DO 30 K=1,25
        STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
        TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
        TRM1R = STR
        S1R = S1R + TRM1R
        S1I = S1I + TRM1I
        STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
        TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
        TRM2R = STR
        S2R = S2R + TRM2R
        S2I = S2I + TRM2I
        ATRM = ATRM*AZ3/AD
        D1 = D1 + AK
        D2 = D2 + BK
        AD = MIN(D1,D2)
        IF (ATRM.LT.TOL*AD) GO TO 40
        AK = AK + 18.0D0
        BK = BK + 18.0D0
   30 CONTINUE
   40 CONTINUE
      IF (ID.EQ.1) GO TO 50
      BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I)
      BII = C1*S1I + C2*(ZR*S2I+ZI*S2R)
      IF (KODE.EQ.1) RETURN
      CALL ZSQRT(ZR, ZI, STR, STI)
      ZTAR = TTH*(ZR*STR-ZI*STI)
      ZTAI = TTH*(ZR*STI+ZI*STR)
      AA = ZTAR
      AA = -ABS(AA)
      EAA = EXP(AA)
      BIR = BIR*EAA
      BII = BII*EAA
      RETURN
   50 CONTINUE
      BIR = S2R*C2
      BII = S2I*C2
      IF (AZ.LE.TOL) GO TO 60
      CC = C1/(1.0D0+FID)
      STR = S1R*ZR - S1I*ZI
      STI = S1R*ZI + S1I*ZR
      BIR = BIR + CC*(STR*ZR-STI*ZI)
      BII = BII + CC*(STR*ZI+STI*ZR)
   60 CONTINUE
      IF (KODE.EQ.1) RETURN
      CALL ZSQRT(ZR, ZI, STR, STI)
      ZTAR = TTH*(ZR*STR-ZI*STI)
      ZTAI = TTH*(ZR*STI+ZI*STR)
      AA = ZTAR
      AA = -ABS(AA)
      EAA = EXP(AA)
      BIR = BIR*EAA
      BII = BII*EAA
      RETURN
C-----------------------------------------------------------------------
C     CASE FOR ABS(Z).GT.1.0
C-----------------------------------------------------------------------
   70 CONTINUE
      FNU = (1.0D0+FID)/3.0D0
C-----------------------------------------------------------------------
C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
C-----------------------------------------------------------------------
      K1 = I1MACH(15)
      K2 = I1MACH(16)
      R1M5 = D1MACH(5)
      K = MIN(ABS(K1),ABS(K2))
      ELIM = 2.303D0*(K*R1M5-3.0D0)
      K1 = I1MACH(14) - 1
      AA = R1M5*K1
      DIG = MIN(AA,18.0D0)
      AA = AA*2.303D0
      ALIM = ELIM + MAX(-AA,-41.45D0)
      RL = 1.2D0*DIG + 3.0D0
      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
C-----------------------------------------------------------------------
C     TEST FOR RANGE
C-----------------------------------------------------------------------
      AA=0.5D0/TOL
      BB=I1MACH(9)*0.5D0
      AA=MIN(AA,BB)
      AA=AA**TTH
      IF (AZ.GT.AA) GO TO 260
      AA=SQRT(AA)
      IF (AZ.GT.AA) IERR=3
      CALL ZSQRT(ZR, ZI, CSQR, CSQI)
      ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
      ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
C-----------------------------------------------------------------------
C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
C-----------------------------------------------------------------------
      SFAC = 1.0D0
      AK = ZTAI
      IF (ZR.GE.0.0D0) GO TO 80
      BK = ZTAR
      CK = -ABS(BK)
      ZTAR = CK
      ZTAI = AK
   80 CONTINUE
      IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90
      ZTAR = 0.0D0
      ZTAI = AK
   90 CONTINUE
      AA = ZTAR
      IF (KODE.EQ.2) GO TO 100
C-----------------------------------------------------------------------
C     OVERFLOW TEST
C-----------------------------------------------------------------------
      BB = ABS(AA)
      IF (BB.LT.ALIM) GO TO 100
      BB = BB + 0.25D0*LOG(AZ)
      SFAC = TOL
      IF (BB.GT.ELIM) GO TO 190
  100 CONTINUE
      FMR = 0.0D0
      IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
      FMR = PI
      IF (ZI.LT.0.0D0) FMR = -PI
      ZTAR = -ZTAR
      ZTAI = -ZTAI
  110 CONTINUE
C-----------------------------------------------------------------------
C     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
C     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI
C-----------------------------------------------------------------------
      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL,
     * ELIM, ALIM)
      IF (NZ.LT.0) GO TO 200
      AA = FMR*FNU
      Z3R = SFAC
      STR = COS(AA)
      STI = SIN(AA)
      S1R = (STR*CYR(1)-STI*CYI(1))*Z3R
      S1I = (STR*CYI(1)+STI*CYR(1))*Z3R
      FNU = (2.0D0-FID)/3.0D0
      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL,
     * ELIM, ALIM)
      CYR(1) = CYR(1)*Z3R
      CYI(1) = CYI(1)*Z3R
      CYR(2) = CYR(2)*Z3R
      CYI(2) = CYI(2)*Z3R
C-----------------------------------------------------------------------
C     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
C-----------------------------------------------------------------------
      CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI)
      S2R = (FNU+FNU)*STR + CYR(2)
      S2I = (FNU+FNU)*STI + CYI(2)
      AA = FMR*(FNU-1.0D0)
      STR = COS(AA)
      STI = SIN(AA)
      S1R = COEF*(S1R+S2R*STR-S2I*STI)
      S1I = COEF*(S1I+S2R*STI+S2I*STR)
      IF (ID.EQ.1) GO TO 120
      STR = CSQR*S1R - CSQI*S1I
      S1I = CSQR*S1I + CSQI*S1R
      S1R = STR
      BIR = S1R/SFAC
      BII = S1I/SFAC
      RETURN
  120 CONTINUE
      STR = ZR*S1R - ZI*S1I
      S1I = ZR*S1I + ZI*S1R
      S1R = STR
      BIR = S1R/SFAC
      BII = S1I/SFAC
      RETURN
  130 CONTINUE
      AA = C1*(1.0D0-FID) + FID*C2
      BIR = AA
      BII = 0.0D0
      RETURN
  190 CONTINUE
      IERR=2
      NZ=0
      RETURN
  200 CONTINUE
      IF(NZ.EQ.(-1)) GO TO 190
      NZ=0
      IERR=5
      RETURN
  260 CONTINUE
      IERR=4
      NZ=0
      RETURN
      END


program test
    ! gfortran -O3 matr4.f90 -o matr4
    implicit none
    integer :: n, stat, i, j
    character(len=32) :: nstr
    real(8), allocatable :: q(:,:), w(:), res(:)
    real :: dt, tic, toc
    real(8), parameter :: pi = 4._8*atan(1._8)
    real(8) :: a, b

    if (command_argument_count() < 1) then
        stop 'ERROR must supply array size as command line argument'
    endif
    call get_command_argument(1, nstr)
    read(nstr, *, iostat=stat) n

    allocate(q(n, n), w(n), res(n))

    do i = 1, n
        w(i) = real(i, 8)
    enddo

    a = sqrt(1._8/n)
    b = sqrt(2._8/n)
    do i = 1, n
        q(i, 1    ) = a
        q(i, 1+n/2) = a * (-1._8)**(i-1)
        do j = 2, n/2
            q(i, j    ) = b * cos((i-1)*(j-1)*2*pi/real(n, 8))
            q(i, j+n/2) = b * sin((i-1)*(j-1)*2*pi/real(n, 8))
        enddo
    enddo

    call cpu_time(tic)
    res = matmul(q, w)
    call cpu_time(toc)
    dt = toc - tic
    print *,'matqwr8 n = ', n, ' time = ', dt, ' secs res = ', sum(res)

    ! print *,'res '
    ! do i = 1, 100
    !    print *,res(i)
    ! enddo

end program test


Module Kinematics
Use Control

Contains

Real(dp) Function kaellen(mx,my,mz)
Implicit None
Real(dp), Intent(in) :: mx, my, mz

kaellen = mx * mx + my * my + mz * mz &
  & - 2._dp * mx * my - 2._dp * mx * mz - 2._dp * my *mz

End Function kaellen

Real(dp) Function GammaTPS(mci,mw,mch,RMsquared)
!TPS = Two-Body Phase Space
Implicit None
Real(dp), Intent(in) :: mci,mw,mch,RMsquared
Real(dp) :: mcip2, mwp2, mchp2

mcip2 = mci * mci
mwp2 = mw * mw
mchp2 = mch * mch

GammaTPS = kaellen(mcip2,mwp2,mchp2)
GammaTPS = sqrt(GammaTPS)
GammaTPS = GammaTPS * RMSquared
GammaTPS = GammaTPS / (16._dp * Pi * mci * mcip2)

End Function GammaTPS

End Module Kinematics


SUBROUTINE weight(ord,x,y,z,sig,mu,eta,xi)

!-------------------------------------------------------------
!
!  Computes the spatial weights
!  From Azmy 1988 in NSE, equations 20a and 20b used
!  First find the epsilons
!  Input: order, dx, dy, dz, total XS, mu, eta, xi
!  Returns: weight for cell (i,j,k) in x (alpha) and
!            y (beta) directions and z (gamma) directions
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: ord
REAL*8, INTENT(IN) :: x, y, z, sig, mu, eta, xi
INTEGER :: t
REAL*8 :: shx, shy, shz, chx, chy, chz, epsxe, epsxo, epsye, epsyo, epsze, epszo
REAL*8 :: smxe, smxo, smye, smyo, smze, smzo

! Compute the coefficients and the hyperbolic functions
ex = 0.5*sig*x/mu
ey = 0.5*sig*y/eta
ez = 0.5*sig*z/xi
shx = SINH(ex)
shy = SINH(ey)
shz = SINH(ez)
chx = COSH(ex)
chy = COSH(ey)
chz = COSH(ez)

! Initialize values for epsilons from 15c in Azmy '88 NSE
epsxe = shx/ex
epsxo = 3.0*(chx-shx/ex)/ex
epsye = shy/ey
epsyo = 3.0*(chy-shy/ey)/ey
epsze = shz/ez
epszo = 3.0*(chz-shz/ez)/ez

! Initialize summation terms
smxe = 0.0
smxo = 0.0
smye = 0.0
smyo = 0.0
smze = 0.0
smzo = 0.0
t = 0

! Start the summations
DO
   ! Even terms
   smxe = smxe + epsxe
   smye = smye + epsye
   smze = smze + epsze
   IF (t == ord) EXIT
   t = t + 1

   ! Odd terms
   smxo = smxo + epsxo
   smyo = smyo + epsyo
   smzo = smzo + epszo
   IF (t == ord) EXIT
   t = t + 1

   ! Compute the updates
   epsxe = (2.0*t+1.0)*(ex*epsxe/(2.0*t-3.0)-epsxo)/ex
   epsye = (2.0*t+1.0)*(ey*epsye/(2.0*t-3.0)-epsyo)/ey
   epsze = (2.0*t+1.0)*(ez*epsze/(2.0*t-3.0)-epszo)/ez
   epsxo = (2.0*t+3.0)*(ex*epsxo/(2.0*t-1.0)-epsxe)/ex
   epsyo = (2.0*t+3.0)*(ey*epsyo/(2.0*t-1.0)-epsye)/ey
   epszo = (2.0*t+3.0)*(ez*epszo/(2.0*t-1.0)-epsze)/ez
END DO

! Finish by taking ratio related to odd and even summations
alpha = (chx - smxe)/(shx - smxo)
beta  = (chy - smye)/(shy - smyo)
gamma = (chz - smze)/(shz - smzo)

RETURN
END SUBROUTINE weight


! $UWHPSC/codes/fortran/newton/functions.f90

module functions

contains

real(kind=8) function f_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    f_sqrt = x**2 - 4.d0

end function f_sqrt

real(kind=8) function fprime_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    fprime_sqrt = 2.d0 * x

end function fprime_sqrt

end module functions


program test_simps
    use stdlib_experimental_kinds, only: sp, dp, qp
    use stdlib_experimental_error, only: check
    use stdlib_experimental_quadrature, only: simps, simps_weights

    implicit none

    real(sp), parameter :: tol_sp = 1000 * epsilon(1.0_sp)
    real(dp), parameter :: tol_dp = 1000 * epsilon(1.0_dp)
    real(qp), parameter :: tol_qp = 1000 *epsilon(1.0_sp)

    call test_simps_sp
    call test_simps_dp
    call test_simps_qp

    call test_simps_weights_sp
    call test_simps_weights_dp
    call test_simps_weights_qp

    call test_simps_zero_sp
    call test_simps_zero_dp
    call test_simps_zero_qp

    call test_simps_even_sp
    call test_simps_even_dp
    call test_simps_even_qp

    call test_simps_weights_even_sp
    call test_simps_weights_even_dp
    call test_simps_weights_even_qp

    call test_simps_six_sp
    call test_simps_six_dp
    call test_simps_six_qp

contains

    subroutine test_simps_sp
        integer, parameter :: n = 13
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i

        print *, "test_simps_sp"

        y = [(real(i-1, sp)**2, i = 1, n)]

        val = simps(y, 1.0_sp)
        ans = 576.0_sp
        print *, "  dx=1", val, ans
        call check(abs(val - ans) < tol_sp)

        val = simps(y, 0.5_sp)
        ans = 288.0_sp
        print *, "  dx=0.5", val, ans
        call check(abs(val - ans) < tol_sp)

        x = [(0.25_sp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 144.0_sp
        print *, "  x=0,0.25,0.5,...", val, ans
        call check(abs(val - ans) < tol_sp)
    end subroutine test_simps_sp

    subroutine test_simps_dp
        integer, parameter :: n = 13
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        print *, "test_simps_dp"

        y = [(real(i-1, dp)**2, i = 1, n)]

        val = simps(y, 1.0_dp)
        ans = 576.0_dp
        print *, "  dx=1", val, ans
        call check(abs(val - ans) < tol_dp)

        val = simps(y, 0.5_dp)
        ans = 288.0_dp
        print *, "  dx=0.5", val, ans
        call check(abs(val - ans) < tol_dp)

        x = [(0.25_dp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 144.0_dp
        print *, "  x=0,0.25,0.5,...", val, ans
        call check(abs(val - ans) < tol_dp)
    end subroutine test_simps_dp

    subroutine test_simps_qp
        integer, parameter :: n = 13
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i

        print *, "test_simps_qp"

        y = [(real(i-1, qp)**2, i = 1, n)]

        val = simps(y, 1.0_qp)
        ans = 576.0_qp
        print *, "  dx=1", val, ans
        call check(abs(val - ans) < tol_qp)

        val = simps(y, 0.5_qp)
        ans = 288.0_qp
        print *, "  dx=0.5", val, ans
        call check(abs(val - ans) < tol_qp)

        x = [(0.25_qp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 144.0_qp
        print *, "  x=0,0.25,0.5,...", val, ans
        call check(abs(val - ans) < tol_qp)
    end subroutine test_simps_qp

    subroutine test_simps_weights_sp
        integer, parameter :: n = 17
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp), dimension(n) :: w
        integer :: i
        real(sp) :: val
        real(sp) :: ans

        print *, "test_simps_weights_sp"

        y = [(real(i-1, sp), i = 1, n)]

        x = y
        w = simps_weights(x)
        val = sum(w*y)
        ans = simps(y, x)
        print *, "  ", val, ans
        call check(abs(val - ans) < tol_sp)
    end subroutine test_simps_weights_sp

    subroutine test_simps_weights_dp
        integer, parameter :: n = 17
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp), dimension(n) :: w
        integer :: i
        real(dp) :: val
        real(dp) :: ans

        print *, "test_simps_weights_dp"

        y = [(real(i-1, dp), i = 1, n)]

        x = y
        w = simps_weights(x)
        val = sum(w*y)
        ans = simps(y, x)
        print *, "  ", val, ans
        call check(abs(val - ans) < tol_dp)
    end subroutine test_simps_weights_dp

    subroutine test_simps_weights_qp
        integer, parameter :: n = 17
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp), dimension(n) :: w
        integer :: i
        real(qp) :: val
        real(qp) :: ans

        print *, "test_simps_weights_qp"

        y = [(real(i-1, qp), i = 1, n)]

        x = y
        w = simps_weights(x)
        val = sum(w*y)
        ans = simps(y, x)
        print *, "  ", val, ans
        call check(abs(val - ans) < tol_qp)
    end subroutine test_simps_weights_qp

    subroutine test_simps_zero_sp
        real(sp), dimension(0) :: a

        print *, "test_simps_zero_sp"

        call check(abs(simps(a, 1.0_sp)) < epsilon(0.0_sp))
        call check(abs(simps([1.0_sp], 1.0_sp)) < epsilon(0.0_sp))
        call check(abs(simps(a, a)) < epsilon(0.0_sp))
        call check(abs(simps([1.0_sp], [1.0_sp])) < epsilon(0.0_sp))
    end subroutine test_simps_zero_sp

    subroutine test_simps_zero_dp
        real(dp), dimension(0) :: a

        print *, "test_simps_zero_dp"

        call check(abs(simps(a, 1.0_dp)) < epsilon(0.0_dp))
        call check(abs(simps([1.0_dp], 1.0_dp)) < epsilon(0.0_dp))
        call check(abs(simps(a, a)) < epsilon(0.0_dp))
        call check(abs(simps([1.0_dp], [1.0_dp])) < epsilon(0.0_dp))
    end subroutine test_simps_zero_dp

    subroutine test_simps_zero_qp
        real(qp), dimension(0) :: a

        print *, "test_simps_zero_qp"

        call check(abs(simps(a, 1.0_qp)) < epsilon(0.0_qp))
        call check(abs(simps([1.0_qp], 1.0_qp)) < epsilon(0.0_qp))
        call check(abs(simps(a, a)) < epsilon(0.0_qp))
        call check(abs(simps([1.0_qp], [1.0_qp])) < epsilon(0.0_qp))
    end subroutine test_simps_zero_qp

    subroutine test_simps_even_sp
        integer, parameter :: n = 11
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i
        integer :: even

        print *, "test_simps_even_sp"

        y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)]

        do even = -1, 1
            print *, "even=", even

            val = simps(y, 1.0_sp)
            ans = 1000.0_sp
            print *, "  dx=1", val, ans
            call check(abs(val - ans) < tol_sp)

            val = simps(y, 0.5_sp)
            ans = 500.0_sp
            print *, "  dx=0.5", val, ans
            call check(abs(val - ans) < tol_sp)

            x = [(0.25_sp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 250.0_sp
            print *, "  x=0,0.25,0.5,...", val, ans
            call check(abs(val - ans) < tol_sp)
        end do
    end subroutine test_simps_even_sp

    subroutine test_simps_even_dp
        integer, parameter :: n = 11
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        print *, "test_simps_even_dp"

        y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)]

        val = simps(y, 1.0_dp)
        ans = 1000.0_dp
        print *, "  dx=1", val, ans
        call check(abs(val - ans) < tol_dp)

        val = simps(y, 0.5_dp)
        ans = 500.0_dp
        print *, "  dx=0.5", val, ans
        call check(abs(val - ans) < tol_dp)

        x = [(0.25_dp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 250.0_dp
        print *, "  x=0,0.25,0.5,...", val, ans
        call check(abs(val - ans) < tol_dp)
    end subroutine test_simps_even_dp

    subroutine test_simps_even_qp
        integer, parameter :: n = 11
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i
        integer :: even

        print *, "test_simps_even_qp"

        y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)]

        do even = -1, 1
            print *, "  even=", even

            val = simps(y, 1.0_qp)
            ans = 1000.0_qp
            print *, "  dx=1", val, ans
            call check(abs(val - ans) < tol_qp)

            val = simps(y, 0.5_qp)
            ans = 500.0_qp
            print *, "  dx=0.5", val, ans
            call check(abs(val - ans) < tol_qp)

            x = [(0.25_qp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 250.0_qp
            print *, "  x=0,0.25,0.5,...", val, ans
            call check(abs(val - ans) < tol_qp)
        end do
    end subroutine test_simps_even_qp

    subroutine test_simps_weights_even_sp
        integer, parameter :: n = 16
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp), dimension(n) :: w
        integer :: i
        real(sp) :: val
        real(sp) :: ans
        integer :: even

        print *, "test_simps_weights_even_sp"

        y = [(real(i-1, sp), i = 1, n)]
        x = y

        do even = -1, 1
            w = simps_weights(x)
            val = sum(w*y)
            ans = simps(y, x)
            print *, "  even=", even, val, ans
            call check(abs(val - ans) < tol_sp)
        end do
    end subroutine test_simps_weights_even_sp

    subroutine test_simps_weights_even_dp
        integer, parameter :: n = 16
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp), dimension(n) :: w
        integer :: i
        real(dp) :: val
        real(dp) :: ans
        integer :: even

        print *, "test_simps_weights_even_dp"

        y = [(real(i-1, dp), i = 1, n)]
        x = y

        do even = -1, 1
            w = simps_weights(x)
            val = sum(w*y)
            ans = simps(y, x)
            print *, "  even=", even, val, ans
            call check(abs(val - ans) < tol_dp)
        end do
    end subroutine test_simps_weights_even_dp

    subroutine test_simps_weights_even_qp
        integer, parameter :: n = 16
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp), dimension(n) :: w
        integer :: i
        real(qp) :: val
        real(qp) :: ans
        integer :: even

        print *, "test_simps_weights_even_qp"

        y = [(real(i-1, qp), i = 1, n)]

        x = y

        do even = -1, 1
            w = simps_weights(x)
            val = sum(w*y)
            ans = simps(y, x)
            print *, "  even=", even, val, ans
            call check(abs(val - ans) < tol_qp)
        end do
    end subroutine test_simps_weights_even_qp

    subroutine test_simps_six_sp
        integer, parameter :: n = 6
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i
        integer :: even

        print *, "test_simps_six_sp"

        y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)]

        do even = -1, 1
            print *, "even=", even

            val = simps(y, 1.0_sp)
            ans = 125.0_sp
            print *, "  dx=1", val, ans
            call check(abs(val - ans) < tol_sp)

            val = simps(y, 0.5_sp)
            ans = 62.5_sp
            print *, "  dx=0.5", val, ans
            call check(abs(val - ans) < tol_sp)

            x = [(0.25_sp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 31.25_sp
            print *, "  x=0,0.25,0.5,...", val, ans
            call check(abs(val - ans) < tol_sp)
        end do
    end subroutine test_simps_six_sp

    subroutine test_simps_six_dp
        integer, parameter :: n = 6
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        print *, "test_simps_six_dp"

        y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)]

        val = simps(y, 1.0_dp)
        ans = 125.0_dp
        print *, "  dx=1", val, ans
        call check(abs(val - ans) < tol_dp)

        val = simps(y, 0.5_dp)
        ans = 62.5_dp
        print *, "  dx=0.5", val, ans
        call check(abs(val - ans) < tol_dp)

        x = [(0.25_dp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 31.25_dp
        print *, "  x=0,0.25,0.5,...", val, ans
        call check(abs(val - ans) < tol_dp)
    end subroutine test_simps_six_dp

    subroutine test_simps_six_qp
        integer, parameter :: n = 6
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i
        integer :: even

        print *, "test_simps_six_qp"

        y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)]

        do even = -1, 1
            print *, "  even=", even

            val = simps(y, 1.0_qp)
            ans = 125.0_qp
            print *, "  dx=1", val, ans
            call check(abs(val - ans) < tol_qp)

            val = simps(y, 0.5_qp)
            ans = 62.5_qp
            print *, "  dx=0.5", val, ans
            call check(abs(val - ans) < tol_qp)

            x = [(0.25_qp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 31.25_qp
            print *, "  x=0,0.25,0.5,...", val, ans
            call check(abs(val - ans) < tol_qp)
        end do
    end subroutine test_simps_six_qp

end program


    Subroutine rstat(rdata,rmin,rmax,rmean,rstd,nrow)
!=======================================================================
!     LATEST CORRECTION BY
!
!     PURPOSE
!       Evaluate some statistical data (min,max,mean and standard deviation)
!
!     PROGRAMMED BY:  bjorn.melhus@akersolutions.com
!     CREATED......:  10.05.2021
!=======================================================================
    implicit none
    real rdata(nrow),rmin,rmax,rsum,rmean,rvar,rstd
    integer nrow,irow
!
    rmin=1.0E+22
    rmax=-1.0E+22
    rsum=0.0
!   Evaluate min,max and mean
    do irow=1,nrow
       if (rdata(irow)<rmin)  rmin=rdata(irow)
       if (rdata(irow)>rmax)  rmax=rdata(irow)
       rsum=rsum+rdata(irow)
    enddo
    rmean=rsum/real(nrow)
!
    rvar=0.0
!   Evaluate standard deviation
    do irow=1,nrow
       rvar=rvar+(rdata(irow)-rmean)**2
    enddo
!
    rstd=sqrt(rvar/real(nrow))
!
    RETURN
    END


! { dg-do compile }
! Tests the fix for PR32962, in which the result of TRANSPOSE, when
! an actual argument of an elemental intrinsic would receive the
! wrong offset.
!
! Contributed by Wirawan Purwanto <wirawan0@gmail.com>
!
  real(kind=8), allocatable :: b(:,:)
  real(kind=8) :: a(2,2), c(2,2)
  i = 2
  allocate (b(i,i))
  a(1,1) = 2
  a(2,1) = 3
  a(1,2) = 7
  a(2,2) = 11
  call foo
  call bar
  if (any (c .ne. b)) STOP 1
contains
  subroutine foo
    b = cos(transpose(a))
  end subroutine
  subroutine bar
    c = transpose(a)
    c = cos(c)
  end subroutine
end program