!!-------- Show cell information
subroutine showcellinfo
use defvar
implicit real*8 (a-h,o-z)
character c200tmp*200
if (ifPBC>0) then
	write(*,*)
    write(*,*) "Cell information"
    write(*,*) "In Bohr:"
    write(*,"(' Cell vector 1,  X=',f11.5,'  Y=',f11.5,'  Z=',f11.5,'  Norm:',f11.5)") cellv1,dsqrt(sum(cellv1**2))
    if (ifPBC>1) then
        write(*,"(' Cell vector 2,  X=',f11.5,'  Y=',f11.5,'  Z=',f11.5,'  Norm:',f11.5)") cellv2,dsqrt(sum(cellv2**2))
        if (ifPBC>2) then
            write(*,"(' Cell vector 3,  X=',f11.5,'  Y=',f11.5,'  Z=',f11.5,'  Norm:',f11.5)") cellv3,dsqrt(sum(cellv3**2))
        end if
    end if
    write(*,*) "In Angstrom:"
    write(*,"(' Cell vector 1,  X=',f11.5,'  Y=',f11.5,'  Z=',f11.5,'  Norm:',f11.5)") cellv1*b2a,dsqrt(sum(cellv1**2))*b2a
    if (ifPBC>1) then
        write(*,"(' Cell vector 2,  X=',f11.5,'  Y=',f11.5,'  Z=',f11.5,'  Norm:',f11.5)") cellv2*b2a,dsqrt(sum(cellv2**2))*b2a
        if (ifPBC>2) then
            write(*,"(' Cell vector 3,  X=',f11.5,'  Y=',f11.5,'  Z=',f11.5,'  Norm:',f11.5)") cellv3*b2a,dsqrt(sum(cellv3**2))*b2a
        end if
    end if
    if (ifPBC==3) then
        call getcellabc(asize,bsize,csize,alpha,beta,gamma)
        write(*,"(' Cell angles:  Alpha=',f9.4,'  Beta=',f9.4,'  Gamma=',f9.4,' degree')") alpha,beta,gamma
        call calc_cellvol(cellvol)
        write(*,"(' Cell volume:',f16.4,' Bohr^3    (',f16.4,' Angstrom^3 )')") cellvol,cellvol*b2a**3
        dens=sum(atmwei(a%index))*amu2kg*1000  /(cellvol*b2a**3/1D24)
        write(*,"(' Density:',f10.5,' g/cm^3    (',f10.3,' kg/m^3 )')") dens,dens*1000
        write(*,*)
        write(c200tmp,"(a,3f10.5,3f8.3,a)") "pbc set {",asize,bsize,csize,alpha,beta,gamma," } -all"
        write(*,"(a,/,1x,a)") " Command of showing box in VMD program: (then run ""pbc box"")",trim(c200tmp)
    end if
end if
end subroutine

!!!------ Initialize some PBC information and settings. After using this, periodic code will be fully compatible with any case
subroutine init_PBC
use defvar
use util
ifdoPBCx=ifdoPBCx_in
ifdoPBCy=ifdoPBCy_in
ifdoPBCz=ifdoPBCz_in
PBCnx=PBCnx_in
PBCny=PBCny_in
PBCnz=PBCnz_in
!Force some directions do not consider periodicity
if (ifPBC==0) then !Isolated system
    ifdoPBCx=0
    ifdoPBCy=0
    ifdoPBCz=0
else if (ifPBC==1) then !1D system
    ifdoPBCy=0
    ifdoPBCz=0
    !Set temporary cellv2 and cellv3 orthogonal to v1, otherwise e.g. fractional coordinate cannot be generated
    call vecprod(cellv1(1),cellv1(2),cellv1(3),5D0,7D0,-4D0,cellv2(1),cellv2(2),cellv2(3)) !(5,7,-4) is arbitrarily selected vector
    call vecprod(cellv1(1),cellv1(2),cellv1(3),cellv2(1),cellv2(2),cellv2(3),cellv3(1),cellv3(2),cellv3(3))
else if (ifPBC==2) then !2D system
    ifdoPBCz=0
    !Set temporary cellv3 orthogonal to v1 and v2, otherwise e.g. fractional coordinate cannot be generated
    call vecprod(cellv1(1),cellv1(2),cellv1(3),cellv2(1),cellv2(2),cellv2(3),cellv3(1),cellv3(2),cellv3(3))
end if
!When PBC is not considered in a direction, PBCnx/y/z should be set to 0 to avoid consider neighbouring cells in corresponding direction
if (ifdoPBCx==0) PBCnx=0
if (ifdoPBCy==0) PBCny=0
if (ifdoPBCz==0) PBCnz=0
end subroutine

!!!------ Convert fractional coordinates to Cartesian coordinates
subroutine fract2Cart(fract,Cart)
use defvar
real*8 fract(3),Cart(3),Amat(3,3),Fcoord(3,1),rcoord(3,1)
Fcoord(:,1)=fract(:)
Amat(:,1)=cellv1(:)
Amat(:,2)=cellv2(:)
Amat(:,3)=cellv3(:)
rcoord=matmul(Amat,Fcoord) !New xyz coordinate
Cart(:)=rcoord(:,1)
end subroutine

!!!------ Convert Cartesian coordinates to fractional coordinates
subroutine Cart2fract(Cart,fract)
use defvar
use util
real*8 Cart(3),fract(3),Amat(3,3),Bmat(3,3),Fcoord(3,1),rcoord(3,1)
rcoord(:,1)=Cart(:)
Amat(:,1)=cellv1(:)
Amat(:,2)=cellv2(:)
Amat(:,3)=cellv3(:)
Bmat=invmat(Amat,3)
Fcoord=matmul(Bmat,rcoord)
fract(:)=Fcoord(:,1)
end subroutine

!!!------ If the inputted coordinate is out of cell, move it to proper position in cell according to PBC
!See Ian Bush's reply in https://scicomp.stackexchange.com/questions/20165/periodic-boundary-conditions-for-triclinic-box for algorithm
subroutine move_to_cell(xyzin,xyzout)
use defvar
use util
real*8 xyzin(3),xyzout(3),Amat(3,3),Bmat(3,3),Fcoord(3,1),rcoord(3,1)
rcoord(:,1)=xyzin(:)
Amat(:,1)=cellv1(:)
Amat(:,2)=cellv2(:)
Amat(:,3)=cellv3(:)
Bmat=invmat(Amat,3)
!Get fractional coordinate
Fcoord=matmul(Bmat,rcoord)
!Move to central cell
if (ifdoPBCx==1) Fcoord(1,1)=Fcoord(1,1)-floor(Fcoord(1,1))
if (ifdoPBCy==1) Fcoord(2,1)=Fcoord(2,1)-floor(Fcoord(2,1))
if (ifdoPBCz==1) Fcoord(3,1)=Fcoord(3,1)-floor(Fcoord(3,1))
!New xyz coordinte
rcoord=matmul(Amat,Fcoord)
xyzout(:)=rcoord(:,1)
end subroutine

!!!------- Used to test "move_to_cell" in interactive interface
!subroutine test_PBC
!use defvar
!real*8 xyzin(3),xyzout(3)
!do while(.true.)
!    write(*,*) "Input x,y,z in Bohr for test"
!    read(*,*) xyzin
!    call move_to_cell(xyzin,xyzout)
!    write(*,*) "x,y,z of new coordinate:"
!    write(*,"(3f12.6,' Bohr')") xyzout
!end do
!end subroutine

!!!------ Input X,Y,Z of a point, get index of the cell containing this point
subroutine getpointcell(x,y,z,icell,jcell,kcell)
use defvar
use util
real*8 x,y,z,vec(3),Amat(3,3),Bmat(3,3),Fcoord(3,1),rcoord(3,1)
integer icell,jcell,kcell
if (ifPBC==0) then
    icell=0
    jcell=0
    kcell=0
    return
end if
vec(1)=x
vec(2)=y
vec(3)=z
rcoord(:,1)=vec(:)
Amat(:,1)=cellv1(:)
Amat(:,2)=cellv2(:)
Amat(:,3)=cellv3(:)
Bmat=invmat(Amat,3)
Fcoord=matmul(Bmat,rcoord) !Get fractional coordinate
icell=0;jcell=0;kcell=0
if (ifdoPBCx==1) icell=floor(Fcoord(1,1))
if (ifdoPBCy==1) jcell=floor(Fcoord(2,1))
if (ifdoPBCz==1) kcell=floor(Fcoord(3,1))
end subroutine

!!!-------- Input xyz of points A and B, return coordinate of B closest to point A according to PBC
subroutine nearest_mirror(xyzA,xyzB,xyzB2)
use defvar
real*8 xyzA(3),xyzB(3),xyztmp(3),xyzB2(3),tvec(3),dist2tmp
dist2min=999999D0
do icell=-ifdoPBCx,ifdoPBCx
    do jcell=-ifdoPBCy,ifdoPBCy
        do kcell=-ifdoPBCz,ifdoPBCz
            call tvec_PBC(icell,jcell,kcell,tvec)
            xyztmp=xyzB+tvec
            dist2tmp=sum((xyzA-xyztmp)**2)
            if (dist2tmp<dist2min) then
                dist2min=dist2tmp
                xyzB2=xyztmp
            end if
        end do
    end do
end do
end subroutine

!!!-------- Input indices of atoms A and B, return their nearest distance, and coordinate of B closest to A
subroutine nearest_atmdistxyz(iatm,jatm,dist,atmx,atmy,atmz)
use defvar
integer iatm,jatm
real*8 dist,atmx,atmy,atmz
real*8 xyzA(3),xyzB(3),xyzB2(3)
xyzA(1)=a(iatm)%x
xyzA(2)=a(iatm)%y
xyzA(3)=a(iatm)%z
xyzB(1)=a(jatm)%x
xyzB(2)=a(jatm)%y
xyzB(3)=a(jatm)%z
call nearest_mirror(xyzA,xyzB,xyzB2)
atmx=xyzB2(1)
atmy=xyzB2(2)
atmz=xyzB2(3)
dist=dsqrt(sum((xyzA-xyzB2)**2))
end subroutine

!!!-------- Input xyz of points A and B, return their nearest distance according to PBC
subroutine nearest_dist(xyzA,xyzB,dist)
real*8 xyzA(3),xyzB(3),xyzB2(3),dist
call nearest_mirror(xyzA,xyzB,xyzB2)
dist=dsqrt(sum((xyzA-xyzB2)**2))
end subroutine

!!!----------- Input number of translation times in various directions, return translation vector
subroutine tvec_PBC(icell,jcell,kcell,tvec)
use defvar
integer icell,jcell,kcell
real*8 tvec(3)
tvec(1)=icell*cellv1(1)+jcell*cellv2(1)+kcell*cellv3(1)
tvec(2)=icell*cellv1(2)+jcell*cellv2(2)+kcell*cellv3(2)
tvec(3)=icell*cellv1(3)+jcell*cellv2(3)+kcell*cellv3(3)
end subroutine

!!!----- Return coordinate of specific vertex of the cell
!idx is the index of following map
!    5-------8
!   /|      /|
!  6-+-----7 |
!  | |     | |
!  | 1-----+-4
!  |/      |/
!  2-------3
!
!   Z
!   |
!   0---Y
!  /
! X
subroutine cellvertex(idx,vertx,verty,vertz)
use defvar
integer idx
real*8 vertx,verty,vertz,v1tmp(3),v2tmp(3),v3tmp(3)
if (idx==1) then
    icell=0;jcell=0;kcell=0
else if (idx==2) then
    icell=1;jcell=0;kcell=0
else if (idx==3) then
    icell=1;jcell=1;kcell=0
else if (idx==4) then
    icell=0;jcell=1;kcell=0
else if (idx==5) then
    icell=0;jcell=0;kcell=1
else if (idx==6) then
    icell=1;jcell=0;kcell=1
else if (idx==7) then
    icell=1;jcell=1;kcell=1
else if (idx==8) then
    icell=0;jcell=1;kcell=1
end if
v1tmp=0
v2tmp=0
v3tmp=0
if (ifdoPBCx==1) v1tmp=cellv1
if (ifdoPBCy==1) v2tmp=cellv2
if (ifdoPBCz==1) v3tmp=cellv3
vertx=icell*v1tmp(1)+jcell*v2tmp(1)+kcell*v3tmp(1)
verty=icell*v1tmp(2)+jcell*v2tmp(2)+kcell*v3tmp(2)
vertz=icell*v1tmp(3)+jcell*v2tmp(3)+kcell*v3tmp(3)
end subroutine

!!----- Wrapper of cellvertex, input two vertex indices return two sets of coordinates
subroutine cellvertex2(idx,jdx,vert1x,vert1y,vert1z,vert2x,vert2y,vert2z)
integer idx,jdx
real*8 vert1x,vert1y,vert1z,vert2x,vert2y,vert2z
call cellvertex(idx,vert1x,vert1y,vert1z)
call cellvertex(jdx,vert2x,vert2y,vert2z)
end subroutine

!!!------- Return max x,y,z of all cell vertices
subroutine cellmaxxyz(xmax,ymax,zmax)
use defvar
implicit real*8 (a-h,o-z)
real*8 xmax,ymax,zmax
xmax=-999
ymax=-999
zmax=-999
do idx=1,8
    call cellvertex(idx,vertx,verty,vertz)
    if (vertx>xmax) xmax=vertx
    if (verty>ymax) ymax=verty
    if (vertz>zmax) zmax=vertz
end do
end subroutine

!!!------- Return mix x,y,z of all cell vertices
subroutine cellminxyz(xmin,ymin,zmin)
use defvar
implicit real*8 (a-h,o-z)
real*8 xmin,ymin,zmin
xmin=999
ymin=999
zmin=999
do idx=1,8
    call cellvertex(idx,vertx,verty,vertz)
    if (vertx<xmin) xmin=vertx
    if (verty<ymin) ymin=verty
    if (vertz<zmin) zmin=vertz
end do
end subroutine

!!!----- Return cell volume according to cell information
subroutine calc_cellvol(cellvol)
use defvar
use util
implicit real*8 (a-h,o-z)
real*8 cellvol,vec(3),mat(3,3)
!V=|a.(bxc)|
call vecprod(cellv2(1),cellv2(2),cellv2(3),cellv3(1),cellv3(2),cellv3(3),vec(1),vec(2),vec(3))
cellvol=abs(sum(cellv1(:)*vec(:)))
!Another way to solve
!mat(:,1)=cellv1(:)
!mat(:,2)=cellv2(:)
!mat(:,3)=cellv3(:)
!cellvol=abs(detmat(mat))
end subroutine

!!!------ Calculate cell vectors cellv1/2/3 based on inputted a,b,c,alpha,beta,gamma, reference: http://gisaxs.com/index.php/Unit_cell
subroutine abc2cellv(asize,bsize,csize,alpha,beta,gamma)
use defvar
implicit real*8 (a-h,o-z)
real*8 asize,bsize,csize,alpha,beta,gamma
alpha=alpha/180*pi
beta=beta/180*pi
gamma=gamma/180*pi
cellv1(1)=asize
cellv1(2)=0
cellv1(3)=0
cellv2(1)=bsize*cos(gamma)
cellv2(2)=bsize*sin(gamma)
cellv2(3)=0
cellv3(1)=csize*cos(beta)
cellv3(2)=csize*(cos(alpha)-cos(beta)*cos(gamma))/sin(gamma)
cellv3(3)=csize*dsqrt( 1 - cos(beta)**2 - ((cos(alpha)-cos(beta)*cos(gamma))/sin(gamma))**2 )
end subroutine

!!!------ Return a,b,c (in Angstrom) and alpha,beta,gamma based on current cell information
subroutine getcellabc(asize,bsize,csize,alpha,beta,gamma)
use defvar
use util
implicit real*8 (a-h,o-z)
real*8 asize,bsize,csize,alpha,beta,gamma
asize=dsqrt(sum(cellv1**2))*b2a
bsize=dsqrt(sum(cellv2**2))*b2a
csize=dsqrt(sum(cellv3**2))*b2a
alpha=vecang(cellv2(1),cellv2(2),cellv2(3),cellv3(1),cellv3(2),cellv3(3))
beta =vecang(cellv1(1),cellv1(2),cellv1(3),cellv3(1),cellv3(2),cellv3(3))
gamma=vecang(cellv1(1),cellv1(2),cellv1(3),cellv2(1),cellv2(2),cellv2(3))
end subroutine

!!!--------- Make molecule truncated by box whole, called by subroutine geom_operation
subroutine makemolwhole
use defvar
use util
implicit real*8 (a-h,o-z)
integer fraglist(ncenter,ncenter) !fraglist(1:frgnatm(ifrag),ifrag) is indices of atoms in fragment ifrag
integer fraglist_old(ncenter,ncenter)
integer frgnatm(ncenter)
integer nfrag !Total number of fragments
integer iffrag(ncenter),intarr(ncenter)
real*8 tvec(3)
write(*,*)
write(*,*) "Please wait..."
!Construct fragments
intarr=1
iatm=1
nfrag=0
frgnatm(:)=0
do while(.true.)
    call getfragatoms(iatm,iffrag)
    nfrag=nfrag+1
    do jatm=1,ncenter
        if (iffrag(jatm)==1) then
            frgnatm(nfrag)=frgnatm(nfrag)+1
            fraglist(frgnatm(nfrag),nfrag)=jatm
            intarr(jatm)=0
        end if
    end do
    if (all(intarr==0)) exit
    do iatm=1,ncenter
        if (intarr(iatm)==1) exit
    end do
end do

!Sort fragments from small to large number of members
forall(i=1:nfrag) intarr(i)=i
call sorti4(frgnatm(1:nfrag),list=intarr)
fraglist_old=fraglist
do ifrag=1,nfrag
    fraglist(:,ifrag)=fraglist_old(:,intarr(ifrag))
end do
!do ifrag=1,nfrag
!    write(*,"(' Fragment',i5,':')") ifrag
!    write(*,"(15i5)") fraglist(1:frgnatm(ifrag),ifrag)
!end do

!Move fragments if new bond can be detected to other atoms
ncombine=0
combinefrag: do while(.true.)
    do ifrag=1,nfrag
        if (frgnatm(ifrag)==0) cycle !This fragment has been combined to another
        !write(*,"(' Testing fragment',i5)") ifrag
        imove=0
        testfrag: do icell=-1,1
            do jcell=-1,1
                do kcell=-1,1
                    if (icell==0.and.jcell==0.and.kcell==0) cycle
                    call tvec_PBC(icell,jcell,kcell,tvec)
                    do idx=1,frgnatm(ifrag)
                        iatm=fraglist(idx,ifrag)
                        do jfrag=1,nfrag
                            if (jfrag==ifrag) cycle
                            if (frgnatm(jfrag)==0) cycle !This fragment has been combined to another
                            do jdx=1,frgnatm(jfrag)
                                jatm=fraglist(jdx,jfrag)
                                dist=dsqrt((a(iatm)%x+tvec(1)-a(jatm)%x)**2+(a(iatm)%y+tvec(2)-a(jatm)%y)**2+(a(iatm)%z+tvec(3)-a(jatm)%z)**2)
                                if (dist < bondcrit*(covr(a(iatm)%index)+covr(a(jatm)%index))) then
                                    imove=1
                                    exit testfrag
                                end if
                            end do
                        end do
                    end do
                end do
            end do
        end do testfrag
        if (imove==1) then
            !write(*,"(' Moving fragment',i5,' by X/Y/Z:',3f10.4,' Bohr')") ifrag,tvec
            a(fraglist(1:frgnatm(ifrag),ifrag))%x=a(fraglist(1:frgnatm(ifrag),ifrag))%x+tvec(1)
            a(fraglist(1:frgnatm(ifrag),ifrag))%y=a(fraglist(1:frgnatm(ifrag),ifrag))%y+tvec(2)
            a(fraglist(1:frgnatm(ifrag),ifrag))%z=a(fraglist(1:frgnatm(ifrag),ifrag))%z+tvec(3)
            !write(*,"(' Combining fragment',i5,' and',i5)") ifrag,jfrag
            fraglist( frgnatm(jfrag)+1:frgnatm(jfrag)+frgnatm(ifrag) , jfrag ) = fraglist(1:frgnatm(ifrag),ifrag)
            frgnatm(jfrag)=frgnatm(jfrag)+frgnatm(ifrag)
            frgnatm(ifrag)=0
            ncombine=ncombine+1
            cycle combinefrag
        end if
    end do
    if (ifrag==nfrag+1) exit
end do combinefrag
if (allocated(connmat)) deallocate(connmat) !getfragatoms generated connmat, while after changing order, the relationship is no longer valid
write(*,"(a,i7)") " Done! Number of combinations performed:",ncombine
end subroutine

!!!------ Ask user to set up grid and generate Sbas for wavefunction analysis
subroutine ask_Sbas_PBC
use defvar
implicit real*8 (a-h,o-z)
character selectyn
if (ifPBC>0) then
    if (allocated(Sbas_PBC)) then
        write(*,"(a)") " Overlap matrix for PBC has already been generated, generate again? (y/n)"
        read(*,*) selectyn
        if (selectyn=='n'.or.selectyn=='N') return
    else
        write(*,"(a)") " Overlap matrix between basis functions is needed to be generated for subsequent analysis"
        allocate(Sbas_PBC(nbasis,nbasis))
    end if
    !call setgrid(0,igridsel)
    write(*,*) "Now input grid spacing used to calculate overlap matrix in Bohr, e.g. 0.25"
    write(*,"(a)") " Note: The smaller the spacing, the more accurate the result, but the higher the cost. &
    Usually 0.25 is good balance between accuracy and cost."
    read(*,*) grdspc
    v1len=dsqrt(sum(cellv1**2))
    v2len=dsqrt(sum(cellv2**2))
    v3len=dsqrt(sum(cellv3**2))
    nx=nint(v1len/grdspc)
    gridv1(:)=cellv1(:)/nx
    ny=nint(v2len/grdspc)
    gridv2(:)=cellv2(:)/ny
    nz=nint(v3len/grdspc)
    gridv3(:)=cellv3(:)/nz
    dx=gridv1(1) !Only for compatibility with old codes
    dy=gridv2(2)
    dz=gridv3(3)
    write(*,"(a,3i5)") " Number of grids in the three directions:",nx,ny,nz
    call genSbas_PBC
end if
end subroutine

!!!--------- Generate overlap matrix between all current basis functions based on uniform grids
!The integral is limited to current cell
subroutine genSbas_PBC
use defvar
use function
use util
implicit real*8 (a-h,o-z)
!real*8 Sbas_PBC_cart(nbasisCar,nbasisCar),basCar(nbasisCar)
real*8 Sbas_tmp(nbasis,nbasis),basval(nmo)

!Not Finished. This part of code will calculate values of all Cartesian basis functions at every point and then evaluate Sbas_PBC
!Sbas_PBC_cart=0
!Sbas_PBC=0
!do k=1,nz
!    do j=1,ny
!        do i=1,nx
!            call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
!            call calcbasCar_PBC(tmpx,tmpy,tmpz,basCar)
!            do ibas=1,nbasisCar
!	            do jbas=ibas,nbasisCar
!                    Sbas_PBC_cart(ibas,jbas)=Sbas_PBC_cart(ibas,jbas)+basCar(ibas)*basCar(jbas)
!	            end do
!            end do
!        end do
!    end do
!end do
!do ibas=1,nbasisCar
!	do jbas=ibas+1,nbasisCar
!        Sbas_PBC_cart(jbas,ibas)=Sbas_PBC_cart(ibas,jbas)
!	end do
!end do
!call matCar2curr(Sbas_PBC_cart,Sbas_PBC)

!After using following code, value of orbitals will correspond to value of basis functions
if (.not.allocated(CObasa_org)) allocate(CObasa_org(nbasis,nbasis))
if (.not.allocated(CO_org)) allocate(CO_org(nmo,nprims))
CObasa_org=CObasa
CObasa=0
do ibas=1,nbasis
    CObasa(ibas,ibas)=1
end do
call CObas2CO(1)

!Generate unique GTFs, for faster evaluation in orbderv
call gen_GTFuniq(0)

call walltime(iwalltime1)
Sbas_PBC=0
ifinish=0
if (expcutoff_PBC<0) write(*,"(' Note: All exponential functions exp(x) with x<',f8.3,' will be ignored')") expcutoff_PBC
call showprog(0,nz)
!$OMP PARALLEL SHARED(Sbas_PBC,ifinish) PRIVATE(Sbas_tmp,i,j,k,tmpx,tmpy,tmpz,basval,ibas,jbas,basi) NUM_THREADS(nthreads)
Sbas_tmp=0
!$OMP do schedule(dynamic)
do k=1,nz
    do j=1,ny
        do i=1,nx
            call getgridxyz(i,j,k,tmpx,tmpy,tmpz)
            call orbderv_PBC(1,1,nbasis,tmpx,tmpy,tmpz,basval)
            !Cycle rows, and fill lower-triangular part
            do ibas=1,nbasis
                basi=basval(ibas)
	            do jbas=ibas,nbasis
                    Sbas_tmp(jbas,ibas)=Sbas_tmp(jbas,ibas)+basval(jbas)*basi
	            end do
            end do
        end do
    end do
    ifinish=ifinish+1
    call showprog(ifinish,nz)
end do
!$OMP END DO
!$OMP CRITICAL
Sbas_PBC=Sbas_PBC+Sbas_tmp
!$OMP END CRITICAL
!$OMP END PARALLEL
!Fill upper-triangular part
do ibas=2,nbasis
	do jbas=1,ibas-1
        Sbas_PBC(jbas,ibas)=Sbas_PBC(ibas,jbas)
	end do
end do
call calc_dvol(dvol)
Sbas_PBC=Sbas_PBC*dvol
Sbas=Sbas_PBC !Usually Sbas_PBC is not directly involved in practical analysis

call del_GTFuniq !Destory unique GTF informtaion

CObasa=CObasa_org
CO=CO_org
deallocate(CObasa_org,CO_org)

write(*,"(' Quality test, Tr(P*S):',f14.8,' (In principle it should be equal to actual number of electrons. &
The larger the deviation to integer, the larger the integration error of current overlap matrix (S))')") sum(Ptot*Sbas)
call walltime(iwalltime2)
write(*,"(' Generation of overlap matrix took up',i8,' seconds wall clock time')") iwalltime2-iwalltime1
!open(10,file="ovlpmat.txt",status="replace")
!call showmatgau(Sbas,"Overlap matrix",0,fileid=10)
!close(10)
end subroutine

!---- Load overlap matrix from .csr file exported by CP2K, however I found the matrix is meaningless, it is neither identical to genSbas or to genSbas_PBC
subroutine loadSbas_csr
use defvar
integer ibas,jbas
open(10,file="a.csr",status="old")
do ibas=1,nbasis
    do jbas=1,nbasis
        read(10,*) itmp,jtmp,Sbas(ibas,jbas)
        write(*,*) itmp,jtmp,Sbas(ibas,jbas)
        pause
    end do
end do
close(10)
end subroutine

!!!----------- Calculate wavefunction value of all basis functions at a point for PBC case (not done for PBC now)
!Clone and adapted from "calcbasval", which is used for isolated systems
!The global COtr matrix must have been allocated and filled by using COtr=transpose(CO)
!Before using this, one should make CO correspond to basis function expressions, namely:
!  CObasa_org=CObasa
!  CObasa=0
!  do ibas=1,nbasis
!      CObasa(ibas,ibas)=1
!  end do
!  call CObas2CO(1)
!    Then after using this routine, recover to original coefficients:
!  CObasa=CObasa_org
!  CO=CO_org
!In fact, using below code can realize identical purpose, but slower because not optimized for present purpose
!  call orbderv(1,1,nbasis,gridatm(ipt)%x,gridatm(ipt)%y,gridatm(ipt)%z,basval), where basval has length of nmo
!subroutine calcbasval_PBC(x,y,z,basval)
!use defvar
!implicit real*8 (a-h,o-z)
!real*8 x,y,z,basval(nbasis),GTFvalarr(nprims)
!
!lastcen=-1
!GTFvalarr=0D0
!do j=1,nprims
!	ix=type2ix(b(j)%type)
!	iy=type2iy(b(j)%type)
!	iz=type2iz(b(j)%type)
!	ep=b(j)%exp
!
!	if (b(j)%center/=lastcen) then
!		sftx=x-a(b(j)%center)%x
!		sfty=y-a(b(j)%center)%y
!		sftz=z-a(b(j)%center)%z
!		sftx2=sftx*sftx
!		sfty2=sfty*sfty
!		sftz2=sftz*sftz
!		rr=sftx2+sfty2+sftz2
!	end if
!	if (expcutoff>0.or.-ep*rr>expcutoff) then
!		expterm=exp(-ep*rr)
!	else
!		expterm=0D0
!	end if
!	lastcen=b(j)%center
!	if (expterm==0D0) cycle
!
!	if (b(j)%type==1) then
!	GTFval=expterm
!	else if (b(j)%type==2) then
!	GTFval=sftx*expterm
!	else if (b(j)%type==3) then
!	GTFval=sfty*expterm
!	else if (b(j)%type==4) then
!	GTFval=sftz*expterm
!	else if (b(j)%type==5) then
!	GTFval=sftx2*expterm
!	else if (b(j)%type==6) then
!	GTFval=sfty2*expterm
!	else if (b(j)%type==7) then
!	GTFval=sftz2*expterm
!	else
!	GTFval=sftx**ix *sfty**iy *sftz**iz *expterm
!	end if
!    GTFvalarr(j)=GTFval
!end do
!
!if (isphergau==1) then !For each basis function, only loops GTFs in the same shell for reducing cost
!    ibas=0
!    iGTF=0
!    do ish=1,nshell
!        nshbas=shtype2nbas(shtype(ish))
!        nshbasCar=shtype2nbas(shtypeCar(ish))
!        nshGTF=nshbasCar*shcon(ish)
!        is=iGTF+1
!        ie=iGTF+nshGTF
!        do jbas=ibas+1,ibas+nshbas
!            !basval(jbas)=sum( GTFvalarr(is:ie)*CO(jbas,is:ie) )
!            basval(jbas)=sum( GTFvalarr(is:ie)*COtr(is:ie,jbas) )
!        end do
!        ibas=ibas+nshbas
!        iGTF=iGTF+nshGTF
!    end do
!else !All basis functions are Cartesian, below code is faster than the above general code
!    do ibas=1,nbasisCar
!        is=primstart(ibas)
!        ie=primend(ibas)
!        basval(ibas)=sum( GTFvalarr(is:ie)*COtr(is:ie,ibas) )
!    end do
!end if
!
!end subroutine

!!!--------- Construct global array a_tmp, which contains real atoms and replicated boundary atoms
!ncenter_tmp is returned variable containing number of all atoms including the replicated boundary ones
subroutine construct_atmp_withbound(ncenter_tmp)
use defvar
implicit real*8 (a-h,o-z)
real*8 Cart(3),fract(3),fracttmp(3)
integer ncenter_tmp
call getcellabc(asize,bsize,csize,alpha,beta,gamma)
devthres=1D-3 !If distance to cell boundary is less than 0.001 Bohr, then it will be regarded as boundary atom
nadd=0
do iatm=1,ncenter
    Cart(1)=a(iatm)%x
    Cart(2)=a(iatm)%y
    Cart(3)=a(iatm)%z
    call Cart2fract(Cart,fract)
    naddold=nadd
    do ix=-1,1
        fracta=fract(1)+ix
        do iy=-1,1
            fractb=fract(2)+iy
            do iz=-1,1
                if (ix==0.and.iy==0.and.iz==0) cycle
                fractc=fract(3)+iz
                !write(*,"(i5,3i3,6f11.6)") iatm,ix,iy,iz,fracta,fractb,fractc,fracta*asize,fractb*bsize,fractc*csize
                if (fracta*asize>-devthres.and.(fracta-1)*asize<devthres.and.&
                    fractb*bsize>-devthres.and.(fractb-1)*bsize<devthres.and.&
                    fractc*csize>-devthres.and.(fractc-1)*csize<devthres) then
                    nadd=nadd+1
                end if
            end do
        end do
    end do
    !write(*,"(i5,1x,a,3f10.6,' added',i5)") iatm,a(iatm)%name,fract(:),nadd-naddold
end do
ncenter_tmp=ncenter+nadd
if (allocated(a_tmp)) deallocate(a_tmp)
allocate(a_tmp(ncenter_tmp))
a_tmp(1:ncenter)=a(1:ncenter)
iadd=0
do iatm=1,ncenter
    Cart(1)=a(iatm)%x
    Cart(2)=a(iatm)%y
    Cart(3)=a(iatm)%z
    call Cart2fract(Cart,fract)
    do ix=-1,1
        fracta=fract(1)+ix
        do iy=-1,1
            fractb=fract(2)+iy
            do iz=-1,1
                if (ix==0.and.iy==0.and.iz==0) cycle
                fractc=fract(3)+iz
                if (fracta*asize>-devthres.and.(fracta-1)*asize<devthres.and.&
                    fractb*bsize>-devthres.and.(fractb-1)*bsize<devthres.and.&
                    fractc*csize>-devthres.and.(fractc-1)*csize<devthres) then
                    iadd=iadd+1
                    a_tmp(ncenter+iadd)=a(iatm)
                    fracttmp(1)=fracta
                    fracttmp(2)=fractb
                    fracttmp(3)=fractc
                    call fract2Cart(fracttmp,Cart)
                    a_tmp(ncenter+iadd)%x=Cart(1)
                    a_tmp(ncenter+iadd)%y=Cart(2)
                    a_tmp(ncenter+iadd)%z=Cart(3)
                end if
            end do
        end do
    end do
end do
!do iatm=1,ncenter_tmp
!    write(*,"(i5,1x,a,3f12.6)") iatm,a_tmp(iatm)%name,a_tmp(iatm)%x,a_tmp(iatm)%y,a_tmp(iatm)%z
!end do
end subroutine

!!!-------- Save current PBC information to memory
subroutine savePBCinfo
use defvar
ifPBC_bk=ifPBC
cellv1_bk=cellv1
cellv2_bk=cellv2
cellv3_bk=cellv3
end subroutine

!!!-------- Load saved PBC information
subroutine loadPBCinfo
use defvar
ifPBC=ifPBC_bk
cellv1=cellv1_bk
cellv2=cellv2_bk
cellv3=cellv3_bk
call init_PBC
end subroutine


*
*     -------------------------------------------------------------
*      I T T K
*     -------------------------------------------------------------
*
*                                                                  *
*     CHESKED TRIANGULAR CONDITIONS FOR   I/2, J/2, K/2.           *
*     I+J>=K, I+K>=J, J+K>=I,                                      *
*     I/2+J/2+K/2 - WHOLE NUMBER                                   *
*     ITTK=1 -   IF NOT SATISFY                                    *
*     ITTK=0 -   IN OVER CASES                                     *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vilnius,  Lithuania                          December 1993   *
*
      FUNCTION ITTK(I,J,K)
      ITTK=0
      IF(IABS(I-J).GT.K)RETURN
      IF(I+J.LT.K)RETURN
      IF(MOD(I+J+K,2).NE.0)RETURN
      ITTK=1
      RETURN
      END


module StructuralMaterialM
  use UtilitiesM
  use PropertyM

  use ThermalMaterialM

  implicit none

  private
  public :: StructuralMaterialDT, thermalStructuralMaterial

  type, extends(ThermalMaterialDT) :: StructuralMaterialDT
     real(rkind) :: young
     real(rkind) :: poissonCoef
     real(rkind) :: thermalCoef
     real(rkind) :: area
     real(rkind) :: thickness
     real(rkind) :: d11, d12, d21, d22, d33
     real(rkind) :: stableTemp
   contains
     procedure :: initThermalStructMat
  end type StructuralMaterialDT

  interface thermalStructuralMaterial
     procedure :: constructor
  end interface thermalStructuralMaterial

contains

  type(StructuralMaterialDT) function constructor &
       (kx, ky, young, poissonCoef, thermalCoef, area, thickness, stableTemp)
    implicit none
    real(rkind), intent(in) :: kx
    real(rkind), intent(in) :: ky
    real(rkind), intent(in) :: young
    real(rkind), intent(in) :: poissonCoef
    real(rkind), intent(in) :: thermalCoef
    real(rkind), intent(in) :: area
    real(rkind), intent(in) :: thickness
    real(rkind), intent(in) :: stableTemp
    call constructor%initThermalStructMat &
         (kx, ky, young, poissonCoef, thermalCoef, area, thickness, stableTemp)
  end function constructor

  subroutine initThermalStructMat &
       (this, kx, ky, young, poissonCoef, thermalCoef, area, thickness, stableTemp)
    implicit none
    class(StructuralMaterialDT), intent(inout) :: this
    real(rkind)                , intent(in)    :: kx
    real(rkind)                , intent(in)    :: ky
    real(rkind)                , intent(in)    :: young
    real(rkind)                , intent(in)    :: poissonCoef
    real(rkind)                , intent(in)    :: thermalCoef
    real(rkind)                , intent(in)    :: area
    real(rkind)                , intent(in)    :: thickness
    real(rkind)                , intent(in)    :: stableTemp
    real(rkind)                                :: factor
    this%conductivity = (/kx, ky/)
    this%young        = young
    this%poissonCoef  = poissonCoef
    this%thermalCoef  = thermalCoef
    this%area         = area
    this%thickness    = thickness
    this%stableTemp   = stableTemp
    !Deformación plana:
    factor = young/((1+poissonCoef)*(1-2*poissonCoef))
    this%d11 = factor*(1-poissonCoef)
    this%d12 = factor*poissonCoef
    this%d21 = factor*poissonCoef
    this%d22 = factor*(1-poissonCoef)
    this%d33 = factor*(1-2*poissonCoef)/2.d0
    !Tensión plana
!!$    factor = young/(1-poissonCoef**2)
!!$    this%d11 = factor
!!$    this%d12 = factor*poissonCoef
!!$    this%d21 = factor*poissonCoef
!!$    this%d22 = factor
!!$    this%d33 = factor*(1-poissonCoef)/2.d0
  end subroutine initThermalStructMat

end module StructuralMaterialM


	FUNCTION PR_DMAX  ( t00x, t06x, tdxc )
C************************************************************************
C* PR_DMAX								*
C*									*
C* This function computes DMAX, the maximum temperature obtained by     *
C* comparing the 6-hour maximum at 00Z, the 6-hour maximum at 06Z, and  *
C* the local midnight maximum (reported at 00 LST).  If either of the   *
C* 6-hour values is missing, the maximum is set to missing.  The inputs *
C* are in degrees C, the output in degrees F.                           *
C*									*
C* REAL PR_DMAX  ( T00X, T06X, TDXC )                                   *
C*									*
C* Input parameters:							*
C*	T00X		REAL	6-hour maximum temperature at 00Z, deg C*
C*	T06X		REAL	6-hour maximum temperature at 06Z, deg C*
C*	TDXC 		REAL	Local midnight max temp at 00 LST, deg C*
C*									*
C* Output parameters:							*
C*	PR_DMAX		REAL	Maximum of the 3 temperature vals, deg F*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 3/99	                                        *
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_DMAX = RMISSD
C
	IF ( ( ERMISS ( t00x ) ) .or. ( ERMISS ( t06x ) ) ) THEN
	    RETURN
	  ELSE IF ( .not. ERMISS ( tdxc ) ) THEN
	    PR_DMAX = PR_TMCF ( AMAX1 ( t00x, t06x, tdxc ) )
	  ELSE
	    PR_DMAX = PR_TMCF ( AMAX1 ( t00x, t06x ) )
	END IF
C*
	RETURN
	END


function wnr(om        ,h         ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: wnr.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute_roller/wnr.f90 $
!!--description-----------------------------------------------------------------
!
! Approximation of the dispersion, original sub-
! routine Disp10 (L, T, h, g)
! relation according to linear wave theory:
!
! w^2 = k TANH k
!
! with k = 2 pi h / L and w = (2 pi / T) sqrt (h/g), and L as
! unknown.
! A rational function approximation is made of the form :
!
!           1 + a1 w^2 + a2 w^4 + a3 w^6 + a4 w^8 + a5 w^10 + a6 w^12
! k^2 = w^2 ---------------------------------------------------------
!           1 + b1 w^2 + b2 w^4 + b3 w^6 + b4 w^8 + a6 w^10
!
! having the exact values for L for:
! w = 0.4, 0.7, 1.0, 1.3, 1.6, 1.95, 2.35, 2.9, 3.8 and 6.5,
! and a relative error less than 1.7E-6 for all w.
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    real(fp)               , pointer :: ag
!
! Local parameters
!
    real(hp), parameter :: a1 = 5.060219360721177D-01
    real(hp), parameter :: a2 = 2.663457535068147D-01
    real(hp), parameter :: a3 = 1.108728659243231D-01
    real(hp), parameter :: a4 = 4.197392043833136D-02
    real(hp), parameter :: a5 = 8.670877524768146D-03
    real(hp), parameter :: a6 = 4.890806291366061D-03
    real(hp), parameter :: b1 = 1.727544632667079D-01
    real(hp), parameter :: b2 = 1.191224998569728D-01
    real(hp), parameter :: b3 = 4.165097693766726D-02
    real(hp), parameter :: b4 = 8.674993032204639D-03
!
! Global variables
!
    real(fp), intent(in) :: h
    real(fp), intent(in) :: om
    real(fp)         :: wnr
!
! Local variables
!
    real(hp) :: den  ! Denominator
    real(hp) :: kd   ! Double value for K
    real(hp) :: num  ! Numerator
    real(hp) :: ome2 ! Omega
!
!! executable statements -------------------------------------------------------
!
    ag       => gdp%gdphysco%ag
    !
    ome2 = real(om, hp)**2*real(h, hp)/real(ag, hp)
    !
    num = 1.0D0 +                                                               &
        & ome2*(a1 + ome2*(a2 + ome2*(a3 + ome2*(a4 + ome2*(a5 + ome2*a6)))))
    den = 1.0D0 + ome2*(b1 + ome2*(b2 + ome2*(b3 + ome2*(b4 + ome2*a6))))
    kd = sqrt(ome2*num/den)/real(h, hp)
    wnr = real(kd, fp)
end function wnr


c
c ---------------------------------------------------
c Modified from coarsen.f in amrclaw
c Uses code taken from update.f to take into account
c wet and dry cells.
c ---------------------------------------------------
c
       subroutine coarsen(valdub,midub,mjdub,auxdub,
     &                    valbgc,mi2tot,mj2tot,auxbgc,nvar,naux)

       use geoclaw_module, only: dry_tolerance
c
       use amr_module, only: mcapa,nghost
       implicit none

       integer, intent(in) :: midub,mjdub,mi2tot,mj2tot,nvar,naux
       real(kind=8), intent(in) :: valdub(nvar,midub, mjdub)
       real(kind=8), intent(in) :: auxdub(naux,midub, mjdub)
       real(kind=8), intent(inout) :: valbgc(nvar,mi2tot,mj2tot)
       real(kind=8), intent(inout) :: auxbgc(naux,mi2tot,mj2tot)

c      # Local variables
       integer :: j,jfine,i,ifine,jco,ico,nwet
       real(kind=8) :: capac,bc,etasum,hsum,husum,hvsum,capa
       real(kind=8) :: hf,huf,hvf,bf,etaf,etaav,hav,hc,huc,hvc

c :::::::::::::::::::::::: COARSEN ::::::::::::::::::::::::::::::::
c coarsen = coarsen the fine grid data (with double the usual
c           number of ghost cells to prepare coarsened
c           grid for error estimation.
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
       do j = 1, mj2tot

         jfine = 2*(j-1) + 1

         do i = 1, mi2tot
           ifine = 2*(i-1) + 1

c          # Getting coarse capacity function and bathymetry
           if (mcapa .eq. 0) then
               capac=1.0d0
           else
               capac=auxbgc(2,i,j)
           endif

           bc = auxbgc(1,i,j)

c          # Calculating which values to use for coarsen
           etasum = 0.d0
           hsum = 0.d0
           husum = 0.d0
           hvsum = 0.d0

           nwet=0

           do jco = 1, 2
            do ico = 1, 2
               if (mcapa .eq. 0) then
                   capa=1.0d0
               else
                   capa=auxdub(2,ifine+ico-1,jfine+jco-1)
               endif

               hf =valdub(1,ifine+ico-1,jfine+jco-1)*capa
               huf=valdub(2,ifine+ico-1,jfine+jco-1)*capa
               hvf=valdub(3,ifine+ico-1,jfine+jco-1)*capa

               bf =auxdub(1,ifine+ico-1,jfine+jco-1)*capa

               if (hf > dry_tolerance) then
                   etaf = hf+bf
                   nwet=nwet+1
               else
                   etaf = 0.d0
                   huf=0.d0
                   hvf=0.d0
                   bf = 0.d0
               endif

               hsum   = hsum + hf
               husum  = husum + huf
               hvsum  = hvsum + hvf
               etasum = etasum + etaf
             enddo
           enddo

c          # Getting coarse averages
           if (nwet.gt.0) then
               etaav=etasum/dble(nwet)
               hav= hsum/dble(nwet)

c              hc=max(etaav-bc*capac,0.d0) !tsunamiclaw method
               hc=min(hav,(max(etaav-bc*capac,0.d0)))
               if (hsum.ne.0) then
                   huc=(min(hav,hc)/hsum)*husum
                   hvc=(min(hav,hc)/hsum)*hvsum
               else
                   huc= 0.d0
                   hvc= 0.d0
               endif
           else
               hc=0.d0
               huc=0.d0
               hvc=0.d0
           endif

c          # set h on coarse grid based on surface, not conservative near shoreline
           valbgc(1,i,j) = hc / capac
           valbgc(2,i,j) = huc / capac
           valbgc(3,i,j) = hvc / capac

         enddo
       enddo

       return
       end


! program to average sounding file.
! to use :  a.out < snd > snd_avg
character(80) header
real, dimension(100) :: z,p,t,q,u,v
read(*,'(a80)') header
p0=0.
z=0.
p=0.
t=0.
q=0.
u=0.
v=0.
m=0
do
  read(*,fmt=*,end=111) day,n,p01
  p0=p0+p01
  do k=1,n
   read*,z1,p1,t1,q1,u1,v1
   z(k) = z(k) + z1
   p(k) = p(k) + p1
   t(k) = t(k) + t1
   q(k) = q(k) + q1
   u(k) = u(k) + u1
   v(k) = v(k) + v1
  end do
  m=m+1
end do
111 continue
z=z/m
p=p/m
t=t/m
q=q/m
u=u/m
v=v/m
p0=p0/m
print*, header
write(*,'(f6.0,i5,f10.3)') 0.,n,p0
write(*,'(6f10.4)') (z(k),p(k),t(k),q(k),u(k),v(k),k=1,n)
write(*,'(f6.0,i5,f10.3)') 1000.,n,p0
write(*,'(6f10.4)') (z(k),p(k),t(k),q(k),u(k),v(k),k=1,n)

end


Function fnstru(x)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save
  fnstru = (1.0-x)**hipr1(44)/(x**2+hipr1(45)**2/hint1(1)**2)**hipr1(46)
  Return
End Function fnstru


!> \file phsolvers.f90
!! \BRIEF
!> Module with routines needed to solve pH-total alkalinity equation (Munhoven, 2013, GMD)
MODULE mphsolvers
!   Module of fastest solvers from Munhoven (2013, Geosci. Model Dev., 6, 1367-1388)
!   ! Taken from SolveSAPHE (mod_phsolvers.F90) & adapted very slightly for use with mocsy
!   ! SolveSaphe is distributed under the GNU Lesser General Public License
!   ! mocsy is distributed under the MIT License
!
! Modifications J. C. Orr, LSCE/IPSL, CEA-CNRS-UVSQ, France, 11 Sep 2014:
! 1) kept only the 3 fastest solvers (atgen, atsec, atfast) and routines which they call
! 2) reduced vertical white space: deleted many blank lines & comment lines that served as divisions
! 3) converted name from .F90 to .f90, deleting a few optional preprocesse if statements
! 4) read in mocsy computed equilibrium constants (as arguments) instead of USE MOD_CHEMCONST
! 5) converted routine names from upper case to lower case
! 6) commented out arguments and equations for NH4 and H2S acid systems

USE msingledouble
USE Dual_Num_Auto_Diff
IMPLICIT NONE

! General parameters
REAL(KIND=wp), PARAMETER :: pp_rdel_ah_target = 1.E-8_wp
REAL(KIND=wp), PARAMETER :: pp_ln10 = 2.302585092994045684018_wp

! Maximum number of iterations for each method
INTEGER, PARAMETER :: jp_maxniter_atgen    = 50
INTEGER, PARAMETER :: jp_maxniter_atsec    = 50
INTEGER, PARAMETER :: jp_maxniter_atfast   = 50

! Bookkeeping variables for each method
! - SOLVE_AT_GENERAL and SOLVE_AT_GENERAL_DNAD
INTEGER :: niter_atgen    = jp_maxniter_atgen

! - SOLVE_AT_GENERAL_SEC
INTEGER :: niter_atsec    = jp_maxniter_atsec

! - SOLVE_AT_FAST (variant of SOLVE_AT_GENERAL w/o bracketing
INTEGER :: niter_atfast   = jp_maxniter_atfast

! Keep the following functions private to avoid conflicts with
! other modules that provide similar ones.
!PRIVATE AHINI_FOR_AT

CONTAINS
!===============================================================================
SUBROUTINE anw_infsup(p_dictot, p_bortot,                                     &
                      p_po4tot, p_siltot,                                     &
                      p_so4tot, p_flutot,                                     &
                      p_alknw_inf, p_alknw_sup)

! Subroutine returns the lower and upper bounds of "non-water-selfionization"
! contributions to total alkalinity (the infimum and the supremum), i.e
! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+])

USE msingledouble
IMPLICIT NONE

! Argument variables
REAL(KIND=wp), INTENT(IN)  :: p_dictot
REAL(KIND=wp), INTENT(IN)  :: p_bortot
REAL(KIND=wp), INTENT(IN)  :: p_po4tot
REAL(KIND=wp), INTENT(IN)  :: p_siltot
!REAL(KIND=wp), INTENT(IN)  :: p_nh4tot
!REAL(KIND=wp), INTENT(IN)  :: p_h2stot
REAL(KIND=wp), INTENT(IN)  :: p_so4tot
REAL(KIND=wp), INTENT(IN)  :: p_flutot
REAL(KIND=wp), INTENT(OUT) :: p_alknw_inf
REAL(KIND=wp), INTENT(OUT) :: p_alknw_sup

p_alknw_inf =  -p_po4tot - p_so4tot - p_flutot
p_alknw_sup =   p_dictot + p_dictot + p_bortot &
              + p_po4tot + p_po4tot + p_siltot !&
!             + p_nh4tot + p_h2stot

RETURN
END SUBROUTINE anw_infsup

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

FUNCTION equation_at(p_alktot, p_h,       p_dictot, p_bortot,                 &
                     p_po4tot, p_siltot,                                      &
                     p_so4tot, p_flutot,                                      &
                     K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,          &
                     p_deriveqn)

  ! Purpose: Compute total alkalinity from ion concentrations and equilibrium constants

USE msingledouble
IMPLICIT NONE
REAL(KIND=wp) :: equation_at

! Argument variables
REAL(KIND=wp), INTENT(IN)            :: p_alktot
REAL(KIND=wp), INTENT(IN)            :: p_h
REAL(KIND=wp), INTENT(IN)            :: p_dictot
REAL(KIND=wp), INTENT(IN)            :: p_bortot
REAL(KIND=wp), INTENT(IN)            :: p_po4tot
REAL(KIND=wp), INTENT(IN)            :: p_siltot
!REAL(KIND=wp), INTENT(IN)            :: p_nh4tot
!REAL(KIND=wp), INTENT(IN)            :: p_h2stot
REAL(KIND=wp), INTENT(IN)            :: p_so4tot
REAL(KIND=wp), INTENT(IN)            :: p_flutot
REAL(KIND=wp), INTENT(IN)            :: K0, K1, K2, Kb, Kw, Ks, Kf
REAL(KIND=wp), INTENT(IN)            :: K1p, K2p, K3p, Ksi
REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_deriveqn

! Local variables
!-----------------
REAL(KIND=wp) :: znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic
REAL(KIND=wp) :: znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor
REAL(KIND=wp) :: znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4
REAL(KIND=wp) :: znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil
REAL(KIND=wp) :: znumer_nh4, zdnumer_nh4, zdenom_nh4, zalk_nh4, zdalk_nh4
REAL(KIND=wp) :: znumer_h2s, zdnumer_h2s, zdenom_h2s, zalk_h2s, zdalk_h2s
REAL(KIND=wp) :: znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4
REAL(KIND=wp) :: znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu
REAL(KIND=wp) ::                                      zalk_wat, zdalk_wat
REAL(KIND=wp) :: aphscale

! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
aphscale = 1._wp + p_so4tot/Ks

! H2CO3 - HCO3 - CO3 : n=2, m=0
znumer_dic = 2._wp*K1*K2 + p_h*       K1
zdenom_dic =       K1*K2 + p_h*(      K1 + p_h)
zalk_dic   = p_dictot * (znumer_dic/zdenom_dic)

! B(OH)3 - B(OH)4 : n=1, m=0
znumer_bor =       Kb
zdenom_bor =       Kb + p_h
zalk_bor   = p_bortot * (znumer_bor/zdenom_bor)

! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1
znumer_po4 = 3._wp*K1p*K2p*K3p + p_h*(2._wp*K1p*K2p + p_h* K1p)
zdenom_po4 =       K1p*K2p*K3p + p_h*(      K1p*K2p + p_h*(K1p + p_h))
zalk_po4   = p_po4tot * (znumer_po4/zdenom_po4 - 1._wp) ! Zero level of H3PO4 = 1

! H4SiO4 - H3SiO4 : n=1, m=0
znumer_sil =       Ksi
zdenom_sil =       Ksi + p_h
zalk_sil   = p_siltot * (znumer_sil/zdenom_sil)

! NH4 - NH3 : n=1, m=0
!znumer_nh4 =       api1_nh4
!zdenom_nh4 =       api1_nh4 + p_h
!zalk_nh4   = p_nh4tot * (znumer_nh4/zdenom_nh4)
! Note: api1_nh4 = Knh4

! H2S - HS : n=1, m=0
!znumer_h2s =       api1_h2s
!zdenom_h2s =       api1_h2s + p_h
!zalk_h2s   = p_h2stot * (znumer_h2s/zdenom_h2s)
! Note: api1_h2s = Kh2s

! HSO4 - SO4 : n=1, m=1
znumer_so4 =       Ks
zdenom_so4 =       Ks + p_h
zalk_so4   = p_so4tot * (znumer_so4/zdenom_so4 - 1._wp)

! HF - F : n=1, m=1
znumer_flu =       Kf
zdenom_flu =       Kf + p_h
zalk_flu   = p_flutot * (znumer_flu/zdenom_flu - 1._wp)

! H2O - OH
zalk_wat   = Kw/p_h - p_h/aphscale

equation_at =    zalk_dic + zalk_bor + zalk_po4 + zalk_sil &
               + zalk_so4 + zalk_flu                       &
               + zalk_wat - p_alktot

IF(PRESENT(p_deriveqn)) THEN
   ! H2CO3 - HCO3 - CO3 : n=2
   zdnumer_dic = K1*K1*K2 + p_h*(4._wp*K1*K2               &
                          + p_h*       K1    )
   zdalk_dic   = -p_dictot*(zdnumer_dic/zdenom_dic**2)

   ! B(OH)3 - B(OH)4 : n=1
   zdnumer_bor = Kb
   zdalk_bor   = -p_bortot*(zdnumer_bor/zdenom_bor**2)

   ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3
   zdnumer_po4 = K1p*K2p*K1p*K2p*K3p + p_h*(4._wp*K1p*K1p*K2p*K3p                &
                                     + p_h*(9._wp*K1p*K2p*K3p + K1p*K1p*K2p      &
                                     + p_h*(4._wp*K1p*K2p                        &
                                     + p_h*       K1p)))
   zdalk_po4   = -p_po4tot * (zdnumer_po4/zdenom_po4**2)

   ! H4SiO4 - H3SiO4 : n=1
   zdnumer_sil = Ksi
   zdalk_sil   = -p_siltot * (zdnumer_sil/zdenom_sil**2)

!  ! NH4 - NH3 : n=1
!  zdnumer_nh4 = Knh4
!  zdalk_nh4   = -p_nh4tot * (zdnumer_nh4/zdenom_nh4**2)

!  ! H2S - HS : n=1
!  zdnumer_h2s = api1_h2s
!  zdalk_h2s   = -p_h2stot * (zdnumer_h2s/zdenom_h2s**2)

   ! HSO4 - SO4 : n=1
   zdnumer_so4 = Ks
   zdalk_so4   = -p_so4tot * (zdnumer_so4/zdenom_so4**2)

   ! HF - F : n=1
   zdnumer_flu = Kf
   zdalk_flu   = -p_flutot * (zdnumer_flu/zdenom_flu**2)

!  p_deriveqn =   zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil &
!               + zdalk_nh4 + zdalk_h2s + zdalk_so4 + zdalk_flu &
!               - Kw/p_h**2 - 1._wp/aphscale
   p_deriveqn =   zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil &
                                        + zdalk_so4 + zdalk_flu &
                - Kw/p_h**2 - 1._wp/aphscale
ENDIF
RETURN
END FUNCTION equation_at

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

FUNCTION equation_at_DNAD(p_alktot, p_h,       p_dictot, p_bortot,                 &
                     p_po4tot, p_siltot,                                      &
                     p_so4tot, p_flutot,                                      &
                     K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,          &
                     p_deriveqn)
  ! Purpose: Compute total alkalinity from ion concentrations and equilibrium constants
  ! and compute its partial derivatives using dual numbers (DNAD) technique

  ! It is similar to subroutine equation_at above except that it computes
  ! partial derivatives of total alkalinity
  ! with respect to four input variables : ta, tc pt and sit

USE msingledouble
IMPLICIT NONE
TYPE(DUAL_NUM) ::equation_at_DNAD

! Argument variables
TYPE(DUAL_NUM), INTENT(IN)            :: p_alktot
TYPE(DUAL_NUM), INTENT(IN)            :: p_h
TYPE(DUAL_NUM), INTENT(IN)            :: p_dictot
TYPE(DUAL_NUM), INTENT(IN)            :: p_bortot
TYPE(DUAL_NUM), INTENT(IN)            :: p_po4tot
TYPE(DUAL_NUM), INTENT(IN)            :: p_siltot
!TYPE(DUAL_NUM), INTENT(IN)            :: p_nh4tot
!TYPE(DUAL_NUM), INTENT(IN)            :: p_h2stot
TYPE(DUAL_NUM), INTENT(IN)            :: p_so4tot
TYPE(DUAL_NUM), INTENT(IN)            :: p_flutot
TYPE(DUAL_NUM), INTENT(IN)            :: K0, K1, K2, Kb, Kw, Ks, Kf
TYPE(DUAL_NUM), INTENT(IN)            :: K1p, K2p, K3p, Ksi
TYPE(DUAL_NUM), INTENT(OUT), OPTIONAL :: p_deriveqn

! Local variables
!-----------------
TYPE(DUAL_NUM) ::znumer_dic, zdnumer_dic, zdenom_dic, zalk_dic, zdalk_dic
TYPE(DUAL_NUM) ::znumer_bor, zdnumer_bor, zdenom_bor, zalk_bor, zdalk_bor
TYPE(DUAL_NUM) ::znumer_po4, zdnumer_po4, zdenom_po4, zalk_po4, zdalk_po4
TYPE(DUAL_NUM) ::znumer_sil, zdnumer_sil, zdenom_sil, zalk_sil, zdalk_sil
TYPE(DUAL_NUM) ::znumer_nh4, zdnumer_nh4, zdenom_nh4, zalk_nh4, zdalk_nh4
TYPE(DUAL_NUM) ::znumer_h2s, zdnumer_h2s, zdenom_h2s, zalk_h2s, zdalk_h2s
TYPE(DUAL_NUM) ::znumer_so4, zdnumer_so4, zdenom_so4, zalk_so4, zdalk_so4
TYPE(DUAL_NUM) ::znumer_flu, zdnumer_flu, zdenom_flu, zalk_flu, zdalk_flu
TYPE(DUAL_NUM) ::                                     zalk_wat, zdalk_wat
TYPE(DUAL_NUM) ::aphscale

! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
aphscale = 1._wp + p_so4tot/Ks

! H2CO3 - HCO3 - CO3 : n=2, m=0
znumer_dic = 2._wp*K1*K2 + p_h*       K1
zdenom_dic =       K1*K2 + p_h*(      K1 + p_h)
zalk_dic   = p_dictot * (znumer_dic/zdenom_dic)

! B(OH)3 - B(OH)4 : n=1, m=0
znumer_bor =       Kb
zdenom_bor =       Kb + p_h
zalk_bor   = p_bortot * (znumer_bor/zdenom_bor)

! H3PO4 - H2PO4 - HPO4 - PO4 : n=3, m=1
znumer_po4 = 3._wp*K1p*K2p*K3p + p_h*(2._wp*K1p*K2p + p_h* K1p)
zdenom_po4 =       K1p*K2p*K3p + p_h*(      K1p*K2p + p_h*(K1p + p_h))
zalk_po4   = p_po4tot * (znumer_po4/zdenom_po4 - 1._wp) ! Zero level of H3PO4 = 1

! H4SiO4 - H3SiO4 : n=1, m=0
znumer_sil =       Ksi
zdenom_sil =       Ksi + p_h
zalk_sil   = p_siltot * (znumer_sil/zdenom_sil)

! NH4 - NH3 : n=1, m=0
!znumer_nh4 =       api1_nh4
!zdenom_nh4 =       api1_nh4 + p_h
!zalk_nh4   = p_nh4tot * (znumer_nh4/zdenom_nh4)
! Note: api1_nh4 = Knh4

! H2S - HS : n=1, m=0
!znumer_h2s =       api1_h2s
!zdenom_h2s =       api1_h2s + p_h
!zalk_h2s   = p_h2stot * (znumer_h2s/zdenom_h2s)
! Note: api1_h2s = Kh2s

! HSO4 - SO4 : n=1, m=1
znumer_so4 =       Ks
zdenom_so4 =       Ks + p_h
zalk_so4   = p_so4tot * (znumer_so4/zdenom_so4 - 1._wp)

! HF - F : n=1, m=1
znumer_flu =       Kf
zdenom_flu =       Kf + p_h
zalk_flu   = p_flutot * (znumer_flu/zdenom_flu - 1._wp)

! H2O - OH
zalk_wat   = Kw/p_h - p_h/aphscale

equation_at_DNAD =  zalk_dic + zalk_bor + zalk_po4 + zalk_sil &
                  + zalk_so4 + zalk_flu                       &
                  + zalk_wat - p_alktot

IF(PRESENT(p_deriveqn)) THEN
   ! H2CO3 - HCO3 - CO3 : n=2
   zdnumer_dic = K1*K1*K2 + p_h*(4._wp*K1*K2               &
                          + p_h*       K1    )
   zdalk_dic   = -p_dictot*(zdnumer_dic/zdenom_dic**2)

   ! B(OH)3 - B(OH)4 : n=1
   zdnumer_bor = Kb
   zdalk_bor   = -p_bortot*(zdnumer_bor/zdenom_bor**2)

   ! H3PO4 - H2PO4 - HPO4 - PO4 : n=3
   zdnumer_po4 = K1p*K2p*K1p*K2p*K3p + p_h*(4._wp*K1p*K1p*K2p*K3p                &
                                     + p_h*(9._wp*K1p*K2p*K3p + K1p*K1p*K2p      &
                                     + p_h*(4._wp*K1p*K2p                        &
                                     + p_h*       K1p)))
   zdalk_po4   = -p_po4tot * (zdnumer_po4/zdenom_po4**2)

   ! H4SiO4 - H3SiO4 : n=1
   zdnumer_sil = Ksi
   zdalk_sil   = -p_siltot * (zdnumer_sil/zdenom_sil**2)

!  ! NH4 - NH3 : n=1
!  zdnumer_nh4 = Knh4
!  zdalk_nh4   = -p_nh4tot * (zdnumer_nh4/zdenom_nh4**2)

!  ! H2S - HS : n=1
!  zdnumer_h2s = api1_h2s
!  zdalk_h2s   = -p_h2stot * (zdnumer_h2s/zdenom_h2s**2)

   ! HSO4 - SO4 : n=1
   zdnumer_so4 = Ks
   zdalk_so4   = -p_so4tot * (zdnumer_so4/zdenom_so4**2)

   ! HF - F : n=1
   zdnumer_flu = Kf
   zdalk_flu   = -p_flutot * (zdnumer_flu/zdenom_flu**2)

!  p_deriveqn =   zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil &
!               + zdalk_nh4 + zdalk_h2s + zdalk_so4 + zdalk_flu &
!               - Kw/p_h**2 - 1._wp/aphscale
   p_deriveqn =   zdalk_dic + zdalk_bor + zdalk_po4 + zdalk_sil &
                                        + zdalk_so4 + zdalk_flu &
                - Kw/p_h**2 - 1._wp/aphscale
ENDIF
RETURN
END FUNCTION equation_at_DNAD

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

SUBROUTINE ahini_for_at(p_alkcb, p_dictot, p_bortot, K1, K2, Kb, p_hini)

! Subroutine returns the root for the 2nd order approximation of the
! DIC -- B_T -- A_CB equation for [H+] (reformulated as a cubic polynomial)
! around the local minimum, if it exists.

! Returns * 1E-03_wp if p_alkcb <= 0
!         * 1E-10_wp if p_alkcb >= 2*p_dictot + p_bortot
!         * 1E-07_wp if 0 < p_alkcb < 2*p_dictot + p_bortot
!                    and the 2nd order approximation does not have a solution

!USE MOD_CHEMCONST, ONLY : api1_dic, api2_dic, api1_bor

USE msingledouble
IMPLICIT NONE

! Argument variables
!--------------------
REAL(KIND=wp), INTENT(IN)   ::  p_alkcb, p_dictot, p_bortot
REAL(KIND=wp), INTENT(IN)   ::  K1, K2, Kb
REAL(KIND=wp), INTENT(OUT)  ::  p_hini

! Local variables
!-----------------
REAL(KIND=wp)  ::  zca, zba
REAL(KIND=wp)  ::  zd, zsqrtd, zhmin
REAL(KIND=wp)  ::  za2, za1, za0

IF (p_alkcb <= 0._wp) THEN
  p_hini = 1.e-3_wp
ELSEIF (p_alkcb >= (2._wp*p_dictot + p_bortot)) THEN
  p_hini = 1.e-10_wp
ELSE
  zca = p_dictot/p_alkcb
  zba = p_bortot/p_alkcb

  ! Coefficients of the cubic polynomial
  za2 = Kb*(1._wp - zba) + K1*(1._wp-zca)
  za1 = K1*Kb*(1._wp - zba - zca) + K1*K2*(1._wp - (zca+zca))
  za0 = K1*K2*Kb*(1._wp - zba - (zca+zca))
                                        ! Taylor expansion around the minimum
  zd = za2*za2 - 3._wp*za1              ! Discriminant of the quadratic equation
                                        ! for the minimum close to the root

  IF(zd > 0._wp) THEN                   ! If the discriminant is positive
    zsqrtd = SQRT(zd)
    IF(za2 < 0) THEN
      zhmin = (-za2 + zsqrtd)/3._wp
    ELSE
      zhmin = -za1/(za2 + zsqrtd)
    ENDIF
    p_hini = zhmin + SQRT(-(za0 + zhmin*(za1 + zhmin*(za2 + zhmin)))/zsqrtd)
  ELSE
    p_hini = 1.e-7_wp
  ENDIF

ENDIF
RETURN
END SUBROUTINE ahini_for_at

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

FUNCTION solve_at_general(p_alktot, p_dictot, p_bortot,                       &
                          p_po4tot, p_siltot,                                 &
                          p_so4tot, p_flutot,                                 &
                          K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,     &
                          p_hini,   p_val)

! Purpose: Compute [H°] ion concentration from sea-water ion concentrations,
!          alkalinity, DIC, and equilibrium constants
! Universal pH solver that converges from any given initial value,
! determines upper an lower bounds for the solution if required

USE msingledouble
IMPLICIT NONE
REAL(KIND=wp) :: SOLVE_AT_GENERAL

! Argument variables
!--------------------
REAL(KIND=wp), INTENT(IN)            :: p_alktot
REAL(KIND=wp), INTENT(IN)            :: p_dictot
REAL(KIND=wp), INTENT(IN)            :: p_bortot
REAL(KIND=wp), INTENT(IN)            :: p_po4tot
REAL(KIND=wp), INTENT(IN)            :: p_siltot
!REAL(KIND=wp), INTENT(IN)            :: p_nh4tot
!REAL(KIND=wp), INTENT(IN)            :: p_h2stot
REAL(KIND=wp), INTENT(IN)            :: p_so4tot
REAL(KIND=wp), INTENT(IN)            :: p_flutot
REAL(KIND=wp), INTENT(IN)            :: K0, K1, K2, Kb, Kw, Ks, Kf
REAL(KIND=wp), INTENT(IN)            :: K1p, K2p, K3p, Ksi
REAL(KIND=wp), INTENT(IN), OPTIONAL  :: p_hini
REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_val

! Local variables
!-----------------
REAL(KIND=wp)  ::  zh_ini, zh, zh_prev, zh_lnfactor
REAL(KIND=wp)  ::  zalknw_inf, zalknw_sup
REAL(KIND=wp)  ::  zh_min, zh_max
REAL(KIND=wp)  ::  zdelta, zh_delta
REAL(KIND=wp)  ::  zeqn, zdeqndh, zeqn_absmin
REAL(KIND=wp)  ::  aphscale
LOGICAL        :: l_exitnow
REAL(KIND=wp), PARAMETER :: pz_exp_threshold = 1.0_wp

! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
aphscale = 1._wp + p_so4tot/Ks

IF(PRESENT(p_hini)) THEN
   zh_ini = p_hini
ELSE
   CALL ahini_for_at(p_alktot, p_dictot, p_bortot, K1, K2, Kb, zh_ini)
ENDIF

 CALL anw_infsup(p_dictot, p_bortot,                                           &
                 p_po4tot, p_siltot,                                           &
                 p_so4tot, p_flutot,                                           &
                 zalknw_inf, zalknw_sup)

zdelta = (p_alktot-zalknw_inf)**2 + 4._wp*Kw/aphscale

IF(p_alktot >= zalknw_inf) THEN
   zh_min = 2._wp*Kw /( p_alktot-zalknw_inf + SQRT(zdelta) )
ELSE
   zh_min = aphscale*(-(p_alktot-zalknw_inf) + SQRT(zdelta) ) / 2._wp
ENDIF

zdelta = (p_alktot-zalknw_sup)**2 + 4._wp*Kw/aphscale

IF(p_alktot <= zalknw_sup) THEN
   zh_max = aphscale*(-(p_alktot-zalknw_sup) + SQRT(zdelta) ) / 2._wp
ELSE
   zh_max = 2._wp*Kw /( p_alktot-zalknw_sup + SQRT(zdelta) )
ENDIF

zh = MAX(MIN(zh_max, zh_ini), zh_min)
niter_atgen        = 0                 ! Reset counters of iterations
zeqn_absmin        = HUGE(1._wp)

DO
   IF(niter_atgen >= jp_maxniter_atgen) THEN
      zh = -1._wp
      EXIT
   ENDIF

   zh_prev = zh
   zeqn = equation_at(p_alktot, zh,       p_dictot, p_bortot,                  &
                      p_po4tot, p_siltot,                                      &
                      p_so4tot, p_flutot,                                      &
                      K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,          &
                      P_DERIVEQN = zdeqndh)

   ! Adapt bracketing interval
   IF(zeqn > 0._wp) THEN
      zh_min = zh_prev
   ELSEIF(zeqn < 0._wp) THEN
      zh_max = zh_prev
   ELSE
      ! zh is the root; unlikely but, one never knows
      EXIT
   ENDIF

   ! Now determine the next iterate zh
   niter_atgen = niter_atgen + 1

   IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin) THEN
      ! if the function evaluation at the current point is
      ! not decreasing faster than with a bisection step (at least linearly)
      ! in absolute value take one bisection step on [ph_min, ph_max]
      ! ph_new = (ph_min + ph_max)/2d0
      !
      ! In terms of [H]_new:
      ! [H]_new = 10**(-ph_new)
      !         = 10**(-(ph_min + ph_max)/2d0)
      !         = SQRT(10**(-(ph_min + phmax)))
      !         = SQRT(zh_max * zh_min)
      zh = SQRT(zh_max * zh_min)
      zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below
   ELSE
      ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH
      !           = -zdeqndh * LOG(10) * [H]
      ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10))
      !
      ! pH_new = pH_old + \deltapH
      !
      ! [H]_new = 10**(-pH_new)
      !         = 10**(-pH_old - \Delta pH)
      !         = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10)))
      !         = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10)))
      !         = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old))

      zh_lnfactor = -zeqn/(zdeqndh*zh_prev)

      IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN
         zh          = zh_prev*EXP(zh_lnfactor)
      ELSE
         zh_delta    = zh_lnfactor*zh_prev
         zh          = zh_prev + zh_delta
      ENDIF

      IF( zh < zh_min ) THEN
         ! if [H]_new < [H]_min
         ! i.e., if ph_new > ph_max then
         ! take one bisection step on [ph_prev, ph_max]
         ! ph_new = (ph_prev + ph_max)/2d0
         ! In terms of [H]_new:
         ! [H]_new = 10**(-ph_new)
         !         = 10**(-(ph_prev + ph_max)/2d0)
         !         = SQRT(10**(-(ph_prev + phmax)))
         !         = SQRT([H]_old*10**(-ph_max))
         !         = SQRT([H]_old * zh_min)
         zh                = SQRT(zh_prev * zh_min)
         zh_lnfactor       = (zh - zh_prev)/zh_prev ! Required to test convergence below
      ENDIF

      IF( zh > zh_max ) THEN
         ! if [H]_new > [H]_max
         ! i.e., if ph_new < ph_min, then
         ! take one bisection step on [ph_min, ph_prev]
         ! ph_new = (ph_prev + ph_min)/2d0
         ! In terms of [H]_new:
         ! [H]_new = 10**(-ph_new)
         !         = 10**(-(ph_prev + ph_min)/2d0)
         !         = SQRT(10**(-(ph_prev + ph_min)))
         !         = SQRT([H]_old*10**(-ph_min))
         !         = SQRT([H]_old * zhmax)
         zh                = SQRT(zh_prev * zh_max)
         zh_lnfactor       = (zh - zh_prev)/zh_prev ! Required to test convergence below
      ENDIF
   ENDIF

   zeqn_absmin = MIN( ABS(zeqn), zeqn_absmin)

   ! Stop iterations once |\delta{[H]}/[H]| < rdel
   ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel
   ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)|

   ! Alternatively:
   ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))|
   !             ~ 1/LOG(10) * |\Delta [H]|/[H]
   !             < 1/LOG(10) * rdel

   ! Hence |zeqn/(zdeqndh*zh)| < rdel

   ! rdel <-- pp_rdel_ah_target

   l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target)

   IF(l_exitnow) EXIT
ENDDO

solve_at_general = zh

IF(PRESENT(p_val)) THEN
   IF(zh > 0._wp) THEN
      p_val = equation_at(p_alktot, zh,       p_dictot, p_bortot,              &
                          p_po4tot, p_siltot,                                  &
                          p_so4tot, p_flutot,                                  &
                          K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
   ELSE
      p_val = HUGE(1._wp)
   ENDIF
ENDIF
RETURN
END FUNCTION solve_at_general

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

FUNCTION solve_at_general_DNAD (p_alktot, p_dictot, p_bortot,                 &
                          p_po4tot, p_siltot,                                 &
                          p_so4tot, p_flutot,                                 &
                          K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,     &
                          p_hini,   p_val)

! Purpose: Compute [H+] ion concentration from sea-water ion concentrations,
! alkalinity, DIC, and equilibrium constants
! It also computes partial derivatives of [H+] using dual numbers (DNAD) technique

! Universal pH solver that converges from any given initial value,
! determines upper an lower bounds for the solution if required

! It is similar to subroutine solve_at_general above except that it computes
! partial derivatives of [H°] ion concentration
! with respect to four input variables : ta, tc pt and sit

! NOTE : all input and output parameters are of type DUAL_NUM (dual number)
!        where they are of type REAL in standard version of this subroutine.
!        But only four input parameters are required to be passed as such :
!         p_alktot, p_dictot, p_po4tot and p_siltot

USE msingledouble
IMPLICIT NONE
! value and partial derivatives of [H+] are returned in one objet of type DUAL_NUM
TYPE(DUAL_NUM) ::SOLVE_AT_GENERAL_DNAD

! Argument variables
!--------------------
TYPE(DUAL_NUM), INTENT(IN)            :: p_alktot
TYPE(DUAL_NUM), INTENT(IN)            :: p_dictot
TYPE(DUAL_NUM), INTENT(IN)            :: p_bortot
TYPE(DUAL_NUM), INTENT(IN)            :: p_po4tot
TYPE(DUAL_NUM), INTENT(IN)            :: p_siltot
!TYPE(DUAL_NUM), INTENT(IN)            :: p_nh4tot
!TYPE(DUAL_NUM), INTENT(IN)            :: p_h2stot
TYPE(DUAL_NUM), INTENT(IN)            :: p_so4tot
TYPE(DUAL_NUM), INTENT(IN)            :: p_flutot
TYPE(DUAL_NUM), INTENT(IN)            :: K0, K1, K2, Kb, Kw, Ks, Kf
TYPE(DUAL_NUM), INTENT(IN)            :: K1p, K2p, K3p, Ksi
TYPE(DUAL_NUM), INTENT(IN), OPTIONAL  :: p_hini
TYPE(DUAL_NUM), INTENT(OUT), OPTIONAL :: p_val

! Local variables
!-----------------
REAL(KIND=wp)  ::  zh_ini
TYPE(DUAL_NUM) ::  zh, zh_prev, zh_lnfactor
REAL(KIND=wp)  ::  zalknw_inf, zalknw_sup
TYPE(DUAL_NUM) ::  zh_min, zh_max
TYPE(DUAL_NUM) ::  zdelta, zh_delta
TYPE(DUAL_NUM) ::  zeqn, zdeqndh, zeqn_absmin
TYPE(DUAL_NUM) ::  aphscale
LOGICAL        :: l_exitnow
REAL(KIND=wp), PARAMETER :: pz_exp_threshold = 1.0_wp

! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
aphscale = 1._wp + p_so4tot/Ks

IF(PRESENT(p_hini)) THEN
   zh_ini = p_hini%x_ad_
ELSE
   CALL ahini_for_at(p_alktot%x_ad_, p_dictot%x_ad_, p_bortot%x_ad_, K1%x_ad_, K2%x_ad_, Kb%x_ad_, zh_ini)
ENDIF

 CALL anw_infsup(p_dictot%x_ad_, p_bortot%x_ad_,                               &
                 p_po4tot%x_ad_, p_siltot%x_ad_,                               &
                 p_so4tot%x_ad_, p_flutot%x_ad_,                               &
                 zalknw_inf, zalknw_sup)

zdelta = (p_alktot-zalknw_inf)**2 + 4._wp*Kw/aphscale

IF(p_alktot >= zalknw_inf) THEN
   zh_min = 2._wp*Kw /( p_alktot-zalknw_inf + SQRT(zdelta) )
ELSE
   zh_min = aphscale*(-(p_alktot-zalknw_inf) + SQRT(zdelta) ) / 2._wp
ENDIF

zdelta = (p_alktot-zalknw_sup)**2 + 4._wp*Kw/aphscale

IF(p_alktot <= zalknw_sup) THEN
   zh_max = aphscale*(-(p_alktot-zalknw_sup) + SQRT(zdelta) ) / 2._wp
ELSE
   zh_max = 2._wp*Kw /( p_alktot-zalknw_sup + SQRT(zdelta) )
ENDIF

zh = MAX(MIN(zh_max, zh_ini), zh_min)
niter_atgen        = 0                 ! Reset counters of iterations
zeqn_absmin        = HUGE(1._wp)

DO
   IF(niter_atgen >= jp_maxniter_atgen) THEN
      zh = -1._wp
      EXIT
   ENDIF

   zh_prev = zh
   zeqn = equation_at_DNAD(p_alktot, zh,       p_dictot, p_bortot,             &
                      p_po4tot, p_siltot,                                      &
                      p_so4tot, p_flutot,                                      &
                      K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,          &
                      P_DERIVEQN = zdeqndh)

   ! Adapt bracketing interval
   IF(zeqn > 0._wp) THEN
      zh_min = zh_prev
   ELSEIF(zeqn < 0._wp) THEN
      zh_max = zh_prev
   ELSE
      ! zh is the root; unlikely but, one never knows
      EXIT
   ENDIF

   ! Now determine the next iterate zh
   niter_atgen = niter_atgen + 1

   IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin) THEN
      ! if the function evaluation at the current point is
      ! not decreasing faster than with a bisection step (at least linearly)
      ! in absolute value take one bisection step on [ph_min, ph_max]
      ! ph_new = (ph_min + ph_max)/2d0
      !
      ! In terms of [H]_new:
      ! [H]_new = 10**(-ph_new)
      !         = 10**(-(ph_min + ph_max)/2d0)
      !         = SQRT(10**(-(ph_min + phmax)))
      !         = SQRT(zh_max * zh_min)
      zh = SQRT(zh_max * zh_min)
      zh_lnfactor = (zh - zh_prev)/zh_prev ! Required to test convergence below
   ELSE
      ! dzeqn/dpH = dzeqn/d[H] * d[H]/dpH
      !           = -zdeqndh * LOG(10) * [H]
      ! \Delta pH = -zeqn/(zdeqndh*d[H]/dpH) = zeqn/(zdeqndh*[H]*LOG(10))
      !
      ! pH_new = pH_old + \deltapH
      !
      ! [H]_new = 10**(-pH_new)
      !         = 10**(-pH_old - \Delta pH)
      !         = [H]_old * 10**(-zeqn/(zdeqndh*[H]_old*LOG(10)))
      !         = [H]_old * EXP(-LOG(10)*zeqn/(zdeqndh*[H]_old*LOG(10)))
      !         = [H]_old * EXP(-zeqn/(zdeqndh*[H]_old))

      zh_lnfactor = -zeqn/(zdeqndh*zh_prev)

      IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN
         zh          = zh_prev*EXP(zh_lnfactor)
      ELSE
         zh_delta    = zh_lnfactor*zh_prev
         zh          = zh_prev + zh_delta
      ENDIF

      IF( zh < zh_min ) THEN
         ! if [H]_new < [H]_min
         ! i.e., if ph_new > ph_max then
         ! take one bisection step on [ph_prev, ph_max]
         ! ph_new = (ph_prev + ph_max)/2d0
         ! In terms of [H]_new:
         ! [H]_new = 10**(-ph_new)
         !         = 10**(-(ph_prev + ph_max)/2d0)
         !         = SQRT(10**(-(ph_prev + phmax)))
         !         = SQRT([H]_old*10**(-ph_max))
         !         = SQRT([H]_old * zh_min)
         zh                = SQRT(zh_prev * zh_min)
         zh_lnfactor       = (zh - zh_prev)/zh_prev ! Required to test convergence below
      ENDIF

      IF( zh > zh_max ) THEN
         ! if [H]_new > [H]_max
         ! i.e., if ph_new < ph_min, then
         ! take one bisection step on [ph_min, ph_prev]
         ! ph_new = (ph_prev + ph_min)/2d0
         ! In terms of [H]_new:
         ! [H]_new = 10**(-ph_new)
         !         = 10**(-(ph_prev + ph_min)/2d0)
         !         = SQRT(10**(-(ph_prev + ph_min)))
         !         = SQRT([H]_old*10**(-ph_min))
         !         = SQRT([H]_old * zhmax)
         zh                = SQRT(zh_prev * zh_max)
         zh_lnfactor       = (zh - zh_prev)/zh_prev ! Required to test convergence below
      ENDIF
   ENDIF

   zeqn_absmin = MIN( ABS(zeqn), zeqn_absmin)

   ! Stop iterations once |\delta{[H]}/[H]| < rdel
   ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel
   ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)|

   ! Alternatively:
   ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))|
   !             ~ 1/LOG(10) * |\Delta [H]|/[H]
   !             < 1/LOG(10) * rdel

   ! Hence |zeqn/(zdeqndh*zh)| < rdel

   ! rdel <-- pp_rdel_ah_target

   l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target)

   IF(l_exitnow) EXIT
ENDDO

solve_at_general_DNAD = zh

IF(PRESENT(p_val)) THEN
   IF(zh > 0._wp) THEN
      p_val = equation_at_DNAD(p_alktot, zh,       p_dictot, p_bortot,         &
                          p_po4tot, p_siltot,                                  &
                          p_so4tot, p_flutot,                                  &
                          K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
   ELSE
      p_val = HUGE(1._wp)
   ENDIF
ENDIF
RETURN
END FUNCTION solve_at_general_DNAD

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

FUNCTION solve_at_general_sec(p_alktot, p_dictot, p_bortot,                   &
                              p_po4tot, p_siltot,                             &
                              p_so4tot, p_flutot,                             &
                              K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi, &
                              p_hini,   p_val)

! Universal pH solver that converges from any given initial value,
! determines upper an lower bounds for the solution if required

!USE MOD_CHEMCONST, ONLY: api1_wat, aphscale
USE msingledouble
IMPLICIT NONE
REAL(KIND=wp) :: SOLVE_AT_GENERAL_SEC

! Argument variables
REAL(KIND=wp), INTENT(IN)            :: p_alktot
REAL(KIND=wp), INTENT(IN)            :: p_dictot
REAL(KIND=wp), INTENT(IN)            :: p_bortot
REAL(KIND=wp), INTENT(IN)            :: p_po4tot
REAL(KIND=wp), INTENT(IN)            :: p_siltot
!REAL(KIND=wp), INTENT(IN)            :: p_nh4tot
!REAL(KIND=wp), INTENT(IN)            :: p_h2stot
REAL(KIND=wp), INTENT(IN)            :: p_so4tot
REAL(KIND=wp), INTENT(IN)            :: p_flutot
REAL(KIND=wp), INTENT(IN)            :: K0, K1, K2, Kb, Kw, Ks, Kf
REAL(KIND=wp), INTENT(IN)            :: K1p, K2p, K3p, Ksi
REAL(KIND=wp), INTENT(IN), OPTIONAL  :: p_hini
REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_val

! Local variables
REAL(KIND=wp)  ::  zh_ini, zh, zh_1, zh_2, zh_delta
REAL(KIND=wp)  ::  zalknw_inf, zalknw_sup
REAL(KIND=wp)  ::  zh_min, zh_max
REAL(KIND=wp)  ::  zeqn, zeqn_1, zeqn_2, zeqn_absmin
REAL(KIND=wp)  ::  zdelta
REAL(KIND=wp)  ::  aphscale
LOGICAL        ::  l_exitnow

! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
aphscale = 1._wp + p_so4tot/Ks

IF(PRESENT(p_hini)) THEN
   zh_ini = p_hini
ELSE
   CALL ahini_for_at(p_alktot, p_dictot, p_bortot, K1, K2, Kb, zh_ini)
ENDIF

 CALL anw_infsup(p_dictot, p_bortot,                                      &
                 p_po4tot, p_siltot,                                      &
                 p_so4tot, p_flutot,                                      &
                 zalknw_inf, zalknw_sup)

zdelta = (p_alktot-zalknw_inf)**2 + 4._wp*Kw/aphscale

IF(p_alktot >= zalknw_inf) THEN
   zh_min = 2._wp*Kw /( p_alktot-zalknw_inf + SQRT(zdelta) )
ELSE
   zh_min = aphscale*(-(p_alktot-zalknw_inf) + SQRT(zdelta) ) / 2._wp
ENDIF

zdelta = (p_alktot-zalknw_sup)**2 + 4._wp*Kw/aphscale

IF(p_alktot <= zalknw_sup) THEN
   zh_max = aphscale*(-(p_alktot-zalknw_sup) + SQRT(zdelta) ) / 2._wp
ELSE
   zh_max = 2._wp*Kw /( p_alktot-zalknw_sup + SQRT(zdelta) )
ENDIF

zh = MAX(MIN(zh_max, zh_ini), zh_min)
niter_atsec        = 0                 ! Reset counters of iterations

! Prepare the secant iterations: two initial (zh, zeqn) pairs are required
! We have the starting value, that needs to be completed by the evaluation
! of the equation value it produces.

! Complete the initial value with its equation evaluation
! (will take the role of the $n-2$ iterate at the first secant evaluation)

niter_atsec = 0                        ! zh_2 is the initial value;

zh_2   = zh
zeqn_2 = equation_at(p_alktot, zh_2,     p_dictot, p_bortot,                 &
                     p_po4tot, p_siltot,                                     &
                     p_so4tot, p_flutot,                                     &
                     K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)

zeqn_absmin        = ABS(zeqn_2)

! Adapt bracketing interval and heuristically set zh_1
IF(zeqn_2 < 0._wp) THEN
                                       ! If zeqn_2 < 0, then we adjust zh_max:
                                       ! we can be sure that zh_min < zh_2 < zh_max.
   zh_max = zh_2
                                       ! for zh_1, try 25% (0.1 pH units) below the current zh_max,
                                       ! but stay above SQRT(zh_min*zh_max), which would be equivalent
                                       ! to a bisection step on [pH@zh_min, pH@zh_max]
   zh_1   = MAX(zh_max/1.25_wp, SQRT(zh_min*zh_max))
ELSEIF(zeqn_2 > 0._wp) THEN
                                       ! If zeqn_2 < 0, then we adjust zh_min:
                                       ! we can be sure that zh_min < zh_2 < zh_max.
   zh_min = zh_2
                                       ! for zh_1, try 25% (0.1 pH units) above the current zh_min,
                                       ! but stay below SQRT(zh_min*zh_max) which would be equivalent
                                       ! to a bisection step on [pH@zh_min, pH@zh_max]
   zh_1   = MIN(zh_min*1.25_wp, SQRT(zh_min*zh_max))
ELSE ! we have got the root; unlikely, but one never knows
   solve_at_general_sec = zh_2
   IF(PRESENT(p_val)) p_val = zeqn_2
   RETURN
ENDIF

! We now have the first pair completed (zh_2, zeqn_2).
! Define the second one (zh_1, zeqn_1), which is also the first iterate.
! zh_1 has already been set above
niter_atsec = 1                        ! Update counter of iterations

zeqn_1 = equation_at(p_alktot, zh_1,       p_dictot, p_bortot,                 &
                     p_po4tot, p_siltot,                                       &
                     p_so4tot, p_flutot,                                       &
                     K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)

! Adapt bracketing interval: we know that zh_1 <= zh <= zh_max (if zeqn_1 > 0)
! or zh_min <= zh <= zh_1 (if zeqn_1 < 0), so this can always be done
IF(zeqn_1 > 0._wp) THEN
   zh_min = zh_1
ELSEIF(zeqn_1 < 0._wp) THEN
   zh_max = zh_1
ELSE ! zh_1 is the root
   solve_at_general_sec = zh_1
   IF(PRESENT(p_val)) p_val = zeqn_1
ENDIF

IF(ABS(zeqn_1) > zeqn_absmin) THEN     ! Swap zh_2 and zh_1 if ABS(zeqn_2) < ABS(zeqn_1)
                                       ! so that zh_2 and zh_1 lead to decreasing equation
                                       ! values (in absolute value)
   zh     = zh_1
   zeqn   = zeqn_1
   zh_1   = zh_2
   zeqn_1 = zeqn_2
   zh_2   = zh
   zeqn_2 = zeqn
ELSE
   zeqn_absmin = ABS(zeqn_1)
ENDIF

! Pre-calculate the first secant iterate (this is the second iterate)
niter_atsec = 2

zh_delta = -zeqn_1/((zeqn_2-zeqn_1)/(zh_2 - zh_1))
zh = zh_1 + zh_delta

! Make sure that zh_min < zh < zh_max (if not,
! bisect around zh_1 which is the best estimate)
IF (zh > zh_max) THEN                  ! this can only happen if zh_2 < zh_1
                                       ! and zeqn_2 > zeqn_1 > 0
   zh = SQRT(zh_1*zh_max)
ENDIF

IF (zh < zh_min) THEN                  ! this can only happen if zh_2 > zh_1
                                       ! and zeqn_2 < zeqn_1 < 0
   zh = SQRT(zh_1*zh_min)
ENDIF

DO
   IF(niter_atsec >= jp_maxniter_atsec) THEN
      zh = -1._wp
      EXIT
   ENDIF

   zeqn = equation_at(p_alktot, zh,       p_dictot, p_bortot,                  &
                      p_po4tot, p_siltot,                                      &
                      p_so4tot, p_flutot,                                      &
                      K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)

   ! Adapt bracketing interval: since initially, zh_min <= zh <= zh_max
   ! we are sure that zh will improve either bracket, depending on the sign
   ! of zeqn
   IF(zeqn > 0._wp) THEN
     zh_min = zh
   ELSEIF(zeqn < 0._wp) THEN
     zh_max = zh
   ELSE
     ! zh is the root
     EXIT
   ENDIF

   ! start calculation of next iterate
   niter_atsec = niter_atsec + 1

   zh_2   = zh_1
   zeqn_2 = zeqn_1
   zh_1   = zh
   zeqn_1 = zeqn

   IF(ABS(zeqn) >= 0.5_wp*zeqn_absmin) THEN
      ! if the function evaluation at the current point
      ! is not decreasing faster in absolute value than
      ! we may expect for a bisection step, then take
      ! one bisection step on [ph_min, ph_max]
      ! ph_new = (ph_min + ph_max)/2d0
      ! In terms of [H]_new:
      ! [H]_new = 10**(-ph_new)
      !         = 10**(-(ph_min + ph_max)/2d0)
      !         = SQRT(10**(-(ph_min + phmax)))
      !         = SQRT(zh_max * zh_min)
      zh                = SQRT(zh_max * zh_min)
      zh_delta           = zh - zh_1
   ELSE
      ! \Delta H = -zeqn_1*(h_2 - h_1)/(zeqn_2 - zeqn_1)
      ! H_new = H_1 + \Delta H
      zh_delta = -zeqn_1/((zeqn_2-zeqn_1)/(zh_2 - zh_1))
      zh       = zh_1 + zh_delta

      IF( zh < zh_min ) THEN
         ! if [H]_new < [H]_min
         ! i.e., if ph_new > ph_max then
         ! take one bisection step on [ph_prev, ph_max]
         ! ph_new = (ph_prev + ph_max)/2d0
         ! In terms of [H]_new:
         ! [H]_new = 10**(-ph_new)
         !         = 10**(-(ph_prev + ph_max)/2d0)
         !         = SQRT(10**(-(ph_prev + phmax)))
         !         = SQRT([H]_old*10**(-ph_max))
         !         = SQRT([H]_old * zh_min)
         zh                = SQRT(zh_1 * zh_min)
         zh_delta          = zh - zh_1
      ENDIF

      IF( zh > zh_max ) THEN
         ! if [H]_new > [H]_max
         ! i.e., if ph_new < ph_min, then
         ! take one bisection step on [ph_min, ph_prev]
         ! ph_new = (ph_prev + ph_min)/2d0
         ! In terms of [H]_new:
         ! [H]_new = 10**(-ph_new)
         !         = 10**(-(ph_prev + ph_min)/2d0)
         !         = SQRT(10**(-(ph_prev + ph_min)))
         !         = SQRT([H]_old*10**(-ph_min))
         !         = SQRT([H]_old * zhmax)
         zh                 = SQRT(zh_1 * zh_max)
         zh_delta           = zh - zh_1
      ENDIF
   ENDIF

   zeqn_absmin = MIN(ABS(zeqn), zeqn_absmin)

   ! Stop iterations once |([H]-[H_1])/[H_1]| < rdel
   l_exitnow = (ABS(zh_delta) < pp_rdel_ah_target*zh_1)

   IF(l_exitnow) EXIT
ENDDO

SOLVE_AT_GENERAL_SEC = zh

IF(PRESENT(p_val)) THEN
   IF(zh > 0._wp) THEN
      p_val = equation_at(p_alktot, zh,       p_dictot, p_bortot,              &
                          p_po4tot, p_siltot,                                  &
                          p_so4tot, p_flutot,                                  &
                          K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
   ELSE
     p_val = HUGE(1._wp)
   ENDIF
ENDIF

RETURN
END FUNCTION SOLVE_AT_GENERAL_SEC

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

FUNCTION SOLVE_AT_FAST(p_alktot, p_dictot, p_bortot,                          &
                       p_po4tot, p_siltot,                                    &
                       p_so4tot, p_flutot,                                    &
                       K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,        &
                       p_hini,   p_val)

! Fast version of SOLVE_AT_GENERAL, without any bounds checking.

USE msingledouble
IMPLICIT NONE
REAL(KIND=wp) :: SOLVE_AT_FAST

! Argument variables
REAL(KIND=wp), INTENT(IN)            :: p_alktot
REAL(KIND=wp), INTENT(IN)            :: p_dictot
REAL(KIND=wp), INTENT(IN)            :: p_bortot
REAL(KIND=wp), INTENT(IN)            :: p_po4tot
REAL(KIND=wp), INTENT(IN)            :: p_siltot
!REAL(KIND=wp), INTENT(IN)            :: p_nh4tot
!REAL(KIND=wp), INTENT(IN)            :: p_h2stot
REAL(KIND=wp), INTENT(IN)            :: p_so4tot
REAL(KIND=wp), INTENT(IN)            :: p_flutot
REAL(KIND=wp), INTENT(IN)            :: K0, K1, K2, Kb, Kw, Ks, Kf
REAL(KIND=wp), INTENT(IN)            :: K1p, K2p, K3p, Ksi
REAL(KIND=wp), INTENT(IN), OPTIONAL  :: p_hini
REAL(KIND=wp), INTENT(OUT), OPTIONAL :: p_val

! Local variables
REAL(KIND=wp)  ::  zh_ini, zh, zh_prev, zh_lnfactor
REAL(KIND=wp)  ::  zhdelta
REAL(KIND=wp)  ::  zeqn, zdeqndh
!REAL(KIND=wp)  ::  aphscale
LOGICAL        :: l_exitnow
REAL(KIND=wp), PARAMETER :: pz_exp_threshold = 1.0_wp

! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
!aphscale = 1._wp + p_so4tot/Ks

IF(PRESENT(p_hini)) THEN
   zh_ini = p_hini
ELSE
   CALL AHINI_FOR_AT(p_alktot, p_dictot, p_bortot, K1, K2, Kb, zh_ini)
ENDIF
zh = zh_ini

niter_atfast    = 0                 ! Reset counters of iterations
DO
   niter_atfast = niter_atfast + 1
   IF(niter_atfast > jp_maxniter_atfast) THEN
      zh = -1._wp
      EXIT
   ENDIF

   zh_prev = zh

   zeqn = equation_at(p_alktot, zh,       p_dictot, p_bortot,                  &
                      p_po4tot, p_siltot,                                      &
                      p_so4tot, p_flutot,                                      &
                      K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi,          &
                      P_DERIVEQN = zdeqndh)

   IF(zeqn == 0._wp) EXIT               ! zh is the root

   zh_lnfactor = -zeqn/(zdeqndh*zh_prev)
   IF(ABS(zh_lnfactor) > pz_exp_threshold) THEN
      zh          = zh_prev*EXP(zh_lnfactor)
   ELSE
      zhdelta     = zh_lnfactor*zh_prev
      zh          = zh_prev + zhdelta
   ENDIF

   ! Stop iterations once |\delta{[H]}/[H]| < rdel
   ! <=> |(zh - zh_prev)/zh_prev| = |EXP(-zeqn/(zdeqndh*zh_prev)) -1| < rdel
   ! |EXP(-zeqn/(zdeqndh*zh_prev)) -1| ~ |zeqn/(zdeqndh*zh_prev)|

   ! Alternatively:
   ! |\Delta pH| = |zeqn/(zdeqndh*zh_prev*LOG(10))|
   !             ~ 1/LOG(10) * |\Delta [H]|/[H]
   !             < 1/LOG(10) * rdel

   ! Hence |zeqn/(zdeqndh*zh)| < rdel

   ! rdel <- pp_rdel_ah_target

   l_exitnow = (ABS(zh_lnfactor) < pp_rdel_ah_target)

   IF(l_exitnow) EXIT
ENDDO

SOLVE_AT_FAST = zh

IF(PRESENT(p_val)) THEN
   IF(zh > 0._wp) THEN
      p_val = equation_at(p_alktot, zh,       p_dictot, p_bortot,              &
                          p_po4tot, p_siltot,                                  &
                          p_so4tot, p_flutot,                                  &
                          K0, K1, K2, Kb, Kw, Ks, Kf, K1p, K2p, K3p, Ksi)
   ELSE
      p_val = HUGE(1._wp)
   ENDIF
ENDIF

RETURN
END FUNCTION solve_at_fast
!===============================================================================

END MODULE mphsolvers