!*==zlarfg.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLARFG + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
!
!       .. Scalar Arguments ..
!       INTEGER            INCX, N
!       COMPLEX*16         ALPHA, TAU
!       ..
!       .. Array Arguments ..
!       COMPLEX*16         X( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLARFG generates a complex elementary reflector H of order n, such
!> that
!>
!>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
!>              (   x   )   (   0  )
!>
!> where alpha and beta are scalars, with beta real, and x is an
!> (n-1)-element complex vector. H is represented in the form
!>
!>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
!>                     ( v )
!>
!> where tau is a complex scalar and v is a complex (n-1)-element
!> vector. Note that H is not hermitian.
!>
!> If the elements of x are all zero and alpha is real, then tau = 0
!> and H is taken to be the unit matrix.
!>
!> Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the elementary reflector.
!> \endverbatim
!>
!> \param[in,out] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX*16
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!> \endverbatim
!>
!> \param[in,out] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension
!>                         (1+(N-2)*abs(INCX))
!>          On entry, the vector x.
!>          On exit, it is overwritten with the vector v.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX*16
!>          The value tau.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup complex16OTHERauxiliary
!
!  =====================================================================
      SUBROUTINE ZLARFG(N,Alpha,X,Incx,Tau)
      IMPLICIT NONE
!*--ZLARFG110
!
!  -- LAPACK auxiliary routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      INTEGER Incx , N
      COMPLEX*16 Alpha , Tau
!     ..
!     .. Array Arguments ..
      COMPLEX*16 X(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      INTEGER j , knt
      DOUBLE PRECISION alphi , alphr , beta , rsafmn , safmin , xnorm
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH , DLAPY3 , DZNRM2
      COMPLEX*16 ZLADIV
      EXTERNAL DLAMCH , DLAPY3 , DZNRM2 , ZLADIV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DCMPLX , DIMAG , SIGN
!     ..
!     .. External Subroutines ..
      EXTERNAL ZDSCAL , ZSCAL
!     ..
!     .. Executable Statements ..
!
      IF ( N<=0 ) THEN
         Tau = ZERO
         RETURN
      ENDIF
!
      xnorm = DZNRM2(N-1,X,Incx)
      alphr = DBLE(Alpha)
      alphi = DIMAG(Alpha)
!
      IF ( xnorm==ZERO .AND. alphi==ZERO ) THEN
!
!        H  =  I
!
         Tau = ZERO
      ELSE
!
!        general case
!
         beta = -SIGN(DLAPY3(alphr,alphi,xnorm),alphr)
         safmin = DLAMCH('S')/DLAMCH('E')
         rsafmn = ONE/safmin
!
         knt = 0
         IF ( ABS(beta)<safmin ) THEN
            DO
!
!           XNORM, BETA may be inaccurate; scale X and recompute them
!
               knt = knt + 1
               CALL ZDSCAL(N-1,rsafmn,X,Incx)
               beta = beta*rsafmn
               alphi = alphi*rsafmn
               alphr = alphr*rsafmn
               IF ( (ABS(beta)>=safmin) .OR. (knt>=20) ) THEN
!
!           New BETA is at most 1, at least SAFMIN
!
                  xnorm = DZNRM2(N-1,X,Incx)
                  Alpha = DCMPLX(alphr,alphi)
                  beta = -SIGN(DLAPY3(alphr,alphi,xnorm),alphr)
                  EXIT
               ENDIF
            ENDDO
         ENDIF
         Tau = DCMPLX((beta-alphr)/beta,-alphi/beta)
         Alpha = ZLADIV(DCMPLX(ONE),Alpha-beta)
         CALL ZSCAL(N-1,Alpha,X,Incx)
!
!        If ALPHA is subnormal, it may lose relative accuracy
!
         DO j = 1 , knt
            beta = beta*safmin
         ENDDO
         Alpha = beta
      ENDIF
!
!
!     End of ZLARFG
!
      END SUBROUTINE ZLARFG


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine stressintensity(nfront,ifrontrel,stress,xt,xn,xa,
     &     dk1,dk2,dk3,xkeq,phi,psi,acrack,shape,nstep)
!
!     calculate the stress intensity factors along the crack fronts
!
      implicit none
!
      integer nfront,ifrontrel(*),i,noderel,nstep,m
!
      real*8 s(3,3),stress(6,nstep,*),xt(3,*),xn(3,*),xa(3,*),
     &     dk1(nstep,*),dk2(nstep,*),dk3(nstep,*),xkeq(nstep,*),
     &     phi(nstep,*),psi(nstep,*),pi,c2,c3,c4,term,
     &     acrack(nstep,*),ratio,constant,t(3),shape(3,*),c1
!
      pi=4.d0*datan(1.d0)
      c2=70.d0*pi/180.d0
      c3=78.d0*pi/180.d0
      c4=33.d0*pi/180.d0
!
      do i=1,nfront
!
!     loop over all nodes belonging to the crack front(s)
!
        noderel=ifrontrel(i)
!
        do m=1,nstep
          s(1,1)=stress(1,m,noderel)
          s(1,2)=stress(4,m,noderel)
          s(1,3)=stress(6,m,noderel)
          s(2,1)=s(1,2)
          s(2,2)=stress(2,m,noderel)
          s(2,3)=stress(5,m,noderel)
          s(3,1)=s(1,3)
          s(3,2)=s(2,3)
          s(3,3)=stress(3,m,noderel)
!
!     calculating the stress vector on the crack plane
!
          t(1)=s(1,1)*xn(1,i)+s(1,2)*xn(2,i)+s(1,3)*xn(3,i)
          t(2)=s(2,1)*xn(1,i)+s(2,2)*xn(2,i)+s(2,3)*xn(3,i)
          t(3)=s(3,1)*xn(1,i)+s(3,2)*xn(2,i)+s(3,3)*xn(3,i)
!
!     calculating the stress intensity factors
!
          dk1(m,i)=t(1)*xn(1,i)+t(2)*xn(2,i)+t(3)*xn(3,i)
          dk2(m,i)=t(1)*xa(1,i)+t(2)*xa(2,i)+t(3)*xa(3,i)
          dk3(m,i)=t(1)*xt(1,i)+t(2)*xt(2,i)+t(3)*xt(3,i)
!
!     taking the formula for the subsurface circular crack
!
c          write(*,*) 'sh1 ',shape(1,i),shape(2,i),shape(3,i)
c          write(*,*)
          constant=dsqrt(pi*acrack(m,i))
          dk1(m,i)=dk1(m,i)*shape(1,i)*constant
          dk2(m,i)=dk2(m,i)*shape(2,i)*constant
          dk3(m,i)=dk3(m,i)*shape(3,i)*constant
        enddo
      enddo
!
!     calculating the equivalent K-factor, the deflection angle
!     and twist angle (formulas by Hans Richard, University of Paderborn;
!     slightly modified to accomodate negative dk1 as well)
!
      do i=1,nfront
        do m=1,nstep
          if(dk1(m,i).ge.0.d0) then
            xkeq(m,i)=(dk1(m,i)+dsqrt(dk1(m,i)*dk1(m,i)+
     &           5.3361*dk2(m,i)*dk2(m,i)+
     &           4.d0*dk3(m,i)*dk3(m,i)))/2.d0
            if(xkeq(m,i).gt.1.d-20) then
              term=dk1(m,i)+dabs(dk2(m,i))+dabs(dk3(m,i))
              ratio=dabs(dk2(m,i))/term
              phi(m,i)=-c2*ratio*(2.d0-ratio)*dk2(m,i)/dabs(dk2(m,i))
              ratio=dabs(dk3(m,i))/term
              psi(m,i)=-ratio*(c3-c4*ratio)*dk3(m,i)/dabs(dk3(m,i))
            else
              phi(m,i)=0.d0
              psi(m,i)=0.d0
            endif
          else
            xkeq(m,i)=-(-dk1(m,i)+dsqrt(dk1(m,i)*dk1(m,i)+
     &           5.3361*dk2(m,i)*dk2(m,i)+
     &           4.d0*dk3(m,i)*dk3(m,i)))/2.d0
!
!     for negative equivalent K-factor the formulas of Richard
!     probably do not apply: to be checked!
!
            phi(m,i)=0.d0
            psi(m,i)=0.d0
          endif
        enddo
      enddo
!
      write(*,*) 'stressintensity k1 k2 k3'
      write(*,*)
      c1=1.d0/dsqrt(1000.d0)
      do m=1,nstep
        do i=1,nfront
          write(*,100) m,i,c1*dk1(m,i),c1*dk2(m,i),c1*dk3(m,i)
        enddo
        write(*,*)
      enddo
!
      write(*,*) 'stressintensity keq phi psi'
      write(*,*)
      do m=1,nstep
        do i=1,nfront
          write(*,100) m,i,c1*xkeq(m,i),phi(m,i)*180.d0/pi,
     &         psi(m,i)*180.d0/pi
        enddo
        write(*,*)
      enddo
 100  format(2i10,3(1x,e11.4))
!
      return
      end


************************************************************************
*
*     Subroutine JKNIFE                             Called by: LADLOAD
*
*     Calculate jackknife estimates of mean river load variance using
*     least absolute deviation estimates of rating curve parameters.
*
*     Reference: Crawford (1996)
*
*     local vars
*     ----------
*     BICOR     transformation bias correction factor
*     MTEJK     mean load for each of the jackknife subsamples
*     MTEMEAN
*     NJACK     number of observations in the jackknife subsample
*     PARAM     LAD parameter estimates
*     PRED      predicted value of log load
*     SUM       sum of the squared differences between jackknife
*               estimate of the mean load and the average mean load
*               for all jackknife subsamples
*     XLCAL2    explanatory variables for the jackknife subsample
*     YLJACK    observed load for the jackknife subsample
*
************************************************************************
      SUBROUTINE JKNIFE(NPAR,NOBSC,XLCAL,YLCAL,NUMOBSE,XP,VLAD,NOBSCI,
     &                  NOBSE)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NOBSC,NUMOBSE,NOBSCI,NOBSE
      DOUBLE PRECISION VLAD
      DOUBLE PRECISION YLCAL(*),XLCAL(NOBSCI,*),XP(NOBSE,*)
*
*     local vars
*
      INTEGER*4 I,II,J,JJ,K,NJACK
      DOUBLE PRECISION BICOR,MTEMEAN,PRED,SUM
      DOUBLE PRECISION PARAM(MAXPARMS),MTEJK(NOBSCI),YLJACK(NOBSCI)
      DOUBLE PRECISION XLCAL2(NOBSCI,MAXPARMS)
*
*     function declaration
*
      DOUBLE PRECISION MEAN
*
*     obtain subsample for jackknife
*
      DO 50 I=1,NOBSC
         NJACK = 0
         DO 20 J=1,NOBSC
            IF (J.NE.I) THEN
               NJACK = NJACK + 1
               DO 10 K=1,NPAR
                  XLCAL2(NJACK,K) = XLCAL(J,K)
 10            CONTINUE
               YLJACK(NJACK) = YLCAL(J)
            ENDIF
 20      CONTINUE
*
*        calculate regression model parameters for jackknife sample
*
         CALL LADREG(NPAR,NJACK,XLCAL2,YLJACK,PARAM,BICOR,NOBSCI)
*
*        calculate jackknife estimate of mean load
*
         MTEJK(I) = 0.D0
         DO 40 II=1,NUMOBSE
            PRED = 0.D0
            DO 30 JJ=1,NPAR
               PRED = PRED + PARAM(JJ)*XP(II,JJ)
 30         CONTINUE
            MTEJK(I) = MTEJK(I) + DEXP(PRED)*BICOR
 40      CONTINUE
         MTEJK(I) = MTEJK(I)/DBLE(NUMOBSE)

 50   CONTINUE
*
*     sum squared difference between jackknife estimate of the mean
*     load and the average mean load for all jacknife subsamples, then
*     calculate estimated variances.
*
      SUM = 0.D0
      MTEMEAN = MEAN(MTEJK,NOBSC)
      DO 60 I=1,NOBSC
         SUM = SUM + (MTEJK(I)-MTEMEAN)**2
 60   CONTINUE
      VLAD = ((DBLE(NOBSC)-1.D0)/DBLE(NOBSC))*SUM

      RETURN
      END


      subroutine compute_permfactor(el, node_k, duu, dvv, dww
     &     , recompute_stress)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! compute elemental permbeality factors
!
! Author : Sai Rapaka

      use comai, only: nei, neq, ns, iout
      use combi, only: nelm
      use comdi, only: t, tini, phi, phini
      use comsi, only: ispm, ipermstr2, perx_m, pery_m, perz_m
      use comsi, only: strx_min, stry_min, strz_min, e1, e2, e3
      use comsi, only: spm1f, spm2f, spm3f
      use comsi, only: spm7f, spm8f, spm9f, du, dv, dw, alp, bulk
      use comfem

      implicit none

      double precision                   :: duu, dvv, dww
      double precision                   :: mean_str(6)
      double precision                   :: D(6,6)
      double precision                   :: B(6, 24)
      integer                            :: node(8)
      double precision                   :: disp(24)
      double precision                   :: gp_strain(6), gp_stress(6)
      double precision                   :: d_strain(6)
      double precision                   :: fac, perm_fac
      double precision                   :: str_max, str_tol
      double precision                   :: alphadeltaT, betadeltaP
      double precision                   :: e1bar, e2bar, e3bar
      integer, parameter                 :: numEdges = 28
      integer el, node_k, i, j, k
      integer node_I, node_J, edge_1, edge_2
      logical recompute_stress
      integer iispmd

      real*8 epsilon_perm

      epsilon_perm = 1.e-18

      str_max = 1.0d0
      mean_str = 0.0
c      permfactor = 1.0

      if(ipermstr2.ne.0) then
        strx_min = spm1f(1)
        stry_min = spm2f(1)
        strz_min = spm3f(1)
        perx_m  = spm7f(1)
        pery_m  = spm8f(1)
        perz_m  = spm9f(1)
      endif

c      recompute = .false.
c      do j=1,ns
c        if(elnode(el,j).eq.node_k) then
c          recompute=.true.
c        endif
c      enddo

      if(recompute_stress) then
        ! Recompute the stress in the element
        do j=1,numgausspoints
          ! first compute the strain
          alphadeltaT = 0.0d0
          betadeltaP = 0.0d0
          e1bar = 0.0d0
          e2bar = 0.0d0
          e3bar = 0.0d0

          !TODO: Should be setting up disp outside gausspoint loop
          disp = 0.0d0
          do k=1,ns
            node(k) = elnode(el, k)
            if(node(k).eq.node_k) then
              disp(3*k-2) = duu
              disp(3*k-1) = dvv
              disp(3*k  ) = dww
            endif
!            if(node(k).eq.node_k) then
!              disp(3*k-2) = disp(3*k-2) + duu
!              disp(3*k-1) = disp(3*k-1) + dvv
!              disp(3*k  ) = disp(3*k  ) + dww
!            endif
            alphadeltaT = alphadeltaT + alp(node(k))*
     &            Psi(el, j, k)*(t(node(k)) - tini(node(k)))
            betadeltaP = betadeltaP + bulk(node(k))*
     &            Psi(el, j, k)*(phi(node(k)) - phini(node(k)))
            e1bar = e1bar + e1(node(k))*Psi(el, j, k)
            e2bar = e2bar + e2(node(k))*Psi(el, j, k)
            e3bar = e3bar + e3(node(k))*Psi(el, j, k)
          enddo

          B = 0.0d0
          do k=1,ns
            B(1,3*(k-1) + 1) = dPsidX(el, j, k)
            B(2,3*(k-1) + 2) = dPsidY(el, j, k)
            B(3,3*(k-1) + 3) = dPsidZ(el, j, k)
            B(4,3*(k-1) + 1) = dPsidY(el, j, k)
            B(4,3*(k-1) + 2) = dPsidX(el, j, k)
            B(5,3*(k-1) + 2) = dPsidZ(el, j, k)
            B(5,3*(k-1) + 3) = dPsidY(el, j, k)
            B(6,3*(k-1) + 1) = dPsidZ(el, j, k)
            B(6,3*(k-1) + 3) = dPsidX(el, j, k)
          enddo

          !! Computing incremental change in strain
          d_strain = matmul(B, disp)

          !! Add incremental strain to elastic strain at gausspoint
          gp_strain = fem_strain(el, j, :) + d_strain
          gp_strain(1) = gp_strain(1) - alphadeltaT - betadeltaP
          gp_strain(2) = gp_strain(2) - alphadeltaT - betadeltaP
          gp_strain(3) = gp_strain(3) - alphadeltaT - betadeltaP

          D = 0.0d0
          !! fem_material_stiffness returns elasto-plastic matrix for
          !! plastic, otherwise elastic matrix
          call fem_material_stiffness(el, j, D)
!          D(1,1) = e1bar
!          D(1,2) = e2bar
!          D(1,3) = e2bar
!          D(2,1) = e2bar
!          D(2,2) = e1bar
!          D(2,3) = e2bar
!          D(3,1) = e2bar
!          D(3,2) = e2bar
!          D(3,3) = e1bar
!          D(4,4) = e3bar
!          D(5,5) = e3bar
!          D(6,6) = e3bar

          gp_stress = matmul(D, gp_strain)
          mean_str = mean_str + gp_stress
        enddo
        mean_str = mean_str/numgausspoints
      else
        mean_str = 0.0d0
        do j=1,numgausspoints
          mean_str = mean_str + fem_stress(el, j, :)
        enddo
        mean_str = mean_str/numgausspoints
      endif

      !! Effective stress
!      write(iout, *) 'Eff'
!      write(iout, *) mean_str(1:3)
!      write(iout, *) betadeltaP
!      write(iout, *) 3.0*e2bar + 2.0*e3bar
!      write(iout, *) (3.0*e2bar + 2.0*e3bar)*betadeltaP

      do j=1, numEdges
        node_I = elnode(el, edges(j,1))
        node_J = elnode(el, edges(j,2))
        edge_1 = edgeNum1(el, j)
        edge_2 = edgeNum2(el, j)

        !! Explicitly considering model 2 here
        !! Need to add a loop to look at model numbers and
        !! break it into different routines
        if(mean_str(1).gt.strx_min) then
          fac = ((mean_str(1)-strx_min)/str_max)
          perm_fac = fac*(perx_m - 1.0d0) + 1.0d0
          permfactor(edge_1, 2) = permfactor(edge_1, 2) + perm_fac
          permfactor(edge_1, 3) = permfactor(edge_1, 3) + perm_fac
          permfactor(edge_2, 2) = permfactor(edge_2, 2) + perm_fac
          permfactor(edge_2, 3) = permfactor(edge_2, 3) + perm_fac
        endif
        if(mean_str(2).gt.stry_min) then
          fac = ((mean_str(2)-stry_min)/str_max)
          perm_fac = fac*(pery_m - 1.0d0) + 1.0d0
          permfactor(edge_1, 3) = permfactor(edge_1, 3) + perm_fac
          permfactor(edge_1, 1) = permfactor(edge_1, 1) + perm_fac
          permfactor(edge_2, 3) = permfactor(edge_2, 3) + perm_fac
          permfactor(edge_2, 1) = permfactor(edge_2, 1) + perm_fac
        endif
        if(mean_str(3).gt.strz_min) then
          fac = ((mean_str(3)-strz_min)/str_max)
          perm_fac = fac*(perz_m - 1.0d0) + 1.0d0
          permfactor(edge_1, 1) = permfactor(edge_1, 1) + perm_fac
          permfactor(edge_1, 2) = permfactor(edge_1, 2) + perm_fac
          permfactor(edge_2, 1) = permfactor(edge_2, 1) + perm_fac
          permfactor(edge_2, 2) = permfactor(edge_2, 2) + perm_fac
        endif
      enddo

      end subroutine compute_permfactor


function fft2(y) result(yh)
! FFT2 function
complex(kind=8), intent(in)  :: y(:,:)
integer(kind=8) :: plan_forward
complex(kind=8), allocatable :: yh(:,:)
allocate(yh(size(y,1),size(y,2)))
call dfftw_plan_dft_2d_ (plan_forward,  size(y,1), size(y,2), y, yh, FFTW_FORWARD, FFTW_ESTIMATE)
call dfftw_execute(plan_forward)
end function fft2


      subroutine dqawo(f,a,b,omega,integr,epsabs,epsrel,result,abserr,
     *   neval,ier,leniw,maxp1,lenw,last,iwork,work)
c***begin prologue  dqawo
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a1
c***keywords  automatic integrator, special-purpose,
c             integrand with oscillatory cos or sin factor,
c             clenshaw-curtis method, (end point) singularities,
c             extrapolation, globally adaptive
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the routine calculates an approximation result to a given
c            definite integral i=integral of f(x)*w(x) over (a,b)
c            where w(x) = cos(omega*x)
c            or w(x) = sin(omega*x),
c            hopefully satisfying following claim for accuracy
c            abs(i-result).le.max(epsabs,epsrel*abs(i)).
c***description
c
c        computation of oscillatory integrals
c        standard fortran subroutine
c        double precision version
c
c        parameters
c         on entry
c            f      - double precision
c                     function subprogram defining the function
c                     f(x).  the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - double precision
c                     lower limit of integration
c
c            b      - double precision
c                     upper limit of integration
c
c            omega  - double precision
c                     parameter in the integrand weight function
c
c            integr - integer
c                     indicates which of the weight functions is used
c                     integr = 1      w(x) = cos(omega*x)
c                     integr = 2      w(x) = sin(omega*x)
c                     if integr.ne.1.and.integr.ne.2, the routine will
c                     end with ier = 6.
c
c            epsabs - double precision
c                     absolute accuracy requested
c            epsrel - double precision
c                     relative accuracy requested
c                     if epsabs.le.0 and
c                     epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c                     the routine will end with ier = 6.
c
c         on return
c            result - double precision
c                     approximation to the integral
c
c            abserr - double precision
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of  integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the requested
c                             accuracy has been achieved.
c                   - ier.gt.0 abnormal termination of the routine.
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                     ier = 1 maximum number of subdivisions allowed
c                             (= leniw/2) has been achieved. one can
c                             allow more subdivisions by increasing the
c                             value of leniw (and taking the according
c                             dimension adjustments into account).
c                             however, if this yields no improvement it
c                             is advised to analyze the integrand in
c                             order to determine the integration
c                             difficulties. if the position of a local
c                             difficulty can be determined (e.g.
c                             singularity, discontinuity within the
c                             interval) one will probably gain from
c                             splitting up the interval at this point
c                             and calling the integrator on the
c                             subranges. if possible, an appropriate
c                             special-purpose integrator should be used
c                             which is designed for handling the type of
c                             difficulty involved.
c                         = 2 the occurrence of roundoff error is
c                             detected, which prevents the requested
c                             tolerance from being achieved.
c                             the error may be under-estimated.
c                         = 3 extremely bad integrand behaviour occurs
c                             at some interior points of the
c                             integration interval.
c                         = 4 the algorithm does not converge.
c                             roundoff error is detected in the
c                             extrapolation table. it is presumed that
c                             the requested tolerance cannot be achieved
c                             due to roundoff in the extrapolation
c                             table, and that the returned result is
c                             the best which can be obtained.
c                         = 5 the integral is probably divergent, or
c                             slowly convergent. it must be noted that
c                             divergence can occur with any other value
c                             of ier.
c                         = 6 the input is invalid, because
c                             (epsabs.le.0 and
c                              epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
c                             or (integr.ne.1 and integr.ne.2),
c                             or leniw.lt.2 or maxp1.lt.1 or
c                             lenw.lt.leniw*2+maxp1*25.
c                             result, abserr, neval, last are set to
c                             zero. except when leniw, maxp1 or lenw are
c                             invalid, work(limit*2+1), work(limit*3+1),
c                             iwork(1), iwork(limit+1) are set to zero,
c                             work(1) is set to a and work(limit+1) to
c                             b.
c
c         dimensioning parameters
c            leniw  - integer
c                     dimensioning parameter for iwork.
c                     leniw/2 equals the maximum number of subintervals
c                     allowed in the partition of the given integration
c                     interval (a,b), leniw.ge.2.
c                     if leniw.lt.2, the routine will end with ier = 6.
c
c            maxp1  - integer
c                     gives an upper bound on the number of chebyshev
c                     moments which can be stored, i.e. for the
c                     intervals of lengths abs(b-a)*2**(-l),
c                     l=0,1, ..., maxp1-2, maxp1.ge.1
c                     if maxp1.lt.1, the routine will end with ier = 6.
c
c            lenw   - integer
c                     dimensioning parameter for work
c                     lenw must be at least leniw*2+maxp1*25.
c                     if lenw.lt.(leniw*2+maxp1*25), the routine will
c                     end with ier = 6.
c
c            last   - integer
c                     on return, last equals the number of subintervals
c                     produced in the subdivision process, which
c                     determines the number of significant elements
c                     actually in the work arrays.
c
c         work arrays
c            iwork  - integer
c                     vector of dimension at least leniw
c                     on return, the first k elements of which contain
c                     pointers to the error estimates over the
c                     subintervals, such that work(limit*3+iwork(1)), ..
c                     work(limit*3+iwork(k)) form a decreasing
c                     sequence, with limit = lenw/2 , and k = last
c                     if last.le.(limit/2+2), and k = limit+1-last
c                     otherwise.
c                     furthermore, iwork(limit+1), ..., iwork(limit+
c                     last) indicate the subdivision levels of the
c                     subintervals, such that iwork(limit+i) = l means
c                     that the subinterval numbered i is of length
c                     abs(b-a)*2**(1-l).
c
c            work   - double precision
c                     vector of dimension at least lenw
c                     on return
c                     work(1), ..., work(last) contain the left
c                      end points of the subintervals in the
c                      partition of (a,b),
c                     work(limit+1), ..., work(limit+last) contain
c                      the right end points,
c                     work(limit*2+1), ..., work(limit*2+last) contain
c                      the integral approximations over the
c                      subintervals,
c                     work(limit*3+1), ..., work(limit*3+last)
c                      contain the error estimates.
c                     work(limit*4+1), ..., work(limit*4+maxp1*25)
c                      provide space for storing the chebyshev moments.
c                     note that limit = lenw/2.
c
c***references  (none)
c***routines called  dqawoe,xerror
c***end prologue  dqawo
c
       double precision a,abserr,b,epsabs,epsrel,f,omega,result,work
       integer ier,integr,iwork,last,limit,lenw,leniw,lvl,l1,l2,l3,l4,
     *  maxp1,momcom,neval
c
       dimension iwork(leniw),work(lenw)
c
       external f
c
c         check validity of leniw, maxp1 and lenw.
c
c***first executable statement  dqawo
      ier = 6
      neval = 0
      last = 0
      result = 0.0d+00
      abserr = 0.0d+00
      if(leniw.lt.2.or.maxp1.lt.1.or.lenw.lt.(leniw*2+maxp1*25))
     *  go to 10
c
c         prepare call for dqawoe
c
      limit = leniw/2
      l1 = limit+1
      l2 = limit+l1
      l3 = limit+l2
      l4 = limit+l3
      call dqawoe(f,a,b,omega,integr,epsabs,epsrel,limit,1,maxp1,result,
     *   abserr,neval,ier,last,work(1),work(l1),work(l2),work(l3),
     *   iwork(1),iwork(l1),momcom,work(l4))
c
c         call error handler if necessary
c
      lvl = 0
10    if(ier.eq.6) lvl = 0
      if(ier.ne.0) call xerror('abnormal return from dqawo',26,ier,lvl)
      return
      end


      SUBROUTINE INTRPL(L,X,Y,N,U,V)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER*4(I-N)
c      PARAMETER ( NR=1000 )
C
C     DOUBLE PRECISION INTERPOLATION OF A SINGLE VALUED FUNCTION
C     THIS SUBROUTINE INTERPOLATES, FROM VALUES OF THE FUNCTION
C     GIVEN  AS ORDINATES OF INPUT DATA POINTS IN AN X-Y PLANE
C     AND FOR A GIVEN SET OF X VALUES(ABSCISSAE),THE VALUES OF
C     A SINGLE VALUED FUNCTION Y=Y(X).
C
C     THE INPUT PARAMETERS ARE;
C
C     L=NUMBER OF DATA POINTS
C     (MUST BE TWO OR GREATER)
C     X=ARRAY OF DIMENSION L STORING THE X VALUES
C     OF INPUT DATA POINTS (IN ASCENDING ORDER)
C     Y=ARRAY OF DIMENSION L STORING THE Y VALUES OF INPUT DATA POINTS
C     N=NUMBER OF POINTS AT WHICH INTERPOLATION OF THE Y-VALUES
C     IS REQUIRED (MUST BE 1 OR GREATER)
C     U=ARRAY OF DIMENSION N STORING THE X VALUES
C     OF THE DESIRED POINTS
C
C     THE OUTPUT PARAMETER IS V=ARRAY OF DIMENSION N WHERE THE
C     INTERPOLATED Y VALUES ARE TO BE DISPLAYED
C

      COMMON/DV/ IDERIV
      DIMENSION DV(N), QQ(4,N)
      COMMON/INTEG/ INT,FINT
      real*8, intent(in) ::  X(L),Y(L),U(N)
      real*8, intent(out) :: V(N)
      EQUIVALENCE (P0,X3),(Q0,Y3),(Q1,T3)
      REAL*8 M1,M2,M3,M4,M5
      EQUIVALENCE (UK,DX),(IMN,X2,A1,M1),(IMX,X5,A5,M5),
     1         (J,SW,SA),(Y2,W2,W4,Q2),(Y5,W3,Q3)

c
c      IDERIV = 0
c      INT = 0

C
C     PRELIMINARY PROCESSING
C
      L0 = L
      LM1 = L0 - 1
      LM2 = LM1 - 1
      LP1 = L0 + 1
      N0 = N
c      NQQ = NR
c        IF(N0.GT.NQQ) THEN
c        NQQV = NQQ
c        WRITE(6,2089) NQQV,N0
c        STOP
c        END IF
      IF(LM2.LT.0) GO TO 90
      IF(N0.LE.0) GO TO 91
      DO 11 I = 2,L0
      if(x(i-1).eq.x(i)) print*, x(i)
      IF(X(I-1)-X(I))11,95,96
   11 CONTINUE
      IPV = 0
C
C     MAIN LOOP
C
      FINT = 0.0D0
      DO 80 K = 1,N0
      UK = U(K)
C
C     BINARY SEARCH TO LOCATE THE DESIRED POINT
C
      IF(LM2.EQ.0) GO TO 27
      IF(UK.GE.X(L0)) GO TO 26
      IF(UK.LT.X(1)) GO TO 25
      IMN = 2
      IMX = L0
   21 I = (IMN+IMX)/2
      IF(UK.GE.X(I)) GO TO 23
      IMX = I
      GO TO 24
   23 IMN = I + 1
   24 IF(IMX.GT.IMN) GO TO 21
      I = IMX
      GO TO 30
   25 I = 1
      GO TO 30
   26 I = LP1
      GO TO 30
   27 I = 2
C
C     CHECK IF I = IPV
C
   30 IF(I.EQ.IPV) GO TO 70
      IPV = I
C
C     ROUTINES TO PICK UP NECESSARY X AND Y VALUES AND TO
C     ESTIMATE THEM IF NECESSARY
C
      J = I
      IF(J.EQ.1) J = 2
      IF(J.EQ.LP1) J = L0
      X3 = X(J-1)
      Y3 = Y(J-1)
      X4 = X(J)
      Y4 = Y(J)
      A3 = X4 - X3
      M3 = (Y4 - Y3)/A3
      IF(LM2.EQ.0) GO TO 43
      IF(J.EQ.2) GO TO 41
      X2 = X(J-2)
      Y2 = Y(J-2)
      A2 = X3 - X2
      M2 = (Y3 - Y2)/A2
      IF(J.EQ.L0) GO TO 42
   41 X5 = X(J+1)
      Y5 = Y(J+1)
      A4 = X5 - X4
      M4 = (Y5 - Y4)/A4
      IF(J.EQ.2) M2 = M3 + M3 - M4
      GO TO 45
   42 M4 = M3 + M3 - M2
      GO TO 45
   43 M2 = M3
   45 IF(J.LE.3) GO TO 46
      A1 = X2 - X(J-3)
      M1 = (Y2 - Y(J-3))/A1
      GO TO 47
   46 M1 = M2 + M2 - M3
   47 IF(J.GE.LM1) GO TO 48
      A5 = X(J+2) - X5
      M5 = (Y(J+2)-Y5)/A5
      GO TO 50
   48 M5 = M4 + M4 - M3
C
C     NUMERICAL DIFFERENTIATION
C
   50 IF(I.EQ.LP1) GO TO 52
      W2 = ABS(M4-M3)
      W3 = ABS(M2-M1)
      SW = W2 + W3
      IF(SW.NE.0.0D0) GO TO 51
      W2 = 0.5D0
      W3 = 0.5D0
      SW = 1.0D0
   51 T3 = (W2*M2 + W3*M3)/SW
      IF(I.EQ.1) GO TO 54
   52 W3 = ABS(M5-M4)
      W4 = ABS(M3-M2)
      SW = W3 + W4
      IF(SW.NE.0.0D0) GO TO 53
      W3 = 0.5D0
      W4 = 0.5D0
      SW = 1.0D0
   53 T4 = (W3*M3 + W4*M4)/SW
      IF(I.NE.LP1) GO TO 60
      T3 = T4
      SA = A2 + A3
      T4 = 0.5D0*(M4 + M5 - A2*(A2-A3)*(M2-M3)/(SA*SA))
      X3 = X4
      Y3 = Y4
      A3 = A2
      M3 = M4
      GO TO 60
   54 T4 = T3
      SA = A3 + A4
      T3 = 0.5D0*(M1 + M2 - A4*(A3-A4)*(M3-M4)/(SA*SA))
      X3 = X3 - A4
      Y3 = Y3 - M2*A4
      A3 = A4
      M3 = M2
C
C     DETERMINATION OF THE COEFFICIENTS
C
   60 Q2 = (2.0D0*(M3-T3) + M3 - T4)/A3
      Q3 = (-M3 - M3 + T3 + T4)/(A3*A3)
C
C     COMPUTATION OF THE POLYNOMIAL
C
   70 DX = UK - P0
      V(K) = Q0 + DX*(Q1 + DX*(Q2 + DX*Q3))
      IF(IDERIV.EQ.0) GO TO 72
      DV(K) = Q1 + DX*(2.0D0*Q2 + DX*3.0D0*Q3)
      QQ(1,K) = Q0
      QQ(2,K) = Q1
      QQ(3,K) = Q2
      QQ(4,K) = Q3
   72 IF(INT.EQ.0) GO TO 80
      IF(K.LT.N0) DD = U(K+1) - U(K)
      IF(K.LT.N0) FINT = FINT
     1 + DD*(Q0 + DD*(Q1/2.0D0+DD*(Q2/3.0D0+DD*Q3/4.0D0)))
   80 CONTINUE
      RETURN
C
C     ERROR EXITS
C
   90 WRITE(6,2090)
      GO TO 99
   91 WRITE(6,2091)
      GO TO 99
   95 WRITE(6,2095)
      GO TO 97
   96 WRITE(6,2096)
   97 WRITE(6,2097)I,X(I)
   99 WRITE(6,2099) L0,N0
      STOP
      RETURN
C
C     FORMAT STATEMENTS
C
 2089 FORMAT( 'WARNING ERROR IN INTRPL. MAX ALLOWED VALUE OF N0 IS',
     *I5,' HERE N0 IS',I5)
 2090 FORMAT(1X/' N  =  1 OR LESS.'/)
 2091 FORMAT(1X/' N  =  0 OR LESS.'/)
 2095 FORMAT(1X/' IDENTICAL X VALUES.'/)
 2096 FORMAT(1X/' X VALUES OUT OF SEQUENCE.'/)
 2097 FORMAT(6H   I =,I7,10X,6HX(I) =,E12.3)
 2099 FORMAT(6H   L =,I7,10X,3HN =,I7/
     1 ' ERRROR DETECTED IN ROUTINE INTRPL')
      END
c      BLOCK DATA
c      IMPLICIT REAL*8(A-H,O-Z)
c      IMPLICIT INTEGER*4(I-N)
c      PARAMETER ( NR=1000 )
c      COMMON/DV/ IDERIV,DV(NR)
c      COMMON/INTEG/ INT,FINT
c      DATA IDERIV,INT/1,0/
c      END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZARGTO (Double Auxiliary Routine Givens TurnOver)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine uses the generators for three Givens rotations represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine and performs a turnover.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  G1, G2, G3       REAL(8) arrays of dimension (3)
!                    generators for givens rotations
!
! OUTPUT VARIABLES:
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies G1 is invalid
!                    INFO = -2 implies G2 is invalid
!                    INFO = -3 implies G3 is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZARGTO(G1,G2,G3,INFO)

  implicit none

  ! input variables
  integer, intent(inout) :: INFO
  real(8), intent(inout) :: G1(3), G2(3), G3(3)

  ! compute variables
  real(8), parameter :: tol = epsilon(1d0)
  real(8) :: nrm, T(3)

  real(8) :: c1r, c1i, s1
  real(8) :: c2r, c2i, s2
  real(8) :: c3r, c3i, s3

  real(8) :: c4r, c4i, s4
  real(8) :: c5r, c5i, s5
  real(8) :: c6r, c6i, s6

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check G1
    call DARACH1(3,G1,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"G2 is invalid",INFO,-1)
      return
    end if

    ! check G2
    call DARACH1(3,G2,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"G2 is invalid",INFO,-2)
      return
    end if

    ! check G3
    call DARACH1(3,G3,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"G3 is invalid",INFO,-3)
      return
    end if

  end if

  ! set local variables
  c1r = G1(1)
  c1i = G1(2)
  s1 = G1(3)
  c2r = G2(1)
  c2i = G2(2)
  s2 = G2(3)
  c3r = G3(1)
  c3i = G3(2)
  s3 = G3(3)

  ! initialize c4r, c4i and s4
  T(1) = s1*c3r + (c1r*c2r + c1i*c2i)*s3
  T(2) = s1*c3i + (-c1i*c2r + c1r*c2i)*s3
  T(3) = s2*s3

  ! compute first rotation
  call ZARCG33(T(1),T(2),T(3),c4r,c4i,s4,nrm,INFO)

  ! check INFO in debug mode
  if (DEBUG) then
    call UARERR(__FILE__,__LINE__,"ZARCG33 failed",INFO,INFO)
    if (INFO.NE.0) then
      return
    end if
  end if

  ! initialize c5r, c5i and s5
  T(1) = c1r*c3r - c1i*c3i - s1*c2r*s3
  T(2) = c1r*c3i + c1i*c3r - s1*c2i*s3
  T(3) = nrm

  ! compute second rotation
  call ZARCG33(T(1),T(2),T(3),c5r,c5i,s5,nrm,INFO)

  ! check INFO in debug mode
  if (DEBUG) then
    call UARERR(__FILE__,__LINE__,"ZARCG33 failed",INFO,INFO)
    if (INFO.NE.0) then
      return
    end if
  end if

  ! initialize c6r, c6i and s6
  T(1) = c2r*c4r + c2i*c4i + c1r*s2*s4
  T(2) = c2i*c4r - c2r*c4i + c1i*s2*s4
  T(3) = s1*s2*s5 - (c5r*c2r + c5i*c2i)*s4 + s2*(c1r*(c4r*c5r + c4i*c5i) + c1i*(c4r*c5i - c4i*c5r))

  ! compute third rotation
  call ZARCG33(T(1),T(2),T(3),c6r,c6i,s6,nrm,INFO)

  ! check INFO in debug mode
  if (DEBUG) then
    call UARERR(__FILE__,__LINE__,"ZARCG33 failed",INFO,INFO)
    if (INFO.NE.0) then
      return
    end if
  end if

  ! store output
  G1(1) = c5r
  G1(2) = c5i
  G1(3) = s5
  G2(1) = c6r
  G2(2) = c6i
  G2(3) = s6
  G3(1) = c4r
  G3(2) = c4i
  G3(3) = s4

end subroutine ZARGTO


CS    REAL FUNCTION ALGAMA(X)
      DOUBLE PRECISION FUNCTION DLGAMA(X)
C----------------------------------------------------------------------
C
C This routine calculates the LOG(GAMMA) function for a positive real
C   argument X.  Computation is based on an algorithm outlined in
C   references 1 and 2.  The program uses rational functions that
C   theoretically approximate LOG(GAMMA) to at least 18 significant
C   decimal digits.  The approximation for X > 12 is from reference
C   3, while approximations for X < 12.0 are similar to those in
C   reference 1, but are unpublished.  The accuracy achieved depends
C   on the arithmetic system, the compiler, the intrinsic functions,
C   and proper selection of the machine-dependent constants.
C
C
C*********************************************************************
C*********************************************************************
C
C Explanation of machine-dependent constants
C
C beta   - radix for the floating-point representation
C maxexp - the smallest positive power of beta that overflows
C XBIG   - largest argument for which LN(GAMMA(X)) is representable
C          in the machine, i.e., the solution to the equation
C                  LN(GAMMA(XBIG)) = beta**maxexp
C XINF   - largest machine representable floating-point number;
C          approximately beta**maxexp.
C EPS    - The smallest positive floating-point number such that
C          1.0+EPS .GT. 1.0
C FRTBIG - Rough estimate of the fourth root of XBIG
C
C
C     Approximate values for some important machines are:
C
C                           beta      maxexp         XBIG
C
C CRAY-1        (S.P.)        2        8191       9.62E+2461
C Cyber 180/855
C   under NOS   (S.P.)        2        1070       1.72E+319
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)        2         128       4.08E+36
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)        2        1024       2.55D+305
C IBM 3033      (D.P.)       16          63       4.29D+73
C VAX D-Format  (D.P.)        2         127       2.05D+36
C VAX G-Format  (D.P.)        2        1023       1.28D+305
C
C
C                           XINF        EPS        FRTBIG
C
C CRAY-1        (S.P.)   5.45E+2465   7.11E-15    3.13E+615
C Cyber 180/855
C   under NOS   (S.P.)   1.26E+322    3.55E-15    6.44E+79
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)   3.40E+38     1.19E-7     1.42E+9
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)   1.79D+308    2.22D-16    2.25D+76
C IBM 3033      (D.P.)   7.23D+75     2.22D-16    2.56D+18
C VAX D-Format  (D.P.)   1.70D+38     1.39D-17    1.20D+9
C VAX G-Format  (D.P.)   8.98D+307    1.11D-16    1.89D+76
C
C**************************************************************
C**************************************************************
C
C Error returns
C
C  The program returns the value XINF for X .LE. 0.0 or when
C     overflow would occur.  The computation is believed to
C     be free of underflow and overflow.
C
C
C Intrinsic functions required are:
C
C      LOG
C
C
C References:
C
C  1) W. J. Cody and K. E. Hillstrom, 'Chebyshev Approximations for
C     the Natural Logarithm of the Gamma Function,' Math. Comp. 21,
C     1967, pp. 198-203.
C
C  2) K. E. Hillstrom, ANL/AMD Program ANLC366S, DGAMMA/DLGAMA, May,
C     1969.
C
C  3) Hart, Et. Al., Computer Approximations, Wiley and sons, New
C     York, 1968.
C
C
C  Authors: W. J. Cody and L. Stoltz
C           Argonne National Laboratory
C
C  Latest modification: June 16, 1988
C
C----------------------------------------------------------------------
*
*  Some modifs from Bruno (25 Feb 2005):
*    - return Nan (in place of XINF) if x <= 0
*    - return Inf (in place of XINF) if x > XBIG
*
*  In fact an error indicator should be returned in these cases to prevent
*  the user...
*
      INTEGER I
CS    REAL
      DOUBLE PRECISION
     1    C,CORR,D1,D2,D4,EPS,FRTBIG,FOUR,HALF,ONE,PNT68,P1,P2,P4,
     2    Q1,Q2,Q4,RES,SQRTPI,THRHAL,TWELVE,TWO,X,XBIG,XDEN,XINF,
     3    XM1,XM2,XM4,XNUM,Y,YSQ,ZERO
      DIMENSION C(7),P1(8),P2(8),P4(8),Q1(8),Q2(8),Q4(8)
C----------------------------------------------------------------------
C  Mathematical constants
C----------------------------------------------------------------------
CS    DATA ONE,HALF,TWELVE,ZERO/1.0E0,0.5E0,12.0E0,0.0E0/,
CS   1     FOUR,THRHAL,TWO,PNT68/4.0E0,1.5E0,2.0E0,0.6796875E0/,
CS   2     SQRTPI/0.9189385332046727417803297E0/
      DATA ONE,HALF,TWELVE,ZERO/1.0D0,0.5D0,12.0D0,0.0D0/,
     1     FOUR,THRHAL,TWO,PNT68/4.0D0,1.5D0,2.0D0,0.6796875D0/,
     2     SQRTPI/0.9189385332046727417803297D0/
C----------------------------------------------------------------------
C  Machine dependent parameters
C----------------------------------------------------------------------
CS    DATA XBIG,XINF,EPS,FRTBIG/4.08E36,3.401E38,1.19E-7,1.42E9/
      DATA XBIG,XINF,EPS,FRTBIG/2.55D305,1.79D308,2.22D-16,2.25D76/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     approximation over (0.5,1.5).
C----------------------------------------------------------------------
CS    DATA D1/-5.772156649015328605195174E-1/
CS    DATA P1/4.945235359296727046734888E0,2.018112620856775083915565E2,
CS   1        2.290838373831346393026739E3,1.131967205903380828685045E4,
CS   2        2.855724635671635335736389E4,3.848496228443793359990269E4,
CS   3        2.637748787624195437963534E4,7.225813979700288197698961E3/
CS    DATA Q1/6.748212550303777196073036E1,1.113332393857199323513008E3,
CS   1        7.738757056935398733233834E3,2.763987074403340708898585E4,
CS   2        5.499310206226157329794414E4,6.161122180066002127833352E4,
CS   3        3.635127591501940507276287E4,8.785536302431013170870835E3/
      DATA D1/-5.772156649015328605195174D-1/
      DATA P1/4.945235359296727046734888D0,2.018112620856775083915565D2,
     1        2.290838373831346393026739D3,1.131967205903380828685045D4,
     2        2.855724635671635335736389D4,3.848496228443793359990269D4,
     3        2.637748787624195437963534D4,7.225813979700288197698961D3/
      DATA Q1/6.748212550303777196073036D1,1.113332393857199323513008D3,
     1        7.738757056935398733233834D3,2.763987074403340708898585D4,
     2        5.499310206226157329794414D4,6.161122180066002127833352D4,
     3        3.635127591501940507276287D4,8.785536302431013170870835D3/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     Approximation over (1.5,4.0).
C----------------------------------------------------------------------
CS    DATA D2/4.227843350984671393993777E-1/
CS    DATA P2/4.974607845568932035012064E0,5.424138599891070494101986E2,
CS   1        1.550693864978364947665077E4,1.847932904445632425417223E5,
CS   2        1.088204769468828767498470E6,3.338152967987029735917223E6,
CS   3        5.106661678927352456275255E6,3.074109054850539556250927E6/
CS    DATA Q2/1.830328399370592604055942E2,7.765049321445005871323047E3,
CS   1        1.331903827966074194402448E5,1.136705821321969608938755E6,
CS   2        5.267964117437946917577538E6,1.346701454311101692290052E7,
CS   3        1.782736530353274213975932E7,9.533095591844353613395747E6/
      DATA D2/4.227843350984671393993777D-1/
      DATA P2/4.974607845568932035012064D0,5.424138599891070494101986D2,
     1        1.550693864978364947665077D4,1.847932904445632425417223D5,
     2        1.088204769468828767498470D6,3.338152967987029735917223D6,
     3        5.106661678927352456275255D6,3.074109054850539556250927D6/
      DATA Q2/1.830328399370592604055942D2,7.765049321445005871323047D3,
     1        1.331903827966074194402448D5,1.136705821321969608938755D6,
     2        5.267964117437946917577538D6,1.346701454311101692290052D7,
     3        1.782736530353274213975932D7,9.533095591844353613395747D6/
C----------------------------------------------------------------------
C  Numerator and denominator coefficients for rational minimax
C     Approximation over (4.0,12.0).
C----------------------------------------------------------------------
CS    DATA D4/1.791759469228055000094023E0/
CS    DATA P4/1.474502166059939948905062E4,2.426813369486704502836312E6,
CS   1        1.214755574045093227939592E8,2.663432449630976949898078E9,
CS   2      2.940378956634553899906876E10,1.702665737765398868392998E11,
CS   3      4.926125793377430887588120E11,5.606251856223951465078242E11/
CS    DATA Q4/2.690530175870899333379843E3,6.393885654300092398984238E5,
CS   2        4.135599930241388052042842E7,1.120872109616147941376570E9,
CS   3      1.488613728678813811542398E10,1.016803586272438228077304E11,
CS   4      3.417476345507377132798597E11,4.463158187419713286462081E11/
      DATA D4/1.791759469228055000094023D0/
      DATA P4/1.474502166059939948905062D4,2.426813369486704502836312D6,
     1        1.214755574045093227939592D8,2.663432449630976949898078D9,
     2      2.940378956634553899906876D10,1.702665737765398868392998D11,
     3      4.926125793377430887588120D11,5.606251856223951465078242D11/
      DATA Q4/2.690530175870899333379843D3,6.393885654300092398984238D5,
     2        4.135599930241388052042842D7,1.120872109616147941376570D9,
     3      1.488613728678813811542398D10,1.016803586272438228077304D11,
     4      3.417476345507377132798597D11,4.463158187419713286462081D11/
C----------------------------------------------------------------------
C  Coefficients for minimax approximation over (12, INF).
C----------------------------------------------------------------------
CS    DATA C/-1.910444077728E-03,8.4171387781295E-04,
CS   1     -5.952379913043012E-04,7.93650793500350248E-04,
CS   2     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
CS   3      5.7083835261E-03/
      DATA C/-1.910444077728D-03,8.4171387781295D-04,
     1     -5.952379913043012D-04,7.93650793500350248D-04,
     2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
     3      5.7083835261D-03/
C----------------------------------------------------------------------
      Y = X
      IF ((Y .GT. ZERO) .AND. (Y .LE. XBIG)) THEN
            IF (Y .LE. EPS) THEN
                  RES = -LOG(Y)
               ELSE IF (Y .LE. THRHAL) THEN
C----------------------------------------------------------------------
C  EPS .LT. X .LE. 1.5
C----------------------------------------------------------------------
                  IF (Y .LT. PNT68) THEN
                        CORR = -LOG(Y)
                        XM1 = Y
                     ELSE
                        CORR = ZERO
                        XM1 = (Y - HALF) - HALF
                  END IF
                  IF ((Y .LE. HALF) .OR. (Y .GE. PNT68)) THEN
                        XDEN = ONE
                        XNUM = ZERO
                        DO 140 I = 1, 8
                           XNUM = XNUM*XM1 + P1(I)
                           XDEN = XDEN*XM1 + Q1(I)
  140                   CONTINUE
                        RES = CORR + (XM1 * (D1 + XM1*(XNUM/XDEN)))
                     ELSE
                        XM2 = (Y - HALF) - HALF
                        XDEN = ONE
                        XNUM = ZERO
                        DO 220 I = 1, 8
                           XNUM = XNUM*XM2 + P2(I)
                           XDEN = XDEN*XM2 + Q2(I)
  220                   CONTINUE
                        RES = CORR + XM2 * (D2 + XM2*(XNUM/XDEN))
                  END IF
               ELSE IF (Y .LE. FOUR) THEN
C----------------------------------------------------------------------
C  1.5 .LT. X .LE. 4.0
C----------------------------------------------------------------------
                  XM2 = Y - TWO
                  XDEN = ONE
                  XNUM = ZERO
                  DO 240 I = 1, 8
                     XNUM = XNUM*XM2 + P2(I)
                     XDEN = XDEN*XM2 + Q2(I)
  240             CONTINUE
                  RES = XM2 * (D2 + XM2*(XNUM/XDEN))
               ELSE IF (Y .LE. TWELVE) THEN
C----------------------------------------------------------------------
C  4.0 .LT. X .LE. 12.0
C----------------------------------------------------------------------
                  XM4 = Y - FOUR
                  XDEN = -ONE
                  XNUM = ZERO
                  DO 340 I = 1, 8
                     XNUM = XNUM*XM4 + P4(I)
                     XDEN = XDEN*XM4 + Q4(I)
  340             CONTINUE
                  RES = D4 + XM4*(XNUM/XDEN)
               ELSE
C----------------------------------------------------------------------
C  Evaluate for argument .GE. 12.0,
C----------------------------------------------------------------------
                  RES = ZERO
                  IF (Y .LE. FRTBIG) THEN
                        RES = C(7)
                        YSQ = Y * Y
                        DO 450 I = 1, 6
                           RES = RES / YSQ + C(I)
  450                   CONTINUE
                  END IF
                  RES = RES/Y
                  CORR = LOG(Y)
                  RES = RES + SQRTPI - HALF*CORR
                  RES = RES + Y*(CORR-ONE)
            END IF
         ELSE
C----------------------------------------------------------------------
C  Return for bad arguments
C----------------------------------------------------------------------
*           modif from Bruno (see comment at the beginning)
*            RES = XINF
            if (X .le. 0.d0) then
               RES = return_a_nan()
            else  ! this means that X > XBIG and so that log(gamma) overflows
               RES = 2*XINF  ! bad trick to get Inf
            endif
*           end modif
      END IF
C----------------------------------------------------------------------
C  Final adjustments and return
C----------------------------------------------------------------------
CS    ALGAMA = RES
      DLGAMA = RES
      RETURN
C ---------- Last line of DLGAMA ----------
      END


module regcoil_read_efit_mod

  use stel_kinds

  implicit none

  private

  public :: regcoil_read_efit

  integer :: nwb, nhb
  real(dp) :: this_theta, psiN_desired, R_mag, Z_mag
  real(dp), dimension(:),   allocatable :: efit_R, efit_Z
  real(dp), dimension(:,:), allocatable :: efit_psi

contains

  subroutine regcoil_read_efit(filename, psiN_desired_in, mnmax, rmnc, zmns, rmns, zmnc)

    ! Most of this subroutine is adapted from GS2's geometry module (geo/eeq.f90)

    ! Inputs:
    !   filename: EFIT file to read
    !   psiN_desired
    use regcoil_splines
    use stel_constants
    use stel_kinds

    implicit none

    character(*) :: filename
    integer, intent(in) :: mnmax
    real(dp), intent(in) :: psiN_desired_in
    real(dp), dimension(mnmax) :: rmnc, zmns, rmns, zmnc

    character(10) ::  char
    integer :: i, j, nw, nh, ierr
    integer :: big
    real(dp) :: xdum
    real(dp) :: rwid, zhei, rcentr, rleft, psi_0, psi_a, bcentr
    real(dp), dimension(:),   allocatable :: psi_bar, fp, qsf, pressure, beta, dummy, spsi_bar, sefit_R, sefit_Z
    real(dp), dimension(:,:), allocatable :: sefit_psi
    real(dp), dimension(:,:,:), allocatable :: dpm, dtm
    integer :: ndum, nbbbs  ! nbbbs = number of points for LCFS in efit file.
    real(dp), allocatable, dimension (:) :: rbbbs, zbbbs, thetab_atan, r_bound !boundary of plasma

    ! Variables for spline fit of psi(R,Z):
    real(dp), dimension(:), allocatable :: zp, temp, zx1, zxm, zy1, zyn
    real(dp) :: zxy11, zxym1, zxy1n, zxymn

    type (spline):: LCFS_spline
    integer :: ntheta = 20
    real(dp), dimension(:), allocatable :: theta_atan, theta_general, R_surface, Z_surface, r_LCFS

    ! Variables related to the root finding:
    integer :: fzeroFlag
    real(dp) :: rootSolve_abserr, rootSolve_relerr, rootSolve_min, rootSolve_max

    real(dp) :: r_minor
    real(dp) :: rtemp, ztemp, rtemps, ztempc, cosmu, sinmu, dnorm
    integer :: m
    real(dp) :: offset1, offset2
    real(dp), dimension(:), allocatable :: thetab_atan_3, r_bound_3

    psiN_desired = psiN_desired_in

    ! nw, nh = original number of grid points in width and height of efit file. ('small' grid)
    ! big = some factor by which the EFIT (R,Z) grid is refined.
    big = 20
    ! nwb, nhb = number of grid points in width and height for refined grid. ('big' grid)
    ! efit_psi = psi on 'big' grid
    ! sefit_psi = psi on 'small' (original) grid

    ! Adding some checks to release previously allocated variables.
    ! This is because STELLOPT may call this function multiple times.
    ! if (allocated()) deallocate()

    print *,"  Reading EFIT file ",trim(filename)

    if (psiN_desired > 1) then
       stop "Error! psiN_desired must be <= 1."
    end if

    if (psiN_desired <= 0) then
       stop "Error! psiN_desired must be more than 0."
    end if

    ! Initialize a theta grid.
    ! (Factor 10 here is arbitrary. Really it just needs to be large enough to resolve mnmax modes without aliasing.)
    ntheta = mnmax * 10
    if (allocated(theta_general)) deallocate(theta_general)
    allocate(theta_general(ntheta))
    if (allocated(theta_atan)) deallocate(theta_atan)
    allocate(theta_atan(ntheta))
    do i=1,ntheta
       theta_general(i) = i-1
    end do
    theta_general = theta_general*twopi/ntheta - pi

    offset1 = 2*pi*0.71
    offset2 = 2*pi*0.3
    theta_atan = theta_general - 0.6*sin((theta_general-offset1)/2)*cos((theta_general-offset1)/2) &
         / (0.3 + sin((theta_general-offset1)/2)**2) &
         - 0.32*sin((theta_general-offset2)/2)*cos((theta_general-offset2)/2) &
         / (0.2 + sin((theta_general-offset2)/2)**2)

    ! Beginning of code taken from gs2/geo/eeq.f90

    open(unit=5,file=trim(filename),status='old',form='formatted')

    ! Read the data

    read(5,1000) char, char, char, char, char, i, nw, nh
1000 format(5(a10),i2,i4,i4)

    !if (verbosity>1) write (*,*) 'EFIT dimensions are: ', nw, nh

    nwb = nw * big
    nhb = nh * big

    ! Next line replaced with the allocates by MJL
    !call alloc_module_arrays(nwb, nwb, nhb, nw, nh)
    !subroutine alloc_module_arrays(np, nw, nh, nws, nhs, ntime)
    if (allocated(psi_bar)) deallocate(psi_bar)
    if (allocated(fp)) deallocate(fp)
    if (allocated(qsf)) deallocate(qsf)
    if (allocated(pressure)) deallocate(pressure)
    if (allocated(beta)) deallocate(beta)
    if (allocated(dummy)) deallocate(dummy)
    if (allocated(efit_R)) deallocate(efit_R)
    if (allocated(efit_Z)) deallocate(efit_Z)
    if (allocated(spsi_bar)) deallocate(spsi_bar)
    if (allocated(sefit_R)) deallocate(sefit_R)
    if (allocated(sefit_Z)) deallocate(sefit_Z)
    if (allocated(efit_psi)) deallocate(efit_psi)
    if (allocated(sefit_psi)) deallocate(sefit_psi)
    allocate(psi_bar(nwb), fp(nwb), qsf(nwb), pressure(nwb), beta(nwb))
    allocate(dummy(nw), efit_R(nwb), efit_Z(nhb))
    allocate(spsi_bar(nw), sefit_R(nw), sefit_Z(nh))
    allocate(efit_psi(nwb, nhb), sefit_psi(nw, nh))
    !allocate(dpm(nwb, nhb, 2), dtm(nwb, nhb, 2))

    read(5,2020) rwid, zhei, rcentr, rleft, xdum
    read(5,2020) R_mag, Z_mag, psi_0, psi_a, bcentr
2020 format (5e16.9)

    !
    ! pbar is defined by
    ! pbar = (psi-psi_0)/(psi_a-psi_0)
    ! fp and q are functions of pbar
    !
    do i=1,2
       read(5,2020)xdum,xdum,xdum,xdum,xdum
    enddo

    do i=1,nw
       spsi_bar(i) = float(i-1) / float(nw-1)
       sefit_R(i) = rleft +rwid * float(i-1) / float(nw-1)
    enddo

    do j=1,nh
       sefit_Z(j) = ((float(j-1) / float(nh-1) ) - 0.5)*zhei
    enddo

    do i=1,nwb
       psi_bar(i) = float(i-1) / float(nwb-1)
       efit_R(i) = rleft +rwid * float(i-1) / float(nwb-1)
    enddo

    do j=1,nhb
       efit_Z(j) = ((float(j-1) / float(nhb-1) ) - 0.5)*zhei
    enddo

    ! Read T = R * B_toroidal
    read(5,2020) (dummy(j),   j = 1, nw)
    !MJL call inter_cspl(nw, spsi_bar, dummy, nwb, psi_bar, fp)
    ! Read pressure
    read(5,2020) (dummy(j), j = 1, nw)
    !MJL call inter_cspl(nw, spsi_bar, dummy, nwb, psi_bar, pressure)
    ! Read T * (dT/dpsi)?
    read(5,2020) (dummy(j),     j = 1, nw)
    ! Read dp/dpsi?
    read(5,2020) (dummy(j),     j = 1 ,nw)
    ! Read psi(R,Z):
    read(5,2020) ((sefit_psi(i,j) , i = 1, nw) , j = 1, nh)

    ! Read q(psi)
    read(5,2020) (dummy(j) ,   j = 1, nw)

    ! Read # of points describing the LCFS:
    read(5,2022) nbbbs, ndum
2022 format (2i5)

    if (allocated(rbbbs)) deallocate(rbbbs)
    if (allocated(zbbbs)) deallocate(zbbbs)
    if (allocated(thetab_atan)) deallocate(thetab_atan)
    if (allocated(r_bound)) deallocate(r_bound)
    allocate(rbbbs(nbbbs), zbbbs(nbbbs), thetab_atan(nbbbs), r_bound(nbbbs))
    ! Read in location of the LCFS:
    read(5,2020) (rbbbs(i), zbbbs(i) , i = 1, nbbbs)

    ! End of info in the EFIT file.
    close(5)

    ! get r_boundary(theta)
    thetab_atan = atan2 ((zbbbs-Z_mag), (rbbbs-R_mag))
    r_bound = sqrt( (rbbbs - R_mag)**2 + (zbbbs - Z_mag)**2 )

    call regcoil_sort(thetab_atan, r_bound, zbbbs, rbbbs, nbbbs)

    ! Allow for duplicated points near +- pi:

    if(thetab_atan(1) == thetab_atan(2)) then
       thetab_atan(1) = thetab_atan(1) + twopi
       call regcoil_sort(thetab_atan, r_bound, zbbbs, rbbbs, nbbbs)
    endif

    if(thetab_atan(nbbbs-1) == thetab_atan(nbbbs)) then
       thetab_atan(nbbbs) = thetab_atan(nbbbs) - twopi
       call regcoil_sort(thetab_atan, r_bound, zbbbs, rbbbs, nbbbs)
    endif

    ! It isn't likely that a duplicate point would exist near theta = 0,
    ! so I am not allowing this possibility for now.

    do i=1,nbbbs-1
       if(thetab_atan(i+1) == thetab_atan(i)) then
          !          write(*,*) 'Duplicates near theta = 0 not allowed.'
          !          write(*,*) i, i+1, ' Stopping.'
          !          stop
          !
          ! put in kluge for duplicate points, which happens near theta=0:
          thetab_atan(i+1) = thetab_atan(i+1)+1.e-8
       endif
    enddo

!!$  print *,"psi_0:",psi_0
!!$  print *,"psi_a:",psi_a
!!$  print *,"sefit_R:"
!!$  print *,sefit_R
!!$  print *,"sefit_Z:"
!!$  print *,sefit_Z

    ! Normalize and shift psi so it goes from 0 on axis to 1 at the LCFS.
    sefit_psi = 1 - (sefit_psi-psi_a)/(psi_0-psi_a)

!!$  print *,"max(sefit_psi):",maxval(sefit_psi)
!!$  print *,"min(sefit_psi):",minval(sefit_psi)

    ! Use splines to interpolate psi(R,Z) from the original coarse grid to the fine ('big') grid:
    ! if (allocated(zp)) deallocate(zp)
    ! if (allocated(temp)) deallocate(temp)
    allocate(zp(3*nw*nh), temp(nw+2*nh))
    if (allocated(zx1)) deallocate(zx1)
    if (allocated(zxm)) deallocate(zxm)
    if (allocated(zy1)) deallocate(zy1)
    if (allocated(zyn)) deallocate(zyn)
    allocate(zx1(nh), zxm(nh), zy1(nw), zyn(nw))

    call fitp_surf1(nw, nh, sefit_R, sefit_Z, sefit_psi, &
         nw, zx1, zxm, zy1, zyn, zxy11, zxym1, zxy1n, zxymn, &
         255, zp, temp, 1.0_dp, ierr)

    do j = 1, nhb
       do i = 1, nwb
          efit_psi(i,j) = fitp_surf2(efit_R(i), efit_Z(j), nw, nh, &
               sefit_R, sefit_Z, sefit_psi, nw, zp, 1.0_dp)
       enddo
    enddo

    deallocate(zp, temp)

!!$  print *,"max(efit_psi):",maxval(efit_psi)
!!$  print *,"min(efit_psi):",minval(efit_psi)

    ! Next, use spline interpolation to get r_LCFS on the theta grid we want.
    ! Since 'thetab_atan' does not run from exactly -pi to pi, there will be a bit of extrapolation
    ! at the ends of the grid. This could be eliminated if it is a problem.
    if (allocated(thetab_atan_3)) deallocate(thetab_atan_3)
    allocate(thetab_atan_3(nbbbs*3))
    if (allocated(r_bound_3)) deallocate(r_bound_3)
    allocate(r_bound_3(nbbbs*3))
    thetab_atan_3(1:nbbbs) = thetab_atan-2*pi
    thetab_atan_3((nbbbs+1):(2*nbbbs)) = thetab_atan
    thetab_atan_3((2*nbbbs+1):(3*nbbbs)) = thetab_atan+2*pi
    r_bound_3(1:nbbbs) = r_bound
    r_bound_3((nbbbs+1):(2*nbbbs)) = r_bound
    r_bound_3((2*nbbbs+1):(3*nbbbs)) = r_bound

    !call new_spline(nbbbs, thetab_atan, r_bound, LCFS_spline)
    call new_spline(nbbbs*3, thetab_atan_3, r_bound_3, LCFS_spline)
    if (allocated(r_LCFS)) deallocate(r_LCFS)
    allocate(r_LCFS(ntheta))
    do i = 1,ntheta
       r_LCFS(i) = splint(theta_atan(i), LCFS_spline)
    end do

!!$  print *," "
!!$  print *,"thetab_atan:",thetab_atan
!!$  print *," "
!!$  print *,"theta:",theta
!!$  print *," "
!!$  print *,"r_LCFS:",r_LCFS
!!$  print *," "

    ! Now solve the root-finding problem at each theta
    if (allocated(R_surface)) deallocate(R_surface)
    if (allocated(Z_surface)) deallocate(R_surface)
    allocate(R_surface(ntheta), Z_surface(ntheta))

    rootSolve_abserr = 1.0e-10_dp
    rootSolve_relerr = 1.0e-10_dp
    do i = 1,ntheta
       print *,"i=",i,"of",ntheta
       rootSolve_min = 0.0_dp
       rootSolve_max = r_LCFS(i)
       this_theta = theta_atan(i)

       if (abs(psiN_desired-1) < 1d-7) then
          r_minor = r_LCFS(i)
          if (i==1) then
             print *,"Using EFIT LCFS directly"
          end if
       else
          if (i==1) then
             print *,"Computing a flux surface inside the EFIT LCFS."
          end if

          call regcoil_fzero(regcoil_efit_fzero_residual, rootSolve_min, rootSolve_max, rootSolve_max * psiN_desired, &
               rootSolve_relerr, rootSolve_abserr, fzeroFlag)
          ! Note: regcoil_fzero returns its answer in rootSolve_min
          r_minor = rootSolve_min
          if (fzeroFlag == 4) then
             stop "ERROR: fzero returned error 4: no sign change in residual"
          else if (fzeroFlag > 2) then
             print *,"WARNING in rem: fzero returned an error code:",fzeroFlag
          end if
       end if

       R_surface(i) = regcoil_Rpos(r_minor, this_theta)
       !Z_surface(i) = Zpos(r_minor, this_theta) - Z_mag  ! Shift vertically so magnetic axis is now at Z=0
       Z_surface(i) = regcoil_Zpos(r_minor, this_theta)
    end do

    print *,"Begin Fourier coefficients of plasma surface ----------"
    ! Begin code adapted from BNORM to Fourier transform data on the theta grid to sin/cos coefficients
    do m = 0, mnmax-1
       dnorm = (1.0_dp)/ntheta
       if (m.ne.0) dnorm = 2*dnorm
       rtemp = 0
       ztemp = 0
       rtemps = 0
       ztempc = 0
       do i = 1, ntheta
          cosmu = cos(m*theta_general(i))*dnorm
          sinmu = sin(m*theta_general(i))*dnorm
          rtemp  = rtemp  + R_surface(i) * cosmu
          ztemp  = ztemp  + Z_surface(i) * sinmu
          rtemps = rtemps + R_surface(i) * sinmu
          ztempc = ztempc + Z_surface(i) * cosmu
       end do
       rmnc(m+1) = rtemp
       zmns(m+1) = ztemp
       rmns(m+1) = rtemps
       zmnc(m+1) = ztempc
       ! Example of format for VMEC input:
       ! RBC(-12, 0) = -5.1637E-05 ZBS(-12, 0) = -9.4960E-05
       print "(a,i3.3,a,e20.12,a,i3.3,a,e20.12)","RBC(0,",m,")=",rmnc(m+1)," ZBS(0,",m,")=",zmns(m+1)
       print "(a,i3.3,a,e20.12,a,i3.3,a,e20.12)","RBS(0,",m,")=",rmns(m+1)," ZBC(0,",m,")=",zmnc(m+1)
    end do
    print *,"End Fourier coefficients of plasma surface ----------"

    print *,"Begin Fourier coefficients of plasma surface ----------"
    print *,'m, rmnc, rmns, zmnc, zmns'
    do m = 0, mnmax-1
       print "(i3.3,4e20.12)",m,rmnc(m+1),rmns(m+1),zmnc(m+1),zmns(m+1)
    end do
    print *,"End Fourier coefficients of plasma surface ----------"

!!$  print *,"r_surface:",r_surface
!!$  print *," "
    print *,"  Succeeded reading and processing EFIT file."

  end subroutine regcoil_read_efit

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

  function regcoil_efit_fzero_residual(r)
    implicit none

    real(dp), intent (in) :: r
    real(dp) :: f, regcoil_efit_fzero_residual

    call regcoil_eqitem(r, this_theta, efit_psi, f)
    regcoil_efit_fzero_residual = f - psiN_desired
  end function regcoil_efit_fzero_residual

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

  subroutine regcoil_eqitem(r, thetin, f, fstar)
    ! Given a quantity f(:,:) on the 'big' (i.e. refined) (R,Z) grid,
    ! linearly interpolate to evaluate the quantity at a given (r,theta)
    ! where theta is the angle defined by tan(theta) = (Z-Z_axis)/(R-R_axis).

    implicit none

    real(dp), intent (in) :: r, thetin, f(:,:)
    real(dp), intent (out) :: fstar
    integer :: i, j, istar, jstar
    real(dp) :: st, dt, sr, dr
    real(dp) :: r_pos, z_pos

    r_pos = regcoil_Rpos(r, thetin)
    z_pos = regcoil_Zpos(r, thetin)

    ! find point on R mesh

    if(r_pos >= efit_R(nwb) .or. r_pos <= efit_R(1)) then
       write(*,*) 'No evaluation of eqitem allowed outside'
       write(*,*) 'or on edge of R domain'
       write(*,*) r, thetin, efit_R(1), efit_R(nwb), r_pos
       stop
    endif

    ! ensure point is on Z mesh

    if(z_pos >= efit_Z(nhb) .or. z_pos <= efit_Z(1)) then
       write(*,*) 'No evaluation of eqitem allowed outside'
       write(*,*) 'or on edge of Z domain'
       write(*,*) r, thetin, efit_Z(1), efit_Z(nhb), z_pos
       stop
    endif

    istar=0
    do i=2,nwb
       if(istar /= 0) cycle
       if(r_pos < efit_R(i)) then
          dr = r_pos - efit_R(i-1)
          sr = efit_R(i) - r_pos
          istar=i-1
       endif
    enddo

    ! Now do Z direction

    jstar=0
    do j=1,nhb
       if(jstar /= 0) cycle
       if(z_pos < efit_Z(j)) then
          dt = z_pos - efit_Z(j-1)
          st = efit_Z(j) - z_pos
          jstar=j-1
       endif
    enddo

    ! use opposite area stencil to interpolate

    fstar=f(istar    , jstar    ) * sr * st &
         +f(istar + 1, jstar    ) * dr * st &
         +f(istar    , jstar + 1) * sr * dt &
         +f(istar + 1, jstar + 1) * dr * dt
    fstar = fstar &
         /abs(efit_R(istar+1)-efit_R(istar)) &
         /(efit_Z(jstar+1)-efit_Z(jstar))

  end subroutine regcoil_eqitem

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

 function regcoil_Zpos (r, theta)
    implicit none
    real(dp), intent (in) :: r, theta
    real(dp) :: regcoil_Zpos

    regcoil_Zpos = Z_mag + r * sin(theta)
  end function regcoil_Zpos

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

  function regcoil_Rpos (r, theta)
    implicit none
    real(dp), intent (in) :: r, theta
    real(dp) :: regcoil_Rpos

    regcoil_Rpos = R_mag + r * cos(theta)
  end function regcoil_Rpos

end module regcoil_read_efit_mod

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

subroutine regcoil_sort(a, b, c, d, N)

  use stel_kinds

  implicit none

  integer, intent(in) :: N
  real(dp), dimension(N), intent(in out) :: a, b, c, d
  real(dp) :: tmp
  integer :: i, jmax
  logical :: sorted

  jmax = size(a)

  do
     sorted = .true.
     do i=1,jmax-1
        if(a(i+1) < a(i)) then
           tmp=a(i); a(i)=a(i+1); a(i+1)=tmp
           tmp=b(i); b(i)=b(i+1); b(i+1)=tmp
           tmp=c(i); c(i)=c(i+1); c(i+1)=tmp
           tmp=d(i); d(i)=d(i+1); d(i+1)=tmp
           sorted = .false.
        endif
     enddo
     if (sorted) exit
  enddo

end subroutine regcoil_sort


c*****************************************************************************
c Subroutine LLSQ - Calculates the least squares solution using the
c                   math77 routine shfti.
c
c 12/7/1992 - M. O'Shaughnessy - Ported LLSQ to UNIX.
c*****************************************************************************
      subroutine llsq(a,b,m,n,l,x,ipiv,eps,ier,aux)

      real*4    a(m,n),b(m,l),x(n,l),aux(n,2),eps
      integer*4 m,n,l,ier,ipiv(n)

c local arrays and variables.

      integer*4 rn_dim
      parameter (rn_dim = 500)          ! max number of right hand sides
                                        ! = max value for l.
      real*4    rnorm(rn_dim)
      integer*4 krank,i,j

c==================================================================

      if (l .gt. rn_dim) then
	call xvmessage('LLSQ> local arrays need to be enlarged!', ' ')
        call abend
      end if

c  call math77 routine to solve least squares problem

      if ( m .ge. n ) then
        call shfti(a,m,m,n,b,m,l,eps,krank,rnorm,aux(1,1),
     .             aux(1,2), ipiv )
        if (krank .eq. 0)  then
          ier = - 1
        else if (krank .lt. n)  then
          ier = krank
        else
          ier = 0         ! error unless pseudo-rank = n.
          do j = 1, l     ! now copy answers to output array.
            do i = 1, n
              x(i,j) = b(i,j)
            end do
          end do
        end if

      else
        ier = -2        ! since shfti uses b array for both input and output,
                        ! there is no convenient way i see to handle the
                        ! case of n gt m with the llsq calling sequence.
        call xvmessage('LLSQ> column number must be <= row number',' ')
      end if

      return
      end


      subroutine poisnd(m,n,rhs,soln,du,dv,res)
      use mod_plot  ! HYCOM plot array interface
c
      real rhs(m-1,*),soln(m-1,*),du(m-1,*),dv(m-1,*),res(*)
c
c --- vectorizable version of s.o.r. poisson solver.
c
c --- the exact form of the equation being solved is
c
c              div [(1/p) grad soln] = rhs/(mesh size squared)
c
c --- where -p- is the layer thickness, -rhs- is the vorticity,
c --- and -soln- is the mass flux stream function
c
c --- m,n  = dimensions of -rhs,soln- in calling program
c --- du   = inverse layer thickness at (i,j+1/2) (u point)
c --- dv   = inverse layer thickness at (i+1/2,j) (v point)
c --- res  = work space of size m*n
c
c --- errmin should represent a number equivalent to [10**(-3) sv]**2
      data rfc/1.7/,itrmax/1500/,errmin/1.e-6/,errmax/1.e37/
c
      mn2=m+n-2
      m1=m-1
      do 10 iter=1,itrmax
      errmx=0.
      do 1 i=4,mn2
      err=0.
      nd=i-1
      if (nsec(nd).eq.0) go to 1
      nptsd=0
      do 4 ns=1,nsec(nd)
      l=i-m
      k1=(m*jfd(nd,ns)+ifd(nd,ns)-l-1)/m1
      k2=(m*jld(nd,ns)+ild(nd,ns)-l-1)/m1
ccc      write (*,'('' nd,ns,ifd,jfd,ild,jld,k1,k2=''8i4)') nd,ns,
ccc     .  ifd(nd,ns),jfd(nd,ns),ild(nd,ns),jld(nd,ns),k1,k2
      nptsd=nptsd+k2-k1+1
      iy1=ifd(nd,ns)+k1
      do 2 k=k1,k2
c --- neighbors i-1,j and i+1,j are at l-1,k and l+1,k respectively
c --- neighbors i,j-1 and i,j+1 are at l-m,k and l+m,k respectively
c
 2    res(k)=(soln(l+1,k)*dv(l,k)+soln(l-1,k)*dv(l-1,k)
     .       +soln(l+m,k)*du(l,k)+soln(l-m,k)*du(l-m,k) - rhs(l,k))
     .      /(            dv(l,k)+            dv(l-1,k)
     .       +            du(l,k)+            du(l-m,k)) - soln(l,k)
      do 3 k=k1,k2
      err=err+res(k)**2
 3    soln(l,k)=soln(l,k)+rfc*res(k)
 4    continue
      err=err/nptsd
      errmx=amax1(errmx,err)
      if (err.gt.errmax) go to 20
 1    continue
      if (iter.lt.25.or.errmx.gt.errmin) go to 10
      write (*,900) iter,errmx
 900  format(' s.o.r. converged at',i4,' iterations -- errmx =',1pe11.3)
      return
 10   continue
 20   write (*,901) iter,errmx
 901  format(' warning - errmx exceeded in s.o.r. routine - iter=',i4,
     .'  errmx=',1pe10.3)
      return
      end


c Monte Carlo code to simulate emission from an isotropic point source
c at origin of a uniform density sphere where the scattering albedo=1
      program mcsphere
      implicit none
      integer iseed,npk
      integer i,j,ipk,nDepth
      real r(3),u(3)
      real pi
      real ran2
      real rmag,rmax,l,taumax,a,nScatt,sCount

      open(8, FILE='mc_iso.dat', status='replace')
c initalise variables
      pi=4.*ATAN(1.)

      iseed=-17284!keep this throughout-CHECK this is that simple!
c using cartesian coords r_x,r_y,r_z; with |r|=rmag
      rmag=0.! |r(x,y,z)|
      rmax=1.
      a=1.!albedo: uniform density=>albedo not a function of r(x,y,z)

c npk: no. of photon packets per optical depth tau
c....... counted using ipk- the ith photon packet
c scount: total no. of scatterings per optical depth
c........counted using scount: scatter count

      nDepth=20 !number of tau_maxes to sample
      npk=20000
      nScatt=0

      do j=1,nDepth
        print*,j
c set a max optical depth; and set scatter count sCount=0
        taumax=real(j)
        sCount=0
c       for this depth, simulate npk photons to be emitted
        do ipk=1,npk

          call emit_photon(iseed,pi,r,u)
          do !exit cond. in loop after |r| is updated
c             ...exit when |r|>rmax
c           get a new l (from a random tau), to find new position r
            l=-log(ran2(iseed))/taumax*rmax
            do i=1,3
              r(i)=r(i)+l*u(i)
            enddo
c           use r to update rmag, and exit loop if rmag>rmax
            rmag=sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
            if (rmag.gt.rmax) exit
c           if pkt is still in sphere, scatter isotropically
            call scatter(iseed,pi,u)
            sCount=sCount+1.
          enddo

        enddo

        nScatt=sCount/(real(npk))
        write(8,*)taumax,nScatt
      enddo
      close(8)
      stop
      end
c-----SUBROUTINES------------------------------------------------------

      subroutine emit_photon(iseed,pi,r,u)
      implicit none
      integer iseed, i
      real r(3),u(3),pi
c     give packets initial position and direction
c     corresponding to emission of isotropic point source at origin
c     position is easy (x,y,z)=(0,0,0)
c     assuming velocity is same mag, any direction

      do i=1,3
         r(i)=0.
      enddo
      call isotropic(iseed,pi,u)

      return
      end
c-------------
      subroutine scatter(iseed,pi,u)
      implicit none
      integer iseed
      real pi, u(3)
c     albedo not function of position so just return new direction
c     and increment scatter count

      call isotropic(iseed,pi,u)

      return
      end
c------------
      subroutine isotropic(iseed,pi,u)
      implicit none
      integer iseed
      real pi, u(3),theta,phi,ran2

      theta=ACOS((2.*ran2(iseed))-1.)
      phi=2.*pi*ran2(iseed)

      u(1)=SIN(theta)*COS(phi)
      u(2)=SIN(theta)*SIN(phi)
      u(3)=COS(theta)

      return
      end


module flatten_module

  implicit none

contains

! :::
! ::: ------------------------------------------------------------------
! :::

  subroutine uflaten(lo,hi,p,u,v,w,flatn,q_l1,q_l2,q_l3,q_h1,q_h2,q_h3)

    use amrex_fort_module, only : rt => amrex_real
    use meth_params_module, only : iorder, small_pres
    use amrex_constants_module

    implicit none

    integer lo(3),hi(3)
    integer q_l1,q_l2,q_l3,q_h1,q_h2,q_h3

    real(rt) p(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3)
    real(rt) u(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3)
    real(rt) v(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3)
    real(rt) w(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3)
    real(rt) flatn(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3)

    integer i, j, k, idx, ishft
    integer nx,ny,nz,nmax

    real(rt) denom, zeta, tst, tmp, ftmp

    ! Local arrays
    real(rt), allocatable :: dp(:,:,:), z(:,:,:), chi(:,:,:)

    ! Knobs for detection of strong shock
    real(rt), parameter :: shktst = 0.33d0, zcut1 = 0.75d0, zcut2 = 0.85d0, dzcut = ONE/(zcut2-zcut1)

    nx = hi(1)-lo(1)+3
    ny = hi(2)-lo(2)+3
    nz = hi(3)-lo(3)+3

    nmax = max(nx,ny,nz)

    if (iorder .eq. 3) then
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                flatn(i,j,k) = ONE
             enddo
          enddo
       enddo
       return
    endif

    ! x-direction flattening coef
    allocate(dp (0:nmax-1,lo(2):hi(2),lo(3):hi(3)))
    allocate(z  (0:nmax-1,lo(2):hi(2),lo(3):hi(3)))
    allocate(chi(0:nmax-1,lo(2):hi(2),lo(3):hi(3)))
    do k = lo(3),hi(3)
       do j = lo(2),hi(2)
          do i = lo(1)-1,hi(1)+1
             idx = i-lo(1)+1
             dp(idx,j,k) = p(i+1,j,k) - p(i-1,j,k)
             denom = max(small_pres,abs(p(i+2,j,k)-p(i-2,j,k)))
             zeta = abs(dp(idx,j,k))/denom
             z(idx,j,k) = min( ONE, max( ZERO, dzcut*(zeta - zcut1) ) )
             if (u(i-1,j,k)-u(i+1,j,k) .ge. ZERO) then
                tst = ONE
             else
                tst = ZERO
             endif
             tmp = min(p(i+1,j,k),p(i-1,j,k))
             if ((abs(dp(idx,j,k))/tmp).gt.shktst) then
                chi(idx,j,k) = tst
             else
                chi(idx,j,k) = ZERO
             endif
          enddo
          do i = lo(1),hi(1)
             idx = i-lo(1)+1
             if(dp(idx,j,k).gt.ZERO)then
                ishft = 1
             else
                ishft = -1
             endif
             flatn(i,j,k) = ONE - &
                  max(chi(idx-ishft,j,k)*z(idx-ishft,j,k),chi(idx,j,k)*z(idx,j,k))
          enddo
       enddo
    enddo

    deallocate(dp,z,chi)

    ! y-direction flattening coef
    allocate(dp (lo(1):hi(1),0:nmax-1,lo(3):hi(3)))
    allocate(z  (lo(1):hi(1),0:nmax-1,lo(3):hi(3)))
    allocate(chi(lo(1):hi(1),0:nmax-1,lo(3):hi(3)))
    do k = lo(3),hi(3)
       do i = lo(1),hi(1)
          do j = lo(2)-1,hi(2)+1
             idx = j-lo(2)+1
             dp(i,idx,k) = p(i,j+1,k) - p(i,j-1,k)
             denom = max(small_pres,abs(p(i,j+2,k)-p(i,j-2,k)))
             zeta = abs(dp(i,idx,k))/denom
             z(i,idx,k) = min( ONE, max( ZERO, dzcut*(zeta - zcut1) ) )
             if (v(i,j-1,k)-v(i,j+1,k) .ge. ZERO) then
                tst = ONE
             else
                tst = ZERO
             endif
             tmp = min(p(i,j+1,k),p(i,j-1,k))
             if ((abs(dp(i,idx,k))/tmp).gt.shktst) then
                chi(i,idx,k) = tst
             else
                chi(i,idx,k) = ZERO
             endif
          enddo
          do j = lo(2),hi(2)
             idx = j-lo(2)+1
             if(dp(i,idx,k).gt.ZERO)then
                ishft = 1
             else
                ishft = -1
             endif
             ftmp = ONE - &
                  max(chi(i,idx-ishft,k)*z(i,idx-ishft,k),chi(i,idx,k)*z(i,idx,k))
             flatn(i,j,k) = min( flatn(i,j,k), ftmp )
          enddo
       enddo
    enddo

    deallocate(dp,z,chi)

    ! z-direction flattening coef
    allocate(dp (lo(1):hi(1),lo(2):hi(2),0:nmax-1))
    allocate(z  (lo(1):hi(1),lo(2):hi(2),0:nmax-1))
    allocate(chi(lo(1):hi(1),lo(2):hi(2),0:nmax-1))
    do j = lo(2),hi(2)
       do i = lo(1),hi(1)
          do k = lo(3)-1,hi(3)+1
             idx = k-lo(3)+1
             dp(i,j,idx) = p(i,j,k+1) - p(i,j,k-1)
             denom = max(small_pres,abs(p(i,j,k+2)-p(i,j,k-2)))
             zeta = abs(dp(i,j,idx))/denom
             z(i,j,idx) = min( ONE, max( ZERO, dzcut*(zeta - zcut1) ) )
             if (w(i,j,k-1)-w(i,j,k+1) .ge. ZERO) then
                tst = ONE
             else
                tst = ZERO
             endif
             tmp = min(p(i,j,k+1),p(i,j,k-1))
             if ((abs(dp(i,j,idx))/tmp).gt.shktst) then
                chi(i,j,idx) = tst
             else
                chi(i,j,idx) = ZERO
             endif
          enddo
          do k = lo(3),hi(3)
             idx = k-lo(3)+1
             if(dp(i,j,idx).gt.ZERO)then
                ishft = 1
             else
                ishft = -1
             endif
             ftmp = ONE - &
                  max(chi(i,j,idx-ishft)*z(i,j,idx-ishft),chi(i,j,idx)*z(i,j,idx))
             flatn(i,j,k) = min( flatn(i,j,k), ftmp )
          enddo
       enddo
    enddo

    deallocate(dp,z,chi)

  end subroutine uflaten

end module flatten_module