      FUNCTION HRS_TO_HHMM
     &        (hours)

c***********************************************************************
c                         function hrs_to_hhmm
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 882

c  Date:
c     11 Apr 1999

c  Function:
c     Converts time in hours to HHMM format

c  Parameters passed:
c     hours            [r] time in hours

c  Parameters returned:
c     hhmm             [r] time in HHMM format

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     int

c  References:

c  Change History:

c*******************!***************************************************

c     Convert from hours to HHMM
      hrs_to_hhmm=INT(hours)*40.+hours*60.+.5

      RETURN
      END      ! HRS_TO_HHMM


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file in the top-level directory of this distribution.

module output
  use progvars
  use files, only: files_ensure_dir
  use stats, only: stats_residuals, stats_mean, stats_variance, stats_median, &
       stats_stdev, stats_mean_sq_err, stats_mean_abs_err

  implicit none

  private

  ! Generic module functions
  public :: output_init
  public :: output_cleanup

  public :: output_log
  public :: output_vd_results
  public :: output_vd_resid_stats
  public :: output_params

  ! Output file unit numbers
  integer, parameter :: log_unit = 99
  integer, parameter :: params_unit = 98
  integer, parameter :: vd_px_unit = 89
  integer, parameter :: vd_py_unit = 87
  integer, parameter :: vd_stats_unit = 86

  character(10) :: date, time

contains
  ! Module initializaiton
  subroutine output_init
    call files_ensure_dir(output_dir)

    open(unit=log_unit, file=trim(output_dir)//trim(log_fname))
    open(unit=params_unit, file=trim(output_dir)//trim(params_fname))
    open(unit=vd_px_unit, file=trim(output_dir)//trim(vd_px_fname))
    open(unit=vd_py_unit, file=trim(output_dir)//trim(vd_py_fname))
    open(unit=vd_stats_unit, file=trim(output_dir)//trim(vd_stats_fname))
  end subroutine output_init

  subroutine output_log(log_text, fmt)
    character(*), intent(in) :: log_text
    character(*), intent(in), optional :: fmt

    call date_and_time(date=date, time=time)
    write(log_unit, *) date, time

    if (present(fmt)) then
       write(log_unit, fmt) log_text
    else
       write(log_unit, *) log_text
    end if

  end subroutine output_log

  subroutine output_params()
  end subroutine output_params

  subroutine output_vd_results()

    integer :: i_px, i_py
    real(dp) :: px, py

    ! Residual analysis
    call stats_residuals(npx_arr, theor_npx_arr, resid_npx_arr)
    call stats_residuals(npy_arr, theor_npy_arr, resid_npy_arr)

    ! Output vd results
    do i_px = 1, size(npx_arr)
       px = vd_px_arr(i_px)
       write(vd_px_unit, *) px, npx_arr(i_px), theor_npx_arr(i_px), resid_npx_arr(i_px)
    end do
    do i_py = 1, size(npy_arr)
       py = vd_py_arr(i_py)
       write(vd_py_unit, *) py, npy_arr(i_py), theor_npy_arr(i_py), resid_npy_arr(i_py)
    end do

  end subroutine output_vd_results

  subroutine output_vd_resid_stats()

    resid_npx_mask(:) = resid_npx_arr(:) .ge. resid_x_eps
    resid_npy_mask(:) = resid_npy_arr(:) .ge. resid_y_eps

    write(*,*)
    write(*,*) "Residual analysis for detected/theoretical momentum distributions"
    write(*,*) "Format: [Label] [x value] [y value]"
    write(*,*)
    write(*,*) "Sum of residuals:", sum(resid_npx_arr), sum(resid_npy_arr)
    write(*,*) "Sum of squared residauls:", sum(resid_npx_arr(:)**2), &
         sum(resid_npy_arr(:)**2)

    write(*,*)
    write(*,*) "Residual thresholds:", resid_x_eps, resid_y_eps
    write(*,*) "Number of above-threshold residuals", &
         count(resid_npx_mask), count(resid_npy_mask)

    write(*,*)
    write(*,*) "Mean of above-threshold residuals:", &
         stats_mean(resid_npx_arr, mask=resid_npx_mask), &
         stats_mean(resid_npy_arr, mask=resid_npy_mask)
    write(*,*) "Median of above-threshold residuals:", &
         stats_median(resid_npx_arr, mask=resid_npx_mask), &
         stats_median(resid_npy_arr, mask=resid_npy_mask)

    write(*,*)
    write(*,*) "Variance of above-threshold residuals:", &
         stats_variance(resid_npx_arr, mask=resid_npx_mask), &
         stats_variance(resid_npy_arr, mask=resid_npy_mask)
    write(*,*) "Mean squared error of above-threshold residuals:", &
         stats_mean_sq_err(resid_npx_arr, mask=resid_npx_mask), &
         stats_mean_sq_err(resid_npy_arr, mask=resid_npy_mask)
    write(*,*) "Mean absolute error of above-threshold residuals:", &
         stats_mean_abs_err(resid_npx_arr, mask=resid_npx_mask), &
         stats_mean_abs_err(resid_npy_arr, mask=resid_npy_mask)

    write(*,*)
    write(*,*) "Maximum residuals:", maxval(resid_npx_arr), maxval(resid_npy_arr)
    write(*,*) "Minimum residuals:", minval(resid_npx_arr), minval(resid_npy_arr)

  end subroutine output_vd_resid_stats

  subroutine output_cleanup
    close(unit=log_unit)
    close(unit=params_unit)
    close(unit=vd_px_unit)
    close(unit=vd_py_unit)
    close(unit=vd_stats_unit)
  end subroutine output_cleanup

end module output


submodule (random) randinit

use, intrinsic:: iso_fortran_env, only: stderr=>error_unit

implicit none

contains

module procedure rand_init
integer :: n, u,ios, i
integer, allocatable :: seed(:),check(:)

call random_seed(size=n)
allocate(seed(n),check(n))

open(newunit=u, file='/dev/urandom', access="stream", &
     form="unformatted", action="read", status="old", iostat=ios)

if (ios==0) then
  read(u,iostat=ios) seed
  close(u)
endif

if (ios/=0) then
  write(stderr,*) 'falling back to internal random number generator'
  do i = 1,n
    seed(i) = randint(-1073741823, 1073741823)
  enddo
endif

call random_seed(put=seed)
!print *,'seed: ',seed    ! for debug/test

end procedure rand_init

end submodule randinit


    program demo_unpack
    implicit none
    integer :: vector(2)  = [1,1]
    logical :: mask(4)  = [ .true., .false., .false., .true. ]
    integer :: field(2,2) = 0, unity(2,2)

       ! result: unity matrix
       unity = unpack(vector, reshape(mask, [2,2]), field)
       write(*,*)unity,size(unity),shape(unity)

    end program demo_unpack


!!The bcs algorithm requires matrix operations such as appending, deleting
!!finding the intersections and complements of data sets. Since these
!!methods are pretty general, it makes sense to put them in their own module.
!!<comments date="27 Jun 2013" author="Conrad W. Rosenbrock">
!!- Changed array reallocations to use move_alloc instead of normal copy/overwrite.</comments>
module matrix_sets
  use num_types
  implicit none
  public intersection, complement, appendto, delete

  !!Appends an element to the end if a list. Accepts either real or
  !!integer lists and values.
  INTERFACE appendto
     module procedure appendto_one_d_list_real, appendto_one_d_list_integer
  END INTERFACE appendto
  !!Removes an element at a specified index from the list. Real or
  !!integer lists supported
  INTERFACE delete
     module procedure delete_element_from_one_d_list_real,delete_element_from_one_d_list_integer
  END INTERFACE delete
contains
  !!Determines the intersection of the specified lists. Returns the values
  !!that are common to both lists in the intersect parameter. Comparison is made using
  !!the built-in fortran operator @CREF[.eq.]. Zero values are not considered common even
  !!if they are in both lists.
  !!<parameter name="listone, listtwo">The two lists to compare values for and take the
  !!intersection of.</parameter>
  !!<parameter name="intersect">The resultant list of indices. Will be overwritten if
  !!already allocated.</parameter>
  SUBROUTINE intersection(listone, listtwo, intersect)
    integer, intent(in) :: listone(:), listtwo(:)
    integer, allocatable, intent(inout) :: intersect(:)

    !!<local name="N,M">The size of the lists 1 and 2 respectively.</local>
    !!<local name="indices">Counter for the number of indices common to both lists.</local>
    !!<local name="numberofnonzero">The final number of non-zero values common to both lists.</local>
    integer, allocatable ::templist(:)
    integer i, N, M, indices, numberofnonzero

    N = size(listone, 1)
    M = size(listtwo, 1)

    if (N > M) then
       allocate(templist(N))
    else
       allocate(templist(M))
    endif

    templist = 0
    indices = 1

    do i=1, N
       if (any(listtwo .eq. listone(i))) then
          templist(indices) = listone(i)
          indices = indices + 1
       endif
    enddo

    !Some of the elements in listone could have been zero and thus common to both lists.
    !But we are only interested in the non-zero values.
    numberofnonzero = count(templist > 0)
    if (allocated(intersect)) deallocate(intersect)
    allocate(intersect(numberofnonzero))
    intersect(1:numberofnonzero) = templist(1:numberofnonzero)
  END SUBROUTINE intersection

  !!Determines the complement of the two lists. Returns the values
  !!of those elements in the first list that are not in the second list.
  !!<parameter name="listone, listtwo" regular="true">The two lists of integer values to
  !!take the complement of.</parameter>
  !!<parameter name="comp">The resulting list of values that are only in list one.</parameter>
  SUBROUTINE complement(listone,listtwo,comp)
    integer, intent(in) :: listone(:), listtwo(:)
    integer, allocatable, intent(inout) :: comp(:)

    !!<local name="N,M">The size of the lists 1 and 2 respectively.</local>
    !!<local name="indices">Counter for the number of values exclusive to list one.</local>
    !!<local name="numberofnonzero">The final number of non-zero values unique to list one.</local>
    integer, allocatable ::templist(:)
    integer i, N, M, indices,numberofnonzero

    N =size(listone,1)
    M = size(listtwo,1)

    if (N > M) then
       allocate(templist(N))
    else
       allocate(templist(M))
    endif

    templist = 0
    indices = 1
    do i=1, N
       if (any(listtwo .eq. listone(i))) then
          cycle
       else
          templist(indices) = listone(i)
          indices = indices + 1
       endif
    enddo

    numberofnonzero = count(templist > 0)
    if (allocated(comp)) deallocate(comp)
    allocate(comp(numberofnonzero))
    comp(1:numberofnonzero) = templist(1:numberofnonzero)
  END SUBROUTINE complement

  !!Removes the element at the specified index from the real-valued list.
  !!<parameter name="list">The list of real values to delete from.</parameter>
  !!<parameter name="deleteindex">The index whose value should be removed from the list.</parameter>
  SUBROUTINE delete_element_from_one_d_list_real(list,deleteindex)
    real(dp), allocatable, intent(inout) :: list(:)
    integer, intent(in) :: deleteindex
    real(dp), allocatable :: templist(:)

    allocate(templist(size(list,1)-1))
    if (deleteindex .gt. 1) then
       templist(1:deleteindex-1) = list(1:deleteindex-1)
       templist(deleteindex:size(list,1)-1) = list(deleteindex+1:size(list, 1))
    else
       templist(:) = list(2:size(list,1))
    end if
    call move_alloc(templist, list)
  END SUBROUTINE delete_element_from_one_d_list_real

  !!Removes the element at the specified index from the integer-valued list.
  !!<parameter name="list">The list of real values to delete from.</parameter>
  !!<parameter name="deleteindex">The index whose value should be removed from the list.</parameter>
  SUBROUTINE delete_element_from_one_d_list_integer(list, deleteindex)
    integer, allocatable, intent(inout) :: list(:)
    integer, intent(in) :: deleteindex
    integer, allocatable :: templist(:)

    allocate(templist(size(list,1)-1))
    if (deleteindex .gt. 1) then
       templist(1:deleteindex-1) = list(1:deleteindex-1)
       templist(deleteindex:size(list,1)-1) = list(deleteindex+1:size(list, 1))
    else
       templist(:) = list(2:size(list,1))
    end if
    call move_alloc(templist, list)
  END SUBROUTINE delete_element_from_one_d_list_integer

  !!Adds the specified value to the end of the real-valued list.
  !!<parameter name="list">The real-valued list to append to.</parameter>
  !!<parameter name="appendage">The extra value to append to the list.</parameter>
  SUBROUTINE appendto_one_d_list_real(list,appendage)
    real(dp), allocatable, intent(inout) :: list(:)
    real(dp), intent(in) :: appendage
    real(dp), allocatable :: templist(:)

    allocate(templist(size(list,1)+1))
    templist(1:size(list,1)) = list
    templist(size(list,1)+1) = appendage

    call move_alloc(templist, list)
  END SUBROUTINE appendto_one_d_list_real

  !!Adds the specified value to the end of the integer-valued list.
  !!<parameter name="list">The integer-valued list to append to.</parameter>
  !!<parameter name="appendage">The extra value to append to the list.</parameter>
  SUBROUTINE appendto_one_d_list_integer(list, appendage)
    integer, allocatable, intent(inout) :: list(:)
    integer, intent(in) :: appendage
    integer, allocatable :: templist(:)

    allocate(templist(size(list,1)+1))
    templist(1:size(list,1)) = list
    templist(size(list,1)+1) = appendage

    call move_alloc(templist, list)
  END SUBROUTINE appendto_one_d_list_integer
end module matrix_sets


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine prep_Discrete_Fourier_Transformation
  use global_variables
  implicit none
  integer :: i,j,k
  real(8) :: an1,an2,an3
  real(8) :: k1(0:NL1-1),k2(0:NL2-1),k3(0:NL3-1),Bt(3,3)
  real(8) :: kx,ky,kz ! debug
  real(8) :: k1_t,k2_t,k3_t

  an1=norm_a_Cvec(1)
  an2=norm_a_Cvec(2)
  an3=norm_a_Cvec(3)

  allocate(exp_x1(0:NL1-1,0:NL1-1),exp_x2(0:NL2-1,0:NL2-1),exp_x3(0:NL3-1,0:NL3-1))
  allocate(cexp_x1(0:NL1-1,0:NL1-1),cexp_x2(0:NL2-1,0:NL2-1),cexp_x3(0:NL3-1,0:NL3-1))
  allocate(zft1(0:NL1-1,0:NL2-1,0:NL3-1),zft2(0:NL1-1,0:NL2-1,0:NL3-1),zft3(0:NL1-1,0:NL2-1,0:NL3-1),zft4(0:NL1-1,0:NL2-1,0:NL3-1))
  allocate(Lap_k(0:NL1-1,0:NL2-1,0:NL3-1),InLap_k(0:NL1-1,0:NL2-1,0:NL3-1))
  allocate(Grad_x_zI(0:NL1-1,0:NL2-1,0:NL3-1),Grad_y_zI(0:NL1-1,0:NL2-1,0:NL3-1),Grad_z_zI(0:NL1-1,0:NL2-1,0:NL3-1))

  do i=0,NL1-1
    do j=0,NL1-1
      exp_x1(i,j)=exp(zI*2d0*pi*dble(i*j)/dble(NL1))
      cexp_x1(i,j)=exp(-zI*2d0*pi*dble(i*j)/dble(NL1))
    end do
  end do

  do i=0,NL2-1
    do j=0,NL2-1
      exp_x2(i,j)=exp(zI*2d0*pi*dble(i*j)/dble(NL2))
      cexp_x2(i,j)=exp(-zI*2d0*pi*dble(i*j)/dble(NL2))
    end do
  end do

  do i=0,NL3-1
    do j=0,NL3-1
      exp_x3(i,j)=exp(zI*2d0*pi*dble(i*j)/dble(NL3))
      cexp_x3(i,j)=exp(-zI*2d0*pi*dble(i*j)/dble(NL3))
    end do
  end do

  do i=0,NL1-1
    k1(i)=2d0*pi*dble(i)
    if(i >= NL1/2) k1(i)=2d0*pi*dble(i-NL1)
  end do
  do i=0,NL2-1
    k2(i)=2d0*pi*dble(i)
    if(i >= NL2/2) k2(i)=2d0*pi*dble(i-NL2)
  end do
  do i=0,NL3-1
    k3(i)=2d0*pi*dble(i)
    if(i >= NL3/2) k3(i)=2d0*pi*dble(i-NL3)
  end do

  do i=1,3
  do j=1,3
    Bt(i,j)=sum(B_matrix(i,:)*B_matrix(j,:))
  end do
  end do

  if(myrank == 0)then
    write(*,*)A_matrix(1,1),A_matrix(1,2),A_matrix(1,3)
    write(*,*)A_matrix(2,1),A_matrix(2,2),A_matrix(2,3)
    write(*,*)A_matrix(3,1),A_matrix(3,2),A_matrix(3,3)
    write(*,*)B_matrix(1,1),B_matrix(1,2),B_matrix(1,3)
    write(*,*)B_matrix(2,1),B_matrix(2,2),B_matrix(2,3)
    write(*,*)B_matrix(3,1),B_matrix(3,2),B_matrix(3,3)
    write(*,*)Bt(1,1),Bt(1,2),Bt(1,3)
    write(*,*)Bt(2,1),Bt(2,2),Bt(2,3)
    write(*,*)Bt(3,1),Bt(3,2),Bt(3,3)
  end if

  an1=0d0 ! debug
  InLap_k=0d0
  do i=0,NL1-1
  do j=0,NL2-1
  do k=0,NL3-1

    k1_t = k1(i)
    k2_t = k2(j)
    k3_t = k3(k)
!    if(i==NL1/2)k1_t = 0d0
!    if(j==NL2/2)k2_t = 0d0
!    if(k==NL3/2)k3_t = 0d0

    Lap_k(i,j,k)=-Bt(1,1)*k1(i)*k1(i)-Bt(1,2)*k1_t*k2_t-Bt(1,3)*k1_t*k3_t &
                 -Bt(2,1)*k2_t*k1_t-Bt(2,2)*k2(j)*k2(j)-Bt(2,3)*k2_t*k3_t &
                 -Bt(3,1)*k3_t*k1_t-Bt(3,2)*k3_t*k2_t-Bt(3,3)*k3(k)*k3(k)

    Grad_x_zI(i,j,k)=-B_matrix(1,1)*k1_t-B_matrix(2,1)*k2_t-B_matrix(3,1)*k3_t
    Grad_y_zI(i,j,k)=-B_matrix(1,2)*k1_t-B_matrix(2,2)*k2_t-B_matrix(3,2)*k3_t
    Grad_z_zI(i,j,k)=-B_matrix(1,3)*k1_t-B_matrix(2,3)*k2_t-B_matrix(3,3)*k3_t

!== debug
    if(myrank == 0)then
      kx=k1(i)*B_matrix(1,1)+k2(j)*B_matrix(2,1)+k3(k)*B_matrix(3,1)
      ky=k1(i)*B_matrix(1,2)+k2(j)*B_matrix(2,2)+k3(k)*B_matrix(3,2)
      kz=k1(i)*B_matrix(1,3)+k2(j)*B_matrix(2,3)+k3(k)*B_matrix(3,3)
!      write(*,'(3(I4,2x),3e16.6e3)')i,j,k,kx+Grad_x_zI(i,j,k),ky+Grad_y_zI(i,j,k),kz+Grad_z_zI(i,j,k)
      an1=an1+abs(kx+Grad_x_zI(i,j,k))+abs(ky+Grad_y_zI(i,j,k))+abs(kz+Grad_z_zI(i,j,k))
    end if
!== debug

!    if(i+j+k == 0)cycle
    if(abs(Lap_k(i,j,k)) < 1d-10)then
      if(myrank == 0)write(*,*)'i,j,k,Lap',i,j,k,Lap_k(i,j,k)
      InLap_k(i,j,k)=0d0
    else
      InLap_k(i,j,k)=1d0/Lap_k(i,j,k)
    end if
  end do
  end do
  end do

  if(myrank == 0)write(*,*)'an1=',an1

  return
end subroutine prep_Discrete_Fourier_Transformation


program m
  logical d
  d(i)=mod(n,i)==0
  do n=1800,2400
  if(d(4).xor.d(100).xor.d(400)) print'(i4)',n
  enddo
end


subroutine  NETRAD (Time,BareRadioTemp,VegnRadioTemp,BareNetRadn,VegnNetRadn,MixedNetRadn,Init)
  use simsphere_mod
  implicit none

!  Subroutine NETRAD computes up and down longwave fluxes and
!  the Net Radiation.

  real :: BareRadioTemp,VegnRadioTemp
  real :: BareNetRadn,VegnNetRadn,MixedNetRadn
  real :: VegnShortWave
  real :: Lwup
  real :: time
  integer(kind=1) :: Init

!      INCLUDE 'modvars.h'

!    Compute the solar radiation.

  if (time >= 0.0) then
    call Input
  else
    write(*,*) 'Error: negative time detected.'
    continue
  end if

!  Calculate the net radiation for the appropriate ground conditions.
!  The decision is made on the fraction of vegetation.

!  Code added 28/11/90 to solve the Partial routine issue
!  Initialise and calculate the effective emissivity of the air and
!  longwave down using a weighted average of surface and air temperature.

  If (Init == 1) Then
    Aepsi = 0.700 + 0.17 * Alog10(Omega)
    if(cloud_flag) aepsi = aepsi + (1 - aepsi)*0.8*(0.1*cld_fract)
    ! Note: forcing real arithmetic

    BareRadioTemp = Tscren - 2
    VegnRadioTemp = Tscren - 2
    Init = 2
  End If

! Vegetation

  if (eq(frveg,1.0)) then

    call Lwdown
    call Vegrad (Time,VegnNetRadn,VegnShortWave,VegnRadioTemp)
    Rnet = VegnNetRadn
    Swave = VegnShortWave

! Bare Soil

  elseif (eq(frveg,0.0)) then

    call Lwdown
    call Uplong (Lwup,BareRadioTemp)
    BareNetRadn = Lwdn*epsi + Swave - Lwup
    Rnet = BareNetRadn
    ! TJC VegnNetRadn, VegnShortWave to 0 in this case (no veg)
    VegnNetRadn = 0.0
    VegnShortWave = 0.0

!TJC -- BareNetRadn is NaN and Swave is Infinity here

! Mixed

  Elseif (Frveg > 0 .and. Frveg < 1) Then

    call Lwdown
    call Uplong (Lwup,BareRadioTemp)
    BareNetRadn = Lwdn*epsi + Swave - Lwup
    call Vegrad (Time,VegnNetRadn,VegnShortWave,VegnRadioTemp)

    MixedNetRadn = (VegnNetRadn * Frveg) + (1-Frveg) * BareNetRadn
    Rnet = MixedNetRadn
    Swave = VegnShortWave * Frveg + Swave * (1- Frveg)

! Error

  Else

!  Print*, ' Logic Error has occurred in rountine Netrad '
!  print*, 'frveg = ',frveg, '  frveg-1 = ',(frveg-1)
!   Print*, ' Stop Program '
!   Stop
    continue

  Endif

  Return
End

Subroutine  Lwdown
  use simsphere_mod, only: Lwdn, aepsi, sigma, t_fine, tdif_s
  implicit none

!      INCLUDE 'modvars.h'

  Lwdn = aepsi*sigma*(T_fine(3) - Tdif_s - 1.5)**4

  Return
End

Subroutine  UpLong (Lwup,SpecTemperature)
  use simsphere_mod, only: epsi, sigma
  implicit none

! epsi and sigma declared in simsphere module
!  real :: SpecTemperature,Lwup,epsi,sigma
  real :: SpecTemperature,Lwup

! Common blocks include via the "use" statement
!  COMMON /KONST/ CP,LE,SIGMA,KARMAN,GRAV,R
!  COMMON /NETCOM/ EPSI,EPSF,ALBF,XLAI,SOL,RNETG,RNETF,AEPSI

  Lwup =  epsi*sigma*SpecTemperature**4

  Return
End


	PROGRAM POTNL

C	Original Vaxstation version     4-22-89
C	Real*8 used                     12-12-89
C       Corrected REAL*8 errors         8-5-95
C       Modified for Linux              3-02-96
C       Added Grace output table        1-21-10
C       RMP82 form for HPL              3-16-10
C       Fermi contact term in HPL       3-16-10
C       Gombas contact term in HPL      3-25-10
C       Annotated in H-He use           11-28-19

C	Computes energies and eigenvalues for alkali-noble gas potentials
C
C	Pseudopotential with spherical cutoff
C       Induced dipole outside depends on polarizability
C       Gombas contact term depends on a perturber electron density parameter
C       Fermi contact inside depends on scattering length
C	Core-core interaction model is the same for all states and is not included
C
C       states.dat --
C
C	  asymptotic state energies and quantum numbers
C	  with the format (5(1x,F10.3))
C
C	  ENERGY (CM-1)
C	  N*
C	  L
C	  J
C	  M
C
C	  stored from low to high energy
C
C       param.dat --
C
C         parameters defining the potential
C
C         ALPHA - Polarizability in A^3
C         R0 - Cutoff radius for nobel gas
C         SL - Scatttering length in A (not used in this version)
C         NS - Number of perturber electrons that scatter valence electron
C         JVSELECT - Eigenvector selected for listing
C         NLOW - Lowest state for tabulation
C
C       range.dat --
C
C         range of RG used in output
C
C         RBEGIN - Starting R in A
C         RDEL - Delta R in A
C         NPTS - Number of points to compute
C
C	E stores the energy matrix elements
C	V stores the eigenvectors
C	QN stores the quantum numbers
C
C	After diagonization data are output to file potnl.dat
C         RG (A)
C         ENERGY (CM^-1)
C         largest contributions to eigenvectors and percentages
C
C       Grace file pseudo.agr contains 8 states from NLOW to NHIGH
C         Grace NXY column format RG (A) and ENERGY (CM^-1)

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23
	DIMENSION E(100,100),V(100,100),QN(100,5)
	DIMENSION ARRAY(100),INRGY(100),IVCTR(100)
	DIMENSION THETA(100,100)
        DIMENSION EPSEUDO(100)
	ERYD=109737.312D0
	A0=0.52917715D0
     	OPEN (UNIT=20,FILE='states.dat',STATUS='OLD')
	I=0
 50	CONTINUE
	I=I+1
	READ(20,*, END=100) (QN(I,J),J=1,5)
	GO TO 50
 100	CONTINUE
	CLOSE (UNIT=20)
	NLVLS=I-1

C	READ IN PARAMETERS FOR CALCULATION
C       DISTANCES IN ANGSTROMS ARE CONVERTED TO ATOMIC UNITS

	OPEN (UNIT=20,FILE='param.dat',STATUS='OLD')
	READ(20,*) ALPHA
	ALPHA=ALPHA/(A0**3)
	READ(20,*) R0
	R0=R0/A0
C	READ(20,*) SL
C	SL=SL/A0
        READ(20,*) ANS
        ANS23=ANS**(2.D0/3.D0)
        READ(20,*) JVSELECT
        READ(20,*) NLOW
        NHIGH=NLOW+9
        IF (NHIGH.GT.NLVLS) NHIGH=NLVLS
	CLOSE(UNIT=20)

C	READ IN DATA ON RANGE OF RG VALUES

	OPEN (UNIT=20,FILE='range.dat',STATUS='OLD')
	READ(20,*) RBEGIN
	READ(20,*) RDEL
	READ(20,*) NPTS
	CLOSE (UNIT=20)

C	START CALCULATIONS

	OPEN(UNIT=20,FILE='pseudo.dat',STATUS='NEW')
	OPEN(UNIT=21,FILE='select.dat',STATUS='NEW')
        OPEN(UNIT=22,FILE='pseudo.agr',STATUS='NEW')
	RBEGIN=RBEGIN/A0
	RDEL=RDEL/A0
	RG=RBEGIN-RDEL
	DO 800 I=1,NPTS
	RG=RG+RDEL

C       CONVERT TO ANGSTROMS FOR OUTPUT

	R=RG*A0
	WRITE(20,1006)
 1006	FORMAT(' ***')
	WRITE(20,1008)
 1008	FORMAT(' ')
	WRITE(20,1010) R
 1010	FORMAT(' R = ',F7.3)
	WRITE(20,1008)

C	Evaluate perturbation matrix

	DO 500 J=1,NLVLS
	DO 500 K=J,NLVLS

C	IDENTIFY QUANTUM NUMBERS OF LEVELS J AND K

	AN=QN(J,2)
	AL=QN(J,3)
	AJ=QN(J,4)
	AMJ=QN(J,5)
	ANP=QN(K,2)
	ALP=QN(K,3)
	AJP=QN(K,4)
	AMJP=QN(K,5)
	E(J,K)=EMAT(AN,AL,AJ,AMJ,ANP,ALP,AJP,AMJP)

C       CONVERT EIGENVALUES TO CM^-1

	E(J,K)=2.D0*ERYD*E(J,K)

C	Fold the matrix on the diagonal

	E(K,J)=E(J,K)
 500	CONTINUE

C	Add asymptotic atomic energies along the diagonal

	DO 510 IC=1,NLVLS
	E(IC,IC)=E(IC,IC)+QN(IC,1)
 510	CONTINUE

C	DIAGONALIZE ENERGY MATRIX

	EPS=1.D-2
	CALL JACOB(NLVLS,EPS,E,V)

C	OUTPUT DATA TO POTNL.DAT FILE
C	EQUATE DIAGONAL ENERGIES TO ARRAY FOR SORT

	DO 600 J=1,NLVLS
	ARRAY(J)=E(J,J)
 600	CONTINUE

C	SORT LEVELS FROM LOW TO HIGH AND STORE NUMBERS IN INRGY

	CALL SORT(NLVLS,ARRAY,INRGY)
	DO 700 J=1,NLVLS
	JE=INRGY(J)
	ENERGY=E(JE,JE)
        EPSEUDO(J)=ENERGY

C	SORT CONTRIBUTIONS TO EIGENVECTOR FOR THIS LEVEL

	DO 650 K=1,NLVLS
	ARRAY(K)=(V(K,JE))**2
 650	CONTINUE
	CALL SORT(NLVLS,ARRAY,IVCTR)
	NL1=NLVLS-1
	JV1=IVCTR(NLVLS)
	JV2=IVCTR(NL1)

C	JV1 AND JV2 ARE THE MOST SIGNIFICANT EIGENVECTORS

	PRCNT1=V(JV1,JE)
	PRCNT1=PRCNT1**2
	PRCNT2=V(JV2,JE)
	PRCNT2=PRCNT2**2
	WRITE(20,2000) ENERGY,JV1,PRCNT1,JV2,PRCNT2
 2000	FORMAT(1X,F10.3,2X,I3,2X,F6.4,2X,I3,2X,F6.4)
        IF(JVSELECT.EQ.JV1) THEN
          WRITE(21,*) R,ENERGY,PRCNT1
        END IF
 700	CONTINUE
	WRITE(20,2020)
	WRITE(20,2020)
 2020	FORMAT(' ')
        WRITE(22,2030) R, (EPSEUDO(K), K=NLOW,NHIGH)
 2030   FORMAT(1X,F10.3,10(2X,F10.3))
 800	CONTINUE
	CLOSE(UNIT=20)
	CLOSE(UNIT=21)
        CLOSE(UNIT=22)
	END

	SUBROUTINE SORT(N,A,I)

C	SORTS THE LIST A INTO ASCENDING VALUES
C	BY STORING THE INDEX OF THE ITEM IN THE LIST I
C
C	INITIALIZE THE LIST AT ZERO

        IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(100),I(100)

	DO 100 J=1,N
	I(J)=0
 100	CONTINUE

C	FIND THE SMALLEST ITEM REMAINING IN THE LIST AND
C	PLACE ITS INDEX IN I

	DO 200 J=1,N
	AMIN=200000.
	DO 190 K=1,N
	IF(A(K).GT.AMIN) GO TO 190

C	CHECK TO SEE IF THIS VALUE HAS BEEN LISTED

	DO 150 KP=1,J
	IF(K.EQ.I(KP)) GO TO 190
 150	CONTINUE
	AMIN=A(K)
	IMIN=K
 190	CONTINUE
	I(J)=IMIN
 200	CONTINUE
	RETURN
	END

	SUBROUTINE JACOB(N,EPS,A,B)

C	COMPUTES EIGENVALUES OF MATRIX A BY
C	CYCLIC JACOBI METHODS . . .
C	REQUIRES SUBROUTINE ROTATN
C
C	FROM "NUMERICAL ANALYSIS OF SYMMETRIC MATRICES"
C	BY H. R. SCHWARZ
C	QA 263 .S3313
C
C	ADAPTED TO DEC-10 BY J. KIELKOPF
C	TO INCLUDE EIGENVECTORS
C	FEBRUARY 14, 1980
C
C	N IS DIMENSION OF MATRIX
C	EPS IS TOLERANCE IN ABSOLUTE VALUE OF EIGENVALUES
C	A IS THE NXN ARRAY TO BE DIAGONALIZED
C	A IS RETURNED AS THE DIAGONAL ARRAY
C	B IS THE NXN ARRAY OF EIGENVECTORS
C	COLUMNS OF B ARE EIGENVECTORS CORRESPONDING TO
C	DIAGONAL ELEMENTS OF A

        IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(100,100),B(100,100)

C	Trap arithmetic overflows with ATOL

	ATOL=1.E-10

	DO 5 I=1,N
	DO 5 J=1,N
	B(I,J)=0.D0
	IF(I.EQ.J) B(I,J)=1.D0
 5	CONTINUE
	NLSS1=N-1

C	ESTABLISH SS
C	SS IS THE CRITERION OF SIZE OF OFF-DIAGONAL ELEMENTS

 10	SS=0.D0
	DO 20 I=1,NLSS1
	IPLS1=I+1
	DO 20 J=IPLS1,N
	SS=SS+A(I,J)**2
 20	CONTINUE

C	TEST WHETHER SS SUFFICIENTLY SMALL

	IF(2.D0*SS-EPS**2) 100,30,30

C	NO, IT IS NOT.  KEEP COMPUTING

 30	DO 80 IP=1,NLSS1
	IPPLS1=IP+1
	DO 80 IQ=IPPLS1,N

C	Trap overflows in THETA

C	IF(A(IP,IQ)) 40,80,40
	ATEST=DABS(A(IP,IQ))
	IF(ATEST.LT.ATOL) GO TO 80

C	APPLY IP-IQ ROTATION

 40	THETA=0.5D0*(A(IQ,IQ)-A(IP,IP))/A(IP,IQ)
	IF(THETA) 60,50,60
 50	T=1.
	GO TO 70
 60	T=1.D0/(THETA+DSIGN(1.D0,THETA)*DSQRT(1.D0+THETA**2))
 70	C=1.D0/DSQRT(1.D0+T*T)
	S=C*T
	KP=IP
	KQ=IQ
	CALL ROTATN(N,C,S,KP,KQ,A)
	CALL VECTOR(N,C,S,KP,KQ,B)
 80	CONTINUE
	GO TO 10
 100	CONTINUE

C	MATRIX IS NOW DIAGONALIZED
C	SET ELEMENTS OFF THE DIAGONAL TO ZERO

	DO 120 I=1,N
	DO 120 J=1,N
	IF(I.NE.J) A(I,J)=0.D0
 120	CONTINUE
	RETURN
	END

	SUBROUTINE ROTATN(N,C,S,IP,IQ,A)

C	THIS SUBROUTINE APPLIES JACOBI ROTATIONS TO THE MATRIX A
C	FINAL RESULTS ARE STORED IN MATRIX A AND RETURNED
C	ROTATION SIN (S) AND COS (C) ARE REQUIRED

        IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(100,100)

	H=C*C*A(IP,IP)-2.D0*C*S*A(IP,IQ)+S*S*A(IQ,IQ)
	G=S*S*A(IP,IP)+2.D0*C*S*A(IP,IQ)+C*C*A(IQ,IQ)
	A(IP,IQ)=C*S*(A(IP,IP)-A(IQ,IQ))+(C*C-S*S)*A(IP,IQ)
	A(IP,IP)=H
	A(IQ,IQ)=G
	IF(IP-1) 15,15,5
 5	IPLSS1=IP-1
	DO 10 J=1,IPLSS1
	H=C*A(J,IP)-S*A(J,IQ)
	A(J,IQ)=S*A(J,IP)+C*A(J,IQ)
	A(J,IP)=H
 10	CONTINUE
 15	IF(IQ-IP-1) 40,25,16
 16	IPPLS1=IP+1
	IQLSS1=IQ-1
	DO 20 J=IPPLS1,IQLSS1
	H=C*A(IP,J)-S*A(J,IQ)
	A(J,IQ)=S*A(IP,J)+C*A(J,IQ)
	A(IP,J)=H
 20	CONTINUE
 25	IF(N-IQ) 40,40,26
 26	IQPLS1=IQ+1
	DO 30 J=IQPLS1,N
	H=C*A(IP,J)-S*A(IQ,J)
	A(IQ,J)=S*A(IP,J)+C*A(IQ,J)
	A(IP,J)=H
 30	CONTINUE
 40	RETURN
	END

	SUBROUTINE VECTOR(N,C,S,IP,IQ,B)

C	THIS SUBROUTINE MODIFIES THE EIGENVECTOR ARRAY
C	FOR EACH ROTATION ABOUT IP,IQ
C
C	MODIFY COLUMNS IP AND IQ SIMULTANEOUSLY

        IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION B(100,100)

	DO 100 I=1,N
	H=B(I,IP)
	G=B(I,IQ)
	B(I,IP)=H*C-G*S
	B(I,IQ)=H*S+G*C
 100	CONTINUE
	RETURN
	END

	DOUBLE PRECISION FUNCTION EMAT(AN,AL,AJ,AMJ,ANP,ALP,AJP,AMJP)

C	COMPUTES <(SL)J,M|HP|(SL')J',M'>

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	EMAT=0.D0
	IF(AMJ.NE.AMJP) RETURN
	A1=AMJ-0.5D0
	A2=AMJ+0.5D0
	E1=U(AN,AL,A1,ANP,ALP,A1)
	E2=U(AN,AL,A2,ANP,ALP,A2)
	VC1L=VC(0.5D0,0.5D0,AL,A1,AJ,AMJ)
	VC1R=VC(0.5D0,0.5D0,ALP,A1,AJP,AMJ)
	VC2L=VC(0.5D0,-0.5D0,AL,A2,AJ,AMJ)
	VC2R=VC(0.5D0,-0.5D0,ALP,A2,AJP,AMJ)
	EMAT=VC1L*VC1R*E1+VC2L*VC2R*E2
 100	RETURN
	END

	DOUBLE PRECISION FUNCTION U(AN,AL,AM,ANP,ALP,AMP)

C       COMPUTES <AN,AL,AM|HP|ANP,ALP,AMP>
C       DIVIDE RADIAL REGIONS AND SELECT ROUTINES
C       INTEGRATES IN THREE REGIONS:
C         FROM THE ORIGIN TO THE INNER CONTACT WITH THE RG
C         THROUGH THE RG CONTACT
C         FROM OUTER RG CONTACT TO INFINITY

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	RMIN=DABS(RG-R0)
	RMAX=RG+R0
	A1=0.5D0
	B1=RMIN
	U=U2(A1,B1,AN,AL,AM,ANP,ALP,AMP)
	A1=RMIN
	B1=RMAX
	U=U+U2(A1,B1,AN,AL,AM,ANP,ALP,AMP)
	A1=RMAX
	B1=100.D0
	U=U+U2(A1,B1,AN,AL,AM,ANP,ALP,AMP)
	RETURN
	END

	DOUBLE PRECISION FUNCTION VC(AJ1,AM1,AJ2,AM2,AJ3,AM3)

C	J. KIELKOPF -- JANUARY 31, 1980
C	COMPUTES THE VECTOR-COUPLING COEFFICIENT

        IMPLICIT REAL*8 (A-H,O-Z)

	VC=TJ(AJ1,AM1,AJ2,AM2,AJ3,-AM3)
	ISUM=-AJ1+AJ2-AM3
	IPH=(-1)**ISUM
	VC=VC*IPH*DSQRT(2.D0*AJ3+1.D0)
	RETURN
	END

	DOUBLE PRECISION FUNCTION TJ(AJ1,AM1,AJ2,AM2,AJ3,AM3)

C	Computes the three-j symbol with these arguments
C	  using the formula of Rotenberg, p.2 or Cowan, p. 142
C	Values of arguments are real, but internal arithmetic
C	  is integral where necessary

        IMPLICIT REAL*8 (A-H,O-Z)

C	Note the J and M are are twice the actual J and M

	TJ=0.D0
	J1=2.D0*AJ1
	M1=2.D0*AM1
	J2=2.D0*AJ2
	M2=2.D0*AM2
	J3=2.D0*AJ3
        M3=2.D0*AM3

C	Check to see that triangular conditions and M-sum are OK

	CALL CHCK(J1,M1,J2,M2,J3,M3,IVAL)
	IF(IVAL.NE.1) RETURN

C	Compute three-J

C	Compute phase

	IPH=J1-J2-M3
	IPH=IPH/2
	IPH=(-1)**IPH
	PHASE=IPH

C	Compute prefactor

	K=J1+J2-J3
	K=K/2
	PRE=FACT(K)
	K=J1-J2+J3
	K=K/2
	PRE=PRE*FACT(K)
	K=-J1+J2+J3
	K=K/2
	PRE=PRE*FACT(K)
	K=J1+M1
	K=K/2
	PRE=PRE*FACT(K)
	K=J1-M1
	K=K/2
	PRE=PRE*FACT(K)
	K=J2+M2
	K=K/2
	PRE=PRE*FACT(K)
	K=J2-M2
	K=K/2
	PRE=PRE*FACT(K)
	K=J3+M3
	K=K/2
	PRE=PRE*FACT(K)
	K=J3-M3
	K=K/2
	PRE=PRE*FACT(K)
	K=J1+J2+J3+2
	K=K/2
	A=FACT(K)
	B=PRE
	PRE=B/A
	PRE=DSQRT(PRE)
	TJ=PHASE*PRE

C	Compute sum over all I consistent with factorial
C	Determine range of sum

	CALL RANGE(J1,M1,J2,M2,J3,M3,IMIN,IMAX)
	SUM=0.D0
	DO I=IMIN,IMAX
	  II=I
	  DENOM=FACT(II)
	  K=J1+J2-J3-2*I
	  K=K/2
	  DENOM=DENOM*FACT(K)
	  K=J1-M1-2*I
	  K=K/2
	  DENOM=DENOM*FACT(K)
	  K=J2+M2-2*I
	  K=K/2
	  DENOM=DENOM*FACT(K)
	  K=J3-J2+M1+2*I
	  K=K/2
	  DENOM=DENOM*FACT(K)
	  K=J3-J1-M2+2*I
	  K=K/2
	  DENOM=DENOM*FACT(K)
	  ANUM=(-1)**I
	  SUM=SUM+ANUM/DENOM
	END DO

C	Complete calculation and return

	TJ=TJ*SUM
	RETURN
	END

	SUBROUTINE CHCK(J1,M1,J2,M2,J3,M3,IVAL)

C	Check validity of parameters
C	Unsatisfied condition yields return with IVAL=0
C	J and M are 2 times the half-integral values

        IMPLICIT REAL*8 (A-H,O-Z)

	IVAL=0

C	Valid J Test

        IF(J1.LT.0) RETURN
	IF(J2.LT.0) RETURN
	IF(J3.LT.0) RETURN

C	Valid M test

	IF(M1.LT.(-J1)) RETURN
	IF(M2.LT.(-J2)) RETURN
	IF(M3.LT.(-J3)) RETURN
	IF(M1.GT.J1) RETURN
	IF(M2.GT.J2) RETURN
	IF(M3.GT.J3) RETURN

C	M-sum test

	IF((M1+M2+M3).NE.0) RETURN

C	Triangle conditions

	K1=J2+J3-J1
	K1=K1/2
	K2=J1+J3-J2
	K2=K2/2
	K3=J1+J2-J3
	K3=K3/2
	IF((K1.LT.0).OR.(K2.LT.0).OR.(K3.LT.0)) RETURN

C	Integral J test
C	J1+J2+J3 must be even

	J=J1+J2+J3
	JP=J/2
	JP=JP*2
	IF(J.NE.JP) RETURN

C	All conditions are satisfied

	IVAL=1
	RETURN
	END

	DOUBLE PRECISION FUNCTION FACT(K)

C	Calculate double precision real factorial of integer K

	IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION A(32)
	DATA KTOP,A(1)/1,1.D0/

C	KTOP is the argument of the last factorial calculated

	IF (K.EQ.0) THEN
	  FACT=1.D0
	ELSE IF (K.LE.KTOP) THEN
	  FACT=A(K)
	ELSE IF (K.LE.32) THEN
	  DO J=KTOP+1,K
	    RJ=J
	    A(J)=RJ*A(J-1)
	  END DO
	  KTOP=K
	  FACT=A(K)
	ELSE IF (K.GT.32) THEN
	  WRITE(5,5000)
 5000	  FORMAT(' Argument of factorial too large in FACT.')
	  FACT=1.D0
	ENDIF
	RETURN
	END

	SUBROUTINE RANGE(J1,M1,J2,M2,J3,M3,IMIN,IMAX)

C	DETERMINES RANGE OF SUM IN THREE-J CALCULATION
C	JI'S AND MI'S ARE TWICE THE REAL VALUES

        IMPLICIT REAL*8 (A-H,O-Z)

	DIMENSION I(5)
	I(1)=J1+J2-J3
	I(2)=J1-M1
	I(3)=J2+M2
	I(4)=J3-J2+M1
	I(5)=J3-J1-M2
	DO 100 J=1,5
	I(J)=I(J)/2
 100	CONTINUE
	IMAX=MIN0(I(1),I(2),I(3))
	IMIN=-MIN0(I(4),I(5))
	IF(IMIN.LT.0) IMIN=0
	IF(IMAX.GE.IMIN) GO TO 1000
	ITMP=IMAX
	IMAX=IMIN
	IMIN=ITMP
 1000	CONTINUE
	RETURN
	END

	DOUBLE PRECISION FUNCTION U2(A1,B1,AN,AL,AM,ANP,ALP,AMP)

C	COMPUTES THE VALUE OF THE SUM OVER POSSIBLE LPP'S
C	OF THE MATRIX ELEMENTS
C	<AN,AL,AM|HP(LPP)|ANP,ALP,AMP>
C	WHERE A1 AND B1 DEFINE LIMITS OF RADIAL INTEGRATION

        IMPLICIT REAL*8 (A-H,O-Z)

	JMAX=AL+ALP+1.D0
	U2=0.D0
	DO 500 J=1,JMAX
	LPP=J-1
	ALPP=LPP
	VALUE=PLME(AL,AM,ALPP,ALP,AMP)
	IF(VALUE.EQ.(0.D0)) GO TO 500
	VALUE=VALUE*GAUSSL(A1,B1,AN,AL,ALPP,ANP,ALP)
	U2=U2+VALUE
 500	CONTINUE
	RETURN
	END

	DOUBLE PRECISION FUNCTION WF(AN,AL,AM,RE,THETA)

C       Computes complete angular and radial alkali atomic wavefunction
C       WF and RE in atomic units
C       For reference, not used in this routine in this form

        IMPLICIT REAL*8 (A-H,O-Z)

	RADVAL=F(AN,AL,RE)
	ANGVAL=Y(AL,AM,THETA)
	WF=RADVAL*ANGVAL
	RETURN
	END

	DOUBLE PRECISION FUNCTION F(AN,AL,RE)

C       Bates-Damgaard radial wavefunctions in atomic units

        IMPLICIT REAL*8 (A-H,O-Z)

	RHO=2.D0*RE/AN
	A=1.D0
	SUM=0.D0
	ITMAX=AN-0.5D0
	IF (ITMAX.EQ.0) GO TO 110
	DO 100 I=1,ITMAX
	AI=I
	A=A*(AL*(AL+1.D0)-(AN-AI)*(AN-AI+1.D0))
	A=A/AI
	S=A/RHO**I
	SUM=SUM+S
 100	CONTINUE
 110	SUM=SUM+1.D0
	F=RHO**AN*DEXP(-RHO/2.D0)*SUM
	ANORM=AN**2*GAMMA(AN+AL+1.D0)*GAMMA(AN-AL)
	ANORM=1.D0/DSQRT(ANORM)
	F=ANORM*F
 120	CONTINUE
	F=F/RE
	RETURN
	END

	DOUBLE PRECISION FUNCTION PLME(ALP,AMLP,ALPP,AL,AML)

C	COMPUTES THE MATRIX ELEMENT  <L'ML'|P(L")|LML>
C	REQUIRES THE THREE-J SUBROUTINE

        IMPLICIT REAL*8 (A-H,O-Z)

	PLME=0.D0
	IF(AMLP.NE.AML) GO TO 1000
	M=AML
	IPH=(-1)**M
	PLME=IPH
	PLME=DSQRT(2.D0*ALP+1.D0)*DSQRT(2.D0*AL+1.D0)*PLME
	AL1=ALP
	AL2=ALPP
	AL3=AL
	AM1=-AML
	AM2=0.D0
	AM3=AML
	PLME=PLME*TJ(AL1,AM1,AL2,AM2,AL3,AM3)
	AM1=0.D0
	AM2=0.D0
	AM3=0.D0
	PLME=PLME*TJ(AL1,AM1,AL2,AM2,AL3,AM3)
 1000	CONTINUE
	RETURN
	END

	DOUBLE PRECISION FUNCTION GAUSSL(A1,B1,AN,AL,ALPP,ANP,ALP)

C	Computes RE-integral

        IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION X(24),Y(24),F(24),W(24)

	X(1)=.064056892862605D0
	X(2)=.191118867473616D0
	X(3)=.315042679696163D0
	X(4)=.433793507626045D0
	X(5)=.545421471688839D0
	X(6)=.648093651936975D0
	X(7)=.740124191578554D0
	X(8)=.820001985973902D0
	X(9)=.886415527004401D0
	X(10)=.938274552002732D0
	X(11)=.974728555971309D0
	X(12)=.995187219997021D0
	W(1)=.127938195346752D0
	W(2)=.125837456346828D0
	W(3)=.121670472927803D0
	W(4)=.115505668053725D0
	W(5)=.107444270115965D0
	W(6)=.097618652104113D0
	W(7)=.086190161531953D0
	W(8)=.073346481411080D0
	W(9)=.059298584915436D0
	W(10)=.044277438817419D0
	W(11)=.028531388628933D0
	W(12)=.012341229799987D0
	DO 110 J=1,12
	K=J+12
	X(K)=-X(J)
	W(K)=W(J)
 110	CONTINUE
	SUM=0.D0
	DO 120 J=1,24
	Y(J)=0.5D0*(B1-A1)*X(J)+0.5D0*(B1+A1)
	RE=Y(J)
	F(J)=HL(AN,AL,ALPP,ANP,ALP,RE)
	SUM=SUM+W(J)*F(J)
 120	CONTINUE
	SUM=SUM*0.5D0*(B1-A1)
	GAUSSL=SUM
	RETURN
	END

	DOUBLE PRECISION FUNCTION HL(AN,AL,ALPP,ANP,ALP,RE)

        IMPLICIT REAL*8 (A-H,O-Z)

	PSI=F(AN,AL,RE)
	PSIP=F(ANP,ALP,RE)
	OPER=HPL(ALPP,RE)

C	ALL OTHER VARIABLES REQUIRED FOR HPL ARE IN COMMON

        HL=PSI*OPER*PSIP*RE*RE
 100    CONTINUE
	RETURN
	END

	DOUBLE PRECISION FUNCTION GAMMA(Y)

C	COMPUTES GAMMA FUNCTION
C	BASED ON ABRAMOWITZ AND STEGUN P. 257

        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION B(8)

	X=Y
	B(1)=-.577191652D0
	B(2)=.988205891D0
	B(3)=-.897056937D0
	B(4)=.918206857D0
	B(5)=-.756704078D0
	B(6)=.482199394D0
	B(7)=-.193527818D0
	B(8)=.035868343D0
C	DETERMINE RANGE OF ARGUMENT AND MULTIPLIER
	GAM=0.D0
	GAMMA=0.D0
	IF(X.GT.(0.D0)) GO TO 50
	WRITE(5,1000)
 1000	FORMAT(' ATTEMPT TO COMPUTE GAMMA OF NEG. OR ZERO ARG.')
	RETURN
 50	CONTINUE
	IF(((0.D0).LE.X).AND.(X.LT.(1.D0))) GO TO 100
	IF(((1.D0).LE.X).AND.(X.LT.(2.D0))) GO TO 200
	GO TO 300
 100	CONTINUE
	A=1.D0/X
	Z=X
	GO TO 500
 200	A=1.D0
	Z=X-1.D0
	GO TO 500
 300	A=1.D0
	Z=X
 310	Z=Z-1.D0
	A=A*Z
	IF(Z.GT.(2.D0)) GO TO 310
	Z=Z-1.D0
 500	GAM=1.D0
	DO 750 I=1,8
	GAM=GAM+B(I)*Z**I
 750	CONTINUE
	GAM=GAM*A
	GAMMA=GAM
	RETURN
	END

	DOUBLE PRECISION FUNCTION Y(AL,AM,THETA)

C	COMPUTES THE SPHERICAL HARMONIC YLM FOR L<=3
C	SUPRESSES DEPENDENCE ON PHI (EXP(PHI)=1.)
C	TESTS THAT AL AND ML ARE INTEGRAL
C	TESTS THAT THETA IS WITHIN RANGE

        IMPLICIT REAL*8 (A-H,O-Z)

	Y=0.D0
	L=AL
	AP=L
	IF(AP.NE.AL) GO TO 1000
	M=AM
	AP=M
	IF(AP.NE.AM) GO TO 1000
	PI=3.14159265359D0
	IF((THETA.LT.(0.D0)).OR.(THETA.GT.PI)) GO TO 1000
	IF((L.GT.3).OR.(L.LT.0)) GO TO 1000
	IF((M.LT.-L).OR.(M.GT.L)) GO TO 1000
C	COMPUTE Y FOR L LESS THAN 4
	SGNM=1.D0
	IF(M.NE.0) SGNM=AM/DABS(AM)
	MABS=DABS(AM)
	J=L+1
	GO TO (100,200,300,400) J
 100	CONTINUE
C	COMPUTE Y FOR L=0
	Y=2.D0*DSQRT(PI)
	Y=1.D0/Y
	RETURN
 200	CONTINUE
C	COMPUTE Y FOR L=1
	IF(M.NE.0) GO TO 210
	Y=0.5D0*DSQRT(3.D0/PI)*DCOS(THETA)
	RETURN
 210	CONTINUE
	Y=-SGNM*0.5D0*DSQRT(3.D0/(2.D0*PI))*DSIN(THETA)
	RETURN
 300	CONTINUE
C	COMPUTE Y FOR L=2
	IF(M.NE.0) GO TO 310
	Y=0.25D0*DSQRT(5.D0/PI)
	Y=Y*(2.D0*DCOS(THETA)*DCOS(THETA)-DSIN(THETA)*DSIN(THETA))
	RETURN
 310	CONTINUE
	IF(MABS.NE.1) GO TO 320
	Y=-SGNM*0.5D0*DSQRT(15.D0/(2.D0*PI))*DCOS(THETA)*DSIN(THETA)
	RETURN
 320	CONTINUE
	Y=0.25D0*DSQRT(15.D0/(2.D0*PI))*(DSIN(THETA))**2.D0
	RETURN
 400	CONTINUE
C	COMPUTE Y FOR L=3
	IF(MABS.NE.0) GO TO 410
	Y=2.D0*(DCOS(THETA))**3.D0-3.D0*DCOS(THETA)*(DSIN(THETA))**2.D0
	Y=Y*0.25D0*DSQRT(7.D0/PI)
	RETURN
 410	CONTINUE
	IF(MABS.NE.1) GO TO 420
	Y=(5.D0*(DCOS(THETA))**2.D0-1.D0)*DSIN(THETA)
	Y=-0.125D0*SGNM*DSQRT(21.D0/PI)*Y
	RETURN
 420	CONTINUE
	IF(MABS.NE.2) GO TO 430
	Y=DCOS(THETA)*DSIN(THETA)*DSIN(THETA)
	Y=Y*0.25D0*DSQRT(52.5D0/PI)
	RETURN
 430	CONTINUE
	Y=DSIN(THETA)
	Y=Y**3.D0
	Y=-Y*SGNM*0.125D0*DSQRT(35.D0/PI)
	RETURN
 1000	CONTINUE
	RETURN
	END

	DOUBLE PRECISION FUNCTION HPL(AL,RE)

C	Compute total of interactions using RMP 1982  Eq. (192)
C       Add Gombas contact term based on perturber electron density
C       Called within HL(AN,AL,ALPP,ANP,ALP,RE)

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	CHI=(RG*RG+RE*RE)/(2.D0*RG*RE)

C       Calculate induced dipole potential
C         when electron is outside cutoff R0 around the RG
C       Based on expansion of step function in spherical harmonics

	RG2=RG*RG
        RG3=RG2*RG
        RG4=RG3*RG
        HPL=SMLF(0.D0,AL,CHI,RE)
	HPL=HPL-2.D0*RG3*SMLF(-1.5D0,AL,CHI,RE)
	HPL=HPL+RG4*SMLF(-2.D0,AL,CHI,RE)
	ALM1=AL-1.D0
	ALP1=AL+1.D0
	TERM=0.D0
	IF(AL.EQ.(0.D0)) GO TO 75
	TERM=AL*SMLF(-1.5D0,ALM1,CHI,RE)/(2.D0*AL-1.D0)
 75	CONTINUE
	TERM=TERM+ALP1*SMLF(-1.5D0,ALP1,CHI,RE)/(2.D0*AL+3.D0)
	TERM=TERM*2.D0*RE*RG2
	HPL=HPL+TERM
	HPL=-0.5D0*ALPHA*HPL/RG4

C	Add Gombas contact term for collisions inside R0
C       R0 and GL are in atomic units
C       This form uses a perturber core electron density parameter

        IF(AL.EQ.(0.D0)) THEN
	TERM=1.D0-SMLF(0.D0,AL,CHI,RE)
        ELSE
        TERM=-SMLF(0.D0,AL,CHI,RE)
        END IF
        GL=1.8415843D0*ANS23*TERM/R0**2
        HPL=HPL+GL

	RETURN
	END

	DOUBLE PRECISION FUNCTION HPLF(AL,RE)

C	Compute total of interactions using RMP 1982  Eq. (192)
C       Add Fermi contact term based on scattering length SL
C       Optional version of HPL function

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	CHI=(RG*RG+RE*RE)/(2.D0*RG*RE)

C       Calculate induced dipole potential
C         when electron is outside cutoff R0 around the RG
C       Based on expansion of step function in spherical harmonics

	RG2=RG*RG
        RG3=RG2*RG
        RG4=RG3*RG
        HPLF=SMLF(0.D0,AL,CHI,RE)
	HPLF=HPLF-2.D0*RG3*SMLF(-1.5D0,AL,CHI,RE)
	HPLF=HPLF+RG4*SMLF(-2.D0,AL,CHI,RE)
	ALM1=AL-1.D0
	ALP1=AL+1.D0
	TERM=0.D0
	IF(AL.EQ.(0.D0)) GO TO 75
	TERM=AL*SMLF(-1.5D0,ALM1,CHI,RE)/(2.D0*AL-1.D0)
 75	CONTINUE
	TERM=TERM+ALP1*SMLF(-1.5D0,ALP1,CHI,RE)/(2.D0*AL+3.D0)
	TERM=TERM*2.D0*RE*RG2
	HPLF=HPLF+TERM
	HPLF=-0.5D0*ALPHA*HPLF/RG4

C	Add Fermi contact term inside cutoff here
C       R0 and SL are in atomic units at this point
C       This form uses a scattering length parameter

        IF(AL.EQ.(0.D0)) THEN
	TERM=1.D0-SMLF(0.D0,AL,CHI,RE)
        ELSE
        TERM=-SMLF(0.D0,AL,CHI,RE)
        END IF
        GL=1.5D0*SL*TERM/R0**3
        HPLF=HPLF+GL

	RETURN
	END

	DOUBLE PRECISION FUNCTION HPLB(AL,RE)

C       Compute total of interactions using Baylis 1969 Eq. A10
C       Optional version of HPL

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

C       Explicitly define the scattering length unless it is in common

	SL=1.D0

C       Set CHI for this RE and RG

        CHI=(RG*RG+RE*RE)/(2.D0*RG*RE)

C       Calculate induced dipole potential
C         when electron is outside cutoff R0 around the RG
C       Based on expansion of step function in spherical harmonics

	HPLB=0.D0
	IF(AL.NE.(0.D0)) GO TO 50
	HPLB=1.D0/RG**4+1.D0/R0**4
 50	CONTINUE
	HPLB=HPLB-SMLF(0.D0,AL,CHI,RE)/R0**4
	HPLB=HPLB-2.D0*SMLF(-1.5D0,AL,CHI,RE)/RG
	HPLB=HPLB+SMLF(-2.D0,AL,CHI,RE)
	ALM1=AL-1.D0
	ALP1=AL+1.D0
	TERM=0.D0
	IF(AL.EQ.(0.D0)) GO TO 75
	TERM=AL*SMLF(-1.5D0,ALM1,CHI,RE)/(2.D0*AL-1.D0)
 75	CONTINUE
	TERM=TERM+ALP1*SMLF(-1.5D0,ALP1,CHI,RE)/(2.D0*AL+3.D0)
	TERM=TERM*2.D0*RE/RG**2
	HPLB=HPLB+TERM
	HPLB=-0.5D0*ALPHA*HPLB

C	Add Fermi contact term inside cutoff here
C       R0 and SL are in atomic units at this point

        IF(AL.EQ.(0.D0)) THEN
	TERM=1.D0-SMLF(0.D0,AL,CHI,RE)
        ELSE
        TERM=-SMLF(0.D0,AL,CHI,RE)
        END IF
        GL=1.5D0*SL*TERM/R0**3
        HPLB=HPLB+GL

	RETURN
	END

	DOUBLE PRECISION FUNCTION SMLF(Q,AL,CHI,RE)

C	COMPUTES THE VALUE OF BAYLIS EQ. (A6)

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	RLIM=DABS(RG-RE)
	RMAX=RG+RE
	CHI2=CHI-R0*R0/(2.D0*RE*RG)
	IF(R0.LE.RLIM) XI0=1.D0
	IF((RLIM.LT.R0).AND.(R0.LT.RMAX)) XI0=CHI2
	IF(RMAX.LE.R0) XI0=-1.D0
	L=AL
	IF(L.NE.0) GO TO 100
	SMLF=SMLFQ0(Q,CHI,RE,XI0)
	RETURN
 100	IF(L.NE.1) GO TO 200
	SMLF=SMLFQ1(Q,CHI,RE,XI0)
	RETURN
 200	CONTINUE

C	IF(L.GE.2) APPLY RECURSION RELATIONS

	F0=SMLFQ0(Q,CHI,RE,XI0)
	F1=SMLFQ1(Q,CHI,RE,XI0)
	K=1
	CKM1=F0
	CK=F1
 250	CONTINUE
	AK=K
	AKP1=AK+1.D0
	AKM1=AK-1.D0
	CKP1=PL(AKP1,XI0)-PL(AKM1,XI0)
	CKP1=CKP1*R0**(2.D0*Q+2.D0)
	CKP1=CKP1/(4.D0*RG*RE)
	CKP1=CKP1+(AK-Q-1.D0)*CKM1/(2.D0*AK-1.D0)
	CKP1=CHI*CK-CKP1
	CKP1=CKP1*(2.D0*AK+3.D0)/(AK+Q+2.D0)
	KP1=K+1
	IF(KP1.EQ.L) GO TO 300
	K=K+1
	CKM1=CK
	CK=CKP1
	GO TO 250
 300	CONTINUE
	SMLF=CKP1
	RETURN
	END

	DOUBLE PRECISION FUNCTION SMLFQ0(Q,CHI,RE,XI0)

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	IF(Q.NE.(-1.D0)) GO TO 100
	ARG=(CHI+1.D0)/(CHI-XI0)
	ARG=DABS(ARG)
	SMLFQ0=DLOG(ARG)
	SMLFQ0=SMLFQ0/(4.D0*RE*RG)
	RETURN
 100	CONTINUE
	SMLFQ0=(CHI+1.D0)**(Q+1.D0)-(CHI-XI0)**(Q+1.D0)
	SMLFQ0=SMLFQ0*(2.D0*RE*RG)**Q
	SMLFQ0=SMLFQ0/(2.D0*(Q+1.D0))
	RETURN
	END

	FUNCTION SMLFQ1(Q,CHI,RE,XI0)

        IMPLICIT REAL*8 (A-H,O-Z)
	COMMON ALPHA,RG,R0,ANS23

	IF(Q.NE.(-2.D0)) GO TO 100
	TERM=SMLFQ0(Q,CHI,RE,XI0)
	SMLFQ1=3.D0*CHI*TERM
	ARG=DABS((CHI+1.D0)/(CHI-XI0))
	TERM=1.5D0*DLOG(ARG)/(2.D0*RE*RG)**2
	SMLFQ1=SMLFQ1-TERM
	RETURN

 100	CONTINUE
	TERM=SMLFQ0(Q,CHI,RE,XI0)
	SMLFQ1=3.D0*CHI*TERM
	TERM=(CHI+1.D0)**(Q+2.D0)-(CHI-XI0)**(Q+2.D0)
	TERM=3.D0*TERM*(2.D0*RE*RG)**Q/(2.D0*(Q+2.D0))
	SMLFQ1=SMLFQ1-TERM
	RETURN
	END

	FUNCTION PL(AL,XI)

C	COMPUTES THE VALUE OF THE AL LEGENDRE POLYNOMIAL

        IMPLICIT REAL*8 (A-H,O-Z)

	P0=1.D0
	P1=XI
	L=AL
	PL=0.D0
	IF(L.LT.0) RETURN
	IF(L.NE.0) GO TO 100
	PL=P0
	RETURN
 100	IF(L.NE.1) GO TO 200
	PL=P1
	RETURN
 200	CONTINUE

C	IF(L.GE.2) APPLY RECURSION RELATIONS

	K=1
	CKM1=P0
	CK=P1
 250	CONTINUE
	AK=K
	CKP1=(2.D0*AK+1.D0)*XI*CK-AK*CKM1
	CKP1=CKP1/(AK+1.D0)
	KP1=K+1
	IF(KP1.EQ.L) GO TO 300
	K=K+1
	CKM1=CK
	CK=CKP1
	GO TO 250
 300	CONTINUE
	PL=CKP1
	RETURN
	END


       SUBROUTINE W3FB04(ALAT,ALONG,XMESHL,ORIENT,XI,XJ)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FB04         LATITUDE, LONGITUDE TO GRID COORDINATES
C   AUTHOR: MCDONELL,J.      ORG: W345       DATE: 86-07-17
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH FROM THE
C   NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO THE GRID (I,J)
C   COORDINATE SYSTEM OVERLAID ON A POLAR STEREOGRAPHIC MAP PRO-
C   JECTION TRUE AT 60 DEGREES N OR S LATITUDE. W3FB04 IS THE REVERSE
C   OF W3FB05.
C
C PROGRAM HISTORY LOG:
C   86-07-17  MCDONELL,J.
C   88-06-07  R.E.JONES   CLEAN UP CODE, TAKE OUT GOTO, USE THEN, ELSE
C   89-11-02  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB04 (ALAT, ALONG, XMESHL, ORIENT, XI, XJ)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALAT   ARG LIST  LATITUDE IN DEGREES (<0 IF SH)
C     ALONG  ARG LIST  WEST LONGITUDE IN DEGREES
C     XMESHL ARG LIST  MESH LENGTH OF GRID IN KM AT 60 DEG LAT(<0 IF SH)
C                   (190.5 LFM GRID, 381.0 NH PE GRID,-381.0 SH PE GRID)
C     ORIENT ARG LIST  ORIENTATION WEST LONGITUDE OF THE GRID
C                   (105.0 LFM GRID, 80.0 NH PE GRID, 260.0 SH PE GRID)
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     XI     ARG LIST  I OF THE POINT RELATIVE TO NORTH OR SOUTH POLE
C     XJ     ARG LIST  J OF THE POINT RELATIVE TO NORTH OR SOUTH POLE
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     COS SIN                                                 SYSLIB
C
C   REMARKS: ALL PARAMETERS IN THE CALLING STATEMENT MUST BE
C     REAL. THE RANGE OF ALLOWABLE LATITUDES IS FROM A POLE TO
C     30 DEGREES INTO THE OPPOSITE HEMISPHERE.
C     THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0)
C     AT THE POLE IN EITHER HEMISPHERE, SO IF THE USER'S GRID HAS ITS
C     ORIGIN AT A POINT OTHER THAN THE POLE, A TRANSLATION IS NEEDED
C     TO GET I AND J. THE GRIDLINES OF I=CONSTANT ARE PARALLEL TO A
C     LONGITUDE DESIGNATED BY THE USER. THE EARTH'S RADIUS IS TAKEN
C     TO BE 6371.2 KM.
C
C WARNING:  THIS CODE IS NOT VECTORIZED. TO VECTORIZE TAKE IT AND
C           SUBROUTINE IT CALLS AND PU THEM IN LINE.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      DATA  RADPD /.01745329/
      DATA  EARTHR/6371.2/
C
      RE    = (EARTHR * 1.86603) / XMESHL
      XLAT  = ALAT * RADPD
C
      IF (XMESHL.GE.0.) THEN
        WLONG = (ALONG + 180.0 - ORIENT) * RADPD
        R     = (RE * COS(XLAT)) / (1.0 + SIN(XLAT))
        XI    =   R * SIN(WLONG)
        XJ    =   R * COS(WLONG)
      ELSE
        RE    = -RE
        XLAT  = -XLAT
        WLONG = (ALONG - ORIENT) * RADPD
        R     = (RE * COS(XLAT)) / (1.0 + SIN(XLAT))
        XI    =   R * SIN(WLONG)
        XJ    =  -R * COS(WLONG)
      ENDIF
C
      RETURN
      END


module pmmf_hpaf_case1_blended
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FOUR, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    use mod_blending_functions,                 only: transition_polynomial_order5
    implicit none
    private

    !>  hpaf_case1_blended mesh motion.
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: hpaf_case1_blended_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type hpaf_case1_blended_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(hpaf_case1_blended_pmmf),  intent(inout)  :: self

        !
        ! Set function name
        !
        call self%set_name("hpaf_case1_blended")

        !
        ! Set function options to default settings
        !
        call self%add_option('blend_rigid_radius', 10.0_rk) !Within this radius, the mesh is rigidly displaced
        call self%add_option('blend_transition_length', 50.0_rk) !Length scale where the mesh is blended between RB and fixed

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(hpaf_case1_blended_pmmf),     intent(inout)  :: self
        real(rk),                       intent(in)  :: time
        real(rk),                  intent(in)  :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                    :: val(3)

        real(rk)                                    :: b1, b2, b3, &
                                                        A2, A3, x0, y0, x_ale, y_ale, &
                                                        xc, yc, height, theta, &
                                                        blend_rigid_radius, blend_transition_length, &
                                                        blend_dist, blend_val

        blend_rigid_radius = self%get_option_value('blend_rigid_radius')
        blend_transition_length = self%get_option_value('blend_transition_length')

        blend_dist = (sqrt(node(1)**TWO+node(2)**TWO)-blend_rigid_radius)/blend_transition_length

        if (blend_dist < ZERO) then
            blend_val = ZERO
        else if (blend_dist > ONE) then
            blend_val = ONE
        else
            blend_val =  transition_polynomial_order5(blend_dist)
        end if

        b1 = time**TWO*(time**TWO-4._rk*time+4._rk)
        b2 = time**TWO*(3._rk-time)/4._rk
        b3 = time**THREE*(-8._rk*time**THREE+51._rk*time**TWO-111._rk*time+84._rk)/16._rk

        !Case 1
        if (time <= TWO) height = b2
        if (time >  TWO) height = ONE
        theta = ZERO

!        !Case 2
!        height = b2
!        A2 = (60._rk*PI/180._rk)
!        theta = A2*b1
!
!        !Case 3
!        height = b3
!        A3 = (80._rk*PI/180._rk)
!        theta = A3*b1

        !Center of motion nodeinates
        xc = 1._rk/3._rk
        yc = 0._rk

        !Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        !Rotate about the center of motion
        x_ale =  cos(theta)*(x0-xc)+sin(theta)*(y0-yc) + xc
        y_ale = -sin(theta)*(x0-xc)+cos(theta)*(y0-yc) + yc

        !Translate vertically
        y_ale = y_ale + height

        val(1) = node(1)*blend_val+x_ale*(ONE-blend_val)
        val(2) = node(2)*blend_val+y_ale*(ONE-blend_val)
        val(3) = node(3)

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(hpaf_case1_blended_pmmf),     intent(inout)  :: self
        real(rk),                       intent(in)  :: time
        real(rk),                  intent(in)  :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                   :: val(3)
        real(rk)                                    :: b1, b2, b3, db1dt, db2dt, db3dt, &
                                                        A2, A3, x0, y0, x_ale, y_ale, &
                                                        xc, yc, height, theta, dheightdt, dthetadt, &
                                                        blend_rigid_radius, blend_transition_length, &
                                                        blend_dist, blend_val

        blend_rigid_radius = self%get_option_value('blend_rigid_radius')
        blend_transition_length = self%get_option_value('blend_transition_length')

        blend_dist = (sqrt(node(1)**TWO+node(2)**TWO)-blend_rigid_radius)/blend_transition_length

        if (blend_dist < ZERO) then
            blend_val = ZERO
        else if (blend_dist > ONE) then
            blend_val = ONE
        else
            blend_val =  transition_polynomial_order5(blend_dist)
        end if

        b1 = time**TWO*(time**TWO-4._rk*time+4._rk)
        b2 = time**TWO*(3._rk-time)/4._rk
        b3 = time**THREE*(-8._rk*time**THREE+51._rk*time**TWO-111._rk*time+84._rk)/16._rk

        db1dt = TWO*time*(time**TWO-4._rk*time+4._rk) + &
                time**TWO*(TWO*time-4._rk)
        db2dt = TWO*time*(3._rk-time)/4._rk + &
                time**TWO*(-1._rk)/4._rk
        db3dt = THREE*time**TWO*(-8._rk*time**THREE+51._rk*time**TWO-111._rk*time+84._rk)/16._rk + &
                time**THREE*(-24._rk*time**TWO+102._rk*time-111._rk)/16._rk

        !Case 1
        height = b2
        theta = ZERO
        dheightdt = db2dt
        dthetadt = ZERO

!        !Case 2
!        height = b2
!        A2 = (60._rk*PI/180._rk)
!        theta = A2*b1
!        dheightdt = db2dt
!        dthetadt = A2*db1dt
!
!        !Case 3
!        height = b3
!        A3 = (80._rk*PI/180._rk)
!        theta = A3*b1
!        dheightdt = db3dt
!        dthetadt = A3*db1dt

        !Center of motion nodeinates
        xc = 1._rk/3._rk
        yc = 0._rk

        !Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        !Rotate about the center of motion
        x_ale = -sin(theta)*dthetadt*(x0-xc)+cos(theta)*dthetadt*(y0-yc)
        y_ale = -cos(theta)*dthetadt*(x0-xc)-sin(theta)*dthetadt*(y0-yc)

        !Translate vertically
        y_ale = y_ale + dheightdt

        if (time > TWO) x_ale = ZERO
        if (time > TWO) y_ale = ZERO

        val(1) = (ONE-blend_val)*x_ale
        val(2) = (ONE-blend_val)*y_ale
        val(3) = ZERO

    end function compute_vel
    !**********************************************************************************

end module pmmf_hpaf_case1_blended


!*==zgetsqrhrt.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZGETSQRHRT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGETSQRHRT + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGETSQRHRT( M, N, MB1, NB1, NB2, A, LDA, T, LDT, WORK,
!      $                       LWORK, INFO )
!       IMPLICIT NONE
!
!       .. Scalar Arguments ..
!       INTEGER           INFO, LDA, LDT, LWORK, M, N, NB1, NB2, MB1
!       ..
!       .. Array Arguments ..
!       COMPLEX*16        A( LDA, * ), T( LDT, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGETSQRHRT computes a NB2-sized column blocked QR-factorization
!> of a complex M-by-N matrix A with M >= N,
!>
!>    A = Q * R.
!>
!> The routine uses internally a NB1-sized column blocked and MB1-sized
!> row blocked TSQR-factorization and perfors the reconstruction
!> of the Householder vectors from the TSQR output. The routine also
!> converts the R_tsqr factor from the TSQR-factorization output into
!> the R factor that corresponds to the Householder QR-factorization,
!>
!>    A = Q_tsqr * R_tsqr = Q * R.
!>
!> The output Q and R factors are stored in the same format as in ZGEQRT
!> (Q is in blocked compact WY-representation). See the documentation
!> of ZGEQRT for more details on the format.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A. M >= N >= 0.
!> \endverbatim
!>
!> \param[in] MB1
!> \verbatim
!>          MB1 is INTEGER
!>          The row block size to be used in the blocked TSQR.
!>          MB1 > N.
!> \endverbatim
!>
!> \param[in] NB1
!> \verbatim
!>          NB1 is INTEGER
!>          The column block size to be used in the blocked TSQR.
!>          N >= NB1 >= 1.
!> \endverbatim
!>
!> \param[in] NB2
!> \verbatim
!>          NB2 is INTEGER
!>          The block size to be used in the blocked QR that is
!>          output. NB2 >= 1.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>
!>          On entry: an M-by-N matrix A.
!>
!>          On exit:
!>           a) the elements on and above the diagonal
!>              of the array contain the N-by-N upper-triangular
!>              matrix R corresponding to the Householder QR;
!>           b) the elements below the diagonal represent Q by
!>              the columns of blocked V (compact WY-representation).
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] T
!> \verbatim
!>          T is COMPLEX*16 array, dimension (LDT,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.
!> \endverbatim
!>
!> \param[in] LDT
!> \verbatim
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB2.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          The dimension of the array WORK.
!>          LWORK >= MAX( LWT + LW1, MAX( LWT+N*N+LW2, LWT+N*N+N ) ),
!>          where
!>             NUM_ALL_ROW_BLOCKS = CEIL((M-N)/(MB1-N)),
!>             NB1LOCAL = MIN(NB1,N).
!>             LWT = NUM_ALL_ROW_BLOCKS * N * NB1LOCAL,
!>             LW1 = NB1LOCAL * N,
!>             LW2 = NB1LOCAL * MAX( NB1LOCAL, ( N - NB1LOCAL ) ),
!>          If LWORK = -1, then a workspace query is assumed.
!>          The routine only calculates the optimal size of the WORK
!>          array, returns this value as the first entry of the WORK
!>          array, and no error message related to LWORK is issued
!>          by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2020
!
!> \ingroup comlpex16OTHERcomputational
!
!> \par Contributors:
!  ==================
!>
!> \verbatim
!>
!> November 2020, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZGETSQRHRT(M,N,Mb1,Nb1,Nb2,A,Lda,T,Ldt,Work,Lwork,Info)
      IMPLICIT NONE
!*--ZGETSQRHRT182
!
!  -- LAPACK computational routine (version 3.10.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2020
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldt , Lwork , M , N , Nb1 , Nb2 , Mb1
!     ..
!     .. Array Arguments ..
      COMPLEX*16 A(Lda,*) , T(Ldt,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 CONE
      PARAMETER (CONE=(1.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER i , iinfo , j , lw1 , lw2 , lwt , ldwt , lworkopt ,       &
     &        nb1local , nb2local , num_all_row_blocks
!     ..
!     .. External Subroutines ..
      EXTERNAL ZCOPY , ZLATSQR , ZUNGTSQR_ROW , ZUNHR_COL , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CEILING , DBLE , DCMPLX , MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      lquery = Lwork== - 1
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 .OR. M<N ) THEN
         Info = -2
      ELSEIF ( Mb1<=N ) THEN
         Info = -3
      ELSEIF ( Nb1<1 ) THEN
         Info = -4
      ELSEIF ( Nb2<1 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -7
      ELSEIF ( Ldt<MAX(1,MIN(Nb2,N)) ) THEN
         Info = -9
!
!        Test the input LWORK for the dimension of the array WORK.
!        This workspace is used to store array:
!        a) Matrix T and WORK for ZLATSQR;
!        b) N-by-N upper-triangular factor R_tsqr;
!        c) Matrix T and array WORK for ZUNGTSQR_ROW;
!        d) Diagonal D for ZUNHR_COL.
!
      ELSEIF ( Lwork<N*N+1 .AND. .NOT.lquery ) THEN
         Info = -11
      ELSE
!
!           Set block size for column blocks
!
         nb1local = MIN(Nb1,N)
!
         num_all_row_blocks = MAX(1,CEILING(DBLE(M-N)/DBLE(Mb1-N)))
!
!           Length and leading dimension of WORK array to place
!           T array in TSQR.
!
         lwt = num_all_row_blocks*N*nb1local

         ldwt = nb1local
!
!           Length of TSQR work array
!
         lw1 = nb1local*N
!
!           Length of ZUNGTSQR_ROW work array.
!
         lw2 = nb1local*MAX(nb1local,(N-nb1local))
!
         lworkopt = MAX(lwt+lw1,MAX(lwt+N*N+lw2,lwt+N*N+N))
!
         IF ( (Lwork<MAX(1,lworkopt)) .AND. (.NOT.lquery) ) Info = -11
!
      ENDIF
!
!     Handle error in the input parameters and return workspace query.
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGETSQRHRT',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         Work(1) = DCMPLX(lworkopt)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( MIN(M,N)==0 ) THEN
         Work(1) = DCMPLX(lworkopt)
         RETURN
      ENDIF
!
      nb2local = MIN(Nb2,N)
!
!
!     (1) Perform TSQR-factorization of the M-by-N matrix A.
!
      CALL ZLATSQR(M,N,Mb1,nb1local,A,Lda,Work,ldwt,Work(lwt+1),lw1,    &
     &             iinfo)
!
!     (2) Copy the factor R_tsqr stored in the upper-triangular part
!         of A into the square matrix in the work array
!         WORK(LWT+1:LWT+N*N) column-by-column.
!
      DO j = 1 , N
         CALL ZCOPY(j,A(1,j),1,Work(lwt+N*(j-1)+1),1)
      ENDDO
!
!     (3) Generate a M-by-N matrix Q with orthonormal columns from
!     the result stored below the diagonal in the array A in place.
!

      CALL ZUNGTSQR_ROW(M,N,Mb1,nb1local,A,Lda,Work,ldwt,Work(lwt+N*N+1)&
     &                  ,lw2,iinfo)
!
!     (4) Perform the reconstruction of Householder vectors from
!     the matrix Q (stored in A) in place.
!
      CALL ZUNHR_COL(M,N,nb2local,A,Lda,T,Ldt,Work(lwt+N*N+1),iinfo)
!
!     (5) Copy the factor R_tsqr stored in the square matrix in the
!     work array WORK(LWT+1:LWT+N*N) into the upper-triangular
!     part of A.
!
!     (6) Compute from R_tsqr the factor R_hr corresponding to
!     the reconstructed Householder vectors, i.e. R_hr = S * R_tsqr.
!     This multiplication by the sign matrix S on the left means
!     changing the sign of I-th row of the matrix R_tsqr according
!     to sign of the I-th diagonal element DIAG(I) of the matrix S.
!     DIAG is stored in WORK( LWT+N*N+1 ) from the ZUNHR_COL output.
!
!     (5) and (6) can be combined in a single loop, so the rows in A
!     are accessed only once.
!
      DO i = 1 , N
         IF ( Work(lwt+N*N+i)==-CONE ) THEN
            DO j = i , N
               A(i,j) = -CONE*Work(lwt+N*(j-1)+i)
            ENDDO
         ELSE
            CALL ZCOPY(N-i+1,Work(lwt+N*(i-1)+i),N,A(i,i),Lda)
         ENDIF
      ENDDO
!
      Work(1) = DCMPLX(lworkopt)
!
!     End of ZGETSQRHRT
!
      END SUBROUTINE ZGETSQRHRT


!***********************************************************
!*               Copyright (c) Wenbin Yu                   *
!*              All rights reserved                        *
!*          Mechanical and Aerospace Engineering           *
!*                                                         *
!*                Utah State University                    *
!***********************************************************

!=========================================================
!
!>  This module contains the linear & nonlinear solver interfaced with MUMPS direct solver library
!
!=========================================================
MODULE SolveMumps

USE InternalData
USE PrescribedCondition
USE System

IMPLICIT NONE

INCLUDE 'mpif.h'
INCLUDE 'dmumps_struc.h'
TYPE (DMUMPS_STRUC) mumps_par   !< an array containing the configuration parameters of MUMPS solver
INTEGER IERR    !< error code of the MUMPS solver

PRIVATE       ! So everything is private, except declared by PUBLIC
PUBLIC LinearSolutionMumps,NewtonRaphsonMumps,CTCabPH,InsertElementValues,ExtractElementValues,ExtractSolution

CONTAINS
!===========================================================

!**************************************************************
!*                                                            *
!>  The linear solver is basically the Newton-Raphson with    *
!!  initial guess equal to zero and only uses one iterations  *
!*															  *
!**************************************************************
SUBROUTINE LinearSolutionMumps(ndof_el,memb_info,v_root_a,omega_a,member,error,&
	& ncond_mb,mb_condition,distr_fun,dof_con,x,aero_flag,grav_flag,init_cond)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::aero_flag   !<#ioaero::aero_flag
INTEGER,INTENT(IN)::grav_flag   !<#ioaero::grav_flag
TYPE (MemberInf),INTENT(IN)::memb_info(:)   ! contains the member parameters of the whole structure

REAL(DBL),INTENT(IN)::v_root_a(:) !< linear velocity of frame a
REAL(DBL),INTENT(IN)::omega_a(:)    !< angular velocity of frame a

REAL(DBL),INTENT(IN) ::distr_fun(:,:)   !<#ioaero::distr_fun
INTEGER,INTENT(IN)   ::member(:,:)  !<#ioaero::member
INTEGER,INTENT(IN)   ::ncond_mb !<#ioaero::ncond_mb
TYPE(PrescriInf),INTENT(IN)::mb_condition(:)    !<#ioaero::mb_condition

INTEGER                 ::dof_con(:) !< this array is passed by value
CHARACTER(*),INTENT(OUT)::error !<#ioaero::error

REAL(DBL),INTENT(OUT) ::x(:)    !<The solution vector

REAL(DBL),OPTIONAL,INTENT(IN)::init_cond(:,:)   !<#ioaero::init_cond
REAL(DBL)  ::rhs(nsize) !<RHS vector

x=0.D0

CALL MPI_INIT(IERR)
! Define a communicator for the package.
mumps_par%COMM = MPI_COMM_WORLD
!  Initialize an instance of the package
!  for L U factorization (sym = 0, with working host)
mumps_par%JOB = -1
mumps_par%SYM = 0
mumps_par%PAR = 1
CALL DMUMPS(mumps_par)
!~       output parameters
mumps_par%ICNTL(3) = 0

! Assemble the right hand side
!---------------------------------------------------------
CALL AssembleRHS(ndof_el,memb_info,v_root_a,omega_a,member,error,&
& ncond_mb,mb_condition,distr_fun,(dof_con),x,rhs,aero_flag,grav_flag,init_cond)
IF(error/='') RETURN
IF(MAXVAL(ABS(rhs))<TOLERANCE) RETURN

! Assemble the coefficient matrix
!---------------------------------------------------------
CALL AssembleJacobian(ndof_el,1,memb_info,v_root_a,omega_a,member,error,&
& ncond_mb,mb_condition,distr_fun,(dof_con),x,aero_flag,grav_flag,init_cond)
IF(error/='') RETURN

!  Define problem on the host (processor 0)
IF ( mumps_par%MYID .eq. 0 ) THEN
	mumps_par%N=nsize
	mumps_par%NZ=ne
	ALLOCATE( mumps_par%IRN ( mumps_par%NZ ) )
	ALLOCATE( mumps_par%JCN ( mumps_par%NZ ) )
	ALLOCATE( mumps_par%A( mumps_par%NZ ) )
	ALLOCATE( mumps_par%RHS ( mumps_par%N  ) )
	mumps_par%IRN(:)=irn(1:mumps_par%NZ)
	mumps_par%JCN(:)=jcn(1:mumps_par%NZ)
	mumps_par%A(:)=coef(1:mumps_par%NZ)
	mumps_par%RHS(:)=rhs(1:mumps_par%N)
	! Analysis and factorisation
	mumps_par%JOB = 6
	IF(ALLOCATED(coef))DEALLOCATE(coef)
	IF(ALLOCATED(irn)) DEALLOCATE (irn)
	IF(ALLOCATED(jcn)) DEALLOCATE (jcn)
END IF

CALL DMUMPS(mumps_par)

! Solve the linear system
!====================================
!~ CALL  LinearSolver((rhs),x,error)
IF ( mumps_par%MYID .eq. 0 ) THEN
	x(:)=mumps_par%RHS(:)
END IF
!  Deallocate user data
IF ( mumps_par%MYID .eq. 0 )THEN
	DEALLOCATE( mumps_par%IRN )
	DEALLOCATE( mumps_par%JCN )
	DEALLOCATE( mumps_par%A )
	DEALLOCATE( mumps_par%RHS )
END IF
! Destroy the instance (deallocate internal data structures)
mumps_par%JOB = -2
CALL DMUMPS(mumps_par)
CALL MPI_FINALIZE(IERR)

END SUBROUTINE LinearSolutionMumps
!***************************************************************

!************************************************************
!*                                                          *
!>  Use Newton-Raphson method to solve the nonlinear system *
!*															*
!************************************************************
SUBROUTINE NewtonRaphsonMumps(ndof_el,memb_info,v_root_a,omega_a,member,niter,error,&
	 & ncond_mb,mb_condition,distr_fun,dof_con,x,aero_flag,grav_flag,init_cond)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::aero_flag   !<#ioaero::aero_flag
INTEGER,INTENT(IN)::grav_flag   !<#ioaero::grav_flag
TYPE (MemberInf),INTENT(IN)::memb_info(:)   !< contains the member parameters of the whole structure

REAL(DBL),INTENT(IN)::v_root_a(:) !< linear velocity of frame a
REAL(DBL),INTENT(IN)::omega_a(:)    !< angular velocity of frame a

REAL(DBL),INTENT(IN) ::distr_fun(:,:)  !<#ioaero::distr_fun
INTEGER,INTENT(IN)   ::member(:,:)  !<#ioaero::member
INTEGER,INTENT(IN)   ::niter    !<#ioaero::niter
INTEGER,INTENT(IN)   ::ncond_mb !<#ioaero::ncond_mb
TYPE(PrescriInf),INTENT(IN):: mb_condition(:)   !<#ioaero::mb_condition
REAL(DBL),INTENT(INOUT) ::x(:)  !<The solution vector

INTEGER                 ::dof_con(:) ! this array is passed by value
CHARACTER(*),INTENT(OUT)::error !<#ioaero::error
REAL(DBL)::rhs(nsize)   !<RHS vector
REAL(DBL),OPTIONAL,INTENT(IN)::init_cond(:,:)   !<#ioaero::init_cond

LOGICAL:: check
REAL(DBL):: fmin,fold !< 0.5*rhs.rhs
REAL(DBL),PARAMETER::STPMX=1000.D0 !< scaled maximum step length allowed in line searches
REAL(DBL)::stpmax
REAL(DBL)::gradient(SIZE(x)) !<-rhs.coef
REAL(DBL)::xold(SIZE(x)) !<holding x from previous iteration
REAL(DBL)::dx(SIZE(x)) !<xnew-xold, the increment calculated by N-R method

REAL(DBL),PARAMETER::TOLF=1.0D-8 !< convergence criterion for the function values

INTEGER::i

CALL AssembleRHS(ndof_el,memb_info,v_root_a,omega_a,member,error,&
& ncond_mb,mb_condition,distr_fun,(dof_con),x,rhs,aero_flag,grav_flag,init_cond)
IF(error/='') RETURN

IF(MAXVAL(ABS(rhs))<TOLF) RETURN

fmin=0.5D0*DOT_PRODUCT(rhs,rhs)  ! calculate fnew=1/2*F.F

stpmax=STPMX*MAX(Norm(x),REAL(SIZE(x)))   ! Calculate step length for line searches

check=.FALSE.

CALL MPI_INIT(IERR)
! Define a communicator for the package.
mumps_par%COMM = MPI_COMM_WORLD
!  Initialize an instance of the package
!  for L U factorization (sym = 0, with working host)
mumps_par%JOB = -1
mumps_par%SYM = 0
mumps_par%PAR = 1
CALL DMUMPS(mumps_par)
!~       output parameters
mumps_par%ICNTL(3) = 0
mumps_par%N=nsize
IF ( mumps_par%MYID .eq. 0 ) THEN
	ALLOCATE( mumps_par%RHS ( mumps_par%N  ) )
	mumps_par%RHS(:)=rhs(1:mumps_par%N)
ENDIF

DO i=1,niter
!~    WRITE(*,*) "ITERATION=",i
   IF(DEBUG) WRITE(IOUT,*) "ITERATION=",i

   ! Assemble the nonlinear system
   !---------------------------------------------------
   CALL AssembleJacobian(ndof_el,niter,memb_info,v_root_a,omega_a,member,error,&
	& ncond_mb,mb_condition,distr_fun,(dof_con),x,aero_flag,grav_flag,init_cond)
   IF(error/='') RETURN
   gradient=MATMUL_sparse(-rhs,nsize,ne,irn,jcn,coef) ! compute gradient for the line search
   xold=x
   fold=fmin

	IF ( mumps_par%MYID .eq. 0 ) THEN
		mumps_par%NZ=ne
		ALLOCATE( mumps_par%IRN ( mumps_par%NZ ) )
		ALLOCATE( mumps_par%JCN ( mumps_par%NZ ) )
		ALLOCATE( mumps_par%A( mumps_par%NZ ) )
		mumps_par%IRN(:)=irn(1:mumps_par%NZ)
		mumps_par%JCN(:)=jcn(1:mumps_par%NZ)
		mumps_par%A(:)=coef(1:mumps_par%NZ)
		IF(ALLOCATED(coef))DEALLOCATE(coef)
		IF(ALLOCATED(irn)) DEALLOCATE (irn)
		IF(ALLOCATED(jcn)) DEALLOCATE (jcn)

		! Analysis and factorisation
		mumps_par%JOB = 6
	END IF

   ! Solve the linear system
   !====================================
	CALL DMUMPS(mumps_par)
!~    CALL  LinearSolver((rhs),dx,error)
	IF ( mumps_par%MYID .eq. 0 ) THEN
		dx(1:nsize)=mumps_par%RHS(1:nsize)
	END IF
   IF(error/='')	 RETURN

	!  Deallocate user data
	IF ( mumps_par%MYID .eq. 0 )THEN
		DEALLOCATE( mumps_par%IRN )
		DEALLOCATE( mumps_par%JCN )
		DEALLOCATE( mumps_par%A )
	END IF

   CALL LineSearch  ! use line search to find a new x and rhs
	mumps_par%RHS(1:nsize) = rhs(1:nsize)
   IF(MAXVAL(ABS(rhs))<TOLF) THEN
       check=.FALSE.  ! the function values converge to zero
!~        WRITE(*,*) "ITERATIONS=",i
	   EXIT
   ENDIF

   IF(check) THEN  ! converges on deltaX
      ! Check for gradient of 1/2 F.F zero, i.e. spurious convergence
	  !---------------------------------------------------------------------
	   check=(MAXVAL(ABS(gradient)*MAX(ABS(x),1.0D0)/MAX(fmin,0.5D0*SIZE(x)))<TOLF)
	   EXIT
   ENDIF

!~ ! It seems the following test is needed, if it converges on x and the gradient is not equal to zero.  as if rhs=0, then the following test must be true for a real solution
!~ ! if it is not, then, it must converge to a local minimum, one must restart with different nonlinear parameters
   IF(MAXVAL(ABS(x-xold)/MAX(ABS(x),1.0D0))<=TOLF) THEN
		check=.FALSE.
		RETURN
	ENDIF  ! no more corrections found for x

    IF(i==niter) THEN
        error='The solution does not converge after the maximum number of iterations' !The maximum number of iterations reached, the solution is still not converged.
        WRITE(0,*) 'SolveMumps.f90 : ',error
        ERROR STOP 122
    ENDIF
ENDDO
IF(check) THEN
    error="The solution converges to a local minimum. Please restart &
	&  with different number of load steps and number of iterations"
    WRITE(0,*) 'SolveMumps.f90 : ',error
    WRITE(0,*) MAXVAL(ABS(gradient)*MAX(ABS(x),1.0D0)/MAX(fmin,0.5D0*SIZE(x)))
    ERROR STOP 123
ENDIF

IF ( mumps_par%MYID .eq. 0 )THEN
	DEALLOCATE( mumps_par%RHS )
	mumps_par%JOB = -2
ENDIF
! Destroy the instance (deallocate internal data structures)

CALL DMUMPS(mumps_par)
CALL MPI_FINALIZE(IERR)

CONTAINS ! The line search subroutine

!*************************************************************
!*                                                           *
!>  Use line search to improve the convergence of Newton
!! Raphson method, modified from the book: Numerical Recipes*
!*															 *
!*************************************************************
SUBROUTINE LineSearch

REAL(DBL),PARAMETER:: ALF=1.0D-4 !< A small number to indicate sufficient decrease of the function
REAL(DBL),PARAMETER:: TOLY=1.0D-12 !< a small number to calculate the minimum step size
REAL(DBL):: tmp, slope,alamin, alam,tmplam,rhs1,rhs2,f2,alam2,a,b,disc

check=.FALSE.

tmp=Norm(dx)

IF(tmp>stpmax) dx=dx*stpmax/tmp  ! Scale if attempted step is too big

slope=DOT_PRODUCT(gradient,dx)

!~ IF(slope>=0.0D0) THEN
!~     error='roundoff problem in line search'
!~     WRITE(0,*) 'SolveMumps.f90 : ',error
!~     ERROR STOP 124
!~ ENDIF

alamin=TOLY/MAXVAL(ABS(dx)/MAX(ABS(xold),1.0D0))  ! Compute lambda_min

alam=1.0D0

DO

  x=xold+alam*dx

  CALL AssembleRHS(ndof_el,memb_info,v_root_a,omega_a,member,error,&
	& ncond_mb,mb_condition,distr_fun,(dof_con),x,rhs,aero_flag,grav_flag,init_cond)
  IF(error/='') RETURN

  fmin=0.5D0*DOT_PRODUCT(rhs,rhs)

  IF(alam<alamin) THEN  ! CONVERGENCE ON deltaX, the calling program should verify the convergence
    x=xold
	check=.TRUE.
	RETURN
  ELSE IF(fmin<=fold+ALF*alam*slope) THEN
	   RETURN  ! SUFFICIENT function decrease
  ELSE
     IF(ABS(alam-1.0D0)<TOLERANCE) THEN
	   tmplam=-slope/(2.0D0*(fmin-fold-slope))
	 ELSE
	   rhs1=fmin-fold-alam*slope
	   rhs2=f2-fold- alam2*slope
	   a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
       b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)

	   IF(ABS(a)<TOLERANCE)THEN
           tmplam=-slope/(2.0D0*b)
	   ELSE
	       disc=b*b-3.0D0*a*slope
		   IF(disc<0.0d0) THEN
		       tmplam=0.5D0*alam  ! for imagine roots choose the max allowed
           ELSE
		       tmplam=(-b+sqrt(disc))/(3.0D0*a)
		   ENDIF
       ENDIF
       IF(tmplam>0.5d0*alam) tmplam=0.5d0*alam
     ENDIF
  ENDIF

  alam2=alam
  f2=fmin
  alam=MAX(tmplam,0.1D0*alam)

ENDDO
END SUBROUTINE LineSearch
!************************************************************

END SUBROUTINE NewtonRaphsonMumps
!***************************************************************
!***************************************************************
!*                                                             *
!> The subroutine extracts the solution for each key point
!! and each member from the solution vector                    *
!*                                                             *
!***************************************************************
SUBROUTINE ExtractSolution(ndof_el,member,coord,memb_info,x,dof_con,sol_pt_i,sol_mb_i)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::member(:,:) !<#ioaero::member
REAL(DBL),INTENT(IN)::coord(:,:)    !<#ioaero::coord
TYPE (MemberInf),INTENT(IN)::memb_info(:)   !< contains the member parameters of the whole structure
REAL(DBL),INTENT(IN)::x(:) !< the solution vector
INTEGER,INTENT(IN)::dof_con(:) !< the connecting condition for key point.

REAL(DBL),INTENT(OUT)      ::sol_pt_i(:,:)     !< solutions for points for ith step
REAL(DBL),INTENT(OUT)      ::sol_mb_i(:,:)     !< solutions for members for ith step

INTEGER::i,j,ncol,pre_dof,free_dof

INTEGER::ndiv !< divisions of the member
INTEGER::val_no !< the position for a value in the member solution vector

! Extract values for the point
!---------------------------------------------
DO i=1,SIZE(dof_con)

	sol_pt_i(i,1:3)=coord(i,:) ! Extract the coordinates

    ncol=index_kp(i,2)

	! for a follower, the prescribed values should be updated
	! by the current orientation calculated from current solution
	!---------------------------------------------------------------------
	IF(ANY(follower_all(i,:)==1)) &
	& cond_all(i,:)=UpdateFollower(dof_all(i,:),follower_all(i,:),cond_all(i,:),x(ncol:ncol+5))

	IF(dof_con(i)==0) THEN	   ! a boundary point
		DO j=1,NSTRN
			pre_dof=dof_all(i,j)
			IF(pre_dof/=0) THEN
				IF(pre_dof>NSTRN) THEN
					free_dof=pre_dof-NSTRN
				ELSE
					free_dof=pre_dof+NSTRN
				ENDIF
				sol_pt_i(i,3+pre_dof)=cond_all(i,j)
				sol_pt_i(i,3+free_dof)=x(ncol+j-1)
			ENDIF
		ENDDO
	ELSE   ! a connection point
		sol_pt_i(i,4:9)=x(ncol:ncol+5)  ! note that forces/moments of connection points are not variables
	ENDIF

ENDDO

val_no=0

! Extract values for the member
!---------------------------------------------
DO i=1,SIZE(member,1)

	ndiv=memb_info(i)%ndiv

    ncol=index_mb(i,2)
	DO j=1,ndiv
	   val_no=val_no+1
	   sol_mb_i(val_no,1:3)=memb_info(i)%coordinate(j,:)
	   sol_mb_i(val_no,4:3+ndof_el)=x(ncol:ncol+ndof_el-1)
       ncol=ncol+ndof_el
	ENDDO

ENDDO

END SUBROUTINE ExtractSolution
!************************************************************

!***************************************************************
!*                                                             *
!> The subroutine extracts elemental values from               *
!! the solution vector						                   *
!*                                                             *
!***************************************************************
SUBROUTINE ExtractElementValues(ndof_el,member,x,sol_mb_i)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::member(:,:) !<#ioaero::member
REAL(DBL),INTENT(IN)::x(:) !< the solution vector
REAL(DBL),INTENT(OUT)      ::sol_mb_i(:,:)     !< solutions for all the elements for ith step

INTEGER::i,j,ncol

INTEGER::val_no !< the position for a value in the member solution vector

val_no=0

! Extract values for the member
!---------------------------------------------
DO i=1,SIZE(member,1)

    ncol=index_mb(i,2)
	DO j=1,member(i,6)
	   val_no=val_no+1
	   sol_mb_i(val_no,4:3+ndof_el)=x(ncol:ncol+ndof_el-1)
       ncol=ncol+ndof_el
	ENDDO
ENDDO

END SUBROUTINE ExtractElementValues
!************************************************************

!***************************************************************
!*                                                             *
!> The subroutine insert the elemental values into the solution
!! vector: needed for initial guess for starting
!! time marching: replace the first six valumes for
!! each element with given initial conditions *
!***************************************************************
SUBROUTINE InsertElementValues(ndof_el,member,x,init_cond)

INTEGER,INTENT(IN)::ndof_el !<#ioaero::ndof_el
INTEGER,INTENT(IN)::member(:,:) !<#ioaero::memeber
REAL(DBL),INTENT(INOUT)::x(:) !< the solution vector

REAL(DBL),INTENT(IN)::init_cond(:,:)    !<#ioaero::init_cond

INTEGER::i,j,ncol

INTEGER::val_no !< the position for a value in the member solution vector

ncol=0
val_no=0

! Insert values into the solution vector
!---------------------------------------------
DO i=1,SIZE(member,1)

    ncol=index_mb(i,2)
	DO j=1,member(i,6)
	   val_no=val_no+1
	   x(ncol:ncol+5)=init_cond(val_no,1:6)
       ncol=ncol+ndof_el
	ENDDO
ENDDO

END SUBROUTINE InsertElementValues
!************************************************************

!> Transfer the vector PH (linear and angular momenta) form frame B to frame a
FUNCTION CTCabPH(niter,member,memb_info ,sol_mb_i)

INTEGER,INTENT(IN)::niter   !<#ioaero::niter
INTEGER,INTENT(IN)::member(:,:)     !<#ioaero::member
TYPE (MemberInf),INTENT(IN)::memb_info(:)
REAL(DBL),INTENT(IN) ::sol_mb_i(:,:)     !< solutions for members for ith step
REAL(DBL)            ::CTCabPH(SIZE(sol_mb_i,1),6)

INTEGER::i,j,val_no
REAL(DBL)::eCab(NDIM,NDIM),theta(NDIM),eCTCab(NDIM,NDIM)

val_no=0

DO i=1,SIZE(member,1)

	DO j=1,member(i,6)
		eCab=memb_info(i)%triad(j,:,:)

	   val_no=val_no+1
	   IF(niter/=1) THEN
 			theta  =  sol_mb_i(val_no,4:6)          ! given initial rotations
			eCTCab =MATMUL(DirCosineTRodrigues(theta),eCab)
	   ELSE
		    eCTCab=eCab
	   ENDIF
 	   CTCabPH(val_no,1:3)=MATMUL(eCTCab,sol_mb_i(val_no,13:15))  ! CTCabP
	   CTCabPH(val_no,4:6)=MATMUL(eCTCab,sol_mb_i(val_no,16:18)) ! CTCabH
	ENDDO

ENDDO
END FUNCTION CTCabPH
!************************************************************
END MODULE SolveMumps
!=========================================================