!===================================================================
!  Uses a divergent flow to push parcels toward or away from grid
!  points so as to bring the area fraction at each grid point back
!  to unity.

!  Here tri-diagonal solves are used in the vertical direction.

!           Initialise data first using inipar.f90
!===================================================================

program diverge

 !Import FFT library:
use stafft
use deriv1d

 !Import parameters and constants:
use constants

implicit none

 !Total number of parcels:
integer:: n

 !Parcel positions (x,z) and area fractions:
double precision:: x(nm),z(nm),v(nm)

 !Rates of change (dx/dt,dz/dt):
double precision:: dxdt(nm),dzdt(nm)

 !Gridded area fraction:
double precision:: volg(0:nz,nx)

!Tri-diagonal arrays:
double precision:: ap(nx),apb(nx)
double precision:: etdv(0:nz,nx),htdv(0:nz,nx)
double precision:: etd1(nz-1),htd1(nz-1)
double precision:: etda(nz),htda(nz)

 !Wavenumbers::
double precision:: hrkx(nx),rkx(nx)

 !Quantities needed in FFTs:
double precision:: xtrig(2*nx)
integer:: xfactors(5)

 !Next horizontal grid point used in bilinear interpolation:
integer:: ixp(nx)

 !Time step (does not matter):
double precision,parameter:: dt=0.01d0

double precision:: t
integer:: istep,nsteps

!---------------------------------------------------------------------
! Initialise (read data, define fixed arrays):
call initialise

write(*,*) ' Enter the number of time steps used to relax the'
write(*,*) ' gridded area fraction back to unity:'
read(*,*) nsteps

! Evolve parcels:
do istep=1,nsteps
  call evolve(istep)
enddo

! Finalise:
call par2grid

! Write final data
write(80,rec=nsteps+1) real(nsteps+1),real(volg-one)

close(40)
close(80)

write(*,*)
write(*,*) ' The rms area fraction error is in volf.asc and the'
write(*,*) ' gridded area fraction error is in dv.r4; view with'
write(*,*)
write(*,'(a,i3,1x,i3,a)') '  dataview -ndim ',nx,nz+1,' dv.r4 -mod &'
write(*,*)

contains

!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

subroutine initialise
! Initialises this program

implicit none

double precision:: a0(nx),a0b(nx),ksq(nx)
double precision,parameter:: dzisq=dzi**2
integer,parameter:: nwx=nx/2
integer:: i,ix,kx,iz

!---------------------------------------------------------------------
! Read parcel positions and volume fractions (of grid cell volume):
open(80,file='ini_parcels.asc',status='old')
read(80,*) n
do i=1,n
  read(80,*) x(i),z(i),v(i)
enddo
close(80)

t=zero

!----------------------------------------------------------
! Next grid point indices used in bi-linear interpolation:
do ix=1,nx-1
  ixp(ix)=ix+1
enddo
ixp(nx)=1

!----------------------------------------------------------
! Set up FFTs:
call initfft(nx,xfactors,xtrig)

! Define x wavenumbers:
call init_deriv(nx,ellx,hrkx)
rkx(1)=zero
do kx=1,nwx-1
  rkx(kx+1)   =hrkx(2*kx)
  rkx(nx+1-kx)=hrkx(2*kx)
enddo
rkx(nwx+1)=hrkx(nx)

 !Squared wavenumber array (used in tridiagonal solve):
ksq=rkx**2

!-----------------------------------------------------------------------
! Fixed coefficients used in the tridiagonal problems:
a0=-two*dzisq-f56*ksq
a0b=-dzisq-f13*ksq
ap=dzisq-f112*ksq
apb=dzisq-f16*ksq

!-----------------------------------------------------------------------
! Tridiagonal arrays for inversion of Poisson's equation:
htdv(:,1)=zero
etdv(:,1)=zero
do kx=2,nx
  htdv(0,kx)=one/a0b(kx)
  etdv(0,kx)=-apb(kx)*htdv(0,kx)
  do iz=1,nz-1
    htdv(iz,kx)=one/(a0(kx)+ap(kx)*etdv(iz-1,kx))
    etdv(iz,kx)=-ap(kx)*htdv(iz,kx)
  enddo
  htdv(nz,kx)=one/(a0b(kx)+apb(kx)*etdv(nz-1,kx))
enddo

! Tridiagonal arrays for the compact difference calculation of d/dz
! for fields f for which df/dz = 0 at the boundaries:
htd1(1)=one/f23
etd1(1)=-f16*htd1(1)
do iz=2,nz-2
  htd1(iz)=one/(f23+f16*etd1(iz-1))
  etd1(iz)=-f16*htd1(iz)
enddo
htd1(nz-1)=one/(f23+f16*etd1(nz-2))

! Tridiagonal arrays used for integrating in z (see vertint):
htda(1)=one/f76
etda(1)=-f16*htda(1)
do iz=2,nz-1
  htda(iz)=one/(one+f16*etda(iz-1))
  etda(iz)=-f16*htda(iz)
enddo
htda(nz)=one/(f76+f16*etda(nz-2))

!---------------------------------------------------------------
! File to contain rms area fraction - 1 & max abs value vs time:
open(40,file='volf.asc',status='replace')

! File to contain the gridded area fraction - 1 vs time:
open(80,file='dv.r4',form='unformatted',access='direct', &
                   status='replace',recl=4*(nx*(nz+1)+1))

return
end subroutine initialise

!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

subroutine evolve(istep)
! Evolves the parcel positions (x,z) one time step (Euler method).

implicit none

double precision:: phi(0:nz,nx),ud(0:nz,nx),wd(0:nz,nx)
double precision:: wbar(0:nz)
double precision:: xx,px,pxc,zz,pz,pzc
integer:: istep,ix,iz,kx
integer:: i,ix0,ix1,iz0,iz1
!DGD
double precision,parameter:: pi=acos(-1.d0)
double precision,parameter:: k=two*pi/ellx,m=pi/ellz
double precision:: phie(0:nz,nx),ude(0:nz,nx),wde(0:nz,nx)
!DGD

!-----------------------------------------------------------------
! Compute gridded area fractions:
call par2grid

! Form divergence field * dt and store in phi temporarily:
phi=volg-one

! Write data
write(80,rec=istep) real(istep),real(phi)

!DGD
!px=one
px=one
do ix=1,nx
  xx=k*(dx*dble(ix-1)-hlx)
  do iz=0,nz
    zz=m*(zmin+dz*dble(iz))
    phie(iz,ix)=sin(xx)*sin(zz)
    ude(iz,ix)=k*cos(xx)*sin(zz)
    wde(iz,ix)=m*(px+sin(xx))*cos(zz)
    phi(iz,ix)=-(m**2*px+(k**2+m**2)*sin(xx))*sin(zz)
  enddo
enddo
!DGD

!-----------------------------------------
! Forward x FFT:
call forfft(nz+1,nx,phi,xtrig,xfactors)

! Compute the x-independent part of wd by integration:
call vertint(phi(0,1),wbar)

! Invert Laplace's operator semi-spectrally with compact differences:
call lapinv1(phi)

! Compute x derivative spectrally:
call deriv(nz+1,nx,hrkx,phi,ud)

! Reverse x FFT to define x velocity component ud:
call revfft(nz+1,nx,ud,xtrig,xfactors)

! Compute z derivative by compact differences:
call diffz1(phi,wd)

! Add on the x-independent part of wd:
wd(:,1)=wd(:,1)+wbar

! Reverse x FFT:
call revfft(nz+1,nx,wd,xtrig,xfactors)

!DGD
open(77,file='nduw.r4',form='unformatted',access='direct', &
                     status='replace',recl=4*(nx*(nz+1)+1))
write(77,rec=1) real(0.),real(ud-ude)
write(77,rec=2) real(0.),real(wd-wde)
close(77)

call revfft(nz+1,nx,phi,xtrig,xfactors)
open(77,file='ndphi.r4',form='unformatted',access='direct', &
                      status='replace',recl=4*(nx*(nz+1)+1))
write(77,rec=1) real(0.),real(phi-phie)
close(77)

open(77,file='phi.r4',form='unformatted',access='direct', &
                    status='replace',recl=4*(nx*(nz+1)+1))
write(77,rec=1) real(0.),real(phi)
close(77)

ud=(ud-ude)**2
xx=sqrt((f12*sum(ud(0,:)+ud(nz,:))+sum(ud(1:nz-1,:)))/dble(ncell))
wd=(wd-wde)**2
zz=sqrt(sum(wd(1:nz-1,:))/dble(ncell))
write(*,'(a,i4,2(a,f18.16))') &
     ' nx = ',nx,'   rms ud error = ',xx,'   rms wd error = ',zz
stop
!DGD

!------------------------------------------------------------------
! Increment parcel positions usind (ud,wd) field:
do i=1,n
  xx=dxi*(x(i)-xmin)
  ix0=min(1+int(xx),nx)
  pxc=dble(ix0)-xx
  px=one-pxc
  ix1=ixp(ix0)

  zz=dzi*(z(i)-zmin)
  iz0=min(int(zz),nz-1)
  pz=zz-dble(iz0)
  pzc=one-pz
  iz1=iz0+1

  x(i)=x(i)+pxc*(pzc*ud(iz0,ix0)+pz*ud(iz1,ix0))+ &
            +px*(pzc*ud(iz0,ix1)+pz*ud(iz1,ix1))

  z(i)=z(i)+pxc*(pzc*wd(iz0,ix0)+pz*wd(iz1,ix0))+ &
            +px*(pzc*wd(iz0,ix1)+pz*wd(iz1,ix1))
enddo

! Advance time:
t=t+dt

return
end subroutine evolve

!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

subroutine par2grid

! Reverse bi-linearly interpolates the area fraction (v)
! on all parcels to obtain the gridded area fraction (volg).

 !Declarations:
implicit none

 !Local variables:
double precision:: xx,px,pxc,zz,pz,pzc
integer:: i,ix0,ix1,iz0,iz1

!--------------------------------------------------
volg=zero

do i=1,n
  xx=dxi*(x(i)-xmin)
  ix0=min(1+int(xx),nx)
  pxc=dble(ix0)-xx
  px=one-pxc
  ix1=ixp(ix0)

  zz=dzi*(z(i)-zmin)
  iz0=min(int(zz),nz-1)
  pz=zz-dble(iz0)
  pzc=one-pz
  iz1=iz0+1

  volg(iz0,ix0)=volg(iz0,ix0)+v(i)*pxc*pzc
  volg(iz1,ix0)=volg(iz1,ix0)+v(i)*pxc*pz
  volg(iz0,ix1)=volg(iz0,ix1)+v(i)*px*pzc
  volg(iz1,ix1)=volg(iz1,ix1)+v(i)*px*pz
enddo

 !Double edge values:
do ix0=1,nx
  volg(0 ,ix0)=two*volg(0 ,ix0)
  volg(nz,ix0)=two*volg(nz,ix0)
enddo

 !Write out diagnostics:
write(40,'(f7.2,2(1x,f15.12))') t,sqrt(sum((volg-one)**2)/dble(ncell)), &
                                  maxval(abs(volg-one))

return
end subroutine par2grid

!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

subroutine lapinv1(fs)
 !Inverts Laplace's operator on fs in semi-spectral space.
 !Here dfs/dz = 0 on the z boundaries.
 !Uses 4th-order compact differencing
 !*** Overwrites fs ***

 !Declarations:
implicit none

 !Passed variables:
double precision:: fs(0:nz,nx)

 !Local variables:
double precision:: rs(0:nz,nx)
integer:: kx,iz

fs(:,1)=zero
do kx=2,nx
  rs(0,kx)=f13*fs(0,kx)+f16*fs(1,kx)
  do iz=1,nz-1
    rs(iz,kx)=f112*(fs(iz-1,kx)+fs(iz+1,kx))+f56*fs(iz,kx)
  enddo
  rs(nz,kx)=f13*fs(nz,kx)+f16*fs(nz-1,kx)

  fs(0,kx)=rs(0,kx)*htdv(0,kx)
  do iz=1,nz-1
    fs(iz,kx)=(rs(iz,kx)-ap(kx)*fs(iz-1,kx))*htdv(iz,kx)
  enddo
  fs(nz,kx)=(rs(nz,kx)-apb(kx)*fs(nz-1,kx))*htdv(nz,kx)

  do iz=nz-1,0,-1
    fs(iz,kx)=etdv(iz,kx)*fs(iz+1,kx)+fs(iz,kx)
  enddo
enddo

return
end subroutine

!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

subroutine diffz1(fs,ds)
 !Calculates df/dz for a field f which has df/dz = 0 at the boundaries
 !using 4th-order compact differencing.  Here fs = f and ds = df/dz.

 !Declarations:
implicit none

 !Passed variables:
double precision:: fs(0:nz,nx),ds(0:nz,nx)

 !Local variables:
integer:: ix,iz

do ix=1,nx
  do iz=1,nz-1
    ds(iz,ix)=(fs(iz+1,ix)-fs(iz-1,ix))*hdzi
  enddo

  ds(0,ix)=zero
  ds(1,ix)=ds(1,ix)*htd1(1)
  do iz=2,nz-1
    ds(iz,ix)=(ds(iz,ix)-f16*ds(iz-1,ix))*htd1(iz)
  enddo
  ds(nz,ix)=zero

  do iz=nz-2,1,-1
    ds(iz,ix)=etd1(iz)*ds(iz+1,ix)+ds(iz,ix)
  enddo
enddo

return
end subroutine

!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

subroutine vertint(ds,fs)
 !Finds f by integrating df/dz = d, ensuring f = 0 at the boundaries
 !using 4th-order compact differencing.  Here ds = df/dz and fs = f.

 !Declarations:
implicit none

 !Passed variables:
double precision:: ds(0:nz),fs(0:nz)

 !Local variables:
double precision:: es(nz),esum
integer:: iz

!-------------------------------------------
 !First interpolate ds to a half grid as es:
do iz=1,nz
  es(iz)=f23*(ds(iz-1)+ds(iz))
enddo

es(1)=es(1)*htda(1)
do iz=2,nz
  es(iz)=(es(iz)-f16*es(iz-1))*htda(iz)
enddo

do iz=nz-1,1,-1
  es(iz)=etda(iz)*es(iz+1)+es(iz)
enddo

!-------------------------------------------
 !Next adjust es to ensure f(nz) = 0:
esum=(f1112*(es(1)+es(nz))+sum(es(2:nz-1)))/(dble(nz)-f16)
es=es-esum

 !Integrate:
fs(0)=zero
fs(1)=dz24*(23.d0*es(1)+es(2))
do iz=2,nz-1
  fs(iz)=fs(iz-1)+dz24*(es(iz-1)+22.d0*es(iz)+es(iz+1))
enddo
fs(nz)=zero

return
end subroutine

 !End main program
end program diverge


subroutine straight_line(xzt,yzt,zzt,xst,yst,zst,ips, tout)

common/ray/ nodes,xray(1000),yray(1000),zray(1000)
common/ray_param/ds_ini,ds_part_min,val_bend_min,bend_max0

dshor = sqrt((xst-xzt)*(xst-xzt)+(yst-yzt)*(yst-yzt))
dsver = abs(zzt-zst)
dstot = sqrt(dshor*dshor+dsver*dsver)

ds_cur=ds_ini

773 nodes = dstot/ds_cur+1

ds = dstot/(nodes-1)
if(nodes.eq.1) then
	nodes=2
	ds=dstot
else if(nodes.gt.1000) then
!    write(*,*)' nodes=',nodes,' distance=',dstot,' ds=',ds_cur
!    write(*,*)' this number should be less than 1000'
!    write(*,*)' increase integration step in MAJOR_PARAM'
!    pause
    ds_cur=ds_cur*2
    goto 773
end if

!write(*,*)' ztr:',xzt,yzt,zzt
do inode = 1,nodes
	sss = ds * (inode-1)
	xray(inode) = xzt + sss * (xst-xzt)/dstot
	yray(inode) = yzt + sss * (yst-yzt)/dstot
	zray(inode) = zzt + sss * (zst-zzt)/dstot
	!write(*,*) sss,xray(inode),yray(inode),zray(inode)
end do
!write(*,*)sss,' sta:',xst,yst,zst

! Time along the streight line:

ddd=0
ttt=0
sss=0
do inode=1,nodes-1
	x1=xray(inode)
	x2=xray(inode+1)
	xm=(x1+x2)/2.

	y1=yray(inode)
	y2=yray(inode+1)
	ym=(y1+y2)/2.

	z1=zray(inode)
	z2=zray(inode+1)
	zm=(z1+z2)/2.

	ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1))
	vvv=velocity (xm,ym,zm,ips)
	!write(*,*)xm,ym,zm,vvv
	!write(*,*)' vvv=',vvv
	ttt=ttt+ds/vvv
	sss=sss+ds
	!write(*,*)' ds=',ds,' sss=',sss
	!write(*,*)' t=',ttt,' s=',sss,' vvv=',vvv
end do
!write(*,*)' ttt=',ttt,' sss=',sss

tout=ttt

!pause

return
end


  module rotate

  use arrays

  CONTAINS

  subroutine rotate_cube(mu, pivot, nx, ny, nz, dx, dy, dz)

   implicit none
   integer, intent(in) :: nx, ny, nz

   integer  Nzcut
   integer  i,j,jj,k, xn, xnp, x_l, z_l
   real(kind=8), intent(in) :: mu, pivot, dx, dy, dz
   real(kind=8)  theta, pivotdx,  newdx, newx, newz
   real(kind=8)   z_f,  x_f
   real(kind=8)   zold, znew, Tnewd

   zold = 0.0d0
   znew = 0.0d0

   theta = acos(mu)
   pivotdx = tan(theta) * pivot
   newdx = dz * sin(theta)
   Nzcut = min(int(Nz * (0.9d0/mu)), int(3.5*Nz))

!   ---  allocate rotation arrays
!   call set_muarray(Nzcut)

!!!!!!!!!!!!!!!!!!!!!!!!!!!
   zgrid(1)=0.0d0
   do k=2,Nzcut
      zgrid(k)=zgrid(k-1)+dz
   end do

! if mu not equal 1 we need new z indices!

!---- start to do the whole cube
!--- over the x-y plan

      do i = 1, Nx
        do k = 1, Ny
           do j = 1, Nzcut
             newx = (k-1)*dx - pivotdx +(j-1)*newdx
             newz = (j-1)*(dz)*mu;
             if (newx .lt. 0.0) then
                 newx = newx+(Ny*dx)
             elseif (newx .ge. (Ny*dx)) then
                 newx = newx - (floor(newx/(dble(Ny)*dx))*(Ny*dx))
             endif

             x_f = newx/dx
             x_l = int(x_f)
             x_f = x_f-dble(x_l)
             z_f = newz/dz
             z_l = int(z_f)
             z_f = z_f-dble(z_l)
             z_l = z_l +1
             xn = x_l + 1
             xnp = xn+1
             if (xnp .gt. Ny) xnp = mod(xnp, Ny)

             newT(i,k,j)  = ((T(i, xn, z_l)) * (1.0d0-x_f) + x_f*(T(i, xnp,  z_l))) *(1.0d0- z_f)
             newT(i,k,j)  = newT(i,k,j) +  z_f*((T(i, xn, z_l+1))*(1.0d0-x_f)+ x_f*(T(i, xnp,z_l+1)))

             newP(i,k,j)  = ((P(i, xn, z_l)) * (1.0d0-x_f) + x_f*(P(i, xnp,  z_l))) *(1.0d0- z_f)
             newP(i,k,j)  = newP(i,k,j) +  z_f*((P(i, xn, z_l+1))*(1.0d0-x_f)+ x_f*(P(i, xnp,z_l+1)))

             newrho(i,k,j)  = ((rho(i, xn, z_l)) * (1.0d0-x_f) + x_f*(rho(i, xnp,  z_l))) *(1.0d0- z_f)
             newrho(i,k,j)  = newrho(i,k,j) +  z_f*((rho(i, xn, z_l+1))*(1.0d0-x_f)+ x_f*(rho(i, xnp,z_l+1)))

            znew = zold + dz*(j-1)*1.0d-5

           end do
         end do
       end do

  end subroutine

  end module


! This module caluclates the right hand side by combining the terms for coagulation, condensation, nucleation,
! and reaction.
module rhs

	use global_variables
    use derived_variables
    use function_list
	implicit none

contains
    subroutine FEX(NEQ,time,Y,YDOT)
        implicit none
        integer, intent (in) :: NEQ
        double precision, intent (in) :: time
        double precision, intent (in) :: Y(NEQ)
        double precision, intent (out) :: YDOT(NEQ)

        double precision :: M0, M1, M2, S, momo1 = 1.0, momo2 = 2.0, momo2by3 = 2.0/3, momo5by3 = 5.0/3, momo8by3 = 8.0/3
        double precision :: vg, rg, linsig, sd

        double precision, dimension(2) :: coa
        double precision, dimension(3) :: con
        double precision, dimension(2) :: nuc
        double precision :: rea

        double precision :: dxCOA_N, dxCOA_W
        double precision :: dxCON_V, dxCON_W, dxCON_S, CON_cons
        double precision :: dxNUC_N, dxNUC_V, dxNUC_W, dxNUC_S
        double precision :: dxREA_S, dxREA_N, dxREA_V, dxREA_W

        !double precision :: ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, t_final, delta_t, n_d

        M0 = y(1)*n_d
        M1 = y(2)*n_d*v1
        M2 = y(3)*n_d*v1*v1
        S  = y(4)

        if ((y(1) > 1e-50) .and. (y(2) > 1e-50) .and. (y(3) > 1e-50)) then
            vg = M1*M1 / ( M0 ** (1.5) * M2 ** (0.5))
            if (vg > 0) then
                rg = (3.0*vg/(4.0*PI))**(1.0/3)
                linsig = 1.0/9 * log(M0*M2/(M1*M1))
                if (linsig > 0) then
                    sd = exp(linsig**0.5)
                else
                    sd = 1.0
                end if
            else
                rg = 0.0
                linsig = 0.0
                sd = 1.0
            end if
        else
            vg = 0.0
            rg = 0.0
            linsig = 0.0
            sd = 1.0
        end if

        ! Call all the functions that are required here and store the values in appropriate variables
        ! unpack
        coa     =   coag(sd,rg,flag_COAG)
        con     =   cond(M0,sd,vg,flag_COND)
        nuc     =   nucl(S,flag_NUCL)
        rea     =   reac(flag_REAC)

        !######################################## NUCLEATION ############################################
        dxNUC_S =   nuc(2) / ns * nuc(1) * tau
        dxNUC_N =   nuc(2) / n_d * tau
        dxNUC_V =   nuc(2) / n_d * nuc(1) * tau
        dxNUC_W =   nuc(2) / n_d * nuc(1) * nuc(1) * tau

        !######################################## REACTION ############################################
        dxREA_S =   rea / (ns / tau)
        dxREA_N =   0.0
        dxREA_V =   0.0
        dxREA_W =   0.0

        !######################################## CONDENSATION ############################################
        if ((y(1) > 1e-50) .and. (y(2) > 1e-50)) then
            if ((flag_COND == 0) .or. (flag_COND == 1)) then
                dxCON_S =    con(2) * y(1) * ( S - 1.0 ) * tau /v1
                dxCON_V =    con(1) * y(1) * ( S - 1.0 ) * tau /v1 * ns/n_d
                dxCON_W =    con(3) * y(2) * ( S - 1.0 ) * tau /v1 * ns/n_d
            elseif (flag_COND == 2) then
                CON_cons =   1e9 * exp(-15155.15/T) * (22.0/7)**(1.0/3) * (6.0)**(2.0/3)
                dxCON_S =    CON_cons * S * tau  * moment(M0,vg,sd,momo2by3) / (ns * v1)
                dxCON_V =    CON_cons * S * tau  * moment(M0,vg,sd,momo2by3) / (n_d * v1)
                dxCON_W =    2.0 * CON_cons * S * tau  * moment(M0,vg,sd,momo5by3) / (n_d * v1 * v1)

            end if

        else
            dxCON_S =    0.0
            dxCON_V =    0.0
            dxCON_W =    0.0
        end if

        !######################################## COAGULATION ##################################################
        if ((y(1) > 1e-50) .and. (y(2) > 1e-50) .and. (y(3) > 1e-50)) then
            dxCOA_N =    coa(1) * y(1) ** 2.0 * n_d * tau
            dxCOA_W =    coa(2) * y(2) ** 2.0 * n_d * tau
        else
            dxCOA_N =    0.0
            dxCOA_W =    0.0
        end if

        !############ Gathering all the phenomenon together into f(t,y) #########################################
        ydot(1) = dxNUC_N - dxCOA_N
        ydot(2) = dxNUC_V + dxCON_V
        ydot(3) = dxNUC_W + dxCON_W + dxCOA_W
        ydot(4) = 0.0 !dxREA_S - dxNUC_S - dxCON_S

        return
    end subroutine FEX

end module rhs

!program test_rhs
!    use rhs
!    implicit none
!
!    integer :: NEQ = 4
!    double precision, dimension(4) :: y_in, y_dot_out
!    double precision :: time_in = 0.0
!    call derived(ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, t_final, delta_t, n_d)
!
!    y_in(1) = num_zero/n_d
!    y_in(2) = moment(num_zero,vg_zero,sigma_g_zero,1)/(v1*n_d)
!    y_in(3) = moment(num_zero,vg_zero,sigma_g_zero,2)/(v1*v1*n_d)
!    y_in(4) = S_zero
!    call FEX(NEQ, time_in, y_in, y_dot_out)
!    print*, y_dot_out
!    print*, tau
!
!
!end program test_rhs


!#########################################################
!#########################################################
!#########################################################
!#########################################################
subroutine rho_ana(x,d,dx,ncell)
  use amr_parameters
  use hydro_parameters
  use poisson_parameters
  implicit none
  integer ::ncell                         ! Number of cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector)       ::d ! Density
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates analytical Poisson source term.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! d(i) is the density field in user units.
  !================================================================
  integer::i
  real(dp)::emass,xmass,ymass,zmass,rr,rx,ry,rz,rcut
  real(dp)::v200,c,spin,fgas,dnfw,dmax,fcut

  emass=2.*boxlen*0.5d0**nlevelmax
  xmass=boxlen/2.0
  ymass=boxlen/2.0
  zmass=boxlen/2.0
  rcut =boxlen/2.0*0.75

  v200=gravity_params(1)
  c   =gravity_params(2)
  spin=gravity_params(3)
  fgas=gravity_params(4)
  dmax=1.0/emass/(1.0+emass)**2

  do i=1,ncell
     rx=x(i,1)-xmass
     ry=x(i,2)-ymass
     rz=x(i,3)-zmass
     rr=sqrt(rx**2+ry**2+rz**2)
     fcut=exp(-(rr/rcut)**50)
     dnfw=1d0/rr/(1d0+rr)**2
     dnfw=MIN(dmax,dnfw)*fcut
     dnfw=MAX(dnfw,1d-15)
     d(i)=(1d0-fgas)*dnfw
  end do

end subroutine rho_ana


PROGRAM average_array_section

  IMPLICIT NONE
  INTEGER, PARAMETER :: nx = 100, ny = 100, nits = 1000000
  REAL, DIMENSION(0:nx+1, 0:ny+1) :: u, uprime
  INTEGER :: ix, iy, iit

  u = 0.0

  DO iit = 1, nits
    !Apply boundary conditions
    u(:,0) = 1.0
    u(:,ny+1) = 10.0
    u(0,:) = 1.0
    u(nx+1,:) = 10.0
    uprime(1:nx,1:ny) = 0.25 * (u(0:nx-1,1:ny) + u(2:nx+1,1:ny) &
        + u(1:nx, 0:ny-1) + u(1:nx, 2:ny+1))
    u = uprime
  END DO

  WRITE(20,*) u(1:nx,1:ny)

END PROGRAM average_array_section


      !
      !
      ! This file contains subroutines for Gaussian elimination which
      ! have been taken from LINPACK and upgraded to quadruple
      ! precision. It also contains simple quadruple precision
      ! implementations of the BLAS procedures which are required by
      ! these subroutines.
      !
      !

      subroutine qgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(1),info
      real *16 a(lda,1)
!
!     dgefa factors a double precision matrix by gaussian elimination.
!
!     dgefa is usually called by dgeco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
!
!     on entry
!
!        a       double precision(lda, n)
!                the matrix to be factored.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!     on return
!
!        a       an upper triangular matrix and the multipliers
!                which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l  is a product of permutation and unit lower
!                triangular matrices and  u  is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                = 0  normal value.
!                = k  if  u(k,k) .eq. 0.0 .  this is not an error
!                     condition for this subroutine, but it does
!                     indicate that dgesl or dgedi will divide by zero
!                     if called.  use  rcond  in dgeco for a reliable
!                     indication of singularity.
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas daxpy,dscal,idamax
!
!     internal variables
!
      real *16 t
      integer idamax,j,k,kp1,l,nm1
      integer, external :: qidamax
!
!
!     gaussian elimination with partial pivoting
!
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
!
!        find l = pivot index
!
         l = qidamax(n-k+1,a(k,k)) + k - 1
         ipvt(k) = l
!
!        zero pivot implies this column already triangularized
!
         if (a(l,k) .eq. 0.0q0) go to 40
!
!           interchange if necessary
!
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
!
!           compute multipliers
!
            t = -1.0q0/a(k,k)
            call qscal(n-k,t,a(k+1,k))
!
!           row elimination with column indexing
!
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call qaxpy(n-k,t,a(k+1,k),a(k+1,j))
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0q0) info = n
      return
      end

      subroutine qgesl(a,lda,n,ipvt,b,job)
      integer lda,n,ipvt(1),job
      real *16 a(lda,1),b(1)
!
!     dgesl solves the double precision system
!     a * x = b  or  trans(a) * x = b
!     using the factors computed by dgeco or dgefa.
!
!     on entry
!
!        a       double precision(lda, n)
!                the output from dgeco or dgefa.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!        ipvt    integer(n)
!                the pivot vector from dgeco or dgefa.
!
!        b       double precision(n)
!                the right hand side vector.
!
!        job     integer
!                = 0         to solve  a*x = b ,
!                = nonzero   to solve  trans(a)*x = b  where
!                            trans(a)  is the transpose.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero will occur if the input factor contains a
!        zero on the diagonal.  technically this indicates singularity
!        but it is often caused by improper arguments or improper
!        setting of lda .  it will not occur if the subroutines are
!        called correctly and if dgeco has set rcond .gt. 0.0
!        or dgefa has set info .eq. 0 .
!
!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!           call dgeco(a,lda,n,ipvt,rcond,z)
!           if (rcond is too small) go to ...
!           do 10 j = 1, p
!              call dgesl(a,lda,n,ipvt,c(1,j),0)
!        10 continue
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas daxpy,ddot
!
!     internal variables
!
      real *16 ddot,t
      integer k,kb,l,nm1
      real *16, external :: qdot
!
      nm1 = n - 1
      if (job .ne. 0) go to 50
!
!        job = 0 , solve  a * x = b
!        first solve  l*y = b
!
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call qaxpy(n-k,t,a(k+1,k),b(k+1))
   20    continue
   30    continue
!
!        now solve  u*x = y
!
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call qaxpy(k-1,t,a(1,k),b(1))
   40    continue
      go to 100
   50 continue
!
!        job = nonzero, solve  trans(a) * x = b
!        first solve  trans(u)*y = b
!
         do 60 k = 1, n
            t = qdot(k-1,a(1,k),b(1))
            b(k) = (b(k) - t)/a(k,k)
   60    continue
!
!        now solve trans(l)*x = y
!
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + qdot(n-k,a(k+1,k),b(k+1))
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end

      subroutine qscal(n,a,x)

      implicit none
      integer n
      real *16 a,x(n)

      x = a*x

      end subroutine qscal

      subroutine qaxpy(n,a,x,y)

      implicit none
      integer n
      real *16 a,x(n),y(n)

      y = a*x+y

      end subroutine qaxpy

      integer function qidamax(n,x)

      implicit none
      integer n
      real *16 x(n)

      qidamax = maxloc(abs(x),dim=1)

      end function qidamax

      real *16 function qdot(n,x,y)

      implicit none
      integer n
      real *16 x(n),y(n)

      qdot = sum(x*y)

      end function qdot


Program kappa_spectra
implicit none
integer::i,j,k,row=200
real::pass_t
real,allocatable ::spec(:,:),culm_spec(:,:)
open(unit=1,File='pc_rta.kl_spec')    !!!!!!  change this file for different file
open(unit=2,File='kappa_spec_culm.dat')

write(*,*)'Input row of the *.kl_spec file:'
read(*,*) row
allocate(spec(row,4))
allocate(culm_spec(row,3))

read(1,*)
read(1,*)
do i=1,row
 read(1,*)pass_t,spec(i,:)
end do

culm_spec=0
do j=1,3
 do i=1,row
  do k=1,i
   culm_spec(i,j)=culm_spec(i,j)+spec(k,j+1)
  end do
 end do
end do

culm_spec=culm_spec*(spec(2,1)-spec(1,1))
do i=1,row
 write(2,300,advance='no')spec(i,:),culm_spec(i,:)
 write(2,*)
end do
300 format(7f12.7)
end program


! Fortran subroutines from SCATE
!
!-------------------------------------------------------------------------------
subroutine trnslt_old(mx,my,mz,nt,dx,dy,zt,ff,dxdz,dydz)

  !  Translate a scalar field to an inclined coordinate system.
  !
  !  Operation count:  10m+8a = 18 flops/pnt
  !
  !  Timing:
  !    Alliant: 48 calls = 1.79 s ->  18*48*31*31*31/1790000 = 14 Mflops
  !
  !  Update history:
  !
  !  28-oct-87/aake:  Added 'nt' parameter; reduces work in shallow case
  !  02-nov-87/aake:  Added 'zt' parameter, to allow separate zrad()
  !  06-nov-87/aake:  Split derivative loops, to loop over simplest index
  !  27-aug-89/bob:   Inverted some l,m loops to make l the inner loop
  !  31-aug-89/aake:  Collapsed loops 100 and 200 to lm loops

  implicit none
  integer,intent(in) :: mx,my,mz,nt
  real,intent(in) :: dx,dy,dxdz,dydz
  real,dimension(nt),intent(in) ::  zt
  real,dimension(mx,my,mz),intent(inout) :: ff

  real,dimension(mx,my) :: f,d
  integer :: k,l,m,n,lp,lp1,mk,mk1
  real :: xk,yk,p,q,af,bf,ad,bd

  do n=1,nt
     xk=dxdz*zt(n)/(mx*dx)
     if(abs(xk).lt.0.001.or.mx.eq.1)cycle
     xk=amod(xk,1.)
     if(xk.lt.0.) xk=xk+1.
     xk=mx*xk
     k=xk
     p=xk-k
     q=1.-p
     af=q+p*q*(q-p)
     bf=p-p*q*(q-p)
     ad=p*q*q
     bd=-p*q*p

     !  Copy input to temporary
     do m=1,my
        do l=1,mx
           f(l,m)=ff(l,m,n)
        end do
     end do

     !  Calculate derivatives by centered differences [1m+1a]
     do m=1,my
        do l=2,mx-1
           d(l,m)=0.5*(f(l+1,m)-f(l-1,m))
        end do
     end do
     do m=1,my
        d(1,m)=0.5*(f(2,m)-f(mx,m))
        d(mx,m)=0.5*(f(1,m)-f(mx-1,m))
     end do
     !
     !  Interpolate using cubic splines [4m+3a]
     !
     do l=1,mx
        lp=mod(l+k-1,mx)+1
        lp1=mod(l+1+k-1,mx)+1
        do m=1,my
           ff(l,m,n)=af*f(lp,m)+bf*f(lp1,m)+ad*d(lp,m)+bd*d(lp1,m)
           !             0.29 sec
        end do
     end do
  end do

  do n=1,nt
     yk=dydz*zt(n)/(my*dy)
     if(abs(yk).lt.0.001.or.my.eq.1)cycle
     yk=amod(yk,1.)
     if(yk.lt.0.) yk=yk+1.
     yk=my*yk
     k=yk
     p=yk-k
     q=1.-p
     af=q+p*q*(q-p)
     bf=p-p*q*(q-p)
     ad=p*q*q
     bd=-p*q*p

     !  Copy input to temporary
     do m=1,my
        do l=1,mx
           f(l,m)=ff(l,m,n)
        end do
     end do

     !  Calculate derivatives by centered differences
     do m=2,my-1
        do l=1,mx
           d(l,m)=0.5*(f(l,m+1)-f(l,m-1))
           !             0.16 sec
        end do
     end do
     do l=1,mx
        d(l,1)=0.5*(f(l,2)-f(l,my))
        d(l,my)=0.5*(f(l,1)-f(l,my-1))
     end do

     !  Interpolate using cubic splines
     do m=1,my
        mk=mod(m+k-1,my)+1
        mk1=mod(m+1+k-1,my)+1
        do l=1,mx
           ff(l,m,n)=af*f(l,mk)+bf*f(l,mk1)+ad*d(l,mk)+bd*d(l,mk1)
           !             0.18 sec -> 48*31*31*31*7/0.18 =
        end do
     end do
  end do

end subroutine trnslt_old

!-------------------------------------------------------------------------------
subroutine trnslt(mx,my,mz,nzt,dx,dy,zt,f,dxdz,dydz)

  !  Translate a scalar field to an inclined coordinate system.
  !
  !  Adapted from original routine by Nordlund and Stein

  implicit none

  integer,                   intent(in)    :: mx, my, mz, nzt
  real,                      intent(in)    :: dx, dy, dxdz, dydz
  real, dimension(nzt),      intent(in)    :: zt
  real, dimension(mx,my,mz), intent(inout) :: f
  real, dimension(mx,my)                   :: ftmp

  integer :: k, l, m, n, lm1, lp0, lp1, lp2, mm1, mp0, mp1, mp2
  real    :: xk, yk, p, q, af, bf, ad, bd, ac, bc

  real, parameter :: eps=1.0e-6

  if (abs(dxdz).gt.eps) then

     do n=1,nzt

        xk = dxdz*zt(n)/(mx*dx)
        xk = amod(xk,1.)
        if (xk.lt.0.) xk = xk + 1.
        xk = mx*xk
        k  = xk
        p  = xk-k
        k  = k + mx
        q  = 1.-p
        af = q+p*q*(q-p)
        bf = p-p*q*(q-p)
        ad = p*q*q*0.5
        bd = -p*q*p*0.5
        ac = af-bd
        bc = bf+ad

        do m=1,my
           do l=1,mx
              ftmp(l,m) = f(l,m,n)
           end do
        end do

        do l=1,mx
           lm1 = mod(l+k-2,mx)+1
           lp0 = mod(l+k-1,mx)+1
           lp1 = mod(l+k  ,mx)+1
           lp2 = mod(l+k+1,mx)+1

           do m=1,my
              f(l,m,n) = ac * ftmp(lp0,m) + bc * ftmp(lp1,m) - ad * ftmp(lm1,m) + bd * ftmp(lp2,m)
           end do
        end do

     end do

  end if

  if (abs(dydz).gt.eps) then

     do n=1,nzt

        yk = dydz*zt(n)/(my*dy)
        yk = amod(yk,1.)
        if (yk.lt.0.) yk = yk + 1.
        yk = my*yk
        k  = yk
        p  = yk - k
        k  = k + my
        q  = 1. - p
        af = q+ p*q*(q-p)
        bf = p-p*q*(q-p)
        ad = p*q*q*0.5
        bd = -p*q*p*0.5
        ac = af-bd
        bc = bf+ad

        do m=1,my
           do l=1,mx
              ftmp(l,m) = f(l,m,n)
           end do
        end do

        do m=1,my
           mm1 = mod(m+k-2,my)+1
           mp0 = mod(m+k-1,my)+1
           mp1 = mod(m+k  ,my)+1
           mp2 = mod(m+k+1,my)+1
           do l=1,mx
              f(l,m,n) = ac * ftmp(l,mp0) + bc * ftmp(l,mp1) - ad * ftmp(l,mm1) + bd * ftmp(l,mp2)
           end do
        end do

     end do

  end if

end subroutine trnslt


*> \brief \b DSBT21
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK,
*                          RESULT )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            KA, KS, LDA, LDU, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
*      $                   U( LDU, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DSBT21  generally checks a decomposition of the form
*>
*>         A = U S U**T
*>
*> where **T means transpose, A is symmetric banded, U is
*> orthogonal, and S is diagonal (if KS=0) or symmetric
*> tridiagonal (if KS=1).
*>
*> Specifically:
*>
*>         RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and
*>         RESULT(2) = | I - U U**T | / ( n ulp )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER
*>          If UPLO='U', the upper triangle of A and V will be used and
*>          the (strictly) lower triangle will not be referenced.
*>          If UPLO='L', the lower triangle of A and V will be used and
*>          the (strictly) upper triangle will not be referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The size of the matrix.  If it is zero, DSBT21 does nothing.
*>          It must be at least zero.
*> \endverbatim
*>
*> \param[in] KA
*> \verbatim
*>          KA is INTEGER
*>          The bandwidth of the matrix A.  It must be at least zero.  If
*>          it is larger than N-1, then max( 0, N-1 ) will be used.
*> \endverbatim
*>
*> \param[in] KS
*> \verbatim
*>          KS is INTEGER
*>          The bandwidth of the matrix S.  It may only be zero or one.
*>          If zero, then S is diagonal, and E is not referenced.  If
*>          one, then S is symmetric tri-diagonal.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA, N)
*>          The original (unfactored) matrix.  It is assumed to be
*>          symmetric, and only the upper (UPLO='U') or only the lower
*>          (UPLO='L') will be referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 1
*>          and at least min( KA, N-1 ).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The diagonal of the (symmetric tri-) diagonal matrix S.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (N-1)
*>          The off-diagonal of the (symmetric tri-) diagonal matrix S.
*>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
*>          (3,2) element, etc.
*>          Not referenced if KS=0.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is DOUBLE PRECISION array, dimension (LDU, N)
*>          The orthogonal matrix in the decomposition, expressed as a
*>          dense matrix (i.e., not as a product of Householder
*>          transformations, Givens transformations, etc.)
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of U.  LDU must be at least N and
*>          at least 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (N**2+N)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (2)
*>          The values computed by the two tests described above.  The
*>          values are currently limited to 1/ulp, to avoid overflow.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK,
     $                   RESULT )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            KA, KS, LDA, LDU, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
     $                   U( LDU, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER
      CHARACTER          CUPLO
      INTEGER            IKA, J, JC, JR, LW
      DOUBLE PRECISION   ANORM, ULP, UNFL, WNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANSB, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANGE, DLANSB, DLANSP
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DSPR, DSPR2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Constants
*
      RESULT( 1 ) = ZERO
      RESULT( 2 ) = ZERO
      IF( N.LE.0 )
     $   RETURN
*
      IKA = MAX( 0, MIN( N-1, KA ) )
      LW = ( N*( N+1 ) ) / 2
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         LOWER = .FALSE.
         CUPLO = 'U'
      ELSE
         LOWER = .TRUE.
         CUPLO = 'L'
      END IF
*
      UNFL = DLAMCH( 'Safe minimum' )
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
*     Some Error Checks
*
*     Do Test 1
*
*     Norm of A:
*
      ANORM = MAX( DLANSB( '1', CUPLO, N, IKA, A, LDA, WORK ), UNFL )
*
*     Compute error matrix:    Error = A - U S U**T
*
*     Copy A from SB to SP storage format.
*
      J = 0
      DO 50 JC = 1, N
         IF( LOWER ) THEN
            DO 10 JR = 1, MIN( IKA+1, N+1-JC )
               J = J + 1
               WORK( J ) = A( JR, JC )
   10       CONTINUE
            DO 20 JR = IKA + 2, N + 1 - JC
               J = J + 1
               WORK( J ) = ZERO
   20       CONTINUE
         ELSE
            DO 30 JR = IKA + 2, JC
               J = J + 1
               WORK( J ) = ZERO
   30       CONTINUE
            DO 40 JR = MIN( IKA, JC-1 ), 0, -1
               J = J + 1
               WORK( J ) = A( IKA+1-JR, JC )
   40       CONTINUE
         END IF
   50 CONTINUE
*
      DO 60 J = 1, N
         CALL DSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
   60 CONTINUE
*
      IF( N.GT.1 .AND. KS.EQ.1 ) THEN
         DO 70 J = 1, N - 1
            CALL DSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
     $                  WORK )
   70    CONTINUE
      END IF
      WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( LW+1 ) )
*
      IF( ANORM.GT.WNORM ) THEN
         RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
      ELSE
         IF( ANORM.LT.ONE ) THEN
            RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
         ELSE
            RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
         END IF
      END IF
*
*     Do Test 2
*
*     Compute  U U**T - I
*
      CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
     $            N )
*
      DO 80 J = 1, N
         WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
   80 CONTINUE
*
      RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
     $              DBLE( N ) ) / ( N*ULP )
*
      RETURN
*
*     End of DSBT21
*
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     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 2);
!
!
!     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, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine e_c3d_u1(co,kon,lakonl,p1,p2,omx,bodyfx,nbody,s,sm,
     &  ff,nelem,nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,
     &  ielmat,ielorien,norien,orab,ntmat_,
     &  t0,t1,ithermal,vold,iperturb,nelemload,
     &  sideload,xload,nload,idist,sti,stx,iexpl,plicon,
     &  nplicon,plkcon,nplkcon,xstiff,npmat_,dtime,
     &  matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme,
     &  ttime,time,istep,iinc,coriolis,xloadold,reltime,
     &  ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold,
     &  ne0,ipkon,thicke,
     &  integerglob,doubleglob,tieset,istartset,iendset,ialset,ntie,
     &  nasym,ielprop,prop)
!
!     computation of the element matrix and rhs for the user element
!     of type u1
!
!     This is a beam type element. Reference:
!     Yunhua Luo, An Efficient 3D Timoshenko Beam Element with
!     Consistent Shape Functions, Adv. Theor. Appl. Mech., Vol. 1,
!     2008, no. 3, 95-106
!
!     special case for which the beam axis goes through the
!     center of gravity of the cross section and the 1-direction
!     corresponds with a principal axis
!
!
!     INPUT:
!
!     co(1..3,i)         coordinates of node i
!     kon(*)             contains the topology of all elements. The
!                        topology of element i starts at kon(ipkon(i)+1)
!                        and continues until all nodes are covered. The
!                        number of nodes depends on the element label
!     lakonl             label of current element nelem (character*8)
!     p1(1..3)           coordinates of a point on the rotation axis
!                        (if applicable)
!     p2(1..3)           unit vector on rotation axis (if applicable)
!     omx                rotational speed square
!     bodyfx(1..3)       acceleration vector
!     nbody              number of body loads
!     nelem              element number
!     nmethod            procedure:
!                        1: static analysis
!                        2: frequency analysis
!                        3: buckling analysis
!                        4: (linear or nonlinear) dynamic analysis
!                        5: steady state dynamics analysis
!                        6: Coriolis frequency calculation
!                        7: flutter frequency calculation
!                        8:  magnetostatics
!                        9:  magnetodynamics
!                        10: electromagnetic eigenvalue problems
!                        11: superelement creation or Green function
!                            calculation
!                        12: sensitivity analysis
!     elcon              elastic constants (cf. List of variables and
!                        their meaning in the User's Manual)
!     nelcon             integers describing the elastic constant fields
!                        (cf. User's Manual)
!     rhcon              density constants (cf. User's Manual)
!     nrhcon             integers describing the density constant fields
!                        (cf. User's Manual)
!     alcon              thermal expansion constants (cf. User's Manual)
!     nalcon             integers describing the thermal expansion
!                        constants (cf. User's Manual)
!     alzero             thermal expansion reference values (cf. User's Manual)
!     ielmat(i)          material for element i
!     ielorien(i)        orientation for element i
!     norien             number of orientations
!     orab(7,*)          description of all local coordinate systems.
!                        (cf. List of variables and their meaning in the
!                        User's manual)
!     ntmat_             maximum number of material temperature points
!     t0(i)              temperature in node i at start of calculation
!     t1(i)              temperature in node i at the end of the current
!                        increment
!     ithermal           cf. ithermal(1) in the List of variables and
!                        their meaning in the User's Manual
!     vold(0..mi(2),i)   value of the variables in node i at the end
!                        of the previous iteration
!     iperturb(*)        describes the kind of nonlinearity of the
!                        calculation, cf. User's Manual
!     nelemload          field describing facial distributed load (cf.
!                        User's Manual)
!     sideload           field describing facial distributed load (cf.
!                        User's Manual)
!     xload              facial distributed load values (cf.
!                        User's Manual)
!     nload              number of facial distributed loads
!     idist              0: no distributed forces in the model
!                        1: distributed forces are present in the model
!                        (body forces or thermal loads or residual
!                        stresses or distributed facial loads)
!     sti(i,j,k)         stress component i in integration point j
!                        of element k at the end of the previous step
!     stx(i,j,k)         stress component i in integration point j
!                        of element k at the end of a static step
!                        describing a reference buckling load
!     iexpl              0: structure: implicit dynamics,
!                           fluid: incompressible
!     iexpl              1: structure: implicit dynamics,
!                           fluid: compressible
!     iexpl              2: structure: explicit dynamics,
!                           fluid: incompressible
!     iexpl              3: structure: explicit dynamics,
!                           fluid: compressible
!     plicon,nplicon     fields describing isotropic hardening of
!                        a plastic material or spring constants of
!                        a nonlinear spring (cf. User's Manual)
!     plkcon,nplkcon     fields describing kinematic hardening of
!                        a plastic material or gap conductance
!                        constants (cf. User's Manual)
!     xstiff(i,j,k)      stiffness (i=1...21) and conductivity
!                        (i=22..27) constants in integration point j
!                        of element k
!     npmat_             maximum number of plastic constants
!     dtime              length of present time increment
!     matname(i)         name of material i
!     mi(1)              max # of integration points per element (max
!                        over all elements)
!     mi(2)              max degree of freedom per node (max over all
!                        nodes) in fields like v(0:mi(2))...
!     mi(3)              max number of layers in the structure
!     ncmat_             max number of elastic constants
!     mass(1)            if 1: mass matrix needed, else not
!     mass(2)            if 1: heat capacity matrix needed, else not
!     stiffness          if 1: stiffness matrix needed, else not
!     buckling           if 1: linear buckling calculation, else not
!     rhsi               if 1: right hand side needed, else not
!     intscheme          1: integration point scheme for the calculation
!                           of the initial acceleration in a dynamic
!                           step
!                        0: any other case
!     ttime              total time at the start of the present increment
!     time               step time at the end of the present increment
!     istep              current step number
!     iinc               current increment number within the actual step
!     coriolis           if 1: Coriolis forces are taken into account,
!                              else not
!     xloadold           load at the end of the previous increment
!                        (cf. User's Manual)
!     reltime            relative step time (between 0 and 1)
!     ipompc(i)          pointer into field nodempc and coefmpc for
!                        MPC i
!     nodempc            field containing the nodes and dof's of all
!                        MPC's (cf. User's Manual)
!     coefmpc            field containing the coefficients of all
!                        MPC's  (cf. User's Manual)
!     nmpc               number of MPC's in the model
!     ikmpc(i)           field containing an integer code number
!                        describing the dependent dof of some MPC:
!                        ikmpc(i)=8*(node-1)+dir, where the dependent
!                        dof is applied in direction dir of node "node"
!                        ikmpc is sorted in ascending order
!     ilmpc(i)           MPC number corresponding to ikmpc(i) (cf.
!                        User's manual)
!     veold(j,i)         time rate of variable j in node i at the end
!                        of the previous iteration
!     ne0                element number before the first contact element;
!                        contact elements are appended after ne0
!     ipkon(i)           points to the location in field kon preceding
!                        the topology of element i
!     thicke(j,i)        thickness of layer j in node i
!     integerglob        integer field needed for determining the
!                        interface loading of a submodel
!     doubleglob         real field needed for determining the
!                        interface loading of a submodel
!     tieset(1..3,*)     tie character information for tie i (cf.
!                        User's Manual)
!     istartset          integer describing set information (cf.
!                        User's Manual)
!     iendset            integer describing set information (cf.
!                        User's Manual)
!     ialset             integer describing set information (cf.
!                        User's Manual)
!     ntie               number of ties in the model
!     nasym              1: asymmetric contributions, else purely
!                        symmetric
!     ielprop(i)         points to the location in field prop preceding
!                        the properties of element i
!     prop(*)            contains the properties and some beam
!                        elements (cf. User's Manual)
!
!
!     OUTPUT:
!
!     s                  element stiffness matrix
!     sm                 element mass matrix
!     ff                 element load vector
!     xload              facial distributed load values (cf.
!                        User's Manual)
!     nmethod            may be changed by the user, e.g. a
!                        change to 0 for negative Jacobians leads
!                        to a program exit in the calling program
!                        for the other value: cf. above
!
      implicit none
!
      integer mass,stiffness,buckling,rhsi,coriolis
!
      character*8 lakonl
      character*20 sideload(*)
      character*80 matname(*),amat
      character*81 tieset(3,*)
!
      integer konl(26),nelemload(2,*),nbody,nelem,mi(*),kon(*),
     &  ielprop(*),index,mattyp,ithermal(*),iperturb(*),nload,idist,
     &  i,j,k,i1,nmethod,kk,nelcon(2,*),nrhcon(*),nalcon(2,*),
     &  ielmat(mi(3),*),ielorien(mi(3),*),ipkon(*),indexe,
     &  ntmat_,nope,norien,ihyper,iexpl,kode,imat,iorien,istiff,
     &  ncmat_,intscheme,istep,iinc,ipompc(*),nodempc(3,*),
     &  nmpc,ikmpc(*),ilmpc(*),ne0,ndof,istartset(*),iendset(*),
     &  ialset(*),ntie,integerglob(*),nasym,nplicon(0:ntmat_,*),
     &  nplkcon(0:ntmat_,*),npmat_
!
      real*8 co(3,*),xl(3,26),veold(0:mi(2),*),rho,s(60,60),bodyfx(3),
     &  ff(60),elconloc(21),coords(3),p1(3),elcon(0:ncmat_,ntmat_,*),
     &  p2(3),eth(6),rhcon(0:1,ntmat_,*),reltime,prop(*),tm(3,3),
     &  alcon(0:6,ntmat_,*),alzero(*),orab(7,*),t0(*),t1(*),
     &  xloadold(2,*),vold(0:mi(2),*),xload(2,*),omx,e,un,um,tt,
     &  sm(60,60),sti(6,mi(1),*),stx(6,mi(1),*),t0l,t1l,coefmpc(*),
     &  elas(21),thicke(mi(3),*),doubleglob(*),dl,e2(3),e3(3),
     &  plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*),
     &  xstiff(27,mi(1),*),plconloc(802),dtime,ttime,time,tmg(12,12),
     &  a,xi11,xi12,xi22,xk,e1(3),offset1,offset2,y1,y2,y3,z1,z2,z3,
     &  sg(12,12)
!
!
!
      indexe=ipkon(nelem)
!
!     material and orientation
!
      imat=ielmat(1,nelem)
      amat=matname(imat)
      if(norien.gt.0) then
         iorien=max(0,ielorien(1,nelem))
      else
         iorien=0
      endif
!
      if(nelcon(1,imat).lt.0) then
         ihyper=1
      else
         ihyper=0
      endif
!
!     properties of the cross section
!
      index=ielprop(nelem)
      a=prop(index+1)
      xi11=prop(index+2)
      xi12=prop(index+3)
      xi22=prop(index+4)
      xk=prop(index+5)
      e2(1)=prop(index+6)
      e2(2)=prop(index+7)
      e2(3)=prop(index+8)
      offset1=prop(index+9)
      offset2=prop(index+10)
!
      nope=2
      ndof=6
!
      if(dabs(xi12).gt.0.d0) then
         write(*,*) '*ERROR in e_c3d_u1: no nonzero cross moment'
         write(*,*) '       of inertia for this type of element'
         call exit(201)
      endif
!
      if(dabs(offset1).gt.0.d0) then
         write(*,*) '*ERROR in e_c3d_u1: no offset in 1-direction'
         write(*,*) '       for this type of element'
         call exit(201)
      endif
!
      if(dabs(offset2).gt.0.d0) then
         write(*,*) '*ERROR in e_c3d_u1: no offset in 2-direction'
         write(*,*) '       for this type of element'
         call exit(201)
      endif
!
!     computation of the coordinates of the local nodes
!
      do i=1,nope
         konl(i)=kon(indexe+i)
         do j=1,3
            xl(j,i)=co(j,konl(i))
         enddo
      enddo
!
!     local axes e1-e2-e3  (e2 is given by the user (in the input deck
!     this is called e1), e1 is parallel to the beam axis)
!
      do j=1,3
         e1(j)=xl(j,2)-xl(j,1)
      enddo
!
      dl=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3))
!
      do j=1,3
         e1(j)=e1(j)/dl
      enddo
!
!     e3 = e1 x e2
!
      e3(1)=e1(2)*e2(3)-e1(3)*e2(2)
      e3(2)=e1(3)*e2(1)-e1(1)*e2(3)
      e3(3)=e1(1)*e2(2)-e1(2)*e2(1)
!
!     transformation matrix from the global into the local system
!
      do j=1,3
         tm(1,j)=e1(j)
         tm(2,j)=e2(j)
         tm(3,j)=e3(j)
      enddo
!
!     initialisation for distributed forces
!
      if(rhsi.eq.1) then
        if(idist.ne.0) then
          do i=1,ndof*nope
            ff(i)=0.d0
          enddo
        endif
      endif
!
!     displacements for 2nd order static and modal theory
!
      if(((iperturb(1).eq.1).or.(iperturb(2).eq.1)).and.
     &          (stiffness.eq.1).and.(buckling.eq.0)) then
         write(*,*) '*ERROR in e_c3d_u1: no second order'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
!
!     initialisation of sm
!
      if((mass.eq.1).or.(buckling.eq.1).or.(coriolis.eq.1)) then
         write(*,*) '*ERROR in e_c3d_u1: no dynamic or buckling'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
!
!     initialisation of s
!
      do i=1,ndof*nope
        do j=1,ndof*nope
          s(i,j)=0.d0
        enddo
      enddo
!
!     computation of the matrix
!
!     calculating the temperature in the integration
!     point
!
      t0l=0.d0
      t1l=0.d0
      if(ithermal(1).eq.1) then
         do i1=1,nope
            t0l=t0l+t0(konl(i1))/2.d0
            t1l=t1l+t1(konl(i1))/2.d0
         enddo
      elseif(ithermal(1).ge.2) then
         write(*,*) '*ERROR in e_c3d_u1: no thermal'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
      tt=t1l-t0l
!
!     calculating the coordinates of the integration point
!     for material orientation purposes (for cylindrical
!     coordinate systems)
!
      if(iorien.gt.0) then
         write(*,*) '*ERROR in e_c3d_u1: no orientation'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
!
!     for deformation plasticity: calculating the Jacobian
!     and the inverse of the deformation gradient
!     needed to convert the stiffness matrix in the spatial
!     frame of reference to the material frame
!
      kode=nelcon(1,imat)
!
      if(kode.eq.2) then
         mattyp=1
      else
         mattyp=0
      endif
!
!     material data and local stiffness matrix
!
      istiff=0
      call materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,nalcon,
     &     imat,amat,iorien,coords,orab,ntmat_,elas,rho,
     &     nelem,ithermal,alzero,mattyp,t0l,t1l,
     &     ihyper,istiff,elconloc,eth,kode,plicon,
     &     nplicon,plkcon,nplkcon,npmat_,
     &     plconloc,mi(1),dtime,kk,
     &     xstiff,ncmat_)
!
      if(mattyp.eq.1) then
         e=elconloc(1)
         un=elconloc(2)
         um=e/(1.d0+un)
         um=um/2.d0
      elseif(mattyp.eq.2) then
         write(*,*) '*ERROR in e_c3d_u1: no orthotropic material'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      else
         write(*,*) '*ERROR in e_c3d_u1: no anisotropic material'
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
!
!     initialization for the body forces
!
      if(rhsi.eq.1) then
         if(nbody.ne.0) then
            write(*,*) '*ERROR in e_c3d_u1: no body forces'
            write(*,*) '       for this type of element'
            call exit(201)
         endif
      endif
!
      if(buckling.eq.1) then
         write(*,*) '*ERROR in e_c3d_u1: no buckling '
         write(*,*) '       calculation for this type of element'
         call exit(201)
      endif
!
!     determination of the stiffness, and/or mass and/or
!     buckling matrix
!
      if((stiffness.eq.1).or.(mass.eq.1).or.(buckling.eq.1).or.
     &     (coriolis.eq.1)) then
!
         if(((iperturb(1).ne.1).and.(iperturb(2).ne.1)).or.
     &        (buckling.eq.1)) then
!
!     stiffness matrix
!
            y1=xk*um*a*e*xi11*(12.d0*e*xi11+xk*um*a*dl*dl)
            y2=(12.d0*e*xi11-xk*um*a*dl*dl)**2
            y3=4.d0*e*xi11*((xk*um*a)**2*dl**4+
     &         3.d0*xk*um*a*dl*dl*e*xi11+
     &         36.d0*(e*xi11)**2)
            z1=xk*um*a*e*xi22*(12.d0*e*xi22+xk*um*a*dl*dl)
            z2=(12.d0*e*xi22-xk*um*a*dl*dl)**2
            z3=4.d0*e*xi22*((xk*um*a)**2*dl**4+
     &         3.d0*xk*um*a*dl*dl*e*xi22+
     &         36.d0*(e*xi22)**2)
!
!           stiffness matrix S' in local coordinates
!
            s(1,1)=e*a/dl
            s(1,7)=-s(1,1)
            s(2,2)=12.d0*y1/(dl*y2)
            s(2,6)=6.d0*y1/y2
            s(2,8)=-s(2,2)
            s(2,12)=s(2,6)
            s(3,3)=12.d0*z1/(dl*z2)
            s(3,5)=-6.d0*z1/z2
            s(3,9)=s(3,3)
            s(3,11)=s(3,5)
            s(4,4)=um*(xi11+xi22)/dl
            s(4,10)=-s(4,4)
            s(5,5)=z3/(dl*z2)
            s(5,9)=6.d0*z1/z2
            s(5,11)=-2.d0*e*xi22*(72.d0*(e*xi22)**2-
     &              (xk*um*a)**2*dl**4-
     &              30.d0*xk*um*a*dl*dl*e*xi22)/(dl*z2)
            s(6,6)=y3/(dl*y2)
            s(6,8)=-6.d0*y1/y2
            s(6,12)=-2.d0*e*xi11*(-(xk*um*a)**2*dl**4-
     &              30.d0*xk*um*a*dl*dl*e*xi11+
     &              72.d0*(e*xi11)**2)/(dl*y2)
            s(1,7)=-s(1,1)
            s(7,7)=s(1,1)
            s(8,8)=12.d0*y1/(dl*y2)
            s(8,12)=-6.d0*y1/y2
            s(9,9)=12.d0*z1/(dl*z2)
            s(9,11)=6.d0*z1/z2
            s(10,10)=s(4,4)
            s(11,11)=z3/(dl*z2)
            s(12,12)=y3/(dl*y2)
!
!           completing the symmetric part
!
            do i=1,12
               do j=1,i
                  s(i,j)=s(j,i)
               enddo
            enddo
!
!           12 x 12 transformation matrix
!
            do i=1,12
               do j=1,12
                  tmg(i,j)=0.d0
               enddo
            enddo
            do i=1,3
               do j=1,3
                  tmg(i,j)=tm(i,j)
                  tmg(i+3,j+3)=tm(i,j)
                  tmg(i+6,j+6)=tm(i,j)
                  tmg(i+9,j+9)=tm(i,j)
               enddo
            enddo
!
!           stiffness matrix in global coordinates: S = T^T*S'*T
!
            do i=1,12
               do j=1,12
                  sg(i,j)=0.d0
                  do k=1,12
                     sg(i,j)=sg(i,j)+s(i,k)*tmg(k,j)
                  enddo
               enddo
            enddo
!
!           only upper triangular matrix
!
            do i=1,12
               do j=i,12
                  s(i,j)=0.d0
                  do k=1,12
                     s(i,j)=s(i,j)+tmg(k,i)*sg(k,j)
                  enddo
               enddo
            enddo
!
         endif
!
      endif
!
      return
      end


! Copyright © 2021, UChicago Argonne, LLC, OPEN SOURCE LICENSE
! See (root dir/)LICENSE.TXT

!  PGAS-FMO Proxy Application
!  Written by Graham D. Fletcher, Computational Science Division,
!  Argonne National Laboratory

!  GPU offload version (0.1)
!  Models
!  - Fragments are He atoms
!  - The fragment basis is a contracted s-type GTO (used uncontracted)
!  - The density is just the product of the contraction weights
!  Assumptions
!  - The fragment basis sets and geometries are replicated
!  - The fragment densities are stored in a PGAS array
!  - The D*S factors for the intermediate coulomb approximation
!    are re-computed on-the-fly
!  Implementations
!  - 1 rank per compute process group
!  - Variable number of fragments per group
!
!  References
!  The basic method-
!  [1] D.G. Fedorov, K. Kitaura, J. Chem. Phys. 120, 6832-6840(2004)
!  The electrostatic approximations (long-range and intermediate-range -
!  eqns. (12) and (13), respectively)-
!  [2] T. Nakano, et al, Chemical Physics Letters 351 (2002) 475–480

 module pgasfmo_params
 parameter  ( pi = 3.1415926535897931d0 )
 real(8)      sqrpi2
 parameter  ( sqrpi2 = ( pi**( -0.5d0 ) )*2.0d0 )
 real(8)      dtol,          rcut
 parameter  ( dtol= 1.0d-10, rcut= 1.0d-12 )
 real(8)      tobohrs
 parameter  ( tobohrs = 1.889725987722d0 )
 end module pgasfmo_params

 module pgasfmo_info
 implicit   none
 integer(4) num_proc, myrank, errcon
 integer(4) mpi_comm_compute
 integer    num_comp
 integer,   allocatable ::  pgas_map( : )
 end module pgasfmo_info

 program   pgas_fmo
 use       pgasfmo_params
 use       pgasfmo_info
 implicit  none
 integer   nfrag,ngauss,myfrag,ifrag,jfrag,nfrag_me, i,j,k,l
 real(8),  allocatable ::  xpnt( : )
 real(8),  allocatable ::  coef( : )
 real(8),  allocatable ::  geom( : , : )
 real(8),  allocatable ::  fock( : , : , : )
 real(8),  allocatable ::  dens( : , : )
 real(8)   rmedium,rlong, eri,rsep,mullpop,sum,ovl,ptch,potev

 call pgasfmo_init

 if ( myrank == 0 ) read *,  ngauss, nfrag

 call pgasfmo_bcast( 'i', nfrag, 1  )
 call pgasfmo_bcast( 'i', ngauss, 1 )

 allocate( xpnt( ngauss ) )
 allocate( coef( ngauss ) )
 allocate( geom( 3, nfrag ) )

 if ( myrank == 0 ) then
!  read the GTO exponents and contraction coefficients
 read *,  ( xpnt( i ), coef( i ), i = 1, ngauss )

!  read intermediate and long-range inter-fragment separation cutoffs
!  and the (fake) Mulliken population charge
 read *,  rmedium, rlong, mullpop

!  read the geometry
 do  i  =  1,  nfrag
 read *,  ( geom( j, i ), j = 1, 3 )
 end do

 end if  !  master input

!  broadcast input data to all compute ranks
 call pgasfmo_bcast( 'd', rmedium, 1  )
 call pgasfmo_bcast( 'd',   rlong, 1  )
 call pgasfmo_bcast( 'd', mullpop, 1  )
 call pgasfmo_bcast( 'd', xpnt, ngauss  )
 call pgasfmo_bcast( 'd', coef, ngauss  )
 call pgasfmo_bcast( 'd', geom, 3*nfrag )

!  normalize the primitive GTO weights
 do i = 1, ngauss
 coef( i ) = coef( i )*( ( 2.0d0*xpnt( i ) )**0.75d0 )
 end do

!  scale the geometry to Bohrs for energy calculations in AU
 do  i  =  1,  nfrag
 geom( 1, i )  =  geom( 1, i )*tobohrs
 geom( 2, i )  =  geom( 2, i )*tobohrs
 geom( 3, i )  =  geom( 3, i )*tobohrs
 end do
 rmedium = rmedium * tobohrs
 rlong   = rlong   * tobohrs

!  create the PGAS array to hold the fragment densities
 call pgasfmo_create( ngauss**2, nfrag )

 nfrag_me = pgas_map( myrank+1 ) - pgas_map( myrank )
 allocate( fock( ngauss, ngauss, nfrag_me ) )

 do  i  =  1,  nfrag_me
 do  j  =  1,  ngauss
 do  k  =  1,  ngauss
 fock( k, j, i )  =  0.0d0
 end do
 end do
 end do

!  make the density - this could be input
 allocate( dens( ngauss, ngauss ) )
 do  i  =  1,  ngauss
 do  j  =  1,  i
 dens( i, j ) = coef( i ) * coef( j ) !*2.0d0
 dens( j, i ) = dens( i, j )
 end do
 end do

!  fill the PGAS array from each group
 do myfrag = pgas_map( myrank ), pgas_map( myrank+1 ) - 1
 call pgasfmo_put( myfrag, ngauss**2, dens )   ! local PUT
 end do

!  sync to ensure the array is filled before use
 call pgasfmo_sync()

!  Main loops over fragments, compute the e-e potential
 do ifrag = 1, nfrag_me
 myfrag = ifrag + pgas_map( myrank ) - 1
 do jfrag = 1, nfrag

!  compute the inter-fragment separation
!  we would compute and store the fragment centers-of-mass, above
!  here, the fragments are He atoms so we just use their coordinates
  rsep = sqrt( ( geom( 1, jfrag ) - geom( 1, myfrag ) )**2  &
       +       ( geom( 2, jfrag ) - geom( 2, myfrag ) )**2  &
       +       ( geom( 3, jfrag ) - geom( 3, myfrag ) )**2  )

!  begin compute kernel
  do  i  =  1,  ngauss
  do  j  =  1,  ngauss
!  options for computing the potential
  if ( rsep > rlong ) then
!  first, the point-charge approximation (eq.13 of [2])
   fock( i, j, ifrag ) = fock( i, j, ifrag ) + mullpop*ptch( myfrag,jfrag, i,j, xpnt, geom )
  else  if ( rsep > rmedium ) then
!  intermediate, coulomb approximation (eq.12 of [2])
   call pgasfmo_get( jfrag, ngauss**2, dens )
!$OMP TARGET MAP(TO:myfrag,ifrag,jfrag,i,j,ngauss,geom,xpnt,dens) MAP(TOFROM:fock)
!$OMP TEAMS DISTRIBUTE
   do  k  =  1,  ngauss
!  make (density * overlap)_kk for jfrag
   sum = 0.0d0
   do  l  =  1,  ngauss
   sum = sum + dens( k, l )*ovl( jfrag, l,k, xpnt, geom )
   end do
!$OMP ATOMIC
   fock( i, j, ifrag ) = fock( i, j, ifrag ) + sum*eri( myfrag,jfrag, i,j,k,k, xpnt, geom )
   end do
!$OMP END TEAMS DISTRIBUTE
!$OMP END TARGET
  else
!  full/explicit calculation (2nd term in curly brackets, RHS, eq.5 of [1])
   call pgasfmo_get( jfrag, ngauss**2, dens )
!$OMP TARGET MAP(TO:myfrag,ifrag,jfrag,i,j,ngauss,geom,xpnt,dens) MAP(TOFROM:fock)
!$OMP TEAMS DISTRIBUTE COLLAPSE(2)
   do  k  =  1,  ngauss
   do  l  =  1,  ngauss
!$OMP ATOMIC
   fock( i, j, ifrag ) = fock( i, j, ifrag ) + dens( k, l )*eri( myfrag,jfrag, i,j,k,l, xpnt, geom )
   end do  ;  end do
!$OMP END TEAMS DISTRIBUTE
!$OMP END TARGET
  end if
  end do  ;  end do     ! fock matrix elements
! end of compute kernel

 end do  ! all fragments (monomers)
 end do  ! my fragments

!  compute total interaction energy (eq.6 of [1]) - mainly for validation
 potev  =  0.0d0
 do ifrag = 1, nfrag_me
 myfrag = ifrag + pgas_map( myrank ) - 1
 call pgasfmo_get( myfrag, ngauss**2, dens )
 do  i  =  1,  ngauss
 do  j  =  1,  ngauss
 potev  =  potev  +  fock( i, j, ifrag )*dens( i, j )
 end do  ;  end do
 end do
 call pgasfmo_gsumf( potev, 1 )
 if ( myrank == 0 ) print *,'V= ', potev !*0.25d0

 deallocate( dens )
 deallocate( fock )
 deallocate( geom )
 deallocate( coef )
 deallocate( xpnt )
 call pgasfmo_end()
 end program pgas_fmo

!OMP DECLARE TARGET
 real(8)    function eri( ifrag,jfrag, ib,jb,kb,lb, xpnt, geom )
 use        pgasfmo_params
 implicit   none
 integer    ifrag,jfrag, i,j,k,l
 real(8)    xpnt(*), geom(3,*)
 integer    ib,jb,kb,lb
 real(8)    aij,dij,xij,yij,zij, akl,dkl, aijkl,tt,f0t

 i = ifrag    !  formula is left
 j = ifrag    !   general for later
 k = jfrag    !   extension, see also
 l = jfrag    !   ptch() and ovl()
 eri = 0.0d0
 aij = 1.0d0/( xpnt( ib ) + xpnt( jb ) )
 dij = exp( -xpnt( ib )*xpnt( jb )*aij*  &
     ( ( geom( 1, i ) - geom( 1, j ) )**2   &
     + ( geom( 2, i ) - geom( 2, j ) )**2   &
     + ( geom( 3, i ) - geom( 3, j ) )**2  )  )*( aij**1.5d0 )
 if ( abs( dij ) > dtol ) then
 xij = aij*( xpnt( ib )*geom( 1, i ) + xpnt( jb )*geom( 1, j ) )
 yij = aij*( xpnt( ib )*geom( 2, i ) + xpnt( jb )*geom( 2, j ) )
 zij = aij*( xpnt( ib )*geom( 3, i ) + xpnt( jb )*geom( 3, j ) )
 akl = 1.0d0/( xpnt( kb ) + xpnt( lb ) )
 dkl = dij*exp( -xpnt( kb )*xpnt( lb )*akl*  &
     ( ( geom( 1, k ) - geom( 1, l ) )**2   &
     + ( geom( 2, k ) - geom( 2, l ) )**2   &
     + ( geom( 3, k ) - geom( 3, l ) )**2  )  )*( akl**1.5d0 )
 if ( abs( dkl ) > dtol ) then
 aijkl = ( xpnt( ib ) + xpnt( jb ) )*( xpnt( kb ) + xpnt( lb ) )  &
       / ( xpnt( ib ) + xpnt( jb )  +  xpnt( kb ) + xpnt( lb ) )
 tt = aijkl*( ( xij -akl*( xpnt( kb )*geom( 1, k ) + xpnt( lb )*geom( 1, l ) ) )**2  &
            + ( yij -akl*( xpnt( kb )*geom( 2, k ) + xpnt( lb )*geom( 2, l ) ) )**2  &
            + ( zij -akl*( xpnt( kb )*geom( 3, k ) + xpnt( lb )*geom( 3, l ) ) )**2  )
 f0t  =  sqrpi2
 if ( tt > rcut )  f0t  =  ( tt**( -0.5d0 ) )*erf( sqrt(tt) )
 eri  =  dkl*f0t*sqrt(aijkl)
 end if
 end if
 end function eri
!OMP END DECLARE TARGET

 real(8)    function ptch( ifrag,jfrag, ib,jb, xpnt, geom )
 use        pgasfmo_params
 implicit   none
 integer    ifrag,jfrag, i,j
 real(8)    xpnt(*), geom(3,*)
 integer    ib,jb
 real(8)    eij,aij,ovl,xij,yij,zij, tt,f0t

 ptch  =  0.0d0
 i = ifrag
 j = ifrag
 eij = xpnt( ib ) + xpnt( jb )
 aij = 1.0d0/eij
 ovl = exp( -xpnt( ib )*xpnt( jb )*aij*  &
     ( ( geom( 1, i ) - geom( 1, j ) )**2   &
     + ( geom( 2, i ) - geom( 2, j ) )**2   &
     + ( geom( 3, i ) - geom( 3, j ) )**2  )  )*( aij**1.5d0 )
 if ( abs( ovl ) > dtol ) then
 xij = aij*( xpnt( ib )*geom( 1, i ) + xpnt( jb )*geom( 1, j ) )
 yij = aij*( xpnt( ib )*geom( 2, i ) + xpnt( jb )*geom( 2, j ) )
 zij = aij*( xpnt( ib )*geom( 3, i ) + xpnt( jb )*geom( 3, j ) )
 tt = (  ( xij -geom( 1, jfrag ) )**2  &
      +  ( yij -geom( 2, jfrag ) )**2  &
      +  ( zij -geom( 3, jfrag ) )**2  )*eij
 f0t  =  sqrpi2
 if ( tt > rcut )  f0t  =  ( tt**( -0.5d0 ) )*erf( sqrt(tt) )
 ptch  =  ovl*f0t*sqrt( eij )
 end if
 end function ptch

!OMP DECLARE TARGET
 real(8)    function ovl( jfrag, ib,jb, xpnt, geom )
 use        pgasfmo_params
 implicit   none
 integer    jfrag, i,j
 real(8)    xpnt(*), geom(3,*)
 integer    ib,jb
 real(8)    aij

 i = jfrag
 j = jfrag
 aij = 1.0d0/( xpnt( ib ) + xpnt( jb ) )
 ovl = exp( -xpnt( ib )*xpnt( jb )*aij*  &
     ( ( geom( 1, i ) - geom( 1, j ) )**2   &
     + ( geom( 2, i ) - geom( 2, j ) )**2   &
     + ( geom( 3, i ) - geom( 3, j ) )**2  )  )*( aij**1.5d0 )
 end function ovl
!OMP END DECLARE TARGET

 subroutine  pgasfmo_init
 use         pgasfmo_info
 implicit    none
 include      'mpif.h'
 integer     i
 integer(4)  group_world, group_comp
 integer(4), allocatable :: ranks( : )
 call mpi_init( errcon )
 call mpi_comm_rank( mpi_comm_world, myrank,   errcon )
 call mpi_comm_size( mpi_comm_world, num_proc, errcon )
 if ( mod( num_proc, 2 ) .ne. 0 ) stop '!odd rank count!'
 num_comp = num_proc/2
 if ( myrank == 0 ) print *,'total (compute) ranks= ',num_comp
!     create compute process communicator to enable
!     collective communications between them
 allocate( ranks( 0 : num_comp - 1 ) )
 do i = 0, num_comp - 1
 ranks(i) = i
 end do
 call mpi_comm_group( mpi_comm_world, group_world, errcon )
 call mpi_group_incl( group_world, num_comp, ranks,   &
                      group_comp, errcon )
 call mpi_comm_create( mpi_comm_world, group_comp,   &
                       mpi_comm_compute, errcon )
 deallocate( ranks )
 if ( myrank >= num_comp ) then
 call pgasfmo_server()
 else
 allocate( pgas_map( 0 : num_comp ) )
 call pgasfmo_sync()
 end if
 end subroutine pgasfmo_init

 subroutine    pgasfmo_bcast( chtype, buff, len )
 use           pgasfmo_info
 implicit      none
 include      'mpif.h'
 character(1)  chtype
 integer       buff(*), len
 integer(4)    type, from, len4
 if ( chtype == 'i' ) then
 type = mpi_integer4
 else if ( chtype == 'd' ) then
 type = mpi_real8
 else
!       error
 end if
 len4 = len
 from = 0
 call mpi_bcast( buff, len4, type, from, mpi_comm_compute, errcon )
 end subroutine  pgasfmo_bcast

 subroutine  pgasfmo_gsumf( buff, datalen )
 use         pgasfmo_info
 implicit    none
 include    'mpif.h'
 real(8)     buff(*)
 integer     datalen
 integer(4)  len4, type, oper
 integer     maxrcv
 parameter  (maxrcv = 16384 )
 real(8)     rcv( maxrcv )
 integer     i,j,loc,npass,len
 type = mpi_real8
 oper = mpi_sum
 npass = 1 + ( datalen - 1)/maxrcv
 loc  = 1
 len4 = maxrcv
 do i = 1, npass
 if ( i == npass ) len4 = datalen - maxrcv*(npass-1)
 call mpi_allreduce( buff( loc ), rcv, len4, type,  &
                     oper, mpi_comm_compute, errcon  )
 do j = 1, len4
 buff( loc + j - 1 ) = rcv( j )
 end do
 loc = loc + len4
 end do
 end subroutine pgasfmo_gsumf

 subroutine pgasfmo_sync()
 use        pgasfmo_info
 implicit   none
 call mpi_barrier( mpi_comm_compute, errcon )
 end subroutine pgasfmo_sync

 subroutine pgasfmo_create( nrows, ncols )
 use        pgasfmo_info
 implicit   none
 include    'mpif.h'
 integer    nrows, ncols
 integer    mincol,lftcol,icol,i
 integer(4) message(3)
!  create the domain decomposition (map columns to ranks)
 mincol = ncols/num_comp
 lftcol = mod(ncols,num_comp)
 icol = 1
 do i = 0, num_comp
 pgas_map( i ) = icol
 icol = icol + mincol
 if ( i < lftcol ) icol = icol + 1
 end do
 message(1) = 0          ! = do a CREATE
 message(2) = pgas_map( myrank+1 ) - pgas_map( myrank )
 message(3) = nrows
 call pgasfmo_send( message, 12, myrank + num_comp )
 call mpi_barrier( mpi_comm_world, errcon )
 end subroutine pgasfmo_create

 subroutine pgasfmo_locate( pgas_addr, data_loc, item )
 use        pgasfmo_info
 implicit   none
 integer    pgas_addr, data_loc, item
 integer    i

! scan the PGAS mapping of the global address 'pgas_addr' to find the
!  corresponding data 'item' on rank 'data_loc'
 do i = 0, num_comp - 1
 if ( pgas_addr >= pgas_map( i ) .and. pgas_addr <= pgas_map( i+1 ) -1 ) then
 data_loc = i
 item = pgas_addr - pgas_map( i ) + 1
 end if
 end do
 end subroutine pgasfmo_locate

 subroutine pgasfmo_get( pgas_addr, len, buff )
 use        pgasfmo_info
 implicit   none
 integer    pgas_addr, len, item, data_loc
 real(8)    buff(*)
 integer(4) message(3)
 call pgasfmo_locate( pgas_addr, data_loc, item )
 message(1) = 1          ! = do a GET
 message(2) = item
 message(3) = len
 call pgasfmo_send( message, 12, data_loc + num_comp )
 call pgasfmo_recv( buff, len*8, data_loc + num_comp )
 end subroutine pgasfmo_get

 subroutine pgasfmo_put( pgas_addr, len, buff )
 use        pgasfmo_info
 implicit   none
 integer    pgas_addr, len, item, data_loc
 real(8)    buff(*)
 integer(4) message(3)
 call pgasfmo_locate( pgas_addr, data_loc, item )
 message(1) = 2          ! = do a PUT
 message(2) = item
 message(3) = len
 call pgasfmo_send( message, 12, data_loc + num_comp )
 call pgasfmo_send( buff, len*8, data_loc + num_comp )
 end subroutine pgasfmo_put

 subroutine pgasfmo_send( sendbuff, len, to )
 implicit   none
 include    'mpif.h'
 integer    sendbuff(*)
 integer    len, to
 integer(4) len4, mpityp, to4, msgtag, errcon
 msgtag = 270908
 mpityp = mpi_byte
 len4   = len
 to4    = to
 call mpi_ssend( sendbuff, len4, mpityp, to4, msgtag,  &
                 mpi_comm_world, errcon )
 end subroutine pgasfmo_send

 subroutine pgasfmo_recv( recvbuff, len, from )
 implicit   none
 include    'mpif.h'
 real(8)    recvbuff(*)
 integer    len, from
 integer(4) len4,mpityp,from4,msgtag,status(mpi_status_size),errcon
 msgtag = 270908
 mpityp = mpi_byte
 len4   = len
 from4  = from
 call mpi_recv( recvbuff, len4, mpityp, from4, msgtag,  &
                mpi_comm_world, status, errcon )
 end subroutine pgasfmo_recv

 subroutine pgasfmo_rcvany( recvbuff, len, from )
 implicit   none
 include    'mpif.h'
 integer    recvbuff(*)
 integer    len, from
 integer(4) len4,mpityp,msgtag,status(mpi_status_size),errcon
 msgtag = 270908
 mpityp = mpi_byte
 len4   = len
 call mpi_recv( recvbuff, len4, mpityp, mpi_any_source, msgtag,  &
                mpi_comm_world, status, errcon )
 from = status(mpi_source)
 end subroutine pgasfmo_rcvany

 subroutine pgasfmo_server
 implicit   none
 include    'mpif.h'
 logical    serving
 integer(4) message(3), errcon
 integer    from,task,item,len
 real(8), allocatable :: pgasfmo_data( : , : )   ! FMO1 density

 serving = .true.
 do while ( serving )
  call pgasfmo_rcvany( message, 12, from )
  task = message(1)
  item = message(2)
   len = message(3)
       if ( task == 0 ) THEN
   allocate( pgasfmo_data( len, item ) )  !  create local part of the PGAS
   call mpi_barrier( mpi_comm_world, errcon )
  else if ( task == 1 ) then        !  GET
   call pgasfmo_send( pgasfmo_data(1,item), len*8, from )
  else if ( task == 2 ) then        !  PUT
   call pgasfmo_recv( pgasfmo_data(1,item), len*8, from )
  else if ( task == 3 ) then
   serving = .false.                !  done serving
  end if
 end do
 call mpi_barrier( mpi_comm_world, errcon )
 deallocate( pgasfmo_data )
 call mpi_finalize( errcon )
 stop   ! server does not return to the main program
 end subroutine pgasfmo_server

 subroutine pgasfmo_end      !  called by compute ranks
 include    'mpif.h'
 integer(4) num_proc, myrank, errcon
 integer(4) message(3)
 call mpi_comm_rank( mpi_comm_world, myrank, errcon )
 call mpi_comm_size( mpi_comm_world, num_proc, errcon )
 message(1) = 3      ! = terminate server
 call pgasfmo_send( message, 12, myrank + num_proc/2 )
 call mpi_barrier( mpi_comm_world, errcon )
 call mpi_finalize( errcon )
 end subroutine pgasfmo_end


      SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR)
C***BEGIN PROLOGUE  ZBIRY
C***DATE WRITTEN   830501   (YYMMDD)
C***REVISION DATE  890801   (YYMMDD)
C***CATEGORY NO.  B5K
C***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE  TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z
C***DESCRIPTION
C
C                      ***A DOUBLE PRECISION ROUTINE***
C         ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR
C         ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
C         KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)*
C         DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN
C         BOTH THE LEFT AND RIGHT HALF PLANES WHERE
C         ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA).
C         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
C         MATHEMATICAL FUNCTIONS (REF. 1).
C
C         INPUT      ZR,ZI ARE DOUBLE PRECISION
C           ZR,ZI  - Z=CMPLX(ZR,ZI)
C           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1
C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
C                    KODE= 1  RETURNS
C                             BI=BI(Z)                 ON ID=0 OR
C                             BI=DBI(Z)/DZ             ON ID=1
C                        = 2  RETURNS
C                             BI=CEXP(-AXZTA)*BI(Z)     ON ID=0 OR
C                             BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE
C                             ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA)
C                             AND AXZTA=ABS(XZTA)
C
C         OUTPUT     BIR,BII ARE DOUBLE PRECISION
C           BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
C                    KODE
C           IERR   - ERROR FLAG
C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C                    IERR=1, INPUT ERROR   - NO COMPUTATION
C                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z)
C                            TOO LARGE ON KODE=1
C                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED
C                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
C                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY
C                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION
C                            COMPLETE LOSS OF ACCURACY BY ARGUMENT
C                            REDUCTION
C                    IERR=5, ERROR              - NO COMPUTATION,
C                            ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C         BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL
C         FUNCTIONS BY
C
C                BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) )
C               DBI(Z)=C *  Z  * ( I(-2/3,ZTA) + I(2/3,ZTA) )
C                               C=1.0/SQRT(3.0)
C                             ZTA=(2/3)*Z**(3/2)
C
C         WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
C
C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
C         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
C         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
C         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
C         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
C         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
C         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
C         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
C         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
C         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
C         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
C         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
C         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
C         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
C         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
C         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
C         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
C         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
C         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
C         MACHINES.
C
C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
C         OR -PI/2+P.
C
C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C                 COMMERCE, 1955.
C
C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C                 1018, MAY, 1985
C
C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C                 MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED  ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH
C***END PROLOGUE  ZBIRY
C     COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
      DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR,
     * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2,
     * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5,
     * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I,
     * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS
      INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
      DIMENSION CYR(2), CYI(2)
      DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01,
     * 6.14926627446000736D-01,4.48288357353826359D-01,
     * 5.77350269189625765D-01,3.14159265358979324D+00/
      DATA CONER, CONEI /1.0D0,0.0D0/
C***FIRST EXECUTABLE STATEMENT  ZBIRY
      IERR = 0
      NZ=0
      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (IERR.NE.0) RETURN
      AZ = ZABS(CMPLX(ZR,ZI,kind=KIND(1.0D0)))
      TOL = DMAX1(D1MACH(4),1.0D-18)
      FID = DBLE(FLOAT(ID))
      IF (AZ.GT.1.0E0) GO TO 70
C-----------------------------------------------------------------------
C     POWER SERIES FOR CABS(Z).LE.1.
C-----------------------------------------------------------------------
      S1R = CONER
      S1I = CONEI
      S2R = CONER
      S2I = CONEI
      IF (AZ.LT.TOL) GO TO 130
      AA = AZ*AZ
      IF (AA.LT.TOL/AZ) GO TO 40
      TRM1R = CONER
      TRM1I = CONEI
      TRM2R = CONER
      TRM2I = CONEI
      ATRM = 1.0D0
      STR = ZR*ZR - ZI*ZI
      STI = ZR*ZI + ZI*ZR
      Z3R = STR*ZR - STI*ZI
      Z3I = STR*ZI + STI*ZR
      AZ3 = AZ*AA
      AK = 2.0D0 + FID
      BK = 3.0D0 - FID - FID
      CK = 4.0D0 - FID
      DK = 3.0D0 + FID + FID
      D1 = AK*DK
      D2 = BK*CK
      AD = DMIN1(D1,D2)
      AK = 24.0D0 + 9.0D0*FID
      BK = 30.0D0 - 9.0D0*FID
      DO 30 K=1,25
        STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
        TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
        TRM1R = STR
        S1R = S1R + TRM1R
        S1I = S1I + TRM1I
        STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
        TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
        TRM2R = STR
        S2R = S2R + TRM2R
        S2I = S2I + TRM2I
        ATRM = ATRM*AZ3/AD
        D1 = D1 + AK
        D2 = D2 + BK
        AD = DMIN1(D1,D2)
        IF (ATRM.LT.TOL*AD) GO TO 40
        AK = AK + 18.0D0
        BK = BK + 18.0D0
   30 CONTINUE
   40 CONTINUE
      IF (ID.EQ.1) GO TO 50
      BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I)
      BII = C1*S1I + C2*(ZR*S2I+ZI*S2R)
      IF (KODE.EQ.1) RETURN
      CALL ZSQRT(ZR, ZI, STR, STI)
      ZTAR = TTH*(ZR*STR-ZI*STI)
      ZTAI = TTH*(ZR*STI+ZI*STR)
      AA = ZTAR
      AA = -DABS(AA)
      EAA = DEXP(AA)
      BIR = BIR*EAA
      BII = BII*EAA
      RETURN
   50 CONTINUE
      BIR = S2R*C2
      BII = S2I*C2
      IF (AZ.LE.TOL) GO TO 60
      CC = C1/(1.0D0+FID)
      STR = S1R*ZR - S1I*ZI
      STI = S1R*ZI + S1I*ZR
      BIR = BIR + CC*(STR*ZR-STI*ZI)
      BII = BII + CC*(STR*ZI+STI*ZR)
   60 CONTINUE
      IF (KODE.EQ.1) RETURN
      CALL ZSQRT(ZR, ZI, STR, STI)
      ZTAR = TTH*(ZR*STR-ZI*STI)
      ZTAI = TTH*(ZR*STI+ZI*STR)
      AA = ZTAR
      AA = -DABS(AA)
      EAA = DEXP(AA)
      BIR = BIR*EAA
      BII = BII*EAA
      RETURN
C-----------------------------------------------------------------------
C     CASE FOR CABS(Z).GT.1.0
C-----------------------------------------------------------------------
   70 CONTINUE
      FNU = (1.0D0+FID)/3.0D0
C-----------------------------------------------------------------------
C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
C-----------------------------------------------------------------------
      K1 = I1MACH(15)
      K2 = I1MACH(16)
      R1M5 = D1MACH(5)
      K = MIN0(IABS(K1),IABS(K2))
      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
      K1 = I1MACH(14) - 1
      AA = R1M5*DBLE(FLOAT(K1))
      DIG = DMIN1(AA,18.0D0)
      AA = AA*2.303D0
      ALIM = ELIM + DMAX1(-AA,-41.45D0)
      RL = 1.2D0*DIG + 3.0D0
      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
C-----------------------------------------------------------------------
C     TEST FOR RANGE
C-----------------------------------------------------------------------
      AA=0.5D0/TOL
      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
      AA=DMIN1(AA,BB)
      AA=AA**TTH
      IF (AZ.GT.AA) GO TO 260
      AA=DSQRT(AA)
      IF (AZ.GT.AA) IERR=3
      CALL ZSQRT(ZR, ZI, CSQR, CSQI)
      ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
      ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
C-----------------------------------------------------------------------
C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
C-----------------------------------------------------------------------
      SFAC = 1.0D0
      AK = ZTAI
      IF (ZR.GE.0.0D0) GO TO 80
      BK = ZTAR
      CK = -DABS(BK)
      ZTAR = CK
      ZTAI = AK
   80 CONTINUE
      IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90
      ZTAR = 0.0D0
      ZTAI = AK
   90 CONTINUE
      AA = ZTAR
      IF (KODE.EQ.2) GO TO 100
C-----------------------------------------------------------------------
C     OVERFLOW TEST
C-----------------------------------------------------------------------
      BB = DABS(AA)
      IF (BB.LT.ALIM) GO TO 100
      BB = BB + 0.25D0*DLOG(AZ)
      SFAC = TOL
      IF (BB.GT.ELIM) GO TO 190
  100 CONTINUE
      FMR = 0.0D0
      IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
      FMR = PI
      IF (ZI.LT.0.0D0) FMR = -PI
      ZTAR = -ZTAR
      ZTAI = -ZTAI
  110 CONTINUE
C-----------------------------------------------------------------------
C     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
C     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI
C-----------------------------------------------------------------------
      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL,
     * ELIM, ALIM)
      IF (NZ.LT.0) GO TO 200
      AA = FMR*FNU
      Z3R = SFAC
      STR = DCOS(AA)
      STI = DSIN(AA)
      S1R = (STR*CYR(1)-STI*CYI(1))*Z3R
      S1I = (STR*CYI(1)+STI*CYR(1))*Z3R
      FNU = (2.0D0-FID)/3.0D0
      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL,
     * ELIM, ALIM)
      CYR(1) = CYR(1)*Z3R
      CYI(1) = CYI(1)*Z3R
      CYR(2) = CYR(2)*Z3R
      CYI(2) = CYI(2)*Z3R
C-----------------------------------------------------------------------
C     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
C-----------------------------------------------------------------------
      CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI)
      S2R = (FNU+FNU)*STR + CYR(2)
      S2I = (FNU+FNU)*STI + CYI(2)
      AA = FMR*(FNU-1.0D0)
      STR = DCOS(AA)
      STI = DSIN(AA)
      S1R = COEF*(S1R+S2R*STR-S2I*STI)
      S1I = COEF*(S1I+S2R*STI+S2I*STR)
      IF (ID.EQ.1) GO TO 120
      STR = CSQR*S1R - CSQI*S1I
      S1I = CSQR*S1I + CSQI*S1R
      S1R = STR
      BIR = S1R/SFAC
      BII = S1I/SFAC
      RETURN
  120 CONTINUE
      STR = ZR*S1R - ZI*S1I
      S1I = ZR*S1I + ZI*S1R
      S1R = STR
      BIR = S1R/SFAC
      BII = S1I/SFAC
      RETURN
  130 CONTINUE
      AA = C1*(1.0D0-FID) + FID*C2
      BIR = AA
      BII = 0.0D0
      RETURN
  190 CONTINUE
      IERR=2
      NZ=0
      RETURN
  200 CONTINUE
      IF(NZ.EQ.(-1)) GO TO 190
      NZ=0
      IERR=5
      RETURN
  260 CONTINUE
      IERR=4
      NZ=0
      RETURN
      END


      SUBROUTINE SAMLMU(X,N,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  SAMPLE L-MOMENTS OF A DATA ARRAY
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING
C                  ORDER.
C  N      * INPUT* NUMBER OF DATA VALUES
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. CONTAINS THE SAMPLE L-MOMENTS,
C                  STORED AS DESCRIBED BELOW.
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 100.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXMOM=100)
      DOUBLE PRECISION X(N),XMOM(NMOM),COEF(2,MAXMOM)
      DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/
C
      IF(NMOM.GT.MAXMOM)GOTO 1000
      DN=N
      DO 10 J=1,NMOM
   10 XMOM(J)=ZERO
      IF(NMOM.LE.2)GOTO 100
C
C         UNBIASED ESTIMATES OF L-MOMENTS -- THE 'DO 30' LOOP
C         RECURSIVELY CALCULATES DISCRETE LEGENDRE POLYNOMIALS, VIA
C         EQ.(9) OF NEUMAN AND SCHONBACH (1974, INT.J.NUM.METH.ENG.)
C
      DO 20 J=3,NMOM
      TEMP=ONE/DFLOAT((J-1)*(N-J+1))
      COEF(1,J)=DFLOAT(J+J-3)*TEMP
      COEF(2,J)=DFLOAT((J-2)*(N+J-2))*TEMP
   20 CONTINUE
      TEMP=-DN-ONE
      CONST=ONE/(DN-ONE)
      NHALF=N/2
      DO 40 I=1,NHALF
      TEMP=TEMP+TWO
      XI=X(I)
      XII=X(N+1-I)
      TERMP=XI+XII
      TERMN=XI-XII
      XMOM(1)=XMOM(1)+TERMP
      S1=ONE
      S=TEMP*CONST
      XMOM(2)=XMOM(2)+S*TERMN
      DO 30 J=3,NMOM,2
      S2=S1
      S1=S
      S=COEF(1,J)*TEMP*S1-COEF(2,J)*S2
      XMOM(J)=XMOM(J)+S*TERMP
      IF(J.EQ.NMOM)GOTO 30
      JJ=J+1
      S2=S1
      S1=S
      S=COEF(1,JJ)*TEMP*S1-COEF(2,JJ)*S2
      XMOM(JJ)=XMOM(JJ)+S*TERMN
   30 CONTINUE
   40 CONTINUE
      IF(N.EQ.NHALF+NHALF)GOTO 60
      TERM=X(NHALF+1)
      S=ONE
      XMOM(1)=XMOM(1)+TERM
      DO 50 J=3,NMOM,2
      S=-COEF(2,J)*S
      XMOM(J)=XMOM(J)+S*TERM
   50 CONTINUE
C
C         L-MOMENT RATIOS
C
   60 CONTINUE
      XMOM(1)=XMOM(1)/DN
      IF(XMOM(2).EQ.ZERO)GOTO 1010
      DO 70 J=3,NMOM
   70 XMOM(J)=XMOM(J)/XMOM(2)
      XMOM(2)=XMOM(2)/DN
      RETURN
C
C         AT MOST TWO L-MOMENTS
C
  100 CONTINUE
      SUM1=ZERO
      SUM2=ZERO
      TEMP=-DN+ONE
      DO 110 I=1,N
      SUM1=SUM1+X(I)
      SUM2=SUM2+X(I)*TEMP
      TEMP=TEMP+TWO
  110 CONTINUE
      XMOM(1)=SUM1/DN
      IF(NMOM.EQ.1)RETURN
      XMOM(2)=SUM2/(DN*(DN-ONE))
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      DO 1020 J=1,NMOM
 1020 XMOM(J)=ZERO
      RETURN
C
 7000 FORMAT(' ** WARNING ** ROUTINE SAMLMU :',
     *  ' PARAMETER NMOM INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE SAMLMU :',
     *  ' ALL DATA VALUES EQUAL')
      END