MODULE corr_focus_mod

  USE myMath_module;    USE seism_uti_module
 ! USE myString_mod

  IMPLICIT NONE

  ! PRIVATE  ::

CONTAINS
!==================================
function SQRT_to_odd1(n2) result(od)
integer  :: n2, od
integer  :: j, k
! Gieven input n2, find closest od >= 3, such that od^2 == n2

j  = floor( (sqrt(real(n2))-1.)/2. )
k  = j+1

j  = 2*j+1  ! odd
k  = 2*k+1  ! odd

if (n2 - j**2 <= k**2 - n2) then
  od = j
else
  od = k
end if
od = max(1, od)

end function
!-----------
subroutine SQRT_to_odd2(od, er, n2)
integer, intent(out) :: od(2), er
integer, intent(in)  :: n2
integer  :: j(4), k(4), e(4), i, loc(1), resi

! Given an input n2, find the best od(2)>=3, such that \sum od(:)^2 == n2

j = (/ -1, 2, 1, 0 /) +  floor( (sqrt(real(n2)/2.)-1.)/2. )

j = 2*j + 1 ! odd
e = 10000   ! init big
od= 0

do i = 1,4
  resi = n2 - j(i)**2
  if (j(i) <= 1  .OR. resi <= 0)  cycle
  k(i) = SQRT_to_odd1(resi)
  e(i) = abs(resi - k(i)**2)
end do

loc = minloc(e)
od(1) = j( loc(1) )
od(2) = k( loc(1) )
er    = e( loc(1) )
end subroutine
!------------

subroutine SQRT_to_odd3(od, er, n2)
integer, intent(out) :: od(3), er
integer, intent(in)  :: n2
integer  :: j(4), e(4), i, loc(1), resi

! Given an input n2, find the best od(3), such that \sum od(:)^2 == n2

j = (/ -1, 2, 1, 0 /) +  floor( (sqrt(real(n2)/3.)-1.)/2. )

j = 2*j + 1 ! odd
e = 10000   ! init big
od= 0

do i = 1,4
  resi = n2 - j(i)**2
  if (j(i) <=1 .OR. resi <=0)   cycle
  call SQRT_to_odd2(od(2:3), e(i), resi)
end do

loc = minloc(e)
er  = e ( loc(1) )
od(1) = j(loc(1) )

if (er==10000)  return  ! all are invalid

if (loc(1) /= 4) then
  call SQRT_to_odd2(od(2:3), er, n2-od(1)**2)
end if

end subroutine
!------------
subroutine SQRT_to_odd4(od, er, n2)
integer, intent(out) :: od(4), er
integer, intent(in)  :: n2
integer  :: j(4), e(4), i, loc(1), resi

! Given an input n2, find the best od(4), such that \sum od(:)^2 == n2

j = (/ -1, 2, 1, 0 /) +  floor( (sqrt(real(n2)/4.)-1.)/2. )

j = 2*j + 1 ! odd
e = 10000   ! init big
od= 0

do i = 1,4
  resi = n2 - j(i)**2
  if (j(i) <=1 .OR. resi <=0)   cycle
  call SQRT_to_odd3(od(2:4), e(i), resi)
end do

loc = minloc(e)
er  = e ( loc(1) )
od(1) = j(loc(1) )

if (er==10000)  return  ! all are invalid

if (loc(1) /= 4) then
  call SQRT_to_odd3(od(2:4), er, n2-od(1)**2)
end if

end subroutine
!-------------
subroutine Bspline_wids(wids, M)
! rect width M, to be equated w/ a B-spline with 4 narrower widths --> their spatial var. are eq
integer, intent(out):: wids(4)
integer, intent(in) :: M   ! var = (M^2 - 1)/12

integer  :: er
if (M <=  6) then
   wids = 3
   return
end if
call SQRT_to_odd4(wids, er, M*M + 3)

end subroutine
!-------------

subroutine make_imp_resp_Bspline(V, wids)
! B-spline with 4 narrower widths.  Find the impulse response in V
real, allocatable, intent(out):: V(:)
integer, intent(in)  :: wids(4)

integer  :: M2, M
real(8), allocatable :: tmp1(:), tmp2(:)

M  = sum(wids) - (size(wids) - 1)  ! because of keeping conv'ing
M2 = M/2

if (allocated(V))    deallocate(V)
allocate(V(M), tmp1(M), tmp2(M))
V       =  0.
V(M2+1) =  1.
call Bspline1D_mirr_conv_S(V, wids, tmp1, tmp2)

deallocate(tmp1, tmp2)

end subroutine

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

subroutine index_intersec(hsi,tsi, Hbi,Tbi, hs,ts, Hb,Tb)
! a short vector whose index range on the domain of a big vector is
! supposedly [hs,ts].  The big vector's valid index range is [Hb,Tb].
! Intersect them, so now the [hsi,tsi] of the small vec resides on
! [Hbi, Tbi] of the big one.

integer, intent(out):: hsi,tsi, Hbi,Tbi
integer, intent(in) :: hs, ts,  Hb, Tb
integer  :: L

L = ts-hs+1   ! small vec's length

if (hs>=Hb) then
   hsi = 1
   Hbi = hs
else
   hsi = 1+Hb-hs
   Hbi = Hb
end if

if (ts<=Tb) then
   tsi = L
   Tbi = ts
else
   tsi = L - (ts-Tb)
   Tbi = Tb
end if

end subroutine
!-------------

subroutine corr_cent(y, u, W, lag12, HEAD)
! y = Xcorr(u, W)
! u: N x 1
! W: M x 1,  M << N, M odd, M's reference point is its center, if HEAD == <0>
!                     else, the reference pnt is W(1)
!
! W sliding across u, produce the corr output y
! lag12  2 x 1,  the lag range of W's reference pnt wrt u
! y:  lag12(2)-lag12(1)+1 x 1
!===  All vectors' memory assigned ====

real,   intent(out):: y(:)
real,   intent(in) :: u(:), W(:)
integer,intent(in) :: lag12(2)
integer,intent(in),optional :: HEAD

integer :: i, hsi,tsi, Hbi,Tbi, N, M, M2, headx ! local var HEAD
! integer, save :: callcounter = 0

headx = 0;    if(present(HEAD))  headx = HEAD

N = size(u)
M = size(W)
if (headx==0) then
  M2 = M/2
  do i = lag12(1), lag12(2)
      call index_intersec(hsi,tsi, Hbi,Tbi, i-M2, i+M2, 1, N)
      y(i-lag12(1)+1) = sum(W(hsi:tsi)*u(Hbi:Tbi))
  end do
else
  do i = lag12(1), lag12(2)
      call index_intersec(hsi,tsi, Hbi,Tbi, i, i+M-1, 1, N)
      y(i-lag12(1)+1) = sum(W(hsi:tsi)*u(Hbi:Tbi))
  end do
end if
!if (callcounter == 0) then
!   call write_binfile('y.bin', y)  !!!!!!!!!
!   call write_binfile('u.bin', u)  !!!!!!!!!
!   call write_binfile('W.bin', W)  !!!!!!!!!
!end if
!callcounter = callcounter + 1

end subroutine
!-------------
subroutine squashNega(f,g, x, alph, MODE)
! idea is: reduce the influence of the negative part of x
! x:  vector
! alph:  1x1
! f:  same size as x
! g:  gradient elem-wise, \partial f_k / \partial x_k, so same size as x
!
! MODE == 0:
! map x \in [-1, 1] to f \in [0, 1]  ~ exp(x)
!     x is normalized, so \in [-1, 1]
!
! MODE == 1, 2:
! f(x) = exp(alph.*x), when x<=0.  When x>0:
! 1:
!     1 + alph.*x      f, f' conti
! 2:
!     alph^2/2 .*(x+ 1/alph).^2 + 1/2,   f, f', f" conti

real, intent(out) :: f(:), g(:)
real, intent(in)  :: x(:), alph
integer,intent(in):: MODE
real  :: bet, exa

select case (MODE)
case (0)
   exa = exp(alph)
   bet = 1./(exa - 1./exa)
   g   = exp(alph*x)
   f   = bet * (g - 1./exa)
   g   = (alph*bet) * g
case (1)
   where (x<0)
      f = exp(alph*x)
      g = alph*f
   elsewhere
      f = 1 + alph*x
      g = alph
   end where
case (2)
   bet = alph*alph
   where (x<0)
      f = exp(alph*x)
      g = alph*f
   elsewhere
      f = 0.5*(1. + bet* (x + 1/alph)**2)
      g =       bet* (x + 1/alph)
   end where
end select

end subroutine
!-------------

subroutine localMx(pk, y, L2, Boff, thresh, pktmp, itmp)
! y    N x 1  waveform
! pk   N x 1  logical, marking the local peaks of y within a
!             [-L2, L2] neighborhood
! Boff 1 x 1  the distance within Boff near the boundary is turned off
! thresh 1x1  peaks must >= thresh
! pktmp  Nx1  same size as pk

logical, intent(out)   :: pk(:)
logical, intent(inout) :: pktmp(:)
real,    intent(in)    :: y(:), thresh
integer, intent(in)    :: L2,   Boff
integer, intent(inout) :: itmp(:)

integer  :: N, i, M, M2, lf, rt, id(1)

N     =  size(y)
pk    = .false.
pktmp = .false.
pktmp(2:N-1) = y(2:N-1) > y(1:N-2) .and. y(2:N-1) > y(3:N) &
               .and. y(2:N-1) > thresh

pktmp(1:Boff)      = .false.
pktmp(N-Boff+1:N)  = .false.  ! preventing peaks near the boundaries

M     = count(pktmp)
itmp  = pack( (/(i, i=1,N) /), pktmp )  ! idx to peaks

do i = 1, M
  lf = max(1, itmp(i)-L2)
  rt = min(N, itmp(i)+L2)
  id = maxloc(y(lf:rt), pktmp(lf:rt))
  if (id(1) == itmp(i)-lf+1)  pk(itmp(i)) = .true.
end do

end subroutine
!-------------

subroutine envelop_mx(y, pk, itmp, GauSig2)
! y   N x 1,  waveform, in-place form an envelop over the peaks of y
! pk  N x 1,  logical, marking the peaks of y
! GauSig2 1 x 1   real,  Gaussian's sigma^2.  The Gaussian is the yenv outside the itmp range
!     if GauSig2 <= 0, then outside is unmodified (0 most likely)
!     if ~present, then outside is constant
real,    intent(inout) :: y(:)
logical, intent(in)    :: pk(:)
integer, intent(inout) :: itmp(:)
real,    intent(in), optional :: GauSig2

integer  :: N, i, M, dx, x1, x2
real     :: y1, y2

integer, save :: callcounter = 0

N     =  size(y)
itmp  =  pack( (/ (i, i=1,N) /), pk )  ! idx to peaks
M     =  count(pk)

if (callcounter==0) then
   call write_binfile('y--0.bin', y)  !!!!!!!!!
else if (callcounter==1) then
   call write_binfile('y--1.bin', y)  !!!!!!!!!
end if

if (present(GauSig2))  then
   if (GauSig2 > 0) then
      y(1:itmp(1)) = y(itmp(1))*exp( (/ (i, i=1-itmp(1),0) /)**2 /(-2.*GauSig2) )
      y(itmp(M):N) = y(itmp(M))*exp( (/ (i, i=0,N-itmp(M)) /)**2 /(-2.*GauSig2) )
   end if  ! otherwise don't modify
else
   y(1:itmp(1)) = y(itmp(1))
   y(itmp(M):N) = y(itmp(M))
end if

do i = 1, M-1
   x1 = itmp(i)
   x2 = itmp(i+1)
   dx = x2 - x1
   y1 = y(x1)
   y2 = y(x2)
   y(x1:x2) = y2 + (y1-y2)/2. * (1.+ &
     cos( (/ (N, N=0, x2-x1) /)/(real(dx)/PI) ) )
end do

if (callcounter==0) then
   call write_binfile('yenv0.bin', y)  !!!!!!!!!
else if (callcounter==1) then
   call write_binfile('yenv1.bin', y)  !!!!!!!!!
end if
callcounter = callcounter + 1

end subroutine
!-------------

subroutine corr_focusing1D(J, g, u,upks,V,Vwids, d,W0,W1,Wsig2, alph, lag12,&
                unrm,gchnk,   dtprd,fdtp, gdtp, simi,simF, dnrm, dtmp, &
                itmp,pk,pktmp,Vtmp, tmpD1,tmpD2)
! J = \Sum_k { \int W f(Xcorr^k, alph) / \int f(Xcorr^k, alph) }
!          k: peak index in u
!          Xcorr^k  corr(d, u^k), where d: data trace; u^k: kth u's chunk
!
! g:  grad J / u,   N x 1
!                     f(., alpha, MODE)   squashing-negativ nonlinearity
!
! u    N x 1    predicted trace
! upks Npk x 1  peak locations in u
!               around each peak [-M/2, M/2] is a u's chunk
!      NOTE: u's peaks should be M/2 away from the trace beg & end!
!
! V    M x 1    the narrow weight profile for a /u chunk/
! Vwids Nvwids x 1  rect wids, keep convolving => the B-spline V
!
! d    N x 1    data trace
! W0   lag(2)-lag(1)+1 x 1   Gaussian weigtht profile over xcorr lags
! W1   ditto                 specific weights
!
! Wsig2 1x 1   for overall weight profile (e.g., Gaussian, B-spline) over Xcorr shifts,
!              encouraging xcorr mass @ 0.
! lag12  2 x 1  the Xcorr is limied to this range of *relative* lags (relative means,
!     assuming u chunk's center @ t=0, where does it shift around on d's trace?)

! MODE: norm. dot-prod followed by a nega-squashing nonlinearity of mode
! 0:   [e(a x)
! 1:   [e(a x), x-b]
! 2:   [e(a x), c(x-b)^2+d], then \int w/ weight

real,   intent(out)  :: J,    g(:)
real,   intent(in)   :: u(:), d(:), V(:),    W0(:),   Wsig2, alph
integer,intent(in)   :: upks(:),  Vwids(:),  lag12(2)
real   ,intent(inout):: unrm(:),  gchnk(:),  W1(:),   dtprd(:,:), &
                        fdtp(:,:),gdtp(:,:),             & ! all pre-allocated memory
                        simi(:,:),simF(:,:), dnrm(:), dtmp(:), Vtmp(:)
! unrm:    u chunks' norm (Npk #)
! gchnk:   g_chunk  M x 1
! dtprd:   normlz. dot-prod (d, u_chunks)  diff(lag12)+1 x Npk
! fdtp, gdtp: funct & grad of passing dtprd through a nega-squashing nonlinearity
!       same size as dtprd
! simi: init. similarity weights, between d's elements and u's chunks, N x Npk
! simF: Final ... (after double-normalizing)
!       From simF/simi, we know the gain weights.
! dnrm: d's local sliding-window's norm, N x 1
! dtmp: N x 1
! Vtmp: length(M), temp for a u chunk

real(8),intent(inout) :: tmpD1(:), tmpD2(:)  ! for Bspline V (*) ..., length(M)
integer,intent(inout) :: itmp(:) ! peak indices
logical,intent(inout) :: pk(:), pktmp(:)

integer ::  N, Npk, i, k, M, M2, lf,rt, da,db,Va,Vb, lg1,lg2,  dh,dt,Wh,Wt
            ! da,db,Va,Vb represent beg & end indices on d and V  (after intersection)
            ! dh,dt,Wh,Wt  ...      beg & end indices on d and W  (after intersection)

real    ::  Jk, E, eps, thresh

! dtprd & simi: d-trace & u chunk

N     =  size(d)
M     =  size(V);   M2 = M/2
Npk   =  size(upks)

! compute d_nrm:
dnrm  = d*d
call Bspline_conv(dnrm, Vwids, tmpD1, tmpD2)
dnrm  = sqrt(dnrm)  ! local d_norm
! call write_binfile('dnrm.bin',dnrm)  !!!!!!!!
! compute u_nrm:

eps  = 1.e-4
simi = 0.
simF = 0.
dtprd= 0.

do k = 1, Npk
  lf = upks(k)-M2           ! may outside [1,N]
  rt = upks(k)+M2
  call index_intersec(Va,Vb, da,db, lf, rt,  1,N)

  lg1= lag12(1) + upks(k)   ! may outside [1,N]
  lg2= lag12(2) + upks(k)
  call index_intersec(Wh,Wt, dh,dt, lg1,lg2, 1,N)

  Vtmp    = 0.
  Vtmp(Va:Vb) = V(Va:Vb)  * u(da : db)               ! weighted u chunk
  unrm(k)     = sqrt(sum(Vtmp(Va:Vb) * u(da : db) )) ! chunk norm, weighted
  call corr_cent(dtprd(Wh:Wt,k), d, Vtmp, (/dh, dt /) )
!  dtprd(Wh:Wt,k) = dtprd(Wh:Wt,k)/(unrm(k)+eps)/(dnrm(dh:dt) + eps)

  call squashNega(fdtp(Wh:Wt,k),gdtp(Wh:Wt,k), dtprd(Wh:Wt,k), alph, 2) ! MODE 2
  simi(dh:dt,k) = fdtp(Wh:Wt,k)
end do

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

#if 0

  call write_binfile('dtprd.bin',dtprd)  !!!!!!!!!
  call write_binfile('fdtp.bin', fdtp)  !!!!!!!!!
  call write_binfile('simi0.bin', simi)  !!!!!!!!!

! threshold of peaks
thresh = 0.2*minval(maxval(simi, 1))

lf = 0.5*M2  ! a temp int
do k = 1, Npk
  call localMx(pk, simi(:,k), lf, max(M2,maxval(abs(lag12))), thresh, pktmp, itmp)
  call envelop_mx( simi(:,k), pk, itmp, real(lag12(1)**2) )  ! should prod Gaussian 1st, then mark peaks

  simi(:,k) = simi(:,k) * exp( (/ (i-upks(k), i=1,N) /)**2 /(-2.*Wsig2) )
end do  ! init similarity envelope

call write_binfile('simi.bin',simi)  !!!!!!!!!

simF = simi
! compute simi as attribution weight
dtmp = sum(simF, 2) + eps
do k = 1, Npk
   simF(:,k) = simF(:,k) / dtmp  ! 1) normalize over u_chunks
end do
call write_binfile('simF1.bin',simF)  !!!!!!!!!

do k = 1, Npk
   simF(:,k) = simF(:,k) / (sum(simF(:,k))+eps)  ! 2) normalize over t
end do
call write_binfile('simF2.bin',simF)  !!!!!!!!!

dtmp = sum(simF, 2) + eps
do k = 1, Npk
   simF(:,k) = simF(:,k) / dtmp  ! 3) normalize over u_chunks
end do
  call write_binfile('simF3.bin',simF)  !!!!!!!!!

#endif

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

J    = 0.
g    = 0.
do k = 1, Npk
   lf= upks(k)-M2
   rt= upks(k)+M2
   call index_intersec(Va,Vb, da,db, lf, rt, 1,N)

  lg1= lag12(1) + upks(k)
  lg2= lag12(2) + upks(k)
  call index_intersec(Wh,Wt, dh,dt, lg1,lg2, 1,N)

   W1 = W0  !* simF(lg1:lg2,k)/(simi(lg1:lg2,k) + eps)

   E = sum(fdtp(Wh:Wt,k)) + eps
   Jk= sum(W1(Wh:Wt) * fdtp(Wh:Wt,k)) / E

   gchnk = 0.

!   call corr_cent(gchnk,d,(W1(Wh:Wt)-Jk)*gdtp(Wh:Wt,k)/(dnrm(dh:dt)+eps),dh+(/-M2,M2/),1)
!   gchnk(Va:Vb) = gchnk(Va:Vb) -sum((W1(Wh:Wt)-Jk)*gdtp(Wh:Wt,k)*dtprd(Wh:Wt,k))/(unrm(k)+eps) *u(da:db)
!   gchnk(Va:Vb) = gchnk(Va:Vb) * V(Va:Vb) / ((unrm(k)+eps) * E)

   call corr_cent(gchnk,d,(W1(Wh:Wt)-Jk)*gdtp(Wh:Wt,k), dh+(/-M2,M2/), 1)
   gchnk(Va:Vb) = gchnk(Va:Vb) * V(Va:Vb) / E

   g(da:db) = g(da:db) + gchnk(Va:Vb)

   J     = J + Jk
end do
! call write_binfile('grd.bin', g)  !!!!!!!!!

end subroutine
!-------------

subroutine corr_focusing_Adj_Src(AdjS1, misF,  datP1, datO1, f0, dt, Terr_max)
! Output:
! AdjS   nt x ng   adjoint source, or the negative-gradient direction to minimize the misfit
! misF   scalar    criterion function (of negative value)
!
! Input:
! datP   nt x ng   predicted data
! datO   nt x ng   observed data
! f0               peak freq. (Hz)
! dt               delta t (s)
! Terr_max         max time error (s)

real,  intent(out) :: AdjS1(:,:),  misF
real,  intent(in)  :: datP1(:,:), datO1(:,:), f0, dt, Terr_max
!--------------------

real               :: J,  alph, Wsig2, thresh, stdV
integer            :: Vwids(4), lag12(2)
real,   allocatable:: V(:),  unrm(:), gchnk(:), dtprd(:,:),&
                      fdtp(:,:),gdtp(:,:),   W0(:), W1(:),        &
                      simi(:,:),simF(:,:),   dnrm(:),  dtmp(:), Vtmp(:),  &
                      datP(:,:),datO(:,:), AdjS(:,:)
integer,allocatable:: upks(:),  itmp(:)
real(8),allocatable:: tmpD1(:), tmpD2(:)
logical,allocatable:: pk(:),    pktmp(:)

integer :: nt1, nt, ng, ig, i, M2, M, L2, L, Npk, Npkmx

nt1   = size(datP1,1)
ng    = size(datP1,2)
nt   = 3*nt1

allocate( datP(nt,ng), datO(nt,ng), AdjS(nt,ng) )
do i = 1, nt1
   datP(i+nt1,:)   = datP1(i,:);    datO(i+nt1,:) = datO1(i,:)
   datP(i,:) = datP1(nt1+1-i,:);    datO(i,:) = datO1(nt1+1-i,:)  ! mirror reflec
   datP(i+2*nt1,:) = datP(i,:);     datO(i+2*nt1,:) = datO(i,:)
end do

L2    = NINT(Terr_max/dt);  L = 2*L2+1  ! Xcorr lag range:
lag12 = (/ -L2, L2 /)

M     = NINT(2/f0/dt);      M2 = M/2;   M = 2*M2+1  ! wavelet chunk length ~ 2 T, odd
call Bspline_wids(Vwids, M)
call make_imp_resp_Bspline(V, Vwids)
M     = size(V);              M2 = M/2
!stdV  = sqrt( ( sum(Vwids**2)-size(Vwids) )/12. )
stdV  = 0.5/f0/dt  ! spacing, half period
Npk   = NINT((Nt1-2*M2)/(stdV)) + 1

allocate(upks(Npk), W0(L), W1(L))

do i = 1,Npk
  upks(i) = Nt1+ 1+M2 + NINT( (i-1)*(1.5 *stdV) )
end do

Wsig2 = (L2*2)**2        ! var for W weight profile over Xcorr shifts
W0    = exp( (/ (i, i= -L2, L2) /)**2 /(-2.*Wsig2) )

! write(*,*) 'M, Vwids', M, Vwids; call flush(6)
! call write_binfile('V.bin', V)   !!!!!!!!!!!!!

alph  = 8.
Npkmx = nt1/2 ! # local maxima

allocate(pk(Nt),    pktmp(Nt), itmp(Npkmx),  &
         gchnk(M),  dnrm(Nt),  &
         dtmp(Nt),  Vtmp(M),   tmpD1(Nt), tmpD2(Nt), &
         unrm(Npk),   dtprd(L,Npk), &
         fdtp(L,Npk), gdtp(L,Npk),  &
         simi(Nt,Npk),simF(Nt,Npk)  )

misF = 0.
AdjS = 0.
do ig = 1, ng
    call corr_focusing1D(J, AdjS(:,ig), datP(:,ig),upks,V,Vwids, datO(:,ig), &
                        W0, W1, Wsig2,  alph, lag12, &
                        unrm,gchnk,   dtprd,fdtp, gdtp, simi,simF,dnrm,dtmp, &
                        itmp,pk,pktmp,Vtmp, tmpD1,tmpD2)
    misF = misF -J
end do
Adjs1 = AdjS(nt1+1: 2*nt1,:)

deallocate(pk,     pktmp, itmp, &
          gchnk,   W0,W1, dnrm, &
          dtmp,    V,Vtmp,tmpD1, tmpD2, &
          upks,    &
          unrm, dtprd,  &
          fdtp, gdtp,   &
          simi, simF    )

deallocate(datP, datO, Adjs)

end subroutine
!-------------

END MODULE


submodule(euler_interface_m) euler_prob_0020_m
    implicit none

contains

    module character(len=20) function euler0020()
        write (euler0020, "(i20)") ans(100)
    end function euler0020

    integer function ans(n)
        integer, intent(in) :: n
        integer, allocatable :: iarr(:)
        integer :: l, i, j
        real(sp) :: lr

        lr = 0._sp
        do i = 1, n
            lr = lr + log10(real(i, sp))
        end do
        l = floor(lr + 1.)

        allocate (iarr(l))
        iarr = 0
        iarr(l) = 1

        do i = 1, n
            iarr = iarr*i

            do j = l, 2, -1
                iarr(j - 1) = iarr(j - 1) + iarr(j)/10
                iarr(j) = mod(iarr(j), 10)
            end do
        end do
        ans = sum(iarr, dim=1)
    end function ans

end submodule euler_prob_0020_m


! .................................................................................................
!   +       t *
! LL = 1 + Z Z
!
! the Cholesky decomposition or Cholesky factorization is a decomposition of a Hermitian,
! positive-definite matrix into the product of a lower triangular matrix and its conjugate transpose
! .................................................................................................
	SUBROUTINE Lmatrix(Z,GLOB_LOC,NDIM)
	USE VAPHFB_PAR
	implicit real*8 (a-h,o-z)

	DIMENSION Z(NDIM,NDIM)
	DIMENSION GLOB_LOC(NDIM,NDIM)
	DIMENSION AUX1(NDIM,NDIM)
	DIMENSION AUX2(NDIM,NDIM)
	DIMENSION AUX3(NDIM+1,NDIM)

	call DGEMM ('t','n',NDIM,NDIM,NDIM,one,             &
     &	Z,NDIM,Z,NDIM,zero,AUX1,NDIM)

     	do ii=1,NDIM
	  do jj=ii,NDIM
	    if (ii.ne.jj) then
	    AUX2(ii,jj)=AUX1(ii,jj)
	    AUX2(jj,ii)=AUX2(ii,jj)
	    else if (ii.eq.jj) then
	    AUX2(ii,jj)=AUX1(ii,jj)+1.d0
	    AUX2(jj,ii)=AUX2(ii,jj)
	    end if
	  end do
	end do

	call cholesky_format1(AUX2,AUX3,NDIM)

	call DPBTRF( 'L', NDIM, NDIM,AUX3,NDIM+1, INFO )
	if (info.ne.0) then
	 print*,'Cholesky fails.'
	 print*,'Try another seed or lower eta1,eta2'
	 stop
	end if

	call cholesky_format2(AUX3,GLOB_LOC,NDIM)
1000	format(1000F10.4)
	END SUBROUTINE Lmatrix

	SUBROUTINE cholesky_format1(A,AB,NDIM)

	implicit real*8 (a-h,o-z)
	DIMENSION A(NDIM,NDIM)
	DIMENSION AB(NDIM+1,NDIM)

        do ii=1,NDIM
	  do jj=1,NDIM
	    kk=1+ii-jj
	    if(jj.le.ii) then
	      AB(kk,jj)=A(ii,jj)
	    end if
	  end do
        end do

	END SUBROUTINE

	SUBROUTINE cholesky_format2(AB,A,NDIM)

	implicit real*8 (a-h,o-z)

	PARAMETER (one=1.d0)
	PARAMETER (zero=0.d0)
	DIMENSION A(NDIM,NDIM)
	DIMENSION AB(NDIM+1,NDIM)

	 do ii=1,NDIM
	   do jj=1,NDIM
	     A(jj,ii)=zero
	   end do
	 end do

        do ii=1,NDIM
	  do jj=1,NDIM+1-ii

	   ll = (ii-1)+jj
	   mm = jj

	   A(ll,mm)=AB(ii,jj)

	  end do

        end do

	END SUBROUTINE

	SUBROUTINE Lmatrix_VAP(Z,GLOB_LOC,NDIM)
        USE VAPHFB_PAR
	implicit real*8 (a-h,o-z)

	COMPLEX*16 IM,Izero,Ione
	PARAMETER (IM=(0.d0,1.d0))
	PARAMETER (Izero=(0.d0,0.d0))
	PARAMETER (Ione=(1.d0,0.d0))

	COMPLEX*16 Z(NDIM,NDIM)
	COMPLEX*16 GLOB_LOC(NDIM,NDIM)
	COMPLEX*16 AUX1(NDIM,NDIM)
	COMPLEX*16 AUX2(NDIM,NDIM)
	COMPLEX*16 AUX3(NDIM+1,NDIM)

	call ZGEMM ('c','n',NDIM,NDIM,NDIM,Ione,   &
     &	Z,NDIM,Z,NDIM,Izero,AUX1,NDIM)

     	do ii=1,NDIM
	  do jj=1,NDIM
	    if (ii.ne.jj) then
	    AUX2(jj,ii)=dreal(AUX1(jj,ii))-IM*dimag(AUX1(jj,ii))
	    else if (ii.eq.jj) then
	    AUX2(jj,ii)=dreal(AUX1(jj,ii))-IM*dimag(AUX1(jj,ii))+ one
	    end if
	  end do
	end do
	call cholesky_format1_VAP(AUX2,AUX3,NDIM)

	call ZPBTRF( 'L', NDIM, NDIM,AUX3,NDIM+1, INFO )
	if (info.ne.0) then
	 print*,'Cholesky fails.'
	 print*,'Try another seed or lower eta1,eta2'
	 stop
	end if

	call cholesky_format2_VAP(AUX3,GLOB_LOC,NDIM)
1000	format(1000F10.4)
	END SUBROUTINE

	SUBROUTINE cholesky_format1_VAP(A,AB,NDIM)

	implicit real*8 (a-h,o-z)
	COMPLEX*16 A(NDIM,NDIM)
	COMPLEX*16 AB(NDIM+1,NDIM)

        do ii=1,NDIM
	  do jj=1,NDIM
	    kk=1+ii-jj
	    if(jj.le.ii) then
	      AB(kk,jj)=A(ii,jj)
	    end if
	  end do
        end do

	END SUBROUTINE

	SUBROUTINE cholesky_format2_VAP(AB,A,NDIM)

	implicit real*8 (a-h,o-z)
	COMPLEX*16 Izero
	PARAMETER (Izero=(0.d0,0.d0))
	COMPLEX*16 A(NDIM,NDIM)
	COMPLEX*16 AB(NDIM+1,NDIM)

	 do ii=1,NDIM
	   do jj=ii,NDIM
	     A(ii,jj)=Izero
	     A(jj,ii)=Izero
	   end do
	 end do

        do ii=1,NDIM
	  do jj=1,NDIM+1-ii

	   ll = (ii-1)+jj
	   mm = jj

	   A(ll,mm)=AB(ii,jj)

	  end do

        end do

	END SUBROUTINE


*dk volume_hex
      subroutine volume_hex(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
     *                      x5,y5,z5,x6,y6,z6,x7,y7,z7,x8,y8,z8,
     *                      volhex)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A HEX-ELEMENT DEFINDED BY
C            8 COORDINATE NODES. THE VOLUME OF THE HEX IS DETERMINED
C            BY SUBDIVIDING IT INTO 24 TETRAHEDRAL ELEMENTS AND THEN
C            SUMMING THE VOLUME OF THE TETRAHEDRA.
C
C            THIS VERSION USES THE MIDPOINTS
C            see volume_hex_alt_lg below for version using "min-area-points"
C
C
C     ******************************************************************
C
C     DEFINE THE STRUCTURE OF A GENERIC HEXRAHEDRON.
C
C
C          8$ * * * * * * $7             Face 1: 1 2 3 4  (bottom)
C           * *           - *                 2: 5 8 7 6  (top)
C           *   *         -   *               3: 1 5 6 2  (front)
C           *     *       -     *             4: 2 6 7 3  (back)
C           *       *     -       *           5: 3 7 8 4  (right)
C           *        5$ * * * * * * $6        6: 1 4 8 5  (left)
C           *         *   -         *
C          4$ - - - - - - $3        *    Edge 1: 1 2
C             *       *     -       *            2 3
C               *     *       -     *            3 4
C                 *   *         -   *            4 1
C                   * *           - *            5 6
C                    1$ * * * * * * $2           6 7
C                                                7 8
C                                                8 5
C                                                1 5
C                                                2 6
C                                                3 7
C                                                4 8
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x8,y8,z8) - THE COORDINATES OF THE HEX WHERE
C                                    1,2,3,4 FORM THE BOTTOM FACE AND
C                                    5,6,7,8 FORM THE TOP FACE.
C
C     OUTPUT ARGUMENTS -
C
C        volhex - THE VOLUME OF THE HEX.
C
C     CHANGE HISTORY -
C
C        $Log: volume_hex.f,v $
C        Revision 2.00  2007/11/09 20:04:05  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.5   Tue Oct 19 13:18:02 1999   jtg
CPVCS    alternate way of calculating volume using "minimum area
CPVCS    point" (instead of midpoint) for each faces added.
CPVCS
CPVCS       Rev 1.4   Mon Apr 14 17:05:36 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.3   Thu Nov 21 19:07:46 1996   het
CPVCS    Correct an error in the calculation of the first tet of the hex.
CPVCS
CPVCS       Rev 1.2   Mon Nov 11 20:56:14 1996   het
CPVCS    Remove the absolute value for volume.
CPVCS
CPVCS       Rev 1.1   08/15/95 18:29:36   het
CPVCS    Modify some comment lines
C
C
C#######################################################################
C
      implicit real*8 (a-h,o-z)
C
C#######################################################################
C
C
C     ..................................................................
C     FIND THE MEDIAN POINT FOR EACH OF THE SIX FACES AND THE HEX.
C
      x1432=0.25d+00*(x1+x4+x3+x2)
      y1432=0.25d+00*(y1+y4+y3+y2)
      z1432=0.25d+00*(z1+z4+z3+z2)
      x5678=0.25d+00*(x5+x6+x7+x8)
      y5678=0.25d+00*(y5+y6+y7+y8)
      z5678=0.25d+00*(z5+z6+z7+z8)
      x2376=0.25d+00*(x2+x3+x7+x6)
      y2376=0.25d+00*(y2+y3+y7+y6)
      z2376=0.25d+00*(z2+z3+z7+z6)
      x1584=0.25d+00*(x1+x5+x8+x4)
      y1584=0.25d+00*(y1+y5+y8+y4)
      z1584=0.25d+00*(z1+z5+z8+z4)
      x1265=0.25d+00*(x1+x2+x6+x5)
      y1265=0.25d+00*(y1+y2+y6+y5)
      z1265=0.25d+00*(z1+z2+z6+z5)
      x4873=0.25d+00*(x4+x8+x7+x3)
      y4873=0.25d+00*(y4+y8+y7+y3)
      z4873=0.25d+00*(z4+z8+z7+z3)
      x12345678=(x1+x2+x3+x4+x5+x6+x7+x8)/8.0d+00
      y12345678=(y1+y2+y3+y4+y5+y6+y7+y8)/8.0d+00
      z12345678=(z1+z2+z3+z4+z5+z6+z7+z8)/8.0d+00
C
C
C     ..................................................................
C     FIND THE VOLUME OF THE 24-TET HEX.
C
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x1,y1,z1,
     *            x4,y4,z4,
     *            voltet11)
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x4,y4,z4,
     *            x3,y3,z3,
     *            voltet12)
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x3,y3,z3,
     *            x2,y2,z2,
     *            voltet13)
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x2,y2,z2,
     *            x1,y1,z1,
     *            voltet14)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x5,y5,z5,
     *            x6,y6,z6,
     *            voltet21)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x6,y6,z6,
     *            x7,y7,z7,
     *            voltet22)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x7,y7,z7,
     *            x8,y8,z8,
     *            voltet23)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x8,y8,z8,
     *            x5,y5,z5,
     *            voltet24)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x2,y2,z2,
     *            x3,y3,z3,
     *            voltet31)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x3,y3,z3,
     *            x7,y7,z7,
     *            voltet32)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x7,y7,z7,
     *            x6,y6,z6,
     *            voltet33)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x6,y6,z6,
     *            x2,y2,z2,
     *            voltet34)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x1,y1,z1,
     *            x5,y5,z5,
     *            voltet41)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x5,y5,z5,
     *            x8,y8,z8,
     *            voltet42)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x8,y8,z8,
     *            x4,y4,z4,
     *            voltet43)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x4,y4,z4,
     *            x1,y1,z1,
     *            voltet44)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x1,y1,z1,
     *            x2,y2,z2,
     *            voltet51)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x2,y2,z2,
     *            x6,y6,z6,
     *            voltet52)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x6,y6,z6,
     *            x5,y5,z5,
     *            voltet53)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x5,y5,z5,
     *            x1,y1,z1,
     *            voltet54)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x4,y4,z4,
     *            x8,y8,z8,
     *            voltet61)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x8,y8,z8,
     *            x7,y7,z7,
     *            voltet62)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x7,y7,z7,
     *            x3,y3,z3,
     *            voltet63)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x3,y3,z3,
     *            x4,y4,z4,
     *            voltet64)
C
C
C     ..................................................................
C     SUM THE 24 TET VOLUMES TO THE VOLUME OF THE HEX.
C
      volhex=-voltet11-voltet12-voltet13-voltet14-
     *        voltet21-voltet22-voltet23-voltet24-
     *        voltet31-voltet32-voltet33-voltet34-
     *        voltet41-voltet42-voltet43-voltet44-
     *        voltet51-voltet52-voltet53-voltet54-
     *        voltet61-voltet62-voltet63-voltet64
C
      return
      end
C#######################################################################
C=======================================================================
C#######################################################################
*dk volume_hex
      subroutine volume_hex_alt_lg(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
     *                      x5,y5,z5,x6,y6,z6,x7,y7,z7,x8,y8,z8,
     *                      volhex)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A HEX-ELEMENT DEFINDED BY
C            8 COORDINATE NODES. THE VOLUME OF THE HEX IS DETERMINED
C            BY SUBDIVIDING IT INTO 24 TETRAHEDRAL ELEMENTS AND THEN
C            SUMMING THE VOLUME OF THE TETRAHEDRA.
C
C            THIS VERSION USES THE AREA-MINMIZING POINTS OF THE QUD FACES
C            see volume_hex above for version using midpoints, and conventions
C
C
C#######################################################################
C
      implicit real*8 (a-h,o-z)
C
C#######################################################################
C
C
C     ..................................................................
C     FIND THE AREA_MINIMIZING POINT FOR EACH OF THE SIX FACES AND THE HEX.
C
      call volume_qud_alt_lg(x1,y1,z1, x4,y4,z4, x3,y3,z3, x2,y2,z2,
     *                       vvv, x1432,y1432,z1432 )
      call volume_qud_alt_lg(x5,y5,z5, x6,y6,z6, x7,y7,z7, x8,y8,z8,
     *                       vvv, x5678,y5678,z5678 )
      call volume_qud_alt_lg(x2,y2,z2, x3,y3,z3, x7,y7,z7, x6,y6,z6,
     *                       vvv, x2376,y2376,z2376 )
      call volume_qud_alt_lg(x1,y1,z1, x5,y5,z5, x8,y8,z8, x4,y4,z4,
     *                       vvv, x1584,y1584,z1584 )
      call volume_qud_alt_lg(x1,y1,z1, x2,y2,z2, x6,y6,z6, x5,y5,z5,
     *                       vvv, x1265,y1265,z1265 )
      call volume_qud_alt_lg(x4,y4,z4, x8,y8,z8, x7,y7,z7, x3,y3,z3,
     *                       vvv, x4873,y4873,z4873 )

      ! OK to use midpoint for center, as +/- contributions should cancel...
      x12345678=(x1432+x5678+x2376+x1584+x1265+x4873)/6.0d+00
      y12345678=(y1432+y5678+y2376+y1584+y1265+y4873)/6.0d+00
      z12345678=(z1432+z5678+z2376+z1584+z1265+z4873)/6.0d+00

      ! if actually need volume-minimizing-point for breaking into tets:
      ! calculate as point which minimizes [ sum_{1=1,24} V(i)^2 ]
      ! where V(i) is the volume of the 24 sub-tets
      ! (similar to min-area-point calculation in volume_qud_alt_lg)
C
C     ..................................................................
C     FIND THE VOLUME OF THE 24-TET HEX (same as above).
C
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x1,y1,z1,
     *            x4,y4,z4,
     *            voltet11)
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x4,y4,z4,
     *            x3,y3,z3,
     *            voltet12)
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x3,y3,z3,
     *            x2,y2,z2,
     *            voltet13)
      call volume_tet(x1432,y1432,z1432,
     *            x12345678,y12345678,z12345678,
     *            x2,y2,z2,
     *            x1,y1,z1,
     *            voltet14)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x5,y5,z5,
     *            x6,y6,z6,
     *            voltet21)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x6,y6,z6,
     *            x7,y7,z7,
     *            voltet22)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x7,y7,z7,
     *            x8,y8,z8,
     *            voltet23)
      call volume_tet(x5678,y5678,z5678,
     *            x12345678,y12345678,z12345678,
     *            x8,y8,z8,
     *            x5,y5,z5,
     *            voltet24)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x2,y2,z2,
     *            x3,y3,z3,
     *            voltet31)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x3,y3,z3,
     *            x7,y7,z7,
     *            voltet32)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x7,y7,z7,
     *            x6,y6,z6,
     *            voltet33)
      call volume_tet(x2376,y2376,z2376,
     *            x12345678,y12345678,z12345678,
     *            x6,y6,z6,
     *            x2,y2,z2,
     *            voltet34)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x1,y1,z1,
     *            x5,y5,z5,
     *            voltet41)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x5,y5,z5,
     *            x8,y8,z8,
     *            voltet42)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x8,y8,z8,
     *            x4,y4,z4,
     *            voltet43)
      call volume_tet(x1584,y1584,z1584,
     *            x12345678,y12345678,z12345678,
     *            x4,y4,z4,
     *            x1,y1,z1,
     *            voltet44)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x1,y1,z1,
     *            x2,y2,z2,
     *            voltet51)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x2,y2,z2,
     *            x6,y6,z6,
     *            voltet52)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x6,y6,z6,
     *            x5,y5,z5,
     *            voltet53)
      call volume_tet(x1265,y1265,z1265,
     *            x12345678,y12345678,z12345678,
     *            x5,y5,z5,
     *            x1,y1,z1,
     *            voltet54)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x4,y4,z4,
     *            x8,y8,z8,
     *            voltet61)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x8,y8,z8,
     *            x7,y7,z7,
     *            voltet62)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x7,y7,z7,
     *            x3,y3,z3,
     *            voltet63)
      call volume_tet(x4873,y4873,z4873,
     *            x12345678,y12345678,z12345678,
     *            x3,y3,z3,
     *            x4,y4,z4,
     *            voltet64)
C
C
C     ..................................................................
C     SUM THE 24 TET VOLUMES TO THE VOLUME OF THE HEX.
C
      volhex=-voltet11-voltet12-voltet13-voltet14-
     *        voltet21-voltet22-voltet23-voltet24-
     *        voltet31-voltet32-voltet33-voltet34-
     *        voltet41-voltet42-voltet43-voltet44-
     *        voltet51-voltet52-voltet53-voltet54-
     *        voltet61-voltet62-voltet63-voltet64
C
      return
      end


module WGFM_SauterSchwabData
use tools
implicit none

private
public:: SSDataType, init_ssdata, get_ss_identical_params,  &
         get_ss_edge_params, get_ss_vertex_params

! Constants
integer,parameter:: NINTEGRALS_IDENTICAL = 6   ! number of integrals, identical case
integer,parameter:: NINTEGRALS_EDGE = 5        ! number of integrals, edge case
integer,parameter:: NINTEGRALS_VERTEX = 2      ! number of integrals, vertex case

type SSDataArrays
    ! qweights for each qpoint [n1, n2, n3, i] (jacobian included)
    real(8),allocatable:: qweights(:,:,:,:)       ! qweight = qweights(i, n3, n2, n1)
    ! variables [uO, vO, uI, vI] for each qpoint `[n1, n2, n3, i]` and integral `l`
    real(8),allocatable:: variables(:,:,:,:,:,:)  ! [uO, vO, uI, vI] = variables(:, l, i, n3, n2, n1)
end type

! Data structure that contains the Sauter-Schwab quadrature data.
! The quadrature points are indexed by 4 integers `[n1, n2, n3, i]`
! with each integer belonging to {1,2,...,nQ}. They individually
! represent qpoints in the hypercube coordinates (eta1, eta2, eta3, xi) \in [0,1]^4.
! For each case (identical, common edge, common vertex) there are (6, 5, 2)
! integrals to compute, respectively. Each integral is indexed by the integer `l`
! in {1,2,...,lMax}, with `lMax` depending on the case.
type SSDataType
    integer:: nQ            ! number of quadrature points in 1D
    integer:: n_identical   ! number of integrals, identical case (6 integrals)
    integer:: n_edge        ! number of integrals, edge case  (5 integrals)
    integer:: n_vertex      ! number of integrals, vertex case  (2 integrals)
    type(SSDataArrays):: identical_data    ! quadrature data for the identical case
    type(SSDataArrays):: edge_data         ! quadrature data for the edge case
    type(SSDataArrays):: vertex_data       ! quadrature data for the vertex case
end type

contains
! ********************* Public procedures ************************************************************
! Initializes `ssdata` by generating the quadrature points and weights.
subroutine init_ssdata(ssdata, nQ)
    type(SSDataType),intent(out):: ssdata
    integer,intent(in):: nQ    ! number of quadrature points in 1D
    real(8):: t(nQ), w(nQ)     ! hold 1D gaussian quadrature points and weights
    real(8):: eta1, eta2, eta3, xi  ! hypercube variables
    real(8):: gauss_qweight     ! holds the tensor gauss quadrature weight
    integer:: n1, n2, n3, i    ! loop indices

    ! save number of quad. points and number of integrals
    ssdata%nQ = nQ
    ssdata%n_identical = NINTEGRALS_IDENTICAL
    ssdata%n_edge = NINTEGRALS_EDGE
    ssdata%n_vertex = NINTEGRALS_VERTEX
    ! obtain quadrature data and scale to the interval [0, 1]
    call gaussQuadrature(t,w,nQ)
    w = 0.5d0*w
    t = 0.5d0*(1.0d0+t)
    ! allocate data
    call allocate_ssdata(ssdata)
    ! compute qnodes and qweights
    do n1 = 1,nQ ! eta1
        eta1 = t(n1)
        do n2 = 1,nQ !eta2
            eta2 = t(n2)
            do n3 = 1,nQ !eta3
                eta3 = t(n3)
                do i = 1,nQ ! xi
                    xi = t(i)
                    ! tensor gauss quadrature weight
                    gauss_qweight = w(n1)*w(n2)*w(n3)*w(i)
                    ! identical data
                    call store_ssdata_identical(ssdata%identical_data, gauss_qweight, eta1, eta2, eta3, xi, n1, n2, n3, i)
                    ! edge data
                    call store_ssdata_edge(ssdata%edge_data, gauss_qweight, eta1, eta2, eta3, xi, n1, n2, n3, i)
                    ! vertex data
                    call store_ssdata_vertex(ssdata%vertex_data, gauss_qweight, eta1, eta2, eta3, xi, n1, n2, n3, i)
                end do
            end do
        end do
    end do
end subroutine init_ssdata

! Gets the parametrization `(x,y)` and the quadrature weight `qweight` (jacobian included)
! for the qnode `[n1, n2, n3, i]`, integral `l` and the triangle with vertices `[p1, p2, p3]`,
! for the identical case.
pure subroutine get_ss_identical_params(ssdata, x, y, qweight, n1, n2, n3, i, l, p1, p2, p3)
    type(SSDataType),intent(in):: ssdata
    real(8),intent(out):: x(3), y(3)               ! points in triangle
    real(8),intent(out):: qweight                  ! quadrature weight and jacobian
    integer,intent(in):: n1, n2, n3, i, l          ! loop indices
    real(8),intent(in):: p1(3), p2(3), p3(3)       ! triangle  vertices
    call get_ss_params(ssdata%identical_data, x, y, n1, n2, n3, i, l, p1, p2, p3, p1, p2, p3)
    call get_ss_qweight(ssdata%identical_data, qweight, n1, n2, n3, i)
end subroutine get_ss_identical_params

! Gets the parametrization `(x,y)` and the quadrature weight `qweight`
! for the qnode `[n1, n2, n3, i]`, integral `l` and the triangles with vertices `[q1, q2, q3]`
! and `[p1, p2, p3]`, for the common edge case.
pure subroutine get_ss_edge_params(ssdata, x, y, qweight, n1, n2, n3, i, l, q1, q2, q3, p1, p2, p3)
    type(SSDataType),intent(in):: ssdata
    real(8),intent(out):: x(3), y(3)              ! points in triangle
    real(8),intent(out):: qweight                 ! quadrature weight and jacobian
    integer,intent(in):: n1, n2, n3, i, l         ! loop indices
    real(8),intent(in):: q1(3), q2(3), q3(3)      ! triangle 1 vertices
    real(8),intent(in):: p1(3), p2(3), p3(3)      ! triangle 2 vertices
    call get_ss_params(ssdata%edge_data, x, y, n1, n2, n3, i, l, q1, q2, q3, p1, p2, p3)
    if (l == 1) then
        call get_ss_qweight(ssdata%edge_data, qweight, n1, n2, n3, i)  ! for integral 1
    else
        call get_ss_qweight(ssdata%identical_data, qweight, n1, n2, n3, i)  ! for integral 2,3,4,5
    end if
end subroutine get_ss_edge_params

! Gets the parametrization `(x,y)` and the quadrature weight `qweight`
! for the qnode `[n1, n2, n3, i]`, integral `l` and the triangles with vertices `[q1, q2, q3]`
! and `[p1, p2, p3]`, for the common vertex case.
pure subroutine get_ss_vertex_params(ssdata, x, y, qweight, n1, n2, n3, i, l, q1, q2, q3, p1, p2, p3)
    type(SSDataType),intent(in):: ssdata
    real(8),intent(out):: x(3), y(3)               ! points in triangle
    real(8),intent(out):: qweight                  ! quadrature weight and jacobian
    integer,intent(in):: n1, n2, n3, i, l          ! loop indices
    real(8),intent(in):: q1(3), q2(3), q3(3)       ! triangle 1 vertices
    real(8),intent(in):: p1(3), p2(3), p3(3)       ! triangle 2 vertices
    call get_ss_params(ssdata%vertex_data, x, y, n1, n2, n3, i, l, q1, q2, q3, p1, p2, p3)
    call get_ss_qweight(ssdata%vertex_data, qweight, n1, n2, n3, i)
end subroutine get_ss_vertex_params

! ********************* Private procedures ************************************************************
! Gets the parametrization `(x,y)` for the qnode `[n1, n2, n3, i]`, integral `l`
! and the triangles with vertices `[q1, q2, q3]` and `[p1, p2, p3]`.
pure subroutine get_ss_params(ssdata_a, x, y, n1, n2, n3, i, l, q1, q2, q3, p1, p2, p3)
    type(SSDataArrays),intent(in):: ssdata_a
    real(8),intent(out):: x(3), y(3)           ! points in triangles 1 and 2
    integer,intent(in):: n1, n2, n3, i, l      ! loop indices
    real(8),intent(in):: q1(3), q2(3), q3(3)   ! triangle 1 vertices
    real(8),intent(in):: p1(3), p2(3), p3(3)   ! triangle 2 vertices
    real(8):: uO, vO, uI, vI                   ! hypercube variables
    ! get hypercube variables
    uO = ssdata_a%variables(1, l, i, n3, n2, n1)
    vO = ssdata_a%variables(2, l, i, n3, n2, n1)
    uI = ssdata_a%variables(3, l, i, n3, n2, n1)
    vI = ssdata_a%variables(4, l, i, n3, n2, n1)
    ! map variables to the triangles
    x = triangle_parametrization(uO, vO, q1, q2, q3)
    y = triangle_parametrization(uI, vI, p1, p2, p3)
end subroutine get_ss_params

! Gets the the quadrature weight `qweight` for the qnode `[n1, n2, n3, i]`.
pure subroutine get_ss_qweight(ssdata_a, qweight, n1, n2, n3, i)
    type(SSDataArrays),intent(in):: ssdata_a
    real(8),intent(out):: qweight              ! quadrature weight and jacobian
    integer,intent(in):: n1, n2, n3, i      ! loop indices
    ! get qweight and jacobian
    qweight = ssdata_a%qweights(i, n3, n2, n1)
end subroutine get_ss_qweight

! Maps (u,v) in the reference triangle to the 3D triangle with vertices
! `p1`, `p2` and `p3`.
pure function triangle_parametrization(u, v, p1, p2, p3) result(x)
    real(8),intent(in):: u, v                  ! parameters
    real(8),intent(in):: p1(3), p2(3), p3(3)   ! triangle vertices
    real(8):: x(3)
    x = p1 + u*(p2-p1) + v*(p3-p2)
end function triangle_parametrization

! Allocates the arrays for storing the quadrature data in `ssdata`.
subroutine allocate_ssdata(ssdata)
    type(SSDataType),intent(inout):: ssdata
    integer:: nQ    ! number of quadrature points in 1D

    nQ = ssdata%nQ
    ! allocate identical data
    allocate(ssdata%identical_data%qweights(nQ,nQ,nQ,nQ))
    allocate(ssdata%identical_data%variables(4,NINTEGRALS_IDENTICAL,nQ,nQ,nQ,nQ)) ! 4 variables, 6 integrals
    ! allocate edge data
    allocate(ssdata%edge_data%qweights(nQ,nQ,nQ,nQ))    ! for integral 1; integrals 2,3,4,5,6 use qweights from the identical case
    allocate(ssdata%edge_data%variables(4,NINTEGRALS_EDGE,nQ,nQ,nQ,nQ))  ! 4 variables, 5 integrals
    ! allocate vertex data
    allocate(ssdata%vertex_data%qweights(nQ,nQ,nQ,nQ))
    allocate(ssdata%vertex_data%variables(4,NINTEGRALS_VERTEX,nQ,nQ,nQ,nQ)) ! 4 variables, 2 integrals

end subroutine allocate_ssdata

! Computes the quadrature data for the identical case
subroutine store_ssdata_identical(ssdata_i, gauss_qweight, eta1, eta2, eta3, xi, n1, n2, n3, i)
    type(SSDataArrays),intent(inout):: ssdata_i
    real(8),intent(in):: gauss_qweight         ! tensor gauss quadrature weight
    real(8),intent(in):: eta1, eta2, eta3, xi  ! hypercube variables
    integer,intent(in):: n1, n2, n3, i         ! loop indices
    integer::l                                 ! loop index for different integrals
    real(8):: uO, vO, uI, vI                   ! hypercube variables
    real(8):: qweight                          ! quad. weigth and jacobian

    ! Integral 1
    l = 1
    uO = xi
    vO = xi*(1.0d0-eta1+eta1*eta2)
    uI = xi*(1.0d0-eta1*eta2*eta3)
    vI = xi*(1.0d0-eta1)
    ssdata_i%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 2
    l = 2
    uO = xi*(1.0d0-eta1*eta2*eta2)
    vO = xi*(1.0d0-eta1)
    uI = xi
    vI = xi*(1.0d0-eta1+eta1*eta2)
    ssdata_i%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 3
    l = 3
    uO = xi
    vO = xi*eta1*(1.0d0-eta2+eta2*eta3)
    uI = xi*(1.0d0-eta1*eta2)
    vI = xi*eta1*(1.0d0-eta2)
    ssdata_i%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 4
    l = 4
    uO = xi*(1.0d0-eta1*eta2)
    vO = xi*eta1*(1.0d0-eta2)
    uI = xi
    vI = xi*eta1*(1.0d0-eta2+eta2*eta3)
    ssdata_i%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 5
    l = 5
    uO = xi*(1.0d0-eta1*eta2*eta3)
    vO = xi*eta1*(1.0d0-eta2*eta3)
    uI = xi
    vI = xi*eta1*(1.0d0-eta2)
    ssdata_i%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 6
    l = 6
    uO = xi
    vO = xi*eta1*(1.0d0-eta2)
    uI = xi*(1.0d0-eta1*eta2*eta3)
    vI = xi*eta1*(1.0d0-eta2*eta3)
    ssdata_i%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Quadrature weight and jacobian
    qweight = xi**3*eta1**2*eta2*gauss_qweight
    ssdata_i%qweights(i, n3, n2, n1) = qweight
end subroutine store_ssdata_identical

! Computes the quadrature data for the common edge case
subroutine store_ssdata_edge(ssdata_e, gauss_qweight, eta1, eta2, eta3, xi, n1, n2, n3, i)
    type(SSDataArrays),intent(inout):: ssdata_e
    real(8),intent(in):: gauss_qweight         ! tensor gauss quadrature weight
    real(8),intent(in):: eta1, eta2, eta3, xi  ! hypercube variables
    integer,intent(in):: n1, n2, n3, i         ! loop indices
    integer::l                                 ! loop index for different integrals
    real(8):: uO, vO, uI, vI                   ! hypercube variables
    real(8):: qweight                          ! quad. weigth and jacobian

    ! Integral 1
    l = 1
    uO = xi
    vO = xi*eta1*eta3
    uI = xi*(1.0d0-eta1*eta2)
    vI = xi*eta1*(1.0d0-eta2)
    ssdata_e%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 2
    l = 2
    uO = xi
    vO = xi*eta1
    uI = xi*(1.0d0-eta1*eta2*eta3)
    vI = xi*eta1*eta2*(1.0d0-eta3)
    ssdata_e%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 3
    l = 3
    uO = xi*(1.0d0-eta1*eta2)
    vO = xi*eta1*(1.0d0-eta2)
    uI = xi
    vI = xi*eta1*eta2*eta3
    ssdata_e%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 4
    l = 4
    uO = xi*(1.0d0-eta1*eta2*eta3)
    vO = xi*eta1*eta2*(1.0d0-eta3)
    uI = xi
    vI = xi*eta1
    ssdata_e%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 5
    l = 5
    uO = xi*(1.0d0-eta1*eta2*eta3)
    vO = xi*eta1*(1.0d0-eta2*eta3)
    uI = xi
    vI = xi*eta1*eta2
    ssdata_e%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Quadrature weight and jacobian for integral 1
    qweight = xi**3*eta1**2*gauss_qweight
    ssdata_e%qweights(i, n3, n2, n1) = qweight
end subroutine store_ssdata_edge

! Computes the quadrature data for the common vertex case
subroutine store_ssdata_vertex(ssdata_v, gauss_qweight, eta1, eta2, eta3, xi, n1, n2, n3, i)
    type(SSDataArrays),intent(inout):: ssdata_v
    real(8),intent(in):: gauss_qweight         ! tensor gauss quadrature weight
    real(8),intent(in):: eta1, eta2, eta3, xi  ! hypercube variables
    integer,intent(in):: n1, n2, n3, i         ! loop indices
    integer::l                                 ! loop index for different integrals
    real(8):: uO, vO, uI, vI                   ! hypercube variables
    real(8):: qweight                          ! quad. weigth and jacobian

    ! Integral 1
    l = 1
    uO = xi
    vO = xi*eta1
    uI = xi*eta2
    vI = xi*eta2*eta3
    ssdata_v%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Integral 2
    l = 2
    uO = xi*eta2
    vO = xi*eta2*eta3
    uI = xi
    vI = xi*eta1
    ssdata_v%variables(:, l, i, n3, n2, n1) = [uO, vO, uI, vI]
    ! Quadrature weight and jacobian
    qweight = xi**3*eta2*gauss_qweight
    ssdata_v%qweights(i, n3, n2, n1) = qweight
end subroutine store_ssdata_vertex

end module WGFM_SauterSchwabData


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file shsgc.f
c
c     this file contains code and documentation for subroutines
c     shsgc and shsgci
c
c ... files which must be loaded with shsgc.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine shsgc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                 wshsgc,lshsgc,work,lwork,ierror)
c
c     subroutine shsgc performs the spherical harmonic synthesis
c     on the arrays a and b and stores the result in the array g.
c     the synthesis is performed on an equally spaced longitude grid
c     and a gaussian colatitude grid.  the associated legendre functions
c     are recomputed rather than stored as they are in subroutine
c     shsgs.  the synthesis is described below at output parameter
c     g.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the synthesis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the synthesis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls shsgc,
c            the arrays g,a and b can be three dimensional in which
c            case multiple synthesis will be performed.  the third
c            index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shsgc. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shsgc. jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shsgc. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shsgc. ndab must be at least nlat
c
c     a,b    two or three dimensional arrays (see the input parameter
c            nt) that contain the coefficients in the spherical harmonic
c            expansion of g(i,j) given below at the definition of the
c            output parameter g.  a(m,n) and b(m,n) are defined for
c            indices m=1,...,mmax and n=m,...,nlat where mmax is the
c            maximum (plus one) longitudinal wave number given by
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     wshsgc an array which must be initialized by subroutine shsgci.
c            once initialized, wshsgc can be used repeatedly by shsgc
c            as long as nlat and nlon remain unchanged.  wshsgc must
c            not be altered between calls of shsgc.
c
c     lshsgc the dimension of the array wshsgc as it appears in the
c            program that calls shsgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgc must be at least
c
c               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                      nlat*(nlon*nt+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                      l2*(nlon*nt+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     g      a two or three dimensional array (see input parameter nt)
c            that contains the discrete function which is synthesized.
c            g(i,j) contains the value of the function at the gaussian
c            colatitude point theta(i) and longitude point
c            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
c            above at the input parameter isym.  for isym=0, g(i,j)
c            is given by the the equations listed below.  symmetric
c            versions are used when isym is greater than zero.
c
c     the normalized associated legendre functions are given by
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c
c     define the maximum (plus one) longitudinal wave number
c     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then g(i,j) = the sum from n=0 to n=nlat-1 of
c
c                   .5*pbar(0,n,theta(i))*a(1,n+1)
c
c              plus the sum from m=1 to m=mmax-1 of
c
c                   the sum from n=m to n=nlat-1 of
c
c              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
c                                    -b(m+1,n+1)*sin(m*phi(j)))
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lwshig
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shsgci(nlat,nlon,wshsgc,lshsgc,dwork,ldwork,ierror)
c
c     subroutine shsgci initializes the array wshsgc which can then
c     be used repeatedly by subroutines shsgc. it precomputes
c     and stores in wshsgc quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshsgc an array which must be initialized by subroutine shsgci.
c            once initialized, wshsgc can be used repeatedly by shsgc
c            as long as nlat and nlon remain unchanged.  wshsgc must
c            not be altered between calls of shsgc.
c
c     lshsgc the dimension of the array wshsgc as it appears in the
c            program that calls shsgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c     dwork  a double precision work array that does not have to be saved.
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls shsgci. ldwork must be at least
c
c                 nlat*(nlat+4)
c
c     output parameter
c
c     wshsgc an array which must be initialized before calling shsgc.
c            once initialized, wshsgc can be used repeatedly by shsgc
c            as long as nlat and nlon remain unchanged.  wshsgc must not
c            altered between calls of shsgc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshsgc
c            = 4  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      subroutine shsgc(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab,
     1                    wshsgc,lshsgc,work,lwork,ierror)
c     subroutine shsgc performs the spherical harmonic synthesis on
c     a gaussian grid using the coefficients in array(s) a,b and returns
c     the results in array(s) g.  the legendre polynomials are computed
c     as needed in this version.
c
      dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),
     1          wshsgc(lshsgc),work(lwork)
c     check input parameters
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
      ierror = 3
      if (mode.lt.0 .or.mode.gt.2) return
      ierror = 4
      if (nt.lt.1) return
c     set limit for m iin a(m,n),b(m,n) computation
      l = min0((nlon+2)/2,nlat)
c     set gaussian point nearest equator pointer
      late = (nlat+mod(nlat,2))/2
c     set number of grid points for analysis/synthesis
      lat = nlat
      if (mode.ne.0) lat = late
      ierror = 5
      if (idg.lt.lat) return
      ierror = 6
      if (jdg.lt.nlon) return
      ierror = 7
      if(mdab .lt. l) return
      ierror = 8
      if(ndab .lt. nlat) return
      l1 = l
      l2 = late
      ierror = 9
c     check permanent work space length
      if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 10
c     check temporary work space length
      if (mode.eq.0) then
      if(lwork.lt.nlat*(nlon*nt+max0(3*l2,nlon)))return
      else
c     mode.ne.0
      if(lwork.lt.l2*(nlon*nt+max0(3*nlat,nlon))) return
      end if
      ierror = 0
c     starting address  fft values
      ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1
c     set pointers for internal storage of g and legendre polys
      ipmn = lat*nlon*nt+1
      call shsgc1(nlat,nlon,l,lat,mode,g,idg,jdg,nt,a,b,mdab,ndab,
     1wshsgc,wshsgc(ifft),late,work(ipmn),work)
      return
      end
      subroutine shsgc1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab,
     1                  ndab,w,wfft,late,pmn,g)
      dimension gs(idg,jdg,nt),a(mdab,ndab,nt),b(mdab,ndab,nt)
      dimension w(1),pmn(nlat,late,3),g(lat,nlon,nt),wfft(1)
c     reconstruct fourier coefficients in g on gaussian grid
c     using coefficients in a,b
c     set m+1 limit for b coefficient calculation
      lm1 = l
      if (nlon .eq. l+l-2) lm1 = l-1
c     initialize to zero
      do 100 k=1,nt
      do 100 j=1,nlon
      do 100 i=1,lat
      g(i,j,k) = 0.0
  100 continue
      if (mode.eq.0) then
c     set first column in g
      m = 0
c     compute pmn for all i and n=m,...,l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 101 k=1,nt
c     n even
      do 102 np1=1,nlat,2
      do 102 i=1,late
      g(i,1,k) = g(i,1,k)+a(1,np1,k)*pmn(np1,i,km)
  102 continue
c     n odd
      nl2 = nlat/2
      do 103 np1=2,nlat,2
      do 103 i=1,nl2
      is = nlat-i+1
      g(is,1,k) = g(is,1,k)+a(1,np1,k)*pmn(np1,i,km)
  103 continue
c     restore m=0 coefficents (reverse implicit even/odd reduction)
      do 112 i=1,nl2
      is = nlat-i+1
      t1 = g(i,1,k)
      t3 = g(is,1,k)
      g(i,1,k) = t1+t3
      g(is,1,k) = t1-t3
  112 continue
  101 continue
c     sweep  columns of g for which b is available
      do 104 mp1=2,lm1
      m = mp1-1
      mp2 = m+2
c     compute pmn for all i and n=m,...,l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 105 k=1,nt
c     for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,
c     for i=1,...,late
      do 106 np1=mp1,nlat,2
      do 107 i=1,late
      g(i,2*m,k) = g(i,2*m,k)+a(mp1,np1,k)*pmn(np1,i,km)
      g(i,2*m+1,k) = g(i,2*m+1,k)+b(mp1,np1,k)*pmn(np1,i,km)
  107 continue
  106 continue
c     for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k)
c     for i=1,...,nlat/2 (p=2*m,p=2*m+1)
      do 108 np1=mp2,nlat,2
      do 109 i=1,nl2
      is = nlat-i+1
      g(is,2*m,k) = g(is,2*m,k)+a(mp1,np1,k)*pmn(np1,i,km)
      g(is,2*m+1,k) = g(is,2*m+1,k)+b(mp1,np1,k)*pmn(np1,i,km)
  109 continue
  108 continue
c     now set fourier coefficients using even-odd reduction above
      do 110 i=1,nl2
      is = nlat-i+1
      t1 = g(i,2*m,k)
      t2 = g(i,2*m+1,k)
      t3 = g(is,2*m,k)
      t4 = g(is,2*m+1,k)
      g(i,2*m,k) = t1+t3
      g(i,2*m+1,k) = t2+t4
      g(is,2*m,k) = t1-t3
      g(is,2*m+1,k) = t2-t4
  110 continue
  105 continue
  104 continue
c     set last column (using a only)
      if (nlon.eq. l+l-2) then
      m = l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 111 k=1,nt
c     n-m even
      do 131 np1=l,nlat,2
      do 131 i=1,late
      g(i,nlon,k) = g(i,nlon,k)+2.0*a(l,np1,k)*pmn(np1,i,km)
  131 continue
      lp1 = l+1
c     n-m odd
      do 132 np1=lp1,nlat,2
      do 132 i=1,nl2
      is = nlat-i+1
      g(is,nlon,k) = g(is,nlon,k)+2.0*a(l,np1,k)*pmn(np1,i,km)
  132 continue
      do 133 i=1,nl2
      is = nlat-i+1
      t1 = g(i,nlon,k)
      t3 = g(is,nlon,k)
      g(i,nlon,k)= t1+t3
      g(is,nlon,k)= t1-t3
  133 continue
  111 continue
      end if
      else
c     half sphere (mode.ne.0)
c     set first column in g
      m = 0
      meo = 1
      if (mode.eq.1) meo = 2
      ms = m+meo
c     compute pmn for all i and n=m,...,l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 113 k=1,nt
      do 113 np1=ms,nlat,2
      do 113 i=1,late
      g(i,1,k) = g(i,1,k)+a(1,np1,k)*pmn(np1,i,km)
  113 continue
c     sweep interior columns of g
      do 114 mp1=2,lm1
      m = mp1-1
      ms = m+meo
c     compute pmn for all i and n=m,...,l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 115 k=1,nt
      do 115 np1=ms,nlat,2
      do 115 i=1,late
      g(i,2*m,k) = g(i,2*m,k)+a(mp1,np1,k)*pmn(np1,i,km)
      g(i,2*m+1,k) = g(i,2*m+1,k)+b(mp1,np1,k)*pmn(np1,i,km)
  115 continue
  114 continue
      if (nlon.eq.l+l-2) then
c     set last column
      m = l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      ns = l
      if (mode.eq.1) ns = l+1
      do 116 k=1,nt
      do 116 i=1,late
      do 116 np1=ns,nlat,2
      g(i,nlon,k) = g(i,nlon,k)+2.0*a(l,np1,k)*pmn(np1,i,km)
  116 continue
      end if
      end if
c     do inverse fourier transform
      do 120 k=1,nt
      call hrfftb(lat,nlon,g(1,1,k),lat,wfft,pmn)
  120 continue
c     scale output in gs
      do 122 k=1,nt
      do 122 j=1,nlon
      do 122 i=1,lat
      gs(i,j,k) = 0.5*g(i,j,k)
  122 continue
      return
      end
      subroutine shsgci(nlat,nlon,wshsgc,lshsgc,dwork,ldwork,ierror)
c     this subroutine must be called before calling shsgc with
c     fixed nlat,nlon. it precomputes quantites such as the gaussian
c     points and weights, m=0,m=1 legendre polynomials, recursion
c     recursion coefficients.
      dimension wshsgc(lshsgc)
      double precision dwork(ldwork)
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
c     set triangular truncation limit for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set equator or nearest point (if excluded) pointer
      late = (nlat+mod(nlat,2))/2
      l1 = l
      l2 = late
      ierror = 3
c     check permanent work space length
      if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 4
      if (ldwork .lt. nlat*(nlat+4)) return
      ierror = 0
c     set pointers
      i1 = 1
      i2 = i1+nlat
      i3 = i2+nlat*late
      i4 = i3+nlat*late
      i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1)
      i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1)
      i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1)
c     set indices in temp work for double precision gaussian wts and pts
      idth = 1
      idwts = idth+nlat
      iw = idwts+nlat
      call shsgci1(nlat,nlon,l,late,wshsgc(i1),wshsgc(i2),wshsgc(i3),
     1wshsgc(i4),wshsgc(i5),wshsgc(i6),wshsgc(i7),dwork(idth),
     2dwork(idwts),dwork(iw),ierror)
      if (ierror.ne.0) ierror = 5
      return
      end
      subroutine shsgci1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel,
     1                  wfft,dtheta,dwts,work,ier)
      dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1),
     1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat)
      double precision pb,dtheta,dwts,work(*)
c     compute the nlat  gaussian points and weights, the
c     m=0,1 legendre polys for gaussian points and all n,
c     and the legendre recursion coefficients
c     define index function used in storing
c     arrays for recursion coefficients (functions of (m,n))
c     the index function indx(m,n) is defined so that
c     the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no
c     "holes" as m varies from 2 to n and n varies from 2 to l-1.
c     (m=0,1 are set from p0n,p1n for all n)
c     define for 2.le.n.le.l-1
      indx(m,n) = (n-1)*(n-2)/2+m-1
c     define index function for l.le.n.le.nlat
      imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1
c     preset quantites for fourier transform
      call hrffti(nlon,wfft)
c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+1)+2
      lw = nlat*(nlat+2)
      call gaqd(nlat,dtheta,dwts,work,lw,ier)
      if (ier.ne.0) return
c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      do 100 i=1,nlat
      wts(i) = dwts(i)
  100 continue
c     initialize p0n,p1n using double precision dnlfk,dnlft
      do 101 np1=1,nlat
      do 101 i=1,late
      p0n(np1,i) = 0.0
      p1n(np1,i) = 0.0
  101 continue
c     compute m=n=0 legendre polynomials for all theta(i)
      np1 = 1
      n = 0
      m = 0
      call dnlfk(m,n,work)
      do 103 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(1,i) = pb
  103 continue
c     compute p0n,p1n for all theta(i) when n.gt.0
      do 104 np1=2,nlat
      n = np1-1
      m = 0
      call dnlfk(m,n,work)
      do 105 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(np1,i) = pb
  105 continue
c     compute m=1 legendre polynomials for all n and theta(i)
      m = 1
      call dnlfk(m,n,work)
      do 106 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p1n(np1,i) = pb
  106 continue
  104 continue
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      do 107 n=2,nlat
      mlim = min0(n,l)
      do 107 m=2,mlim
      imn = indx(m,n)
      if (n.ge.l) imn = imndx(m,n)
      abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/
     1               float(((2*n-3)*(m+n-1)*(m+n))))
      bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/
     1               float(((2*n-3)*(m+n-1)*(m+n))))
      cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/
     1               float(((n+m-1)*(n+m))))
  107 continue
      return
      end


e          ! Not available. Can be calculated EXP(1)
pi         ! Not available. Can be calculated 4.0*ATAN(1.0)
SQRT(x)    ! square root
LOG(x)     ! natural logarithm
LOG10(x)   ! logarithm to base 10
EXP(x)     ! exponential
ABS(x)     ! absolute value
FLOOR(x)   ! floor - Fortran 90 or later only
CEILING(x) ! ceiling - Fortran 90 or later only
x**y       ! x raised to the y power


program test_inverse_trig
use lfortran_intrinsic_math, only: asin, acos, atan, asinh, acosh, atanh
implicit none
real :: x

x = asin(0.84147098)
if (abs(x - 1.0) > 1e-5) error stop

x = acos(0.54030231)
if (abs(x - 1.0) > 1e-5) error stop

x = atan(1.5574077)
if (abs(x - 1.0) > 1e-5) error stop

x = asinh(1.1752012)
if (abs(x - 1.0) > 1e-5) error stop

x = acosh(1.5430806)
if (abs(x - 1.0) > 1e-5) error stop

x = atanh(0.76159416)
if (abs(x - 1.0) > 1e-5) error stop

end program


      SUBROUTINE W3FC05(U, V, DIR, SPD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:  W3FC05        EARTH U,V WIND COMPONENTS TO DIR AND SPD
C   PRGMMR: CHASE            ORG: NMC421      DATE:88-10-26
C
C ABSTRACT: GIVEN THE TRUE (EARTH ORIENTED) WIND COMPONENTS
C   COMPUTE THE WIND DIRECTION AND SPEED.
C   INPUT WINDS AT THE POLE ARE ASSUMED TO FOLLOW THE WMO
C   CONVENTIONS, WITH THE OUTPUT DIRECTION COMPUTED IN ACCORDANCE
C   WITH WMO STANDARDS FOR REPORTING WINDS AT THE POLE.
C   (SEE OFFICE NOTE 241 FOR WMO DEFINITION.)
C
C PROGRAM HISTORY LOG:
C   81-12-30  STACKPOLE, JOHN
C   88-10-19  CHASE, P.   ALLOW OUTPUT VALUES TO OVERLAY INPUT
C   89-01-21  R.E.JONES   CONVERT TO MICROSOFT FORTRAN 4.10
C   90-06-11  R.E.JONES   CONVERT TO SUN FORTRAN 1.3
C   91-03-30  R.E.JONES   SiliconGraphics FORTRAN
C   93-03-29  R.E.JONES   ADD SAVE STATEMENT
C
C USAGE:    CALL W3FC05 (U, V, DIR, SPD)
C
C   INPUT ARGUMENT LIST:
C     U        - REAL*4 EARTH-ORIENTED U-COMPONENT
C     V        - REAL*4 EARTH-ORIENTED V-COMPONENT
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     DIR      - REAL*4 WIND DIRECTION, DEGREES.  VALUES WILL
C                BE FROM 0 TO 360 INCLUSIVE.
C     SPD      - REAL*4 WIND SPEED IN SAME UNITS AS INPUT
C
C   INPUT FILES:   NONE
C
C   OUTPUT FILES:  NONE
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       COMMON   - SQRT, ATAN2
C
C REMARKS:  IF SPEED IS LESS THAN 1E-10 THEN DIRECTION WILL BE SET
C   TO ZERO.
C
C ATTRIBUTES:
C   LANGUAGE: SiliconGraphics 3.5 FORTRAN 77
C   MACHINE:  SiliconGraphics IRIS-4D/25, 35, INDIGO
C
C$$$
C
C     VARIABLES.....
C
      REAL   U, V, DIR, SPD, XSPD
C
C     CONSTANTS.....
C
      SAVE
C
      DATA  SPDTST/1E-10/, RTOD/57.2957795/, DCHALF/180.0/

      XSPD = SQRT(U * U + V * V)
      IF (XSPD .LT. SPDTST) THEN
         DIR = 0.0
      ELSE
         DIR = ATAN2(U,V) * RTOD + DCHALF
      ENDIF
      SPD = XSPD
      RETURN
      END


C **********************************************************************
C Function to compute the Johnson-Cook yield stress
C **********************************************************************
      function yieldStress (
C Parameters
     1 epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm )
      include 'vaba_param.inc'
C Hardening part of the Johnson-Cook law
      hardPart = parA + parB * epsp**parn
C Dependence to the deformation rate
      if (depsp .gt. pardepsp0) then
        viscPart = 1.0 + parC * log (depsp/pardepsp0)
      else
        viscPart = 1.0
      end if
C Dependence to the temperature if parT0 < temp < parTm
      tempPart = 1.0
      if (temp > parT0) then
        if (temp < parTm) then
          tempPart = 1.0 - ((temp - parT0) / (parTm - parT0))**parm
        else
          tempPart = 0.0
       end if
      end if
C Compute and return the yield stress
      yieldStress = hardPart * viscPart * tempPart
      return
      end

C **********************************************************************
C Function to compute the Johnson-Cook hardening / epsp
C **********************************************************************
      function yieldHardEpsp (
C Parameters
     1 epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      include 'vaba_param.inc'
C Hardening part of the Johnson-Cook law
      hardPart = parn * parB * (epsp**(parn - 1.0))
C Dependence to the deformation rate
      if (depsp .gt. pardepsp0) then
        hardPart = hardPart * (1.0 + parC * log (depsp/pardepsp0))
      end if
C Dependence to the temperature if parT0 < temp < parTm
      tempPart = 1.0
      if (temp > parT0) then
        if (temp < parTm) then
          tempPart = 1.0 - ((temp - parT0) / (parTm - parT0))**parm
        else
          tempPart = 0.0
       end if
      end if
C Compute and return the yield stress
      yieldHardEpsp = hardPart * tempPart
      return
      end

C **********************************************************************
C Function to compute the Johnson-Cook hardening / depsp
C **********************************************************************
      function yieldHardDepsp (
C Parameters
     1 epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      include 'vaba_param.inc'
C Hardening part of the Johnson-Cook law
      hardPart = 0.0
C Dependence to the deformation rate
      if (depsp .gt. pardepsp0) then
        hardPart = (parA + parB * epsp**parn) * parC / depsp
      end if
C Dependence to the temperature if parT0 < temp < parTm
      tempPart = 1.0
      if (temp > parT0) then
        if (temp < parTm) then
          tempPart = 1.0 - ((temp - parT0) / (parTm - parT0))**parm
        else
          tempPart = 0.0
       end if
      end if
C Compute and return the yield stress
      yieldHardDepsp = hardPart * tempPart
      return
      end

C **********************************************************************
C Function to compute the Johnson-Cook hardening / T
C **********************************************************************
      function yieldHardTemp (
C Parameters
     1 epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      include 'vaba_param.inc'
C Hardening part of the Johnson-Cook law
      hardPart = parA + parB * epsp**parn
C Dependence to the deformation rate
      if (depsp .gt. pardepsp0) then
        viscPart = 1.0 + parC * log (depsp/pardepsp0)
      else
        viscPart = 1.0
      end if
C Dependence to the temperature if parT0 < temp < parTm
      tempPart = 0.0
      if (temp > parT0 .and. temp < parTm) then
        tempPart = -parm*(((temp - parT0)/(parTm - parT0))**(parm))
     1    / (temp - parT0)
      end if
C Compute and return the yield stress
      yieldHardTemp = hardPart * viscPart * tempPart
      return
      end

C **********************************************************************
C Function to compute the numerical Johnson-Cook hardening / epsp
C **********************************************************************
      function yieldHardEpspNum (
C Parameters
     1 yield, epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      include 'vaba_param.inc'
C Increment of the plastic strain
      deltaEpsp = 1.0e-1
      if (j_sys_Dimension .eq. 2) deltaEpsp = 1.0e-8
      epspForward = epsp + deltaEpsp
c yieldForward
      yieldForward = yieldStress (epspForward, depsp, temp,
     1 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      yieldHardEpspNum = (yieldForward - yield) / deltaEpsp
      return
      end

C **********************************************************************
C Function to compute the numerical Johnson-Cook hardening / depsp
C **********************************************************************
      function yieldHardDepspNum (
C Parameters
     1 yield, epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      include 'vaba_param.inc'
c Increment of the plastic strain rate
      deltaDepsp = 1.0e-1
      if (j_sys_Dimension .eq. 2) deltaDepsp = 1.0e-8
      depspForward = depsp + deltaDepsp
c yieldForward
      yieldForward = yieldStress (epsp, depspForward, temp,
     1 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      yieldHardDepspNum = (yieldForward - yield) / deltaDepsp
      return
      end

C **********************************************************************
C Function to compute the numerical Johnson-Cook hardening / T
C **********************************************************************
      function yieldHardTempNum (
C Parameters
     1 yield, epsp, depsp, temp,
C Constants of the constitutive law
     2 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      include 'vaba_param.inc'
c Increment of the temperature
      deltaTemp = 1.0e-1
      if (j_sys_Dimension .eq. 2) deltaTemp = 1.0e-8
      tempForward = temp + deltaTemp
c yieldForward
      yieldForward = yieldStress (epsp, depsp, tempForward,
     1 parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      yieldHardTempNum = (yieldForward - yield) / deltaTemp
      return
      end


      SUBROUTINE OPA_SET_UP_GRID
     &          (delta_min,
     &           mxlat,nrlat,mxlon,nrlon,
     &           xlat1,xlon1,xlat2,xlon2,
     &           xclt,cxclt,sxclt,xlng)

c Generates grid of latitude and longitude;
c Sign convention is + for West and North

c mxlat       maximum number of points in latitude               INTEGER
c nrlat       number of points output for latitude               INTEGER

c mxlon       maximum number of points in longitude              INTEGER
c nrlon       number of points output for longitude              INTEGER

c delta_min   minimum increment of latitude/longitude               REAL

c xlat1       latitude  of the lower left  corner                   REAL
c xlon1       longitude of the lower left  corner                   REAL
c xlat2       latitude  of the upper right corner                   REAL
c xlon2       longitude of the upper right corner                   REAL

c xlng        longitude points in radians                           REAL
c xclt        latitude  points in radians                           REAL
c cxclt       cosine(xclt)                                          REAL
c sxclt         sine(xclt)                                          REAL

      real            xclt(mxlat),cxclt(mxlat),sxclt(mxlat),xlng(mxlon)

      data            xlats1,xlats2,xlons1,xlons2/4*720./

c     Test if this is a new op area grid
      if (xlon1 .eq. xlons1 .and. xlat1 .eq. xlats1 .and.
     &    xlon2 .eq. xlons2 .and. xlat2 .eq. xlats2) return

c     Longitude increment is chosen to give maximum resolution within
c     the op area consistent with the maximum number of points allowed
      xlng1=xlon1
      xlng2=xlon2
      if (xlng2 .ge. xlng1) xlng2=xlng2-360.

      delta=10.
      mx=(xlng1-xlng2)/delta+1.
      do while (mx .le. mxlon .and. delta .ge. delta_min)
         nrlon=mx
         delta=delta/2.
         mx=(xlng1-xlng2)/delta+1.
      end do
      delta=delta*2.

      sum=xlng1
      do j=1,nrlon
         xlng(j)=sum*.01745329252 ! convert to radians
         sum=sum-delta
         if (sum .lt. -180.) sum=sum+360.
      end do

c     Latitude increment is chosen to give maximum resolution within
c     the op area consistent with the maximum number of points allowed
      xclt1=90.-xlat1
      xclt2=90.-xlat2

      delta=10.
      my=(xclt1-xclt2)/delta+1.
      do while (my .le. mxlat .and. delta .ge. delta_min)
         nrlat=my
         delta=delta/2.
         my=(xclt1-xclt2)/delta+1.
      end do
      delta=delta*2.

      sum=xclt1
      do j=1,nrlat
         xclt(j)=sum*.01745329252 ! convert to radians
         cxclt(j)=cos(xclt(j))
         sxclt(j)=sin(xclt(j))
         sum=sum-delta
      end do

c     Save test parameters
      xlons1=xlon1
      xlons2=xlon2
      xlats1=xlat1
      xlats2=xlat2

      return
      END      ! OPA_SET_UP_GRID


SUBROUTINE crf_bff (r_CRS, v_CRS, Yangle, Rcrf_bff, Rrtn_bff)

! ----------------------------------------------------------------------
! SUBROUTINE: crf_bff.f90
! ----------------------------------------------------------------------
! Purpose:
!  Transformation between inertial frame and body-fixed frame
!  Transformation between orbital frame and body-fixed frame
! ----------------------------------------------------------------------
! Input arguments:
! - r_sat: 			Satellite position vector (m)
! - v_sat: 			Satellite velocity vector (m/sec)
! - Yangle:			Yaw angle (degrees)
!
! Output arguments:
! - Rcrf_bff:		Transformation matrix: Inertial frame (GCRF) to Body-fixed frame
! - Rrtn_bff:		Transformation matrix: Orbital frame to Body-fixed frame
! ----------------------------------------------------------------------
! Thomas D. Papanikolaou, Geoscience Australia                 June 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      !USE mdl_arr
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: r_CRS(3), v_CRS(3)
      REAL (KIND = prec_d), INTENT(IN) :: Yangle
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: Rcrf_bff(3,3), Rrtn_bff(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: Rcrf_rtn(3,3), Drtn_bff(3,3), Rz_yaw(3,3)
      REAL (KIND = prec_d) :: Rtest(3,3)
      REAL (KIND = prec_d) :: Yangle_rad
      INTEGER (KIND = prec_int4) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Transformation matrix: Inertial frame (GCRF) to Body-fixed frame
! ----------------------------------------------------------------------

! Rcrf_bff = Rz_yaw * Drtn_bff * Rcrf_rtn

! Xbff = Rz_yaw * Drtn_bff * Rcrf_rtn * Xcrf = Rz_yaw * Drtn_bff * Xrtn

! ----------------------------------------------------------------------
! Inertial (GCRF) to Orbital Frame
! ----------------------------------------------------------------------
! RTN: Radial, Along (Tangential), Cross (Normal)
! Xrtn = Rcrf_rtn * Xcrf
      CALL orb_frame(r_CRS, v_CRS, Rcrf_rtn)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Orbital frame to body-fixed frame
! ----------------------------------------------------------------------

! Rotation matrix for the axes directions correspondence: RTN to TNR to XYZ axes
! For yaw = 0
! eBF_x =  eT
! eBF_y = -eN
! eBF_z = -eR
      Drtn_bff (1,1:3) = (/  0.0D0,  1.0D0,  0.0D0  /)
      Drtn_bff (2,1:3) = (/  0.0D0,  0.0D0, -1.0D0  /)
      Drtn_bff (3,1:3) = (/ -1.0D0,  0.0D0,  0.0D0  /)

! Rz(yaw) rotation matrix:
      Yangle_rad = Yangle * (PI_global / 180.0D0)

      Rz_yaw(1,1:3) = (/  cos(Yangle_rad),  sin(Yangle_rad),  0.0D0 /)
      Rz_yaw(2,1:3) = (/ -sin(Yangle_rad),  cos(Yangle_rad),  0.0D0 /)
      Rz_yaw(3,1:3) = (/            0.0D0,            0.0D0,  1.0D0 /)
! ----------------------------------------------------------------------

! Arrays multiplication

! ----------------------------------------------------------------------
! Allocatable arrays
!      ALLOCATE (R1(3,3), STAT = AllocateStatus)
!      ALLOCATE (R2(3,3), STAT = AllocateStatus)
!      ALLOCATE (R3(3,3), STAT = AllocateStatus)
!      IF (AllocateStatus /= 0) THEN
!         PRINT *, "Error: Not enough memory"
!         PRINT *, "Error: SUBROUTINE crf_bff.f90"
!         STOP "*** Not enough memory ***"
!      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Orbital to body-fixed frame
      !R1 = Rz_yaw
      !R2 = Drtn_bff
      !CALL matrixRxR (R1, R2, R3)
      !Rrtn_bff = R3
      ! matrix_RxR equivalent to MATMUL
      Rrtn_bff = MATMUL(Rz_yaw, Drtn_bff)

! Inertial to body-fixed frame
      !R1 = Rrtn_bff
      !R2 = Rcrf_rtn
      !CALL matrix_RxR (R1, R2, R3)
      !Rcrf_bff = R3
      ! matrix_RxR equivalent to MATMUL
      Rcrf_bff = MATMUL(Rrtn_bff, Rcrf_rtn)
      !Rcrf_bff = MATMUL(Rcrf_rtn,Rrtn_bff)
! ----------------------------------------------------------------------

END Subroutine


        subroutine getillls(pin)
        implicit double precision (a-h,o-z)
        dimension fa(0:40),si(0:40),pin(0:8,0:8,0:16)

        fa(0)=1.d0
        si(0)=1.d0
        do i=1,32
          fa(i)=dfloat(i)*fa(i-1)
          si(i)=-si(i-1)
        enddo

        do 1000 l=0,8
        do 1000 m=0,8
        do 1000 n=m+l,0,-2
          xi=0.d0
          xf=2.d0/2.d0**dfloat(n+l+m)
          nn=(n+1)/2
          mm=(m+1)/2
          ll=(l+1)/2
          do 500 ia=nn,n
            af=si(ia)*fa(ia+ia)/fa(ia)/fa(n-ia)/fa(ia+ia-n)              // ***
            do 500 ib=ll,l
              bf=si(ib)*fa(ib+ib)/fa(ib)/fa(l-ib)/fa(ib+ib-l)            // ***
              do 500 ic=mm,m
                xcf=si(ic)*fa(ic+ic)/fa(ic)/fa(m-ic)/fa(ic+ic-m)         // ***
                xi=xi+xf*af*bf*xcf/dfloat(ia*2+ib*2+ic*2-n-l-m+1)        // ***
 500      continue
          pin(l,m,n)=xi
 1000   continue

        return

        end


!> Procedures to compute the Hypergeometric function _2F_1 in the
!! special case in which a or b is a negative integer.
module m_hyp2f1_negint
use iso_c_binding
implicit none

contains

!> Computes the value of the Gauss hypergeometric function in the
!! special case in which @p a or @p b is a negative integer.
!!
!! @see Equation 15.4.1 from Abramowitz and Stegun: Handbook of
!! Mathematical Functions.
!!
pure function hyp2f1_negint(a, b, c, z) result(sum)
  integer, intent(in) :: a, b, c
  real(c_double), intent(in) :: z
  real(c_double) :: sum
  integer(c_int) :: n
  integer :: i

  if (a < 0) n = -a
  if (b < 0 .and. b > a) n = -b

  sum = coeff(a, b, c, n)
  do i = n - 1, 0, -1
     sum = sum * z + coeff(a, b, c, i)
  end do

end function

pure function coeff(a, b, c, n) result(res)
  integer, intent(in) :: a, b, c, n
  real(c_double) :: res
  if (n == 0) then
     res = 1.0
  else
     res = ph(a, n) / real(ph(c, n), c_double) * ph(b, n) / &
          real(fact(n), c_double)
  end if
end function coeff

pure recursive function ph(a, n) result(res)
  integer, intent(in) :: a, n
  real(c_double) :: res
  if (n == 0 ) then
     res = 1
  else
     res = a * ph(a + 1, n - 1)
  end if
end function ph

pure recursive function fact(n) result(res)
  integer, intent(in) :: n
  real(c_double) :: res
  if (n > 1) then
     res = n * fact(n - 1)
  else
     res = 1
  end if
end function fact

end module m_hyp2f1_negint


! Compute the analytic solution for the relaxation to thermal
! equilibrium radiation problem.  We follow the problem outline from
! Swesty and Myra (2009), section 4.4.1.
!
! This code returns the radiation energy as a function of time.

module constants_module

  use amrex_fort_module, only : rt => amrex_real

  ! fundamental constants
  real(rt), parameter :: k_B      = 1.3806504d-16   ! erg / K
  real(rt), parameter :: c_light  = 2.99792458d10   ! cm / s
  real(rt), parameter :: sigma_SB = 5.670400d-5     ! erg/s/cm^2/K^4
  real(rt), parameter :: a_rad    = 4.0d0*sigma_SB/c_light
  real(rt), parameter :: m_p      = 1.672621637d-24 ! g

  ! problem parameters

  ! matter density
  real(rt), parameter :: rho_ambient = 1.e-7   ! g / cm**3

  ! mean molecular weight
  real(rt), parameter :: mu = 0.6

  ! ratio of specific heats
  real(rt), parameter :: gamma = 5.0d0/3.0d0

  ! starting time
  real(rt), parameter :: t_0 = 1.d-16   ! s

  ! starting radiation energy density
  real(rt), parameter :: E_rad = 1.d12  ! erg / cm**3

  ! starting matter energy density
  !
  ! This is one of the main parameters that controls the behavior of
  ! the problem.  The matter energy sets the matter temperature (via
  ! the EOS).  If (a T**4) > E_rad, then we are doing a cooling
  ! problem.  If (a T**4) < E_rad, then we are doing a heating problem
  ! (i.e. the matter temperature will increase with time to the
  ! equilibrium temperature).

  !real(rt), parameter :: rhoe_i = 1.d9  ! erg / cm**3
  real(rt), parameter :: rhoe_i = 1.d2  ! erg / cm**3

  ! we will specify the opacity as a constant kappa.  In Castro lingo,
  ! this is the Planck mean opacity, which appears in the source term.
  real(rt), parameter :: kappa_p = 4.d-8

end module constants_module

function f(x,beta,eta) result (fval)

  real(rt), intent(in)  :: x, beta, eta
  real(rt) :: fval

  ! There are different analytic solutions depending on whether we are
  ! heating (x < beta/eta) or cooling (x > beta/eta)

  if (x < beta/eta) then

     ! note: this form is different than what appears in Swesty and Myra,
     ! but instead, this is the form that Doug seems to have used in his
     ! code.
     fval = (1.d0/(2.d0*eta*beta**3)) * &
          (0.5d0*log((beta + eta*x)/(beta - eta*x)) + &
          atan(eta*x/beta))
  else
     fval = (1.d0/(2.d0*eta*beta**3)) * &
          (0.5d0*log((x + beta/eta)/(x - beta/eta)) + &
          atan(eta*x/beta))
  endif

  return
end function f

program analytic

  ! compute the analytic solution to the thermal relaxation problem,
  ! as given by Swesty and Myra (2009), Eq. 83, 84.

  ! The analytic solution provides t(rho*e) for the gas component.

  use constants_module

  implicit none

  real(rt) :: safe_print
  real(rt) :: f

  real(rt) :: beta, c_v, eta
  real(rt) :: rhoe_f, rhoe, dlog_rhoe
  real(rt) :: t

  integer :: n
  integer, parameter :: nsteps = 2000

  ! the beta constant as implied in Swesty and Myra, eq. 81
  beta = (c_light*kappa_p*E_rad)**0.25d0

  ! specific heat at constant volume for an idea gas (Note: Swesty and
  ! Myra work with temperature in MeV, so Boltzmann's constant, k_B,
  ! does not appear in their derivation.
  c_v = k_B/(mu*m_p*(gamma - 1.d0))

  ! the eta constant as implied in Swesty and Myra, eq. 81
  eta = ((c_light*kappa_p*a_rad)**0.25d0)/(c_v*rho_ambient)

  ! final energy density (see Swesty and Myra, text just before
  ! Eq. 82)
  rhoe_f = beta/eta

  ! energy increment
  dlog_rhoe = (log(rhoe_f) - log(rhoe_i))/(nsteps-1)

  print *, '# t, rho*e (matter)'

  ! loop in energy to find corresponding time
  do n = 1, nsteps
     rhoe = exp(log(rhoe_i) + dble(n-1)*dlog_rhoe)

     t = t_0 + f(rhoe,beta,eta) - f(rhoe_i,beta,eta)

     print *, t, rhoe
  enddo

end program analytic


      subroutine MINV2(A,B)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(2,2),B(2,2)
      DETA=A(1,1)*A(2,2)-A(1,2)*A(2,1)
      IF(DETA.EQ.0.) THEN
           WRITE(6,'(A)') 'DETERMINANT=0 MATRIX-INV NOT FOUND'
           WRITE(6,'(4F10.4)') A
           STOP
      END IF
      B(1,1)=A(2,2)/DETA
      B(1,2)=-A(1,2)/DETA
      B(2,1)=-A(2,1)/DETA
      B(2,2)=A(1,1)/DETA
      RETURN
      END