    Program zcposv_example

!     ZCPOSV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zcposv
      Use lapack_precision, Only: sp, dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, iter, lda, ldb, ldx, n, r
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), work(:, :), x(:, :)
      Complex (Kind=sp), Allocatable :: swork(:)
      Real (Kind=dp), Allocatable :: rwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'ZCPOSV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, r
      lda = n
      ldb = n
      ldx = n
      Allocate (a(lda,n), b(ldb,r), work(n,r), x(ldx,r), swork(n*(n+ &
        r)), rwork(n))

!     Read A and B from data file

      Read (nin, *)(a(i,i:n), i=1, n)
      Read (nin, *)(b(i,1:r), i=1, n)

!     Solve the equations Ax = b for x
      Call zcposv('U', n, r, a, lda, b, ldb, x, ldx, work, swork, rwork, iter, &
        info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100)(x(i,1:r), i=1, n)

      Else
        Write (nout, 110) 'The leading minor of order ', info, &
          ' is not positive definite'
      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))
110   Format (1X, A, I3, A)
    End Program


!======================================================================================================
!> Program: cpFlow                                                                                !!
!> Details: PROGRAM TO COMPUTE FLOW PARAMETERS FOR COUETTE-POISEUILLE FLOW USING MIXING LENGTH MODEL !!
!> @Author: Aakash PATIL, IMP Turbulence                                                             !!
!> Mentor:  Dr. Jean-Philip LAVAL                                                                    !!
!======================================================================================================
program cpflow

use module_parameters
use module_grid
use module_triSolve
use module_solver
implicit none
        INTEGER		    :: NUM_CASE         !Case number under consideration
	REAL(8),ALLOCATABLE :: YHAD(:),YPAD(:)  !Grid parameters
        CHARACTER(len=15)   :: OUTPUTFILE       !Output filename
        REAL(8)             :: VW, H, DPDX      !Input conditions for a given case number
        !VW is the Velocity of Wall, H is the Height of Channel, and DPDX is Pressure Gradient
        CHARACTER(len=100)  :: EXCOMMAND        !String for writing command line arguments

        print*, "########################################"
        print*, "###### Couette_Poiseuille-FlowCode #####"
        print*, "########################################"

        !CASE SELECTION
        print*,"Please Enter a Case Number(from 1 to 18): "
        read*, NUM_CASE
        !do NUM_CASE=1,18 !end of RunAllCasesLoop
        !NUM_CASE=15      !single case

        !Checking Case Number and Managing Filenames
        if (NUM_CASE<1 .OR. NUM_CASE>18) then
                  print *, "Invalid Case Number. Exiting"
                  STOP
        else if (NUM_CASE < 10) then
                  write (OUTPUTFILE, "(A6,I1,A8)") "Case_0",NUM_CASE,"_sim.dat"
        else if (NUM_CASE<19) then
                  write (OUTPUTFILE, "(A5,I2,A8)") "Case_",NUM_CASE,"_sim.dat"
        else
                  print *, "Invalid Case Number. Exiting"
                  STOP
        endif

        !Read the Parameters
        print *, "### Fetching Values from the Parameters File ###"
        CALL case_select(NUM_CASE,VW, H, DPDX)
        print *, "The selected CASE NUMBER is ",NUM_CASE
        print *, "Here, the values of VW, H, DPDX are ",VW, H, DPDX, "respectively."
        print *, "The data generated will be saved to file ", OUTPUTFILE

	!Call Main Functions
	print *, "### Generating Grid ###"
	ALLOCATE(YPAD(N),YHAD(N))
	CALL sGrid_Generator(H,N,ALPHA,YPAD,YHAD)
	print *, "### Solving for Flow Parameters ###"
        CALL flowSolve(VW,H,N,YPAD,YHAD,ALPHA,DPDX,KIN_VIS,CONV_CRIT,MAX_ITER,OUTPUTFILE,NUM_CASE)
        DEALLOCATE(YPAD,YHAD)

        !Data Management
        print *, "### Organizing Data Files ###"
        print *, "Copied Successfully "
        print *, "Copying Generated simulation data to the directory '../Simulated_Data'"
        EXCOMMAND="cp "//OUTPUTFILE//" ../Simulated_Data/"//OUTPUTFILE
        print *, trim(EXCOMMAND)
        call system(trim(EXCOMMAND))
        print *, "Copied Successfully "

        !Automatic Plotting
        print *, "### Plotting ###"
        EXCOMMAND="python autoplotting.py --file "//OUTPUTFILE
        if (PLOT=='Y') then
                print *, "Creating Plots"
                print *, trim(EXCOMMAND)
                call system(trim(EXCOMMAND))
        else
                print *, "Auto Plotting Disabled"
                print *, "For direct plotting, type 'python autoplotting.py --file ",OUTPUTFILE," '"
        end if

        print*, "Cleaning Execution Directory"
        call system("rm *.dat")

       !end do !end of RunAllCasesLoop
end program


! { dg-do run }
! Tests the fix for pr32682, in which the scalarization loop variables
! were not being determined when 'c' came first in an expression.
!
! Contributed by Janus Weil <jaydub66@gmail.com>
!
program matrix

  implicit none
  real,dimension(2,2),parameter::c=reshape((/1,2,3,4/),(/2,2/))
  real,dimension(2,2)::m, n

  m=f()+c
  if (any (m .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 1
  m=c+f()
  if (any (m .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 2
  call sub(m+f())
  if (any (n .ne. reshape((/3,4,5,6/),(/2,2/)))) STOP 3
  call sub(c+m)
  if (any (n .ne. reshape((/3,5,7,9/),(/2,2/)))) STOP 4
  call sub(f()+c)
  if (any (n .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 5
  call sub(c+f())
  if (any (n .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 6

contains

  function f()
    implicit none
    real, dimension(2,2)::f
    f=1
  end function f

  subroutine sub(a)
    implicit none
    real, dimension(2,2)::a
    n = a
  end subroutine sub

end program matrix


C$Procedure      SPHLAT ( Spherical to latitudinal coordinates )

      SUBROUTINE SPHLAT ( R, COLAT, LONGS, RADIUS, LONG, LAT )

C$ Abstract
C
C     Convert from spherical coordinates to latitudinal coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION, COORDINATES
C
C$ Declarations

      DOUBLE PRECISION R
      DOUBLE PRECISION COLAT
      DOUBLE PRECISION LONGS
      DOUBLE PRECISION RADIUS
      DOUBLE PRECISION LONG
      DOUBLE PRECISION LAT

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     R          I   Distance of the point from the origin.
C     COLAT      I   Angle of the point from positive Z axis (radians).
C     LONGS      I   Angle of the point from the XZ plane (radians).
C     RADIUS     O   Distance of a point from the origin
C     LONG       O   Angle of the point from the XZ plane in radians
C     LAT        O   Angle of the point from the XY plane in radians
C
C$ Detailed_Input
C
C     R          Distance of the point from the origin.
C
C     COLAT      Angle between the vector from the origin to the point
C                and the positive Z axis in radians.
C
C     LONGS      Angle of the point from the XZ plane (radians).
C
C$ Detailed_Output
C
C     RADIUS     Distance of a point from the origin
C
C     LONG       Angle of the point from the XZ plane in radians. LONG
C                is set equal to LONGS.
C
C     LAT        Angle of the point from the XY plane in radians. LAT
C                is computed as pi/2 - COLAT.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the latitudinal coordinates of a point
C     whose position is input in spherical coordinates.
C
C     Latitudinal coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     above the equator of a sphere centered at the central reference
C     point.
C
C     Spherical coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     from the z-axis.
C
C$ Examples
C
C
C     Latitude is obtained by subtracting co-latitude from HALFPI()
C     Radius and longitude mean the same thing in both latitudinal
C     and spherical coordinates.  The table below lists LAT and
C     corresponding COLAT in terms of degrees.
C
C             LAT            COLAT
C            ------         ------
C              0             90
C             20             70
C             45             45
C            -30            120
C             90              0
C            -45            135
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     spherical to latitudinal coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION HALFPI

C
C     Local Variables
C
      DOUBLE PRECISION RR
      DOUBLE PRECISION LATTUD

C
C     Convert to latitudinal coordinates, storing the results in
C     temporary variables
C
      RR     = R
      LATTUD = HALFPI() - COLAT

C
C     Move the results to the output variables.
C
      LONG   = LONGS
      RADIUS = RR
      LAT    = LATTUD

      RETURN
      END


! -----------------------------------------------------------------------
! This code computes the generalized Lomb-Scargle (GLS) periodogram
! for one time-series read from an ASCII input file.
! The following paper describes the method:
!        Zechmeister & Kuerster, 2009, A&A, 496, 577)
! -----------------------------------------------------------------------

PROGRAM gls

use gls_mod, only: dp, twopi, readfile, glsspec, sinefit, specwin
use mc_mod, only: gauss, ssort, interx1, shuffle, init_random_seed

implicit none

integer, parameter :: nmax=1000000, nsimmax=10000
integer :: i,N,wexp=2,io=0,index,iargc,en
! wexp = weightening exponent (default Chi2)
! weightening of errors: wexp=0 (variance), wexp=2 (Chi2)
integer :: numarg,nstep,istep,iter,nthread=1
integer :: iverb=1,isout=1,ilog=0,isim=0,nsim=100,iboot=0
logical :: isparfile, longhelp=.false.
character :: TV*40, name*80, fittype*8, logfile*80
integer, external :: ntokens

real(dp) :: tbase=0,FLXmean=0,wsum,YY=0, &
rmssin=0,chisin=0,wrmssin=0,powSin=0,dFLXsin, &
fbeg,fend,fendmax,step,ofac,PSin,Amp,CBest,ph, &
w,M,FAP,prob,probMC=1,deferr,rms0=1,rms,PSin0,PowSin0=0

real(dp), dimension(:), allocatable :: flx,flxerr,t,ww
real(dp), allocatable, dimension(:) :: powMC,pp
integer, allocatable, dimension(:) :: indx

fittype="unknown"
logfile='gls.log'
fendMax=50.0d0
ofac=20.0d0
deferr=0.001d0

!========================= USER INTERFACE ========================

! >>> Read parameter file.

inquire(file="gls.par", exist=isparfile)
if (isparfile) then    ! (else defaults will be used)
   open(unit=2, file= "gls.par", status= "OLD")
   read(2,*) ofac                ! default oversampling factor = 20
   read(2,*) wexp                ! default wexp = 0 (variance)
   read(2,*) Fbeg                ! default Fbeg = 1./tbase/10.
   read(2,*) Fend                ! default Fend = N*Fbeg*10. (average Nyquist frequency)
   read(2,*) deferr              ! default error (if error value is 0 in input file)
   read(2,*) isim                ! estimate significance by MC?
   read(2,*) nsim                ! number of realizations in MC
   read(2,*) iboot               ! use bootstrapping instead of white noise?
   read(2,*) iverb               ! verbose mode?
   read(2,*) isout               ! write out spectrum?
   read(2,*) ilog                ! write logfile?
   read(2,*) nthread             ! number of threads
   close(2)
endif

ofac=DABS(ofac)
nsim=ABS(nsim)
nthread=ABS(nthread)
if (nsim>nsimmax) then
  write(0,*) "WARNING: nsim > ",nsimmax," !"
  write(0,*) "  nsim = ",nsimmax," has been set."
  nsim=nsimmax
end if

if (fbeg>fend) then
    write(0,*) "WARNING: minimum frequency is higher than maximum frequency!"
    write(0,*) "  Minimum and maximum frequencies have been swapped."
    fbeg = fbeg + fend
    fend = fbeg - fend
    fbeg = fbeg - fend
endif

if (fend>fendmax) then
    fend=fendmax
    write(0,*) "WARNING: maximum frequency is larger than ",fendmax," !"
    write(0,*) "  Maximum frequency have been set to ",fendmax," ."
endif

if (.NOT.(wexp==0 .or. wexp==2)) then
    write(0,*) "WARNING: weightening exponent has an illegal value!"
    write(0,*) "  Weightening exponent has been set to 0."
endif

! >>> Read command line arguments.

numarg=iargc()

if (numarg==0) then
    call print_help(longhelp)
endif

call getarg(1,name)

if(name=='-help') then
    longhelp=.true.
    call print_help(longhelp)
endif

if (numarg>1) then    ! if the are any command line arguments
    do i=1,numarg-1
        call getarg(i,name)             ! testing i-th command line argument
        if (name=='-e2') wexp=2          ! i.e. chi2 (use error bars)
        if (name=='-e1') wexp=1          ! i.e. chi2 (use error bars)
        if (name=='-ne') wexp=0          ! i.e. variance (no error bars)
        if (name=='-s')  isout=1         ! write out spectrum
        if (name=='-ns') isout=0         ! don't write out spectrum
        if (name=='-v')  iverb=1
        enddo
endif

if (wexp==2) fittype = "chi2"
if (wexp==0) fittype = "variance"

! >>> Read input file name (last command line argument):
call getarg(numarg,name)

!========================= DATA INPUT ========================

call readfile(name,nmax,wexp,deferr,wsum,t,flx,flxerr,ww)

n=size(t)

!========================= GLS SPECTRUM ========================

! >>> Check if parameter file exists, if no, set Fbeg, Fend to defaults.

tbase=MAXVAL(t)

if(isparfile.eqv.(.false.)) then    ! no parameter file -> no frequency range specified
    Fbeg = 1./tbase/10.              ! default value
    Fend = N*Fbeg*10.                ! default value (average Nyquist frequency)
    !if (Fbeg.lt.1./tbase/10.) Fbeg = 1./tbase/10.              ! default value
endif
! Set Fbeg to small positive value:
step = 1.0d0/tbase/ofac
if(Fbeg.lt.step) Fbeg=1./tbase/10.

! >>> Compute GLS Spectrum:
call glsspec(nthread,name,isout,Fbeg,Fend,ofac,t,flx,ww,yy,psin,powsin,amp,ph,cbest,rms)

powSin0=powSin
PSin0=PSin
rms0=rms
do i=1,N
    dFLXsin = FLX(i)-(Amp*sin(t(i)*twopi/PSin0+ph)+CBest)
    rmssin = rmssin + dFLXsin**2
    chisin = chisin + (dFLXsin/FLXerr(i))**2
end do
rmssin = sqrt(rmssin/(N-4))           ! unbiased rms
wrmssin = sqrt(chisin/wsum*N/(N-4))   ! weighted rms

! >>> Calculate analytical estimator of false alarm probability.

prob= (1.0d0-powSin0)**((dfloat(N)-3.0d0)/2.0d0)        ! spectral false alarm probability
M   = tbase * dabs(Fend-Fbeg)         ! number of independent frequencies
FAP = M * prob
if (FAP>0.01d0) FAP = 1.0d0 - (1.0d0-prob)**M

!========================= MONTE CARLO FAP ESTIMATION ========================

if(isim==1) then    ! Perform MC estimation of FAP.

    allocate(powmc(nsim))
    allocate(pp(nsim))
    allocate(indx(nsim))

    ww=1.0_dp/DFLOAT(n)  ! No error bars in this case..
    do iter=1,nsim   ! Loop for MC (will become iterated if isim=1)

        if(iboot.eq.0) then
            call gauss(flx,rms0,n)
            !open(7,file="tmp")
            !do i=1,n
            !  write(7,*) t(i),flx(i)
            !enddo
            !close(7)
        else
            call shuffle(flx)
        end if

        call glsspec(nthread,name,isout,Fbeg,Fend,ofac,t,flx,ww,yy,psin,powsin,amp,ph,cbest,rms)

        powMC(iter)=powsin
        pp(iter)=1.0d0-DFLOAT(nsim-iter)/DFLOAT(nsim)

    end do   !  End loop for MC.
    call ssort(powMC,indx)
    if(powSin0.le.powMC(1)) then
        call interx1(powMC,pp,powsin0,probmc)
    else
        probmc=pp(1)
    end if

    open(7,file="tmp1")
    do i=1,nsim
        write(7,*) pp(i),powmc(i)
        end do
    close(7)

    deallocate(powmc)
    deallocate(pp)
    deallocate(indx)

end if

if (iverb.eq.1) then
    print *, "Number of data points = ", N
    print *, "Total time base =", tbase," days"
    print *, "Number of independent frequencies = ", 1./tbase, " 1/d"
    print *, fittype(:lnblnk(fittype))//"_0 = ", YY*wsum
    print *, "rms_0 = ",rms
    write(6,*)"Number of frequency steps = ",int((Fend-Fbeg)/step+1)
    endif

if (iverb.eq.1) then
    print *
    write (*,'(1x,a,i3,a,i2)') 'Used parameters: ofac =',int(ofac),' , wexp =',int(wexp)
    print *, " ",fittype(:lnblnk(fittype))//" for constant:",YY*wsum
    print *, " RMS for constant: ",rms0
    if (wexp .eq. 2) print *, " mean weighted internal error:", sqrt(N/wsum)
    print *
    print *, "Best sine fit values for ", name(:lnblnk(name))
    print *, " best sine period [d] =       ", PSin0," +/-",sqrt(6./N)*2/twopi/tbase*wrmssin/Amp*PSin0**2
    print *, " amplitude =                  ", Amp," +/-",sqrt(2./N)*wrmssin
    write(6,*)
    print *, fittype(:lnblnk(fittype))," of residuals:",(1.-powSin0)*YY*wsum,chisin ! variance after fit
    print *, " weighted rms of residuals:  ", wrmssin
    print *, " rms of residuals:           ", rmssin
    print *, " highest power p[0..1]:      ", powSin0
    print *, "               P[0..(N-1)/2]:", powSin0*(N-1)/2
    print *, " Analytical FAP(spectral)=(1-p)^((N-3)/2):", prob
    print *, " Analytical FAP:                        ", FAP
    if(isim.eq.1) then
        print *, " FAP (MC):", probMC
        print *, " Number of realizations:", nsim
        end if
    print *, "----------------------------------------------------------------"
    print *, "RESULTS:"
    print *
    endif

! >>> Write results to STDOUT.
if(isim.eq.0) then
  write(*,'(a,1x,i5,1x,f9.6,1x,f7.3,1x,f6.2,1x,i7,2x,e15.3e4,1x,f8.6)') &
  TRIM(name),N,1.0d0/PSin0,powSin0,Fend,int(M),FAP,1.0d0/tbase
else
  write(*,'(a,1x,i5,1x,f9.6,1x,f7.3,1x,f6.2,1x,i7,2x,2(e15.3e4,1x),f8.6)') &
  TRIM(name),N,1.0d0/PSin0,powSin0,Fend,int(M),FAP,probmc,1.0d0/tbase
endif

if (allocated(flx)) deallocate(flx)
if (allocated(flxerr)) deallocate(flxerr)
if (allocated(ww)) deallocate(ww)
if (allocated(t)) deallocate(t)

!  TRIM(name),N,1.0d0/PSin0,powSin0*(N-1)/2,Fend,int(M),FAP

! >>>  Add results to logfile.
if (ilog==1) then
    open(unit=3, file=TRIM(logfile) ,access='APPEND')
    write(3,*)"file='",name(:lnblnk(name)),"'"
    write(3,*)"PSin=",PSin0,";  Amp=",Amp,";"
    close(3)
endif

contains

subroutine print_help(longhelp)
    implicit none
    logical, intent(in) :: longhelp

    if (longhelp) then
        print *,"Usage:      gls [<flag>] <inputfile>"
        print *,"Where:"
        print *," <inputfile> contains the input time series in columns:"
        print *,"             time, flux [, flux error]"
        print *," <flag> may be one or more of the following options:"
        print *,"        -e2 : use chi^2 weightening (= use error bars)"
        print *,"        -ne : use variance weightening (= don't use error bars)"
        print *,"        -s  : write out spectrum (output file is <inputfile>.gls)"
        print *,"        -ns : don't write out spectrum"
        print *,"        -v  : verbose mode (writes out information on STDOUT)"
        print *,"Optionally, a parameter file called 'gls.par' can be provided."
        print *,"The parameter file overrides default settings, flags override both."
        print *,"Normal output is one line to STDOUT with the following values:"
        print *,"  <filename>, number of points in time series, main frequency [d^-1],"
        print *,"  GLS power of main frequency, high frequency limit, number of independent frequencies,"
        print *,"  analytical false alarm probability (FAP), [Monte Carlo FAP,] nominal frequency resolution"
        print *,""
        stop
    else
        print *,"Usage:      gls [<flag>] <inputfile>"
	       print *,"Type 'gls -help' for more info."
	       stop
    endif

end subroutine print_help

end program gls


module ops
    use fstack
    contains
        subroutine ops_add(stack) ! Add 2 numbers from the stack
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = a + b
            call fs_push(stack, c)
        end subroutine ops_add
        subroutine ops_sub(stack) ! See add
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = b - a
            call fs_push(stack, c)
        end subroutine ops_sub
        subroutine ops_mul(stack) ! See add
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = a * b
            call fs_push(stack, c)
        end subroutine ops_mul
        subroutine ops_div(stack) ! See add
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = b / a
            call fs_push(stack, c)
        end subroutine ops_div
        subroutine ops_mod(stack) ! Modulo
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = modulo(b,a)
            call fs_push(stack, c)
        end subroutine ops_mod
        subroutine ops_pow(stack) ! Powers
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = b ** a
            call fs_push(stack, c)
        end subroutine ops_pow
        subroutine ops_inv_pow(stack) ! Roots, via inverse powers
            type(fs_stack), intent(inout) :: stack
            real :: a,b,c
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = b ** (1/a)
            call fs_push(stack, c)
        end subroutine ops_inv_pow
        subroutine ops_sin(stack) ! Trig functions
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = sind(a)
            call fs_push(stack, c)
        end subroutine ops_sin
        subroutine ops_cos(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = cosd(a)
            call fs_push(stack, c)
        end subroutine ops_cos
        subroutine ops_tan(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = tand(a)
            call fs_push(stack, c)
        end subroutine ops_tan
        subroutine ops_rtan(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = tan(a)
            call fs_push(stack, c)
        end subroutine ops_rtan
        subroutine ops_rsin(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = sin(a)
            call fs_push(stack, c)
        end subroutine ops_rsin
        subroutine ops_rcos(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = cos(a)
            call fs_push(stack, c)
        end subroutine ops_rcos
        subroutine ops_acos(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = acosd(a)
            call fs_push(stack, c)
        end subroutine ops_acos
        subroutine ops_asin(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = asind(a)
            call fs_push(stack, c)
        end subroutine ops_asin
        subroutine ops_atan(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = atand(a)
            call fs_push(stack, c)
        end subroutine ops_atan
        subroutine ops_acosr(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = acos(a)
            call fs_push(stack, c)
        end subroutine ops_acosr
        subroutine ops_asinr(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = asin(a)
            call fs_push(stack, c)
        end subroutine ops_asinr
        subroutine ops_atanr(stack)
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = atan(a)
            call fs_push(stack, c)
        end subroutine ops_atanr
        subroutine ops_loge(stack) ! Natural Log
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = log(a)
            call fs_push(stack, c)
        end subroutine ops_loge
        subroutine ops_log10(stack) ! Log 10
            type(fs_stack), intent(inout) :: stack
            real :: a,c
            call fs_pop(stack, a)
            c = log10(a)
            call fs_push(stack, c)
        end subroutine ops_log10
        subroutine ops_log(stack) ! Log with base of number off stack, via natural log division.
            type(fs_stack), intent(inout) :: stack
            real :: a,c,b
            call fs_pop(stack, a)
            call fs_pop(stack, b)
            c = log (a) / log (b)
            call fs_push(stack, c)
        end subroutine ops_log
end module ops


!----------------------------------------------------------------------------- best with 100 columns

function BDFNewtonKrylov1()
  use modSUNDIALS
  use iso_c_binding
  integer::BDFNewtonKrylov1
  type(BDFNewtonKrylov)::p
  double precision::t,s(2)

  BDFNewtonKrylov1=0
  call p%init(2,func)
  call p%setTol(1d-8,1d-12)
  call p%setMaxSteps(-1)
  t=0d0
  s(:)=[1d0,0d0]
  call p%setIV(t,s)
  do while(t<2d0)
    call p%step(2d0,t,s)
  end do
  if(norm2(s-[cos(t),-sin(t)])>1d-6)then
    BDFNewtonKrylov1=1
  end if
  call p%clear()

contains

  function func(ct,cx,cdx,dat)
    use iso_c_binding
    use modSUNDIALS
    real(C_DOUBLE),value::ct
    type(C_PTR),value::cx,cdx,dat
    integer(C_INT)::func
    double precision::t
    double precision,pointer::x(:)
    double precision,pointer::dx(:)
    type(C_PTR)::foo

    t=ct
    call associateVector(cx,x)
    call associateVector(cdx,dx)
    dx(1:2)=[x(2),-x(1)]
    func=0
    foo=dat
  end function

end function


	FUNCTION BXPA(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE WIND X SEARCH COIL,PREAMP AND
C	INPUT STAGE ON THE 212 BOARD.
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA Q,T0,F0 / 1.43,2.62E-3,1700./     		! T0 is in Volts/nT
	DATA C10,R1,R2,C1/ .959E-6, 49.9E3, 1.E6, 1.005E-9/
	DATA TWOPI /6.2831853/
C
C
	W = TWOPI*F
C	OUTPUT OF SEARCH COIL PLUS PREAMP, VOLTS/nT
	CGAIN = T0/CMPLX(1.,Q*(F/F0 - F0/F))
C
C	EFFECT OF INPUT ON 212 BOARD
C
	Y2 = CMPLX(1./R2,W*C1)
	Z1 = CMPLX(R1, -1./W/C10)
	CGAIN = CGAIN/(Z1*Y2)
C
C	NORMALIZE TO E PREAMPS
C
	CGAIN = 21.*CGAIN
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPADC = CABS(CGAIN)
	RETURN
	END


      module MOD_MOMADD
      contains
C**********  MODULNAME: MOMADD    ******* 24/03/87  19.29.57.******   109 KARTEN
      SUBROUTINE MOMADD (JP,LMAX,ND,NP,Z,RADIUS,P,W0,W1,W2,W3,
     $                   WBMHO,WBMNO,WBMHI,WBMNI )
C***  AT GIVEN IMPACT-PARAMETER INDEX JP, THIS SUBROUTINE CALCULATES THE
C***  WEIGHTS FOR THE ANGLE INTEGRATION OF THE 0. TO 3. MOMENTS
C***  THE WEIGHTS W0 AND W2 ARE CALCULATED FOR THE ORIGINAL DEPTH POINTS
C***  THE WEIGHTS W1 AND W3 ARE CALCULATED FOR INTERMESH POINTS
C***  SPECIAL WEIGHTS WBMH AND WBMN ARE CALCULATED FOR THE OUTER BOUNDARY
      implicit real*8(a-h,o-z)

	parameter (two=2.0d0,three=3.0d0,four=4.0d0,six=6.0d0,half=0.5d0)

      DIMENSION W0(ND),W1(ND),W2(ND),W3(ND)
      DIMENSION Z(ND,NP),P(NP),RADIUS(ND)

C***  0. AND 2. MOMENT. THE INTEGRATION IS PERFORMED IN THE Z VARIABLE
      DO 10 L=1,LMAX
      RL=RADIUS(L)
      RL2=RL+RL
      RRR12=RL*RL*RL*12.d0
      IF (JP.GT.1) GOTO 8
C***  FIRST STEP IF JP=1
      B=Z(L,1)
      A=Z(L,2)
      W0(L)=(B-A)/RL2
      AA=A*A
      BB=B*B
      W2(L)=(B*(three*BB-AA)-A*(BB+AA))/RRR12
      GOTO 10
    8 IF (L.EQ.LMAX .AND. JP.GT.(NP-ND) ) GOTO 9
C***  INTERMEDIATE STEP
      A=Z(L,JP+1)
      B=Z(L,JP)
      C=Z(L,JP-1)
      W0(L)=(C-A)/RL2
      AA=A*A
      BB=B*B
      CC=C*C
      W2(L)=(B*(CC-AA)+C*(CC+BB)-A*(BB+AA))/RRR12
      GOTO 10
C***  LAST STEP, IMPLYING Z(L,JMAX)=0
    9 B=Z(L,JP-1)
      W0(L)=B/RL2
      W2(L)=B*B*B/RRR12
   10 CONTINUE

C***  THE FEAUTRIER FLUX V IS ADDED TO THE 1. AND 3. MOMENTS .
C***  THE DEPTH POINTS FOR THE MOMENTS ARE ASSUMED TO LIE ON THE RADIUS-
C***  INTERMESH. THIS IS ONLY APPROXIMATELY, BECAUSE FROM THE RAY-BY-RAY
C***  FORMAL SOLUTION V RESULTS AT INTERSTICES IN THE Z COORDINATE.
C***  THE INTEGRATION IS CARRIED OUT IN P
C***  1. MOMENT    MUE DMUE  =  P DP / R**2
C***  3. MOMENT   MUE**3 DMUE  =  P DP /R**2  -  P**3 DP /R**4
C***  THE WEIGHTS ARE INDEPENDENT OF THE DEPTH, EXCEPT OF THE DIVISOR
C***  CONTAINING R, AND EXCEPT OF THE LAST POINT LZ
      LZ=LMAX-1
C***  FIRST STEP
      IF (JP.GT.1 ) GOTO 2
      B=P(2)
      BB=B*B
      WW1=BB
      WW3=BB*BB
      GOTO 5
C***  INTERMEDIATE STEPS
    2 A=P(JP-1)
      B=P(JP)
      C=P(JP+1)
      WW1=(A+B+C)*(C-A)
      AA=A*A
      BB=B*B
      CC=C*C
      WW3=(B-A)*(AA*(A+two*B)+BB*(three*A+four*B))
     $  +(C-B)*(CC*(C+two*B)+BB*(three*C+four*B))
C***  FOR THE LAST INTERVAL (L=LZ TO THE P AXIS), THE NEXT POINT IS AN
C***  INTERMESH-POINT IN P
      C=half*(B+C)
      W1LZ=(A+B+C)*(C-A)
      CC=C*C
      W3LZ=(B-A)*(AA*(A+two*B)+BB*(three*A+four*B))
     $  +(C-B)*(CC*(C+two*B)+BB*(three*C+four*B))
C***  NO WEIGHT FOR THE Z=0 POINT IS CALCULATED, AS V=0 THERE FOR SYMMETRY .

C***  LOOP OVER DEPTH INDEX L
    5 DO 1 L=1,LZ
      RZ=half*(RADIUS(L)+RADIUS(L+1))
      RZQ6=RZ*RZ*six
      RRRR20=RZ*RZ*RZ*RZ*20.d0
      IF (L.NE.LZ .OR. JP.LE.(NP-ND) ) GOTO 4
         W1(L)=W1LZ/RZQ6
         W3(L)=W1(L)-W3LZ/RRRR20
         GOTO 1
    4 W1(L)=WW1/RZQ6
      W3(L)=W1(L)-WW3/RRRR20
    1 CONTINUE

C***  SPECIAL WEIGHTS AT THE OUTER BOUNDARY (FOR H AND N )
      R=RADIUS(1)
      WBMHO=WW1/R/R/six
      WBMNO=WBMHO-WW3/R/R/R/R/20.d0
C***  SPECIAL WEIGHTS AT THE INNER BOUNDARY
      IF (LMAX.LT.ND) GOTO 99
      IF (JP.LE.NP-ND) GOTO 3
C***  CORE TANGENT RAY, LAST STEP OF INTEGRATION
      WW1=(B-A)*(two*B+A)
      WW3=(B-A)*(AA*(A+2*B)+BB*(three*A+4*B))
    3 CONTINUE
      WBMHI=WW1/six
      WBMNI=WBMHI-WW3/20.d0

   99 RETURN
      end subroutine
      end module


      subroutine phi3m(xth,xphi,p0,p1,p2,m1,m2,wt,*)
c     massive particle p0 in rest frame
c     decaying into p1 fixed mass m1 and p2 fixed mass m2.
c     vectors returned p1 and p2 are in the frame in which
C     p0 is supplied
c result is 1/8/pi * 2|p|/sqrts  * domega/(4*pi)
c     factor of (2*pi)^4 included in definition of phase space
      implicit none
      include 'constants.f'
      include 'process.f'
      double precision p0(4),p1(4),p2(4),p1cm(4)
      double precision xth,xphi,phi,s,roots,costh,sinth
      double precision wt0,wt
      double precision m1,m2,m1sq,m2sq,lambda,lambda2,smin
      integer j
      parameter(wt0=one/eight/pi)

      wt=0d0

      s=p0(4)**2-p0(1)**2-p0(2)**2-p0(3)**2

      smin=(m1+m2)**2
      if (s .lt. smin) then
       if (case(1:4) .ne. 'vlch') then
        write(6,*) 's<smin',s,smin
       endif
       return 1
      endif

      if (dsqrt(s)-m1-m2 .lt. 0d0) return 1

      roots=dsqrt(s)
      m1sq=m1**2
      m2sq=m2**2
      costh=two*xth-one
      sinth=dsqrt(one-costh**2)
      phi=twopi*xphi

      lambda2=((s+m1sq-m2sq)**2-4d0*m1sq*s)

      if (lambda2 .lt. 0d0) then
      write(6,*) 'phi3m:lambda2=', lambda2
      return 1
      endif
      lambda=dsqrt(lambda2)

      p1cm(4)=roots/two*(s+m1sq-m2sq)/s
      p1cm(1)=roots/two*lambda/s*sinth*dsin(phi)
      p1cm(2)=roots/two*lambda/s*sinth*dcos(phi)
      p1cm(3)=roots/two*lambda/s*costh

c      write(6,*) 'e',roots/two*(s+m1sq-m2sq)/s
c      write(6,*) 'p',roots/two*lambda/s

c      write(6,*) 'sinth',sinth
c      write(6,*) 'costh',costh
c      write(6,*) 'p1cm**2',p1cm(4)**2-p1cm(1)**2-p1cm(2)**2-p1cm(3)**2
c      pause

      call boost(roots,p0,p1cm,p1)
      do j=1,4
      p2(j)=p0(j)-p1(j)
      enddo

      if (  (p0(4) .lt. 0d0)
     & .or. (p1(4) .lt. 0d0)
     & .or. (p2(4) .lt. 0d0)) then
      write(6,*) 'p0',p0(4),p0(4)**2-p0(1)**2-p0(2)**2-p0(3)**2,s
      write(6,*) 'p1',p1(4),p1(4)**2-p1(1)**2-p1(2)**2-p1(3)**2,m1sq
      write(6,*) 'p2',p2(4),p2(4)**2-p2(1)**2-p2(2)**2-p2(3)**2,m2sq
      write(6,*) 'in phi3m'
      return 1
      endif

      wt=wt0*lambda/s

      return
      end


      SUBROUTINE slPRCS (SYSTEM, EP0, EP1, RA, DC)
*+
*     - - - - - - -
*      P R C E
*     - - - - - - -
*
*  Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or
*  FK5 (Fricke, post IAU 1976) as required.
*
*  Given:
*     SYSTEM     int    precession to be applied: 1 = FK4 or 2 = FK5
*     EP0,EP1    dp     starting and ending epoch
*     RA,DC      dp     RA,Dec, mean equator & equinox of epoch EP0
*
*  Returned:
*     RA,DC      dp     RA,Dec, mean equator & equinox of epoch EP1
*
*  Called:    slDA2P, slPRBN, slPREC, slDS2C,
*             slDMXV, slDC2S
*
*  Notes:
*
*     1)  Lowercase characters in SYSTEM are acceptable.
*
*     2)  The epochs are Besselian if SYSTEM=FK4 and Julian if FK5.
*         For example, to precess coordinates in the old system from
*         equinox 1900.0 to 1950.0 the call would be:
*             CALL slPRCS (1, 1900D0, 1950D0, RA, DC)
*
*     3)  This routine will NOT correctly convert between the old and
*         the new systems - for example conversion from B1950 to J2000.
*         For these purposes see slFK45, slFK54, slF45Z and
*         slF54Z.
*
*     4)  If an invalid SYSTEM is supplied, values of -99D0,-99D0 will
*         be returned for both RA and DC.
*
*  P.T.Wallace   Starlink   20 April 1990
*-

      IMPLICIT NONE

      INTEGER SYSTEM
      DOUBLE PRECISION EP0,EP1,RA,DC

      DOUBLE PRECISION PM(3,3),V1(3),V2(3)

      DOUBLE PRECISION slDA2P

*  Convert to uppercase and validate SYSTEM
      IF (SYSTEM.NE.1.AND.SYSTEM.NE.2) THEN
         RA=-99D0
         DC=-99D0
      ELSE

*     Generate appropriate precession matrix
         IF (SYSTEM.EQ.1) THEN
            CALL slPRBN(EP0,EP1,PM)
         ELSE
            CALL slPREC(EP0,EP1,PM)
         END IF

*     Convert RA,Dec to x,y,z
         CALL slDS2C(RA,DC,V1)

*     Precess
         CALL slDMXV(PM,V1,V2)

*     Back to RA,Dec
         CALL slDC2S(V2,RA,DC)
         RA=slDA2P(RA)

      END IF

      END


      subroutine destsv(n,r,ldr,svmin,z)
      integer ldr, n
      double precision svmin
      double precision r(ldr,n), z(n)

c Minpack Copyright Notice (1999) University of Chicago.  All rights reserved
c see CopyrightMINPACK.txt
c
c     **********
c
c     Subroutine destsv
c
c     Given an n by n upper triangular matrix R, this subroutine
c     estimates the smallest singular value and the associated
c     singular vector of R.
c
c     In the algorithm a vector e is selected so that the solution
c     y to the system R'*y = e is large. The choice of sign for the
c     components of e cause maximal local growth in the components
c     of y as the forward substitution proceeds. The vector z is
c     the solution of the system R*z = y, and the estimate svmin
c     is norm(y)/norm(z) in the Euclidean norm.
c
c     The subroutine statement is
c
c       subroutine estsv(n,r,ldr,svmin,z)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of R.
c         On exit n is unchanged.
c
c       r is a double precision array of dimension (ldr,n)
c         On entry the full upper triangle must contain the full
c            upper triangle of the matrix R.
c         On exit r is unchanged.
c
c       ldr is an integer variable.
c         On entry ldr is the leading dimension of r.
c         On exit ldr is unchanged.
c
c       svmin is a double precision variable.
c         On entry svmin need not be specified.
c         On exit svmin contains an estimate for the smallest
c            singular value of R.
c
c       z is a double precision array of dimension n.
c         On entry z need not be specified.
c         On exit z contains a singular vector associated with the
c            estimate svmin such that norm(R*z) = svmin and
c            norm(z) = 1 in the Euclidean norm.
c
c     Subprograms called
c
c       Level 1 BLAS ... dasum, daxpy, dnrm2, dscal
c
c     MINPACK-2 Project. October 1993.
c     Argonne National Laboratory
c     Brett M. Averick and Jorge J. More'.
c
c     **********
      double precision one, p01, zero
      parameter (zero=0.d0,p01=1.0d-2,one=1.0d0)

      integer i, j
      double precision e, s, sm, temp, w, wm, ynorm, znorm

      double precision dasum, dnrm2
      external dasum, daxpy, dnrm2, dscal

      do i = 1, n
         z(i) = zero
      end do

c     This choice of e makes the algorithm scale invariant.

      e = abs(r(1,1))
      if (e .eq. zero) then
         svmin = zero
         z(1) = one
         return
      end if

c     Solve R'*y = e.

      do i = 1, n

c        Scale y. The factor of 0.01 reduces the number of scalings.

         e = sign(e,-z(i))
         if (abs(e-z(i)) .gt. abs(r(i,i))) then
            temp = min(p01,abs(r(i,i))/abs(e-z(i)))
            call dscal(n,temp,z,1)
            e = temp*e
         end if

c        Determine the two possible choices of y(i).

         if (r(i,i) .eq. zero) then
            w = one
            wm = one
         else
            w = (e-z(i))/r(i,i)
            wm = -(e+z(i))/r(i,i)
         end if

c        Choose y(i) based on the predicted value of y(j) for j > i.

         s = abs(e-z(i))
         sm = abs(e+z(i))
         do j = i + 1, n
            sm = sm + abs(z(j)+wm*r(i,j))
         end do
         if (i .lt. n) then
            call daxpy(n-i,w,r(i,i+1),ldr,z(i+1),1)
            s = s + dasum(n-i,z(i+1),1)
         end if
         if (s .lt. sm) then
            temp = wm - w
            w = wm
            if (i .lt. n) call daxpy(n-i,temp,r(i,i+1),ldr,z(i+1),1)
         end if
         z(i) = w

      end do

      ynorm = dnrm2(n,z,1)

c     Solve R*z = y.

      do j = n, 1, -1

c        Scale z.

         if (abs(z(j)) .gt. abs(r(j,j))) then
            temp = min(p01,abs(r(j,j))/abs(z(j)))
            call dscal(n,temp,z,1)
            ynorm = temp*ynorm
         end if
         if (r(j,j) .eq. zero) then
            z(j) = one
         else
            z(j) = z(j)/r(j,j)
         end if
         temp = -z(j)
         call daxpy(j-1,temp,r(1,j),1,z,1)

      end do

c     Compute svmin and normalize z.

      znorm = one/dnrm2(n,z,1)
      svmin = ynorm*znorm
      call dscal(n,znorm,z,1)

      end


module faddeeva_fortran_interface
    integer, parameter, public :: dp=kind(0.d0)
    interface
        !> @brief the error function
        !!
        !! computes erf(z), where erf - the error function
        !!
        !! @param[in]   z       a complex value
        !! @param[in]   relerr  demanding relative error
        !! @return      a complex value of the mentioned function
        complex (c_double_complex) function Faddeeva_erf(z, relerr) bind(c, name = 'Faddeeva_erf')
            use iso_c_binding
            complex(c_double_complex), value :: z
            real(c_double), value :: relerr
        end function Faddeeva_erf

        !> @brief the imaginary error function
        !!
        !! computes erfi(z) = -i*erf(i*z), where erf is the error function
        !!
        !! @param[in]   z       a complex value
        !! @param[in]   relerr  demanding relative error
        !! @return      a complex value of the mentioned function
        complex (c_double_complex) function Faddeeva_erfi(z, relerr) bind(c, name = 'Faddeeva_erfi')
            use iso_c_binding
            complex(c_double_complex), value :: z
            real(c_double), value :: relerr
        end function Faddeeva_erfi

        !> @brief the complementary error function
        !!
        !! computes erfc(z) = 1 - erf(z), where erf is the error function
        !!
        !! @param[in]   z       a complex value
        !! @param[in]   relerr  demanding relative error
        !! @return      a complex value of the mentioned function
        complex (c_double_complex) function Faddeeva_erfc(z, relerr) bind(c, name = 'Faddeeva_erfc')
            use iso_c_binding
            complex(c_double_complex), value :: z
            real(c_double), value :: relerr
        end function Faddeeva_erfc

        !> @brief the scaled complementary error function
        !!
        !! computes erfcx(z) = exp(z*z)*erfc(z), where erfc is the complementary error function
        !!
        !! @param[in]   z       a complex value
        !! @param[in]   relerr  demanding relative error
        !! @return      a complex value of the mentioned function
        complex (c_double_complex) function Faddeeva_erfcx(z, relerr) bind(c, name = 'Faddeeva_erfcx')
            use iso_c_binding
            complex(c_double_complex), value :: z
            real(c_double), value :: relerr
        end function Faddeeva_erfcx

        !> @brief the Faddeeva function of complex argument
        !!
        !! computes w(z) = exp(-z*z)*erfc(-i*z), where erfc - the complementary error function
        !!
        !! @param[in]   z       argument
        !! @param[in]   relerr  demanding relative error
        !! @return      a complex value of the mentioned function
        complex (c_double_complex) function Faddeeva_w(z, relerr) bind(c, name = 'Faddeeva_w')
            use iso_c_binding
            complex(c_double_complex), value :: z
            real(c_double), value :: relerr
        end function Faddeeva_w

        !> @brief the dawson function
        !!
        !! computes Dawson(z) = sqrt(pi)/2*exp(-z*z)*erfi(z), the erfi is the imaginary error function
        !!
        !! @param[in]   z       a complex value
        !! @param[in]   relerr  demanding relative error
        !! @return      a complex value of the mentioned function
        complex (c_double_complex) function Faddeeva_dawson(z, relerr) bind(c, name = 'Faddeeva_Dawson')
            use iso_c_binding
            complex(c_double_complex), value :: z
            real(c_double), value :: relerr
        end function Faddeeva_dawson
    end interface

    contains
        !> @brief provide an example of usage
        !!
        !! provide a terminal output of function name, input arguments,
        !! demanding relative error and computational results
        !!
        !! @param[in]   func            a pointer to the function
        !! @param[in]   func_name       function name as a string
        !! @param[in]   z               a complex value
        !! @param[in]   relerr          demanding relative error
        subroutine example(func, func_name, z, relerr)
            character(len=15), intent(in) :: func_name
            complex(dp) :: z
            real(dp) :: relerr

            interface AFunc
                function func(z, relerr)
                    use iso_c_binding
                    complex(c_double_complex), value :: z
                    real(c_double), value :: relerr
                    complex(c_double_complex) :: func
                end function
            end interface

            if (relerr < 2.22e-16_dp) relerr = 2.22e-16_dp !according to https://en.wikipedia.org/wiki/Machine_epsilon
            print *, func_name, ' of argument z =', z, 'with relative error' , relerr, 'equals ', func(z, relerr)

        end subroutine example

        !> @brief define a relative error between two real input arguments
        !!
        !! @param[in]   a       real argument
        !! @param[in]   b       real argument
        !! @return      a relative error
        real(dp) function find_relerr(a, b)
            real(dp), intent(in) :: a, b

            find_relerr = abs((b-a)/a)

        end function find_relerr
end module faddeeva_fortran_interface


! This routine will perform a coordinates conversion. It takes the
! heliocentric angle (theta), the line-of-sight magnetic inclination
! (Gamma_p) and azimuth (Chi_p) and returns the local inclination (Gamma)
! and azimuth (Chi). All of these angles are real arrays of size npoints.
!
! It is assumed that the heliocentriz azimuth is zero, which means that
! the observed point is on the E-W line that crosses the solar disk center.
! If that is not the case, the azimuth obtained is uncalibrated by an
! additive constant.
!
! navarro@hao.ucar.edu , Mar 2000
!
Subroutine los_to_local(npoints, Theta, Gamma_p, Chi_p, Gamma, Chi)
  Implicit None
  Integer :: npoints
  Real :: Theta
  Real, parameter :: Pi = 3.14159265389793D0, Deg_to_rad = Pi/180.
  Real, dimension (npoints) :: Gamma, Chi, Gamma_p, Chi_p
!
! Do NOT convert!
!
  Chi=Chi_p
  Gamma=Gamma_p
  Return
!
!
!
!
!
! Piece of cake
!
  Chi=Chi_p
  Gamma=Acos(Cos(Gamma_p*Deg_to_rad)*Cos(Theta*Deg_to_rad) + &
       Sin(Gamma_p*Deg_to_rad)*Cos(Chi_p*Deg_to_rad)*Sin(Theta*Deg_to_rad)) /&
       Deg_to_rad
!
! Done!
!
  Return
End Subroutine los_to_local


C$Procedure      AXISAR ( Axis and angle to rotation )

      SUBROUTINE AXISAR ( AXIS, ANGLE, R )

C$ Abstract
C
C     Construct a rotation matrix that rotates vectors by a specified
C     angle about a specified axis.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C     MATRIX
C     ROTATION
C
C$ Declarations

      DOUBLE PRECISION      AXIS  ( 3 )
      DOUBLE PRECISION      ANGLE
      DOUBLE PRECISION      R     ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     AXIS       I   Rotation axis.
C     ANGLE      I   Rotation angle, in radians.
C     R          O   Rotation matrix corresponding to AXIS and ANGLE.
C
C$ Detailed_Input
C
C     AXIS,
C     ANGLE          are, respectively, a rotation axis and a rotation
C                    angle.  AXIS and ANGLE determine a coordinate
C                    transformation whose effect on any vector V is to
C                    rotate V by ANGLE radians about the vector AXIS.
C
C$ Detailed_Output
C
C     R              is a rotation matrix representing the coordinate
C                    transformation determined by AXIS and ANGLE:  for
C                    each vector V, R*V is the vector resulting from
C                    rotating V by ANGLE radians about AXIS.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)  If AXIS is the zero vector, the rotation generated is the
C         identity.  This is consistent with the specification of VROTV.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     AXISAR can be thought of as a partial inverse of RAXISA.  AXISAR
C     really is a `left inverse':  the code fragment
C
C        CALL RAXISA ( R,    AXIS,  ANGLE )
C        CALL AXISAR ( AXIS, ANGLE, R     )
C
C     preserves R, except for round-off error, as long as R is a
C     rotation matrix.
C
C     On the other hand, the code fragment
C
C        CALL AXISAR ( AXIS, ANGLE, R     )
C        CALL RAXISA ( R,    AXIS,  ANGLE )
C
C     preserves AXIS and ANGLE, except for round-off error, only if
C     ANGLE is in the range (0, pi).  So AXISAR is a right inverse
C     of RAXISA only over a limited domain.
C
C$ Examples
C
C     1)  A matrix that rotates vectors by pi/2 radians about the z-axis
C         can be found using the code fragment
C
C            AXIS(1) = 0.D0
C            AXIS(2) = 0.D0
C            AXIS(3) = 1.D0
C
C            CALL AXISAR ( AXIS, HALFPI(), R )
C
C         The returned matrix R will equal
C
C            +-               -+
C            |  0    -1     0  |
C            |                 |
C            |  1     0     0  |.
C            |                 |
C            |  0     0     1  |
C            +-               -+
C
C
C     2)  Linear interpolation between two rotation matrices:
C
C            Let R(t) be a time-varying rotation matrix; R could be
C            a C-matrix describing the orientation of a spacecraft
C            structure.  Given two points in time t1 and t2 at which
C            R(t) is known, and given a third time t3, where
C
C               t1  <  t3  <  t2,
C
C            we can estimate R(t3) by linear interpolation.  In other
C            words, we approximate the motion of R by pretending that
C            R rotates about a fixed axis at a uniform angular rate
C            during the time interval [t1, t2].  More specifically, we
C            assume that each column vector of R rotates in this
C            fashion.  This procedure will not work if R rotates through
C            an angle of pi radians or more during the time interval
C            [t1, t2]; an aliasing effect would occur in that case.
C
C            If we let
C
C               R1 = R(t1)
C               R2 = R(t2), and
C
C                           -1
C               Q  = R2 * R1  ,
C
C            then the rotation axis and angle of Q define the rotation
C            that each column of R(t) undergoes from time t1 to time
C            t2.  Since R(t) is orthogonal, we can find Q using the
C            transpose of R1.  We find the rotation axis and angle via
C            RAXISA.
C
C               CALL MXMT   ( R2,   R1,    Q      )
C               CALL RAXISA ( Q,    AXIS,  ANGLE  )
C
C            Find the fraction of the total rotation angle that R
C            rotates through in the time interval [t1, t3].
C
C               FRAC = ( T3 - T1 )  /  ( T2 - T1 )
C
C            Finally, find the rotation DELTA that R(t) undergoes
C            during the time interval [t1, t3], and apply that rotation
C            to R1, yielding R(t3), which we'll call R3.
C
C               CALL AXISAR ( AXIS,   FRAC * ANGLE,  DELTA  )
C               CALL MXM    ( DELTA,  R1,            R3     )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 25-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VROTV call.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 30-AUG-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     axis and angle to rotation
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 25-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VROTV call.
C
C        Identity matrix is now obtained from IDENT.
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      VTEMP ( 3 )
      INTEGER               I

C
C     First, set R equal to the identity.
C
      CALL IDENT ( R )

C
C     The matrix we want rotates EVERY vector by ANGLE about AXIS.
C     In particular, it does so to our basis vectors.  The columns
C     of R are the images of the basis vectors under this rotation.
C
      DO I = 1, 3
         CALL VROTV ( R(1,I), AXIS, ANGLE, VTEMP  )
         CALL VEQU  ( VTEMP,               R(1,I) )
      END DO

      RETURN
      END


	SUBROUTINE SNDHLC ( nparms, nlevel, hdata, iret )
C************************************************************************
C* SNDHLC								*
C*									*
C* This routine will compute the Helicity for a sounding processed	*
C* with SNDIAG.								*
C*									*
C* SNDHLC ( NPARMS, NLEVEL, HDATA, IRET )				*
C*									*
C* Input parameters:							*
C*	NPARMS		INTEGER		Number of parameters		*
C*	NLEVEL		INTEGER		Number of levels		*
C*									*
C* Input/Output parameters:						*
C*	HDATA (LLMXLV)	REAL		Interpolated sounding data	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	REAL		hdata(*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
	DO  i = 1, nlevel
	    IF  ( ( .not. ERMISS(hdata((i-1)*nparms+IUWND)) ) .and.
     +            ( .not. ERMISS(hdata((i-1)*nparms+IVWND)) ) .and.
     +            ( .not. ERMISS(hdata(0*nparms+IUWND)) ) .and.
     +            ( .not. ERMISS(hdata(0*nparms+IVWND)) ) )  THEN
		IF  ( hdata((i-1)*nparms+IHGHT) .ne.
     +		      hdata(0*nparms+IHGHT) )  THEN
		    term1 = hdata((i-1)*nparms+IVWND) *
     +			(hdata((i-1)*nparms+IUWND)-
     +				hdata(0*nparms+IUWND)) /
     +			(hdata((i-1)*nparms+IHGHT)-
     +				hdata(0*nparms+IHGHT))
		    term2 = hdata((i-1)*nparms+IUWND) *
     +		    	(hdata((i-1)*nparms+IVWND)-
     +				hdata(0*nparms+IVWND)) /
     +		    	(hdata((i-1)*nparms+IHGHT)-
     +				hdata(0*nparms+IHGHT))
		    hdata((i-1)*nparms+IHELC) = term1 - term2
		ELSE
		    hdata((i-1)*nparms+IHELC) = RMISSD
		END IF
	    END IF
	END DO
C*
	RETURN
	END


program rzf
use omp_lib

double precision pi, pi_squared_over_6, zeta_2, zeta, z2, zeta_fixed2
integer*8 N, u, l, Nthr, thrid
pi = 4.0d0*atan(1.0d0)
pi_squared_over_6 = pi*pi / 6.0d0
N = 16000000000_8
zeta_2 = 0.0d0

!$OMP PARALLEL shared(N) private(u,l,Nthr,thrid,i,z2)
thrid = OMP_GET_THREAD_NUM()
Nthr  = omp_get_num_threads()

u     = N/Nthr * (thrid + 1)
l     = N/Nthr * (thrid) + 1
!z2    = zeta(u,l,2_8)
z2      = zeta_fixed2(u,l)

!$OMP ATOMIC
zeta_2 = zeta_2 + z2

!zeta(N,2_8)
!$OMP END PARALLEL

print *,"    zeta(2) = ",zeta_2
print *,"pi^2 / 6.0  = ",pi_squared_over_6
print *,"      error = ",pi_squared_over_6 - zeta_2

end

double precision function zeta(upper,lower,a)
integer*8 N,a,k,upper,lower
integer unr
double precision xsum, ri
double precision, dimension(4) :: r,ik,dk = (/ 4.0d0,4.0d0,4.0d0,4.0d0/), qsum = 0.0d0

xsum = 0.0

do unr=1,4
  ik(unr) = dble( upper - (unr-1) )
enddo

do k=upper,lower,-4
        r = 1.0d0 / ik
        ik = ik - dk
        qsum = qsum + r**a
enddo

zeta = xsum + sum(qsum)

end function

double precision function zeta_fixed2(upper,lower)
integer*8 N,k,upper,lower
integer unr
double precision xsum, ri
double precision, dimension(4) :: r,ik,dk = (/ 4.0d0,4.0d0,4.0d0,4.0d0/), qsum = 0.0d0

xsum = 0.0

do unr=1,4
  ik(unr) = dble( upper - (unr-1) )
enddo

do k=upper,lower,-4
        r = 1.0d0 / ik
        ik = ik - dk
        qsum = qsum + r*r ! r**a, when a is fixed at 2
enddo

zeta_fixed2 = xsum + sum(qsum)

end function


	FUNCTION FLILO(X,B)
C
C
C       FLILO MEANS LINEAR FUNCTION FOR SMALL ARGUMENT
C       AND LOGARITHM FOR LARGE ARGUMENT
C       SIGN IS PRESERVED
C       FOR /X/.LT.B   FLILO=X
C       FOR /X/.GT.B   FLILO=A*LOG(X)+C IN SUCH A WAY
C       THAT FLILO AND ITS DERIVATIVE ARE CONTINUOUS AT /X/=/B/
C
        XM=ABS(X)
        IF(XM.GT.B) GO TO 1
	 FLILO=X
        RETURN
    1   FT=B*ALOG(XM/B)+B
        FLILO=SIGN(FT,X)
        RETURN
	END
         FUNCTION AFLILO(X,B)
C
C       INVERSE OF FLILO
C
        XM=ABS(X)
        IF(XM.GT.B) GO TO 1
        AFLILO=X
        RETURN
    1   FT=B*EXP(XM/B-1.)
        AFLILO=SIGN(FT,X)
        RETURN
        END


program P3
  implicit none
  real*8, external :: drand48
  real*8 :: I=0,x
  integer :: n,j
  n = 0
  ! do-while loop until reach desired accuracy
  do while (abs(I-155.0/6)>1E-4)
     x = 0
     n = n + 1
     ! do loop to scatter one point in 10-D space
     do j = 1,10
       x = x + drand48()
     enddo
     I = I * ( n - 1 ) + x**2 ! reverse the total value in 10-D space for n trails
     I = I / n ! average value of all the n possible points is the integration result
     print "(i6,2x,f6.3)", n, I
  enddo
end program P3


*----------------------------------------------------------------------*
      subroutine inv_svd(vx,amat,vb,ndim,inc_b)
*----------------------------------------------------------------------*
*     solve A*x + b = 0 by singular value decomposition
*     A(ndim,ndim), vx(ndim), vb(inc_b,ndim)
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     ndim, inc_b
      real(8), intent(in) ::
     &     amat(ndim,ndim)
      real(8), intent(inout) ::
     &     vx(ndim)
      real(8), intent(in) ::
     &     vb(inc_b,ndim)

      real(8), parameter ::
     &     thrsh = 1d-12

      real(8), pointer ::
     &     umat(:,:), vtmat(:,:), wrk(:), singval(:)

      integer ::
     &     idx, kdx, info, lwrk

      lwrk=max(1024,ndim*ndim)
      allocate(umat(ndim,ndim),vtmat(ndim,ndim),
     &     wrk(lwrk),singval(ndim))

      call dgesvd('A','A',ndim,ndim,
     &     amat,ndim,singval,
     &     umat,ndim,vtmat,ndim,
     &     wrk,lwrk,info)

      if (info.ne.0) then
        write(lulog,*) 'WARNING: SVD seems to be in trouble'
      end if

      do idx = 1, ndim
        wrk(idx) = 0d0
        if (abs(singval(idx)).lt.thrsh) cycle
        do kdx = 1, ndim
          wrk(idx) = wrk(idx)+
     &         umat(kdx,idx)*vb(1,kdx)
        end do
        wrk(idx) = wrk(idx)/singval(idx)
      end do

      do idx = 1, ndim
        vx(idx) = 0d0
        do kdx = 1, ndim
          vx(idx) = vx(idx) +
     &         vtmat(kdx,idx)*wrk(kdx)
        end do
      end do

      return
      end


      SUBROUTINE MCON(ETA,INFINY,SMALNO,BASE)                           MCON4840
C MCON PROVIDES MACHINE CONSTANTS USED IN VARIOUS PARTS OF THE
C PROGRAM. THE USER MAY EITHER SET THEM DIRECTLY OR USE THE
C STATEMENTS BELOW TO COMPUTE THEM. THE MEANING OF THE FOUR
C CONSTANTS ARE -
C ETA       THE MAXIMUM RELATIVE REPRESENTATION ERROR
C WHICH CAN BE DESCRIBED AS THE SMALLEST POSITIVE
C FLOATING-POINT NUMBER SUCH THAT 1.0D0 + ETA IS
C GREATER THAN 1.0D0.
C INFINY    THE LARGEST FLOATING-POINT NUMBER
C SMALNO    THE SMALLEST POSITIVE FLOATING-POINT NUMBER
C BASE      THE BASE OF THE FLOATING-POINT NUMBER SYSTEM USED
C LET T BE THE NUMBER OF BASE-DIGITS IN EACH FLOATING-POINT
C NUMBER(DOUBLE PRECISION). THEN ETA IS EITHER .5*B**(1-T)
C OR B**(1-T) DEPENDING ON WHETHER ROUNDING OR TRUNCATION
C IS USED.
C LET M BE THE LARGEST EXPONENT AND N THE SMALLEST EXPONENT
C IN THE NUMBER SYSTEM. THEN INFINY IS (1-BASE**(-T))*BASE**M
C AND SMALNO IS BASE**N.
C THE VALUES FOR BASE,T,M,N BELOW CORRESPOND TO THE IBM/360.
      DOUBLE PRECISION ETA,INFINY,SMALNO,BASE
      INTEGER M,N,T
      BASE = 16.0D0
      T = 14
      M = 63
      N = -65
      ETA = BASE**(1-T)
      INFINY = BASE*(1.0D0-BASE**(-T))*BASE**(M-1)
      SMALNO = (BASE**(N+3))/BASE**3
      RETURN
      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                mncloc : clocur test program                        cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(38),w(19),u(19),t(40),c(80),wrk(1500),sp(40)
      integer iwrk(40)
      real al,del,fp,s
      integer i,idim,ier,iopt,ipar,is,i1,i2,j,j1,k,l,lwrk,l1,m,mx,
     * n,nc,nest,nk1
c  the data absciss values
      data x(1),x(3),x(5),x(7),x(9),x(11),x(13),x(15),x(17),x(19),x(21),
     * x(23),x(25),x(27),x(29),x(31),x(33),x(35)/-4.7,-7.048,-6.894,
     * -3.75,-1.042,0.938,2.5,3.524,4.511,5.0,4.886,3.524,3.2,1.302,
     * -1.424,-3.0,-3.064,-3.665/
c  the data ordinate values
      data x(2),x(4),x(6),x(8),x(10),x(12),x(14),x(16),x(18),x(20),
     * x(22),x(24),x(26),x(28),x(30),x(32),x(34),x(36)/0.0,2.565,
     * 5.785,6.495,5.909,5.318,4.33,2.957,1.642,0.0,-1.779,-2.957,
     * -5.543,-7.386,-8.075,-5.196,-2.571,-1.334/
c  m denotes the number of data points
      m = 19
c  the first and last data point coincide
      x(2*m-1) = x(1)
      x(2*m) = x(2)
c  we set up the weights and parameter values of the data points
      do 10 i=1,m
         w(i) = 1.0
         al = (i-1)*20
         u(i) = al
  10  continue
c  we set up the dimension information.
      nest = 40
      lwrk = 1500
      nc = 80
      mx = 38
c  we will determine a planar closed curve   x=sx(u) , y=sy(u)
      idim = 2
c  for the first approximations we will use cubic splines
      k = 3
c  we will also supply the parameter values u(i)
      ipar = 1
c  loop for the different approximating spline curves
      do 400 is=1,9
         go to (110,120,130,140,150,160,170,180,190),is
c  we start computing the least-squares point ( s very large)
 110     iopt = 0
         s = 900.
         go to 300
c  iopt =  1 from the second call on
 120     iopt = 1
         s = 10.
         go to 300
c  a smaller value for s to get a closer approximation
 130     s = 0.1
         go to 300
c  a larger value for s to get a smoother approximation
 140     s = 0.5
         go to 300
c  if a satisfactory fit is obtained we can calculate a curve of equal
c  quality of fit (same value for s) but possibly with fewer knots by
c  specifying iopt=0
 150     iopt = 0
         s = 0.5
         go to 300
c  we determine a spline curve with respect to the same smoothing
c  factor s,  but now we let the program determine parameter values u(i)
 160     ipar = 0
         iopt = 0
         s = 0.5
         go to 300
c  we choose a different degree of spline approximation
 170     k = 5
         iopt = 0
         s = 0.5
         go to 300
c  we determine an interpolating curve
 180     s = 0.
         go to 300
c  finally we calculate a least-squares spline curve with specified
c  knots
 190     iopt =-1
         n = 9+2*k
         j = k+2
         del = (u(m)-u(1))*0.125
         do 200 l=1,7
            al = l
            t(j) = u(1)+al*del
            j = j+1
 200     continue
c  determine the approximating closed curve
 300     call clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,
     *    c,fp,wrk,lwrk,iwrk,ier)
c  printing of the results.
         if(iopt.ge.0) go to 310
         write(6,910) k,ipar
         go to 320
 310     write(6,915) k,ipar
         write(6,920) s
 320     write(6,925) fp,ier
         write(6,930) n
         write(6,935)
         if(ipar.eq.1) write(6,940) (t(i),i=1,n)
         if(ipar.eq.0) write(6,950) (t(i),i=1,n)
         nk1 = n-k-1
         write(6,945)
         write(6,950) (c(l),l=1,nk1)
         write(6,955)
         i1 = n+1
         i2 = n+nk1
         write(6,950) (c(l),l=i1,i2)
         write(6,960)
c  we evaluate the spline curve
         call curev(idim,t,n,c,nc,k,u,m,sp,mx,ier)
         do 330 i=1,9
           l = (i-1)*4+1
           l1 = l+1
           j = l+2
           j1 = j+1
           write(6,965) x(l),x(l1),sp(l),sp(l1),x(j),x(j1),sp(j),sp(j1)
 330     continue
 400  continue
      stop
 910  format(38h0least-squares closed curve of degree ,i1,7h  ipar=,i1)
 915  format(34h0smoothing closed curve of degree ,i1,7h  ipar=,i1)
 920  format(20h smoothing factor s=,f7.1)
 925  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i2)
 930  format(1x,24htotal number of knots n=,i3)
 935  format(1x,22hposition of the knots )
 940  format(5x,10f6.0)
 945  format(1x,30hb-spline coefficients of sx(u))
 950  format(5x,8f9.4)
 955  format(1x,30hb-spline coefficients of sy(u))
 960  format(1h0,2(4x,2hxi,7x,2hyi,6x,6hsx(ui),3x,6hsy(ui)))
 965  format(1h ,8f9.4)
      end


      subroutine radcur(day,hr,rdlat,decl,ratio)

c
c     +++PURPOSE+++
c     This function is from Jensen etal. 1990 ACSE No. 70
c     "ET and Irrigation Water Requirements".  We are using
c     it to find the ratio between the hourly potential radiation
c     and the estimated radiation on a sloping surface for the day.
c     This function returns an hourly value which, in turn is used
c     in the sunmap routine to find the ratio of hourly to
c     daily.  The daily radiation value is then broken up into
c     an hourly value distributed over a bell shaped curve.
c
c     Author(s):  John Witte, UofMn WCES @ USDA-ARS-NCSRL
c     Date: 03/24/93

c     Verified and tested by Reza Savabi, USDA-ARS, NSERL 317-494-5051
c                  August 1994
c
c     +++ARGUMENT DECLARATIONS+++
      real     ratio,rdlat,decl
      integer  day,hr
c
c     +++ARGUMENT DEFINITIONS+++
c     ratio  - The calculated factor with which to multiply daily
c              radiation to calculate hourly radiation.
c     rdlat  - The latitude in radian units.
c     day    - The julian day of year.
c     hr     - The hour of the day being run.
c     decl   - Declination of the sun in radian units.(+)North (-)Sth.
c
c     +++COMMON BLOCKS+++
c
c     +++LOCAL VARIABLES+++
      real   pi,slrtm,hasun,haset,harise,solcon,rdsun,dfact
c
c     +++LOCAL DEFINITIONS+++
c     dfact  - Day factor used in solar time correction equation.
c     pi     - Estimated value of 22/7.
c     slrtm  - Seasonal correction for solar time (hrs).
c     hasun  - Hour angle of the sun given the day of year (degrees).
c     haset  - Hour angle at sunset (deg).
c     harise - Hour angle at sunrise (deg).
c     solcon - Solar constant--this time units are:  (MJ/m^2.min).
c     rdsun  - Relative distance between earth and sun.
c
c     +++END SPECIFICATIONS+++
c

      pi = 3.141593
      solcon = 0.082

      dfact = ((2 * pi) * (day - 81)) / 365

      slrtm = (0.1645 * sin(2 * dfact)) - (0.1255 * cos(dfact)) -
     1        (0.025 * sin(dfact))

      hasun = ((hr + slrtm) - 12) * (pi / 12)

c -- Could possibly add a longitude adjustment for locations between
c -- longitudinal coordinates.  However, such an adjustment is so
c -- minute that Bob decided we didn't need it here.

      haset = hasun - (pi / 24)

      harise = hasun + (pi / 24)

      rdsun = 1 + 0.033 * cos((2 * pi * day) / 365)

      ratio = ((12 * 60) / pi) * solcon * rdsun * (cos(rdlat) *
     1         cos(decl) * (sin(harise) - sin(haset)) +
     2         (harise - haset) * sin(rdlat) * sin(decl))

      if (ratio .lt. 0.0) ratio = 0.0

      return

      end


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! PR 24174 and PR 24305
program large_real_kind_form_io_1
  ! This should be 10 on systems that support kind=10
  integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1)
  real(kind=k) :: a,b(2), c, eps
  complex(kind=k) :: d, e, f(2), g
  character(len=180) :: tmp
  ! Test real(k) scalar and array formatted IO
  eps = 10 * spacing (2.0_k) ! 10 ulp precision is enough.
  b(:) = 2.0_k
  write (tmp, *) b
  read (tmp, *) a, c
  if (abs (a - b(1)) > eps) call abort ()
  if (abs (c - b(2)) > eps) call abort ()
  ! Complex(k) scalar and array formatted and list formatted IO
  d = cmplx ( 1.0_k, 2.0_k, k)
  f = d
  write (tmp, *) f
  read (tmp, *) e, g
  if (abs (e - d) > eps) call abort ()
  if (abs (g - d) > eps) call abort ()
  write (tmp, '(2(e12.4e5, 2x))') d
  read (tmp, '(2(e12.4e5, 2x))') e
  if (abs (e - d) > eps) call abort()
end program large_real_kind_form_io_1


module m_ranmean3
contains
subroutine ranmean3(ens,ave,n_var,n_ens)
! Return ensemble mean vector
!
  implicit none
  integer             :: j
  integer,intent(in)  :: n_var,n_ens
  real(8),intent(in)  :: ens(n_var,n_ens)
  real(8),intent(out) :: ave(n_var)
!
  ave(:)=ens(:,1)
  do j=2,n_ens
    ave(:)=ave(:)+ens(:,j)
  enddo
  ave(:)=ave(:)/dble(n_ens)
!
end subroutine ranmean3
end module


module line_mod
    use :: types_mod, only : sp
    implicit none

    private
    real(kind=sp) :: epsilon = 1.0e-4_sp
    public :: on_line, line, set_epsilon, get_epsilon

contains

    subroutine set_epsilon(eps)
        implicit none
        real(kind=sp), intent(in) :: eps
        epsilon = eps
    end subroutine set_epsilon

    function get_epsilon() result(eps)
        implicit none
        real(kind=sp) :: eps
        eps = epsilon
    end function get_epsilon

    elemental function line(x) result(y)
        implicit none
        real(kind=sp), intent(in) :: x
        real(kind=sp) :: y
        y = 3.0 + 0.5*x
    end function line

    elemental function on_line(x, y) result(is_on_line)
        implicit none
        real(kind=sp), intent(in) :: x, y
        logical :: is_on_line
        real(kind=sp) :: y_exp
        y_exp = line(x)
        is_on_line = equal(y, y_exp)

    contains

        pure function equal(a, b) result(is_equal)
            implicit none
            real(kind=sp), intent(in) :: a, b
            logical :: is_equal
            is_equal = abs(a - b) < epsilon
        end function equal

    end function on_line

end module line_mod


C NCLFORTSTART
      SUBROUTINE DRMSD(X,Y,NPTS,XMSG,YMSG,XYRMSD,NPTUSE,IER)
      IMPLICIT NONE
c
c NCL:    rmsd = dim_rmsd(x,y)
c         interface must chk that the length of x and y are the same
c                                         input
      INTEGER NPTS
      DOUBLE PRECISION X(NPTS),Y(NPTS),XMSG,YMSG
c                                         output
      INTEGER NPTUSE,IER
      DOUBLE PRECISION XYRMSD
C NCLEND

c this routine will calculate estimates of the first two  moments
c .   of the vector x containing missing data.

c input arguments:
c .   x,y      - input vectors
c .   npts     - length of x and y
c .   xmsg,ymsg- missing code: if there are no msg values
c .                            set xmsg to some value which will
c .                            not be encountered.

c output arguments:
c .   xyrmsd   - root-mean-square-difference
c .   nptuse  - no. of points used to calculate the estimates
c .   ier      - if (ier.ne.0) an error has occurred

c note :
c .   uncalculated quantities are set to xmsg (nptuse set to zero)

      INTEGER N
      DOUBLE PRECISION RN

      NPTUSE = 0
      XYRMSD = XMSG

      IF (NPTS.LT.1) THEN
          IER = 1
          RETURN
      END IF

      IER = 0
      XYRMSD = 0.D0
      RN = 0.D0
      DO N = 1,NPTS
          IF (X(N).NE.XMSG .AND. Y(N).NE.YMSG) THEN
              RN = RN + 1.0D0
              XYRMSD = XYRMSD + (X(N)-Y(N))**2
          END IF
      END DO

      NPTUSE = RN

      IF (RN.GT.0.D0) THEN
          XYRMSD = SQRT(XYRMSD/RN)
      ELSE
          XYRMSD = XMSG
C error code for all msg values
          IER = 2
      END IF

      RETURN
      END


! caf -o bcast bcast.f90
! cafrun -np 2 ./bcast
! mwe for issue github.com/sourceryinstitute/OpenCoarrays/issues/503

program main
   real, allocatable, dimension(:, :, :) :: arr1, arr2
   integer :: i, me, nimg
   real :: red1, sum1, red2, sum2

   allocate(arr1(10, 20, 8))
   allocate(arr2(10, 20, 30))

   me = this_image()
   nimg = num_images()

   if (me == 1) then
      arr1 = reshape([(i, i=1, size(arr1))], shape(arr1))
      arr2 = reshape([(i, i=1, size(arr2))], shape(arr2))
   end if

   call co_broadcast(arr1, source_image=1)
   call co_broadcast(arr2, source_image=1)

   sum1 = sum(arr1)
   sum2 = sum(arr2)

   red1 = sum1
   red2 = sum2

   call co_sum(red1)
   call co_sum(red2)

   sync all
   print *, me, ' sum1=', sum1, ' red1=', red1
   print *, me, ' sum2=', sum2, ' red2=', red2

   if (abs(red1 - nimg * sum1) > epsilon(0.) .or. abs(red2 - nimg * sum2) > epsilon(0.)) then
      write(*,*) 'Test failed!'
      error stop 5
   else
      write(*,*) 'Test passed.'
   end if
   deallocate(arr1, arr2)
end program


       subroutine trigl(x0,y0,w,h,theta,slope)
C       to draw a triangle by providing the base length less than height
C       and angle the side intersections at the start. point forms with
C       the base,x0, y0  x and y coordinates of the starting point of a
C       triangle.
C       w         length of the base,
C       h         height of the triangle
C       theta     angle which is formed by two sides,
C      slope     angle which the base of the triangle forms with the
C                positive direction of the x-axis.
       a=3.14159265/180.0
       x1=x0+w*cos(slope*a)
       y1=y0+w*sin(slope*a)
       s=h/sin(theta*a)
       x2=x0+s*cos(a*(slope+theta))
       y2=y0+s*sin(a*(slope+theta))
       call move(x0,y0,0)
       call move(x1,y1,1)
       call move(x2,y2,1)
       call move(x0,y0,1)
       return
       end


program main

  use clock_class, only : clock
  type(clock) :: timer

  call timer % start()
  call test_norm()
  call timer % stop()

  if (this_image() .eq. 1) then
     write(*, '("Model run time:",F8.3," seconds")') timer % getelapsed()
  end if

end program main

!=====================================================================!
! Program to compute the norm of a large vector in a distributed
! fashion using fortran coarrays and collective routines.
!
! Author : Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

subroutine test_norm

  use vector_class, only : vector

  implicit none

  integer, parameter :: global_size = 2000000
  integer :: nimages = 1
  integer :: local_size

  ! Distributed work data
  real(8), allocatable :: x(:)
  type(vector) :: xvec
  real(8) :: xdot
  real(8) :: xnorm

  ! Determine partition
  nimages = num_images()
  local_size = global_size/nimages

  ! Create smaller vectors
  allocate(x(local_size))

  !-------------------------------------------------------------------!
  ! Test norm computations of large vector with random values
  !-------------------------------------------------------------------!

  test_random: block

    ! Set random values into the vector
    call random_number(x)

    ! Using direct procedure
    xdot = dot_product(x,x)
    call co_sum (xdot)
    if (this_image() == 1) then
       write(*,*) "Norm of the array using direct procedure is", sqrt(xdot) , this_image()
    end if

    ! Using CO_NORM2 function
    xnorm = co_norm2(x)
    if (this_image() == 1) then
       write(*,*) "Norm of the vector using co_norm2 function is", xnorm, this_image()
    end if

    ! Using derived datatype that uses direct procedure internally
    xvec % values = x
    xnorm = xvec % norm()
    if (this_image() == 1) then
       write(*,*) "Norm of the vector datatype is", xnorm , this_image()
    end if

  end block test_random

  !-------------------------------------------------------------------!
  ! Test norm computations of large vector with same values
  !-------------------------------------------------------------------!

  test_deterministic: block

    ! Set deterministic values into the vector
    x = 1.0d0

    ! Using direct procedure
    xdot = dot_product(x,x)
    call co_sum (xdot)
    if (this_image() == 1) then
       write(*,*) "Norm of the array using direct procedure is", sqrt(xdot) , this_image()
    end if

    ! Using CO_NORM2 function
    xnorm = co_norm2(x)
    if (this_image() == 1) then
       write(*,*) "Norm of the vector using co_norm2 function is", xnorm, this_image()
    end if

    ! Using derived datatype that uses direct procedure internally
    xvec % values = x
    xnorm = xvec % norm()
    if (this_image() == 1) then
       write(*,*) "Norm of the vector datatype is", xnorm , this_image()
    end if

  end block test_deterministic

  deallocate(x)

contains

  !===================================================================!
  ! Function to compute the norm of a distributed vector
  !===================================================================!

  function co_norm2(x) result(norm)

    real(8), intent(in) :: x(:)
    real(8) :: xdot, norm

    ! find dot product, sum over processors, take sqrt and return
    xdot = dot_product(x,x)
    call co_sum (xdot)
    norm = sqrt(xdot)

  end function co_norm2

  ! MPI_SUM
  pure function sum(a, b)
    real(8), intent(in) :: a, b
    real(8) :: sum
    sum = a + b
  end function sum

end subroutine test_norm


c     # ------------------------------------------------------------
c     # Streamfunction, velocity components and derivatives
c     #
c     # Stream function depends on these global variables
c     #         example (0=incompressible; 1=compressible)
c     #         mapping (0=swirl; 1=twisted swirl)
c     # ------------------------------------------------------------
      double precision function swirl_psi(x,y)
      implicit none

      double precision x, y

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer example
      common /example_comm/ example

      double precision psi, r

      r = sqrt((x-0.5d0)**2 + (y-0.5d0)**2)

c     # Rigid body rotation
c     psi = r**2

c     # Filament formation (negative for clockwise rotation)
      psi = (4.d0/3.d0)*r**3

      swirl_psi = psi

      end

      subroutine swirl_psi_derivs(x,y,p,px,py)
      implicit none

      double precision x, y
      double precision p, px, py

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      double precision r, rx, ry

      r = sqrt((x-0.5d0)**2 + (y-0.5d0)**2)
      if (r .eq. 0) then
           write(5,*) 'swirl_psi_derivs (psi.f) : r .eq. 0'
           stop
      endif
      rx = x/r
      ry = y/r

      p = (4.d0/3.d0)*r**3
      px = 4*r**2*rx
      py = 4*r**2*ry

      end

      subroutine swirl_velocity_components(x,y,u)
      implicit none

      double precision x, y, u(2)
      double precision uderivs(4)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer example
      common /example_comm/ example

      double precision s

      call swirl_velocity_derivs(x,y,u,uderivs)

      end

      subroutine swirl_velocity_derivs(x,y,u,uderivs)
      implicit none

      double precision x, y, u(2)
      double precision uderivs(4)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer example
      common /example_comm/ example

      double precision s, pim, u1x, u1y, u2x, u2y
      integer k

c     # uderivs(1) = u1x
c     # uderivs(2) = u1y
c     # uderivs(3) = u2x
c     # uderivs(4) = u2y

      u1x = 0
      u1y = 0
      u2x = 0
      u2y = 0

c     # Set non-zeros derivs only
      s = sqrt(2.d0)
      if (example .eq. 0) then
c        # Conservative for all solvers (rp=1,2,3,4)
         u(1) = 1
         u(2) = 1
      elseif (example .eq. 1) then
c        # Conservative for all solvers (rp=1,2,3,4)
         u(1) = s*(cos(pi*x)**2 + 0.5d0)
         u(2) = s*(sin(pi*y)**2 + 0.5d0)
         u1x = -pi*s*sin(pi*x)
         u2y =  pi*s*cos(pi*y)
      elseif (example .eq. 2) then
         u(1) = s*(cos(pi*x)**2 - 0.5d0)
         u(2) = s*(sin(pi*y)**2 - 0.5d0)
         u1x = -pi*s*sin(pi*x)
         u2y =  pi*s*cos(pi*y)
      else if (example .ge. 3) then
c         u = 1
c         u = s*(sin(pi*yc)**2 + 0.5d0)
c         u = s*sin(pi*yc)

c         v = 0
c         v = -s*(sin(pi*xc)**2 + 0.5d0)
c         v = s*sin(pi*xc)

c         r = sqrt((x-0.5d0)**2 + (y-0.5d0)**2)

c        # Rigid body rotation
c        psi = r**2
c         u(1) = 2*(yc-0.5)
c         u(2) = -2*(xc-0.5)

c        # Filament formation (negative for clockwise rotation)
c         psi = (4.d0/3.d0)*r**3

      else
         write(6,'(A,A)') 'clawpack46_setaux : ',
     &              'No valid example provided'
         stop
      endif

      uderivs(1) = u1x
      uderivs(2) = u1y
      uderivs(3) = u2x
      uderivs(4) = u2y

      end

      subroutine swirl_basis_complete(x,y, t, tinv,tderivs, flag)
      implicit none

      double precision x,y
      integer flag
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /swirl_comm/ alpha, beta

      double precision pi4
      double precision swirl_dot

      integer k, kk, i
      logical compute_covariant, compute_contravariant
      logical compute_derivatives, b(32)

      if (flag > 7) then
          write(6,*) 'psi.f : flag > 7'
          stop
      endif

c     # flag = 0      NA
c     # flag = 1      Covariant basis only
c     # flag = 2      NA
c     # flag = 3      Covariant + contravariant basis
c     # flag = 4      Derivatives only
c     # flag = 5      Derivatives + covariant basis
c     # flag = 6      NA
c     # flag = 7      Covariant + contravariant + derivatives

      do i = 1,bit_size(flag)
          b(i) = btest(flag,i-1)
      enddo

      compute_covariant     = b(1) .or. b(2)
      compute_contravariant = b(2)
      compute_derivatives   = b(3)

      pi4 = pi2*pi2

      if (compute_covariant) then
          do k = 1,3
              t(k,1) = 0
              t(k,2) = 0
          enddo
          t(1,1) = 1
          t(2,2) = 1
      endif

      if (compute_contravariant) then
          do k = 1,3
              tinv(k,1) = 0
              tinv(k,2) = 0
          end do
          tinv(1,1) = 1
          tinv(2,2) = 1
      endif

      if (compute_derivatives) then
          do k = 1,3
              tderivs(k,1,1) = 0

c             # d(t1)/dy = d(g*fx + gx*f)/dy
              tderivs(k,1,2) = 0

c             # d(t2)/dx = d(g*fy + gy*f)/dx
              tderivs(k,2,1) = 0

c             # d(t2)/dy = d(g*fy + gy*f)/dy
              tderivs(k,2,2) = 0
          enddo
      endif

      end

      subroutine swirl_transform_coordinates(a,b,x,y,mapping)
      implicit none

      double precision a,b, x,y
      integer mapping
      double precision l0(4), l1(4), l2(4)

      data l0 /1., 0., 0., 1./
      data l1 /1., 0., 1., 1./
      data l2 /1., -1., 1., 0./

c     # This compute (x,y) from a1*t1 + a2*t2, where
c     # t1, t2 are the columns of the matrix L.

      x = a
      y = b

c      if (mapping .eq. 0) then
c          x = a
c          y = b
c      elseif (mapping .eq. 1)  then
c          x = a*l1(1) + b*l1(2)
c          y = a*l1(3) + b*l1(4)
c      elseif (mapping .eq. 2) then
c          x = a*l2(1) + b*l2(2)
c          y = a*l2(3) + b*l2(4)
c      endif

      end