!*******************************  A U T O S U R F  *********************************!
!===================================================================================!
!-----------------------------------------------------------------------------------!
!-                                                                                -!
!-        AUTOSURF Package: A set of programs for the automated construction       -!
!-              of Potential Energy Surfaces on van der Waals systems              -!
!-                                                                                -!
!-----------------------------------------------------------------------------------!
!===================================================================================!
!***********************************************************************************!

!===================================================================================
!***********************************************************************************
!-           Set of Fortran90 functions for "AUTOSURF_rigid4D" PROGRAM             -
!***********************************************************************************

!                                F U N C T I O N S

function func(xi)

use nrtype
USE dynamic_parameters
implicit none

INTERFACE
  FUNCTION func_actual_min(xi)
    use nrtype
    USE dynamic_parameters
    IMPLICIT NONE
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP) :: func_actual_min
  END FUNCTION func_actual_min
end interface
INTERFACE
  FUNCTION func_actual_seed(xi)
    use nrtype
    USE dynamic_parameters
    IMPLICIT NONE
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP) :: func_actual_seed
  END FUNCTION func_actual_seed
end interface

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP) :: func
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,jp,jj,kk,R,M
integer :: count
real*8 :: temp,weight,norm,somme,jac3(4),jac4(4),tampon,h2wn,dist,temp1,temp2,diff(4),pii
real*8,allocatable :: ind7(:),PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)
integer,allocatable :: ind8(:)

pii=acos(-1d0)
do j=1,4
  if(xi(j)>rmax(j).or.xi(j)<rmin(j))then
    func=0d0
    return
  endif
enddo
call INT_Cart(cart,xi,mass,natom1,natom2,ref1,ref2)
call cart_to_bdist_inter(cart,natom1,natom2,dist_tol,dist_flag)
if(dist_flag==1) then
  func=0d0
  return
endif
if(low_grid>0) then
  temp=func_actual_seed(xi)
  if(temp>Max_E_seed)then
    func=0d0
    return
  endif
endif
temp1=func_actual_min(xi)
if(subzero==0)then
  if(temp1>Max_E)then
    func=0d0
    return
  endif
endif
if(subzero==1)then
  if(temp1+temp>Max_E)then
    func=0d0
    return
  endif
endif
allocate(ind7(count3),ind8(count3),PM1(0:order_2+1,0:order_2+1),PM2(0:order_3+1,0:order_3+1))
allocate(PD1(0:order_2+1,0:order_2+1),PD2(0:order_3+1,0:order_3+1))
jac3=xi
count=0
do ip=1,count3
  count=count+1
  Jac4=coords(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss)
enddo
call indexxy(count3,ind7,ind8)
quitt=0!
do ip=1,count3
  if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 12
  quitt=quitt+1
enddo
12 norm=0d0
temp=0d0
jac3=xi
jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2+1,order_2,order_2,jac4(2),PM1,PD1)
call LPMN(order_3+1,order_3,order_3,jac4(3),PM2,PD2)
do i=1,quitt
  jj=ind8(count3+1-i)
  weight=ind7(ind8(count3+1-i))
  norm=norm+weight
  temp=temp+weight*b2(1,jj)
  count=1
  do R=1,order_1
    do L1=0,order_2
      do L2=0,order_3
        if((L1+L2)<order_4+1)then
          do M=0,min(L1,L2)
           count=count+1
           temp=temp+weight*b2(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
          enddo
        endif
      enddo
    enddo
  enddo
enddo
func=temp/norm
order_1=order_1-1
order_2=order_2-1
order_3=order_3-1
order_4=order_4-1
norm=0d0
temp=0d0
do i=1,quitt
  jj=ind8(count3+1-i)
  weight=ind7(ind8(count3+1-i))
  norm=norm+weight
  temp=temp+weight*b2_lower(1,jj)
  count=1
  do R=1,order_1
    do L1=0,order_2
      do L2=0,order_3
        if((L1+L2)<order_4+1)then
          do M=0,min(L1,L2)
           count=count+1
           temp=temp+weight*b2_lower(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
          enddo
        endif
      enddo
    enddo
  enddo
enddo
deallocate(ind7,ind8)
func=-abs(func-temp/norm)**2
order_1=order_1+1
order_2=order_2+1
order_3=order_3+1
order_4=order_4+1

return
end function func

function func1(xi)

use nrtype
USE dynamic_parameters
implicit none

INTERFACE
  FUNCTION func_actual_min(xi)
    use nrtype
    USE dynamic_parameters
    IMPLICIT NONE
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP) :: func_actual_min
  END FUNCTION func_actual_min
end interface
INTERFACE
  FUNCTION func_actual_seed(xi)
    use nrtype
    USE dynamic_parameters
    IMPLICIT NONE
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP) :: func_actual_seed
  END FUNCTION func_actual_seed
end interface

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP) :: func1
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,jp,jj,kk,R,M
integer :: count
real*8 :: temp,weight,norm,somme,jac3(4),jac4(4),tampon,h2wn,dist,temp1,temp2,diff(4),pii
real*8,allocatable :: ind7(:),PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)
integer,allocatable :: ind8(:)

pii=acos(-1d0)
 if(xi(1)>rmax(1).or.xi(1)<rmin(1))then
   func1=0d0
   return
 endif
do j=2,3
 if(xi(j)>0.9999d0.or.xi(j)<-0.9999d0)then
   func1=0d0
   return
 endif
enddo
 if(xi(4)>rmax(4).or.xi(4)<(-1.d0*rmax(4)))then
   func1=0d0
   return
 endif
call INT_Cart(cart,xi,mass,natom1,natom2,ref1,ref2)
call cart_to_bdist_inter(cart,natom1,natom2,dist_tol,dist_flag)
if(dist_flag==1) then
  func1=0d0
  return
endif
if(low_grid>0) then
  temp=func_actual_seed(xi)
  if(temp>Max_E_seed)then
    func1=0d0
    return
  endif
endif
temp1=func_actual_min(xi)
if(subzero==0)then
  if(temp1>Max_E)then
    func1=0d0
    return
  endif
endif
if(subzero==1)then
  if(temp1+temp>Max_E)then
    func1=0d0
    return
  endif
endif
allocate(ind7(count3),ind8(count3),PM1(0:order_2+1,0:order_2+1),PM2(0:order_3+1,0:order_3+1))
allocate(PD1(0:order_2+1,0:order_2+1),PD2(0:order_3+1,0:order_3+1))
jac3=xi
count=0
do ip=1,count3
  count=count+1
  Jac4=coords(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss)
enddo
call indexxy(count3,ind7,ind8)
quitt=0!
do ip=1,count3
  if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 12
  quitt=quitt+1
enddo
!write(701,*) quitt
12 norm=0d0
temp=0d0
jac3=xi
jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2+1,order_2,order_2,jac4(2),PM1,PD1)
call LPMN(order_3+1,order_3,order_3,jac4(3),PM2,PD2)
do i=1,quitt
  jj=ind8(count3+1-i)
  weight=ind7(ind8(count3+1-i))
  norm=norm+weight
  temp=temp+weight*b2(1,jj)
  count=1
  do R=1,order_1
    do L1=0,order_2
      do L2=0,order_3
        if((L1+L2)<order_4+1)then
          do M=0,min(L1,L2)
           count=count+1
           temp=temp+weight*b2(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
          enddo
        endif
      enddo
    enddo
  enddo
enddo
func1=temp/norm
order_1=order_1-1
order_2=order_2-1
order_3=order_3-1
order_4=order_4-1
norm=0d0
temp=0d0
do i=1,quitt
  jj=ind8(count3+1-i)
  weight=ind7(ind8(count3+1-i))
  norm=norm+weight
  temp=temp+weight*b2_lower(1,jj)
  count=1
  do R=1,order_1
    do L1=0,order_2
      do L2=0,order_3
        if((L1+L2)<order_4+1)then
          do M=0,min(L1,L2)
           count=count+1
           temp=temp+weight*b2_lower(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
          enddo
        endif
      enddo
    enddo
  enddo
enddo
deallocate(ind7,ind8)
func1=-abs(func1-temp/norm)**2
!write(550+myid,*) xi
!write(550+myid,*) func1
order_1=order_1+1
order_2=order_2+1
order_3=order_3+1
order_4=order_4+1

return
end function func1

function dfunc_actual_anal1(xi)

use nrtype
USE dynamic_parameters
implicit none

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP), DIMENSION(size(xi)) :: x2,x3
REAL(SP), DIMENSION(size(xi)+1) :: dfunc_actual_anal1
real*8 :: tampon,tampon2,scale
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,count,jp,jj,kk,R,M
real*8 :: temp(4),weight,norm,h2wn,jac3(4),jac4(4),temp2(4+1),temp3,temp4,diff(4)
real*8,allocatable :: ind7(:),weight_grad(:,:),weight_grad2(:,:)
real*8,allocatable :: PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)
integer,allocatable :: ind8(:)
real*8 :: somme,somme2,norm_grad(4),grad2(4),valeur,pii

pii=acos(-1d0)
allocate(ind7(count3),ind8(count3))

jac3=xi
count=0
do ip=1,count3
  count=count+1
  Jac4=coords(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss)
enddo
call indexxy(count3,ind7,ind8)
quitt=0!
norm=0d0
do ip=1,count3
  if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 13
  norm=norm+ind7(ind8(count3+1-ip))
  quitt=quitt+1
enddo
13 continue
allocate(weight_grad(quitt,4),PM1(0:order_2+1,0:order_2+1),PM2(0:order_3+1,0:order_3+1))
allocate(PD1(0:order_2+1,0:order_2+1),PD2(0:order_3+1,0:order_3+1))
weight_grad=0d0
norm_grad=0d0
!write(*,*) 'made it15'
do i=1,quitt
  jj=ind8(count3+1-i)
  Jac4=coords(jj,:)
  scale=sqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  jac4(1)=(jac3(1)-jac4(1))*(W_a**2)
  jac4(2)=(acos(jac3(2))-acos(jac4(2)))/sqrt(1d0-jac3(2)**2)
  jac4(3)=(acos(jac3(3))-acos(jac4(3)))/sqrt(1d0-jac3(3)**2)
  jac4(4)=jac3(4)-jac4(4)
  if(jac4(4)>pii)then
    jac4(4)=jac4(4)-2d0*pii
  endif
  if(jac4(4)<-pii)then
    jac4(4)=jac4(4)+2d0*pii
  endif
  jac4(4)=jac4(4)*scale
  somme2=0d0
  somme2=somme/(d(jj)**2)
  temp=0d0
  if(somme>1d-10)then
    do ip=1,4
      temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*&
      ((1.0d0/(d(jj)**2))+(zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/(somme)))
    enddo
  else
    temp=0d0
  endif
  weight_grad(i,:)=temp
  do ip=1,4
    norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip)
  enddo
enddo
!write(*,*) 'made it16'
temp2=0d0
Jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2+1,order_2,order_2,jac4(2),PM1,PD1)
call LPMN(order_3+1,order_3,order_3,jac4(3),PM2,PD2)
do i=1,quitt
  jj=ind8(count3+1-i)
!  if(pot(jj)<E_limit)then
   temp=0d0
   grad2=0d0
   valeur=0d0
   weight=ind7(ind8(count3+1-i))
   valeur=valeur+weight*b2(1,jj)
   count=1
   do R=1,order_1
     do L1=0,order_2
       do L2=0,order_3
         if((L1+L2)<order_4+1)then
           do M=0,min(L1,L2)
            count=count+1
            valeur=valeur+weight*b2(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
            grad2(1)=grad2(1)+b2(count,jj)*dble(R)*alpha*xbeta*(jac3(1))**(xbeta-1d0)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)* &
                     cos(dble(M)*jac4(4))
            grad2(2)=grad2(2)+b2(count,jj)*(jac4(1))**(R)*PD1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
            grad2(3)=grad2(3)+b2(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PD2(M,L2)*cos(dble(M)*jac4(4))
            grad2(4)=grad2(4)+b2(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*(-dble(M)* &
                     sin(dble(M)*jac4(4)))
           enddo
         endif
       enddo
     enddo
   enddo
   temp2(1)=temp2(1)+valeur
   do k=1,4
      temp(k)=(weight/norm)*grad2(k)
   enddo
   temp2(2:4+1)=temp2(2:4+1)+temp
   do k=1,4
      temp2(k+1)=temp2(k+1)+(valeur/(weight*norm))*weight_grad(i,k)-&
                 (1.0d0/norm**2)*valeur*norm_grad(k)
   enddo
!  endif
enddo
dfunc_actual_anal1(1)=temp2(1)/norm
dfunc_actual_anal1(2:5)=temp2(2:5)
deallocate(ind7,ind8,weight_grad)

return
end function dfunc_actual_anal1

function dfunc_actual_seed(xi)

use nrtype
USE dynamic_parameters
implicit none

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP), DIMENSION(size(xi)) :: x2,x3
REAL(SP), DIMENSION(size(xi)+1) :: dfunc_actual_seed
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,count,jp,jj,kk,R,M
integer,allocatable :: ind8(:)
real*8 :: tampon,tampon2
real*8 :: temp(4),weight,norm,h2wn,jac3(4),jac4(4),temp2(4+1),temp3,temp4,diff(4)
real*8 :: somme,somme2,norm_grad(4),grad2(4),valeur,pii,scale
real*8,allocatable :: ind7(:),weight_grad(:,:),weight_grad2(:,:)
real*8,allocatable :: PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)

pii=acos(-1d0)
allocate(ind7(count_seed),ind8(count_seed))
jac3=xi
count=0
do ip=1,count_seed
  count=count+1
  Jac4=coords_seed(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d_seed(ip)**2))/(((somme)/d_seed(ip)**2)**(zz_low/2)+epss)
enddo
call indexxy(count_seed,ind7,ind8)
quitt=0
norm=0d0
do ip=1,count_seed
  if(ind7(ind8(count_seed))/ind7(ind8(count_seed+1-ip))>1d11) goto 13
! if(pot(ind8(count_seed+1-ip))<E_limit)then
   norm=norm+ind7(ind8(count_seed+1-ip))
! endif
  quitt=quitt+1
enddo
13 continue
allocate(weight_grad(quitt,4),PM1(0:order_2_min+1,0:order_2_min+1))
allocate(PM2(0:order_3_min+1,0:order_3_min+1),PD1(0:order_2_min+1,0:order_2_min+1))
allocate(PD2(0:order_3_min+1,0:order_3_min+1))
weight_grad=0d0
norm_grad=0d0
do i=1,quitt
  jj=ind8(count_seed+1-i)
  Jac4=coords(jj,:)
  scale=sqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  jac4(1)=(jac3(1)-jac4(1))*(W_a**2)
  jac4(2)=(acos(jac3(2))-acos(jac4(2)))/sqrt(1d0-jac3(2)**2)
  jac4(3)=(acos(jac3(3))-acos(jac4(3)))/sqrt(1d0-jac3(3)**2)
  jac4(4)=jac3(4)-jac4(4)
  if(jac4(4)>pii)then
    jac4(4)=jac4(4)-2d0*pii
  endif
  if(jac4(4)<-pii)then
    jac4(4)=jac4(4)+2d0*pii
  endif
  jac4(4)=jac4(4)*scale
  somme2=0d0
  somme2=somme/(d_seed(jj)**2)
  temp=0d0
  if(somme>1d-10)then
    do ip=1,4
     temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count_seed+1-i))*((1.0d0/(d_seed(jj)**2))+ &
     (zz_low/2)*((somme2**(zz_low/2))/((somme2**(zz_low/2))+epss))*(1.0d0/(somme)))
    enddo
  else
    temp=0d0
  endif
  weight_grad(i,:)=temp
  do ip=1,4
    norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip)
  enddo
enddo
!write(*,*) 'made it16'
temp2=0d0
Jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2_min+1,order_2_min,order_2_min,jac4(2),PM1,PD1)
call LPMN(order_3_min+1,order_3_min,order_3_min,jac4(3),PM2,PD2)
do i=1,quitt
  jj=ind8(count_seed+1-i)
!  if(pot(jj)<E_limit)then
   temp=0d0
   grad2=0d0
   valeur=0d0
   weight=ind7(ind8(count_seed+1-i))
   valeur=valeur+weight*b2_seed(1,jj)
   count=1
   do R=1,order_1_min
     do L1=0,order_2_min
       do L2=0,order_3_min
         if((L1+L2)<order_4_min+1)then
           do M=0,min(L1,L2)
            count=count+1
            valeur=valeur+weight*b2_seed(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
            grad2(1)=grad2(1)+b2_seed(count,jj)*dble(R)*alpha*xbeta*(jac3(1))**(xbeta-1d0)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)* &
                     cos(dble(M)*jac4(4))
            grad2(2)=grad2(2)+b2_seed(count,jj)*(jac4(1))**(R)*PD1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
            grad2(3)=grad2(3)+b2_seed(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PD2(M,L2)*cos(dble(M)*jac4(4))
            grad2(4)=grad2(4)+b2_seed(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*(-dble(M)* &
                     sin(dble(M)*jac4(4)))
           enddo
         endif
       enddo
     enddo
   enddo
   temp2(1)=temp2(1)+valeur
   do k=1,4
     temp(k)=(weight/norm)*grad2(k)
   enddo
   temp2(2:4+1)=temp2(2:4+1)+temp
   do k=1,4
     temp2(k+1)=temp2(k+1)+(valeur/(weight*norm))*weight_grad(i,k)- &
                (1.0d0/norm**2)*valeur*norm_grad(k)
   enddo
!  endif
enddo
dfunc_actual_seed(1)=temp2(1)/norm
dfunc_actual_seed(2:5)=temp2(2:5)
deallocate(ind7,ind8,weight_grad)

return
end function dfunc_actual_seed

function dfunc_actual_anal2(xi)

use nrtype
USE dynamic_parameters
implicit none

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP), DIMENSION(size(xi)) :: x2,x3
REAL(SP), DIMENSION(size(xi)+1) :: dfunc_actual_anal2
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,count,jp,jj,kk,R,M
integer,allocatable :: ind8(:)
real*8 :: tampon,tampon2
real*8 :: somme,somme2,norm_grad(4),grad2(4),valeur,pii,scale
real*8 :: temp(4),weight,norm,h2wn,jac3(4),jac4(4),temp2(4+1),temp3,temp4,diff(4)
real*8,allocatable :: ind7(:),weight_grad(:,:),weight_grad2(:,:)
real*8,allocatable :: PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)

pii=acos(-1d0)
order_1=order_1-1
order_2=order_2-1
order_3=order_3-1
order_4=order_4-1
jac3=xi
allocate(ind7(count3),ind8(count3),PM1(0:order_2+1,0:order_2+1))
allocate(PM2(0:order_3+1,0:order_3+1),PD1(0:order_2+1,0:order_2+1),PD2(0:order_3+1,0:order_3+1))
count=0
do ip=1,count3
  count=count+1
  Jac4=coords(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss)
enddo
call indexxy(count3,ind7,ind8)
quitt=0
norm=0d0
do ip=1,count3
  if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 13
!  if(pot(ind8(count3+1-ip))<E_limit)then
   norm=norm+ind7(ind8(count3+1-ip))
!  endif
  quitt=quitt+1
enddo
13 allocate(weight_grad(quitt,4))
weight_grad=0d0
norm_grad=0d0
!write(*,*) 'made it15'
do i=1,quitt
  jj=ind8(count3+1-i)
  Jac4=coords(jj,:)
  scale=sqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  jac4(1)=(jac3(1)-jac4(1))*(W_a**2)
  jac4(2)=(acos(jac3(2))-acos(jac4(2)))/sqrt(1d0-jac3(2)**2)
  jac4(3)=(acos(jac3(3))-acos(jac4(3)))/sqrt(1d0-jac3(3)**2)
  jac4(4)=jac3(4)-jac4(4)
  if(jac4(4)>pii)then
    jac4(4)=jac4(4)-2d0*pii
  endif
  if(jac4(4)<-pii)then
    jac4(4)=jac4(4)+2d0*pii
  endif
  jac4(4)=jac4(4)*scale
  somme2=0d0
  somme2=somme/(d(jj)**2)
  temp=0d0
  if(somme>1d-10)then
    do ip=1,4
      temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*((1.0d0/(d(jj)**2))+ &
      (zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/somme))
    enddo
  else
    temp=0d0
  endif
  weight_grad(i,:)=temp
  do ip=1,4
    norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip)
  enddo
enddo
!write(*,*) 'made it16'
temp2=0d0
Jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2+1,order_2,order_2,jac4(2),PM1,PD1)
call LPMN(order_3+1,order_3,order_3,jac4(3),PM2,PD2)
do i=1,quitt
  jj=ind8(count3+1-i)
!  if(pot(jj)<E_limit)then
   temp=0d0
   grad2=0d0
   valeur=0d0
   weight=ind7(ind8(count3+1-i))
   valeur=valeur+weight*b2_lower(1,jj)
   count=1
   do R=1,order_1
     do L1=0,order_2
       do L2=0,order_3
         if((L1+L2)<order_4+1)then
           do M=0,min(L1,L2)
            count=count+1
            valeur=valeur+weight*b2_lower(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
            grad2(1)=grad2(1)+b2_lower(count,jj)*dble(R)*alpha*xbeta*(jac3(1))**(xbeta-1d0)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)* &
                     cos(dble(M)*jac4(4))
            grad2(2)=grad2(2)+b2_lower(count,jj)*(jac4(1))**(R)*PD1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
            grad2(3)=grad2(3)+b2_lower(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PD2(M,L2)*cos(dble(M)*jac4(4))
            grad2(4)=grad2(4)+b2_lower(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*(-dble(M)* &
                     sin(dble(M)*jac4(4)))
           enddo
         endif
       enddo
     enddo
   enddo
   temp2(1)=temp2(1)+valeur
   do k=1,4
     temp(k)=(weight/norm)*grad2(k)
   enddo
   temp2(2:4+1)=temp2(2:4+1)+temp
   do k=1,4
      temp2(k+1)=temp2(k+1)+(valeur/(weight*norm))*weight_grad(i,k)- &
      (1.0d0/norm**2)*valeur*norm_grad(k)
   enddo
!  endif
enddo
dfunc_actual_anal2(1)=temp2(1)/norm
dfunc_actual_anal2(2:5)=temp2(2:5)
deallocate(ind7,ind8,weight_grad)
order_1=order_1+1
order_2=order_2+1
order_3=order_3+1
order_4=order_4+1

return
end function dfunc_actual_anal2

function dfunc(xi)

use nrtype
USE dynamic_parameters
implicit none

INTERFACE
  function dfunc_actual_anal1(xi)
    use nrtype
    USE dynamic_parameters
    implicit none
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP), DIMENSION(size(xi)) :: x2,x3
    REAL(SP), DIMENSION(size(xi)+1) :: dfunc_actual_anal1
  end function dfunc_actual_anal1
end interface
INTERFACE
  function dfunc_actual_anal2(xi)
    use nrtype
    USE dynamic_parameters
    implicit none
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP), DIMENSION(size(xi)) :: x2,x3
    REAL(SP), DIMENSION(size(xi)+1) :: dfunc_actual_anal2
  end function dfunc_actual_anal2
end interface
INTERFACE
  FUNCTION func_actual_min(xi)
    use nrtype
    USE dynamic_parameters
    IMPLICIT NONE
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP) :: func_actual_min
  END FUNCTION func_actual_min
end interface
INTERFACE
  FUNCTION func_actual_seed(xi)
    use nrtype
    USE dynamic_parameters
    IMPLICIT NONE
    REAL(SP), DIMENSION(:), INTENT(IN) :: xi
    REAL(SP) :: func_actual_seed
  END FUNCTION func_actual_seed
end interface

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP), DIMENSION(size(xi)) :: dfunc,x2,x3
integer :: i,j,k
real*8 :: temp(5),val1,val2,grad1(4),grad2(4),tampon,tampon1,h2wn,dist,jac3(4),pii

pii=acos(-1d0)
do j=1,4
  if(xi(j)>rmax(j).or.xi(j)<rmin(j))then
    dfunc=0d0
    return
  endif
enddo
call INT_Cart(cart,xi,mass,natom1,natom2,ref1,ref2)
call cart_to_bdist_inter(cart,natom1,natom2,dist_tol,dist_flag)
if(dist_flag==1) then
   dfunc=0d0
   return
endif
if(low_grid>0) then
  tampon=func_actual_seed(xi)
  if(tampon>Max_E_seed)then
    dfunc=0d0
    return
  endif
endif
tampon1=func_actual_min(xi)
if(subzero==0)then
  if(tampon1>Max_E)then
    dfunc=0d0
    return
  endif
endif
if(subzero==1)then
  if(tampon1+tampon>Max_E)then
    dfunc=0d0
    return
  endif
endif
temp=dfunc_actual_anal1(xi)
val1=temp(1)
grad1(:)=temp(2:5)
temp=dfunc_actual_anal2(xi)
val2=temp(1)
grad2(:)=temp(2:5)
dfunc(:)=-2d0*(val1-val2)*(grad1(:)-grad2(:))
!write(570+myid,*) xi
!write(570+myid,*) dfunc

return
end function dfunc

function func_actual(xi)

use nrtype
USE dynamic_parameters
implicit none

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP) :: func_actual
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,jp,jj,kk,R,M
integer :: count
real*8 :: temp,weight,norm,somme,jac3(4),jac4(4),temp1,temp2,diff(4),pii
real*8,allocatable :: ind7(:),PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)
integer,allocatable :: ind8(:)

pii=acos(-1d0)
jac3=xi
allocate(ind7(count3),ind8(count3),PM1(0:order_2+1,0:order_2+1),PM2(0:order_3+1,0:order_3+1))
allocate(PD1(0:order_2+1,0:order_2+1),PD2(0:order_3+1,0:order_3+1))

count=0
do ip=1,count3
  count=count+1
  Jac4=coords(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss)
enddo
call indexxy(count3,ind7,ind8)

quitt=0!
do ip=1,count3
  if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 12
  quitt=quitt+1
enddo
!write(701,*) quitt
12 jac3=xi
Jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2+1,order_2,order_2,jac4(2),PM1,PD1)
call LPMN(order_3+1,order_3,order_3,jac4(3),PM2,PD2)
norm=0d0
temp=0d0
do i=1,quitt
  jj=ind8(count3+1-i)
!  if(pot(jj)<E_limit)then
   weight=ind7(ind8(count3+1-i))
   !write(665,*) weight
   norm=norm+weight
   temp=temp+weight*b2(1,jj)
   count=1
   do R=1,order_1
     do L1=0,order_2
       do L2=0,order_3
         if((L1+L2)<order_4+1)then
           do M=0,min(L1,L2)
            count=count+1
            temp=temp+weight*b2(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)*cos(dble(M)*jac4(4))
           enddo
         endif
       enddo
     enddo
   enddo
!  endif
enddo
func_actual=temp/norm

return
end function func_actual

function func_actual_min(xi)

use nrtype
USE dynamic_parameters
implicit none

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP) :: func_actual_min
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,jp,jj,kk,R,M
integer :: count
real*8 :: temp,weight,norm,somme,jac3(4),jac4(4),temp1,temp2,diff(4),pii
real*8,allocatable :: ind7(:),PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)
integer,allocatable :: ind8(:)

pii=acos(-1d0)
jac3=xi
allocate(ind7(count3),ind8(count3),PM1(0:order_2_min+1,0:order_2_min+1))
allocate(PM2(0:order_3_min+1,0:order_3_min+1),PD1(0:order_2_min+1,0:order_2_min+1))
allocate(PD2(0:order_3_min+1,0:order_3_min+1))

count=0
do ip=1,count3
  count=count+1
  Jac4=coords(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss)
enddo
call indexxy(count3,ind7,ind8)
quitt=0!
do ip=1,count3
   if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 12
   quitt=quitt+1
enddo
!write(701,*) quitt
12 jac3=xi
Jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2_min+1,order_2_min,order_2_min,jac4(2),PM1,PD1)
call LPMN(order_3_min+1,order_3_min,order_3_min,jac4(3),PM2,PD2)
norm=0d0
temp=0d0
do i=1,quitt
  jj=ind8(count3+1-i)
!  if(pot(jj)<E_limit)then
   weight=ind7(ind8(count3+1-i))
   ! write(665,*) weight
   norm=norm+weight
   temp=temp+weight*b2_minimal(1,jj)
   count=1
   do R=1,order_1_min
     do L1=0,order_2_min
       do L2=0,order_3_min
         if((L1+L2)<order_4_min+1)then
           do M=0,min(L1,L2)
             count=count+1
             temp=temp+weight*b2_minimal(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)* &
                  cos(dble(M)*jac4(4))
           enddo
         endif
       enddo
     enddo
   enddo
!  endif
enddo
func_actual_min=temp/norm

return
end function func_actual_min

function func_actual_seed(xi)

use nrtype
USE dynamic_parameters
implicit none

REAL(SP), DIMENSION(:), INTENT(IN) :: xi
REAL(SP) :: func_actual_seed
integer :: i,j,k,ipp,jpp,ip,quitt,l1,l2,l3,l4,count2,l,jp,jj,kk,R,M
integer :: count
real*8 :: temp,weight,norm,somme,jac3(4),jac4(4),temp1,temp2,diff(4),pii
real*8,allocatable :: ind7(:),PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:)
integer,allocatable :: ind8(:)

pii=acos(-1d0)

jac3=xi
allocate(ind7(count_seed),ind8(count_seed),PM1(0:order_2_min+1,0:order_2_min+1))
allocate(PM2(0:order_3_min+1,0:order_3_min+1),PD1(0:order_2_min+1,0:order_2_min+1))
allocate(PD2(0:order_3_min+1,0:order_3_min+1))

count=0
do ip=1,count_seed
  count=count+1
  Jac4=coords_seed(ip,:)
  call dist_metric(jac3,jac4,W_a,somme)
  somme=somme**2
  ind7(count)=exp(-((somme)/d_seed(ip)**2))/(((somme)/d_seed(ip)**2)**(zz_low/2)+epss)
enddo
call indexxy(count_seed,ind7,ind8)

quitt=0!
do ip=1,count_seed
   if(ind7(ind8(count_seed))/ind7(ind8(count_seed+1-ip))>1d11) goto 12
   quitt=quitt+1
enddo
!write(701,*) quitt
12 jac3=xi
Jac4=jac3
jac4(1)=exp(alpha*jac4(1)**xbeta)
call LPMN(order_2_min+1,order_2_min,order_2_min,jac4(2),PM1,PD1)
call LPMN(order_3_min+1,order_3_min,order_3_min,jac4(3),PM2,PD2)
norm=0d0
temp=0d0
do i=1,quitt
  jj=ind8(count_seed+1-i)
!  if(pot(jj)<E_limit)then
   weight=ind7(ind8(count_seed+1-i))
   ! write(665,*) weight
   norm=norm+weight
   temp=temp+weight*b2_seed(1,jj)
   count=1
   do R=1,order_1_min
     do L1=0,order_2_min
       do L2=0,order_3_min
         if((L1+L2)<order_4_min+1)then
           do M=0,min(L1,L2)
             count=count+1
             temp=temp+weight*b2_seed(count,jj)*(jac4(1))**(R)*PM1(M,L1)*PM2(M,L2)* &
                  cos(dble(M)*jac4(4))
           enddo
         endif
       enddo
     enddo
   enddo
!  endif
enddo
func_actual_seed=temp/norm

return
end function func_actual_seed

FUNCTION dbrent(ax,bx,cx,func,dfunc,tol,xmin)

USE nrtype; USE nrutil, ONLY : nrerror
IMPLICIT NONE
REAL(SP), INTENT(IN) :: ax,bx,cx,tol
REAL(SP), INTENT(OUT) :: xmin
REAL(SP) :: dbrent
INTERFACE
  FUNCTION func(x)
  USE nrtype
    IMPLICIT NONE
    REAL(SP), INTENT(IN) :: x
    REAL(SP) :: func
  END FUNCTION func
!BL
  FUNCTION dfunc(x)
  USE nrtype
    IMPLICIT NONE
    REAL(SP), INTENT(IN) :: x
    REAL(SP) :: dfunc
  END FUNCTION dfunc
END INTERFACE

INTEGER(I4B), PARAMETER :: ITMAX=100
REAL(SP), PARAMETER :: ZEPS=1.0e-3_sp*epsilon(ax)
INTEGER(I4B) :: iter
REAL(SP) :: a,b,d,d1,d2,du,dv,dw,dx,e,fu,fv,fw,fx,olde,tol1,tol2,&
	u,u1,u2,v,w,x,xm
LOGICAL :: ok1,ok2
a=min(ax,cx)
b=max(ax,cx)
v=bx
w=v
x=v
e=0.0
fx=func(x)
fv=fx
fw=fx
dx=dfunc(x)
dv=dx
dw=dx
do iter=1,ITMAX
	xm=0.5_sp*(a+b)
	tol1=tol*abs(x)+ZEPS
	tol2=2.0_sp*tol1
	if (abs(x-xm) <= (tol2-0.5_sp*(b-a))) exit
	if (abs(e) > tol1) then
		d1=2.0_sp*(b-a)
		d2=d1
		if (dw /= dx) d1=(w-x)*dx/(dx-dw)
		if (dv /= dx) d2=(v-x)*dx/(dx-dv)
		u1=x+d1
		u2=x+d2
		ok1=((a-u1)*(u1-b) > 0.0) .and. (dx*d1 <= 0.0)
		ok2=((a-u2)*(u2-b) > 0.0) .and. (dx*d2 <= 0.0)
		olde=e
		e=d
		if (ok1 .or. ok2) then
			if (ok1 .and. ok2) then
				d=merge(d1,d2, abs(d1) < abs(d2))
			else
				d=merge(d1,d2,ok1)
			end if
			if (abs(d) <= abs(0.5_sp*olde)) then
				u=x+d
				if (u-a < tol2 .or. b-u < tol2) &
					d=sign(tol1,xm-x)
			else
				e=merge(a,b, dx >= 0.0)-x
				d=0.5_sp*e
			end if
		else
			e=merge(a,b, dx >= 0.0)-x
			d=0.5_sp*e
		end if
	else
		e=merge(a,b, dx >= 0.0)-x
		d=0.5_sp*e
	end if
	if (abs(d) >= tol1) then
		u=x+d
		fu=func(u)
	else
		u=x+sign(tol1,d)
		fu=func(u)
		if (fu > fx) exit
	end if
	du=dfunc(u)
	if (fu <= fx) then
		if (u >= x) then
			a=x
		else
			b=x
		end if
		call mov3(v,fv,dv,w,fw,dw)
		call mov3(w,fw,dw,x,fx,dx)
		call mov3(x,fx,dx,u,fu,du)
	else
		if (u < x) then
			a=u
		else
			b=u
		end if
		if (fu <= fw .or. w == x) then
			call mov3(v,fv,dv,w,fw,dw)
			call mov3(w,fw,dw,u,fu,du)
		else if (fu <= fv .or. v == x .or. v == w) then
			call mov3(v,fv,dv,u,fu,du)
		end if
	end if
end do
if (iter > ITMAX) call nrerror('dbrent: exceeded maximum iterations')
xmin=x
dbrent=fx
CONTAINS
!BL
SUBROUTINE mov3(a,b,c,d,e,f)
REAL(SP), INTENT(IN) :: d,e,f
REAL(SP), INTENT(OUT) :: a,b,c
a=d
b=e
c=f
END SUBROUTINE mov3
END FUNCTION dbrent


#include "macros.h"
module timestep
    ! Time stepping routines
    use numbers
    use openmpi
    use io
    use parameters
    use fieldio
    use fftw
    use vfield
    use rhs

    integer(i4) :: ncorr_last = 1
    real(dp)    :: error_last = 0, courant

    integer(i4)    :: steps_ch
    character(255) :: steps_file = 'steps.gp'
    logical :: steps_written = .false.

    contains

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

    subroutine timestep_precorr(vel_vfieldxx, vel_vfieldk, fvel_vfieldk)

        real(dp), intent(inout) :: vel_vfieldxx(:, :, :, :)
        complex(dpc), intent(inout) :: vel_vfieldk(:, :, :, :)
        complex(dpc), intent(out) :: fvel_vfieldk(:, :, :, :)

        real(dp)     :: timestep_prefieldxx(nyy, nzz_perproc, nxx, 3)
        complex(dpc), dimension(nx_perproc, ny_half, nz, 3) :: &
            timestep_prefieldk, timestep_corfieldk, timestep_nonlinterm_next, &
            timestep_nonlinterm_prev

        ! semi-implicit predictor-corrector method
        _indices
        integer(i4) :: c
        real(dp)    :: invdt, norm, error

        ! initial rhs
        call rhs_nonlin_term(vel_vfieldxx, vel_vfieldk, fvel_vfieldk)
        timestep_nonlinterm_prev = fvel_vfieldk

        ! add the linear term to the rhs for others's use
        _loop_spec_begin
            fvel_vfieldk(ix,iy,iz,1:3) = fvel_vfieldk(ix,iy,iz,1:3) &
                                    + (- laplacian(ix,iy,iz) / Re) &
                                    * vel_vfieldk(ix,iy,iz,1:3)
        _loop_spec_end

        invdt = 1.0_dp/dt

        ! Prediction: u(n+1)_1 = ((1/dt + (1 - implicitness) L) u(n) + N(n)) /
        !                        (1/dt - implicitness L)

        _loop_spec_begin
            timestep_prefieldk(ix,iy,iz,1:3) = &
                ((invdt + (1 - implicitness) * (- laplacian(ix,iy,iz) / Re)) &
                * vel_vfieldk(ix,iy,iz,1:3) + timestep_nonlinterm_prev(ix,iy,iz,1:3)) & !nonlintrm
                / (invdt - implicitness * (- laplacian(ix,iy,iz) / Re))
        _loop_spec_end

        ! Corrector iterations
        do c = 1, ncorr

            ! Compute the prediction norm:
            call vfield_norm(timestep_prefieldk, norm, .true.)

            call fftw_vk2x(timestep_prefieldk, timestep_prefieldxx)
            call rhs_nonlin_term(timestep_prefieldxx, timestep_prefieldk, timestep_nonlinterm_next)

            ! Now we have N(n+1)^c in state(:,:,:,1:3)
            _loop_spec_begin
                timestep_corfieldk(ix,iy,iz,1:3) = implicitness &
                * (timestep_nonlinterm_next(ix,iy,iz,1:3) - timestep_nonlinterm_prev(ix,iy,iz,1:3)) &
                / (invdt - implicitness * (-laplacian(ix,iy,iz) / Re))
                ! Update the prediction
                timestep_prefieldk(ix,iy,iz,1:3) = timestep_prefieldk(ix,iy,iz,1:3) &
                                                 + timestep_corfieldk(ix,iy,iz,1:3)
            _loop_spec_end

            ! Compute the corrector norm:
            call vfield_norm(timestep_corfieldk, error, .true.)

            ! update
            timestep_nonlinterm_prev(:,:,:,1:3) = timestep_nonlinterm_next(:,:,:,1:3)

            if (error/norm < steptol) then
                ! accept step
                vel_vfieldk(:,:,:,1:3) = timestep_prefieldk(:,:,:,1:3)

                ! apply pressure, galilean invariance and symmetry projections
                call vfield_pressure(vel_vfieldk)
                call vfield_galinv(vel_vfieldk)
                call symmopps_project_all(vel_vfieldk,vel_vfieldk)
                call vfield_solvediv(vel_vfieldk)

                ! update the physical space version
                call fftw_vk2x(vel_vfieldk, vel_vfieldxx)

                ! log the step
                ncorr_last = c
                error_last = error/norm
                exit
            end if

        end do

        if (error/norm > steptol) then
            write(out, *) 'timestep: Timestep did not converge.'
            write(out, *) 'timestep: Error = ', error_last
            write(out, *) 'timestep: Terminating at t = ', time
            flush(out)
            error stop
        end if

    end subroutine timestep_precorr

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

    subroutine timestep_set_dt

        dt = (courant_target / courant) * dt

        if (dtmax > 0 .and. dt > dtmax) then
            dt = dtmax
            courant = courant * dtmax / dt
        else
            courant = courant_target
        end if

    end subroutine timestep_set_dt

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

    subroutine timestep_courant(vfieldxx)
        real(dp), intent(in) :: vfieldxx(:, :, :, :)
        real(dp) :: sfieldxx(nyy, nzz_perproc, nxx)
        real(dp) :: my_courant

        sfieldxx(:, :, :) = abs(vfieldxx(:,:,:,1)) * dt / dx &
                                + abs(vfieldxx(:,:,:,2)) * dt / dy &
                                + abs(vfieldxx(:,:,:,3)) * dt / dz
        my_courant = maxval(sfieldxx(:, :, :))
        if (.not. adaptive_dt) then
            call MPI_REDUCE(&
            my_courant,courant,1,MPI_REAL8,MPI_MAX,0,MPI_COMM_WORLD,mpi_err)
        else
            call MPI_ALLREDUCE(&
            my_courant,courant,1,MPI_REAL8,MPI_MAX,MPI_COMM_WORLD,mpi_err)
        end if

    end subroutine timestep_courant

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

    subroutine timestep_write

        ! outputting statistics

        if (my_id==0) then

           ! outputting all this in the stat file

            inquire(file=TRIM(steps_file), exist=there, opened=there2)
            if (.not.there) then
            open(newunit=steps_ch,file=TRIM(steps_file),form='formatted')
                write(steps_ch,"(A2,"//i4_len//","//"4"//sp_len//","//i4_len//")") &
                    "# ", "itime", "time", "dt", "courant", "err_corr", "ncorr"
            end if
            if(there.and..not.there2) then
            open(newunit=steps_ch,file=TRIM(steps_file),position='append')
            end if
            write(steps_ch,"(A2,"//i4_f//","//"4"//sp_f//","//i4_f//")")&
                "  ", itime, time, dt, courant, error_last, ncorr_last

           steps_written = .true.

        end if

    end subroutine timestep_write

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

end module timestep


!@sum  RES_M24S Resolution info for 24 layer, 4x5 strat model
!@+    (M20b with 4 more layers between 984mb and 150mb)
!@auth Original Development Team
!@ver  1.0

      MODULE RESOLUTION
!@sum  RESOLUTION contains horiz/vert resolution variables
!@auth Original Development Team
!@ver  1.0
      IMPLICIT NONE
      SAVE
!@var IM,JM longitudinal and latitudinal number of grid boxes
!@var LM number of vertical levels
!@var LS1 Layers LS1->LM: constant pressure levels, L<LS1: sigma levels
      INTEGER, PARAMETER :: IM=72,JM=46,LM=24, LS1=17

!@var PSF,PMTOP global mean surface, model top pressure  (mb)
!@var PTOP pressure at interface level sigma/const press coord syst (mb)
      REAL*8, PARAMETER :: PSF=984.d0, PTOP = 150.d0, PMTOP = .3d0
!@var PSFMPT,PSTRAT pressure due to troposhere,stratosphere
      REAL*8, PARAMETER :: PSFMPT=PSF-PTOP, PSTRAT=PTOP-PMTOP

!@var PLbot pressure levels at bottom of layers (mb)
      REAL*8, PARAMETER, DIMENSION(LM+1) :: PLbot = (/
     t     PSF, 974.d0, 959.d0, 934.d0, 900.d0, 857.d0, ! Pbot L=1,..
     t  804.d0, 744.d0, 677.d0, 607.d0, 535.d0, 463.d0, !      L=...
     t  393.d0, 325.d0, 260.d0, 200.d0,                 !      L=...
     1    PTOP,                                         !      L=LS1
     s  110.d0,  80.d0,   55.d0,   35.d0,    20.d0,     !      L=...
     s  10.d0,    3.d0,   PMTOP /)                      !      L=..,LM+1

C**** KEP depends on whether stratos. EP flux diagnostics are calculated
C**** If dummy EPFLUX is used set KEP=0, otherwise KEP=21
!@param KEP number of lat/height E-P flux diagnostics
      INTEGER, PARAMETER :: KEP=21

C**** Based on model top, determine how much of stratosphere is resolved
C****         PMTOP >= 10 mb,    ISTRAT = 0
C**** 1 mb <= PMTOP <  10 mb,    ISTRAT = 1
C****         PMTOP <   1 mb,    ISTRAT = 2
      INTEGER, PARAMETER :: ISTRAT = 2

      END MODULE RESOLUTION

C**** The vertical resolution also determines whether
C**** stratospheric wave drag will be applied or not.
C**** This resolution is for a stratospheric model and so must be used
C**** in conjunction with the strat. modules


!***********************************/
!	Name:FDS法によって2次元風上流束を求めるプログラム
!	Alias:UpwindFlux_Dim2
!	Description:FDS法を用いて2次元系における風上流束を求める
!	Type:CE
!	Input:Geometory,CellEdge,CellCenter
!	Output:CellEdge
!	Note:次元ごとにサブルーチンを分けているのは1つだけでも割と長いプログラムになってしまったため
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:下の方でx方向とy方向を分ているのは法線ベクトルを計算していないため
!***********************************/
    subroutine UpwindFlux_Dim2(Geom,CE,CC) !MUSCL経由の場合CEのみ，1次精度の場合CCを渡す
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, Epsilon => EntropyCorrection
    implicit none
    type(Geometry), intent(in) :: Geom
    type(CellEdge), intent(inout) :: CE
    type(CellCenter), intent(in), optional :: CC

    type(FDSMatrix) :: FM
    type(RoeAverage) :: RA
    type(PrivateVar4OMP) :: SP4O
    integer :: iSkip

    iDim = Geom%Dimension
    allocate(RA%GeneralFlux(iDim+2,1,2), SP4O%UF%DeltaQuantity(iDim+2),SP4O%UF%RoeFlux(iDim+2))
    allocate(FM%RightEigenMatrix(iDim+2,iDim+2),FM%LeftEigenMatrix(iDim+2,iDim+2),FM%AbsEigenValues(iDim+2,iDim+2))
    allocate(RA%RoeAverage(iDim+2),RA%SideQuantity(iDim+2,2))

        allocate(SP4O%GRA%SqrtDensity(2),SP4O%GRA%Enthalpy(2))
        allocate(SP4O%GRA%Velocity(Geom%Dimension,2))

    !Roeスキームの流束を求める

    RA%Direction = 1
!$omp parallel num_threads(CoreNumberOfCPU),shared(Geom,CE,CC),firstprivate(FM,RA,SP4O,iLoop,iSkip,iCenterX,iCenterY,iFaceX,iFaceY)
!$omp do
    do iCenterY=1,Geom%CellNumber(2) !y方向はセル中心位置として
        do iFaceX=0,Geom%CellNumber(1) !すべてのX界面についての総和を取る
!___________________!call directionX!________________________________
            if(present(CC)) then !保存変数からの流束計算
                RA%SideQuantity(:,1) = CC%ConservedQuantity(:,iFaceX,iCenterY,1) !負側の保存量
                RA%SideQuantity(:,2) = CC%ConservedQuantity(:,iFaceX+1,iCenterY,1) !正側の保存量
                RA%TypeOfQuantity = 1
            else  !基礎変数からの流束計算

                RA%SideQuantity(1,1) = CE%RebuildQunatity(1,iFaceX,iCenterY,1,2) !負側の保存量
                RA%SideQuantity(2,1) = CE%RebuildQunatity(2,iFaceX,iCenterY,1,2) * CE%RebuildQunatity(1,iFaceX,iCenterY,1,2)
                RA%SideQuantity(3,1) = CE%RebuildQunatity(3,iFaceX,iCenterY,1,2) * CE%RebuildQunatity(1,iFaceX,iCenterY,1,2)
                RA%SideQuantity(4,1) = InverseGmin1*CE%RebuildQunatity(4,iFaceX,iCenterY,1,2) &
                &   + 0.5d0*CE%RebuildQunatity(1,iFaceX,iCenterY,1,2) &
                &   * (CE%RebuildQunatity(2,iFaceX,iCenterY,1,2)**2 + CE%RebuildQunatity(3,iFaceX,iCenterY,1,2)**2)

                RA%SideQuantity(1,2) = CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1)
                RA%SideQuantity(2,2) = CE%RebuildQunatity(2,iFaceX+1,iCenterY,1,1)*CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1)
                RA%SideQuantity(3,2) = CE%RebuildQunatity(3,iFaceX+1,iCenterY,1,1)*CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1)

                RA%SideQuantity(4,2) = InverseGmin1*CE%RebuildQunatity(4,iFaceX+1,iCenterY,1,1) &
                &   + 0.5d0*CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1) &
                &   * (CE%RebuildQunatity(2,iFaceX+1,iCenterY,1,1)**2 + CE%RebuildQunatity(3,iFaceX+1,iCenterY,1,1)**2)
                RA%TypeOfQuantity = 1
            end if
!___________________!call common2DFDS!________________________________

        call GetGeneralFlux(Geom,RA)
        SP4O%UF%DeltaQuantity(:) = RA%SideQuantity(:,2) - RA%SideQuantity(:,1)
        iSkip = 0
        do iVariable=1,4
            if(SP4O%UF%DeltaQuantity(iVariable) == 0.0d0) then
                iSkip = iSkip + 1
            end if
        end do
        if(iSkip /= 4) then
            call GetRoeAverage(Geom,RA,SP4O)
            !左右の固有ベクトルから風上化流束を求める
            call GetEigenMatrix(Geom,RA,FM,SP4O)
            !エントロピー補正
            do iLoop =1,iDim+2
                if(FM%AbsEigenValues(iLoop,iLoop) < Epsilon) then
                    FM%AbsEigenValues(iLoop,iLoop) = 0.5d0*(FM%AbsEigenValues(iLoop,iLoop)**2 + Epsilon**2)/Epsilon
                end if
            end do
            SP4O%UF%RoeFlux = matmul(matmul(matmul(FM%RightEigenMatrix,FM%AbsEigenValues),FM%LeftEigenMatrix),SP4O%UF%DeltaQuantity)
        else
            SP4O%UF%RoeFlux = 0.0d0
        end if
!___________________end common2DFDS________________________________

        CE%NormalFluxDiff(:,iFaceX,iCenterY,1,1) = &
        &   0.5d0 * ((RA%GeneralFlux(:,1,1)+RA%GeneralFlux(:,1,2)) - SP4O%UF%RoeFlux(:))

!___________________end directionX________________________________
        end do
    end do
!$omp end do
!$omp barrier
    RA%Direction = 2
!$omp do
    do iCenterX=1,Geom%CellNumber(1) !x方向はセル中心位置として
        do iFaceY=0,Geom%CellNumber(2) !すべてのy界面についての総和を取る
!___________________call directionY________________________________
        if(present(CC)) then !保存変数からの流束計算
            RA%SideQuantity(:,1) = CC%ConservedQuantity(:,iCenterX,iFaceY,1) !負側の保存量
            RA%SideQuantity(:,2) = CC%ConservedQuantity(:,iCenterX,iFaceY+1,1) !正側の保存量
            RA%TypeOfQuantity = 1
        else  !基礎変数からの流束計算
            RA%SideQuantity(1,1) = CE%RebuildQunatity(1,iCenterX,iFaceY,1,4) !負側の保存量
            RA%SideQuantity(2,1) = CE%RebuildQunatity(2,iCenterX,iFaceY,1,4) * CE%RebuildQunatity(1,iCenterX,iFaceY,1,4)
            RA%SideQuantity(3,1) = CE%RebuildQunatity(3,iCenterX,iFaceY,1,4) * CE%RebuildQunatity(1,iCenterX,iFaceY,1,4)
            RA%SideQuantity(4,1) = InverseGmin1*CE%RebuildQunatity(4,iCenterX,iFaceY,1,4) &
            &   + 0.5d0*CE%RebuildQunatity(1,iCenterX,iFaceY,1,4) &
            &   * (CE%RebuildQunatity(2,iCenterX,iFaceY,1,4)**2 + CE%RebuildQunatity(3,iCenterX,iFaceY,1,4)**2)
                RA%SideQuantity(1,2) = CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3)

            RA%SideQuantity(2,2) = CE%RebuildQunatity(2,iCenterX,iFaceY+1,1,3)*CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3)
            RA%SideQuantity(3,2) = CE%RebuildQunatity(3,iCenterX,iFaceY+1,1,3)*CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3)
            RA%SideQuantity(4,2) = InverseGmin1*CE%RebuildQunatity(4,iCenterX,iFaceY+1,1,3) &
            &   + 0.5d0*CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3) &
            &   * (CE%RebuildQunatity(2,iCenterX,iFaceY+1,1,3)**2 + CE%RebuildQunatity(3,iCenterX,iFaceY+1,1,3)**2)
            RA%TypeOfQuantity = 1
        end if

!___________________call common2DFDS________________________________
        call GetGeneralFlux(Geom,RA)
        SP4O%UF%DeltaQuantity(:) = RA%SideQuantity(:,2) - RA%SideQuantity(:,1)
        iSkip = 0
        do iVariable=1,4
            if(SP4O%UF%DeltaQuantity(iVariable) == 0.0d0) then
                iSkip = iSkip + 1
            end if
        end do
        if(iSkip /= 4) then
            call GetRoeAverage(Geom,RA,SP4O)
            !左右の固有ベクトルから風上化流束を求める
            call GetEigenMatrix(Geom,RA,FM,SP4O)
            !エントロピー補正
            do iLoop =1,iDim+2
                if(FM%AbsEigenValues(iLoop,iLoop) < Epsilon) then
                    FM%AbsEigenValues(iLoop,iLoop) = 0.5d0*(FM%AbsEigenValues(iLoop,iLoop)**2 + Epsilon**2)/Epsilon
                end if
            end do
            SP4O%UF%RoeFlux = matmul(matmul(matmul(FM%RightEigenMatrix,FM%AbsEigenValues),FM%LeftEigenMatrix),SP4O%UF%DeltaQuantity)
        else
            SP4O%UF%RoeFlux = 0.0d0
        end if
!___________________end common2DFDS________________________________

        CE%NormalFluxDiff(:,iCenterX,iFaceY,1,2) = &
        &   0.5d0 * ((RA%GeneralFlux(:,1,1)+RA%GeneralFlux(:,1,2)) - SP4O%UF%RoeFlux(:))

!___________________end directionY________________________________
        end do
    end do
!$omp end do
!$omp end parallel
    return

contains

    subroutine directionX !X方向界面流束
    implicit none
        if( present(CC)) then !保存変数からの流束計算
            RA%SideQuantity(:,1) = CC%ConservedQuantity(:,iFaceX,iCenterY,1) !負側の保存量
            RA%SideQuantity(:,2) = CC%ConservedQuantity(:,iFaceX+1,iCenterY,1) !正側の保存量
            RA%TypeOfQuantity = 1
        else  !基礎変数からの流束計算

            RA%SideQuantity(1,1) = CE%RebuildQunatity(1,iFaceX,iCenterY,1,2) !負側の保存量
            RA%SideQuantity(2,1) = CE%RebuildQunatity(2,iFaceX,iCenterY,1,2) * CE%RebuildQunatity(1,iFaceX,iCenterY,1,2)
            RA%SideQuantity(3,1) = CE%RebuildQunatity(3,iFaceX,iCenterY,1,2) * CE%RebuildQunatity(1,iFaceX,iCenterY,1,2)
            RA%SideQuantity(4,1) = InverseGmin1*CE%RebuildQunatity(4,iFaceX,iCenterY,1,2) &
            &   + 0.5d0*CE%RebuildQunatity(1,iFaceX,iCenterY,1,2) &
            &   * (CE%RebuildQunatity(2,iFaceX,iCenterY,1,2)**2 + CE%RebuildQunatity(3,iFaceX,iCenterY,1,2)**2)

            RA%SideQuantity(1,2) = CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1)

            RA%SideQuantity(2,2) = CE%RebuildQunatity(2,iFaceX+1,iCenterY,1,1)*CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1)

            RA%SideQuantity(3,2) = CE%RebuildQunatity(3,iFaceX+1,iCenterY,1,1)*CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1)

            RA%SideQuantity(4,2) = InverseGmin1*CE%RebuildQunatity(4,iFaceX+1,iCenterY,1,1) &
            &   + 0.5d0*CE%RebuildQunatity(1,iFaceX+1,iCenterY,1,1) &
            &   * (CE%RebuildQunatity(2,iFaceX+1,iCenterY,1,1)**2 + CE%RebuildQunatity(3,iFaceX+1,iCenterY,1,1)**2)

            RA%TypeOfQuantity = 1
        end if

        call common2DFDS

        CE%NormalFluxDiff(:,iFaceX,iCenterY,1,1) = &
        &   0.5d0 * ((RA%GeneralFlux(:,1,1)+RA%GeneralFlux(:,1,2)) - SP4O%UF%RoeFlux(:))

    return
    end subroutine directionX
!________________________________________________________

    subroutine directionY !Y方向界面流束
    implicit none

        if(present(CC)) then !保存変数からの流束計算
            RA%SideQuantity(:,1) = CC%ConservedQuantity(:,iCenterX,iFaceY,1) !負側の保存量
            RA%SideQuantity(:,2) = CC%ConservedQuantity(:,iCenterX,iFaceY+1,1) !正側の保存量
            RA%TypeOfQuantity = 1
        else  !基礎変数からの流束計算
            RA%SideQuantity(1,1) = CE%RebuildQunatity(1,iCenterX,iFaceY,1,4) !負側の保存量
            RA%SideQuantity(2,1) = CE%RebuildQunatity(2,iCenterX,iFaceY,1,4) * CE%RebuildQunatity(1,iCenterX,iFaceY,1,4)
            RA%SideQuantity(3,1) = CE%RebuildQunatity(3,iCenterX,iFaceY,1,4) * CE%RebuildQunatity(1,iCenterX,iFaceY,1,4)
            RA%SideQuantity(4,1) = InverseGmin1*CE%RebuildQunatity(4,iCenterX,iFaceY,1,4) &
            &   + 0.5d0*CE%RebuildQunatity(1,iCenterX,iFaceY,1,4) &
            &   * (CE%RebuildQunatity(2,iCenterX,iFaceY,1,4)**2 + CE%RebuildQunatity(3,iCenterX,iFaceY,1,4)**2)
                RA%SideQuantity(1,2) = CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3)

            RA%SideQuantity(2,2) = CE%RebuildQunatity(2,iCenterX,iFaceY+1,1,3)*CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3)
            RA%SideQuantity(3,2) = CE%RebuildQunatity(3,iCenterX,iFaceY+1,1,3)*CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3)
            RA%SideQuantity(4,2) = InverseGmin1*CE%RebuildQunatity(4,iCenterX,iFaceY+1,1,3) &
            &   + 0.5d0*CE%RebuildQunatity(1,iCenterX,iFaceY+1,1,3) &
            &   * (CE%RebuildQunatity(2,iCenterX,iFaceY+1,1,3)**2 + CE%RebuildQunatity(3,iCenterX,iFaceY+1,1,3)**2)
            RA%TypeOfQuantity = 1
        end if

        call common2DFDS
        CE%NormalFluxDiff(:,iCenterX,iFaceY,1,2) = &
        &   0.5d0 * ((RA%GeneralFlux(:,1,1)+RA%GeneralFlux(:,1,2)) - SP4O%UF%RoeFlux(:))

    return
    end subroutine directionY
!________________________________________________________

    subroutine common2DFDS
    implicit none

        call GetGeneralFlux(Geom,RA)
        SP4O%UF%DeltaQuantity(:) = RA%SideQuantity(:,2) - RA%SideQuantity(:,1)
        iSkip = 0
        do iVariable=1,4
            if(SP4O%UF%DeltaQuantity(iVariable) == 0.0d0) then
                iSkip = iSkip + 1
            end if
        end do
        if(iSkip /= 4) then
            call GetRoeAverage(Geom,RA,SP4O)
            !左右の固有ベクトルから風上化流束を求める
            call GetEigenMatrix(Geom,RA,FM,SP4O)
            !エントロピー補正
            do iLoop =1,iDim+2
                if(FM%AbsEigenValues(iLoop,iLoop) < Epsilon) then
                    FM%AbsEigenValues(iLoop,iLoop) = 0.5d0*(FM%AbsEigenValues(iLoop,iLoop)**2 + Epsilon**2)/Epsilon
                end if
            end do
            SP4O%UF%RoeFlux = matmul(matmul(matmul(FM%RightEigenMatrix,FM%AbsEigenValues),FM%LeftEigenMatrix),SP4O%UF%DeltaQuantity)
        else
            SP4O%UF%RoeFlux = 0.0d0
        end if

        return
    end subroutine common2DFDS

end subroutine UpwindFlux_Dim2


subroutine main(km, jm,             &
                Rd, Cpd, a, omega,  &
                delh, delv, Newt,   &
                dt, lat, lev,    &
                T, U, V, q, Vold,   &
                Tinc, Uinc, Vinc, qinc, psi, theta, theta_e, p, W, &
                Tdot, Udot, Vdot, qdot)

implicit none

! In
integer                  :: km,jm
real                     :: Rd, Cpd, a, omega
real                     :: dt, delh, delv, Newt
real,  dimension(jm)     :: lat
real,  dimension(km)     :: lev
real,  dimension(jm,km)  :: T, U, V, q, Vold

! Out
real, intent(out), dimension(jm,km) :: psi, theta, theta_e, p, W
real, intent(out), dimension(jm,km) :: Tinc,  Uinc,  Vinc,  qinc
real, intent(out), dimension(jm,km) :: Tdot,  Udot,  Vdot,  qdot

! Local
integer :: j,k
real :: pi, phi, dphi, dp, kappa, ps
real, dimension(jm,km)  :: sinphi, cosphi, tanphi
real, dimension(jm)     :: Vm

!shapiro
!complex, allocatable, dimension(:) :: dat, smo, old, cof
complex, dimension(jm) :: dat, smo
complex, dimension(8) :: old, cof
integer, save :: count

! Scalar parameters
pi    = abs(acos(-1.))
dphi  = (lat(2)-lat(1))/180.*pi
dp    = (lev(2)-lev(1)) * 100. ! mb -> Pa
kappa = Rd/Cpd

! Initialise pressure field
do j=1,jm
   p(j,:) = lev * 100. ! mb -> Pa
enddo
ps = lev(km)*100. + dp/2.

! Initialise trig fields
do j=1,jm
   phi = lat(j)/180.*pi
   sinphi(j,:)  = sin(phi) !max(abs(sin(phi)), 1.e-8)*sign(1.,phi)
   cosphi(j,:)  = cos(phi)
   tanphi(j,:)  = sinphi(j,:)/cosphi(j,:)
enddo

! -- Initialise radiative equilibrium pot. temperature structure (at midlayer)
!    following Held and Suarez (1994)
do k=1,km
   theta_e(:,k) = max( 200./(p(:,k)/ps)**kappa,       &
                  315. - delh*sinphi(:,k)**2               &
                  - delv*log10(p(:,k)/ps)*cosphi(:,k)**2      )
enddo

! Apply Shapiro filter every 10 time steps
if (count > 10 .and. jm > 8) then
   do k=1,km
      dat = V(:,k)
      ! 8th order, 2 passes, zero boundary conds
      call shpiro(smo,dat,cof,old,jm,8,2,0,1)
      V(:,k) = real(smo)
      dat = T(:,k)
      ! 8th order, 2 passes, zero boundary conds
      call shpiro(smo,dat,cof,old,jm,8,2,0,1)
      T(:,k) = real(smo)
   enddo
   count = 0
endif
count=count+1

! Get tendencies
call tendency(km, jm, a, Rd, kappa, omega, Newt, dphi, dp, dt, ps, p, T, U, V, q, &
     sinphi, cosphi, tanphi, theta_e, Tdot, Udot, Vdot, qdot, psi, theta, W)

! Compute increments
Tinc = Tdot *2.*dt
Uinc = Udot *2.*dt
Vinc = Vdot *2.*dt
qinc = qdot *2.*dt

! Impose non-divergent V (i.e. rigid boundary conditions)
! Do not need to solve an elliptic equation because it's a 1D problem here
! See http://mitgcm.org/pelican/online_documents/node32.html#eq:discrete-time-u
Vm = sum(Vold + Vinc, dim=2)/km
do k = 1,km
 Vinc(:,k) = Vinc(:,k) - Vm
enddo
Vdot = Vinc/2./dt

! Convert tendencies to K/day (for output only)
Tdot = Tdot * 86400.
Udot = Udot * 86400.
Vdot = Vdot * 86400.
qdot = qdot * 86400.

end subroutine main


      double complex function A1lcqqppmp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, November 2011
C---- taken from arXiv:1101.5947 [hep-ph], Eq. (55)
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'zabprods_decl.f'
      include 'epinv.f'
      include 'scale.f'
      double precision mt2
      double complex BSYA0qqppmp,BSYA1lcqqppmp,Vlc,lnrat
      integer e1,p2,p3,e4
      mt2=mt**2
c--- NB: added a minus sign in front of the double pole compared to Eq. (55)
      Vlc=-dcmplx(epinv**2)+dcmplx(epinv)*(8d0/3d0
     & -(lnrat(musq,-s(1,p2))+lnrat(mt2,-s(1,p2))))
      A1lcqqppmp=Vlc*BSYA0qqppmp(e1,p2,p3,e4,za,zb,zab,zba)
     &              +BSYA1lcqqppmp(e1,p2,p3,e4,za,zb,zab,zba)

      return
      end


! { dg-do run }
! Structure constructor with component naming.

PROGRAM test
  IMPLICIT NONE

  ! Structure of basic data types
  TYPE :: basics_t
    INTEGER :: i
    REAL :: r
    COMPLEX :: c
    LOGICAL :: l
  END TYPE basics_t

  TYPE(basics_t) :: basics

  basics = basics_t (42, -1.5, c=(.5, .5), l=.FALSE.)
  IF (basics%i /= 42 .OR. basics%r /= -1.5 &
      .OR. basics%c /= (.5, .5) .OR. basics%l) THEN
    CALL abort()
  END IF

  basics = basics_t (r=-1.5, i=42, l=.FALSE., c=(.5, .5))
  IF (basics%i /= 42 .OR. basics%r /= -1.5 &
      .OR. basics%c /= (.5, .5) .OR. basics%l) THEN
    CALL abort()
  END IF

END PROGRAM test


      module rjb

      implicit none (type, external)

      contains

      SUBROUTINE RJBESL(X, ALPHA, NB, B, NCALC)
C---------------------------------------------------------------------
C This routine calculates Bessel functions J sub(N+ALPHA) (X)
C   for non-negative argument X, and non-negative order N+ALPHA.
C
C
C  Explanation of variables in the calling sequence.
C
C   X     - working precision non-negative real argument for which
C           J's are to be calculated.
C   ALPHA - working precision fractional part of order for which
C           J's or exponentially scaled J'r (J*exp(X)) are
C           to be calculated.  0 <= ALPHA < 1.0.
C   NB  - integer number of functions to be calculated, NB > 0.
C           The first function calculated is of order ALPHA, and the
C           last is of order (NB - 1 + ALPHA).
C   B  - working precision output vector of length NB.  If RJBESL
C           terminates normally (NCALC=NB), the vector B contains the
C           functions J/ALPHA/(X) through J/NB-1+ALPHA/(X), or the
C           corresponding exponentially scaled functions.
C   NCALC - integer output variable indicating possible errors.
C           Before using the vector B, the user should check that
C           NCALC=NB, i.e., all orders have been calculated to
C           the desired accuracy.  See Error Returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C  Explanation of machine-dependent constants
C
C   it     = Number of bits in the mantissa of a working precision
C            variable
C   NSIG   = Decimal significance desired.  Should be set to
C            INT(LOG10(2)*it+1).  Setting NSIG lower will result
C            in decreased accuracy while setting NSIG higher will
C            increase CPU time without increasing accuracy.  The
C            truncation error is limited to a relative error of
C            T=.5*10**(-NSIG).
C   ENTEN  = 10.0 ** K, where K is the largest integer such that
C            ENTEN is machine-representable in working precision
C   ENSIG  = 10.0 ** NSIG
C   RTNSIG = 10.0 ** (-K) for the smallest integer K such that
C            K .GE. NSIG/4
C   ENMTEN = Smallest ABS(X) such that X/4 does not underflow
C   XLARGE = Upper limit on the magnitude of X.  If ABS(X)=N,
C            then at least N iterations of the backward recursion
C            will be executed.  The value of 10.0 ** 4 is used on
C            every machine.
C
C
C     Approximate values for some important machines are:
C
C
C                            it    NSIG    ENTEN       ENSIG
C
C   CRAY-1        (S.P.)     48     15    1.0E+2465   1.0E+15
C   Cyber 180/855
C     under NOS   (S.P.)     48     15    1.0E+322    1.0E+15
C   IEEE (IBM/XT,
C     SUN, etc.)  (S.P.)     24      8    1.0E+38     1.0E+8
C   IEEE (IBM/XT,
C     SUN, etc.)  (D.P.)     53     16    1.0D+308    1.0D+16
C   IBM 3033      (D.P.)     14      5    1.0D+75     1.0D+5
C   VAX           (S.P.)     24      8    1.0E+38     1.0E+8
C   VAX D-Format  (D.P.)     56     17    1.0D+38     1.0D+17
C   VAX G-Format  (D.P.)     53     16    1.0D+307    1.0D+16
C
C
C                           RTNSIG      ENMTEN      XLARGE
C
C   CRAY-1        (S.P.)    1.0E-4    1.84E-2466   1.0E+4
C   Cyber 180/855
C     under NOS   (S.P.)    1.0E-4    1.25E-293    1.0E+4
C   IEEE (IBM/XT,
C     SUN, etc.)  (S.P.)    1.0E-2    4.70E-38     1.0E+4
C   IEEE (IBM/XT,
C     SUN, etc.)  (D.P.)    1.0E-4    8.90D-308    1.0D+4
C   IBM 3033      (D.P.)    1.0E-2    2.16D-78     1.0D+4
C   VAX           (S.P.)    1.0E-2    1.17E-38     1.0E+4
C   VAX D-Format  (D.P.)    1.0E-5    1.17D-38     1.0D+4
C   VAX G-Format  (D.P.)    1.0E-4    2.22D-308    1.0D+4
C
C*******************************************************************
C*******************************************************************
C
C  Error returns
C
C    In case of an error,  NCALC .NE. NB, and not all J's are
C    calculated to the desired accuracy.
C
C    NCALC .LT. 0:  An argument is out of range. For example,
C       NBES .LE. 0, ALPHA .LT. 0 or .GT. 1, or X is too large.
C       In this case, B(1) is set to zero, the remainder of the
C       B-vector is not calculated, and NCALC is set to
C       MIN(NB,0)-1 so that NCALC .NE. NB.
C
C    NB .GT. NCALC .GT. 0: Not all requested function values could
C       be calculated accurately.  This usually occurs because NB is
C       much larger than ABS(X).  In this case, B(N) is calculated
C       to the desired accuracy for N .LE. NCALC, but precision
C       is lost for NCALC .LT. N .LE. NB.  If B(N) does not vanish
C       for N .GT. NCALC (because it is too small to be represented),
C       and B(N)/B(NCALC) = 10**(-K), then only the first NSIG-K
C       significant figures of B(N) can be trusted.
C
C
C  Intrinsic and other functions required are:
C
C     ABS, AINT, COS, DBLE, GAMMA (or DGAMMA), INT, MAX, MIN,
C
C     REAL, SIN, SQRT
C
C
C  Acknowledgement
C
C   This program is based on a program written by David J. Sookne
C   (2) that computes values of the Bessel functions J or I of real
C   argument and integer order.  Modifications include the restriction
C   of the computation to the J Bessel function of non-negative real
C   argument, the extension of the computation to arbitrary positive
C   order, and the elimination of most underflow.
C
C  References: "A Note on Backward Recurrence Algorithms," Olver,
C               F. W. J., and Sookne, D. J., Math. Comp. 26, 1972,
C               pp 941-947.
C
C              "Bessel Functions of Real Argument and Integer Order,"
C               Sookne, D. J., NBS Jour. of Res. B. 77B, 1973, pp
C               125-132.
C
C  Latest modification: March 19, 1990
C
C  Author: W. J. Cody
C          Applied Mathematics Division
C          Argonne National Laboratory
C          Argonne, IL  60439
C
C---------------------------------------------------------------------
      INTEGER I,J,K,L,M,MAGX,N,NB,NBMX,NCALC,NEND,NSTART
CS    REAL               GAMMA,
CD    DOUBLE PRECISION  DGAMMA,
       double precision
     1 ALPHA,ALPEM,ALP2EM,B,CAPP,CAPQ,EIGHTH,EM,EN,ENMTEN,ENSIG,
     2 ENTEN,FACT,FOUR,GNU,HALF,HALFX,ONE,ONE30,P,PI2,PLAST,
     3 POLD,PSAVE,PSAVEL,RTNSIG,S,SUM,T,T1,TEMPA,TEMPB,TEMPC,TEST,
     4 THREE,THREE5,TOVER,TWO,TWOFIV,TWOPI1,TWOPI2,X,XC,XIN,XK,XLARGE,
     5 XM,VCOS,VSIN,Z,ZERO
      DIMENSION B(NB), FACT(25)
C---------------------------------------------------------------------
C  Mathematical constants
C
C   PI2    - 2 / PI
C   TWOPI1 - first few significant digits of 2 * PI
C   TWOPI2 - (2*PI - TWOPI) to working precision, i.e.,
C            TWOPI1 + TWOPI2 = 2 * PI to extra precision.
C---------------------------------------------------------------------
CS    DATA PI2, TWOPI1, TWOPI2 /0.636619772367581343075535E0,6.28125E0,
CS   1 1.935307179586476925286767E-3/
CS    DATA ZERO, EIGHTH, HALF, ONE /0.0E0,0.125E0,0.5E0,1.0E0/
CS    DATA TWO, THREE, FOUR, TWOFIV /2.0E0,3.0E0,4.0E0,25.0E0/
CS    DATA ONE30, THREE5 /130.0E0,35.0E0/
CD    DATA PI2, TWOPI1, TWOPI2 /0.636619772367581343075535D0,6.28125D0,
CD   1 1.935307179586476925286767D-3/
CD    DATA ZERO, EIGHTH, HALF, ONE /0.0D0,0.125D0,0.5D0,1.0D0/
CD    DATA TWO, THREE, FOUR, TWOFIV /2.0D0,3.0D0,4.0D0,25.0D0/
CD    DATA ONE30, THREE5 /130.0D0,35.0D0/
C---------------------------------------------------------------------
C  Machine-dependent parameters
C---------------------------------------------------------------------
CS    DATA ENTEN, ENSIG, RTNSIG /1.0E38,1.0E8,1.0E-2/
CS    DATA ENMTEN, XLARGE /1.2E-37,1.0E4/
CD    DATA ENTEN, ENSIG, RTNSIG /1.0D38,1.0D17,1.0D-4/
CD    DATA ENMTEN, XLARGE /1.2D-37,1.0D4/
C---------------------------------------------------------------------
C     Factorial(N)
C---------------------------------------------------------------------
CS    DATA FACT /1.0E0,1.0E0,2.0E0,6.0E0,24.0E0,1.2E2,7.2E2,5.04E3,
CS   1 4.032E4,3.6288E5,3.6288E6,3.99168E7,4.790016E8,6.2270208E9,
CS   2 8.71782912E10,1.307674368E12,2.0922789888E13,3.55687428096E14,
CS   3 6.402373705728E15,1.21645100408832E17,2.43290200817664E18,
CS   4 5.109094217170944E19,1.12400072777760768E21,
CS   5 2.585201673888497664E22,6.2044840173323943936E23/
CD    DATA FACT /1.0D0,1.0D0,2.0D0,6.0D0,24.0D0,1.2D2,7.2D2,5.04D3,
CD   1 4.032D4,3.6288D5,3.6288D6,3.99168D7,4.790016D8,6.2270208D9,
CD   2 8.71782912D10,1.307674368D12,2.0922789888D13,3.55687428096D14,
CD   3 6.402373705728D15,1.21645100408832D17,2.43290200817664D18,
CD   4 5.109094217170944D19,1.12400072777760768D21,
CD   5 2.585201673888497664D22,6.2044840173323943936D23/
C---------------------------------------------------------------------
C Statement functions for conversion and the gamma function.
C---------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CS    FUNC(X) = GAMMA(X)
CD    CONV(I) = DBLE(I)
CD    FUNC(X) = DGAMMA(X)
C---------------------------------------------------------------------
C Check for out of range arguments.
C---------------------------------------------------------------------
      MAGX = INT(X)
      IF ((NB.GT.0) .AND. (X.GE.ZERO) .AND. (X.LE.XLARGE)
     1       .AND. (ALPHA.GE.ZERO) .AND. (ALPHA.LT.ONE))
     2   THEN
C---------------------------------------------------------------------
C Initialize result array to zero.
C---------------------------------------------------------------------
            NCALC = NB
            DO 20 I=1,NB
              B(I) = ZERO
   20       CONTINUE
C---------------------------------------------------------------------
C Branch to use 2-term ascending series for small X and asymptotic
C form for large X when NB is not too large.
C---------------------------------------------------------------------
            IF (X.LT.RTNSIG) THEN
C---------------------------------------------------------------------
C Two-term ascending series for small X.
C---------------------------------------------------------------------
               TEMPA = ONE
               ALPEM = ONE + ALPHA
               HALFX = ZERO
               IF (X.GT.ENMTEN) HALFX = HALF*X
               IF (ALPHA.NE.ZERO)
     1            TEMPA = HALFX**ALPHA/(ALPHA*gamma(ALPHA))
               TEMPB = ZERO
               IF ((X+ONE).GT.ONE) TEMPB = -HALFX*HALFX
               B(1) = TEMPA + TEMPA*TEMPB/ALPEM
               IF ((X.NE.ZERO) .AND. (B(1).EQ.ZERO)) NCALC = 0
               IF (NB .NE. 1) THEN
                  IF (X .LE. ZERO) THEN
                        DO 30 N=2,NB
                          B(N) = ZERO
   30                   CONTINUE
                     ELSE
C---------------------------------------------------------------------
C Calculate higher order functions.
C---------------------------------------------------------------------
                        TEMPC = HALFX
                        TOVER = (ENMTEN+ENMTEN)/X
                        IF (TEMPB.NE.ZERO) TOVER = ENMTEN/TEMPB
                        DO 50 N=2,NB
                          TEMPA = TEMPA/ALPEM
                          ALPEM = ALPEM + ONE
                          TEMPA = TEMPA*TEMPC
                          IF (TEMPA.LE.TOVER*ALPEM) TEMPA = ZERO
                          B(N) = TEMPA + TEMPA*TEMPB/ALPEM
                          IF ((B(N).EQ.ZERO) .AND. (NCALC.GT.N))
     1                       NCALC = N-1
   50                   CONTINUE
                  END IF
               END IF
            ELSE IF ((X.GT.TWOFIV) .AND. (NB.LE.MAGX+1)) THEN
C---------------------------------------------------------------------
C Asymptotic series for X .GT. 21.0.
C---------------------------------------------------------------------
               XC = SQRT(PI2/X)
               XIN = (EIGHTH/X)**2
               M = 11
               IF (X.GE.THREE5) M = 8
               IF (X.GE.ONE30) M = 4
               XM = FOUR*dble(M)
C---------------------------------------------------------------------
C Argument reduction for SIN and COS routines.
C---------------------------------------------------------------------
               T = AINT(X/(TWOPI1+TWOPI2)+HALF)
               Z = ((X-T*TWOPI1)-T*TWOPI2) - (ALPHA+HALF)/PI2
               VSIN = SIN(Z)
               VCOS = COS(Z)
               GNU = ALPHA + ALPHA
               DO 80 I=1,2
                 S = ((XM-ONE)-GNU)*((XM-ONE)+GNU)*XIN*HALF
                 T = (GNU-(XM-THREE))*(GNU+(XM-THREE))
                 CAPP = S*T/FACT(2*M+1)
                 T1 = (GNU-(XM+ONE))*(GNU+(XM+ONE))
                 CAPQ = S*T1/FACT(2*M+2)
                 XK = XM
                 K = M + M
                 T1 = T
                 DO 70 J=2,M
                   XK = XK - FOUR
                   S = ((XK-ONE)-GNU)*((XK-ONE)+GNU)
                   T = (GNU-(XK-THREE))*(GNU+(XK-THREE))
                   CAPP = (CAPP+ONE/FACT(K-1))*S*T*XIN
                   CAPQ = (CAPQ+ONE/FACT(K))*S*T1*XIN
                   K = K - 2
                   T1 = T
   70            CONTINUE
                 CAPP = CAPP + ONE
                 CAPQ = (CAPQ+ONE)*(GNU*GNU-ONE)*(EIGHTH/X)
                 B(I) = XC*(CAPP*VCOS-CAPQ*VSIN)
                 IF (NB.EQ.1) GO TO 300
                 T = VSIN
                 VSIN = -VCOS
                 VCOS = T
                 GNU = GNU + TWO
   80         CONTINUE
C---------------------------------------------------------------------
C If  NB .GT. 2, compute J(X,ORDER+I)  I = 2, NB-1
C---------------------------------------------------------------------
               IF (NB .GT. 2) THEN
                  GNU = ALPHA + ALPHA + TWO
                  DO 90 J=3,NB
                    B(J) = GNU*B(J-1)/X - B(J-2)
                    GNU = GNU + TWO
   90             CONTINUE
               END IF
C---------------------------------------------------------------------
C Use recurrence to generate results.  First initialize the
C calculation of P*S.
C---------------------------------------------------------------------
            ELSE
               NBMX = NB - MAGX
               N = MAGX + 1
               EN = dble(N+N) + (ALPHA+ALPHA)
               PLAST = ONE
               P = EN/X
C---------------------------------------------------------------------
C Calculate general significance test.
C---------------------------------------------------------------------
               TEST = ENSIG + ENSIG
               IF (NBMX .GE. 3) THEN
C---------------------------------------------------------------------
C Calculate P*S until N = NB-1.  Check for possible overflow.
C---------------------------------------------------------------------
                  TOVER = ENTEN/ENSIG
                  NSTART = MAGX + 2
                  NEND = NB - 1
                  EN = dble(NSTART+NSTART) - TWO + (ALPHA+ALPHA)
                  DO 130 K=NSTART,NEND
                     N = K
                     EN = EN + TWO
                     POLD = PLAST
                     PLAST = P
                     P = EN*PLAST/X - POLD
                     IF (P.GT.TOVER) THEN
C---------------------------------------------------------------------
C To avoid overflow, divide P*S by TOVER.  Calculate P*S until
C ABS(P) .GT. 1.
C---------------------------------------------------------------------
                        TOVER = ENTEN
                        P = P/TOVER
                        PLAST = PLAST/TOVER
                        PSAVE = P
                        PSAVEL = PLAST
                        NSTART = N + 1
  100                   N = N + 1
                           EN = EN + TWO
                           POLD = PLAST
                           PLAST = P
                           P = EN*PLAST/X - POLD
                        IF (P.LE.ONE) GO TO 100
                        TEMPB = EN/X
C---------------------------------------------------------------------
C Calculate backward test and find NCALC, the highest N such that
C the test is passed.
C---------------------------------------------------------------------
                        TEST = POLD*PLAST*(HALF-HALF/(TEMPB*TEMPB))
                        TEST = TEST/ENSIG
                        P = PLAST*TOVER
                        N = N - 1
                        EN = EN - TWO
                        NEND = MIN(NB,N)
                        DO 110 L=NSTART,NEND
                           POLD = PSAVEL
                           PSAVEL = PSAVE
                           PSAVE = EN*PSAVEL/X - POLD
                           IF (PSAVE*PSAVEL.GT.TEST) THEN
                              NCALC = L - 1
                              GO TO 190
                           END IF
  110                   CONTINUE
                        NCALC = NEND
                        GO TO 190
                     END IF
  130             CONTINUE
                  N = NEND
                  EN = dble(N+N) + (ALPHA+ALPHA)
C---------------------------------------------------------------------
C Calculate special significance test for NBMX .GT. 2.
C---------------------------------------------------------------------
                  TEST = MAX(TEST,SQRT(PLAST*ENSIG)*SQRT(P+P))
               END IF
C---------------------------------------------------------------------
C Calculate P*S until significance test passes.
C---------------------------------------------------------------------
  140          N = N + 1
                  EN = EN + TWO
                  POLD = PLAST
                  PLAST = P
                  P = EN*PLAST/X - POLD
               IF (P.LT.TEST) GO TO 140
C---------------------------------------------------------------------
C Initialize the backward recursion and the normalization sum.
C---------------------------------------------------------------------
  190          N = N + 1
               EN = EN + TWO
               TEMPB = ZERO
               TEMPA = ONE/P
               M = 2*N - 4*(N/2)
               SUM = ZERO
               EM = dble(N/2)
               ALPEM = (EM-ONE) + ALPHA
               ALP2EM = (EM+EM) + ALPHA
               IF (M .NE. 0) SUM = TEMPA*ALPEM*ALP2EM/EM
               NEND = N - NB
               IF (NEND .GT. 0) THEN
C---------------------------------------------------------------------
C Recur backward via difference equation, calculating (but not
C storing) B(N), until N = NB.
C---------------------------------------------------------------------
                  DO 200 L=1,NEND
                     N = N - 1
                     EN = EN - TWO
                     TEMPC = TEMPB
                     TEMPB = TEMPA
                     TEMPA = (EN*TEMPB)/X - TEMPC
                     M = 2 - M
                     IF (M .NE. 0) THEN
                        EM = EM - ONE
                        ALP2EM = (EM+EM) + ALPHA
                        IF (N.EQ.1) GO TO 210
                        ALPEM = (EM-ONE) + ALPHA
                        IF (ALPEM.EQ.ZERO) ALPEM = ONE
                        SUM = (SUM+TEMPA*ALP2EM)*ALPEM/EM
                     END IF
  200             CONTINUE
               END IF
C---------------------------------------------------------------------
C Store B(NB).
C---------------------------------------------------------------------
  210          B(N) = TEMPA
               IF (NEND .GE. 0) THEN
                  IF (NB .LE. 1) THEN
                        ALP2EM = ALPHA
                        IF ((ALPHA+ONE).EQ.ONE) ALP2EM = ONE
                        SUM = SUM + B(1)*ALP2EM
                        GO TO 250
                     ELSE
C---------------------------------------------------------------------
C Calculate and store B(NB-1).
C---------------------------------------------------------------------
                        N = N - 1
                        EN = EN - TWO
                        B(N) = (EN*TEMPA)/X - TEMPB
                        IF (N.EQ.1) GO TO 240
                        M = 2 - M
                        IF (M .NE. 0) THEN
                           EM = EM - ONE
                           ALP2EM = (EM+EM) + ALPHA
                           ALPEM = (EM-ONE) + ALPHA
                           IF (ALPEM.EQ.ZERO) ALPEM = ONE
                           SUM = (SUM+B(N)*ALP2EM)*ALPEM/EM
                        END IF
                  END IF
               END IF
               NEND = N - 2
               IF (NEND .NE. 0) THEN
C---------------------------------------------------------------------
C Calculate via difference equation and store B(N), until N = 2.
C---------------------------------------------------------------------
                  DO 230 L=1,NEND
                     N = N - 1
                     EN = EN - TWO
                     B(N) = (EN*B(N+1))/X - B(N+2)
                     M = 2 - M
                     IF (M .NE. 0) THEN
                        EM = EM - ONE
                        ALP2EM = (EM+EM) + ALPHA
                        ALPEM = (EM-ONE) + ALPHA
                        IF (ALPEM.EQ.ZERO) ALPEM = ONE
                        SUM = (SUM+B(N)*ALP2EM)*ALPEM/EM
                     END IF
  230             CONTINUE
               END IF
C---------------------------------------------------------------------
C Calculate B(1).
C---------------------------------------------------------------------
               B(1) = TWO*(ALPHA+ONE)*B(2)/X - B(3)
  240          EM = EM - ONE
               ALP2EM = (EM+EM) + ALPHA
               IF (ALP2EM.EQ.ZERO) ALP2EM = ONE
               SUM = SUM + B(1)*ALP2EM
C---------------------------------------------------------------------
C Normalize.  Divide all B(N) by sum.
C---------------------------------------------------------------------
  250          IF ((ALPHA+ONE).NE.ONE)
     1              SUM = SUM*gamma(ALPHA)*(X*HALF)**(-ALPHA)
               TEMPA = ENMTEN
               IF (SUM.GT.ONE) TEMPA = TEMPA*SUM
               DO 260 N=1,NB
                 IF (ABS(B(N)).LT.TEMPA) B(N) = ZERO
                 B(N) = B(N)/SUM
  260          CONTINUE
            END IF
C---------------------------------------------------------------------
C Error return -- X, NB, or ALPHA is out of range.
C---------------------------------------------------------------------
         ELSE
            B(1) = ZERO
            NCALC = MIN(NB,0) - 1
      END IF
C---------------------------------------------------------------------
C Exit
C---------------------------------------------------------------------
  300 RETURN
C ---------- Last line of RJBESL ----------
      END SUBROUTINE RJBESL

      end module rjb


!
! Copyright (C) 2001-2003 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#define TEST_NEW_PRECONDITIONING
!
!-----------------------------------------------------------------------
subroutine g_psi (lda, n, m, npol, psi, e)
  !-----------------------------------------------------------------------
  !
  !    This routine computes an estimate of the inverse Hamiltonian
  !    and applies it to m wavefunctions
  !
  USE kinds
  USE g_psi_mod
  implicit none
  integer :: lda, n, m, npol, ipol
  ! input: the leading dimension of psi
  ! input: the real dimension of psi
  ! input: the number of bands
  ! input: the number of coordinates of psi
  ! local variable: counter of coordinates of psi
  real(DP) :: e (m)
  ! input: the eigenvectors
  complex(DP) :: psi (lda, npol, m)
  ! inp/out: the psi vector
  !
  !    Local variables
  !
  real(DP), parameter :: eps = 1.0d-4
  ! a small number
  real(DP) :: x, scala, denm
  integer :: k, i
  ! counter on psi functions
  ! counter on G vectors
  !
  call start_clock ('g_psi')
  !
#ifdef TEST_NEW_PRECONDITIONING
  scala = 1.d0
  do ipol=1,npol
     do k = 1, m
        do i = 1, n
           x = (h_diag(i,ipol) - e(k)*s_diag(i,ipol))*scala
           denm = (1.d0+x+sqrt(1.d0+(x-1)*(x-1.d0)))/scala
        !         denm = 1.d0 + 16*x*x*x*x/(27.d0+18*x+12*x*x+8*x*x*x)
           psi (i, ipol, k) = psi (i, ipol, k) / denm
        enddo
     enddo
  enddo
#else
  do ipol=1,npol
     do k = 1, m
        do i = 1, n
           denm = h_diag (i,ipol) - e (k) * s_diag (i,ipol)
        !
        ! denm = g2+v(g=0) - e(k)
        !
           if (abs (denm) < eps) denm = sign (eps, denm)
        !
        ! denm = sign( max( abs(denm),eps ), denm )
        !
           psi (i, ipol, k) = psi (i, ipol, k) / denm
        enddo
     enddo
  enddo
#endif

  call stop_clock ('g_psi')
  return
end subroutine g_psi


        SUBROUTINE ZGETBT(INT,BIT1,BIT2,RESULT)
*
*  Module number:
*
*  Module name: ZGETBT
*
*  Keyphrase:
*  ----------
*       Extract specified bits
*  Description:
*  ------------
*       This routine will extract bits BIT1 through BIT2 from
*       UNSIGNED*2 integer value stored in integer*4 value INT
*       and place the result into RESULT.
*       Bit numbers start at true bit 16 since they are i*2
*       bit numbers in an i*4 word.
*       ALSO NOTE - all numbers are positive and thus 1 or 2's
*               complement hardware is not an issue.
*
*  FORTRAN name: zgetbt.for
*
*
*  Subroutines Called:
*  -------------------
*
*  History:
*  --------
*  Version      Date        Author          Description
*    1        D. Lindler  Feb. 1989     Designed and coded
*-------------------------------------------------------------------------------
*
* Inputs
*       INT - value to extract bits from (integer)
*       bit1 - FIRST BIT (starting at sign bit = 0)
*       bit2 - LAST BIT (integer 0 to 15)
* Outputs
*       RESULT - integer result containing the extracted bits
*------------------------------------------------------------------------------
C
C LOCAL VARIABLES
C
        INTEGER NBITS,BIT1,BIT2,RESULT,INT,RSHIFT
        REAL SHIFT
C
C------------------------------------------------------------------------------
        NBITS=BIT2-BIT1+1
C
C SHIFT INPUT TO PLACE BIT2 IN THE LAST BIT
C
        RESULT=INT
        RESULT=RESULT/(2**(15-BIT2))
C
C SHIFT NBITS OFF OF RESULT AND THEN SHIFT BACK ZEROS
C
        SHIFT=2**NBITS
        RSHIFT=RESULT/SHIFT
        RSHIFT=RSHIFT*SHIFT
C
C NOW SUBTRACT UPPER ORDER BITS
C
        RESULT=RESULT-RSHIFT
        RETURN
        END


!*==ctbcon.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CTBCON
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CTBCON + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
!                          RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          DIAG, NORM, UPLO
!       INTEGER            INFO, KD, LDAB, N
!       REAL               RCOND
!       ..
!       .. Array Arguments ..
!       REAL               RWORK( * )
!       COMPLEX            AB( LDAB, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CTBCON estimates the reciprocal of the condition number of a
!> triangular band matrix A, in either the 1-norm or the infinity-norm.
!>
!> The norm of A is computed and an estimate is obtained for
!> norm(inv(A)), then the reciprocal of the condition number is
!> computed as
!>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] NORM
!> \verbatim
!>          NORM is CHARACTER*1
!>          Specifies whether the 1-norm condition number or the
!>          infinity-norm condition number is required:
!>          = '1' or 'O':  1-norm;
!>          = 'I':         Infinity-norm.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!> \endverbatim
!>
!> \param[in] DIAG
!> \verbatim
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KD
!> \verbatim
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band matrix A.  KD >= 0.
!> \endverbatim
!>
!> \param[in] AB
!> \verbatim
!>          AB is COMPLEX array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!> \endverbatim
!>
!> \param[out] RCOND
!> \verbatim
!>          RCOND is REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (N)
!> \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 December 2016
!
!> \ingroup complexOTHERcomputational
!
!  =====================================================================
      SUBROUTINE CTBCON(Norm,Uplo,Diag,N,Kd,Ab,Ldab,Rcond,Work,Rwork,   &
     &                  Info)
      IMPLICIT NONE
!*--CTBCON147
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Diag , Norm , Uplo
      INTEGER Info , Kd , Ldab , N
      REAL Rcond
!     ..
!     .. Array Arguments ..
      REAL Rwork(*)
      COMPLEX Ab(Ldab,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL nounit , onenrm , upper
      CHARACTER normin
      INTEGER ix , kase , kase1
      REAL ainvnm , anorm , scale , smlnum , xnorm
      COMPLEX zdum
!     ..
!     .. Local Arrays ..
      INTEGER isave(3)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ICAMAX
      REAL CLANTB , SLAMCH
      EXTERNAL LSAME , ICAMAX , CLANTB , SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL CLACN2 , CLATBS , CSRSCL , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , AIMAG , MAX , REAL
!     ..
!     .. Statement Functions ..
      REAL CABS1
!     ..
!     .. Statement Function definitions ..
      CABS1(zdum) = ABS(REAL(zdum)) + ABS(AIMAG(zdum))
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      upper = LSAME(Uplo,'U')
      onenrm = Norm=='1' .OR. LSAME(Norm,'O')
      nounit = LSAME(Diag,'N')
!
      IF ( .NOT.onenrm .AND. .NOT.LSAME(Norm,'I') ) THEN
         Info = -1
      ELSEIF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -2
      ELSEIF ( .NOT.nounit .AND. .NOT.LSAME(Diag,'U') ) THEN
         Info = -3
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( Kd<0 ) THEN
         Info = -5
      ELSEIF ( Ldab<Kd+1 ) THEN
         Info = -7
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CTBCON',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Rcond = ONE
         RETURN
      ENDIF
!
      Rcond = ZERO
      smlnum = SLAMCH('Safe minimum')*REAL(MAX(N,1))
!
!     Compute the 1-norm of the triangular matrix A or A**H.
!
      anorm = CLANTB(Norm,Uplo,Diag,N,Kd,Ab,Ldab,Rwork)
!
!     Continue only if ANORM > 0.
!
      IF ( anorm>ZERO ) THEN
!
!        Estimate the 1-norm of the inverse of A.
!
         ainvnm = ZERO
         normin = 'N'
         IF ( onenrm ) THEN
            kase1 = 1
         ELSE
            kase1 = 2
         ENDIF
         kase = 0
         DO
            CALL CLACN2(N,Work(N+1),Work,ainvnm,kase,isave)
            IF ( kase/=0 ) THEN
               IF ( kase==kase1 ) THEN
!
!              Multiply by inv(A).
!
                  CALL CLATBS(Uplo,'No transpose',Diag,normin,N,Kd,Ab,  &
     &                        Ldab,Work,scale,Rwork,Info)
               ELSE
!
!              Multiply by inv(A**H).
!
                  CALL CLATBS(Uplo,'Conjugate transpose',Diag,normin,N, &
     &                        Kd,Ab,Ldab,Work,scale,Rwork,Info)
               ENDIF
               normin = 'Y'
!
!           Multiply by 1/SCALE if doing so will not cause overflow.
!
               IF ( scale/=ONE ) THEN
                  ix = ICAMAX(N,Work,1)
                  xnorm = CABS1(Work(ix))
                  IF ( scale<xnorm*smlnum .OR. scale==ZERO ) EXIT
                  CALL CSRSCL(N,scale,Work,1)
               ENDIF
               CYCLE
            ENDIF
!
!        Compute the estimate of the reciprocal condition number.
!
            IF ( ainvnm/=ZERO ) Rcond = (ONE/anorm)/ainvnm
            EXIT
         ENDDO
      ENDIF
!
!
!     End of CTBCON
!
      END SUBROUTINE CTBCON


module transpose_module

  implicit none

  private
  public :: rsdft_transpose
  public :: estimate_transpose

contains

  subroutine rsdft_transpose( a, nblk )

    implicit none
    real(8),intent(inout) :: a(:,:)
    integer,intent(in) :: nblk
    integer :: n,i,j,i0,i1,j0,j1,ii,jj
    real(8),allocatable :: blk(:,:),trp(:,:)

    n=size(a,1)
    allocate( blk(nblk,nblk) ); blk=0.0d0
    allocate( trp(nblk,nblk) ); trp=0.0d0

    do j0=1,n,nblk
       j1=min(j0+nblk-1,n)
       jj=j1-j0+1

       do i0=j0,n,nblk
          i1=min(i0+nblk-1,n)
          ii=i1-i0+1

          if ( i0 == j0 ) then

             do j=j0,j1
                do i=j+1,i1
                   blk(i-i0+1,j-j0+1)=a(i,j)
                end do
             end do
             trp(1:jj,1:ii)=transpose( blk(1:ii,1:jj) )
             do i=i0,i1
                do j=j0,i-1
                   a(j,i)=trp(j-j0+1,i-i0+1)
                end do
             end do

          else

             do j=j0,j1
                do i=i0,i1
                   blk(i-i0+1,j-j0+1)=a(i,j)
                end do
             end do
             trp(1:jj,1:ii)=transpose( blk(1:ii,1:jj) )
             do i=i0,i1
                do j=j0,j1
                   a(j,i)=trp(j-j0+1,i-i0+1)
                end do
             end do

          end if

       end do ! i0

    end do ! j0

    deallocate( trp )
    deallocate( blk )

  end subroutine rsdft_transpose

  subroutine estimate_transpose( n, nblk )
    implicit none
    integer,intent(in)  :: n
    integer,intent(out) :: nblk
    real(8),allocatable :: b(:,:)
    integer :: itry, it_best(3), i, j
    real(8) :: ct0,ct1,ct,ct_best(3)

    allocate( b(n,n) ); b=0.0d0

    nblk = 1
    ct_best(:) = 1.d100
    it_best(:) = 0

    do itry=1,10

       nblk = nblk*2
       if ( nblk >= n ) exit

       call cpu_time( ct0 )
       call rsdft_transpose( b, nblk )
       call cpu_time( ct1 )

       ct=ct1-ct0
       do i=1,3
          if ( ct < ct_best(i) ) then
             do j=3,i+1,-1
                ct_best(j) = ct_best(j-1)
                it_best(j) = it_best(j-1)
             end do
             ct_best(i) = ct
             it_best(i) = itry
          end if
       end do ! i

    end do ! itry

!    write(*,'(1x,3(f10.5,i10))') (ct_best(i), it_best(i), i=1,3)

    nblk = 2**it_best(1)

    deallocate( b )

  end subroutine estimate_transpose

end module transpose_module


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE INVFFT
      IMPLICIT NONE
C
C Purpose: Reverse fourier transform
C
      INCLUDE 'COMMON.FOR'
C
C Calls   9: COSQT  , DAWRT  , ERRMSG , FFT1D  , FILL   , GETCHN
C            GETHDR , GETXAX , OPNFIL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    COSTAB(513)
      INTEGER ICLO,JOP,IRC,IMEM,KREC,IFRAME,NCHAN
      INTEGER ISPEC1,LSPEC1,MEM1,IFFR1,ILFR1,INCR1,IFINC1
      INTEGER ISPEC2,LSPEC2,MEM2,IFFR2,ILFR2,INCR2,IFINC2
      INTEGER IHFMX1,IFRMX1,IHFMX2,IFRMX2,NCHANX,NCHAN1
      INTEGER ICH1,ICH2,NFRAM1,NFRAM2,I,J,K
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM1,HFNAM2,OFNAM
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMX1 : Nos. of frames in sequence
C IHFMX1 : Nos. of header file in sequence
C ISPEC1 : First header file in sequence
C LSPEC1 : Last header file in sequence
C MEM1   : Positional or calibration data indicator
C IFFR1  : First frame in sequence
C ILFR1  : Last frame in sequence
C INCR1  : Header file increment
C IFINC1 : Frame increment
C HFNAM1 : Header filename
C IFRMX2 : Nos. of frames in sequence
C IHFMX2 : Nos. of header file in sequence
C ISPEC2 : First header file in sequence
C LSPEC2 : Last header file in sequence
C MEM2   : Positional or calibration data indicator
C IFFR2  : First frame in sequence
C ILFR2  : Last frame in sequence
C INCR2  : Header file increment
C IFINC2 : Frame increment
C HFNAM2 : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C KREC   : Output file record
C IMEM   : Output memory dataset
C NCHAN  : Nos of data points in spectrum 1
C NCHAN1 : Nos of data points in spectrum 2
C NFRAME : Nos of time frames
C NCHANX : Nos. of data points in x-axis
C COSTAB : Cosine table
C
      DATA  IMEM/1/
C
C-----------------------------------------------------------------------
      WRITE (IPRINT,*) 'X-axis'
      CALL GETXAX (NCHANX,IRC)
      IF (IRC.NE.0) GOTO 999
10    ICLO=0
      JOP=0
      KREC=0
C
      WRITE (IPRINT,*) 'Modulus data'
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM1,ISPEC1,LSPEC1,INCR1,MEM1,
     1             IFFR1,ILFR1,IFINC1,IHFMX1,IFRMX1,NCHAN,IRC)
      IF (IRC.NE.0) GOTO 999
      WRITE (IPRINT,*) 'Phase data'
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM2,ISPEC2,LSPEC2,INCR2,MEM2,
     1             IFFR2,ILFR2,IFINC2,IHFMX2,IFRMX2,NCHAN1,IRC)
      IF (IRC.NE.0) GOTO 999
C
      IF (NCHAN1.NE.NCHAN) THEN
         CALL ERRMSG ('Error: Incompatible number of channels')
         GOTO 10
      ENDIF
      IF (IHFMX1.LT.IHFMX2) IHFMX1=IHFMX2
      IF (IFRMX1.LT.IFRMX2) IFRMX1=IFRMX2
      IFRAME=IHFMX1+IFRMX1-1
C
      CALL GETCHN (ITERM,IPRINT,NCHAN,ICH1,ICH2,IRC)
      IF (IRC.NE.0) GOTO 10
      CALL COSQT (11,COSTAB)
C
      DO 40 I=1,IFRAME
C
         IF (I.EQ.1.OR.INCR1.NE.0) THEN
            CALL OPNFIL (JUNIT,HFNAM1,ISPEC1,MEM1,IFFR1,ILFR1,NCHAN,
     1                   NFRAM1,IRC)
            IF (IRC.NE.0) GOTO 50
            ISPEC1=ISPEC1+INCR1
         ENDIF
         IF (I.EQ.1.OR.INCR2.NE.0) THEN
            CALL OPNFIL (LUNIT,HFNAM2,ISPEC2,MEM2,IFFR2,ILFR2,NCHAN1,
     1                   NFRAM2,IRC)
            IF (IRC.NE.0) GOTO 50
            ISPEC2=ISPEC2+INCR2
         ENDIF
C
         READ (JUNIT,REC=IFFR1) (SP1(K),K=1,NCHAN)
         READ (LUNIT,REC=IFFR2) (SP2(K),K=1,NCHAN)
         IFFR1=IFFR1+IFINC1
         IFFR2=IFFR2+IFINC2
         KREC=KREC+1
         IF (INCR1.NE.0) CLOSE (UNIT=JUNIT)
         IF (INCR2.NE.0) CLOSE (UNIT=LUNIT)
C
         CALL FILL (SP3,2048,0.0)
         CALL FILL (SP4,2048,0.0)
         DO 20 J=ICH1,ICH2
            SP3(J)=2.0*SP1(J)*COS(SP2(J))
            SP4(J)=2.0*SP1(J)*SIN(SP2(J))
20       CONTINUE
         CALL FFT1D (SP3,SP4,COSTAB,11,30,1)
C
         IF (IFRAME.EQ.1) CALL APLOT (ITERM,IPRINT,SP3,NCHAN)
         IF (KREC.GE.IFRAME) ICLO=1
         IF (KREC.EQ.1) THEN
            CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
            IF (IRC.NE.0) GOTO 50
         ENDIF
         CALL DAWRT (KUNIT,OFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1               SP3,KREC,JOP,ICLO,IRC)
         IF (IRC.NE.0) GOTO 50
40    CONTINUE
50    CLOSE (UNIT=JUNIT)
      CLOSE (UNIT=LUNIT)
      GOTO 10
999   RETURN
      END