module sub_

contains

  subroutine binninginit

    use fieldinfo_
    implicit none

    integer ::  np,i,j,i1,j1
    real ::  dlogl,lx,ly,labs
    real, dimension(npmax) :: lbinm,num

    if (bkind=='lin') then
       do np=1,npmax
          dlbin(np)=(lmax-lmin)/npmax
          lbinm(np)=lmin+dlbin(np)*(np-0.5)
          llowbin(np)=lmin+dlbin(np)*(np-1)
       enddo
    else
       do np=1,npmax
          dlogl=log(lmax/lmin)/npmax
          dlbin(np)=lmin*(exp(dlogl*np)-exp(dlogl*(np-1)))
          lbinm(np)=lmin*exp(dlogl*(np-0.5))
          llowbin(np)=lmin*exp(dlogl*(np-1))
       enddo
    endif
    llowbin(npmax+1)=lmax

    lbin=0.
    num=0.

    do j=1,nj
       j1 = j-1
       if (j1 > nj/2)  j1 = j1 - nj
       do i=1,ni
          i1 = i-1
          lx=float(i1)*(2.*pi)/rad1
          ly=float(j1)*(2.*pi)/rad2
          labs=sqrt(lx*lx+ly*ly)

          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle

          np=1
          do while (labs>=llowbin(np))
             np=np+1
          enddo
          np=np-1
          if (i==1) then
             lbin(np)=lbin(np)+labs
             num(np)=num(np)+1.
          else
             lbin(np)=lbin(np)+2.*labs
             num(np)=num(np)+2.
          endif
       enddo
    enddo
    lbin=lbin/num

  end subroutine binninginit

  subroutine recwin(s,nd,win)

    implicit none
    integer :: nd
    real :: s,win,spi
    real, parameter :: pi=3.14159265358979

    if (abs(s)<1.e-10) then
       win=1.
    else
       spi=s*pi
       win=(sin(spi)/(spi))/(sin(spi/nd)/(spi/nd))
       win=win*win
    endif

  end subroutine recwin

  subroutine readcl1(inf,cl)

    use fieldinfo_
    implicit none
    integer :: np
    real :: x
    real, pointer :: cl(:)
    character, intent(in) :: inf*100

    if (inf=="none") then
       cl=0.
    else
       open(1,file=inf,status='old')
       do np=1,npmax
          read(1,*) x,cl(np)
       enddo
       close(1)
    endif

  end subroutine readcl1

  subroutine readcl3(inf,cl)

    use fieldinfo_
    implicit none
    integer :: np,np2,np3
    real :: x
    real, pointer :: cl(:)
    character, intent(in) :: inf*100

    if (inf=="none") then
       cl=0.
    else
       open(1,file=inf,status='old')
       do np=1,npmax
          np2=np+npmax
          np3=np+npmax2
          read(1,*) x,cl(np),cl(np2),cl(np3)
       enddo
       close(1)
    endif

  end subroutine readcl3

  subroutine outcl3(outf,cl)

    use fieldinfo_
    implicit none

    integer :: np,np2,np3
    real, pointer :: cl(:)
    character, intent(in) :: outf*100

    write(*,*) 'output cl:',outf(1:len_trim(outf))
    open(2,file=outf,status='unknown')
    do np=1,npmax
       np2=np+npmax
       np3=np+npmax2
       write(2,'(4(1pe12.5,1x))') lbin(np),cl(np),cl(np2),cl(np3)
    enddo
    close(2)

  end subroutine outcl3

  subroutine outcl1(outf,cl)

    use fieldinfo_
    implicit none

    integer :: np
    real, pointer :: cl(:)
    character, intent(in) :: outf*100

    write(*,*) 'output cl:',outf(1:len_trim(outf))
    open(2,file=outf,status='unknown')
    do np=1,npmax
       write(2,*) lbin(np),cl(np)
    enddo
    close(2)

  end subroutine outcl1

  subroutine outinitpow(outf,clkappa,clshear)

    use fieldinfo_
    implicit none

    integer :: np,np2,np3
    real, pointer :: clkappa(:),clshear(:)
    character, intent(in) :: outf*100

    open(2,file=outf,status='unknown')
    do np=1,npmax
       np2=np+npmax
       np3=np+npmax2
       write(2,"(7(1pe12.5,1x))") lbin(np),clkappa(np),0.,0., &
            clshear(np),clshear(np2),clshear(np3)
    enddo
    close(2)
    deallocate(clkappa,clshear)

  end subroutine outinitpow

  subroutine randist(pos,idum)

!  create random distribution in range of [0,ni] and [0,nj]

    use fieldinfo_
    implicit none

    integer :: n,idum
    real, pointer :: pos(:,:)

    allocate(pos(ntot,2))
    do n=1,ntot
       pos(n,1)=ran2(idum)*ni
       pos(n,2)=ran2(idum)*nj
    enddo

  end subroutine randist

  subroutine gridpos(pos)

    use fieldinfo_
    implicit none
    integer :: n,i,j
    real, pointer :: pos(:,:)

    allocate(pos(ntot,2))
    n=0
    do j=1,nj
       do i=1,ni
          n=n+1
          pos(n,1)=i-0.5
          pos(n,2)=j-0.5
       enddo
    enddo

  end subroutine gridpos

  subroutine outsheardat(outf,pos,sdata)

!  output shear data
!    1st line: position(1:ntot,1:2)
!    2nd line: shear(1:ntot)

    use fieldinfo_
    implicit none

    integer :: n
    real :: rpart,ipart
    real, pointer :: pos(:,:)
    complex, pointer :: sdata(:)
    character(100) :: outf

    write(*,*) 'output shear data:',outf
    open(2,file=outf,status='unknown',form='unformatted')
    write(2) pos
    write(2) sdata
    close(2)

  end subroutine outsheardat

  subroutine readmat(inf,mat)

    use fieldinfo_
    implicit none

    integer :: np1,np2,i,j
    double precision ::   mat(npmax3,npmax3)
    character :: inf*100

    mat=0.d0
    if (inf(1:4)=='none') then
       do np2=1,npmax3
          do np1=1,npmax3
             if (np1==np2) mat(np1,np2)=1.d0
          enddo
       enddo
    else
       write(*,*) 'read mode-mode coupling matrix from'
       write(*,*) inf
       open(1,file=inf,status='old')
       do np2=1,npmax3
          do np1=1,npmax3
             read(1,*) i,j,mat(i,j)
          enddo
          read(1,*)
       enddo
       close(1)
    endif

  end subroutine readmat

  subroutine calcpow(shear,pow)

!   shear(ni,nj): shear field (ni x nj)
!   pow(npmax3): power spectrum for EE, BB, and EB

    use fieldinfo_

    implicit none

    integer ::  i,j,i1,j1,np,np1,np2,nn(2)
    complex, pointer :: shear(:,:)
    real, allocatable ::   g1(:,:),g2(:,:)
    real ::  lx,ly,labs,area,cos1,sin1,cos2,sin2,cellarea,pbl
    real ::  num(npmax)
    real, pointer :: pow(:)
    real ::  g1r,g1i,g2r,g2i,elr,eli,blr,bli,powee,powbb,poweb
    character ::  outf*100

    write(*,*)  'Calculate Power Spectrum'
    nn(1)=ni
    nn(2)=nj
    area=rad1*rad2
    cellarea=area/float(ni)/float(nj)

    allocate(g1(ni*2,nj),g2(ni*2,nj))
    do j=1,nj
       do i=1,ni
          g1(2*i-1,j)=real(shear(i,j))*cellarea
          g1(2*i,j)=0.
          g2(2*i-1,j)=imag(shear(i,j))*cellarea
          g2(2*i,j)=0.
       enddo
    enddo

    num=0.
    allocate(pow(npmax3))
    pow=0.

    call fourn(g1,nn,2,-1)
    call fourn(g2,nn,2,-1)

    do j=1,nj
       j1 = j-1
       if (j1 > nj/2)  j1 = j1 - nj
       do i=1,ni/2+1
          i1 = i-1
          lx=float(i1)/rad1*(2.*pi)
          ly=float(j1)/rad2*(2.*pi)
          labs=sqrt(lx*lx+ly*ly)
          pbl=labs*labs/2./pi

          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle

          cos1=lx/labs
          sin1=ly/labs
          cos2=cos1*cos1-sin1*sin1
          sin2=2.*sin1*cos1

          g1r = g1(2*i-1,j)
          g1i = g1(2*i,j)
          g2r = g2(2*i-1,j)
          g2i = g2(2*i,j)

          elr =  g1r*cos2 + g2r*sin2
          eli =  g1i*cos2 + g2i*sin2
          blr = -g1r*sin2 + g2r*cos2
          bli = -g1i*sin2 + g2i*cos2

          powee=elr*elr+eli*eli
          powbb=blr*blr+bli*bli
          poweb=elr*blr+eli*bli

          np=1
          do while (labs>=llowbin(np))
             np=np+1
          enddo
          np=np-1

          if (i==1) then
             num(np)=num(np)+1.
             pow(np)=pow(np)+powee*pbl
             pow(np+npmax)=pow(np+npmax)+powbb*pbl
             pow(np+npmax2)=pow(np+npmax2)+poweb*pbl
          else
             num(np)=num(np)+2.
             pow(np)=pow(np)+2.*powee*pbl
             pow(np+npmax)=pow(np+npmax)+2.*powbb*pbl
             pow(np+npmax2)=pow(np+npmax2)+2.*poweb*pbl
          endif

       enddo
    enddo

    do np=1,npmax
       if (num(np)>0.) then
          pow(np)=pow(np)/num(np)/area
          pow(np+npmax)=pow(np+npmax)/num(np)/area
          pow(np+npmax2)=pow(np+npmax2)/num(np)/area
       endif
    enddo

    deallocate(g1,g2)

  end subroutine calcpow

  subroutine calcpow_scalar(rhoin,pow)

    use fieldinfo_

    implicit none

    integer ::  i,j,i1,j1,np,np1,np2,nn(2)
    real, pointer ::  rhoin(:,:)
    real, allocatable :: rho(:,:)
    real ::  num(npmax),rhor,rhoi,lx,ly,labs,area,cellarea,pbl
    real ::  powrho,lnyq
    real, pointer ::  pow(:)
    character :: outf*100

    allocate(rho(2*ni,nj))
    nn(1)=ni
    nn(2)=nj
    area=rad1*rad2
    cellarea=area/float(ni)/float(nj)

    do j=1,nj
       do i=1,ni
          rho(2*i-1,j)=rhoin(i,j)*cellarea
          rho(2*i,j)=0.
       enddo
    enddo

    num=0.
    allocate(pow(npmax))
    pow=0.

    call fourn(rho,nn,2,-1)

    lnyq=2.*pi/rad1*(float(ni)/2.)

    do j=1,nj
       j1 = j-1
       if (j1 > nj/2)  j1 = j1 - nj
       do i=1,ni/2+1
          i1 = i-1
          lx=float(i1)/rad1*(2.*pi)
          ly=float(j1)/rad2*(2.*pi)
          labs=sqrt(lx*lx+ly*ly)
          pbl=labs*labs/2./pi

          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle

          rhor=rho(2*i-1,j)
          rhoi=rho(2*i,j)
          powrho=rhor*rhor+rhoi*rhoi

          np=1
          do while (labs>=llowbin(np))
             np=np+1
          enddo
          np=np-1

          if (i==1) then
             num(np)=num(np)+1.
             pow(np)=pow(np)+powrho*pbl
          else
             num(np)=num(np)+2.
             pow(np)=pow(np)+2.*powrho*pbl
          endif

       enddo
    enddo

    do np=1,npmax
       if (num(np)>0.) then
          pow(np)=pow(np)/num(np)/area
       endif
    enddo
    deallocate(rho)

  end subroutine calcpow_scalar

  subroutine readinitspec(inf,cl,ilmax)

    use fieldinfo_
    implicit none

    integer, intent(in) :: ilmax
    integer :: il,l
    real, intent(out) :: cl(ilmax)
    character, intent(in) :: inf*100

    write(*,*) 'Read Initial Spectrum from',inf

    cl=0.
    open(1,file=inf,status='old')
    do il=1,ilmax
       read(1,*) l,cl(l)
    enddo
    close(1)

  end subroutine readinitspec

  subroutine deconv_kappa(cl,mat)

    use fieldinfo_
    implicit none

    integer :: np,np2
    real, pointer ::  cl(:)
    real, allocatable :: cl2(:)
    double precision,dimension(npmax3,npmax3),intent(in) :: mat
    double precision,dimension(npmax,npmax) :: arr,invarr

    allocate(cl2(npmax))
    do np=1,npmax
       cl2(np)=cl(np)
       cl(np)=0.
       do np2=1,npmax
          arr(np,np2)=mat(np,np2)+mat(np+npmax,np2)
       enddo
    enddo
    call calcinvarray(arr,invarr,npmax)
    cl=matmul(invarr,cl2)
    deallocate(cl2)

  end subroutine deconv_kappa

  subroutine conv_kappa(cl,mat)

    use fieldinfo_
    implicit none

    integer :: np,np2
    real, pointer ::  cl(:)
    real, allocatable :: cl2(:)
    double precision,dimension(npmax3,npmax3),intent(in) :: mat

    allocate(cl2(npmax))
    do np=1,npmax
       cl2(np)=cl(np)
       cl(np)=0.
    enddo
    do np=1,npmax
       do np2=1,npmax
          cl(np)=cl(np)+(mat(np,np2)+mat(np+npmax,np2))*cl2(np2)
       enddo
    enddo
    deallocate(cl2)

  end subroutine conv_kappa

  subroutine deconv_shear(cl,mat,mat2)

    use fieldinfo_
    implicit none

    real, pointer ::  cl(:)
    real, allocatable :: cl2(:)
    double precision,dimension(npmax3,npmax3),intent(in) :: mat,mat2
    double precision :: imat(npmax3,npmax3)

    allocate(cl2(npmax3))
    cl2=cl
    call calcinvarray(matmul(mat2,mat),imat,npmax3)
    cl=matmul(imat,cl2)
    call conv_kappa(cl,mat)
    deallocate(cl2)

  end subroutine deconv_shear

  subroutine conv_shear(cl,mat,mat2)

    use fieldinfo_
    implicit none

    real, pointer ::  cl(:)
    real, allocatable :: cl2(:)
    double precision,dimension(npmax3,npmax3),intent(in) :: mat,mat2

    allocate(cl2(npmax3))
    cl2=cl
    cl=matmul(mat2,matmul(mat,cl2))
    deallocate(cl2)

  end subroutine conv_shear

  subroutine addnoise(sdata,idum)

    use fieldinfo_
    implicit none

    integer :: idum
    integer :: n
    real :: rpart,ipart
    complex, pointer :: sdata(:)

    write(*,*) 'add noise'
    do n=1,ntot
       rpart=normsinv(dble(ran2(idum)))*intshear
       ipart=normsinv(dble(ran2(idum)))*intshear
       sdata(n)=sdata(n)+cmplx(rpart,ipart)
    enddo

  end subroutine addnoise

  subroutine rotateshear(sdata,idum)

    use fieldinfo_
    implicit none

    integer :: n,idum
    complex, pointer :: sdata(:)
    real :: phase

    write(*,*) 'rotate shape'
    do n=1,ntot
       phase=2*pi*ran2(idum)
       sdata(n)=sdata(n)*cmplx(cos(phase),sin(phase))
    enddo

  end subroutine rotateshear

  real function dist(a,b,n)

    integer :: i,n
    real :: a(n),b(n),d

    d=0.
    do i=1,n
       d=d+(a(i)-b(i))*(a(i)-b(i))
    enddo

    dist=sqrt(d)

  end function dist

  SUBROUTINE spline(x,y,n,yp1,ypn,y2)
    IMPLICIT NONE
    INTEGER, INTENT(in) :: n
    REAL, INTENT(in) :: yp1,ypn
    REAL, DIMENSION(n), INTENT(in) :: x,y
    REAL, DIMENSION(n), INTENT(out) :: y2
    INTEGER, parameter :: NMAX=1500
    INTEGER :: i,k
    REAL :: p,qn,sig,un
    REAL, DIMENSION(NMAX) :: u
    if (yp1>.99e30) then
       y2(1)=0.
       u(1)=0.
    else
       y2(1)=-0.5
       u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
    endif
    do i=2,n-1
       sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
       p=sig*y2(i-1)+2.
       y2(i)=(sig-1.)/p
       u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1))) &
            /(x(i+1)-x(i-1))-sig*u(i-1))/p
    enddo
    if (ypn>.99e30) then
       qn=0.
       un=0.
    else
       qn=0.5
       un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
    endif
    y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
    do k=n-1,1,-1
       y2(k)=y2(k)*y2(k+1)+u(k)
    enddo

  END SUBROUTINE spline

  SUBROUTINE splint(xa,ya,y2a,n,x,y)

    IMPLICIT NONE
    INTEGER, INTENT(in) :: n
    REAL, INTENT(in) :: x
    REAL, INTENT(in), DIMENSION(n) :: xa, y2a, ya
    REAL, INTENT(out) :: y
    INTEGER :: k,khi,klo
    REAL :: a,b,h

    klo=1
    khi=n
    do
       k=(khi+klo)/2
       if(xa(k)>x)then
          khi=k
       else
          klo=k
       endif
       if (khi-klo<=1) exit
    end do
    h=xa(khi)-xa(klo)
    if (h==0.) then
       write(*,*) 'bad xa input in splint'
       stop
    endif
    a=(xa(khi)-x)/h
    b=(x-xa(klo))/h
    y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

  END SUBROUTINE splint

  SUBROUTINE fourn(data,nn,ndim,isign)

!
!   Replaces DATA by its NDIM-dimensional Fourier transform,
!  if ISIGN is input as 1. NN is an integer array of length NDIM,
!  containing the lengths of each dimension (number of complex
!  values), which MUST all be powers of 2. DATA is a real array
!  of length twice the product of these lengths, in which the data
!  are stored as in a multidimensional complex FORTRAN array. If
!  ISIGN is input as -1, DATA is replaced by its inverse transform
!  times the product of the lengths of all dimensions.
!
!     adopted from Numerical Recipes chapter 12, p.451.
! ====================================================================
!
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: ndim, isign, nn(ndim)
    REAL, INTENT(INOUT) :: data(2*product(nn))
    DOUBLE PRECISION, PARAMETER :: pi=3.141592653589793238d0
    DOUBLE PRECISION :: wr, wi, wpr, wpi, wtemp, theta
    INTEGER :: ntot, idim, nprev, n, nrem, ibit, ifp1, ifp2
    INTEGER :: i1, i2, i3, ip1, ip2, ip3, i2rev, i3rev, k1, k2
    REAL :: tempr, tempi
!
!  Compute total number of complex values.
!  ---------------------------------------
    ntot = product(nn)
!
!  Main loop over the dimensions.
!  ------------------------------
    nprev = 1
    do idim=1,ndim
       n = nn(idim)
       nrem  = ntot/(n*nprev)
       ip1   = 2*nprev
       ip2   = ip1*n
       ip3   = ip2*nrem
       i2rev = 1
!
!  This is the bit reversal section of the routine.
!  ------------------------------------------------
       do i2 = 1,ip2,ip1
          if (i2<i2rev) then
             do i1 = i2, i2+ip1-2,2
                do i3 = i1, ip3, ip2
                   i3rev = i2rev + i3 - i2
                   tempr = data(i3)
                   tempi = data(i3+1)
                   data(i3) = data(i3rev)
                   data(i3+1) = data(i3rev+1)
                   data(i3rev) = tempr
                   data(i3rev+1) = tempi
                enddo
             enddo
          endif
          ibit = ip2/2
          do while (ibit>ip1.and.i2rev>ibit)
             i2rev = i2rev - ibit
             ibit  = ibit/2
          end do
          i2rev = i2rev + ibit
       end do
!
!  Here begins the Danielson-Lanczos section of the routine.
!  ---------------------------------------------------------
       ifp1 = ip1
       do while (ifp1<ip2)
          ifp2  = 2*ifp1
          theta = isign*2.0*pi/(ifp2/ip1)
          wpr   = -2.d0*dsin(0.5d0*theta)**2
          wpi   = dsin(theta)
          wr    = 1.d0
          wi    = 0.d0
          do i3=1,ifp1,ip1
             do i1=i3,i3+ip1-2,2
                do i2=i1,ip3,ifp2
                   k1    = i2
                   k2    = k1 + ifp1
                   tempr = sngl(wr)*data(k2)   - sngl(wi)*data(k2+1)
                   tempi = sngl(wr)*data(k2+1) + sngl(wi)*data(k2)
                   data(k2)   = data(k1) - tempr
                   data(k2+1) = data(k1+1) - tempi
                   data(k1)   = data(k1) + tempr
                   data(k1+1) = data(k1+1) + tempi
                enddo
             enddo
             wtemp = wr
             wr    = wr*wpr - wi*wpi + wr
             wi    = wi*wpr + wtemp*wpi + wi
          enddo
          ifp1 = ifp2
       end do
       nprev = n*nprev
    enddo

  END SUBROUTINE fourn

  subroutine ave_sum(y,nmax,mean,var,nave)

    implicit none
    integer, intent(in) :: nmax,nave
    real, dimension(nmax), intent(in) :: y
    real, dimension(nmax), intent(inout) :: mean, var

    if (nave==1) then
       mean=y
       var=y*y
    else
       mean=mean+y
       var=var+y*y
    endif

  end subroutine ave_sum

  subroutine ave_div(mean,err,nmax,nave)

    implicit none

    integer, intent(in) :: nmax, nave
    real, dimension(nmax), intent(inout) ::  mean, err

    if (nave==1) then
       mean=mean
       err=0.
    else
       mean=mean/float(nave)
       err=err-float(nave)*mean**2
       err=err/float(nave-1)
       err=sqrt(err)
    endif

  end subroutine ave_div

  subroutine calcinvarray(covorg,incov,nmax)

    implicit none

    integer, intent(in) ::  nmax
    double precision, intent(in) :: covorg(nmax,nmax)
    double precision, intent(out) :: incov(nmax,nmax)
    double precision :: cov(nmax,nmax)
    integer ::  k, nx, ny, indx(nmax)
    double precision :: d, col(nmax)

    cov=covorg
    call ludcmp(cov,nmax,nmax,indx,d)
    do ny=1,nmax
       col=0.d0
       col(ny)=1.d0
       call lubksb(cov,nmax,nmax,indx,col)
       do nx=1,nmax
          incov(nx,ny)=col(nx)
       enddo
    enddo

    call invarraycheck(covorg,incov,nmax,nmax)

  end subroutine calcinvarray

  SUBROUTINE ludcmp(a,n,np,indx,d)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n, np
    INTEGER, INTENT(OUT) :: indx(n)
    INTEGER, PARAMETER :: NMAX=1300
    DOUBLE PRECISION, INTENT(OUT) :: d
    DOUBLE PRECISION, INTENT(INOUT) :: a(np,np)
    DOUBLE PRECISION, PARAMETER :: TINY=1.0d-20
    INTEGER :: i,imax,j,k
    DOUBLE PRECISION :: aamax,dum,sum,vv(NMAX)

    d=1.
    do i=1,n
       aamax=0.d0
       do j=1,n
          if (abs(a(i,j))>aamax) aamax=abs(a(i,j))
       enddo
       if (aamax==0.) then
          write(*,*) 'singular matrix in ludcmp'
          stop
       endif
       vv(i)=1./aamax
    enddo
    do j=1,n
       do i=1,j-1
          sum=a(i,j)
          do k=1,i-1
             sum=sum-a(i,k)*a(k,j)
          enddo
          a(i,j)=sum
       enddo
       aamax=0.
       do i=j,n
          sum=a(i,j)
          do k=1,j-1
             sum=sum-a(i,k)*a(k,j)
          enddo
          a(i,j)=sum
          dum=vv(i)*abs(sum)
          if (dum.ge.aamax) then
             imax=i
             aamax=dum
          endif
       enddo
       if (j/=imax)then
          do k=1,n
             dum=a(imax,k)
             a(imax,k)=a(j,k)
             a(j,k)=dum
          enddo
          d=-d
          vv(imax)=vv(j)
       endif
       indx(j)=imax
       if (a(j,j)==0.) a(j,j)=TINY
       if (j/=n) then
          dum=1./a(j,j)
          do i=j+1,n
             a(i,j)=a(i,j)*dum
          enddo
       endif
    enddo

  END SUBROUTINE ludcmp

  SUBROUTINE lubksb(a,n,np,indx,b)
    INTEGER, INTENT(IN) :: n,np
    INTEGER, INTENT(IN) :: indx(n)
    DOUBLE PRECISION, INTENT(IN) :: a(np,np)
    DOUBLE PRECISION, INTENT(INOUT) :: b(n)
    INTEGER :: i,ii,j,ll
    DOUBLE PRECISION :: sum

    ii=0
    do i=1,n
       ll=indx(i)
       sum=b(ll)
       b(ll)=b(i)
       if (ii/=0) then
          do j=ii,i-1
             sum=sum-a(i,j)*b(j)
          enddo
       else if (sum/=0.) then
          ii=i
       endif
       b(i)=sum
    enddo
    do i=n,1,-1
       sum=b(i)
       do j=i+1,n
          sum=sum-a(i,j)*b(j)
       enddo
       b(i)=sum/a(i,i)
    enddo

  END SUBROUTINE lubksb

  subroutine invarraycheck(a,b,nmax,ncheck)

    implicit none

    integer, intent(in) :: nmax,ncheck
    double precision, dimension(nmax,nmax), intent(in) :: a, b
    integer ::  nx,ny
    double precision :: e
    double precision, parameter :: tolerance=1.d-8

    do ny=1,ncheck
       do nx=1,ncheck
          e=dot_product(a(nx,:),b(:,ny))
          if (nx==ny) then
             if (abs(e-1.d0)>tolerance) then
                write(*,*) nx,ny,e
                write(*,*) 'accuracy of invarray is bad'
             endif
          else
             if (abs(e)>tolerance) then
                write(*,*) nx,ny,e
                write(*,*) 'accuracy of invarray is bad'
             endif
          endif
       enddo
    enddo

  end subroutine invarraycheck

  double precision function normsinv(p)

    implicit none

    double precision, parameter ::  &
         A1=-3.969683028665376e+01, &
         A2=2.209460984245205e+02 , &
         A3=-2.759285104469687e+02, &
         A4=1.383577518672690e+02, &
         A5=-3.066479806614716e+01, &
         A6=2.506628277459239e+00, &
         B1=-5.447609879822406e+01, &
         B2= 1.615858368580409e+02, &
         B3= -1.556989798598866e+02, &
         B4=   6.680131188771972e+01, &
         B5= -1.328068155288572e+01, &
         C1= -7.784894002430293e-03, &
         C2= -3.223964580411365e-01, &
         C3= -2.400758277161838e+00, &
         C4= -2.549732539343734e+00, &
         C5=  4.374664141464968e+00, &
         C6=  2.938163982698783e+00, &
         D1=  7.784695709041462e-03, &
         D2=  3.224671290700398e-01, &
         D3=  2.445134137142996e+00, &
         D4=  3.754408661907416e+00, &
         P_LOW= 0.02425, &
         P_HIGH=  0.97575

    double precision, intent(in) :: p
    double precision :: x, q, r, u, e
    if ((0<p).and.(p<P_LOW)) then
       q = sqrt(-2*log(p))
       x = (((((C1*q+C2)*q+C3)*q+C4)*q+C5)*q+C6)/((((D1*q+D2)*q+D3)*q+D4)*q+1)
    elseif ((P_LOW<=p).and.(p<=P_HIGH)) then
       q = p - 0.5
       r = q*q
       x = (((((A1*r+A2)*r+A3)*r+A4)*r+A5)*r+A6)*q &
            /(((((B1*r+B2)*r+B3)*r+B4)*r+B5)*r+1)
    elseif ((P_HIGH<p).and.(p<1)) then
       q = sqrt(-2*log(1-p))
       x = -(((((C1*q+C2)*q+C3)*q+C4)*q+C5)*q+C6) &
            / ((((D1*q+D2)*q+D3)*q+D4)*q+1)
    endif

    normsinv=x

  end function normsinv

  REAL FUNCTION ran2(idum)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT) :: idum
    INTEGER, PARAMETER :: IM1=2147483563,IM2=2147483399,IMM1=IM1-1
    INTEGER, PARAMETER :: IA1=40014,IA2=40692,IQ1=53668,IQ2=52774
    INTEGER, PARAMETER :: IR1=12211,IR2=3791,NTAB=32,NDIV=1+IMM1/NTAB
    REAL, PARAMETER :: AM=1./IM1,EPS=1.2e-7,RNMX=1.-EPS
    INTEGER :: idum2=123456789,j,k,iy=0
    INTEGER, DIMENSION(NTAB) :: iv=0

    if (idum.le.0) then
       idum=max(-idum,1)
       idum2=idum
       do j=NTAB+8,1,-1
          k=idum/IQ1
          idum=IA1*(idum-k*IQ1)-k*IR1
          if (idum.lt.0) idum=idum+IM1
          if (j.le.NTAB) iv(j)=idum
       enddo
       iy=iv(1)
    endif
    k=idum/IQ1
    idum=IA1*(idum-k*IQ1)-k*IR1
    if (idum.lt.0) idum=idum+IM1
    k=idum2/IQ2
    idum2=IA2*(idum2-k*IQ2)-k*IR2
    if (idum2.lt.0) idum2=idum2+IM2
    j=1+iy/NDIV
    iy=iv(j)-idum2
    iv(j)=idum
    if(iy.lt.1)iy=iy+IMM1
    ran2=min(AM*iy,RNMX)
    return
  END FUNCTION ran2

end module sub_


! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Basic test for PPCs with FUNCTION interface and NOPASS.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

  type t
    procedure(fcn), pointer, nopass :: ppc
    procedure(abstr), pointer, nopass :: ppc1
    integer :: i
  end type

  abstract interface
    integer function abstr(x)
      integer, intent(in) :: x
    end function
  end interface

  type(t) :: obj
  procedure(fcn), pointer :: f
  integer :: base

  intrinsic :: iabs

! Check with interface from contained function
  obj%ppc => fcn
  base=obj%ppc(2)
  if (base/=4) call abort
  call foo (obj%ppc,3)

! Check with abstract interface
  obj%ppc1 => obj%ppc
  base=obj%ppc1(4)
  if (base/=8) call abort
  call foo (obj%ppc1,5)

! Check compatibility components with non-components
  f => obj%ppc
  base=f(6)
  if (base/=12) call abort
  call foo (f,7)

contains

  integer function fcn(x)
    integer, intent(in) :: x
    fcn = 2 * x
  end function

  subroutine foo (arg, i)
    procedure (fcn), pointer :: arg
    integer :: i
    if (arg(i)/=2*i) call abort
  end subroutine

end


      function ddsum(n, din)
      use stel_kinds
      implicit none
      integer :: n
      real(rprec), intent(in) :: din(n)
      real(rprec) :: ddsum
!
!     accurate summation by sorting and
!     adding in increasing order
!
      logical is_all_negative, is_all_positive
      integer istart
      real(rprec) :: possum,negsum
      real(rprec), parameter :: zero = 0

      integer i, info
      integer, allocatable :: iperm(:)
      real(rprec), allocatable :: dinabs(:)
      real(rprec) dsum

!SIMPLE FUNCTIONALITY      ddsum = SUM(din)
!      return

      allocate (iperm(n), dinabs(n))

!     ------------------------
!     use shell sort to sort increasing abs value
!     ------------------------
      dinabs = abs(din)
      call dshell(n, dinabs, iperm )

      dsum = zero
      do i=1,n
         dsum = dsum + din(iperm(i))
      enddo

      ddsum = dsum

      deallocate (iperm, dinabs)

      return
      end function ddsum

      subroutine dshell(n,dx,iperm)
      use stel_kinds
      integer, intent(in) :: n
      integer, intent(out) :: iperm(n)
      real(rprec), intent(in) :: dx(n)
      integer :: i
      real(rprec) :: dtemp,dxert

      integer j,k,m,maxmn
      integer itemp

      do i=1,n
        iperm(i) = i
      enddo

      m = n/2
      do while (m.gt.0)
         maxmn = n - m

         do 23004 j = 1,maxmn
            do 23006 k = j,1,-m
            dxert = dx(iperm(k+m))
            if (dxert .ge. dx(iperm(k))) exit

            itemp = iperm(k+m)
            iperm(k+m) = iperm(k)
            iperm(k) = itemp

c      dtemp = dx(k+m)
c      dx(k+m) = dx(k)
c      dx(k) = dtemp

23006       continue
C end do k

23004    continue
C end do j

      m = m/2

      end do
C end while

      end subroutine dshell

      subroutine dshell2(n,arrin,iperm)
      use stel_kinds
      implicit none
      integer, intent(in) :: n
      integer, intent(out) :: iperm(n)
      real(rprec), intent(in) :: arrin(n)
      integer :: i, j, ir, m, indx
      real(rprec) :: dtemp

      do i=1,n
        iperm(i) = i
      enddo

      m = n/2+1
      ir = n

      do while (m .gt. 0)
         if (m .gt. 1) then
            m = m-1
            indx = iperm(m)
            dtemp = arrin(indx)
         else
            indx = iperm(ir)
            dtemp = arrin(indx)
            iperm(ir) = iperm(1)
            ir = ir-1
            if (ir .le. 1) then
!            if (ir .eq. 1) then
               iperm(1) = indx
               exit
            end if
         end if

         i = m
         j = m+m
         do while (j .le. ir)
            if (j .lt. ir) then
               if (arrin(iperm(j)) .lt. arrin(iperm(j+1))) j=j+1
            endif
            if (dtemp .lt. arrin(iperm(j))) then
               iperm(i) = iperm(j)
               i = j
               j = j+j
            else
               j = ir+1
            endif
         end do

         iperm(i) = indx

      end do

      end subroutine dshell2


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.

program test_utility

use mod_testing,only:assert,initialize_tests,report_tests
use mod_precision,only:rk => realkind,ik => intkind
use mod_utility,only:diff,diff_periodic,zeros,ones,range,tile
use mod_const,only:WAVY_REAL,WAVY_INT

implicit none

integer,parameter :: ndm = 1000

integer,parameter :: stdout = 6

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: ntests
integer :: n,norder

real(kind=rk),dimension(10) :: ones1d
real(kind=rk),dimension(10,10) :: ones2d
real(kind=rk),dimension(10,10,10) :: ones3d
real(kind=rk),dimension(10,10,10,10) :: ones4d

integer(kind=ik),dimension(10) :: ones1d_int
integer(kind=ik),dimension(10,10) :: ones2d_int
integer(kind=ik),dimension(10,10,10) :: ones3d_int
integer(kind=ik),dimension(10,10,10,10) :: ones4d_int

n = 1

! Edit this number when adding new tests
ntests = 41

call initialize_tests(tests,ntests)

tests(n) = assert(all(zeros(1,WAVY_INT) == [0]),&
                  'all(zeros(1,WAVY_INT) %  == [0])')
n = n + 1

tests(n) = assert(all(zeros(5,WAVY_INT) == [0,0,0,0,0]),&
                  'all(zeros(5,WAVY_INT) == [0,0,0,0,0]')
n = n + 1

tests(n) = assert(size(zeros(0,WAVY_INT)) == 0,&
                  'size(zeros(0,WAVY_INT)) == 0')
n = n + 1

tests(n) = assert(size(zeros(-5,WAVY_INT)) == 0,&
                  'size(zeros(-5,WAVY_INT)) == 0')
n = n + 1

tests(n) = assert(all(zeros(1,WAVY_REAL) == [0]),&
                  'all(zeros(1,WAVY_REAL) %  == [0])')
n = n + 1

tests(n) = assert(all(zeros(5,WAVY_REAL) == [0,0,0,0,0]),&
                  'all(zeros(5,WAVY_REAL) == [0,0,0,0,0]')
n = n + 1

tests(n) = assert(size(zeros(0,WAVY_REAL)) == 0,&
                  'size(zeros(0,WAVY_REAL)) == 0')
n = n + 1

tests(n) = assert(size(zeros(-5,WAVY_REAL)) == 0,&
                  'size(zeros(-5,WAVY_REAL)) == 0')
n = n + 1

tests(n) = assert(all(zeros(5,WAVY_REAL) == zeros(5,WAVY_INT)),&
                  'all(zeros(5,WAVY_REAL) == zeros(5,WAVY_INT))')
n = n + 1

tests(n) = assert(all(ones(5,WAVY_REAL) == ones(5,WAVY_INT)),&
                  'all(ones(5,WAVY_REAL) == ones(5,WAVY_INT))')
n = n + 1

tests(n) = assert(all(range(1,5,1) == [1,2,3,4,5]),&
                  'all(range(1,5,1) == [1,2,3,4,5])')
n = n + 1

tests(n) = assert(all(range(1,5) == [1,2,3,4,5]),&
                  'all(range(1,5) == [1,2,3,4,5])')
n = n + 1

tests(n) = assert(all(range(1,5) == range(1,5,1)),&
                  'all(range(1,5) == range(1,5,1))')
n = n + 1

tests(n) = assert(all(range(1,5,2) == [1,3,5]),&
                  'all(range(1,5,2) == [1,3,5])')
n = n + 1

tests(n) = assert(all(range(5,1,-1) == [5,4,3,2,1]),&
                  'all(range(5,1,-1) == [5,4,3,2,1])')
n = n + 1

tests(n) = assert(all(range(1._rk,5._rk,1._rk) == [1,2,3,4,5]),&
                  'all(range(1._rk,5._rk,1._rk) == [1,2,3,4,5])')
n = n + 1

tests(n) = assert(all(range(1._rk,5._rk) == [1,2,3,4,5]),&
                  'all(range(1._rk,5._rk) == [1,2,3,4,5])')
n = n + 1

tests(n) = assert(all(range(1._rk,5._rk) == range(1._rk,5._rk,1._rk)),&
                  'all(range(1._rk,5._rk) == range(1._rk,5._rk,1._rk))')
n = n + 1

tests(n) = assert(all(range(1._rk,5._rk,2._rk) == [1._rk,3._rk,5._rk]),&
                  'all(range(1._rk,5._rk,2._rk) == [1._rk,3._rk,5._rk])')
n = n + 1

tests(n) = assert(all(range(5._rk,1._rk,-1._rk)             &
                        == [5._rk,4._rk,3._rk,2._rk,1._rk]),&
                  'all(range(5._rk,1._rk,-1._rk)'           &
                   //'== [5._rk,4._rk,3._rk,2._rk,1._rk])')
n = n + 1

tests(n) = assert(all(range(1._rk,5._rk) == range(1,5)),&
                  'all(range(1._rk,5._rk) == range(1,5))')
n = n + 1

tests(n) = assert(all(diff(zeros(10,WAVY_REAL)) == zeros(10,WAVY_REAL)),&
                  'all(diff(zeros(10,WAVY_REAL)) == zeros(10,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff(ones(10,WAVY_REAL)) == zeros(10,WAVY_REAL)),&
                  'all(diff(ones(10,WAVY_REAL)) == zeros(10,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff(zeros(1,WAVY_REAL)) == zeros(1,WAVY_REAL)),&
                  'all(diff(zeros(1,WAVY_REAL)) == zeros(1,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff(ones(1,WAVY_REAL)) == zeros(1,WAVY_REAL)),&
                  'all(diff(ones(1,WAVY_REAL)) == zeros(1,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff(ones(0,WAVY_REAL)) == zeros(0,WAVY_REAL)),&
                  'all(diff(ones(0,WAVY_REAL)) == zeros(0,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff_periodic(zeros(10,WAVY_REAL)) == zeros(10,WAVY_REAL)),&
                  'all(diff_periodic(zeros(10,WAVY_REAL)) == zeros(10,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff_periodic(ones(10,WAVY_REAL)) == zeros(10,WAVY_REAL)),&
                  'all(diff_periodic(ones(10,WAVY_REAL)) == zeros(10,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff_periodic(zeros(1,WAVY_REAL)) == zeros(1,WAVY_REAL)),&
                  'all(diff_periodic(zeros(1,WAVY_REAL)) == zeros(1,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff_periodic(ones(1,WAVY_REAL)) == zeros(1,WAVY_REAL)),&
                  'all(diff_periodic(ones(1,WAVY_REAL)) == zeros(1,WAVY_REAL))')
n = n + 1

tests(n) = assert(all(diff_periodic(ones(0,WAVY_REAL)) == zeros(0,WAVY_REAL)),&
                  'all(diff_periodic(ones(0,WAVY_REAL)) == zeros(0,WAVY_REAL))')
n = n + 1

ones1d = 1
ones2d = 1
ones3d = 1
ones4d = 1

tests(n) = assert(all(tile(ones1d,10) == ones2d),'tile_1d_realkind')
n = n + 1

tests(n) = assert(all(tile(ones2d,10) == ones3d),'tile_2d_realkind')
n = n + 1

tests(n) = assert(all(tile(ones3d,10) == ones4d),'tile_3d_realkind')
n = n + 1

tests(n) = assert(size(tile(ones1d,0)) == 0,&
                  'tile_1d_realkind result of zero copies size')
n = n + 1

tests(n) = assert(all(shape(tile(ones1d,0)) == [10,0]),&
                  'tile_1d_realkind result of zero copies shape')
n = n + 1

ones1d_int = 1
ones2d_int = 1
ones3d_int = 1
ones4d_int = 1

tests(n) = assert(all(tile(ones1d_int,10) == ones2d_int),'tile_1d_intkind')
n = n + 1

tests(n) = assert(all(tile(ones2d_int,10) == ones3d_int),'tile_2d_intkind')
n = n + 1

tests(n) = assert(all(tile(ones3d_int,10) == ones4d_int),'tile_3d_intkind')
n = n + 1

tests(n) = assert(size(tile(ones1d_int,0)) == 0,&
                  'tile_1d_intkind result of zero copies size')
n = n + 1

tests(n) = assert(all(shape(tile(ones1d_int,0)) == [10,0]),&
                  'tile_1d_intkind result of zero copies shape')
n = n + 1

write(unit=stdout,fmt='(80("-"))')

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_utility


submodule(euler_interface_m) euler_prob_0036_m
    implicit none

contains

    module character(len=20) function euler0036()
        write (euler0036, "(i20)") ans(1000000_int64)
    end function euler0036

    integer(int64) function ans(n)
        integer(int64), intent(in) :: n
        integer(int64) :: isum, i, next_ten_pow, p

        isum = 0_int64; i = 1_int64
        next_ten_pow = 10_int64
        p = gen_single_palindormic_10(i)

        do while (p <= n)
            if (is_palindromic_2(p)) then
                isum = isum + p
            end if

            p = p + (i - i/10_int64)*next_ten_pow
            if (p <= n .and. is_palindromic_2(p)) isum = isum + p

            i = i + 1_int64
            if (i == next_ten_pow) then
                next_ten_pow = next_ten_pow*10_int64
            end if
            p = gen_single_palindormic_10(i)
        end do
        ans = isum
    end function ans

    integer(int64) function gen_single_palindormic_10(n)
        integer(int64), intent(in) :: n
        integer(int64) :: tmp, i

        tmp = n
        i = n/10_int64

        do while (i > 0_int64)
            tmp = tmp*10_int64 + mod(i, 10_int64)
            i = i/10_int64
        end do

        gen_single_palindormic_10 = tmp
    end function gen_single_palindormic_10

    logical function is_palindromic_2(n)
        integer(int64), intent(in) :: n
        integer(int64) :: a, b, digit

        a = n
        b = 0_int64
        do while (a > 0_int64)
            digit = mod(a, 2_int64)
            b = b*2_int64 + digit
            a = a/2_int64
        end do

        if (n == b) then
            is_palindromic_2 = .true.
        else
            is_palindromic_2 = .false.
        end if
    end function is_palindromic_2
end submodule euler_prob_0036_m


      SUBROUTINE CONDI(H,j,m,co,si,conda)

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

      dimension co(m),si(m),H(m+1,m)

      do ii=1,1000

C     *** RQ ***

      do i=1,j-1
         t1=h(i,i)
         t2=h(i,i+1)
         t4=h(i+1,i+1)
         c=co(i)
         s=si(i)
         h(i+1,i)  =  s*t4
         h(i,i)    =  c*t1+s*t2
         h(i,i+1)  = -s*t1+c*t2
         h(i+1,i+1)=  c*t4
      enddo

C     *** condA ***

      alam1=1000.0
      alam2=0.0
      do i=1,j
C         Write(*,*)H(i,i)
         if(dabs(H(i,i)).LT.alam1) alam1=dabs(H(i,i))
         if(dabs(H(i,i)).GT.alam2) alam2=dabs(H(i,i))
      enddo
      condA=alam2/alam1
      write(*,*)'Nbre de cond de A=',condA

C     *** QR ***

      do jj=1,j-1

         DO i=1, jj-1
            temp   =  H(i,jj)*co(i) + H(i+1,jj)*si(i)
            H(i+1,jj) = -H(i,jj)*si(i) + H(i+1,jj)*co(i)
            H(i,jj)   =  temp
         ENDDO

         temp=DSQRT(H(jj,jj)*H(jj,jj)+H(jj+1,jj)*H(jj+1,jj))
         si(jj)=H(jj+1,jj)/temp
         co(jj)=H(jj,jj)/temp

         i=jj
         temp        =  H(i,jj)*co(i) + H(i+1,jj)*si(i)
         H(i+1,jj)   = -H(i,jj)*si(i) + H(i+1,jj)*co(i)
         H(i,jj)     =  temp

      enddo

      enddo

      RETURN
      END


        program simpleshear
c
          implicit none
c
          double precision :: dgam, gam, gf, b
          double precision :: F0(9), F1(9)
          double precision :: F(9),dF(9),l(9),D(9),W(9),R(9),logc
          double precision :: ep(9), deps(9), eR(9), Re(9)
          double precision :: sig (9), sigR(9), Rsig(9)
          double precision :: sigp(9), epp(9)
          double precision :: cm(20), hisv(11), gamout(6)
          integer incout(6),place
          integer i,inc
c
          dgam = 0.0005_8
          gam = 0.0_8
          gf = 0.002_8
c          gf = 6.001_8
          b = 0.5_8
c          gamout = (/ 0.005_8,0.1_8,0.5_8,1.0_8,3.0_8,6.0_8 /)
c          incout = gamout / dgam
c          incout = incout + 1
          place = 1
c
          inc = gf/dgam
          cm(1) = 1
          cm(2) = 2530.0_8
          cm(3) = 30.4e9_8
          cm(4) = 0.93_8
          cm(5) = 0.20_8
          cm(6) = 0.003_8
          cm(7) = 1.00_8
          cm(8) = 0.77_8
          cm(9) = 1.0_8
          cm(10) = 0.015e9_8
          cm(11) = 0.5_8
          cm(12) = 5.95e9_8
          cm(13) = 2.92e9_8
          cm(14) = 1.0_8
          cm(15) = 0.043_8
          cm(16) = 0.85_8
          cm(17) = 45.4e9_8
          cm(18) = -138e9_8
          cm(19) = 290e9_8
          cm(20) = 2.4_8
c
          ep = 0.0_8
          deps = 0.0_8
          sig = 0.0_8
          D = 0.0_8
          F1 = (/ 1.0_8, 0.0_8, 0.0_8,
     &            0.0_8, 1.0_8, 0.0_8,
     &            0.0_8, 0.0_8, 1.0_8 /)
c
          do i=1,inc
c
c           Get kinematics of deformation
c
            F0 = F1
            F1 = (/ 1.0_8,   gam, 0.0_8,
     &              0.0_8, 1.0_8, 0.0_8,
     &              0.0_8, 0.0_8, 1.0_8 /)
c
            call kindef (F0,F1,b, dF,F,l,D,W)
c
c           Perform objective update on strain
c
             if (i.ne.1) then
                logc = dgam/(4.0_8+gam*gam)
                logc = logc + dgam*gam*0.25_8/(SQRT(4+gam*gam)
     &                        *ASINH(gam/2))
                R = logc*(/ 0,1,0,-1,0,0,0,0,0 /)
             else
	        R = 0.0_8
             end if
c            R = W
            call tc_2s2 (ep,R,eR)
            call tc_2s2 (R,ep,Re)
c           +Objective Update of Strain HERE
             deps = D
c            deps = D - eR + Re
            ep = ep + deps -eR + Re
c
c           Perform objective update on stress (-sigW + Wsig, the objective update)
c
            call tc_2s2 (sig,R,sigR)
            call tc_2s2 (R,sig,Rsig)
c           +Objective Update of Stress HERE
            sig = sig - sigR + Rsig
c
c           Perform stress update on stress (sig dot hat, the stress update)
c
            call CH (ep, epp)
	    call CH (sig, sigp)
c            call umat_elastic (cm,deps,sig,hisv)
c            call umat_43 (cm,sig,deps,hisv,0.0_8,0.0_8)
           call umat_JH2 (cm,sig,deps,hisv,0.0_8,0.0_8)
c           if (i.eq.incout(place)) then
c               print "(27e15.6)",gam,ep,sig,
c     &               epp(1),epp(5),epp(9),sigp(1),sigp(5),sigp(9),
c     &               hisv(1),hisv(11)
c               place = place + 1
c
c            end if
c
            print *,
            print *,"gamma:"
            print "(1e12.4)",gam
            print *,
            print *,"ep"
            call t2print (ep)
            print *,
            print *,"deps"
            call t2print (deps)
            print *,
            print *,"R"
            call t2print (R)
            print *,
            print *,"D"
            call t2print (D)
            print *,
            print *,"sig"
            call t2print (sig)
            print *,
            gam = gam + dgam
c
          end do
c
        end program simpleshear
c


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Program name: FiveBodyMD.f90
!
! Program Purpose:
!                  Solve ten-bodies probelm with Nose-Hoover Thermostat in molecule simulation.
!  Version message:
!        Date          Programmer            Description of change
!      ========       ============          =========================
!  1.  36/4/2016      Yang Yang :-)               Source Code
!
!
!
! A brief algorithm introduction:
! First time step is caculated using velocity-verlet algorithm and other time step is
! caculated using verlet algorithm. Velocity is caculated using centered differential scheme.
! $r(0 + \delta t) = 2r(0) - \delta t*v(0) + \frac{1}{2} \delta \t^{2} a(0)$
!!$v(0 + \delta t) = v(t) + \frac{1}{2} \delta t [a(0) + a(0 + \delta t)]$
! $r(t+\delta t) = 2r(t) - r(t - \delta t)+ \delta \t^{2}a(t)$
! $v(t) = [r(t + \delta t) - r(t - \delta t)] / 2\delta t$
! $v(N) = [r(N) - r(N - \delta t)] / \delta t$
! external field : $V(r) = \frac{1}{2} \r^{2}
! internal reaction : Leonard-Jones 6-12 potential  $V(r_{ij}) = 4[(\frac{1}{r_{ij}})^{12} - (\frac{1}{r_{ij}})^{6}]
! Nose-Hoover thermostat: $zeta(t_\delta t) = zeta(t) + frac{\Sigma m_{i}v_{i}^2 - N_{f}T}{Q} \delta t$    ~ O(delta_t)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!------------------------------------------------------------------------------------------------
! Setup computing parameters
MODULE ParametersBlock
implicit none

integer, parameter:: N_particles = 10                                                      ! Number of particle
integer, parameter:: N_dimension = 3                                                       ! Problem dimension

!real*8, parameter:: Mass = 1.d0                                                            ! Particles' mass (this term is not necessary!)

integer(kind=8), parameter:: N_time = 50000000000                                          ! Number of time step
real*8, parameter::  delta_t = 1.d-7                                                       ! Time step size  (really important)

real*8, parameter:: Temperature = 150.d0                                                   ! Temeprature of thermostat
!real*8, parameter:: Qm = N_particles * N_dimension * (10000000000*delta_t)**2             ! Thermostat's equvalent mass
real*8, parameter:: Qm = 1.d0                                                             ! Thermostat's equvalent mass

integer(kind=8), parameter:: Output_interval = 100000                                      ! Output interval

character(len=20), parameter:: OutputFile = 'result.txt'                                   ! Output file name

real*8, parameter:: pi = 3.1415926535897932384626433832795028841971693993751d0             ! Constant ratio of circumference

! distribution in a ball in three-dimension space
real*8, parameter:: x1_ini = cos(0.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi),&
& y1_ini = sin(0.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi), z1_ini = cos(60.d0/180.d0 * pi)        ! Particle No.1's position

real*8, parameter:: x2_ini = cos(34.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi),&
& y2_ini = sin(34.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi), z2_ini = cos(120.d0/180.d0 * pi)     ! Particle No.2's position

real*8, parameter:: x3_ini = cos(70.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi),&
& y3_ini = sin(70.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi), z3_ini = cos(60.d0/180.d0 * pi)     ! Particle No.3's position

real*8, parameter:: x4_ini = cos(110.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi),&
& y4_ini = sin(110.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi), z4_ini = cos(120.d0/180.d0 * pi)    ! Particle No.4's position

real*8, parameter:: x5_ini = cos(142.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi),&
& y5_ini = sin(142.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi), z5_ini = cos(60.d0/180.d0 * pi)    ! Particle No.5's position

real*8, parameter:: x6_ini = cos(181.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi),&
& y6_ini = sin(181.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi), z6_ini = cos(120.d0/180.d0 * pi)  ! Particle No.6's position

real*8, parameter:: x7_ini = cos(214.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi),&
& y7_ini = sin(214.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi), z7_ini = cos(60.d0/180.d0 * pi)  ! Particle No.7's position

real*8, parameter:: x8_ini = cos(256.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi),&
& y8_ini = sin(256.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi), z8_ini = cos(120.d0/180.d0 * pi)  ! Particle No.8's position

real*8, parameter:: x9_ini = cos(290.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi),&
& y9_ini = sin(290.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi), z9_ini = cos(60.d0/180.d0 * pi)  ! Particle No.9's position

real*8, parameter:: x10_ini = cos(324.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi),&
& y10_ini = sin(324.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi), z10_ini = cos(120.d0/180.d0 * pi) ! Particle No.10's position

!real*8, parameter:: x1_ini = cos(0.d0/180.d0 * pi)*sin(0.d0/180.d0 * pi),&
!& y1_ini = sin(0.d0/180.d0 * pi)*sin(0.d0/180.d0 * pi), z1_ini = cos(0.d0/180.d0 * pi)        ! Particle No.1's position
!
!real*8, parameter:: x2_ini = cos(36.d0/180.d0 * pi)*sin(20.d0/180.d0 * pi),&
!& y2_ini = sin(36.d0/180.d0 * pi)*sin(20.d0/180.d0 * pi), z2_ini = cos(20.d0/180.d0 * pi)     ! Particle No.2's position
!
!real*8, parameter:: x3_ini = cos(72.d0/180.d0 * pi)*sin(40.d0/180.d0 * pi),&
!& y3_ini = sin(72.d0/180.d0 * pi)*sin(40.d0/180.d0 * pi), z3_ini = cos(40.d0/180.d0 * pi)     ! Particle No.3's position
!
!real*8, parameter:: x4_ini = cos(108.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi),&
!& y4_ini = sin(108.d0/180.d0 * pi)*sin(60.d0/180.d0 * pi), z4_ini = cos(60.d0/180.d0 * pi)    ! Particle No.4's position
!
!real*8, parameter:: x5_ini = cos(144.d0/180.d0 * pi)*sin(80.d0/180.d0 * pi),&
!& y5_ini = sin(144.d0/180.d0 * pi)*sin(80.d0/180.d0 * pi), z5_ini = cos(80.d0/180.d0 * pi)    ! Particle No.5's position
!
!real*8, parameter:: x6_ini = cos(180.d0/180.d0 * pi)*sin(100.d0/180.d0 * pi),&
!& y6_ini = sin(180.d0/180.d0 * pi)*sin(100.d0/180.d0 * pi), z6_ini = cos(100.d0/180.d0 * pi)  ! Particle No.6's position
!
!real*8, parameter:: x7_ini = cos(216.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi),&
!& y7_ini = sin(216.d0/180.d0 * pi)*sin(120.d0/180.d0 * pi), z7_ini = cos(120.d0/180.d0 * pi)  ! Particle No.7's position
!
!real*8, parameter:: x8_ini = cos(252.d0/180.d0 * pi)*sin(140.d0/180.d0 * pi),&
!& y8_ini = sin(252.d0/180.d0 * pi)*sin(140.d0/180.d0 * pi), z8_ini = cos(140.d0/180.d0 * pi)  ! Particle No.8's position
!
!real*8, parameter:: x9_ini = cos(288.d0/180.d0 * pi)*sin(160.d0/180.d0 * pi),&
!& y9_ini = sin(288.d0/180.d0 * pi)*sin(160.d0/180.d0 * pi), z9_ini = cos(160.d0/180.d0 * pi)  ! Particle No.9's position
!
!real*8, parameter:: x10_ini = cos(324.d0/180.d0 * pi)*sin(180.d0/180.d0 * pi),&
!& y10_ini = sin(324.d0/180.d0 * pi)*sin(180.d0/180.d0 * pi), z10_ini = cos(180.d0/180.d0 * pi)  ! Particle No.10's position

END MODULE ParametersBlock
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
! The main program
PROGRAM Main
use ParametersBlock
implicit none

! Variables
real*8 x_new(1:N_particles,1:N_dimension), x_current(1:N_particles,1:N_dimension), x_old(1:N_particles,1:N_dimension)   ! Particles' direction
real*8 u_current(1:N_particles,1:N_dimension)                                                                           ! Particles' velocity
real*8 acceleration(1:N_particles,1:N_dimension), acceleration_int(1:N_particles,1:N_dimension)                         ! Particles' acceleration
real*8 potential_energy(1:N_particles), kinetic_energy(1:N_particles)                                                   ! particle's Potential energy and Kinetic energy
real*8 potential_energy_total, kinetic_energy_total                                                                     ! system's total potnetial and kinetic energy
real*8 zeta_new, zeta_current                                                                                ! damping coefficient

! Index
integer i,j,ierror
integer(kind=8):: t = 0

! Initial all varibales

do i = 1, N_particles
  do j = 1, N_dimension
      x_new(i,j) = 0.d0
      x_current(i,j) = 0.d0
      x_old(i,j) = 0.d0
      u_current(i,j) = 0.d0
      acceleration(i,j) = 0.d0
      acceleration_int(i,j) = 0.d0
  end do
end do

do i = 1, N_particles
    potential_energy(i) = 0.d0
    kinetic_energy(i) = 0.d0
end do

potential_energy_total = 0.d0
kinetic_energy_total = 0.d0
zeta_new = 0.d0
zeta_current = 0.d0

! Initial particles' state
! particles' initial position
x_current(1,1) = x1_ini
x_current(1,2) = y1_ini
x_current(1,3) = z1_ini

x_current(2,1) = x2_ini
x_current(2,2) = y2_ini
x_current(2,3) = z2_ini

x_current(3,1) = x3_ini
x_current(3,2) = y3_ini
x_current(3,3) = z3_ini

x_current(4,1) = x4_ini
x_current(4,2) = y4_ini
x_current(4,3) = z4_ini

x_current(5,1) = x5_ini
x_current(5,2) = y5_ini
x_current(5,3) = z5_ini

x_current(6,1) = x6_ini
x_current(6,2) = y6_ini
x_current(6,3) = z6_ini

x_current(7,1) = x7_ini
x_current(7,2) = y7_ini
x_current(7,3) = z7_ini

x_current(8,1) = x8_ini
x_current(8,2) = y8_ini
x_current(8,3) = z8_ini

x_current(9,1) = x9_ini
x_current(9,2) = y9_ini
x_current(9,3) = z9_ini

x_current(10,1) = x10_ini
x_current(10,2) = y10_ini
x_current(10,3) = z10_ini

call compute_acceleration(x_current,u_current,zeta_current,acceleration,acceleration_int)   ! Compute acceleration at first time step

! time step evolution
do i = 1,N_particles
   do j = 1,N_dimension
      x_new(i,j) = x_current(i,j) + delta_t*u_current(i,j) + 0.5d0*(delta_t**2)*acceleration(i,j)
   end do
end do

! compute potential energy
call compute_potnetialEnergy(x_current,potential_energy,potential_energy_total)          ! Compute potential energy

! compute kinetic energy
call compute_kineticEnergy(u_current,kinetic_energy,kinetic_energy_total)                ! Compute kinetic energy

! compute damping coefficient
call compute_zeta(u_current,zeta_current,zeta_new)                                       ! Compute damping coefficient

! open the output file
open(unit = 10, file = Trim(OutputFile), IOSTAT = ierror)
if (ierror.EQ.0) then
  print*, 'File result.txt successfully opened!...'
endif

! output result in first time step
Write(10,100) (t-1)*delta_t,&
& x_current(1,1), x_current(1,2), x_current(1,3), u_current(1,1), u_current(1,2), u_current(1,3),&
&   acceleration_int(1,1), acceleration_int(1,2), acceleration_int(1,3), kinetic_energy(1), potential_energy(1),&
& x_current(2,1), x_current(2,2), x_current(2,3), u_current(2,1), u_current(2,2), u_current(2,3),&
&   acceleration_int(2,1), acceleration_int(2,2), acceleration_int(2,3), kinetic_energy(2), potential_energy(2),&
& x_current(3,1), x_current(3,2), x_current(3,3), u_current(3,1), u_current(3,2), u_current(3,3),&
&   acceleration_int(3,1), acceleration_int(3,2), acceleration_int(3,3), kinetic_energy(3), potential_energy(3),&
& x_current(4,1), x_current(4,2), x_current(4,3), u_current(4,1), u_current(4,2), u_current(4,3),&
&   acceleration_int(4,1), acceleration_int(4,2), acceleration_int(4,3), kinetic_energy(4), potential_energy(4),&
& x_current(5,1), x_current(5,2), x_current(5,3), u_current(5,1), u_current(5,2), u_current(5,3),&
&   acceleration_int(5,1), acceleration_int(5,2), acceleration_int(5,3), kinetic_energy(5), potential_energy(5),&
& x_current(6,1), x_current(6,2), x_current(6,3), u_current(6,1), u_current(6,2), u_current(6,3),&
&   acceleration_int(6,1), acceleration_int(6,2), acceleration_int(6,3), kinetic_energy(6), potential_energy(6),&
& x_current(7,1), x_current(7,2), x_current(7,3), u_current(7,1), u_current(7,2), u_current(7,3),&
&   acceleration_int(7,1), acceleration_int(7,2), acceleration_int(7,3), kinetic_energy(7), potential_energy(7),&
& x_current(8,1), x_current(8,2), x_current(8,3), u_current(8,1), u_current(8,2), u_current(8,3),&
&   acceleration_int(8,1), acceleration_int(8,2), acceleration_int(8,3), kinetic_energy(8), potential_energy(8),&
& x_current(9,1), x_current(9,2), x_current(9,3), u_current(9,1), u_current(9,2), u_current(9,3),&
&   acceleration_int(9,1), acceleration_int(9,2), acceleration_int(9,3), kinetic_energy(9), potential_energy(9),&
& x_current(10,1), x_current(10,2), x_current(10,3), u_current(10,1), u_current(10,2), u_current(10,3),&
&   acceleration_int(10,1), acceleration_int(10,2), acceleration_int(10,3), kinetic_energy(10), potential_energy(10)

100 format(1x,111ES24.15,/)

! Output simulation setup parameters
call OutputParameters(x_current,u_current,kinetic_energy,potential_energy,kinetic_energy_total, potential_energy_total,zeta_current)
Write(*,*) 'Are these parameters property?... Programing Paused, Continue?...'
pause

! new to old
x_old = x_current
x_current = x_new
zeta_current = zeta_new

! Time evolution
do t = 2,N_time

   ! Compute acceleration
     call compute_acceleration(x_current,u_current,zeta_current,acceleration,acceleration_int)
   ! particles' new pisition
     call compute_position(x_current,x_old,acceleration,x_new)
   ! compute particle's velocity
     call compute_velocity(x_new,x_old,u_current)
   ! compute damping coefficient
     call compute_zeta(u_current,zeta_current,zeta_new)
   ! Output
       if(mod(t,Output_interval).EQ.0) then
          ! compute particle's potential energy
          call compute_potnetialEnergy(x_current,potential_energy,potential_energy_total)
          ! compute particles' kinetic energy
          call compute_kineticEnergy(u_current,kinetic_energy,kinetic_energy_total)
          print 200, (t-1)
          print 201, kinetic_energy_total, potential_energy_total,  kinetic_energy_total/(0.5*N_particles*N_dimension)
          print 202, zeta_current
          print *,  ''
          Write(10,100) (t-1)*delta_t,&
&         x_current(1,1), x_current(1,2), x_current(1,3), u_current(1,1), u_current(1,2), u_current(1,3),&
&           acceleration_int(1,1), acceleration_int(1,2), acceleration_int(1,3), kinetic_energy(1), potential_energy(1),&
&         x_current(2,1), x_current(2,2), x_current(2,3), u_current(2,1), u_current(2,2), u_current(2,3),&
&           acceleration_int(2,1), acceleration_int(2,2), acceleration_int(2,3), kinetic_energy(2), potential_energy(2),&
&         x_current(3,1), x_current(3,2), x_current(3,3), u_current(3,1), u_current(3,2), u_current(3,3),&
&           acceleration_int(3,1), acceleration_int(3,2), acceleration_int(3,3), kinetic_energy(3), potential_energy(3),&
&         x_current(4,1), x_current(4,2), x_current(4,3), u_current(4,1), u_current(4,2), u_current(4,3),&
&           acceleration_int(4,1), acceleration_int(4,2), acceleration_int(4,3), kinetic_energy(4), potential_energy(4),&
&         x_current(5,1), x_current(5,2), x_current(5,3), u_current(5,1), u_current(5,2), u_current(5,3),&
&           acceleration_int(5,1), acceleration_int(5,2), acceleration_int(5,3), kinetic_energy(5), potential_energy(5),&
&         x_current(6,1), x_current(6,2), x_current(6,3), u_current(6,1), u_current(6,2), u_current(6,3),&
&           acceleration_int(6,1), acceleration_int(6,2), acceleration_int(6,3), kinetic_energy(6), potential_energy(6),&
&         x_current(7,1), x_current(7,2), x_current(7,3), u_current(7,1), u_current(7,2), u_current(7,3),&
&           acceleration_int(7,1), acceleration_int(7,2), acceleration_int(7,3), kinetic_energy(7), potential_energy(7),&
&         x_current(8,1), x_current(8,2), x_current(8,3), u_current(8,1), u_current(8,2), u_current(8,3),&
&           acceleration_int(8,1), acceleration_int(8,2), acceleration_int(8,3), kinetic_energy(8), potential_energy(8),&
&         x_current(9,1), x_current(9,2), x_current(9,3), u_current(9,1), u_current(9,2), u_current(9,3),&
&           acceleration_int(9,1), acceleration_int(9,2), acceleration_int(9,3), kinetic_energy(9), potential_energy(9),&
&         x_current(10,1), x_current(10,2), x_current(10,3), u_current(10,1), u_current(10,2), u_current(10,3),&
&           acceleration_int(10,1), acceleration_int(10,2), acceleration_int(10,3), kinetic_energy(10), potential_energy(10)
       !pause
       end if
    ! time update
    x_old = x_current
    x_current = x_new
    zeta_current = zeta_new
!    zeta_current = 1.d0

end do

200 format(1x,'Current Time Step = ',I20)
201 format(1x,'SystemKineticEnergy = ',ES15.5,', SystemPotentialEnergy=',ES15.5,', SystemTemperature = 'ES15.5)
202 format(1x,'DampingCoefficient = ',ES15.5,/)

 close(10)

! Output computing log file
call logfile(t,x_current,u_current,kinetic_energy,potential_energy,potential_energy_total, kinetic_energy_total,zeta_current)

END PROGRAM Main
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE OutputParameters(x_current,u_current,kinetic_energy,potential_energy,kinetic_energy_total, potential_energy_total,zeta)
use ParametersBlock
implicit none

! decline variables
real*8, INTENT(IN):: x_current(1:N_particles,1:N_dimension), u_current(1:N_particles,1:N_dimension)          ! Particles' position and velocity
real*8, INTENT(IN):: kinetic_energy(1:N_particles), potential_energy(1:N_particles)                          ! Particles' kinetic energy and potential energy
real*8, INTENT(IN):: potential_energy_total, kinetic_energy_total                                            ! system's total potnetial and kinetic energy
real*8, INTENT(IN):: zeta                                                                                ! Damping coefficient

! file name
character(len=20), parameter:: FileName1='SimulationParameters.txt'

! Print parameters in screen
Write(*,100) N_particles,N_dimension
100 format(1x,'Particles = 'I10,', Problem Dimension = ',I10,/)

Write(*,101) N_time, delta_t, Output_interval
101 format(1x,'Total time step = 'I20,', Time step size = ',ES15.5,', Data output interval = ',I20,/)

Write(*,102)
102 format(1x,'Position     Velocity      Kinetic Energy    Potential Energy',/)

Write(*,103) x_current(1,1), x_current(1,2), x_current(1,3), u_current(1,1), u_current(1,2), u_current(1,3),&
&            kinetic_energy(1), potential_energy(1)
103 format(1x,', x1 = ',ES15.5,', y1 = ',ES15.5,', z1 = ',ES15.5,', u1 = ',ES15.5,', v1 = ',ES15.5,', w1 = ',ES15.5,&
&          ', k1 = ',ES15.5,', p1 = ',ES15.5,/)

Write(*,104) x_current(2,1), x_current(2,2), x_current(2,3), u_current(2,1), u_current(2,2), u_current(2,3),&
&            kinetic_energy(2), potential_energy(2)
104 format(1x,', x2 = ',ES15.5,', y2 = ',ES15.5,', z2 = ',ES15.5,', u2 = ',ES15.5,', v2 = ',ES15.5,', w2 = ',ES15.5,&
&          ', k2 = ',ES15.5,', p2 = ',ES15.5,/)

Write(*,105) x_current(3,1), x_current(3,2), x_current(3,3), u_current(3,1), u_current(3,2), u_current(3,3),&
&            kinetic_energy(3), potential_energy(3)
105 format(1x,', x3 = ',ES15.5,', y3 = ',ES15.5,', z3 = ',ES15.5,', u3 = ',ES15.5,', v3 = ',ES15.5,', w3 = ',ES15.5,&
&          ', k3 = ',ES15.5,', p3 = ',ES15.5,/)

Write(*,106) x_current(4,1), x_current(4,2), x_current(4,3), u_current(4,1), u_current(4,2), u_current(4,3),&
&            kinetic_energy(4), potential_energy(4)
106 format(1x,', x4 = ',ES15.5,', y4 = ',ES15.5,', z4 = ',ES15.5,', u4 = ',ES15.5,', v4 = ',ES15.5,', w4 = ',ES15.5,&
&          ', k4 = ',ES15.5,', p4 = ',ES15.5,/)

Write(*,107) x_current(5,1), x_current(5,2), x_current(5,3), u_current(5,1), u_current(5,2), u_current(5,3),&
&            kinetic_energy(5), potential_energy(5)
107 format(1x,', x5 = ',ES15.5,', y5 = ',ES15.5,', z5 = ',ES15.5,', u5 = ',ES15.5,', v5 = ',ES15.5,', w5 = ',ES15.5,&
&          ', k5 = ',ES15.5,', p5 = ',ES15.5,/)

Write(*,108) x_current(6,1), x_current(6,2), x_current(6,3), u_current(6,1), u_current(6,2), u_current(6,3),&
&            kinetic_energy(6), potential_energy(6)
108 format(1x,', x6 = ',ES15.5,', y6 = ',ES15.5,', z6 = ',ES15.5,', u6 = ',ES15.5,', v6 = ',ES15.5,', w6 = ',ES15.5,&
&          ', k6 = ',ES15.5,', p6 = ',ES15.5,/)

Write(*,109) x_current(7,1), x_current(7,2), x_current(7,3), u_current(7,1), u_current(7,2), u_current(7,3),&
&            kinetic_energy(7), potential_energy(7)
109 format(1x,', x7 = ',ES15.5,', y7 = ',ES15.5,', z7 = ',ES15.5,', u7 = ',ES15.5,', v7 = ',ES15.5,', w7 = ',ES15.5,&
&          ', k7 = ',ES15.5,', p7 = ',ES15.5,/)

Write(*,110) x_current(8,1), x_current(8,2), x_current(8,3), u_current(8,1), u_current(8,2), u_current(8,3),&
&            kinetic_energy(8), potential_energy(8)
110 format(1x,', x8 = ',ES15.5,', y8 = ',ES15.5,', z8 = ',ES15.5,', u8 = ',ES15.5,', v8 = ',ES15.5,', w8 = ',ES15.5,&
           ', k8 = ',ES15.5,', p8 = ',ES15.5,/)

Write(*,111) x_current(9,1), x_current(9,2), x_current(9,3), u_current(9,1), u_current(9,2), u_current(9,3),&
&            kinetic_energy(9), potential_energy(9)
111 format(1x,', x9 = ',ES15.5,', y9 = ',ES15.5,', z9 = ',ES15.5,', u9 = ',ES15.5,', v9 = ',ES15.5,', w9 = ',ES15.5,&
&          ', k9 = ',ES15.5,', p9 = ',ES15.5,/)

Write(*,112) x_current(10,1), x_current(10,2), x_current(10,3), u_current(10,1), u_current(10,2), u_current(10,3),&
&            kinetic_energy(10), potential_energy(10)
112 format(1x,', x10 = ',ES15.5,', y10 = ',ES15.5,', z10 = ',ES15.5,', u10 = ',ES15.5,', v10 = ',ES15.5,', w10 = ',ES15.5,&
&          ', k10 = ',ES15.5,', p10 = ',ES15.5,/)

Write(*,113) Temperature, Qm
113 format(1x,'ThermostatTemperatureSetup = ',ES15.5,', Qm = ',ES15.5,/)

Write(*,114) zeta
114 format(1x,'Damping coefficient = ',ES15.5,/)

Write(*,115) potential_energy_total, kinetic_energy_total
115 format(1x,'SystemPotentialEnergy = ',ES15.5,', SystemKineticEnergy = ',ES15.5/)

! Output to file
Open(unit=20,file=Trim(FileName1))
Write(20,100) N_particles,N_dimension

Write(20,101) N_time, delta_t, Output_interval

Write(20,102)

Write(20,103) x_current(1,1), x_current(1,2), x_current(1,3), u_current(1,1), u_current(1,2), u_current(1,3),&
&            kinetic_energy(1), potential_energy(1)

Write(20,104) x_current(2,1), x_current(2,2), x_current(2,3), u_current(2,1), u_current(2,2), u_current(2,3),&
&            kinetic_energy(2), potential_energy(2)

Write(20,105) x_current(3,1), x_current(3,2), x_current(3,3), u_current(3,1), u_current(3,2), u_current(3,3),&
&            kinetic_energy(3), potential_energy(3)

Write(20,106) x_current(4,1), x_current(4,2), x_current(4,3), u_current(4,1), u_current(4,2), u_current(4,3),&
&            kinetic_energy(4), potential_energy(4)

Write(20,107) x_current(5,1), x_current(5,2), x_current(5,3), u_current(5,1), u_current(5,2), u_current(5,3),&
&            kinetic_energy(5), potential_energy(5)

Write(20,108) x_current(6,1), x_current(6,2), x_current(6,3), u_current(6,1), u_current(6,2), u_current(6,3),&
&            kinetic_energy(6), potential_energy(6)

Write(20,109) x_current(7,1), x_current(7,2), x_current(7,3), u_current(7,1), u_current(7,2), u_current(7,3),&
&            kinetic_energy(7), potential_energy(7)

Write(20,110) x_current(8,1), x_current(8,2), x_current(8,3), u_current(8,1), u_current(8,2), u_current(8,3),&
&            kinetic_energy(8), potential_energy(8)

Write(20,111) x_current(9,1), x_current(9,2), x_current(9,3), u_current(9,1), u_current(9,2), u_current(9,3),&
&            kinetic_energy(9), potential_energy(9)

Write(20,112) x_current(10,1), x_current(10,2), x_current(10,3), u_current(10,1), u_current(10,2), u_current(10,3),&
&            kinetic_energy(10), potential_energy(10)

Write(20,113) Temperature, Qm

Write(20,114) zeta

Write(20,115) potential_energy_total, kinetic_energy_total

END SUBROUTINE OutputParameters
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
! Compute force
SUBROUTINE compute_acceleration(x_current,u_current,zeta_current,acceleration,acceleration_int)
use ParametersBlock
implicit none

! decline variables
real*8, INTENT(IN)::  x_current(1:N_particles,1:N_dimension)                                     ! Particles' current position
real*8, INTENT(IN)::  u_current(1:N_particles,1:N_dimension)                                     ! Particles' current velocity
real*8, INTENT(IN)::  zeta_current                                                               ! Damping coefficient
real*8, INTENT(OUT):: acceleration(1:N_particles,1:N_dimension)                                  ! Particles' total acceleration
real*8, INTENT(OUT):: acceleration_int(1:N_particles,1:N_dimension)                              ! Particles' conservation reaction acceleration

! Temporary varibles
!real*8 x_r,y_r,r,f         ! use this for 2-D
real*8 x_r,y_r,z_r,r,f     ! use this for 3-D

! index
integer i,j,k

! recation with external potential field
do i = 1, N_particles
  do k = 1, N_dimension
      acceleration(i,k) = -x_current(i,k)
  end do
end do

! reaction between particles

do i = 1, N_particles - 1
     do j = i+1, N_particles
        x_r = x_current(i,1) - x_current(j,1)                     ! compute vector x_ij
        y_r = x_current(i,2) - x_current(j,2)                     ! compute vector y_ij
        z_r = x_current(i,3) - x_current(j,3)                     ! compute vector z_ij
!        r = sqrt( x_r**2 + y_r**2 )                               ! compute norm of vector r_ij (2-D)
        r = sqrt( x_r**2 + y_r**2 + z_r**2)                       ! compute norm of vector r_ij (3-D)
        f = 24.d0 * ( 2.d0*(1.d0/r)**13 - (1.d0/r)**7 )           ! compute force scalar due to LJ 6-12 Potential
        acceleration(i,1) = acceleration(i,1) + x_r / r * f       ! compute acceleration in x direction
        acceleration(i,2) = acceleration(i,2) + y_r / r * f       ! compute acceleration in y direction
        acceleration(i,3) = acceleration(i,3) + z_r / r * f       ! compute acceleration in z direction
        acceleration(j,1) = acceleration(j,1) - x_r / r * f       ! compute acceleration in x direction  (inverse force)
        acceleration(j,2) = acceleration(j,2) - y_r / r * f       ! compute acceleration in y direction  (inverse force)
        acceleration(j,3) = acceleration(j,3) - z_r / r * f       ! compute acceleration in z direction  (inverse force)
     end do
end do

acceleration_int = acceleration                                   ! Particles' conservation reaction acceleration

! Nose-hoover thermostat damping coefficient
do i = 1, N_particles
  do k = 1, N_dimension
      acceleration(i,k) = acceleration(i,k) - zeta_current*u_current(i,k)
  end do
end do

END SUBROUTINE compute_acceleration
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
! Update particle's Direction
SUBROUTINE compute_position(x_current,x_old,acceleration,x_new)
use ParametersBlock
implicit none

! decline variables
real*8, INTENT(IN):: x_current(1:N_particles,1:N_dimension), x_old(1:N_particles,1:N_dimension)  ! particles' current position and old position
real*8, INTENT(IN):: acceleration(1:N_particles,1:N_dimension)                                   ! Particles' current acceleration
real*8, INTENT(OUT):: x_new(1:N_particles,1:N_dimension)                                         ! Particles' new direction

! Index
integer i,j

! Verlet Scheme
do i = 1,N_particles
   do j = 1,N_dimension
      x_new(i,j) = 2.d0 * x_current(i,j) - x_old(i,j) + (delta_t**2) * acceleration(i,j)
   end do
end do

END SUBROUTINE compute_position
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_velocity(x_new,x_old,u_current)
use ParametersBlock
implicit none
! particles' current position and old position
real*8, INTENT(IN):: x_new(1:N_particles,1:N_dimension), x_old(1:N_particles,1:N_dimension)
real*8, INTENT(OUT):: u_current(1:N_particles,1:N_dimension)                                       ! Particles' new direction

! index
integer i,j

! compute velocity using centered difference scheme
do i = 1, N_particles
  do j = 1, N_dimension
      u_current(i,j) = ( x_new(i,j) - x_old(i,j) ) / (2.d0*delta_t)
  end do
end do

END SUBROUTINE compute_velocity
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_zeta(u_current,zeta_current,zeta_new)
use ParametersBlock
implicit none

! velocity imput
real*8, INTENT(IN):: u_current(1:N_particles,1:N_dimension)

! damping coefficient
real*8, INTENT(IN):: zeta_current
real*8, INTENT(OUT):: zeta_new

! temporary variable
real*8 delta_zeta, temp

! index
integer i,j

! initial
delta_zeta = 0.d0
temp = 0.d0

! Compute zeta_new
do i = 1, N_particles
   do j = 1, N_dimension
      temp = temp + u_current(i,j)**2
   end do
end do

delta_zeta = ((temp - (N_particles*N_dimension)*Temperature ) / Qm) * delta_t

zeta_new = zeta_current + delta_zeta

!print 100, temp, (N_particles*N_dimension)*Temperature, delta_zeta
!100 format(1x,3ES15.5,/)

END SUBROUTINE compute_zeta
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_potnetialEnergy(x_current,potential_energy,potential_energy_total)
use ParametersBlock
implicit none
real*8, INTENT(IN):: x_current(1:N_particles,1:N_dimension)                                        ! Particles' current position
real*8, INTENT(OUT):: potential_energy(1:N_particles)                                              ! Particles' potential energy
real*8, INTENT(OUT):: potential_energy_total                                                       ! System's total potential energy

! Index
integer i,j

! temporary varibales
! real*8 x_r,y_r,r,phi       ! Use this for 2D
real*8 x_r,y_r,z_r,r,phi     ! Use this for 3D
do i = 1, N_particles
      potential_energy = 0.d0                                    ! Initial
end do

! system's total potential energy
potential_energy_total = 0.d0                                    ! Initial

! external field potential
do i = 1, N_particles
!    potential_energy(i) = 0.5d0*( x_current(i,1)**2 + x_current(i,2)**2 + x_current(i,3)**2 )      ! 3D
     do j = 1, N_dimension
      potential_energy(i) = potential_energy(i) + 0.5d0*x_current(i,j)**2
     end do
     potential_energy_total = potential_energy_total + potential_energy(i)
end do

! Compute potential energy
do i = 1, N_particles - 1
     do j = i+1, N_particles
        x_r = x_current(i,1) - x_current(j,1)                     ! compute vector x_ij
        y_r = x_current(i,2) - x_current(j,2)                     ! compute vector y_ij
        z_r = x_current(i,3) - x_current(j,3)                     ! compute vector z_ij
!        r = sqrt( x_r**2 + y_r**2 )                               ! compute norm of vector r_ij (2-D)
        r = sqrt( x_r**2 + y_r**2 + z_r**2)                       ! compute norm of vector r_ij (3-D)
        phi = 4.d0 * ( (1.d0/r)**12 - (1.d0/r)**6 )               ! compute LJ 6-12 Potential
        potential_energy(i) = potential_energy(i) + phi
        potential_energy(j) = potential_energy(j) + phi
     end do
     potential_energy_total = potential_energy_total + potential_energy(i)
end do

END SUBROUTINE compute_potnetialEnergy
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_kineticEnergy(u_current,kinetic_energy,kinetic_energy_total)
use ParametersBlock
implicit none
real*8, INTENT(IN):: u_current(1:N_particles,1:N_dimension)                                         ! Particles' current velocity
real*8, INTENT(OUT):: kinetic_energy(1:N_particles)                                                 ! Particles' kinetic energy
real*8, INTENT(OUT):: kinetic_energy_total                                                          ! System's total kinetic energy

! index
integer i,j

! initial
do i = 1,N_particles
    kinetic_energy(i) = 0.d0
end do

kinetic_energy_total = 0.d0

! Sum
do i = 1,N_particles
   do j = 1,N_dimension
      kinetic_energy(i) = kinetic_energy(i) + 0.5d0*(u_current(i,j)**2)
   end do
   kinetic_energy_total = kinetic_energy_total + kinetic_energy(i)
end do

END SUBROUTINE compute_kineticEnergy
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE logfile(t,x_current,u_current,kinetic_energy,potential_energy,potential_energy_total, kinetic_energy_total,zeta)
use ParametersBlock
implicit none

! decline variables
integer(kind=8), INTENT(IN):: t                                                                                ! Final time step
real*8, INTENT(IN)::  x_current(1:N_particles,1:N_dimension), u_current(1:N_particles,1:N_dimension)           ! Particles' position and velocity
real*8, INTENT(IN)::  kinetic_energy(1:N_particles), potential_energy(1:N_particles)                           ! Particles' kinetic energy and potential energy
real*8, INTENT(IN)::  potential_energy_total, kinetic_energy_total                                             ! system's total potnetial and kinetic energy
real*8, INTENT(IN)::  zeta                                                                                ! Damping coefficient

! file name
character(len=20), parameter:: FileName1='Report.log'

! Output to ReportFile
Open(unit=20,file=Trim(FileName1))
Write(20,100) N_particles,N_dimension
Write(20,101) N_time, delta_t, Output_interval
Write(20,102) t, real(t-1)*delta_t
Write(20,103)
Write(20,104) x_current(1,1), x_current(1,2), x_current(1,3), u_current(1,1), u_current(1,2), u_current(1,3),&
&            kinetic_energy(1), potential_energy(1)
Write(20,105) x_current(2,1), x_current(2,2), x_current(2,3), u_current(2,1), u_current(2,2), u_current(2,3),&
&            kinetic_energy(2), potential_energy(2)
Write(20,106) x_current(3,1), x_current(3,2), x_current(3,3), u_current(3,1), u_current(3,2), u_current(3,3),&
&            kinetic_energy(3), potential_energy(3)
Write(20,107) x_current(4,1), x_current(4,2), x_current(4,3), u_current(4,1), u_current(4,2), u_current(4,3),&
&            kinetic_energy(4), potential_energy(4)
Write(20,108) x_current(5,1), x_current(5,2), x_current(5,3), u_current(5,1), u_current(5,2), u_current(5,3),&
&            kinetic_energy(5), potential_energy(5)
Write(20,109) x_current(6,1), x_current(6,2), x_current(6,3), u_current(6,1), u_current(6,2), u_current(6,3),&
&            kinetic_energy(6), potential_energy(6)
Write(20,110) x_current(7,1), x_current(7,2), x_current(7,3), u_current(7,1), u_current(7,2), u_current(7,3),&
&            kinetic_energy(7), potential_energy(7)
Write(20,111) x_current(8,1), x_current(8,2), x_current(8,3), u_current(8,1), u_current(8,2), u_current(8,3),&
&            kinetic_energy(8), potential_energy(8)
Write(20,112) x_current(9,1), x_current(9,2), x_current(9,3), u_current(9,1), u_current(9,2), u_current(9,3),&
&            kinetic_energy(9), potential_energy(9)
Write(20,113) x_current(10,1), x_current(10,2), x_current(10,3), u_current(10,1), u_current(10,2), u_current(10,3),&
&            kinetic_energy(10), potential_energy(10)
Write(20,114) Temperature, Qm
Write(20,115) zeta
Write(20,116) potential_energy_total, kinetic_energy_total

100 format(1x,'Particles = 'I10,', Problem Dimension = ',I10,/)
101 format(1x,'Total time step = 'I20,', Time step size = ',ES15.5,', Data output interval = ',I20,/)
102 format(1x,'Final time step= ',I20,', Final time = ',ES15.5,/)
103 format(1x,'Position     Velocity      Kinetic Energy    Potential Energy',/)
104 format(1x,', x1 = ',ES15.5,', y1 = ',ES15.5,', z1 = ',ES15.5,', u1 = ',ES15.5,', v1 = ',ES15.5,', w1 = ',ES15.5,&
&          ', k1 = ',ES15.5,', p1 = ',ES15.5,/)
105 format(1x,', x2 = ',ES15.5,', y2 = ',ES15.5,', z2 = ',ES15.5,', u2 = ',ES15.5,', v2 = ',ES15.5,', w2 = ',ES15.5,&
&          ', k2 = ',ES15.5,', p2 = ',ES15.5,/)
106 format(1x,', x3 = ',ES15.5,', y3 = ',ES15.5,', z3 = ',ES15.5,', u3 = ',ES15.5,', v3 = ',ES15.5,', w3 = ',ES15.5,&
&          ', k3 = ',ES15.5,', p3 = ',ES15.5,/)
107 format(1x,', x4 = ',ES15.5,', y4 = ',ES15.5,', z4 = ',ES15.5,', u4 = ',ES15.5,', v4 = ',ES15.5,', w4 = ',ES15.5,&
&          ', k4 = ',ES15.5,', p4 = ',ES15.5,/)
108 format(1x,', x5 = ',ES15.5,', y5 = ',ES15.5,', z5 = ',ES15.5,', u5 = ',ES15.5,', v5 = ',ES15.5,', w5 = ',ES15.5,&
&          ', k5 = ',ES15.5,', p5 = ',ES15.5,/)
109 format(1x,', x6 = ',ES15.5,', y6 = ',ES15.5,', z6 = ',ES15.5,', u6 = ',ES15.5,', v6 = ',ES15.5,', w6 = ',ES15.5,&
&          ', k6 = ',ES15.5,', p6 = ',ES15.5,/)
110 format(1x,', x7 = ',ES15.5,', y7 = ',ES15.5,', z7 = ',ES15.5,', u7 = ',ES15.5,', v7 = ',ES15.5,', w7 = ',ES15.5,&
&          ', k7 = ',ES15.5,', p7 = ',ES15.5,/)
111 format(1x,', x8 = ',ES15.5,', y8 = ',ES15.5,', z8 = ',ES15.5,', u8 = ',ES15.5,', v8 = ',ES15.5,', w8 = ',ES15.5,&
           ', k8 = ',ES15.5,', p8 = ',ES15.5,/)
112 format(1x,', x9 = ',ES15.5,', y9 = ',ES15.5,', z9 = ',ES15.5,', u9 = ',ES15.5,', v9 = ',ES15.5,', w9 = ',ES15.5,&
&          ', k9 = ',ES15.5,', p9 = ',ES15.5,/)
113 format(1x,', x10 = ',ES15.5,', y10 = ',ES15.5,', z10 = ',ES15.5,', u10 = ',ES15.5,', v10 = ',ES15.5,', w10 = ',ES15.5,&
&          ', k10 = ',ES15.5,', p10 = ',ES15.5,/)
114 format(1x,'ThermostatTemperatureSetup = ',ES15.5,', Qm = ',ES15.5,/)
115 format(1x,'Damping coefficient = ',ES15.5,/)
116 format(1x,'SystemPotentialEnergy = ',ES15.5,', SystemKineticEnergy = ',ES15.5/)

 close(20)

END SUBROUTINE logfile
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------


! written by jxzou at 20180410
! modified by jxzou at 20190910:
!  1) optimize the code
!  2) add subroutine mo_svd_qcmo, diagonalize SVOs into QCMOs (quasi-canonical MOs)

!  For GNU compiler, use
! ------------------------------------------------
!  f2py -m mo_svd -c mo_svd.f90 --link-lapack_opt
! ------------------------------------------------
!  For INTEL compiler, use
! ---------------------------------------------------------------------------------------
!  f2py -m mo_svd -c mo_svd.f90 --link-lapack_opt --fcompiler=intelem --compiler=intelem
! ---------------------------------------------------------------------------------------

module mo_ovlp_and_svd
 implicit none
 integer, parameter :: iout = 6
contains

 ! Compute the overlap of two sets of MOs
 ! Note that these two sets MOs can have different number of basis functions and number of MOs
 subroutine get_mo_basis_ovlp2(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, ao_ovlp, mo_ovlp)
  implicit none
  integer, intent(in) :: nbf1, nmo1, nbf2, nmo2
  real(kind=8), intent(in) :: coeff1(nbf1,nmo1), coeff2(nbf2,nmo2)
  real(kind=8), intent(in) :: ao_ovlp(nbf1,nbf2)
  real(kind=8), intent(out) :: mo_ovlp(nmo1,nmo2)
  real(kind=8), allocatable :: temp(:,:)

  mo_ovlp = 0d0
  allocate(temp(nbf1,nmo2), source=0d0)
  ! ?gemm: Computes a matrix-matrix product with general matrices
  ! Syntax FORTRAN 77:
  ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
  call dgemm('N', 'N', nbf1, nmo2, nbf2, 1d0, ao_ovlp, nbf1, coeff2, nbf2, 0d0, temp, nbf1)
  call dgemm('T', 'N', nmo1, nmo2, nbf1, 1d0, coeff1, nbf1, temp, nbf1, 0d0, mo_ovlp, nmo1)

  deallocate(temp)
  return
 end subroutine get_mo_basis_ovlp2

 ! Perform SVD on two sets of MOs and rotate them using obtained unitary matrice U and V_T
 ! Note that these two sets MOs can have different number of basis functions and number of MOs
 subroutine svd_and_rotate2(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, mo_ovlp, sv, reverse, mo_e)
  implicit none
  integer :: i
  integer, intent(in) :: nbf1, nmo1, nbf2, nmo2
  real(kind=8), intent(inout) :: coeff1(nbf1,nmo1), coeff2(nbf2,nmo2)
  real(kind=8), intent(inout), optional :: mo_e(nmo1)
  real(kind=8), intent(in) :: mo_ovlp(nmo1,nmo2)
  real(kind=8), intent(out) :: sv(nmo1)
  real(kind=8), allocatable :: sv2(:)
  real(kind=8), allocatable :: u(:,:), vt(:,:), u2(:,:), vt2(:,:)
  logical, intent(in) :: reverse

  sv = 0d0
  allocate(u(nmo1,nmo1), source=0d0)
  allocate(vt(nmo2,nmo2), source=0d0)

  ! perform SVD on mo_ovlp
  call svd_on_ovlp(nmo1, nmo2, mo_ovlp, u, vt, sv)

  if(reverse) then
   allocate(sv2(nmo1), source=0d0)
   forall(i = 1:nmo1)
    sv2(i) = sv(nmo1-i+1)
   end forall
   sv = sv2
   deallocate(sv2)

   allocate(u2(nmo1,nmo1), source=0d0)
   allocate(vt2(nmo2,nmo2), source=0d0)
   forall(i = 1:nmo1)
    u2(:,i) = u(:,nmo1-i+1)
   end forall
   u = u2

   forall(i = 1:nmo2)
    vt2(i,:) = vt(nmo2-i+1,:)
   end forall
   vt = vt2

   deallocate(u2, vt2)
  end if

  ! rotate the original orbitals
  allocate(u2(nbf1,nmo1), source=0d0)
  allocate(vt2(nbf2,nmo2), source=0d0)
  ! ?gemm: Computes a matrix-matrix product with general matrices
  ! Syntax FORTRAN 77:
  ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
  call dgemm('N', 'N', nbf1, nmo1, nmo1, 1d0, coeff1, nbf1, u, nmo1, 0d0, u2, nbf1)
  call dgemm('N', 'T', nbf2, nmo2, nmo2, 1d0, coeff2, nbf2, vt, nmo2, 0d0, vt2, nbf2)
  coeff1 = u2
  coeff2 = vt2
  deallocate(u2, vt, vt2)

  if(present(mo_e)) then
   ! e' = (U^T)eU
   allocate(vt(nmo1,nmo1), source=0d0)
   allocate(u2(nmo1,nmo1), source=0d0)
   forall(i = 1:nmo1) vt(i,i) = mo_e(i)
   allocate(vt2(nmo1,nmo1), source=0d0)
   call dgemm('T', 'N', nmo1, nmo1, nmo1, 1d0, u, nmo1, vt, nmo1, 0d0, vt2, nmo1)
   call dgemm('N', 'N', nmo1, nmo1, nmo1, 1d0, vt2, nmo1, u, nmo1, 0d0, vt, nmo1)
   u2 = vt
   deallocate(vt2)

   ! diagonalize (1:nmo2,1:nmo2) part of symmetric matrix e', obtaining a new U matrix
   allocate(vt2(nmo2,nmo2), source=0d0)
   vt2 = vt(1:nmo2,1:nmo2)
   deallocate(vt)
   allocate(sv2(nmo2), source=0d0)
   call diag_get_e_and_vec(nmo2, vt2, sv2)
   mo_e = 0d0
   mo_e(1:nmo2) = sv2
   deallocate(sv2)
   ! Note that orthonormal eigenvectors are now stored in matrix vt2

   ! C' = CU done in (1:nmo2,1:nmo2) block
   allocate(vt(nbf1,nmo2))
   call dgemm('N', 'N', nbf1, nmo2, nmo2, 1d0, coeff1(:,1:nmo2), nbf1, vt2, nmo2, 0d0, vt, nbf1)
   coeff1(:,1:nmo2) = vt
   deallocate(vt, vt2)

   ! diagonalize the left of symmetric matrix e', obtaining a new U matrix
   i = nmo1 - nmo2
   allocate(vt2(i,i), source=0d0)
   vt2 = u2(nmo2+1:nmo1,nmo2+1:nmo1)
   deallocate(u2)
   allocate(sv2(i), source=0d0)
   call diag_get_e_and_vec(i, vt2, sv2)
   mo_e(nmo2+1:nmo1) = sv2
   deallocate(sv2)
   ! Note that orthonormal eigenvectors are now stored in matrix vt2

   ! C' = CU done in (nmo2+1:nmo1,nmo2+1:nmo1) block
   allocate(vt(nbf1,i))
   call dgemm('N', 'N', nbf1, i, i, 1d0, coeff1(:,nmo2+1:nmo1), nbf1, vt2, i, 0d0, vt, nbf1)
   coeff1(:,nmo2+1:nmo1) = vt
   deallocate(vt, vt2)

!   allocate(vt2(nmo1,nmo1), source=0d0)
!   vt2 = vt(1:nmo1,1:nmo1)
!   deallocate(vt)
!   allocate(sv2(nmo1), source=0d0)
!   call diag_get_e_and_vec(nmo1, vt2, sv2)
!   mo_e = 0d0
!   mo_e(1:nmo1) = sv2
!   deallocate(sv2)
!   ! Note that orthonormal eigenvectors are now stored in matrix vt2
!
!   ! C' = CU done in (1:nmo2,1:nmo2) block
!   allocate(vt(nbf1,nmo1))
!   call dgemm('N', 'N', nbf1, nmo1, nmo1, 1d0, coeff1(:,1:nmo1), nbf1, vt2, nmo1, 0d0, vt, nbf1)
!   coeff1(:,1:nmo1) = vt
!   deallocate(vt2)
  end if

  deallocate(u)
  return
 end subroutine svd_and_rotate2

 ! perform SVD on overlap matrix s
 subroutine svd_on_ovlp(m, n, a, u, vt, s)
  implicit none
  integer :: lwork, info
  integer, intent(in) :: m, n
  integer, parameter :: iout = 6
  real(kind=8), intent(in) :: a(m,n)
  real(kind=8), intent(out) :: u(m,m), vt(n,n), s(m)
  real(kind=8), allocatable :: work(:), a_copy(:,:)

  info = 0
  u = 0d0; vt = 0d0; s = 0d0
  allocate(a_copy(m,n), source=a)

  ! ?gesvd: Computes the singular value decomposition of a general rectangular matrix
  ! Syntax FORTRAN 77:
  ! call dgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info)
  lwork = -1
  allocate(work(1), source=0d0)
  call dgesvd('A', 'A', m, n, a_copy, m, s, u, m, vt, n, work, lwork, info)

  lwork = CEILING(work(1))
  deallocate(work)
  allocate(work(lwork),source=0d0)
  call dgesvd('A', 'A', m, n, a_copy, m, s, u, m, vt, n, work, lwork, info)

  if(info /= 0) then
   write(iout,'(A)') 'ERROR in subroutine svd_on_ovlp: info/=0! Please check why.'
   write(iout,'(A5,I0)') 'info=', info
   stop
  end if

  deallocate(work, a_copy)
  return
 end subroutine svd_on_ovlp

end module mo_ovlp_and_svd

! perform SVD on two sets of MOs, and get new MOs
subroutine mo_svd(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, ao_ovlp, reverse)
 use mo_ovlp_and_svd
 implicit none
 integer :: i
 integer :: nbf1, nmo1, nbf2, nmo2
!f2py intent(in) :: nbf1, nmo1, nbf2, nmo2

 real(kind=8) :: coeff1(nbf1,nmo1), coeff2(nbf2,nmo2)
!f2py intent(inout) :: coeff1, coeff2
!f2py depend(nbf1,nmo1) :: coeff1
!f2py depend(nbf2,nmo2) :: coeff2

 real(kind=8) :: ao_ovlp(nbf1,nbf2)
!f2py intent(in) :: ao_ovlp
!f2py depend(nbf1,nbf2) :: ao_ovlp

 logical :: reverse
!f2py intent(in) :: reverse

 real(kind=8), allocatable :: mo_ovlp(:,:), sv(:)

 ! compute MO basis overlap
 allocate(mo_ovlp(nmo1,nmo2), source=0d0)
 call get_mo_basis_ovlp2(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, ao_ovlp, mo_ovlp)

 ! perform SVD and get new MO
 allocate(sv(nmo1), source=0d0)
 call svd_and_rotate2(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, mo_ovlp, sv, reverse)

 write(iout,'(/,A)') 'Singular values:'
 write(iout,'(5(1X,ES15.8))') (sv(i),i=1,nmo1)
 deallocate(mo_ovlp, sv)
 return
end subroutine mo_svd

! 1) project a set of MOs of a small basis set onto the (partially) occupied MOs of
!    a large basis set, leading to virtual orbitals of the small basis set
! 2) project virtual MOs of the large basis set onto those orbitals of the small
!    basis set
subroutine proj_occ_get_act_vir(nbf1, nmo1, nbf2, na_np, S2, cross_S, coeff1, coeff)
 use mo_ovlp_and_svd, only: iout, get_mo_basis_ovlp2, svd_and_rotate2
 implicit none
 integer :: i, j, nmo2, nvir1, nvir2
 integer :: nbf1, nmo1, nbf2, na_np
!f2py intent(in) nbf1, nmo1, nbf2, na_np
 real(kind=8) :: S2(nbf2,nbf2), cross_S(nbf1,nbf2)
!f2py intent(in,copy) S2
!f2py intent(in) cross_S
!f2py depend(nbf2) S2
!f2py depend(nbf1,nbf2) cross_S
 real(kind=8) :: coeff1(nbf1,nmo1), coeff(nbf1,nmo1)
!f2py intent(in,copy) coeff1
!f2py intent(out) :: coeff
!f2py depend(nbf1,nmo1) coeff, coeff1
 real(kind=8), allocatable :: coeff2(:,:), mo_ovlp(:,:), sv(:), sv2(:,:)

! na_np: the number of alpha orbitals + unoccupied localized UNOs in coeff1
! coeff1: MOs of large basis set
! coeff2: MOs of small basis set
 coeff = 0d0

 ! U^(T)SU = s, X = Us^(-1/2), a orthonormal set of MOs of small basis set
 allocate(sv(nbf2))
 call diag_get_e_and_vec(nbf2, S2, sv)
 nmo2 = COUNT(sv > 1d-6)
 if(na_np >= nmo2) then
  write(iout,'(/,A)') 'ERROR in subroutine proj_occ_get_act_vir: na_np>=nmo2.'
  write(iout,'(A,5I5)') 'nbf1,nmo1,nbf2,nmo2,na_np=',nbf1,nmo1,nbf2,nmo2,na_np
  stop
 end if
 if(nmo2 < nbf2) write(iout,'(A)') 'Warning from subroutine proj_occ_get_act_&
                                   &vir: nmo2 < nbf2, rare case.'
 allocate(coeff2(nbf2,nmo2), sv2(nmo2,nmo2))
 sv2 = 0d0
 j = nbf2 - nmo2
 forall(i = 1:nmo2) sv2(i,i) = 1d0/DSQRT(sv(j+i))
 call dgemm('N', 'N', nbf2, nmo2, nmo2, 1d0, S2(j+1:nbf2,j+1:nbf2), nbf2, sv2,&
            nmo2, 0d0, coeff2, nbf2)
 deallocate(sv, sv2)

 allocate(mo_ovlp(nmo2,na_np))
 call get_mo_basis_ovlp2(nbf2, nmo2, nbf1, na_np, coeff2, coeff1(:,1:na_np), &
                         TRANSPOSE(cross_S), mo_ovlp)

 coeff(:,1:na_np) = coeff1(:,1:na_np)
 allocate(sv(nmo2))
 call svd_and_rotate2(nbf2,nmo2, nbf1,na_np, coeff2,coeff,mo_ovlp, sv, .false.)
 write(iout,'(/,A)') 'Singular values of projecting small basis MOs onto large&
                    & basis (partially) occupied MOs:'
 write(iout,'(5(1X,ES15.8))') (sv(i),i=1,nmo2)
 deallocate(sv, mo_ovlp)

 nvir1 = nmo1 - na_np
 nvir2 = nmo2 - na_np
 allocate(mo_ovlp(nvir1,nvir2))
 call get_mo_basis_ovlp2(nbf1, nvir1, nbf2, nvir2, coeff1(:,na_np+1:nmo1), &
                         coeff2(:,na_np+1:nmo2), cross_S, mo_ovlp)
 allocate(sv(nvir1))
 call svd_and_rotate2(nbf1, nvir1, nbf2, nvir2, coeff1(:,na_np+1:nmo1), &
                      coeff2(:,na_np+1:nmo2), mo_ovlp, sv, .false.)
 write(iout,'(/,A)') 'Singular values of projecting large basis set virtual MOs&
                    & onto small basis virtual MOs:'
 write(iout,'(5(1X,ES15.8))') (sv(i),i=1,nvir1)
 deallocate(sv, mo_ovlp)

 coeff = coeff1
 return
end subroutine proj_occ_get_act_vir

! perform SVD on two sets of MOs, get new MOs, and diagonalize part of MOs to
!  obtain quasi-canonical MOs (with corresponding energies)
subroutine mo_svd_qcmo(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, ao_ovlp, mo_e)
 use mo_ovlp_and_svd
 implicit none
 integer :: i
 integer :: nbf1, nmo1, nbf2, nmo2
!f2py intent(in) :: nbf1, nmo1, nbf2, nmo2

 real(kind=8) :: coeff1(nbf1,nmo1), coeff2(nbf2,nmo2), mo_e(nmo1)
!f2py intent(inout) :: coeff1, coeff2, mo_e
!f2py depend(nbf1,nmo1) :: coeff1
!f2py depend(nbf2,nmo2) :: coeff2
!f2py depend(nmo1) :: mo_e

 real(kind=8) :: ao_ovlp(nbf1,nbf2)
!f2py intent(in) :: ao_ovlp
!f2py depend(nbf1,nbf2) :: ao_ovlp

 real(kind=8), allocatable :: mo_ovlp(:,:), sv(:)

 ! compute MO basis overlap
 allocate(mo_ovlp(nmo1,nmo2), source=0d0)
 call get_mo_basis_ovlp2(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, ao_ovlp, mo_ovlp)

 ! perform SVD and get new MO
 allocate(sv(nmo1), source=0d0)
 call svd_and_rotate2(nbf1, nmo1, nbf2, nmo2, coeff1, coeff2, mo_ovlp, sv, .false., mo_e)

 write(iout,'(/,A)') 'Singular values:'
 write(iout,'(5(1X,ES15.8))') (sv(i),i=1,nmo1)

 deallocate(mo_ovlp, sv)
 return
end subroutine mo_svd_qcmo


      SUBROUTINE PETASCE(
     &        CANHT, DOY, MSALB, MEEVP, SRAD, TDEW,       !Input
     &        TMAX, TMIN, WINDHT, WINDRUN, XHLAI,         !Input
     &        XLAT, XELEV,                                !Input
     &        EO)                                         !Output

      IMPLICIT NONE

      SAVE

!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CANHT, MSALB, SRAD, TDEW, TMAX, TMIN, WINDHT, WINDRUN
      REAL XHLAI, XLAT, XELEV
      INTEGER DOY
      CHARACTER*1 MEEVP
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL TAVG, PATM, PSYCON, UDELTA, EMAX, EMIN, ES, EA, FC, FEW, FW
      REAL ALBEDO, RNS, PIE, DR, LDELTA, WS, RA1, RA2, RA, RSO, RATIO
      REAL FCD, TK4, RNL, RN, G, WINDSP, WIND2m, Cn, Cd, KCMAX, RHMIN
      REAL WND, CHT
      REAL REFET, SKC, KCBMIN, KCBMAX, KCB, KE, KC
!-----------------------------------------------------------------------

!     ASCE Standardized Reference Evapotranspiration
!     Average temperature (ASCE Standard Eq. 2)
      TAVG = (TMAX + TMIN) / 2.0 !deg C

!     Atmospheric pressure (ASCE Standard Eq. 3)
      PATM = 101.3 * ((293.0 - 0.0065 * XELEV)/293.0) ** 5.26 !kPa

!     Psychrometric constant (ASCE Standard Eq. 4)
      PSYCON = 0.000665 * PATM !kPa/deg C

!     Slope of the saturation vapor pressure-temperature curve
!     (ASCE Standard Eq. 5)                                !kPa/degC
      UDELTA = 2503.0*EXP(17.27*TAVG/(TAVG+237.3))/(TAVG+237.3)**2.0

!     Saturation vapor pressure (ASCE Standard Eqs. 6 and 7)
      EMAX = 0.6108*EXP((17.27*TMAX)/(TMAX+237.3)) !kPa
      EMIN = 0.6108*EXP((17.27*TMIN)/(TMIN+237.3)) !kPa
      ES = (EMAX + EMIN) / 2.0                     !kPa

!     Actual vapor pressure (ASCE Standard Eq. 8)
      EA = 0.6108*EXP((17.27*TDEW)/(TDEW+237.3)) !kPa

!     RHmin (ASCE Standard Eq. 13, RHmin limits from FAO-56 Eq. 70)
      RHMIN = MAX(20.0, MIN(80.0, EA/EMAX*100.0))

!     Net shortwave radiation (ASCE Standard Eq. 16)
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
        ALBEDO = 0.23
      ENDIF
      RNS = (1.0-ALBEDO)*SRAD !MJ/m2/d

!     Extraterrestrial radiation (ASCE Standard Eqs. 21,23,24,27)
      PIE = 3.14159265359
      DR = 1.0+0.033*COS(2.0*PIE/365.0*DOY) !Eq. 23
      LDELTA = 0.409*SIN(2.0*PIE/365.0*DOY-1.39) !Eq. 24
      WS = ACOS(-1.0*TAN(XLAT*PIE/180.0)*TAN(LDELTA)) !Eq. 27
      RA1 = WS*SIN(XLAT*PIE/180.0)*SIN(LDELTA) !Eq. 21
      RA2 = COS(XLAT*PIE/180.0)*COS(LDELTA)*SIN(WS) !Eq. 21
      RA = 24.0/PIE*4.92*DR*(RA1+RA2) !MJ/m2/d Eq. 21

!     Clear sky solar radiation (ASCE Standard Eq. 19)
      RSO = (0.75+2E-5*XELEV)*RA !MJ/m2/d

!     Net longwave radiation (ASCE Standard Eqs. 17 and 18)
      RATIO = SRAD/RSO
      IF (RATIO .LT. 0.3) THEN
        RATIO = 0.3
      ELSEIF (RATIO .GT. 1.0) THEN
        RATIO = 1.0
      END IF
      FCD = 1.35*RATIO-0.35 !Eq 18
      TK4 = ((TMAX+273.16)**4.0+(TMIN+273.16)**4.0)/2.0 !Eq. 17
      RNL = 4.901E-9*FCD*(0.34-0.14*SQRT(EA))*TK4 !MJ/m2/d Eq. 17

!     Net radiation (ASCE Standard Eq. 15)
      RN = RNS - RNL !MJ/m2/d

!     Soil heat flux (ASCE Standard Eq. 30)
      G = 0.0 !MJ/m2/d

!     Wind speed (ASCE Standard Eq. 33)
      WINDSP = WINDRUN * 1000.0 / 24.0 / 60.0 / 60.0 !m/s
      WIND2m = WINDSP * (4.87/LOG(67.8*WINDHT-5.42))
C      HACK: adding initialized values due to possible undefined behavior
      Cn = 0.0
      Cd = 0.0
      IF (MEEVP .EQ. 'A') THEN
        Cn = 1600.0
        Cd = 0.38
      ELSE IF (MEEVP .EQ. 'G') THEN
        Cn = 900.0
        Cd = 0.34
      END IF

!     Standardized reference evapotranspiration (ASCE Standard Eq. 1)
      REFET =0.408*UDELTA*(RN-G)+PSYCON*(Cn/(TAVG+273.0))*WIND2m*(ES-EA)
      REFET = REFET/(UDELTA+PSYCON*(1.0+Cd*WIND2m)) !mm/d
      REFET = MAX(0.0001, REFET)

!     Aerodynamic roughness and surface resistance daily timestep constants
!     (ASCE Standard Table 1)

!      SELECT CASE(MEEVP) !
!        CASE('A') !Alfalfa reference
!          Cn = 1600.0 !K mm s^3 Mg^-1 d^-1
!          Cd = 0.38 !s m^-1
!        CASE('G') !Grass reference
!          Cn = 900.0 !K mm s^3 Mg^-1 d^-1
!          Cd = 0.34 !s m^-1
!      END SELECT

!     FAO-56 dual crop coefficient approach
!     Basal crop coefficient (Kcb)
!     Also similar to FAO-56 Eq. 97
!     KCB is zero when LAI is zero

!     Values set from paper inspection
      SKC = 0.8
      KCBMIN = 0.3
      KCBMAX = 1.2

      IF (XHLAI .LE. 0.0) THEN
         KCB = 0.0
      ELSE
         !DeJonge et al. (2012) equation
         KCB = MAX(0.0,KCBMIN+(KCBMAX-KCBMIN)*(1.0-EXP(-1.0*SKC*XHLAI)))
      ENDIF

      !Maximum crop coefficient (Kcmax) (FAO-56 Eq. 72)
      WND = MAX(1.0,MIN(WIND2m,6.0))
      CHT = MAX(0.001,CANHT)

C     HACK: Another one like the above
      KCMAX = 0.5           ! HACK: Guarantees greater that KCBMIN
      IF (MEEVP .EQ. 'A') THEN
        KCMAX = MAX(1.0,KCB+0.05)
      ELSE IF (MEEVP .EQ. 'G') THEN
        KCMAX = MAX((1.2+(0.04*(WND-2.0)-0.004*(RHMIN-45.0))
     &                      *(CHT/3.0)**(0.3)),KCB+0.05)
      END IF

      !Effective canopy cover (fc) (FAO-56 Eq. 76)
      IF (KCB .LE. KCBMIN) THEN
         FC = 0.0
      ELSE
         FC = ((KCB-KCBMIN)/(KCMAX-KCBMIN))**(1.0+0.5*CANHT)
      ENDIF

      !Exposed and wetted soil fraction (FAO-56 Eq. 75)
      !Unresolved issue with FW (fraction wetted soil surface).
      !Some argue FW should not be used to adjust demand.
      !Rather wetting fraction issue should be addressed on supply side.
      !Difficult to do with a 1-D soil water model
      FW = 1.0
      FEW = MIN(1.0-FC,FW)

      !Potential evaporation coefficient (Ke) (Based on FAO-56 Eq. 71)
      !Kr = 1.0 since this is potential Ke. Model routines handle stress
      KE = MAX(0.0, MIN(1.0*(KCMAX-KCB), FEW*KCMAX))

      !Potential crop coefficient (Kc) (FAO-56 Eqs. 58 & 69)
C      KC = KCB + KE
C     NOTE: the above is dead code

      !Potential evapotranspiration (FAO-56 Eq. 69)
      EO = (KCB + KE) * REFET

      EO = MAX(EO,0.0001)

      RETURN
      END SUBROUTINE PETASCE
!-------------------------------------------------------------------