module fslatm_pairwise

implicit none

real*8, parameter :: r0 = 0.1
double precision, parameter :: eps = epsilon(0.0d0)
double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

contains

function linspace(x0, x1, nx) result(xs)

    implicit none

    double precision, intent(in) :: x0,x1
    integer, intent(in) :: nx
    double precision, dimension(nx) :: xs
    integer :: i
    double precision :: step

    step = (x1 - x0) / (nx - 1)
    !!$OMP PARALLEL DO
    do i = 1, nx
        xs(i) = x0 + (i - 1) * step
    enddo
    !!$OMP END PARALLEL DO
end function linspace

function calc_angle(a, b, c) result(angle)
    implicit none
    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c
    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2
    double precision :: cos_angle
    double precision :: angle
    v1 = a - b
    v2 = c - b
    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)
    cos_angle = dot_product(v1,v2)
    ! Clipping
    if (cos_angle > 1.0d0) cos_angle = 1.0d0
    if (cos_angle < -1.0d0) cos_angle = -1.0d0
    angle = acos(cos_angle)
end function calc_angle

function calc_cos_angle(a, b, c) result(cos_angle)
    implicit none
    real*8, intent(in) :: a(3),b(3),c(3)
    real*8 :: v1(3),v2(3)
    real*8 :: cos_angle
    v1 = a - b
    !print *, 'v1 = ', v1
    v2 = c - b
    !print *, 'v2 = ', v2
    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)
    cos_angle = dot_product(v1,v2)
end function calc_cos_angle

function calc_dist(na, coords) result(ds)
    implicit none
    integer, intent(in) :: na
    real*8, intent(in) :: coords(3,na)
    real*8 :: ds(na,na)
    integer :: i,j
    real*8 :: dij
    ds(:,:) = 0.0
    do i = 1,na
        do j = i+1,na
            dij = norm2(coords(:,i)-coords(:,j))
            ds(i,j) = dij
            ds(j,i) = dij
        enddo
    enddo
end function calc_dist

!end module fslatm_math

subroutine calc_sbot(na, coords, zs, z1, z2, z3, rscut, nx, dgrid, sigma, rpower3, ys)
    !use fslatm_math

    implicit none
    integer, intent(in) :: na
    double precision, dimension(3,na), intent(in) :: coords
    integer, dimension(:), intent(in) :: zs
    double precision, intent(in) :: rscut(2)
    integer, intent(in) :: nx
    double precision, intent(in) :: dgrid, sigma, rpower3
    double precision, dimension(nx), intent(out) :: ys
    integer, intent(in) :: z1, z2, z3
    integer, dimension(:), allocatable :: ias1, ias2, ias3
    integer :: nias1, nias2, nias3
    integer :: ia1, ia2, ia3
    double precision :: ds(na,na)
    double precision :: norm
    integer :: i,j,k
    double precision :: d2r,c0,ang,cak,cai,prefactor,r, a0,a1, inv_sigma
    real*8 :: xs(nx),cos_xs(nx)

    ds = calc_dist(na, coords)

    allocate(ias1(na))
    allocate(ias2(na))
    allocate(ias3(na))

    ias1 = 0
    ias2 = 0
    ias3 = 0

    nias1 = 0
    do i = 1, na
        if (int(zs(i)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = i
        endif
    enddo

    nias2 = 0
    do i = 1, na
        if (int(zs(i)).eq.z2) then
            nias2 = nias2 + 1
            ias2(nias2) = i
        endif
    enddo

    nias3 = 0
    do i = 1, na
        if (int(zs(i)).eq.z3) then
            nias3 = nias3 + 1
            ias3(nias3) = i
        endif
    enddo

    d2r = pi/180.0d0
    a0 = -20.0d0 * d2r
    a1 = pi + 20.0d0 * d2r
    xs = linspace(a0, a1, nx)
    prefactor = 1.0d0 / 3.0d0
    c0 = prefactor * (mod(z1,1000)*mod(z2,1000)*mod(z3,1000)) * dgrid
    c0 = c0 / sqrt(2*sigma**2*pi) ! !use normalized gaussian

    ys = 0.0d0
    inv_sigma = -1.0d0 / (2*sigma**2)

    !!$OMP PARALLEL DO
    do i = 1, nx
        cos_xs(i) = cos(xs(i)) * c0
    enddo
    !!$OMP END PARALLEL do

    !!$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
    do ia1 = 1, nias1
        do ia2 = 1, nias2
            if (ias2(ia2).eq.ias1(ia1)) cycle
            if (.not. ((ds(ias2(ia2),ias1(ia1)) > eps) .and. &
                     & (ds(ias2(ia2),ias1(ia1)) <= rscut(1)))) cycle
            do ia3 = 1, nias3
                !if (ds(ias1(ia1),ias3(ia3)) > rscut(1)) cycle
                if (ias2(ia2).eq.ias3(ia3) .or. ias1(ia1).eq.ias3(ia3)) cycle
                if (.not. ((ds(ias2(ia2),ias3(ia3)) > eps) .and. &
                         & (ds(ias2(ia2),ias3(ia3)) <= rscut(1)))) cycle

                    i = ias1(ia1)
                    j = ias2(ia2)
                    k = ias3(ia3)

                    ang = calc_angle(coords(:, i), coords(:, j), coords(:, k))
                    cak = calc_cos_angle(coords(:, i), coords(:, k), coords(:, j))
                    cai = calc_cos_angle(coords(:, k), coords(:, i), coords(:, j))
                    r = ds(i,j) * ds(i,k) * ds(k,j)
                    ys = ys + (c0 + cos_xs*cak*cai)/(r**rpower3) * ( exp((xs-ang)**2 * inv_sigma) )

            enddo
        enddo
    enddo
    !!$OMP END PARALLEL do

    deallocate(ias1)
    deallocate(ias2)
    deallocate(ias3)
end subroutine calc_sbot

subroutine calc_sbot_local(na,coords,zs,ia,ib,z1,z2,z3,rscut,nx,dgrid,sigma,w3,rpower3, ys)
    !use fslatm_math
    implicit none
    integer, intent(in) :: na
    double precision, dimension(3,na), intent(in) :: coords
    integer, dimension(:), intent(in) :: zs
    double precision, intent(in) :: rscut(2)
    integer, intent(in) :: nx,ia,ib
    double precision, intent(in) :: dgrid,sigma, w3, rpower3
    double precision, dimension(nx), intent(out) :: ys
    integer, intent(in) :: z1, z2, z3
    integer, dimension(:), allocatable :: ias1, ias3
    integer :: nias1, nias3
    integer :: ia1, ia2, ia3
    double precision :: ds(na,na)
    double precision :: norm
    integer :: i,j,k
    double precision :: d2r,c0,ang,cak,cai,prefactor,r, a0,a1, inv_sigma
    double precision :: xs(nx),cos_xs(nx)
    !logical :: stop_flag

    ys = 0.0d0
    if (zs(ia).ne.z2) return
    if (ib.gt.0 .and. zs(ib).ne.z1) return ! `ib is defaulted to 0

    ds = calc_dist(na, coords)

    allocate(ias1(na))
    allocate(ias3(na))

    ias1 = 0
    ias3 = 0

    nias1 = 0
    if (ib .gt. 0) then
        if (ib .eq. ia) return
        if (int(zs(ib)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = ib
        endif
    else
        do i = 1, na
            if (zs(i).eq.z1 .and. i.ne.ia) then
                nias1 = nias1 + 1
                ias1(nias1) = i
            endif
        enddo
    endif

    nias3 = 0
    do i = 1, na
        if (int(zs(i)).eq.z3 .and. i.ne.ia) then
            nias3 = nias3 + 1
            ias3(nias3) = i
        endif
    enddo

    d2r = pi/180.0d0
    a0 = -20.0d0 * d2r
    a1 = pi + 20.0d0 * d2r
    xs = linspace(a0, a1, nx)
    prefactor = 1.0d0 ! / 3.0d0
    c0 = prefactor * (mod(z1,1000)*mod(z2,1000)*mod(z3,1000)) * dgrid
    c0 = w3 * c0 / sqrt(2*sigma**2*pi) ! !use normalized gaussian
    inv_sigma = -1.0d0 / (2*sigma**2)

    !!$OMP PARALLEL DO
    do i = 1, nx
        cos_xs(i) = cos(xs(i)) * c0
    enddo
    !!$OMP END PARALLEL do

    !!$OMP PARALLEL DO PRIVATE(i,j,k,ang,cai,cak,r) REDUCTION(+:ys) SCHEDULE(DYNAMIC)
    do ia1 = 1, nias1
        if (ib.gt.0) then
            if (.not. ((ds(ias1(ia1),ia) > eps) .and. &
                     & (ds(ias1(ia1),ia) <= rscut(2)))) cycle
        else
            if (.not. ((ds(ias1(ia1),ia) > eps) .and. &
                     & (ds(ias1(ia1),ia) <= rscut(1)))) cycle
        endif
        do ia3 = 1, nias3
            if (ia.eq.ias3(ia3) .or. ias1(ia1).eq.ias3(ia3)) cycle
            !if (ds(ias1(ia1),ias3(ia3)) > rscut(1)) cycle
            if (.not. ((ds(ia,ias3(ia3)) > eps) .and. &
                     & (ds(ia,ias3(ia3)) <= rscut(1)))) cycle

                ! note that each pair of (i,k) in [i,j,k] can be
                ! considered only once!!
                i = ias1(ia1)
                j = ia
                k = ias3(ia3)

                ang = calc_angle(coords(:, i), coords(:, j), coords(:, k))
                cak = calc_cos_angle(coords(:, i), coords(:, k), coords(:, j))
                cai = calc_cos_angle(coords(:, k), coords(:, i), coords(:, j))
                r = ds(i,j) * ds(i,k) * ds(k,j)
                ys = ys + (c0 + cos_xs*cak*cai)/(r**rpower3) * ( exp((xs-ang)**2 * inv_sigma) )

                !print *, ' in sbot_local (z1!=z3), I,J,K = ', i,j,k, '##', c0, cak, cai, r
                !call check_nan1(nx,ys)

        enddo
    enddo
    !!$OMP END PARALLEL do

    deallocate(ias1)
    deallocate(ias3)

end subroutine calc_sbot_local

subroutine calc_sbop(na, coords, zs, z1, z2, rscut, nx, dgrid, sigma, rpower2, ys)
    !use fslatm_math
    implicit none
    integer, intent(in) :: na
    double precision, dimension(3,na), intent(in) :: coords
    integer, dimension(:), intent(in) :: zs
    double precision, intent(in) :: rscut(2)
    integer, intent(in) :: nx
    double precision, intent(in) :: dgrid,sigma,rpower2
    double precision, dimension(nx), intent(out) :: ys
    integer, intent(in) :: z1, z2
    double precision :: r,racut2
    integer :: i
    integer, dimension(:), allocatable :: ias1, ias2
    integer :: nias1, nias2, ia1,ia2
    double precision, dimension(nx) :: xs
    double precision :: c0
    double precision :: inv_sigma
    double precision, dimension(nx) :: xs0

    allocate(ias1(na))
    allocate(ias2(na))

    ias1 = 0
    ias2 = 0

    nias1 = 0
    do i = 1, na
        if (int(zs(i)).eq.z1) then
            nias1 = nias1 + 1
            ias1(nias1) = i
        endif
    enddo

    nias2 = 0
    do i = 1, na
        if (int(zs(i)).eq.z2) then
            nias2 = nias2 + 1
            ias2(nias2) = i
        endif
    enddo

    xs = linspace(r0, rscut(1), nx)
    ys = 0.0d0

    c0 = mod(z1,1000)*mod(z2,1000)
    c0 = c0 / sqrt(2*sigma**2*pi) ! !use normalized gaussian
    inv_sigma = -0.5d0 / sigma**2
    xs0 = c0/(xs**rpower2) * dgrid
    racut2 = rscut(1)**2

    !!$OMP PARALLEL DO REDUCTION(+:ys)
    do ia1 = 1, nias1
        do ia2 = 1, nias2
            if (ias1(ia1).eq.ias2(ia2)) cycle
            r = sum((coords(:,ias1(ia1)) - coords(:,ias2(ia2)))**2)
            if (r < racut2) ys = ys + xs0 * exp( inv_sigma * (xs - sqrt(r))**2 )

        enddo
    enddo
    !!$OMP END PARALLEL DO

    deallocate(ias1)
    deallocate(ias2)

end subroutine calc_sbop

subroutine calc_sbop_local(coords, zs, ia, ib, z1, z2, rscut, nx, dgrid, sigma, w2,rpower2, ys)
    !use fslatm_math
    implicit none
    double precision, dimension(:,:), intent(in) :: coords
    integer, dimension(:), intent(in) :: zs
    double precision, intent(in) :: rscut(2)
    integer, intent(in) :: nx
    integer, intent(in) :: ia, ib
    double precision, intent(in) :: dgrid
    double precision, intent(in) :: sigma
    double precision, intent(in) :: w2,rpower2
    double precision, dimension(nx), intent(out) :: ys
    integer, intent(in) :: z1, z2
    double precision :: r
    double precision :: racut,racut2
    integer :: i
    integer :: na
    integer, dimension(:), allocatable :: ias2
    integer :: ia2, nias2
    double precision, dimension(nx) :: xs
    double precision :: c0
    double precision :: inv_sigma
    double precision, dimension(nx) :: xs0

    ys = 0.0d0
    if (zs(ia).ne.z1) return
    if (ib.gt.0) then
        if (ib.eq.ia .or. zs(ib).ne.z2) return
    endif

    allocate(ias2(na))
    ias2 = 0
    nias2 = 0
    if (ib.gt.0) then
        nias2 = 1
        ias2(1) = ib
        racut = rscut(2)
    else
        do i = 1, na
            if (int(zs(i)).eq.z2 .and. i.ne.ia) then
                nias2 = nias2 + 1
                ias2(nias2) = i
            endif
        enddo
        racut = rscut(1)
    endif
    xs = linspace(r0, rscut(1), nx)

    c0 = (mod(z1,1000)*mod(z2,1000)) !* (1./2.)  ! added "*(1./2.)" @Dec.2, 2018
    c0 = c0 / sqrt(2*sigma**2*pi) ! !use normalized gaussian
    inv_sigma = -0.5d0 / sigma**2
    xs0 = w2 * c0/(xs**rpower2) * dgrid
    racut2 = racut**2

    !!$OMP PARALLEL DO REDUCTION(+:ys)
    do ia2 = 1, nias2
        r = sum((coords(:,ia) - coords(:,ias2(ia2)))**2)
        if (r < racut2) ys = ys + xs0 * exp( inv_sigma * (xs - sqrt(r))**2 )
    enddo
    !!$OMP END PARALLEL DO

    deallocate(ias2)
end subroutine calc_sbop_local

subroutine calc_spectrum(na0,zs,coords,n1,n2,n3,mbs1,mbs2,mbs3, &
                      n, nsx,rscut,dgrid,sigma,rpower2,rpower3, ys)
    implicit none
    integer, intent(in) :: na0
    integer, intent(in) :: zs(na0), n1,n2,n3, n,nsx(3)
    real*8, intent(in) :: coords(3,na0), rscut(2),dgrid,sigma
    real*8, intent(in) :: rpower2,rpower3
    integer, intent(in) :: mbs1(n1),mbs2(2,n2),mbs3(3,n3)
    real*8, intent(out) :: ys(n)
    integer :: imb1,imb2,imb3,z1,z2,z3, na
    integer :: jb,je, ja

    ys(:) = 0.0
    do imb1 = 1,n1
        z1 = mbs1(imb1)
        do ja = 1,na0
            if (z1.eq.zs(ja)) then
                ys(imb1) = ys(imb1) + z1
            endif
        enddo
    enddo
    do imb2 = 1,n2
        z1 = mbs2(1,imb2)
        z2 = mbs2(2,imb2)
        jb = n1 + (imb2-1)*nsx(1)
        je = n1 + imb2*nsx(1)
        call calc_sbop(na0,coords,zs,z1,z2,rscut,nsx(1),dgrid,sigma,rpower2,ys(jb:je))
    enddo
    do imb3 = 1,n3
        z1 = mbs3(1,imb3)
        z2 = mbs3(2,imb3)
        z3 = mbs3(3,imb3)
        jb = n1 + n2*nsx(1) + (imb3-1)*nsx(3)
        je = n1 + n2*nsx(1) + imb3*nsx(3)
        call calc_sbot(na0,coords,zs,z1,z2,z3,rscut,nsx(3),dgrid,sigma,rpower3,ys(jb:je))
    enddo
end subroutine

subroutine check_nan1(n1,x)
    implicit none
    integer, intent(in) :: n1
    real*8, intent(in):: x(n1)
    integer :: i
    do i = 1,n1
        if (isnan(x(i))) then
            print *, 'x(i)=',i,'NaN'
            stop
        endif
    enddo
end

subroutine check_nan2(n1,n2,x)
    implicit none
    integer, intent(in) :: n1,n2
    real*8, intent(in):: x(n1,n2)
    integer :: i,j
    do i = 1,n1
      do j = 1,n2
        if (isnan(x(i,j))) then
            print *, 'x(i,j)=',i,j,'NaN'
            stop
        endif
      enddo
    enddo
end

subroutine check_nan3(n1,n2,n3,x)
    implicit none
    integer, intent(in) :: n1,n2,n3
    real*8, intent(in):: x(n1,n2,n3)
    integer :: i,j,k
    do i = 1,n1
      do j = 1,n2
        do k = 1,n3
          if (isnan(x(i,j,k))) then
            print *, 'x(i,j,k)=',i,j,k,'NaN'
            stop
          endif
        enddo
      enddo
    enddo
end

subroutine calc_local_spectrum(na0,zs,coords,nbmax,nbrs,n,nu,n1,n2,n3,mbs1,mbs2,mbs3, &
                               nsx,rscut,dgrid,sigma,w2,rpower2,w3,rpower3, ia0,ib0, ys,ys2)
    !
    ! Get aSLATM for a molecule consisting of `na0 atoms
    !
    ! nbmax: the maximal number of neighbors within a radius of `rscut
    !         for all atoms
    !
    implicit none
    integer, intent(in) :: na0
    integer, intent(in) :: ia0,ib0
    integer, intent(in) :: zs(na0), nu,n1,n2,n3, n,nbmax,nsx(3)
    real*8, intent(in) :: coords(3,na0), rscut(2),dgrid,sigma
    real*8, intent(in) :: rpower2,rpower3, w2,w3
    integer, intent(in) :: mbs1(n1),mbs2(2,n2),mbs3(3,n3), nbrs(nbmax,na0)
    real*8, intent(out) :: ys(n,na0),ys2(nu,nbmax,na0)
    integer :: imb1,imb2,imb3,z1,z2,z3, na1,na2
    integer :: i,j,ia,ja,zi,ibgn,iend, ias1(na0),ias2(nbmax,na0),nas2(na0)

    ias1(:) = 0
    if (ia0.gt.0) then
        na1 = 1
        ias1(1) = ia0
    elseif (ia0.eq.0) then
        na1 = na0
        do ia = 1,na1
            ias1(ia) = ia
        enddo
    endif

    ias2(:,:) = -1
    nas2 = 0
    na2 = 0
    if (ib0.eq.0) then
        do ia=1,na0
            ias2(:,ia) = nbrs(:,ia)
            nas2(ia) = count(nbrs(:,ia)>-1)
        enddo
        !print *, ' ** nas2 = ', nas2
        na2 = sum(nas2)
    elseif (ib0.gt.0) then
        nas2(ia0) = 1
        na2 = 1
        ias2(1,ia0) = ib0
    endif
    !print *, ' -- nbmax = ', nbmax
    !print *, ' ----- ias1 = ', ias1
    !print *, ' ----- ias2 = ', ias2

    ys(:,:) = 0.0
    !print *, ' #####1'
    do i = 1,na1
        ia = ias1(i)
        zi = zs(ia)
        do imb1 = 1,n1
            z1 = mbs1(imb1)
            if (z1.eq.zi) then
                ys(imb1,ia) = z1
            endif
            !print *, ' 1body: ', ys(1:n1, ia)
        enddo
        do imb2 = 1,n2
            z1 = mbs2(1,imb2)
            z2 = mbs2(2,imb2)
            ibgn = n1 + (imb2-1)*nsx(1) + 1
            iend = n1 + imb2*nsx(1)
            !print *, ' 2body idx: ', ibgn, iend
            call calc_sbop_local(coords,zs,ia,0,z1,z2,rscut,nsx(1),dgrid,sigma,w2,rpower2,ys(ibgn:iend,ia))
            !call check_nan2(n,na0,ys)
        enddo
        do imb3 = 1,n3
            z1 = mbs3(1,imb3)
            z2 = mbs3(2,imb3)
            z3 = mbs3(3,imb3)
            ibgn = n1 + n2*nsx(1) + (imb3-1)*nsx(3) + 1
            iend = n1 + n2*nsx(1) + imb3*nsx(3)
            !print *, ' 3body idx: ', ibgn,iend
            call calc_sbot_local(na0,coords,zs,ia,0,z1,z2,z3,rscut,nsx(3),dgrid,sigma,w3,rpower3,ys(ibgn:iend,ia))
            !call check_nan2(n,na0,ys)
        enddo
    enddo
    !print *, '#####2'
    ys2(:,:,:) = 0.0 ! for bond representation
    if (na2.gt.0) then
        !print *, ' ++++++++ ias1 = ', ias1
        do i = 1,na1
            !print *, ' *** ias2(:,i) = ', ias2(:,i)
            do j = 1,nas2(i)
                ia = ias1(i)  !!! `ia already starts from 1!!
                ja = ias2(j,i) + 1  !!! convert python idx (starts from 0) to fortran (starts from 1)
                if (ja.eq.ia .or. ja.le.0) cycle
                !print *, '  +++++ i,j,ia,ja = ', i,j,ia,ja
                do imb2 = 1,n2
                    z1 = mbs2(1,imb2)
                    z2 = mbs2(2,imb2)
                    ibgn = n1 + (imb2-1)*nsx(2) + 1
                    iend = n1 + imb2*nsx(2)
                    !print *, ' B(i->j) 2body idx: ', ibgn, iend
                    call calc_sbop_local(coords,zs,ia,ja,z1,z2,rscut,nsx(2),dgrid,sigma,w2,rpower2,ys2(ibgn:iend,j,ia))
                    !call check_nan3(n,nbmax,na0,ys2)
                enddo
                do imb3 = 1,n3
                    z1 = mbs3(1,imb3)
                    z2 = mbs3(2,imb3)
                    z3 = mbs3(3,imb3)
                    ibgn = n1 + n2*nsx(2) + (imb3-1)*nsx(3) + 1
                    iend = n1 + n2*nsx(2) + imb3*nsx(3)
                    !print *, ' B(i->j) 3body idx: ', ibgn, iend, ', j=',j, ', ys2.shape', n,nbmax,na0
                    call calc_sbot_local(na0,coords,zs,ia,ja,z1,z2,z3,rscut,nsx(3),dgrid,sigma,w3,rpower3,ys2(ibgn:iend,j,ia))
                    !print *, ' DONE!'
                    !call check_nan3(n,nbmax,na0,ys2)
                enddo
            enddo
        enddo
    endif

end subroutine

subroutine calc_all_local_spectrum(nm,na,nas,zs,coords,nbmax,nbrs, &
                    n,nu,n1,n2,n3,nsx, mbs1,mbs2,mbs3, rscut,dgrid,sigma, &
                    w2,rpower2,w3,rpower3, ia0,ib0, ys,ys2)
    integer, intent(in) :: nm,na
    integer, intent(in) :: nas(nm),zs(na)
    integer, intent(in) :: n, nbmax, nu,n1,n2,n3, nsx(3), ia0,ib0
    real*8, intent(in) :: coords(3,na), rscut(2),dgrid,sigma
    integer, intent(in) :: mbs1(n1),mbs2(2,n2),mbs3(3,n3), nbrs(nbmax,na)
    real*8, intent(in) :: rpower2,rpower3, w2,w3
    real*8, intent(out) :: ys(n,na), ys2(n,nbmax,na)
    integer :: i, ib,ie, ias1(nm),ias2(nm)

    ! get ias1,ias2
    do i = 1,nm
        ias2(i) = sum(nas(1:i))
    enddo
    ias1(1) = 1
    ias1(2:nm) = ias2(1:nm-1)+1

    !$OMP parallel do private(i,ib,ie)
    do i = 1,nm
        ib = ias1(i)
        ie = ias2(i)
        call calc_local_spectrum(nas(i),zs(ib:ie),coords(:,ib:ie), &
                          nbmax,nbrs(:,ib:ie), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, &
                          nsx,rscut,dgrid,sigma,w2,rpower2, w3,rpower3, &
                          ia0,ib0, ys(:,ib:ie),ys2(:,:,ib:ie))
    enddo
    !$OMP end parallel do
end subroutine

subroutine calc_local_dij(na1,na2,n,x1,x2,dsij)
    implicit none
    integer, intent(in) :: na1,na2,n
    real*8, intent(in) :: x1(n,na1),x2(n,na2)
    !character*1, intent(in) :: kernel
    real*8, intent(out) :: dsij(na1,na2)
    integer :: i,j
    do i = 1,na2
        do j = 1,na1
            !if (kernel.eq.'l') then
            !    t = t + exp( - sum(x1(:,i)-x2(:,j))/kwds(ic) )
            !elseif (kernel .eq. 'g') then
            dsij(j,i) = norm2(x1(:,j)-x2(:,i))
            !endif
        enddo
    enddo
end subroutine

subroutine calc_local_kij(na1,na2,n,x1,x2,nco,kwds,kijs)
    implicit none
    integer, intent(in) :: na1,na2,n, nco
    real*8, intent(in) :: x1(n,na1),x2(n,na2)
    real*8, intent(in) :: kwds(nco)
    !character*1, intent(in) :: kernel
    real*8, intent(out) :: kijs(nco)
    integer :: ic,i,j
    real*8 :: t

    do ic = 1,nco
        t = 0.0d0
        do i = 1,na1
            do j = 1,na2
                !if (kernel.eq.'l') then
                !    t = t + exp( - sum(x1(:,i)-x2(:,j))/kwds(ic) )
                !elseif (kernel .eq. 'g') then
                    t = t + exp( - (norm2(x1(:,i)-x2(:,j)))**2/(2.0*kwds(ic)**2) )
                !endif
            enddo
        enddo
        kijs(ic) = t
    enddo
end subroutine

subroutine calc_kij(n,x1,x2,nco,kwds,kijs)
    implicit none
    integer, intent(in) :: n, nco
    real*8, intent(in) :: x1(n),x2(n)
    real*8, intent(in) :: kwds(nco)
    !character*1, intent(in) :: kernel
    real*8, intent(out) :: kijs(nco)
    integer :: ic

    do ic = 1,nco
        !if (kernel.eq.'l') then
        !    kijs(ic) = exp( - sum(x1-x2)/kwds(ic) )
        !elseif (kernel .eq. 'g') then
            kijs(ic) = exp( - (norm2(x1-x2))**2/(2.0*kwds(ic)**2) )
        !endif
    enddo
end subroutine

subroutine calc_mk1(local,nm,na,nas,zs,coords,nbmax,nbrs,n1,n2,n3,mbs1,mbs2,mbs3,&
                    rscut,dgrid,sigma, w2,rpower2,w3,rpower3, nco,kwds, k1)
    !
    ! K for training set
    !
    ! Calculate molecular kernel matrix K (upper case), to be distinguished with
    ! lower case k, characterizing similarity between atoms.
    ! The i-th and j-th entry of K is
    !        K(i,j) = \sum_{I \in i} \sum_{J \in j} k(I,J)
    !
    logical, intent(in) :: local
    integer, intent(in) :: nm,na, nbmax
    integer, intent(in) :: nas(nm),zs(na)
    integer, intent(in) :: n1,n2,n3, nbrs(nbmax,na)
    real*8, intent(in) :: coords(3,na), rscut(2),dgrid,sigma
    integer, intent(in) :: mbs1(n1),mbs2(2,n2),mbs3(3,n3), nco
    real*8, intent(in) :: kwds(nco), w2,rpower2,w3,rpower3
    !character*1, intent(in) :: kernel
    real*8, intent(out) :: k1(nco,nm,nm)
    real*8, allocatable :: xs1(:,:),xs2(:,:),x1(:),x2(:), nul(:,:,:)
    integer :: i,j, iar, im,iab,iae, namax, nsx(3)
    integer :: n,nu
    integer :: pair(2),iasr(2), amap(na), ias1(nm),ias2(nm)
    real*8 :: dmax,kijs(nco)

    ! get ias1,ias2
    do i = 1,nm
        ias2(i) = sum(nas(1:i))
    enddo
    ias1(1) = 1
    ias1(2:nm) = ias2(1:nm-1)+1

    ! get amap: atomic idx --> mol idx
    !print *, '##1'
    amap(:) = 0
    do i = 1,nm
        amap(ias1(i):ias2(i)) = i
    enddo

    ! setup grid
    nsx = 0
    nsx(1) = int((rscut(1) - r0)/dgrid) + 1
    !d2r = pi/dble(180) ! degree to rad
    !a0 = -20.0*d2r
    !a1 = pi + 20.0*d2r
    nsx(3) = int((pi + 40.0*(pi/dble(180)))/dgrid) + 1
    n = n1 + n2*nsx(1) + n3*nsx(3)
    nu = n1 + n2*nsx(2) + n3*nsx(3)
    namax = maxval(nas)
    !print *, '##2'
    allocate( xs1(n,namax),xs2(n,namax), x1(n),x2(n), nul(nu,nbmax,namax) )
    xs1(:,:) = 0.0
    xs2(:,:) = 0.0
    x1(:) = 0.0
    x2(:) = 0.0
    !print *, '##3'
    if (local) then
        !$OMP parallel do private(i,j,xs1,xs2,kijs)
        do i = 1,nm
            do j = i,nm
                !print *, ' I,J = ', I,J
                call calc_local_spectrum(nas(i),zs(ias1(i):ias2(i)),coords(:,ias1(i):ias2(i)), &
                                  nbmax,nbrs(:,ias1(i):ias2(i)), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, nsx, &
                                  rscut,dgrid,sigma,w2,rpower2,w3,rpower3, 0, -1, xs1(:,1:nas(i)), nul(:,:,1:nas(i)))
                call calc_local_spectrum(nas(j),zs(ias1(j):ias2(j)),coords(:,ias1(j):ias2(j)), &
                                  nbmax,nbrs(:,ias1(i):ias2(i)), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, nsx, &
                                  rscut,dgrid,sigma,w2,rpower2,w3,rpower3, 0, -1, xs2(:,1:nas(j)), nul(:,:,1:nas(i)))
                call calc_local_kij(nas(i),nas(j),n,xs1(:,1:nas(i)),xs2(:,1:nas(j)), nco,kwds, kijs)
                k1(:,i,j) = kijs
                k1(:,j,i) = kijs
            enddo
        enddo
        !$OMP end parallel do
    else
        !$OMP parallel do private(i,j,x1,x2,kijs)
        do i = 1,nm
            do j = i,nm
                call calc_spectrum(nas(i),zs(ias1(i):ias2(i)),coords(:,ias1(i):ias2(i)), n1,n2,n3,&
                                  mbs1,mbs2,mbs3, n,nsx,rscut,dgrid,sigma,rpower2,rpower3,x1)
                call calc_spectrum(nas(j),zs(ias1(j):ias2(j)),coords(:,ias1(j):ias2(j)), n1,n2,n3, &
                                  mbs1,mbs2,mbs3, n,nsx,rscut,dgrid,sigma,rpower2,rpower3,x2)
                call calc_kij(n,x1,x2, nco,kwds, kijs)
                k1(:,i,j) = kijs
                k1(:,j,i) = kijs
            enddo
        enddo
        !$OMP end parallel do
    endif
    deallocate( xs1,xs2, x1,x2, nul )
end subroutine

subroutine calc_mk2(local,nm1,nm,na,nas,zs,coords,nbmax,nbrs,n1,n2,n3,mbs1,mbs2,mbs3,&
                    rscut,dgrid,sigma, w2,rpower2,w3,rpower3, nco,kwds, k2)
    !
    ! K between test & training molecules
    !
    logical, intent(in) :: local
    integer, intent(in) :: nm1,nm,na, nbmax
    integer, intent(in) :: nas(nm),zs(na), nbrs(nbmax,na)
    integer, intent(in) :: n1,n2,n3
    real*8, intent(in) :: coords(3,na), rscut(2),dgrid,sigma, kwds(nco)
    integer, intent(in) :: mbs1(n1),mbs2(2,n2),mbs3(3,n3), nco
    real*8, intent(in) :: rpower2,rpower3,w2,w3
    !character*1, intent(in) :: kernel  !! only gaussian kernel is allowed
    real*8, intent(out) :: k2(nco,nm-nm1,nm1)
    real*8, allocatable :: xs1(:,:),xs2(:,:),x1(:),x2(:), nul(:,:,:)
    integer :: i,j, n,nu, im, namax, nsx(3)
    integer :: amap(na), ias1(nm),ias2(nm)
    real*8 :: kijs(nco)

    ! get ias1,ias2
    do i = 1,nm
        ias2(i) = sum(nas(1:i))
    enddo
    ias1(1) = 1
    ias1(2:nm) = ias2(1:nm-1)+1

    ! get amap: atomic idx --> mol idx
    amap(:) = 0
    do i = 1,nm
        amap(ias1(i):ias2(i)) = i
    enddo
    print *, '##1'

    ! setup grid
    nsx = 0
    nsx(1) = int((rscut(1) - r0)/dgrid) + 1
    !d2r = pi/dble(180) ! degree to rad
    !a0 = -20.0*d2r
    !a1 = pi + 20.0*d2r
    nsx(3) = int((pi + 40.0*(pi/dble(180)))/dgrid) + 1
    n = n1 + n2*nsx(1) + n3*nsx(3)
    nu = n1 + n2*nsx(2) + n3*nsx(3)

    namax = maxval(nas)
    allocate( xs1(n,namax),xs2(n,namax), x1(n),x2(n), nul(nu,nbmax,namax) )

    xs1(:,:) = 0.0
    xs2(:,:) = 0.0
    x1(:) = 0.0
    x2(:) = 0.0
    print *, '##2'
    if (local) then
        !!$OMP parallel do private(i,j,kijs,xs1,xs2)
        do i = 1,nm1
            do j = nm1+1,nm
                print *, ' i,j = ', i,j
                call calc_local_spectrum(nas(i),zs(ias1(i):ias2(i)),coords(:,ias1(i):ias2(i)), &
                                  nbmax, nbrs(:,ias1(i):ias2(i)), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, nsx,&
                                  rscut,dgrid,sigma,w2,rpower2,w3,rpower3, 0, -1, xs1(:,1:nas(i)), nul(:,:,1:nas(i)))
                print *, '++2'
                call calc_local_spectrum(nas(j),zs(ias1(j):ias2(j)),coords(:,ias1(j):ias2(j)), &
                                  nbmax, nbrs(:,ias1(j):ias2(j)), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, nsx,&
                                  rscut,dgrid,sigma,w2,rpower2,w3,rpower3, 0, -1, xs2(:,1:nas(j)), nul(:,:,1:nas(i)))
                print *, '++3'
                call calc_local_kij(nas(i),nas(j),n,xs1(:,1:nas(i)),xs2(:,1:nas(j)), nco,kwds, kijs)
                print *, '++4'
                k2(:,j,i) = kijs
            enddo
        enddo
        !!$OMP end parallel do
    else
        !$OMP parallel do private(i,j,kijs,x1,x2)
        do i = 1,nm1
            do j = nm1+1,nm
                call calc_spectrum(nas(i),zs(ias1(i):ias2(i)),coords(:,ias1(i):ias2(i)), &
                            n1,n2,n3,mbs1,mbs2,mbs3, n,nsx,rscut,dgrid,sigma,rpower2,rpower3,x1)
                call calc_spectrum(nas(j),zs(ias1(j):ias2(j)),coords(:,ias1(j):ias2(j)), &
                                  n1,n2,n3,mbs1,mbs2,mbs3, n,nsx,rscut,dgrid,sigma,rpower2,rpower3,x2)
                call calc_kij(n,x1,x2, nco,kwds, kijs)
                k2(:,j,i) = kijs
            enddo
        enddo
        !$OMP end parallel do
    endif
    deallocate( xs1,xs2, x1,x2, nul )
end subroutine

subroutine calc_dij_max(local,nm,na,nas,zs,coords,nbmax,nbrs,n1,n2,n3,mbs1,mbs2,mbs3,&
                    rscut,dgrid,sigma, w2,rpower2,w3,rpower3, dmax)
    !
    ! K for training set
    !
    ! Calculate molecular kernel matrix K (upper case), to be distinguished with
    ! lower case k, characterizing similarity between atoms.
    ! The i-th and j-th entry of K is
    !        K(i,j) = \sum_{I \in i} \sum_{J \in j} k(I,J)
    !
    logical, intent(in) :: local
    integer, intent(in) :: nm,na, nbmax
    integer, intent(in) :: nas(nm),zs(na)
    integer, intent(in) :: n1,n2,n3, nbrs(nbmax,na)
    real*8, intent(in) :: coords(3,na), rscut(2),dgrid,sigma
    integer, intent(in) :: mbs1(n1),mbs2(2,n2),mbs3(3,n3)
    real*8, intent(in) :: w2,rpower2,w3,rpower3
    !character*1, intent(in) :: kernel
    real*8, intent(out) :: dmax
    real*8, allocatable :: xs1(:,:),xs2(:,:),x1(:),x2(:), &
                           ds(:,:),dsij(:,:), nul(:,:,:)
    integer :: i,j, iar, im,iab,iae, namax, nsx(3)
    integer :: n,nu
    integer :: pair(2),iasr(2), amap(na), ias1(nm),ias2(nm)

    ! get ias1,ias2
    do i = 1,nm
        ias2(i) = sum(nas(1:i))
    enddo
    ias1(1) = 1
    ias1(2:nm) = ias2(1:nm-1)+1

    ! get amap: atomic idx --> mol idx
    amap(:) = 0
    do i = 1,nm
        amap(ias1(i):ias2(i)) = i
    enddo

    ! setup grid
    nsx = 0
    nsx(1) = int((rscut(1) - r0)/dgrid) + 1
    !d2r = pi/dble(180) ! degree to rad
    !a0 = -20.0*d2r
    !a1 = pi + 20.0*d2r
    nsx(3) = int((pi + 40.0*(pi/dble(180)))/dgrid) + 1
    n = n1 + n2*nsx(1) + n3*nsx(3)
    nu = n1 + n2*nsx(2) + n3*nsx(3)

    namax = maxval(nas)
    allocate( xs1(n,namax),xs2(n,namax), x1(n),x2(n), nul(nu,nbmax,namax) )
    allocate( ds(nm,nm),dsij(namax,namax) )
    xs1(:,:) = 0.0
    xs2(:,:) = 0.0
    x1(:) = 0.0
    x2(:) = 0.0
    if (local) then
        !$OMP parallel do private(i,j,xs1,xs2,dsij)
        do i = 1,nm
            do j = i,nm
                call calc_local_spectrum(nas(i),zs(ias1(i):ias2(i)),coords(:,ias1(i):ias2(i)), &
                                  nbmax,nbrs(:,ias1(i):ias2(i)), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, nsx, &
                                  rscut,dgrid,sigma,w2,rpower2,w3,rpower3, 0, -1, xs1(:,1:nas(i)), nul(:,:,1:nas(i)))
                call calc_local_spectrum(nas(j),zs(ias1(j):ias2(j)),coords(:,ias1(j):ias2(j)), &
                                  nbmax,nbrs(:,ias1(i):ias2(i)), n,nu,n1,n2,n3,mbs1,mbs2,mbs3, nsx, &
                                  rscut,dgrid,sigma,w2,rpower2,w3,rpower3, 0, -1, xs2(:,1:nas(j)), nul(:,:,1:nas(i)))
                call calc_local_dij(nas(i),nas(j),n,xs1(:,1:nas(i)),xs2(:,1:nas(j)), dsij(1:nas(i),1:nas(j)))
                ds(i,j) = maxval(dsij)
            enddo
        enddo
        !$OMP end parallel do
    else
        !$OMP parallel do private(i,j,x1,x2)
        do i = 1,nm
            do j = i,nm
                call calc_spectrum(nas(i),zs(ias1(i):ias2(i)),coords(:,ias1(i):ias2(i)), n1,n2,n3,&
                                  mbs1,mbs2,mbs3, n,nsx,rscut,dgrid,sigma,rpower2,rpower3,x1)
                call calc_spectrum(nas(j),zs(ias1(j):ias2(j)),coords(:,ias1(j):ias2(j)), n1,n2,n3, &
                                  mbs1,mbs2,mbs3, n,nsx,rscut,dgrid,sigma,rpower2,rpower3,x2)
                ds(i,j) = norm2(x1-x2)
            enddo
        enddo
        !$OMP end parallel do
    endif
    dmax = maxval(ds)
    deallocate( xs1,xs2, x1,x2, nul, dsij,ds )
end subroutine

end module


C     Linear regression of data
C     USES gammq

      SUBROUTINE fit(x,y,ndata,sig,mwt,a,b,siga,sigb,chi2,coef)

      INTEGER mwt,ndata,i
      REAL*8 a,b,chi2,siga,sigb,sig(ndata),x(ndata),y(ndata)
      REAL*8 sigdat,ss,st2,sx,sxoss,sy,t,wt,coef

      sx=0.
      sy=0.
      st2=0.
      b=0.
      if(mwt.ne.0) then
        ss=0.
        do i=1,ndata
          wt=1./(sig(i)**2)
          ss=ss+wt
          sx=sx+x(i)*wt
          sy=sy+y(i)*wt
        enddo
      else
        do i=1,ndata
          sx=sx+x(i)
          sy=sy+y(i)
        enddo
        ss=dble(ndata)
      endif

      sxoss=sx/ss
      if(mwt.ne.0) then
        do i=1,ndata
          t=(x(i)-sxoss)/sig(i)
          st2=st2+t*t
          b=b+t*y(i)/sig(i)
        enddo
      else
        do i=1,ndata
          t=x(i)-sxoss
          st2=st2+t*t
          b=b+t*y(i)
        enddo
      endif

      b=b/st2
      a=(sy-sx*b)/ss
      siga=sqrt((1.+sx*sx/(ss*st2))/ss)
      sigb=sqrt(1./st2)
      chi2=0.
      coef=-sx/ss/st2/siga/sigb

      if(mwt.eq.0) then
        do i=1,ndata
          chi2=chi2+(y(i)-a-b*x(i))**2
        enddo
      sigdat=sqrt(chi2/(ndata-2))
      siga=siga*sigdat
      sigb=sigb*sigdat
      else
        do i=1,ndata
          chi2=chi2+((y(i)-a-b*x(i))/sig(i))**2
        enddo
      endif

      return
      END


PROGRAM Finite_Element
  ! This program demonstrates the parallelization of a program that is based
  ! on the Finite Element Method. In this program, nodes and elements are
  ! distributed in the following way:
  !
  ! N   N   N   N
  !   E   E   E
  ! N   N   N   N
  !   E   E   E
  ! N   N   N   N
  !
  ! The procedure inside of the main loop of this program is:
  ! 1. The value of each element is added to the closest surrounding nodes.
  ! 2. The value of each nodes is divided by 4
  ! 3. The value of each node is added to the closest surrounding elements.
  ! 4. The value of each element is divided by 4

  USE Grid
  IMPLICIT NONE

  INTEGER :: step         ! The time steps
  INTEGER :: r            ! rows
  INTEGER :: c            ! columns

  CALL initialize()

  ! Initialize the inner element grid
  DO r=1, rows
    DO c=1, localCols
      elements(r, c) = (r + (c-1)*rows + myrank*rows*localCols) * 10.0
    END DO
  END DO

  ! Initialize the nodes that surround the elements
  DO r=1, rows+1
    DO c=1, localCols+1
      nodes(r, c) = (c + myrank*localCols + (r-1)*(cols+1)) * 100.0
    END DO
  END DO

  CALL printGrids("Initial configuration")

  ! The main loop
  main: DO step=1, 2
    ! Elements -> nodes
    CALL synchronizeElements()
    DO r=1, rows
      DO c=1, localCols
        nodes(r  ,c  ) = nodes(r  ,c  ) + elements(r,c)
        nodes(r  ,c+1) = nodes(r  ,c+1) + elements(r,c)
        nodes(r+1,c  ) = nodes(r+1,c  ) + elements(r,c)
        nodes(r+1,c+1) = nodes(r+1,c+1) + elements(r,c)
      END DO
      IF (myrank < nprocs-1) THEN
        c = localCols+1
        nodes(r  ,c) = nodes(r  ,c) + elements(r,c)
        nodes(r+1,c) = nodes(r+1,c) + elements(r,c)
      ENDIF
    END DO

    CALL printGrids("Elements->nodes")

    ! Update nodes
    DO r=1, rows+1
      DO c=1, localCols+1
        nodes(r,c) = nodes(r,c) * 0.25
      END DO
    END DO

    CALL printGrids("Update nodes")

    ! Nodes -> elements
    CALL synchronizeNodes()
    DO r=1, rows
      DO c=1, localCols
        elements(r,c) = elements(r,c) + nodes(r,c) + nodes(r,c+1) + &
                        nodes(r+1,c) + nodes(r+1,c+1)
      END DO
    END DO

    CALL printGrids("Nodes->elements")

    ! Update elements
    DO r=1, rows
      DO c=1, localCols
        elements(r,c) = elements(r,c) * 0.25
      END DO
    END DO

    CALL printGrids("Update elements")
  END DO main

  CALL finalize()

END PROGRAM Finite_Element


program compute_pi
    use omp_lib
    implicit none
    integer, parameter :: num_iters = 1000
    integer :: i, thread_num, num_threads
    real :: x, pi_sum, dx, pi

    pi_sum = 0.0
    dx = 1.0/num_iters
    num_threads = 1
    thread_num = 0
    !$omp parallel private(x)
    !$ num_threads = omp_get_num_threads()
    !$ thread_num = omp_get_thread_num()
    x = real(thread_num)*num_iters/num_threads
    !$omp do
    do i = 1, num_iters
        x = x + dx
        pi_sum = pi_sum + 1.0/(1.0 + x**2)
    end do
    !$end omp do
    !$omp end parallel
    pi = 4.0*pi_sum*dx
    print *, pi
end program compute_pi


program i
  integer, dimension(2, 2) :: array
  array(1, 1) = 1 + 1
  array(1, 2) = 1 * 2
  array(2, 1) = 1 ** 2
  array(2, 2) = array(1, 1) + array(1, 2) * array(2, 1)

end program i


program exp_distr_program
    implicit none
    integer, parameter :: NR_VALUES = 1000
    integer :: i

    do i = 1, NR_VALUES
        print *, get_exp_rand()
    end do

contains

    function get_exp_rand() result(val)
        implicit none
        real :: val
        real, save :: next_val
        logical, save :: is_next_set = .false.
        real :: x, y, radius, factor

        if (is_next_set) then
            is_next_set = .false.
            val = next_val
        else
            do while (.not. is_next_set)
                call random_number(x)
                call random_number(y)
                x = 2.0*x - 1.0
                y = 2.0*y - 1.0
                radius = x**2 + y**2
                if (0.0 < radius .and. radius <= 1.0) exit
            end do
            factor = sqrt(-2.0*log(radius)/radius)
            val = x*factor
            next_val =y*factor
            is_next_set = .true.
        end if
    end function get_exp_rand

end program exp_distr_program


program main

use euler

implicit none

        ! Constants
        integer (kind=8), parameter :: MAXIMUM = 1600000
        integer (kind=8), parameter :: BASE = 10

        integer (kind=8), dimension(10) :: facts
        integer (kind=8) :: i, last, sum;

        sum = 0;
        last = 1;

        facts(1) = 1
        do i = 2, 10, 1
                facts(i) = last * (i - 1);
                last = facts(i);
        end do

        do i = 5 , MAXIMUM, 1

                if(i == digital_factorial_sum(i)) then
                        call inc(sum, i);
                endif
        end do

        call printint(sum);

contains

        ! For each digit in the number, we sum the factorial of said digit

        pure function digital_factorial_sum(i)

                ! Define in and out vars
                integer (kind=8), intent(in) :: i
                integer (kind=8) :: digital_factorial_sum

                ! Locals
                integer (kind=8) :: tmp;

                digital_factorial_sum = 0;
                tmp = i;

                do while(tmp /= 0)

                        call inc(digital_factorial_sum, &
                                        facts(mod(tmp, BASE) + 1));
                        tmp = tmp / BASE;
                end do

        end function digital_factorial_sum

end program main


program one
  implicit none

  integer :: i, j
  integer, parameter :: imax = 3, jmax = 3

  real a(0:imax,0:jmax), b(0:imax,0:jmax)

  ! some kind of setup
  do i = 0, imax
     do j = 0, jmax
        a(i,j) = i+j
     end do
  end do
  !do i = 1, (imax-1)
  !   do j = 1, (jmax-1)
  !      a(i, j) = i*j
  !   end do
  !end do

  write (*,*) "A = "
  do i = 0, imax
     do j = 0, jmax
        write (*,'(" ",f0.2," ")',advance="no") a(i,j)
     end do
     write (*,*) "\n"
  end do

  ! compute mean
  do i = 1, (imax-1)
     do j = 1, (jmax-1)
        b(i,j) = stencil(i,j)
     end do
     ! top and bottom (inner) edges
     != stencil readOnce, centered(depth=1, dim=1) :: a
     b(i, 0) = (a(i, 0) + a(i-1,0) + a(i+1,0) + a(i,1))/4.0
     != stencil readOnce, centered(depth=1, dim=1) :: a
     b(i, jmax) = (a(i, jmax) + a(i-1, jmax) + a(i+1, jmax) + a(i,jmax-1))/4.0
  end do

  ! left and right (inner) edges
  do j = 1, (jmax-1)
     != stencil readOnce, centered(depth=1, dim=2) :: a
     b(0, j) = (a(0, j) + a(0,j-1) + a(0,j+1) + a(1,j))/4.0
     != stencil readOnce, centered(depth=1, dim=2) :: a
     b(imax, j) = (a(imax, j) + a(imax, j-1) + a(imax, j+1) + a(imax-1,j))/4.0
  end do

  ! corners
  b(0,0) = (a(0,0) + a(0,1) + a(1,0))/3.0
  b(imax,jmax) = (a(imax,jmax) + a(imax-1,jmax) + a(imax,jmax-1))/3.0
  b(imax,0) = (a(imax, 0) + a(imax-1,0) + a(imax,1))/3.0
  b(0, jmax) = (a(0, jmax) + a(1, jmax) + a(0, jmax-1))/3.0

  ! output routine
  write (*,*) "B = "
  do i = 0, imax
     do j = 0, jmax
        write (*,'(" ",f0.2," ")',advance="no") b(i,j)
     end do
     write (*,*) "\n"
  end do

  contains

    real function stencil(i,j)
      integer :: i, j
      stencil = (a(i-1,j) + a(i,j) + a(i+1,j) + &
                 a(i,j-1) + a(i,j+1)) / 5.0

    end function

end program


!> @file
!! check to see if value exceeds threshold

!  --------------------------------------------------------------
!> @brief Check if the gradient exceeds the threshold
!!
!! @param[in] blockno the block number
!! @param[in] qval the
!! @param[in] qmin the minimum q value
!! @param[in] qmax the maximum q value
!! @param[in] quad the value and adjacent values of q
!! @param[in] dx, dy, dz the spacing in the x and y directions
!! @param[in] xc, yc, zc the coordinate of the cell
!! @param[in] threshold the threshold
!! @param[in] init_flag true if in init stage
!! @param[in] is_ghost true if cell is a ghost cell
!! @return 1 if exceeds threshold, 0 if not, -1 if inconclusive.
!  --------------------------------------------------------------
integer function fclaw3dx_clawpatch_gradient_exceeds_th(blockno,&
                                     qval,qmin,qmax,quad, &
                                     dx,dy,dz, xc,yc,zc, threshold, &
                                     init_flag, is_ghost)
    implicit none

    double precision :: qval,qmin,qmax,threshold
    double precision :: quad(-1:1,-1:1,-1:1)
    double precision :: dx,dy, dz, xc, yc, zc
    integer :: blockno, init_flag
    logical(kind=4) :: is_ghost

    double precision :: dqx, dqy, dqz
    double precision :: grad(3), dx2, dy2, dz2, ds

    double precision :: clawpatch_gradient_dot3
    integer :: refine

    if (is_ghost) then
!!      # quad may have uninitialized values.  Test is inconclusive
        fclaw3dx_clawpatch_gradient_exceeds_th = -1
        return
    endif

    dx2 = 2*dx
    dy2 = 2*dy
    dz2 = 2*dz

    dqx = (quad(1,0,0) - quad(-1,0,0))/dx2
    dqy = (quad(0,1,0) - quad(0,-1,0))/dy2
    dqz = (quad(0,0,1) - quad(0,0,-1))/dz2

    refine = 0
    grad(1) = dqx
    grad(2) = dqy
    grad(3) = dqz

    ds = sqrt(clawpatch_gradient_dot3(grad,grad))

    if (ds .gt. threshold) then
        refine = 1
    endif

    fclaw3dx_clawpatch_gradient_exceeds_th = refine

end function fclaw3dx_clawpatch_gradient_exceeds_th

!  --------------------------------------------------------------
!> @brief Dot product of two vector
!!
!! @param[in] u, v the vectors
!! @return the dot product
!  --------------------------------------------------------------
double precision function clawpatch_gradient_dot3(u,v)
    implicit none

    double precision :: u(3), v(3)

    clawpatch_gradient_dot3 = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

end function clawpatch_gradient_dot3


submodule(chamber_gas_t_interface) chamber_gas_t_implementation
  !! Defined the chamber_gas_t user-defined structure constructors and type-bound procedures
  implicit none

contains

  module procedure new_chamber_gas_t
    new_chamber_gas_t%MW_  = MW
    new_chamber_gas_t%c_p_ = c_p
    new_chamber_gas_t%mcham_ = p*V/(new_chamber_gas_t%R_gas()*T)
    new_chamber_gas_t%echam_  = new_chamber_gas_t%mcham_*new_chamber_gas_t%c_v()*T
  end procedure

  module procedure incremented_chamber_gas_t
    incremented_chamber_gas_t%MW_    = old_chamber_gas_t%MW_
    incremented_chamber_gas_t%c_p_   = old_chamber_gas_t%c_p_
    incremented_chamber_gas_t%mcham_ = old_chamber_gas_t%mcham_ + mass_increment
    incremented_chamber_gas_t%echam_ = old_chamber_gas_t%echam_ + energy_increment
  end procedure

  module procedure R_gas
    real(dp), parameter :: R_universal=8314._dp
    R_gas = R_universal/this%MW_
  end procedure

  module procedure c_p
    c_p = this%c_p_
  end procedure

  module procedure c_v
    c_v = this%c_p() - this%R_gas()
  end procedure

  module procedure T
    T = this%echam_/(this%mcham_*this%c_v())
  end procedure

  module procedure calcp
    calcp = this%mcham_*this%R_gas()*this%T()/V
  end procedure

  module procedure g
    g = this%c_p_/this%c_v()
  end procedure

end submodule chamber_gas_t_implementation


subroutine StructureFactors(positions,numbers,Fhkl)
    real   , intent(in )  :: positions(:,:)
    integer, intent(in )  :: numbers(:)
    real   , intent(out)  :: Fhkl(31,31,31,2)
    integer :: h,k,l
    complex :: f_hkl
    real   , parameter :: pi = 3.1415927
    complex, parameter :: j  = cmplx(0,1)
    Fhkl = 0.0
    nat = size(positions,dim=1)
    do h=-15,15
        do k=-15,15
            do l=-15,15
                f_hkl = dot_product(exp(2.0*j*pi*(h*positions(:,1)+k*positions(:,2)+l*positions(:,3))),numbers)
                Fhkl(h+16,k+16,l+16,1) = abs(f_hkl)
                Fhkl(h+16,k+16,l+16,2) = atan2(aimag(f_hkl),real(f_hkl))
            end do
        end do
    end do
end subroutine


module linalg_mod

use constants_mod

contains

pure function matinv2(A) result(B)
  !! Performs a direct calculation of the inverse of a 2×2 matrix.
  real(dp), intent(in) :: A(2,2)   !! Matrix
  real(dp)             :: B(2,2)   !! Inverse matrix
  real(dp)             :: detinv

  ! Calculate the inverse determinant of the matrix
  detinv = 1.0_dp/(A(1,1)*A(2,2) - A(1,2)*A(2,1))

  ! Calculate the inverse of the matrix
  B(1,1) = +detinv * A(2,2)
  B(2,1) = -detinv * A(2,1)
  B(1,2) = -detinv * A(1,2)
  B(2,2) = +detinv * A(1,1)
end function

pure function matinv3(A) result(B)
  !! Performs a direct calculation of the inverse of a 3×3 matrix.
  real(dp), intent(in) :: A(3,3)   !! Matrix
  real(dp)             :: B(3,3)   !! Inverse matrix
  real(dp)             :: detinv

  ! Calculate the inverse determinant of the matrix
  detinv = 1/(A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2)&
            - A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1)&
            + A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1))

  ! Calculate the inverse of the matrix
  B(1,1) = +detinv * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
  B(2,1) = -detinv * (A(2,1)*A(3,3) - A(2,3)*A(3,1))
  B(3,1) = +detinv * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
  B(1,2) = -detinv * (A(1,2)*A(3,3) - A(1,3)*A(3,2))
  B(2,2) = +detinv * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
  B(3,2) = -detinv * (A(1,1)*A(3,2) - A(1,2)*A(3,1))
  B(1,3) = +detinv * (A(1,2)*A(2,3) - A(1,3)*A(2,2))
  B(2,3) = -detinv * (A(1,1)*A(2,3) - A(1,3)*A(2,1))
  B(3,3) = +detinv * (A(1,1)*A(2,2) - A(1,2)*A(2,1))
end function

pure function matinv4(A) result(B)
  !! Performs a direct calculation of the inverse of a 4×4 matrix.
  real(dp), intent(in) :: A(4,4)   !! Matrix
  real(dp)             :: B(4,4)   !! Inverse matrix
  real(dp)             :: detinv

  ! Calculate the inverse determinant of the matrix
  detinv = &
    1/(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
     - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
     + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
     - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

  ! Calculate the inverse of the matrix
  B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
  B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
  B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
  B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
  B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
  B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
  B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
  B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
  B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
  B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
  B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
  B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
  B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
  B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
  B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
  B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))
end function

!! REAL FUNCTION FindDet(matrix, n)
!!
!!     INTEGER, INTENT(IN) :: n
!!     REAL, DIMENSION(n,n) :: matrix
!!     REAL :: m, temp
!!     INTEGER :: i, j, k, l
!!     LOGICAL :: DetExists = .TRUE.
!!     l = 1
!!     !Convert to upper triangular form
!!     DO k = 1, n-1
!!         IF (matrix(k,k) == 0) THEN
!!             DetExists = .FALSE.
!!             DO i = k+1, n
!!                 IF (matrix(i,k) /= 0) THEN
!!                     DO j = 1, n
!!                         temp = matrix(i,j)
!!                         matrix(i,j)= matrix(k,j)
!!                         matrix(k,j) = temp
!!                     END DO
!!                     DetExists = .TRUE.
!!                     l=-l
!!                     EXIT
!!                 ENDIF
!!             END DO
!!             IF (DetExists .EQV. .FALSE.) THEN
!!                 FindDet = 0
!!                 return
!!             END IF
!!         ENDIF
!!         DO j = k+1, n
!!             m = matrix(j,k)/matrix(k,k)
!!             DO i = k+1, n
!!                 matrix(j,i) = matrix(j,i) - m*matrix(k,i)
!!             END DO
!!         END DO
!!     END DO
!!
!!     !Calculate determinant by finding product of diagonal elements
!!     FindDet = l
!!     DO i = 1, n
!!         FindDet = FindDet * matrix(i,i)
!!     END DO
!!
!! END FUNCTION FindDet

pure function invert(o,n) result(c)
    !============================================================
    ! Inverse matrix
    ! Method: Based on Doolittle LU factorization for Ax=b
    ! Alex G. December 2009
    !-----------------------------------------------------------
    ! input ...
    ! a(n,n) - array of coefficients for matrix A
    ! n      - dimension
    ! output ...
    ! c(n,n) - inverse matrix of A
    !===========================================================

    integer, intent(in) :: n
    real(dp), intent(in) :: o(n,n)
    real(dp)             :: a(n,n), c(n,n)
    real(dp)             :: L(n,n), U(n,n), b(n), d(n), x(n)
    real(dp)             :: coeff
    integer             :: i, j, k

    ! step 0: initialization for matrices L and U and b
    ! Fortran 90/95 aloows such operations on matrices
    a = o
    L = 0.0_dp
    U = 0.0_dp
    b = 0.0_dp

    ! step 1: forward elimination
    do k=1, n-1
       do i=k+1,n
          coeff=a(i,k)/a(k,k)
          L(i,k) = coeff
          do j=k+1,n
             a(i,j) = a(i,j)-coeff*a(k,j)
          end do
       end do
    end do

    ! Step 2: prepare L and U matrices
    ! L matrix is a matrix of the elimination coefficient
    ! + the diagonal elements are 1.0
    do i=1,n
      L(i,i) = 1.0_dp
    end do
    ! U matrix is the upper triangular part of A
    do j=1,n
      do i=1,j
        U(i,j) = a(i,j)
      end do
    end do

    ! Step 3: compute columns of the inverse matrix C
    do k=1,n
      b(k)=1.0_dp
      d(1) = b(1)
    ! Step 3a: Solve Ld=b using the forward substitution
      do i=2,n
        d(i)=b(i)
        do j=1,i-1
          d(i) = d(i) - L(i,j)*d(j)
        end do
      end do
    ! Step 3b: Solve Ux=d using the back substitution
      x(n)=d(n)/U(n,n)
      do i = n-1,1,-1
        x(i) = d(i)
        do j=n,i+1,-1
          x(i)=x(i)-U(i,j)*x(j)
        end do
        x(i) = x(i)/u(i,i)
      end do
    ! Step 3c: fill the solutions x(n) into column k of C
      do i=1,n
        c(i,k) = x(i)
      end do
      b(k)=0.0_dp
    end do

end function

pure function shiftMatrix(nrows,ncols,inmat) result(exmat)

    integer, intent(in) :: nrows,ncols
    real(dp), intent(in) :: inmat(:,:)

    real(dp) :: exmat(size(inmat,1),size(inmat,2))

    integer :: i,j

    exmat = 0.0_dp

    do i = nrows+1,size(inmat,1)
        do j = ncols+1,size(inmat,2)
            exmat(i,j) = inmat(i-nrows,j-ncols)
        end do
    end do

end function

end module


!
! ej6_a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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., 51 Franklin Street, Fifth Floor, Boston,
! MA 02110-1301, USA.

PROGRAM ej6_a

use precision, pr => dp

IMPLICIT NONE

integer :: i, j, k
integer, parameter :: n = 1000
real(pr) ::  x0, v0, h, t0, tf, t, error, exacta, vexacta
real(pr) :: xi, xi_1, vi, vi_1
open(unit=10, file='ej6_a.dat', status='UNKNOWN', action='WRITE')

write(10, *) "#  t   x   v   err  exact   vexact"

t0 = 0._pr
tf = 10._pr
x0 = 1._pr
v0 = 1._pr
write(10, *) t0, x0, v0, 0._pr, x0, v0

!condiciones iniciales
xi = x0
vi = v0

   ! para que h = E-7
h = (tf - t0)/real(n, pr)

! para t == 0
do i = 1, n
    xi_1 = xi
    vi_1 = vi
    vi = vi_1 + h * f(xi_1)
    xi = xi_1 + h * vi_1
    t = t0 + i * h
    exacta = sin(t) + cos(t)
    vexacta = cos(t) - sin(t)
    error = abs(xi - exacta)
    write(10, *) t, xi, vi, error, exacta, vexacta
end do

CONTAINS

function f(x)
real (pr) :: f
real (pr), intent(in) :: x
integer(kind=8), parameter :: k = 1

    f = -k*x

end function f

END PROGRAM ej6_a


program househ_ppal

use househ_interface
use sistu_interface
use datasissim_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:,:), allocatable :: a_copia
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: b_copia
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), a_copia(n,n), b(n), b_copia(n), u(n), r(n))

u = 0

call datasissim(a, b)

a_copia = a

b_copia = b

call househ(a, b, deter)

print*, 'A matriz A e: '

do i=1,n
  print*, a(i,:)
end do

call sistu(a, b, u)
call residuo(a_copia, b_copia, u, r)

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

if(allocated(r)) deallocate(r)

if(allocated(a_copia)) deallocate(a_copia)

if(allocated(b_copia)) deallocate(b_copia)

end program


      subroutine berger78(iyear_AD)

C-----------------------------------------------------------------------
C
C	Calculate earth's orbital parameters using Dave Threshers
C	formula which came from Berger, Andre.  1978
C      "A Simple Algorithm to Compute Long-Term Variations
C      of Daily Insolation".  Contribution 18, Institute of Astronomy and
C      Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve,
C	Belgium.
C
C---------------------------Code history--------------------------------
C
C Original Author: Erik Kluzek
C Date:            Oct/97
C
C-----------------------------------------------------------------------
      implicit none
C---------------------------- Input Arguments --------------------------
      integer iyear_AD ! Year to calculate orbit for..
C--------------------------- Output Arguments --------------------------
      real eccen,      ! Earth's orbital eccentricity
     $     obliq,      ! Earth's obliquity in degree's
     $     mvelp       ! Earth's moving vernal equinox longitude
      common/orbpar/eccen, obliq, mvelp

C------------------------------Parameters-------------------------------
C
C Parameters for calculating earth's orbital characteristics
C
      integer poblen,  ! number of elements in the series to calc obliquity
     $        pecclen, ! number of elements in the series to calc eccentricity
     $        pmvelen  ! number of elements in the series to calc vernal equinox
      parameter( poblen = 47, pecclen = 19, pmvelen = 78 )
      real
     $  psecdeg,         ! arc seconds to degrees conversion
     $  degrad,          ! degrees to radians conversion factor
     $  obamp(poblen),   ! amplitudes for obliquity cosine series
     $  obrate(poblen),  ! rates for obliquity cosine series
     $  obphas(poblen),  ! phases for obliquity cosine series
     $  ecamp(pecclen),  ! amplitudes for eccentricity/fvelp cosine/sine series
     $  ecrate(pecclen), ! rates for eccentricity/fvelp cosine/sine series
     $  ecphas(pecclen), ! phases for eccentricity/fvelp cosine/sine series
     $  mvamp(pmvelen),  ! amplitudes for mvelp sine series
     $  mvrate(pmvelen), ! rates for mvelp sine series
     $  mvphas(pmvelen), ! phases for mvelp sine series
     $  yb4_1950AD       ! number of years before 1950 AD
C
      parameter(psecdeg = 1./3600.)
C
C  Cosine series data for computation of obliquity:
C  amplitude (arc seconds), rate (arc seconds/year), phase (degrees).
C
      data obamp /-2462.2214466, -857.3232075, -629.3231835,
     $             -414.2804924, -311.7632587,  308.9408604,
     $             -162.5533601, -116.1077911,  101.1189923,
     $              -67.6856209,   24.9079067,   22.5811241,
     $              -21.1648355,  -15.6549876,   15.3936813,
     $               14.6660938,  -11.7273029,   10.2742696,
     $                6.4914588,    5.8539148,   -5.4872205,
     $               -5.4290191,    5.1609570,    5.0786314,
     $               -4.0735782,    3.7227167,    3.3971932,
     $               -2.8347004,   -2.6550721,   -2.5717867,
     $               -2.4712188,    2.4625410,    2.2464112,
     $               -2.0755511,   -1.9713669,   -1.8813061,
     $               -1.8468785,    1.8186742,    1.7601888,
     $               -1.5428851,    1.4738838,   -1.4593669,
     $                1.4192259,   -1.1818980,    1.1756474,
     $               -1.1316126,    1.0896928/
C
      data obrate /31.609974, 32.620504, 24.172203,
     $             31.983787, 44.828336, 30.973257,
     $             43.668246, 32.246691, 30.599444,
     $             42.681324, 43.836462, 47.439436,
     $             63.219948, 64.230478,  1.010530,
     $              7.437771, 55.782177,  0.373813,
     $             13.218362, 62.583231, 63.593761,
     $             76.438310, 45.815258,  8.448301,
     $             56.792707, 49.747842, 12.058272,
     $             75.278220, 65.241008, 64.604291,
     $              1.647247,  7.811584, 12.207832,
     $             63.856665, 56.155990, 77.448840,
     $              6.801054, 62.209418, 20.656133,
     $             48.344406, 55.145460, 69.000539,
     $             11.071350, 74.291298, 11.047742,
     $              0.636717, 12.844549/
C
      data obphas /251.9025, 280.8325, 128.3057,
     $             292.7252,  15.3747, 263.7951,
     $             308.4258, 240.0099, 222.9725,
     $             268.7809, 316.7998, 319.6024,
     $             143.8050, 172.7351,  28.9300,
     $             123.5968,  20.2082,  40.8226,
     $             123.4722, 155.6977, 184.6277,
     $             267.2772,  55.0196, 152.5268,
     $              49.1382, 204.6609,  56.5233,
     $             200.3284, 201.6651, 213.5577,
     $              17.0374, 164.4194,  94.5422,
     $             131.9124,  61.0309, 296.2073,
     $             135.4894, 114.8750, 247.0691,
     $             256.6114,  32.1008, 143.6804,
     $              16.8784, 160.6835,  27.5932,
     $             348.1074,  82.6496/
C
C  Cosine/sine series data for computation of eccentricity and
C  fixed vernal equinox longitude of perihelion (fvelp):
C  amplitude, rate (arc seconds/year), phase (degrees).
C
      data ecamp /0.01860798,  0.01627522, -0.01300660,
     $            0.00988829, -0.00336700,  0.00333077,
     $           -0.00235400,  0.00140015,  0.00100700,
     $            0.00085700,  0.00064990,  0.00059900,
     $            0.00037800, -0.00033700,  0.00027600,
     $            0.00018200, -0.00017400, -0.00012400,
     $            0.00001250/
C
      data ecrate /4.2072050,  7.3460910, 17.8572630,
     $            17.2205460, 16.8467330,  5.1990790,
     $            18.2310760, 26.2167580,  6.3591690,
     $            16.2100160,  3.0651810, 16.5838290,
     $            18.4939800,  6.1909530, 18.8677930,
     $            17.4255670,  6.1860010, 18.4174410,
     $             0.6678630/
C
      data ecphas /28.620089, 193.788772, 308.307024,
     $            320.199637, 279.376984,  87.195000,
     $            349.129677, 128.443387, 154.143880,
     $            291.269597, 114.860583, 332.092251,
     $            296.414411, 145.769910, 337.237063,
     $            152.092288, 126.839891, 210.667199,
     $             72.108838/
C
C  Sine series data for computation of moving vernal equinox
C  longitude of perihelion:
C  amplitude (arc seconds), rate (arc seconds/year), phase (degrees).
C
      data mvamp /7391.0225890, 2555.1526947, 2022.7629188,
     $           -1973.6517951, 1240.2321818,  953.8679112,
     $            -931.7537108,  872.3795383,  606.3544732,
     $            -496.0274038,  456.9608039,  346.9462320,
     $            -305.8412902,  249.6173246, -199.1027200,
     $             191.0560889, -175.2936572,  165.9068833,
     $             161.1285917,  139.7878093, -133.5228399,
     $             117.0673811,  104.6907281,   95.3227476,
     $              86.7824524,   86.0857729,   70.5893698,
     $             -69.9719343,  -62.5817473,   61.5450059,
     $             -57.9364011,   57.1899832,  -57.0236109,
     $             -54.2119253,   53.2834147,   52.1223575,
     $             -49.0059908,  -48.3118757,  -45.4191685,
     $             -42.2357920,  -34.7971099,   34.4623613,
     $             -33.8356643,   33.6689362,  -31.2521586,
     $             -30.8798701,   28.4640769,  -27.1960802,
     $              27.0860736,  -26.3437456,   24.7253740,
     $              24.6732126,   24.4272733,   24.0127327,
     $              21.7150294,  -21.5375347,   18.1148363,
     $             -16.9603104,  -16.1765215,   15.5567653,
     $              15.4846529,   15.2150632,   14.5047426,
     $             -14.3873316,   13.1351419,   12.8776311,
     $              11.9867234,   11.9385578,   11.7030822,
     $              11.6018181,  -11.2617293,  -10.4664199,
     $              10.4333970,  -10.2377466,   10.1934446,
     $             -10.1280191,   10.0289441,  -10.0034259/
C
      data mvrate /31.609974, 32.620504, 24.172203,
     $              0.636717, 31.983787,  3.138886,
     $             30.973257, 44.828336,  0.991874,
     $              0.373813, 43.668246, 32.246691,
     $             30.599444,  2.147012, 10.511172,
     $             42.681324, 13.650058,  0.986922,
     $              9.874455, 13.013341,  0.262904,
     $              0.004952,  1.142024, 63.219948,
     $              0.205021,  2.151964, 64.230478,
     $             43.836462, 47.439436,  1.384343,
     $              7.437771, 18.829299,  9.500642,
     $              0.431696,  1.160090, 55.782177,
     $             12.639528,  1.155138,  0.168216,
     $              1.647247, 10.884985,  5.610937,
     $             12.658184,  1.010530,  1.983748,
     $             14.023871,  0.560178,  1.273434,
     $             12.021467, 62.583231, 63.593761,
     $             76.438310,  4.280910, 13.218362,
     $             17.818769,  8.359495, 56.792707,
     $              8.448301,  1.978796,  8.863925,
     $              0.186365,  8.996212,  6.771027,
     $             45.815258, 12.002811, 75.278220,
     $             65.241008, 18.870667, 22.009553,
     $             64.604291, 11.498094,  0.578834,
     $              9.237738, 49.747842,  2.147012,
     $              1.196895,  2.133898,  0.173168/
C
      data mvphas /251.9025, 280.8325, 128.3057,
     $             348.1074, 292.7252, 165.1686,
     $             263.7951,  15.3747,  58.5749,
     $              40.8226, 308.4258, 240.0099,
     $             222.9725, 106.5937, 114.5182,
     $             268.7809, 279.6869,  39.6448,
     $             126.4108, 291.5795, 307.2848,
     $              18.9300, 273.7596, 143.8050,
     $             191.8927, 125.5237, 172.7351,
     $             316.7998, 319.6024,  69.7526,
     $             123.5968, 217.6432,  85.5882,
     $             156.2147,  66.9489,  20.2082,
     $             250.7568,  48.0188,   8.3739,
     $              17.0374, 155.3409,  94.1709,
     $             221.1120,  28.9300, 117.1498,
     $             320.5095, 262.3602, 336.2148,
     $             233.0046, 155.6977, 184.6277,
     $             267.2772,  78.9281, 123.4722,
     $             188.7132, 180.1364,  49.1382,
     $             152.5268,  98.2198,  97.4808,
     $             221.5376, 168.2438, 161.1199,
     $              55.0196, 262.6495, 200.3284,
     $             201.6651, 294.6547,  99.8233,
     $             213.5577, 154.1631, 232.7153,
     $             138.3034, 204.6609, 106.5938,
     $             250.4676, 332.3345,  27.3039/
C
C---------------------------Local variables-----------------------------
C
      integer i       ! Index for series summations
      real obsum,     ! Obliquity series summation
     $     cossum,    ! Cosine series summation for eccentricity/fvelp
     $     sinsum,    ! Sine series summation for eccentricity/fvelp
     $     fvelp,     ! Fixed vernal equinox longitude of perihelion
     $     mvsum,     ! mvelp series summation
     $     beta,      ! Intermediate argument for lambm0
     $     years      ! Years to time of interest (negative = past;
C                     ! positive = future)
      real eccen2     ! eccentricity squared
      real pi        ! pi
C-----------------------------------------------------------------------
C
C radinp and algorithms below will need a degrees to radians conversion
C factor.
C
      pi     =  4.*atan(1.)
      degrad = pi/180.
C
C
C The following calculates the earth's obliquity, orbital eccentricity
C (and various powers of it) and vernal equinox mean longitude of
C perihelion for years in the past (future = negative of years past),
C using constants (see parameter section) given in the program of:
C
C Berger, Andre.  1978  A Simple Algorithm to Compute Long-Term Variations
C of Daily Insolation.  Contribution 18, Institute of Astronomy and
C Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium.
C
C and formulas given in the paper (where less precise constants are also
C given):
C
C Berger, Andre.  1978.  Long-Term Variations of Daily Insolation and
C Quaternary Climatic Changes.  J. of the Atmo. Sci. 35:2362-2367
C
C The algorithm is valid only to 1,000,000 years past or hence.
C For a solution valid to 5-10 million years past see the above author.
C Algorithm below is better for years closer to present than is the
C 5-10 million year solution.
C
C Years to time of interest must be negative of years before present
C (1950) in formulas that follow.
C
        yb4_1950AD = 1950.0 - float(iyear_AD)
        years = - yb4_1950AD
C
C In the summations below, cosine or sine arguments, which end up in
C degrees, must be converted to radians via multiplication by degrad.
C
C Summation of cosine series for obliquity (epsilon in Berger 1978) in
C degrees. Convert the amplitudes and rates, which are in arc seconds, into
C degrees via multiplication by psecdeg (arc seconds to degrees conversion
C factor).  For obliq, first term is Berger 1978's epsilon star; second
C term is series summation in degrees.
C
        obsum = 0.0
        do i = 1, poblen
          obsum = obsum +
     $           obamp(i)*psecdeg*cos((obrate(i)*psecdeg*years +
     $                                obphas(i))*degrad)
        end do
        obliq = 23.320556 + obsum
C
C Summation of cosine and sine series for computation of eccentricity
C (eccen; e in Berger 1978) and fixed vernal equinox longitude of perihelion
C (fvelp; pi in Berger 1978), which is used for computation of moving vernal
C equinox longitude of perihelion.  Convert the rates, which are in arc
C seconds, into degrees via multiplication by psecdeg.
C
        cossum = 0.0
        do i = 1, pecclen
          cossum = cossum +
     $            ecamp(i)*cos((ecrate(i)*psecdeg*years +
     $                          ecphas(i))*degrad)
        end do
C
        sinsum = 0.0
        do i = 1, pecclen
          sinsum = sinsum +
     $            ecamp(i)*sin((ecrate(i)*psecdeg*years +
     $                          ecphas(i))*degrad)
        end do
C
C Use summations to calculate eccentricity
C
        eccen2 = cossum*cossum + sinsum*sinsum
        eccen = sqrt(eccen2)
C
C A series of cases for fvelp, which is in radians.
C
        if (abs(cossum) .le. 1.0E-8) then
          if (sinsum .eq. 0.0) then
            fvelp = 0.0
          else if (sinsum .lt. 0.0) then
            fvelp = 1.5*pi
          else if (sinsum .gt. 0.0) then
            fvelp = .5*pi
          endif
        else if (cossum .lt. 0.0) then
          fvelp = atan(sinsum/cossum) + pi
        else if (cossum .gt. 0.0) then
          if (sinsum .lt. 0.0) then
            fvelp = atan(sinsum/cossum) + 2.0*pi
          else
            fvelp = atan(sinsum/cossum)
          endif
        endif
C
C Summation of sine series for computation of moving vernal equinox longitude
C of perihelion (mvelp; omega bar in Berger 1978) in degrees.  For mvelp,
C first term is fvelp in degrees; second term is Berger 1978's psi bar times
C years and in degrees; third term is Berger 1978's zeta; fourth term is
C series summation in degrees.  Convert the amplitudes and rates, which are
C in arc seconds, into degrees via multiplication by psecdeg.  Series summation
C plus second and third terms constitute Berger 1978's psi, which is the
C general precession.
C
        mvsum = 0.0
        do i = 1, pmvelen
          mvsum = mvsum +
     $           mvamp(i)*psecdeg*sin((mvrate(i)*psecdeg*years +
     $                                mvphas(i))*degrad)
        end do
        mvelp = fvelp/degrad + 50.439273*psecdeg*years + 3.392506
     $  + mvsum
C
C Cases to make sure mvelp is between 0 and 360.
C
        do while (mvelp .lt. 0.0)
          mvelp = mvelp + 360.0
        end do
        do while (mvelp .ge. 360.0)
          mvelp = mvelp - 360.0
        end do
C
      end


!==============================================================
! Uniform circular motion in cartesian coordinates
! Author: Devansh Shukla
!==============================================================
program CircularMotion_Cartesian
    ! Program to compute motion of a particle moving with uniform angular velocity in cartesian coordinates.

    implicit none
    real, parameter :: PI=3.141593
    real :: x0=0.0, y0=0.0, R=0.0, omega=0.0
    real :: x, y, dx, dy, ddx, ddy
    real :: t0=0.0, tf=0.0, dt=0.0, t=0.0
    character(len=*), parameter :: fmt1 = "(F10.4,x,F10.4,x,F10.4,x,F10.4,x,F10.4,x,F10.4,x,F10.4)"

    x(t) = x0 + R*cos(omega*(t-t0))
    y(t) = y0 + R*sin(omega*(t-t0))

    dx(t) = -R*omega*sin(omega*(t-t0))
    dy(t) = R*omega*cos(omega*(t-t0))

    ddx(t) = -R*omega*omega*cos(omega*(t-t0))
    ddy(t) = -R*omega*omega*sin(omega*(t-t0))

    open(UNIT=8, FILE="CircleCartesian.dat")

    ! input
    print *, "Enter angular velocity(omega) and radius (R)"
    read *, omega, R
    if (omega .le. 0.0) stop "Illegal  value of omega"
    if (R .le. 0.0) stop "Illegal value of R"

    print *, "Enter the value of x0, y0"
    read *, x0, y0

    print *, "Enter t0, tf, dt"
    read *, t0, tf, dt
    if (dt .le. 0.0) stop "Illegal value of dt"

    print *, "---------------------------------------------------"
    print "(x,A,F10.4,F10.4)", "omega, R =", omega, R
    print "(x,A,F10.4)", "T =", 2.0*PI/omega
    print "(x,A,F10.4,F10.4)", "x0, y0 =", x0, y0
    print "(x,A,F10.4,F10.4,F10.4)", "t0, tf, dt =", t0, tf, dt
    print *, "---------------------------------------------------"

    write (8, *) "# x0=", x0
    write (8, *) "# y0=", y0
    write (8, *) "# t0=", t0
    write (8, *) "# t x y dx dy ddx ddy"
    print "(xA10,A10,xA10,A10,A10,xA10,xA10)", "time", "x(t)", "y(t)", "vx(t)", "vy(t)", "ax(t)", "ay(t)"
    ! Computing
    t = t0
    do while (t <= tf)
        write (*, fmt1) t, x(t), y(t), dx(t), dy(t), ddx(t), ddy(t)
        write (8, fmt1) t, x(t), y(t), dx(t), dy(t), ddx(t), ddy(t)
        t = t + dt
    enddo
    print *, "---------------------------------------------------"
    close(8)

end program CircularMotion_Cartesian


	SUBROUTINE enercalc(Nx,isignf,isignb,incx,incy,ntable,nwork,dt,Es,&
                            enkin,enstr,enpot,en,&
                            kx,temp1,temp2,&
                            v,vold,u,uold,table,work)

	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine program calculates the energy for the nonlinear
	! Klein-Gordon equation in 1 dimension
	! u_{tt}-u_{xx}+u=Es*|u|^2u
	!
	! The energy density is given by
	! 0.5u_t^2+0.5u_x^2+0.5u^2+Es*0.25u^4
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  planfx			= Forward 2d fft plan
	!  planbx			= Backward 2d fft plan
	!  dt				= timestep
	!  Es				= +1 for focusing, -1 for defocusing
	! .. Arrays ..
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  temp1			= array to hold temporary values
	!  temp2			= array to hold temporary values
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!
	! OUTPUT
	!
	! .. Scalars ..
	!  enkin			= Kinetic energy
	!  enstr			= Strain energy
	!  enpot			= Potential energy
	!  en				= Total energy
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library
	!USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)			     :: Nx
	REAL(KIND=8), INTENT(IN)			     :: dt,Es
	COMPLEX(KIND=8), DIMENSION(1:Nx),INTENT(IN)	     :: kx
	COMPLEX(KIND=8), DIMENSION(1:Nx),INTENT(IN)	     :: u,v,uold,vold
	COMPLEX(KIND=8), DIMENSION(1:Nx),INTENT(INOUT)	     :: temp1,temp2
	REAL(KIND=8), INTENT(OUT)			     :: enkin,enstr
	REAL(KIND=8), INTENT(OUT)			     :: enpot,en
	INTEGER(kind=4), INTENT(IN)                          :: ntable,nwork
        INTEGER(kind=4), INTENT(IN)                          :: incx, incy
        INTEGER(kind=4), INTENT(IN)                          :: isignb, isignf
        REAL(kind=8)                                         :: scale
        REAL(kind=8), DIMENSION(1:ntable), INTENT(INOUT)     :: table
        REAL(kind=8), DIMENSION(1:nwork), INTENT(INOUT)      :: work
        INTEGER(KIND=4)			                     :: i
	REAL(kind=8), PARAMETER                   :: c=0.5d0,t=0.0d0
        scale=1.0d0/(REAL(Nx,kind(0d0)))
	!.. Strain energy ..
	!!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		temp1(i)=0.5d0*kx(i)*(vold(i)+v(i))
	END DO
	!!$OMP END PARALLEL DO
        CALL ZFFT(isignb,Nx,scale,temp1,incx,temp2,incy,&
                   table,ntable,work,nwork)
        enstr=0.0d0
	!!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		enstr=enstr+0.5d0*abs(temp2(i))**2
	END DO
	!!$OMP END PARALLEL DO
	! .. Kinetic Energy ..
        enkin=0.0d0
	!!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		enkin=enkin+0.5d0*( abs(u(i)-uold(i))/dt )**2
	END DO
	!!$OMP END PARALLEL DO

	! .. Potential Energy ..
        enpot=0.0D0
	!!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		enpot=enpot+0.5d0*(abs((u(i)+uold(i))*0.50d0))**2&
				-0.125d0*Es*(abs(u(i))**4+abs(uold(i))**4)
	END DO
	!!$OMP END PARALLEL DO
        !enpot=enpot/Nx
        !enkin=enkin/Nx
        !enstr=enstr/Nx
	en=enpot+enkin+enstr

	END SUBROUTINE enercalc


    Program dgelss_example

!     DGELSS Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dnrm2
      Use lapack_interfaces, Only: dgelss
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rcond, rnorm
      Integer :: i, info, lda, lwork, m, n, rank
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:), s(:), work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGELSS Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      lwork = 3*n + nb*(m+n)
      Allocate (a(lda,n), b(m), s(n), work(lwork))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *) b(1:m)

!     Choose RCOND to reflect the relative accuracy of the input data

      rcond = 0.01_dp

!     Solve the least squares problem min( norm2(b - Ax) ) for the x
!     of minimum norm.

      Call dgelss(m, n, 1, a, lda, b, m, s, rcond, rank, work, lwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Least squares solution'
        Write (nout, 100) b(1:n)

!       Print the effective rank of A

        Write (nout, *)
        Write (nout, *) 'Tolerance used to estimate the rank of A'
        Write (nout, 110) rcond
        Write (nout, *) 'Estimated rank of A'
        Write (nout, 120) rank

!       Print singular values of A

        Write (nout, *)
        Write (nout, *) 'Singular values of A'
        Write (nout, 100) s(1:n)

!       Compute and print estimate of the square root of the
!       residual sum of squares

        If (rank==n) Then
          rnorm = dnrm2(m-n, b(n+1), 1)
          Write (nout, *)
          Write (nout, *) 'Square root of the residual sum of squares'
          Write (nout, 110) rnorm
        End If
      Else
        Write (nout, *) 'The SVD algorithm failed to converge'
      End If

100   Format (1X, 7F11.4)
110   Format (3X, 1P, E11.2)
120   Format (1X, I6)
    End Program


c Matrix mutliply: c(m,m) = a(m,m)*b(m,m)

	subroutine matmult1(maxm, m, a, b, c)

	implicit none

c	Parameters:
	integer	maxm
	integer	m
	real	a(maxm,maxm)	! (1..maxm, 1..maxm)
	real	b(maxm,maxm)	! (1..maxm, 1..maxm)
	real	c(maxm,maxm)	! (1..maxm, 1..maxm)

c	Local variables:
	integer	j, l, k		! Dummy loop indices
	real	sum

      do j=1,m
         do k=1,m
            sum=0.0
            do l=1,m
               sum=sum+a(j,l)*b(l,k)
            end do
            c(j,k)=sum
         end do
      end do
      return
      end