From 5231b239e3751aeef329799c76dfb9272adfe174 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:29:49 +0100 Subject: [PATCH 1/7] renamed source files to have F90 extension --- clustering.f95 | 943 -- descriptors.f95 | 13206 ----------------------- descriptors_wrapper.f95 | 587 - find_water_triplets_noncommercial.f95 | 485 - gap_fit.f95 | 113 - gap_fit_module.f95 | 2393 ---- gp_fit.f95 | 750 -- gp_predict.f95 | 5290 --------- make_permutations_noncommercial_v2.f95 | 733 -- 9 files changed, 24500 deletions(-) delete mode 100644 clustering.f95 delete mode 100644 descriptors.f95 delete mode 100644 descriptors_wrapper.f95 delete mode 100644 find_water_triplets_noncommercial.f95 delete mode 100644 gap_fit.f95 delete mode 100644 gap_fit_module.f95 delete mode 100644 gp_fit.f95 delete mode 100644 gp_predict.f95 delete mode 100644 make_permutations_noncommercial_v2.f95 diff --git a/clustering.f95 b/clustering.f95 deleted file mode 100644 index d3ed958a..00000000 --- a/clustering.f95 +++ /dev/null @@ -1,943 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module clustering_module - - ! use libatoms_module - use error_module - use system_module ! , only : dp, optional_default, ran_uniform, reallocate - use linearalgebra_module - - implicit none - private - - public :: pivot, bisect_kmedoids, cluster_kmeans, select_uniform, cluster_fuzzy_cmeans, cur_decomposition - - integer, parameter :: n_trial = 10 - integer, parameter :: n_trial_k_med = 100 - real(dp), parameter :: cluster_jitter = 1.0e-7_dp - real(dp), parameter :: KMEANS_THRESHOLD = 1.0e-6_dp - - type lst - integer, dimension(:), allocatable :: object - integer :: medoid - real(dp) :: sse - integer :: N - endtype lst - - type clstr - type(lst), dimension(:), allocatable :: cluster - real(dp), dimension(:,:), pointer :: dm - integer :: N - endtype clstr - - contains - - subroutine distance_matrix(x,dm,theta_fac,theta) - real(dp), dimension(:,:), intent(in) :: x - real(dp), dimension(:,:), intent(out) :: dm - real(dp), intent(in), optional :: theta_fac - real(dp), dimension(:), intent(in), target, optional :: theta - - real(dp), dimension(:), pointer :: my_theta => null() - real(dp) :: my_theta_fac - integer :: i, j, d, n - - my_theta_fac = optional_default(1.0_dp, theta_fac) - d = size(x,1) - n = size(x,2) - - if( present(theta) ) then - if( size(theta) == d) then - my_theta => theta - else - allocate(my_theta(d)) - my_theta = theta(1) - endif - else - allocate(my_theta(d)) - - do i = 1, d - my_theta(i) = ( maxval(x(i,:)) - minval(x(i,:)) ) - ! theta(i) = sqrt( & !take square root - ! & sum( x(i,:)**2 ) / size(x(i,:)) - & - ! & (sum( x(i,:) ) / size(x(i,:)))**2 ) - if( my_theta(i) .feq. 0.0_dp ) my_theta(i) = 1.0_dp - enddo - my_theta = my_theta * my_theta_fac - endif - - do i = 1, n - do j = i + 1, n - dm(j,i) = cluster_jitter*ran_uniform() - enddo - dm(i,i) = 0.0_dp - enddo - -!$omp parallel do default(none) shared(dm,n,x,my_theta) private(i,j) schedule(dynamic) - do i = 1, n - do j = i + 1, n - dm(j,i) = dm(j,i) + sqrt( sum( ( (x(:,j) - x(:,i)) / my_theta )**2 ) ) - dm(i,j) = dm(j,i) - enddo - enddo -!$omp end parallel do - - do i = 1, n - do j = i + 1, n - dm(i,j) = dm(j,i) - enddo - enddo - - if( present(theta) ) then - my_theta => null() - else - deallocate(my_theta) - endif - - endsubroutine distance_matrix - - subroutine pca(x,x_mean,v) - - real(dp), dimension(:,:), intent(in) :: x - real(dp), dimension(:), intent(out) :: x_mean - real(dp), dimension(:,:), intent(out) :: v - - real(dp), dimension(:), allocatable :: diag_c - real(dp), dimension(:,:), allocatable :: cov - integer :: i, j, d, n - - d = size(x,1) - n = size(x,2) - allocate(cov(d,d),diag_c(d)) - - x_mean = sum(x,dim=2) / n ! empirical mean - - do i = 1, d - do j = 1, d - cov(j,i) = dot_product(x(i,:),x(j,:)) / n - x_mean(i)*x_mean(j) - enddo - enddo - - call diagonalise(cov,diag_c, evects=v) - - deallocate(cov, diag_c) - - endsubroutine pca - - subroutine pivot(x,pivout,theta_fac,theta) - real(dp), dimension(:,:), intent(in) :: x - integer, dimension(:), intent(out) :: pivout - real(dp), intent(in), optional :: theta_fac - real(dp), dimension(:), intent(in), optional :: theta - - real(dp), dimension(:,:), allocatable :: knn - real(dp), dimension(:), allocatable :: ktmp - integer, dimension(:), allocatable :: pivin - - integer :: stat, i, j, k, d, m, n, jtmp, jmax - real(dp) :: dmax - - d = size(x,1) - n = size(x,2) - - m = size(pivout) - - if( m > n ) call system_abort('pivot: required number of changes ('//m//') greater than possible number of changes ('//n//')') - - allocate(knn(n,n),stat=stat) - if(stat /=0 ) call system_abort('pivot: could not allocate knn matrix.') - - allocate(pivin(n),ktmp(n)) - - call distance_matrix(x,knn,theta_fac=theta_fac,theta=theta) - do i = 1, n - do j = 1, n - knn(j,i) = exp(-0.5_dp*knn(j,i)) - enddo - enddo - - pivin = (/ (i, i=1,n) /) - - do k = 1, m - dmax = 0.0_dp - do j = k, n - if( dmax < knn(j,j) ) then - jmax = j - dmax = knn(j,j) - endif - enddo - if( jmax /= k ) then - jtmp = pivin(jmax) - pivin(jmax) = pivin(k) - pivin(k) = jtmp - - ktmp = knn(k,:) - knn(k,:) = knn(jmax,:) - knn(jmax,:) = ktmp - - ktmp = knn(:,k) - knn(:,k) = knn(:,jmax) - knn(:,jmax) = ktmp - endif - - knn(k,k) = sqrt(knn(k,k)) - - knn(k+1:n,k) = knn(k+1:n,k)/knn(k,k) - do j = k+1, n - knn(j:n,j) = knn(j:n,j) - knn(j:n,k)*knn(j,k) - enddo - - do j = 1, n - do i = j+1,n - knn(j,i) = knn(i,j) - enddo - enddo - enddo - - pivout = pivin(1:m) - - deallocate(knn,pivin,ktmp) - - endsubroutine pivot - - subroutine bisect_kmedoids(dat,n_clusters_in, c,med, theta_fac,theta, is_distance_matrix) - real(dp), dimension(:,:), intent(in), target :: dat - integer, intent(in) :: n_clusters_in - integer, dimension(:), intent(out),optional :: c, med - real(dp), intent(in), optional :: theta_fac - real(dp), dimension(:), intent(in), optional :: theta - logical, intent(in), optional :: is_distance_matrix - - type(clstr) :: my_cluster, tmp - - logical :: must_calculate_distance - real(dp), dimension(:,:), allocatable, target :: dm - - real(dp), dimension(:), allocatable :: dv - real(dp) :: max_sse, min_sse, sse - - integer, dimension(:), allocatable :: sub_cluster1, sub_cluster2, sub_cluster1_min, sub_cluster2_min - integer, dimension(1) :: ml - integer :: stat, i, j, k, km, m, n, nc, & - lo_med, hi_med, lo_med_new, hi_med_new, lo_med_min, hi_med_min, n1, n2, n1_min, n2_min, iter - - must_calculate_distance = .not. optional_default(.true., is_distance_matrix) - - n = size(dat,2) - if (.not. must_calculate_distance) then - if (size(dat,1) /= n) call system_abort('is_distance_matrix but not square') - endif - - if( n_clusters_in > n ) call system_abort('bisect_kmedoids: required number of cluster greater than total number of data points') - - if(present(c) ) c = 0 - - if (must_calculate_distance) then - allocate(dm(n,n), stat=stat) - if(stat /=0 ) call system_abort('bisect_kmedoids: could not allocate dm matrix.') - - call print('Started distance matrix calculation', verbosity=PRINT_NERD) - call distance_matrix(dat, dm, theta_fac=theta_fac,theta=theta) - call print('Finished distance matrix calculation', verbosity=PRINT_NERD) - my_cluster%dm => dm - else - my_cluster%dm => dat - endif - - ! start clustering - my_cluster%N = 1 ! start with one big cluster - allocate( my_cluster%cluster(1) ) - my_cluster%cluster(1)%N = n ! put every object in the initial cluster - allocate( my_cluster%cluster(1)%object(n) ) - my_cluster%cluster(1)%object = (/(i,i=1,n)/) - - allocate(dv(n)) ! distance vector, the sum of square of distances of points from central object - dv = sum(my_cluster%dm,dim=1) - my_cluster%cluster(1)%sse = minval( dv ) ! determine initial medoid, the object that is the - ml = minloc( dv ) ! closest to any other object in cluster - my_cluster%cluster(1)%medoid = ml(1) - deallocate(dv) - - ! main loop starts here, bisects initial clusters until desired number of - ! clusters are found - - iter = 0 - do - iter = iter + 1 - call print("Starting iteration "//iter,verbosity=PRINT_NERD) - - if( my_cluster%N == n_clusters_in ) exit - max_sse = -1.0_dp ! select cluster with greatest sse - do j = 1, my_cluster%N - if( max_sse < my_cluster%cluster(j)%sse ) then - i = j - max_sse = my_cluster%cluster(j)%sse - endif - enddo - nc = my_cluster%cluster(i)%N - if( nc==1 ) cycle - allocate( sub_cluster1(nc), sub_cluster2(nc), sub_cluster1_min(nc),sub_cluster2_min(nc) ) - - min_sse = huge(1.0_dp) - do j = 1, n_trial - m = ceiling( ran_uniform()*(nc-1) ) ! choose a bisecting point randomly - ml = minloc( sum( my_cluster%dm( my_cluster%cluster(i)%object(:m), my_cluster%cluster(i)%object(:m) ), dim=1) ) - lo_med_new = my_cluster%cluster(i)%object(ml(1)) - - ml = minloc( sum( my_cluster%dm( my_cluster%cluster(i)%object(m+1:), my_cluster%cluster(i)%object(m+1:) ), dim=1) ) - - hi_med_new = my_cluster%cluster(i)%object(ml(1) + m) - - ! the median of the 2 subclusters determined - lo_med = 0 - hi_med = 0 - - ! perform k-medoid clustering on the two subclusters - do km = 1, n_trial_k_med - if( (lo_med_new == lo_med) .and. (hi_med_new == hi_med) ) exit - lo_med = lo_med_new - hi_med = hi_med_new - n1 = 0 - n2 = 0 - !n1 = 1 - !n2 = 1 - !sub_cluster1(n1) = lo_med - !sub_cluster1(n2) = hi_med - - do k = 1, my_cluster%cluster(i)%N - if( my_cluster%dm(lo_med,my_cluster%cluster(i)%object(k)) < & - & my_cluster%dm(hi_med,my_cluster%cluster(i)%object(k)) ) then - n1 = n1 + 1 - sub_cluster1(n1) = my_cluster%cluster(i)%object(k) - else - n2 = n2 + 1 - sub_cluster2(n2) = my_cluster%cluster(i)%object(k) - endif - enddo - - ml = minloc( sum( my_cluster%dm( sub_cluster1(:n1), sub_cluster1(:n1) ), dim=1) ) - lo_med_new = sub_cluster1(ml(1)) - ml = minloc( sum( my_cluster%dm( sub_cluster2(:n2), sub_cluster2(:n2) ), dim=1) ) - hi_med_new = sub_cluster2(ml(1)) - enddo - sse = sum( my_cluster%dm(lo_med_new,sub_cluster1(:n1)) ) + sum( my_cluster%dm(hi_med_new,sub_cluster2(:n2)) ) - - ! choose the clustering that resulted the smallest sse - if( sse < min_sse ) then - min_sse = sse - sub_cluster1_min = sub_cluster1 - sub_cluster2_min = sub_cluster2 - n1_min = n1 - n2_min = n2 - lo_med_min = lo_med_new - hi_med_min = hi_med_new - endif - enddo - - ! now update the the clusters with the two new subclusters - tmp = my_cluster - - do j = 1, my_cluster%N - deallocate( my_cluster%cluster(j)%object ) - enddo - deallocate( my_cluster%cluster ) - my_cluster%N = my_cluster%N + 1 - allocate( my_cluster%cluster( my_cluster%N ) ) - - do j = 1, my_cluster%N - 1 - if( i == j ) then - allocate( my_cluster%cluster(j)%object(n1_min) ) - my_cluster%cluster(j)%N = n1_min - my_cluster%cluster(j)%object = sub_cluster1_min(:n1_min) - my_cluster%cluster(j)%sse = sum( my_cluster%dm(lo_med_min,sub_cluster1_min(:n1_min)) ) - my_cluster%cluster(j)%medoid = lo_med_min - else - my_cluster%cluster(j) = tmp%cluster(j) - endif - enddo - allocate( my_cluster%cluster(my_cluster%N)%object(n2_min) ) - my_cluster%cluster(my_cluster%N)%N = n2_min - my_cluster%cluster(my_cluster%N)%object = sub_cluster2_min(:n2_min) - my_cluster%cluster(my_cluster%N)%sse = sum( my_cluster%dm(hi_med_min,sub_cluster2_min(:n2_min)) ) - my_cluster%cluster(my_cluster%N)%medoid = hi_med_min - - do j = 1, tmp%N - deallocate( tmp%cluster(j)%object ) - enddo - deallocate( tmp%cluster, sub_cluster1, sub_cluster2, sub_cluster1_min, sub_cluster2_min ) - - call kmedoid(my_cluster) - enddo - - if( present(c) ) then - do j = 1, my_cluster%N - do k = 1, my_cluster%cluster(j)%N - i = my_cluster%cluster(j)%object(k) - c(i) = j - enddo - enddo - endif - - if( present(med) ) then - do j = 1, my_cluster%N - med(j) = my_cluster%cluster(j)%medoid - enddo - endif - - do j = 1, my_cluster%N - deallocate( my_cluster%cluster(j)%object ) - enddo - deallocate(my_cluster%cluster) - if (allocated(dm)) deallocate(dm) - - endsubroutine bisect_kmedoids - - subroutine kmedoid(this) - type(clstr), intent(inout) :: this - - type(clstr) :: tmp - integer, dimension(:), allocatable :: medoids - integer, dimension(1) :: ml - integer :: n, j, k - logical :: refined - - ! k-medoid-refinement - n = size(this%dm,1) - ! n: total number of objects - - tmp%N = this%N - allocate( tmp%cluster(tmp%N), medoids(tmp%N) ) - do j = 1, tmp%N - allocate( tmp%cluster(j)%object(n) ) - medoids(j) = this%cluster(j)%medoid - enddo - - ! main loop starts here, perfom k-medoid clustering until medoids don't - ! change anymore - do - do j = 1, tmp%N - tmp%cluster(j)%N = 0 - enddo - do j = 1, n - ml = minloc( this%dm(j,medoids) ) ! determine to which medoid each object belongs - k = ml(1) - tmp%cluster(k)%N = tmp%cluster(k)%N + 1 - tmp%cluster(k)%object(tmp%cluster(k)%N) = j - enddo - - ! re-determine the medoid in each cluster - do j = 1, tmp%N - ml = minloc( sum( this%dm( tmp%cluster(j)%object(:tmp%cluster(j)%N), & - & tmp%cluster(j)%object(:tmp%cluster(j)%N) ), dim=1) ) - tmp%cluster(j)%medoid = tmp%cluster(j)%object(ml(1)) - enddo - - refined = .true. - - ! check whether medoids have changed - do j = 1, tmp%N - refined = refined .and. (tmp%cluster(j)%medoid == medoids(j)) - medoids(j) = tmp%cluster(j)%medoid - enddo - if(refined) exit - enddo - - ! write results - do j = 1, tmp%N - deallocate( this%cluster(j)%object ) - allocate( this%cluster(j)%object( tmp%cluster(j)%N ) ) - this%cluster(j)%object = tmp%cluster(j)%object(:tmp%cluster(j)%N) - this%cluster(j)%N = tmp%cluster(j)%N - this%cluster(j)%medoid = tmp%cluster(j)%medoid - this%cluster(j)%sse = sum( this%dm(this%cluster(j)%medoid,& - & this%cluster(j)%object ) ) - - deallocate( tmp%cluster(j)%object ) - enddo - deallocate( tmp%cluster, medoids ) - - endsubroutine kmedoid - - subroutine cluster_kmeans(x,cluster_index,theta_fac,theta) - real(dp), dimension(:,:), intent(in) :: x - integer, dimension(:), intent(out) :: cluster_index - real(dp), intent(in), optional :: theta_fac - real(dp), dimension(:), intent(in), target, optional :: theta - - real(dp), dimension(:), pointer :: my_theta => null() - real(dp) :: my_theta_fac, d_min, d_ij, d_total, d_total_prev - - real(dp), dimension(:,:), allocatable :: cluster_centre - integer, dimension(:), allocatable :: cluster_info - integer :: d, n, m, i, j, k, cluster_info_old, iter, n_points_cluster_j - logical :: cluster_same - - d = size(x,1) - n = size(x,2) - m = size(cluster_index) - if( m > n ) call system_abort('cluster_kmeans: required number of clusters ('//m//') greater than total number of points ('//n//')') - - my_theta_fac = optional_default(1.0_dp, theta_fac) - if( present(theta) ) then - if( size(theta) == d) then - my_theta => theta - else - allocate(my_theta(d)) - my_theta = theta(1) - endif - else - allocate(my_theta(d)) - do i = 1, d - my_theta(i) = ( maxval(x(i,:)) - minval(x(i,:)) ) - if( my_theta(i) .feq. 0.0_dp ) my_theta(i) = 1.0_dp - enddo - my_theta = my_theta * my_theta_fac - endif - - allocate(cluster_centre(d,m),cluster_info(n)) - - call fill_random_integer(cluster_index, n) !choose random points as cluster centres. - - cluster_centre = x(:,cluster_index) - cluster_info = 0 - - iter = 0 - d_total = huge(1.0_dp) - do - iter = iter + 1 - call print("iteration: "//iter,verbosity=PRINT_NERD) - cluster_same = .true. - - d_total_prev = d_total - d_total = 0.0_dp -!$omp parallel do default(none) shared(n,m,x,cluster_info,cluster_centre,my_theta) & -!$omp reduction(.and.:cluster_same) & -!$omp private(i,j,d_min,d_ij,cluster_info_old) reduction(+:d_total) - do i = 1, n - d_min = huge(0.0_dp) - cluster_info_old = cluster_info(i) - do j = 1, m - d_ij = sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2) - if( d_ij < d_min ) then - d_min = d_ij - cluster_info(i) = j - endif - enddo - if( cluster_info_old /= cluster_info(i) ) cluster_same = cluster_same .and. .false. - d_total = d_total + d_min - enddo -!$omp end parallel do - call print("cluster_kmeans iteration="//iter//" d_total="//d_total) - -!$omp parallel do default(none) shared(x,cluster_centre,cluster_info,m,d,n) private(j,k,n_points_cluster_j) - do j = 1, m - n_points_cluster_j = count(cluster_info==j) - if( n_points_cluster_j == 0 ) then - cluster_centre(:,j) = x(:,ceiling(ran_uniform()*n)) - else - do k = 1, d - cluster_centre(k,j) = sum(x(k,:),mask=(cluster_info==j)) / n_points_cluster_j - enddo - endif - enddo -!$omp end parallel do - if( cluster_same ) exit - if( abs(d_total - d_total_prev) < KMEANS_THRESHOLD * d_total ) exit - enddo - - do j = 1, m - d_min = huge(0.0_dp) - do i = 1, n - d_ij = sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2) - if( d_ij < d_min ) then - d_min = d_ij - cluster_index(j) = i - endif - enddo - enddo - - deallocate(cluster_centre, cluster_info) - - if(present(theta)) then - my_theta => null() - else - deallocate(my_theta) - endif - - endsubroutine cluster_kmeans - - ! https://sites.google.com/site/dataclusteringalgorithms/fuzzy-c-means-clustering-algorithm - subroutine cluster_fuzzy_cmeans(x,cluster_index,theta_fac,theta,fuzziness) - real(dp), dimension(:,:), intent(in) :: x - integer, dimension(:), intent(out) :: cluster_index - real(dp), intent(in), optional :: theta_fac - real(dp), dimension(:), intent(in), target, optional :: theta - real(dp), intent(in), optional :: fuzziness - - real(dp), dimension(:), pointer :: my_theta => null() - real(dp) :: my_theta_fac, d_min, d_ij, d_total, d_total_prev - - real(dp), dimension(:,:), allocatable :: cluster_centre - real(dp), dimension(:,:), allocatable :: w - real(dp), dimension(:), allocatable, save :: wx_j, d_i - real(dp) :: w_j, w_old, my_fuzziness, alpha - integer :: d, n, m, i, j, iter - logical :: cluster_same -!$omp threadprivate(d_i, wx_j) - - d = size(x,1) - n = size(x,2) - m = size(cluster_index) - if( m > n ) call system_abort('cluster_fuzzy_cmeans: required number of clusters ('//m//') greater than total number of points ('//n//')') - - my_theta_fac = optional_default(1.0_dp, theta_fac) - my_fuzziness = optional_default(4.0_dp, fuzziness) - if( present(theta) ) then - if( size(theta) == d) then - my_theta => theta - else - allocate(my_theta(d)) - my_theta = theta(1) - endif - else - allocate(my_theta(d)) - do i = 1, d - my_theta(i) = ( maxval(x(i,:)) - minval(x(i,:)) ) - if( my_theta(i) .feq. 0.0_dp ) my_theta(i) = 1.0_dp - enddo - my_theta = my_theta * my_theta_fac - endif - - allocate(cluster_centre(d,m), w(n,m)) -!$omp parallel - allocate(d_i(m), wx_j(d)) -!$omp end parallel - - call fill_random_integer(cluster_index, n) !choose random points as cluster centres. - - cluster_centre = x(:,cluster_index) - do i = 1, m - do j = 1, d - cluster_centre(j,i) = cluster_centre(j,i) + ( ran_uniform() - 0.5_dp ) * cluster_jitter - enddo - enddo - - w = 0.0_dp - - iter = 0 - d_total = huge(1.0_dp) - do - iter = iter + 1 - call print("iteration: "//iter,verbosity=PRINT_NERD) - cluster_same = .true. - - d_total_prev = d_total - d_total = 0.0_dp - ! Calculate fuzzy membership -!$omp parallel do default(none) shared(n,m,my_theta,my_fuzziness,w,x,cluster_centre) & -!$omp private(i,j,alpha,w_old) reduction(.and.:cluster_same) reduction(+:d_total) - do i = 1, n - alpha = 0.0_dp - do j = 1, m - d_i(j) = sqrt(sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2)) - alpha = alpha + 1.0_dp / d_i(j)**(2.0_dp / (my_fuzziness - 1.0_dp)) - enddo - - do j = 1, m - w_old = w(i,j) - w(i,j) = 0.0_dp - - w(i,j) = 1.0_dp / d_i(j)**(2.0_dp / (my_fuzziness - 1.0_dp)) / alpha - if( w_old .fne. w(i,j) ) cluster_same = cluster_same .and. .false. - - d_total = d_total + d_i(j)**2 * w(i,j)**my_fuzziness - enddo - enddo -!$omp end parallel do - call print("cluster_fuzzy_cmeans iteration="//iter//" d_total="//d_total) - - ! Calculate fuzzy centres -!$omp parallel do default(none) shared(m,n,w,x,my_fuzziness,cluster_centre) & -!$omp private(i,j,w_j) - do j = 1, m - w_j = 0.0_dp - wx_j = 0.0_dp - - do i = 1, n - w_j = w_j + w(i,j)**my_fuzziness - wx_j = wx_j + x(:,i) * w(i,j)**my_fuzziness - enddo - - cluster_centre(:,j) = wx_j / w_j - enddo -!$omp end parallel do - - call print("cluster_same: "//cluster_same,verbosity=PRINT_NERD) - call print("d_total: "//d_total,verbosity=PRINT_NERD) - call print("d_total_prev: "//d_total_prev,verbosity=PRINT_NERD) - call print("d_total-d_total_prev: "//(d_total-d_total_prev),verbosity=PRINT_NERD) - - if( cluster_same ) exit - if( abs(d_total - d_total_prev) < KMEANS_THRESHOLD * d_total ) exit - enddo - - ! Allocate cluster centres to nearest points - do j = 1, m - d_min = huge(0.0_dp) - do i = 1, n - d_ij = sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2) - if( d_ij < d_min ) then - d_min = d_ij - cluster_index(j) = i - endif - enddo - enddo - - deallocate(cluster_centre, w) -!$omp parallel - if(allocated(d_i)) deallocate(d_i) - if(allocated(wx_j)) deallocate(wx_j) -!$omp end parallel - - if(present(theta)) then - my_theta => null() - else - deallocate(my_theta) - endif - - endsubroutine cluster_fuzzy_cmeans - - subroutine select_uniform(x,index_out) - real(dp), dimension(:,:), intent(in) :: x - integer, dimension(:), intent(out) :: index_out - - integer :: i, d, n, m, n_grid, i_global, i_index_out, d_max - integer, dimension(:), allocatable :: p_grid, i_hist, histogram, x_histogram, index_out_histogram - real(dp), dimension(:), allocatable :: lower_bound, upper_bound, x_range - - d = size(x,1) - n = size(x,2) - m = size(index_out) - - if( n < m ) call system_abort('select_uniform: n = '//n//' < m = '//m) - - allocate(lower_bound(d), upper_bound(d), x_range(d), p_grid(d), i_hist(d)) - - lower_bound = minval(x,dim=2) - upper_bound = maxval(x,dim=2) - x_range = upper_bound - lower_bound - - n_grid = ceiling( real(m, dp)**(1.0_dp / real(d, dp)) ) - d_max = floor( log(real(huge(1), dp)) / log(real(n_grid, dp)) ) - if (d > d_max) then - call system_abort('select_uniform: Descriptor is too large ('//d//' > '//d_max//'). & - &Use another sparse method or descriptor.') - end if - p_grid = (/ ( n_grid**(i-1), i = 1, d ) /) - - allocate(histogram(n_grid**d)) - allocate(x_histogram(n),index_out_histogram(m)) - - histogram = 0 - - do i = 1, n - ! for each datapoint x(:,i) compute the bin index in each d direction - i_hist = nint( ( x(:,i) - lower_bound ) / x_range * (n_grid-1) ) + 1 - - ! map the bin index to a flat histogram bin index - i_global = sum((i_hist-1)*p_grid)+1 - histogram(i_global) = histogram(i_global) + 1 - - ! the i-th datapoint belongs to the i_global-th index in the histogram - x_histogram(i) = i_global - enddo - - index_out = 0 - i_index_out = 0 - - ! To monitor which bins the sparse points belong to. - index_out_histogram = 0 - - do i = 1, n - ! That's the exit condition if all sparse points are assigned before we - ! finish with the data points - if( all(index_out /= 0) ) exit - - if( all(x_histogram(i) /= index_out_histogram) ) then - ! We have just found a point which belongs to a bin that we haven't - ! selected yet in the sparse points - i_index_out = i_index_out + 1 - index_out(i_index_out) = i - index_out_histogram(i_index_out) = x_histogram(i) - endif - enddo - - do while ( any(index_out == 0) ) - ! We haven't yet assigned all sparse points. - - ! Select a bin randomly - i_global = ceiling( ran_uniform() * size(histogram) ) - - ! cycle if the bin is empty - if( histogram(i_global) == 0 ) cycle - - ! check if there are points belonging to this bin which we haven't - ! selected yet - if( count(x_histogram == i_global) == count(index_out_histogram == i_global) ) cycle - - do while (.true.) - ! select a point from x which belongs to that bin and add it to - ! the output. - i = ceiling( ran_uniform() * n ) - if( x_histogram(i) /= i_global .or. any(index_out == i) ) then - cycle - else - i_index_out = i_index_out + 1 - index_out(i_index_out) = i - index_out_histogram(i_index_out) = x_histogram(i) - exit - endif - enddo - enddo - - deallocate(lower_bound, upper_bound, x_range, p_grid, i_hist, histogram, x_histogram,index_out_histogram) - - if (.not. all(index_out /= 0)) call system_abort('select_uniform: could not assign all sparse points') - - endsubroutine select_uniform - - subroutine cur_decomposition(this, index_out, rank, n_iter) - ! based on 10.1073/pnas.0803205106 - - real(dp), intent(in), dimension(:,:) :: this - integer, dimension(:), intent(out) :: index_out - integer, intent(in), optional :: rank, n_iter - - integer :: n - integer :: expected_columns - integer :: my_n_iter, my_rank - type(LA_Matrix) :: LA_this - real(dp), allocatable, dimension(:) :: p, s, p_minus_ran_uniform - real(dp), allocatable, dimension(:,:) :: v - integer :: j, l - integer, allocatable, dimension(:), target :: p_index - integer, pointer, dimension(:) :: tmp_index_out => null() - real(dp), allocatable, dimension(:,:) :: C, Cp - real(dp) :: err, min_err - integer :: error - - expected_columns = size(index_out) - - if( expected_columns <= 0 ) then - call print_warning("cur_decomposition: called with expected_columns "//expected_columns//", can't be zero or less") - return - endif - - call initialise(LA_this,this) - - my_n_iter = optional_default(1, n_iter) - - if (present(rank)) then - call LA_Matrix_SVD_Allocate(LA_this,v=v,error=error) - HANDLE_ERROR(error) - call LA_Matrix_SVD(LA_this,v=v,error=error) - HANDLE_ERROR(error) - my_rank = rank - else - call LA_Matrix_SVD_Allocate(LA_this,s=s,v=v,error=error) - HANDLE_ERROR(error) - call LA_Matrix_SVD(LA_this,s=s,v=v,error=error) - HANDLE_ERROR(error) - my_rank = count(s > TOL_SVD) / 2 - endif - - n = size(v,1) - allocate(p(n), p_minus_ran_uniform(n), p_index(n)) - allocate( C(size(this,1),expected_columns), Cp(expected_columns,size(this,1)) ) - - p = sum(v(:,1:my_rank)**2, dim=2) - p = p * expected_columns - p = p / my_rank - p = min(p,1.0_dp) - - if(my_n_iter <= 0) then ! do not do probabilistic selection of columns - p_index = (/(j, j=1,n )/) - p_minus_ran_uniform = -p - call heap_sort(p_minus_ran_uniform,i_data=p_index) - index_out = p_index(1:expected_columns) - else - min_err = huge(1.0_dp) - do l = 1, my_n_iter - - ! randomly select columns according to the probabilities - do j = 1, n - p_minus_ran_uniform(j) = ran_uniform() - p(j) - p_index(j) = j ! initialise index array - end do - - call heap_sort(p_minus_ran_uniform,i_data=p_index) - tmp_index_out => p_index(1:expected_columns) - - C = this(:,tmp_index_out) - ! pinv: Moore-Penrose pseudo-inverse - call pseudo_inverse(C,Cp) - err = sum( (this - ( C .mult. Cp .mult. this))**2 ) - - call print("cur_decomposition: iteration: "//l//", error: "//err) - if(err < min_err) then ! this happens at least once - index_out = tmp_index_out - min_err = err - endif - - end do - endif - - call finalise(LA_this) - - tmp_index_out => null() - if(allocated(s)) deallocate(s) - if(allocated(v)) deallocate(v) - if(allocated(p)) deallocate(p) - if(allocated(p_minus_ran_uniform)) deallocate(p_minus_ran_uniform) - if(allocated(p_index)) deallocate(p_index) - if(allocated(C)) deallocate(C) - if(allocated(Cp)) deallocate(Cp) - - end subroutine cur_decomposition - -endmodule clustering_module diff --git a/descriptors.f95 b/descriptors.f95 deleted file mode 100644 index 7917c65e..00000000 --- a/descriptors.f95 +++ /dev/null @@ -1,13206 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X© -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -#ifdef _OPENMP -#define OMP_SAVE ,save -#else -#define OMP_SAVE -#endif - -module descriptors_module - - use error_module - use system_module, only : dp, print, optional_default, system_timer, operator(//), split_string, string_to_int, split_string_simple, inoutput, OUTPUT, PRINT_VERBOSE, PRINT_NERD, ran_normal, system_reseed_rng, system_get_random_seed - use linkedlist_module - use units_module - use periodictable_module - use linearalgebra_module - use dictionary_module - use paramreader_module - use atoms_module - use atoms_types_module - use topology_module - use mpi_context_module - use table_module -#ifdef DESCRIPTORS_NONCOMMERCIAL - use permutation_maker_module -#endif - use CInOutput_module - use clusters_module - use connection_module - use angular_functions_module - use gamma_module - - implicit none - - private -#ifdef GAP_VERSION - integer, parameter :: gap_version = GAP_VERSION -#else - integer, parameter :: gap_version = 0 -#endif - - - integer, parameter, public :: DT_NONE = 0 - integer, parameter, public :: DT_BISPECTRUM_SO4 = 1 - integer, parameter, public :: DT_BISPECTRUM_SO3 = 2 - integer, parameter, public :: DT_BEHLER = 3 - integer, parameter, public :: DT_DISTANCE_2B = 4 - integer, parameter, public :: DT_COORDINATION = 5 - integer, parameter, public :: DT_ANGLE_3B = 6 - integer, parameter, public :: DT_CO_ANGLE_3B = 7 - integer, parameter, public :: DT_CO_DISTANCE_2B = 8 - integer, parameter, public :: DT_COSNX = 9 - integer, parameter, public :: DT_TRIHIS = 10 - integer, parameter, public :: DT_WATER_MONOMER = 11 - integer, parameter, public :: DT_WATER_DIMER = 12 - integer, parameter, public :: DT_A2_DIMER = 13 - integer, parameter, public :: DT_AB_DIMER = 14 - integer, parameter, public :: DT_BOND_REAL_SPACE = 15 - integer, parameter, public :: DT_ATOM_REAL_SPACE = 16 - integer, parameter, public :: DT_POWER_SO3 = 17 - integer, parameter, public :: DT_POWER_SO4 = 18 - integer, parameter, public :: DT_SOAP = 19 - integer, parameter, public :: DT_AN_MONOMER = 20 - integer, parameter, public :: DT_GENERAL_MONOMER = 21 - integer, parameter, public :: DT_GENERAL_DIMER = 22 - integer, parameter, public :: DT_GENERAL_TRIMER = 23 - integer, parameter, public :: DT_RDF = 24 - integer, parameter, public :: DT_AS_DISTANCE_2B = 25 - integer, parameter, public :: DT_MOLECULE_LO_D = 26 - integer, parameter, public :: DT_alex = 27 - integer, parameter, public :: DT_COM_DIMER = 28 - integer, parameter, public :: DT_DISTANCE_NB = 29 - integer, parameter, public :: DT_SOAP_EXPRESS = 30 - integer, parameter, public :: DT_SOAP_TURBO = 31 - integer, parameter, public :: DT_WATER_TRIMER = 32 - - integer, parameter :: NP_WATER_DIMER = 8 - integer, parameter :: NP_A2_DIMER = 8 - integer, parameter :: NP_AB_DIMER = 2 - - type transfer_parameters_type - logical :: do_transfer - real(dp) :: factor, r0, width - endtype transfer_parameters_type - - type descriptor_data_mono - real(dp), dimension(:), allocatable :: data - real(dp), dimension(:,:,:), allocatable :: grad_data - ! ci : atom indices amongst which to distribute energy of descriptor - ! ii : all atoms involved in descriptor (for partial derivatives) - integer, dimension(:), allocatable :: ci, ii - real(dp), dimension(:,:), allocatable :: pos - logical :: has_data - logical, dimension(:), allocatable :: has_grad_data - - real(dp) :: covariance_cutoff = 1.0_dp - real(dp), dimension(:,:), allocatable :: grad_covariance_cutoff - endtype descriptor_data_mono - - type cplx_2d - complex(dp), dimension(:,:), allocatable :: mm - endtype cplx_2d - - type int_2d - integer , dimension(:,:), allocatable :: mm - endtype int_2d - - type real_2d - real(dp), dimension(:,:), allocatable :: mm - endtype real_2d - - type cplx_3d - complex(dp), dimension(:,:,:), allocatable :: mm - endtype cplx_3d - - !======================================================================= - !== begin descriptors - !======================================================================= - - - type RadialFunction_type - integer :: n_max - real(dp) :: cutoff, min_cutoff - real(dp), dimension(:,:), allocatable :: RadialTransform - real(dp), dimension(:), allocatable :: NormFunction - - logical :: initialised = .false. - endtype RadialFunction_type - - type fourier_SO4_type - real(dp) :: cutoff - real(dp) :: z0_ratio - real(dp) :: z0 - integer :: j_max, Z - integer, dimension(:), allocatable :: species_Z - real(dp), dimension(:), allocatable :: w - - logical :: initialised = .false. - endtype fourier_SO4_type - - type bispectrum_SO4 - real(dp), pointer :: cutoff - integer, pointer :: j_max, Z - real(dp), pointer :: z0_ratio - real(dp), pointer :: z0 - - integer, dimension(:), pointer :: species_Z - real(dp), dimension(:), pointer :: w - - type(fourier_SO4_type) :: fourier_SO4 - - logical :: initialised = .false. - - endtype bispectrum_SO4 - - type bispectrum_SO3 - - integer :: l_max, n_max, Z - real(dp) :: cutoff, min_cutoff - - type(RadialFunction_type) :: radial - - integer, dimension(:), allocatable :: species_Z - real(dp), dimension(:), allocatable :: w - - logical :: initialised = .false. - - endtype bispectrum_SO3 - - type behler_g2 - integer :: Z_n = 0 - real(dp) :: eta - real(dp) :: rs - real(dp) :: rc - endtype behler_g2 - - type behler_g3 - integer,dimension(2) :: Z_n = 0 - real(dp) :: eta - real(dp) :: lambda - real(dp) :: zeta - real(dp) :: rc - endtype behler_g3 - - type behler - - real(dp) :: cutoff = 0.0_dp - logical :: initialised = .false. - - integer :: Z = 0 - integer :: n_g2, n_g3 - type(behler_g2), dimension(:), allocatable :: g2 - type(behler_g3), dimension(:), allocatable :: g3 - - endtype behler - - type distance_2b - real(dp) :: cutoff - real(dp) :: cutoff_transition_width - integer :: Z1, Z2 - character(STRING_LENGTH) :: resid_name - logical :: only_intra, only_inter - - integer :: n_exponents, tail_exponent - real(dp) :: tail_range - integer, dimension(:), allocatable :: exponents - - logical :: has_tail - logical :: initialised = .false. - - endtype distance_2b - - type coordination - real(dp) :: cutoff - real(dp) :: transition_width - integer :: Z - - logical :: initialised = .false. - - endtype coordination - - type angle_3b - real(dp) :: cutoff - real(dp) :: cutoff_transition_width - integer :: Z, Z1, Z2 - - logical :: initialised = .false. - - endtype angle_3b - - type co_angle_3b - real(dp) :: cutoff - real(dp) :: coordination_cutoff - real(dp) :: coordination_transition_width - integer :: Z, Z1, Z2 - - logical :: initialised = .false. - - endtype co_angle_3b - - type co_distance_2b - real(dp) :: cutoff - real(dp) :: transition_width - real(dp) :: coordination_cutoff - real(dp) :: coordination_transition_width - integer :: Z1, Z2 - - logical :: initialised = .false. - - endtype co_distance_2b - - type cosnx - - integer :: l_max, n_max, Z - real(dp) :: cutoff, min_cutoff - - type(RadialFunction_type) :: radial - - integer, dimension(:), allocatable :: species_Z - real(dp), dimension(:), allocatable :: w - - logical :: initialised = .false. - - endtype cosnx - - type trihis - real(dp) :: cutoff - integer :: n_gauss - - real(dp), dimension(:,:), allocatable :: gauss_centre - real(dp), dimension(:,:), allocatable :: gauss_width - - logical :: initialised = .false. - - endtype trihis - - type water_monomer - real(dp) :: cutoff - - logical :: initialised = .false. - - endtype water_monomer - - type water_dimer - real(dp) :: cutoff, cutoff_transition_width - real(dp) :: monomer_cutoff - logical :: OHH_ordercheck - real(dp) :: power,dist_shift - - logical :: initialised = .false. - - endtype water_dimer - - type A2_dimer - real(dp) :: cutoff - real(dp) :: monomer_cutoff - integer :: atomic_number - - logical :: initialised = .false. - - endtype A2_dimer - - type AB_dimer - real(dp) :: cutoff - real(dp) :: monomer_cutoff - integer :: atomic_number1, atomic_number2 - - logical :: initialised = .false. - - endtype AB_dimer - - type atom_real_space - real(dp) :: cutoff - real(dp) :: cutoff_transition_width - integer :: l_max - real(dp) :: alpha - real(dp) :: zeta - - logical :: initialised = .false. - - endtype atom_real_space - - type power_so3 - integer :: l_max, n_max, Z - real(dp) :: cutoff, min_cutoff - - type(RadialFunction_type) :: radial - - integer, dimension(:), allocatable :: species_Z - real(dp), dimension(:), allocatable :: w - - logical :: initialised = .false. - endtype power_so3 - - type power_SO4 - real(dp), pointer :: cutoff - integer, pointer :: j_max, Z - real(dp), pointer :: z0_ratio - real(dp), pointer :: z0 - - integer, dimension(:), pointer :: species_Z - real(dp), dimension(:), pointer :: w - - type(fourier_SO4_type) :: fourier_SO4 - - logical :: initialised = .false. - - endtype power_SO4 - - type soap - real(dp) :: cutoff - real(dp) :: cutoff_transition_width - real(dp) :: alpha, atom_sigma, covariance_sigma0, central_weight - - integer :: cutoff_dexp - real(dp) :: cutoff_scale - real(dp) :: cutoff_rate - integer :: l_max, n_max, n_Z, n_species - - integer :: nu_R, nu_S - integer, dimension(:), allocatable :: species_Z, Z - real(dp), dimension(:), allocatable :: r_basis - real(dp), dimension(:,:,:), allocatable :: cholesky_overlap_basis - real(dp), dimension(:, :), allocatable :: transform_basis - - logical :: global = .false. - logical :: central_reference_all_species = .false. - logical :: diagonal_radial = .false. - logical :: normalise = .true. - logical :: initialised = .false. - - logical :: Z_mix = .false. - logical :: R_mix = .false. - logical :: sym_mix = .false. - logical :: coupling = .false. - integer :: K - integer :: mix_shift = 0 - - character(len=STRING_LENGTH) :: Z_map_str - character(len=STRING_LENGTH) :: radial_basis - real(dp), dimension(:,:,:), allocatable :: QR_factor - real(dp), dimension(:,:), allocatable :: QR_tau - endtype soap - - - type rdf - real(dp) :: cutoff - real(dp) :: transition_width, w_gauss - integer :: Z, n_gauss - real(dp), dimension(:), allocatable :: r_gauss - - logical :: initialised = .false. - - endtype rdf - - type as_distance_2b - real(dp) :: min_cutoff, max_cutoff, as_cutoff, overlap_alpha - real(dp) :: min_transition_width, max_transition_width, as_transition_width - real(dp) :: coordination_cutoff - real(dp) :: coordination_transition_width - integer :: Z1, Z2 - - logical :: initialised = .false. - - endtype as_distance_2b - - type alex - - integer :: Z, power_min, power_max - real(dp) :: cutoff - - integer :: n_species - integer, dimension(:), allocatable :: species_Z - - logical :: initialised = .false. - endtype alex - - - type distance_Nb - real(dp) :: cutoff - real(dp) :: cutoff_transition_width - integer :: order - integer, dimension(:), allocatable :: Z - integer :: n_permutations - integer, dimension(:,:), allocatable :: permutations - logical, dimension(:,:,:), allocatable :: monomerConnectivities - logical :: compact_clusters = .false. - logical :: initialised = .false. - endtype distance_Nb - - type soap_turbo - ! User controllable parameters - real(dp) :: rcut_hard, rcut_soft, nf - integer :: n_species, radial_enhancement, central_index, l_max, compress_P_nonzero - character(len=STRING_LENGTH) :: basis, scaling_mode, compress_file, compress_mode - - real(dp), dimension(:), allocatable :: atom_sigma_r, atom_sigma_r_scaling, & - atom_sigma_t, atom_sigma_t_scaling, amplitude_scaling, central_weight, compress_P_el - integer, dimension(:), allocatable :: species_Z, alpha_max, compress_P_i, compress_P_j - - logical :: initialised = .false., compress = .false. - endtype soap_turbo - -#ifdef DESCRIPTORS_NONCOMMERCIAL -#include "descriptors_noncommercial_types.inc" -#endif - - ! - ! All the descriptors need to be public so that they are visible to the python wrapper -#ifdef DESCRIPTORS_NONCOMMERCIAL - public :: soap, general_monomer, bispectrum_so4, bispectrum_so3, behler, distance_2b, & - coordination, angle_3b, co_angle_3b, co_distance_2b, cosnx, trihis, water_monomer, & - water_dimer, a2_dimer, bond_real_space, power_so3, power_so4, an_monomer, general_dimer, & - general_trimer, water_trimer, rdf, as_distance_2b, molecule_lo_d, alex, com_dimer, distance_nb, & - descriptor_data_mono, fourier_so4_type, radialfunction_type, transfer_parameters_type, & - ab_dimer, atom_real_space, spherical_harmonics_type, behler_g2, behler_g3, soap_turbo, soap_express -#else - public :: soap, bispectrum_so4, bispectrum_so3, behler, distance_2b, & - coordination, angle_3b, co_angle_3b, co_distance_2b, cosnx, trihis, water_monomer, & - water_dimer, a2_dimer, power_so3, power_so4, & - rdf, as_distance_2b, alex, distance_nb, & - descriptor_data_mono, fourier_so4_type, radialfunction_type, transfer_parameters_type, & - ab_dimer, atom_real_space, spherical_harmonics_type, behler_g2, behler_g3, & - soap_turbo -#endif - - !======================================================================= - !== end descriptors - !======================================================================= - - type descriptor - integer :: descriptor_type = DT_NONE - - type(bispectrum_SO4) :: descriptor_bispectrum_SO4 - type(bispectrum_SO3) :: descriptor_bispectrum_SO3 - type(behler) :: descriptor_behler - type(distance_2b) :: descriptor_distance_2b - type(coordination) :: descriptor_coordination - type(angle_3b) :: descriptor_angle_3b - type(co_angle_3b) :: descriptor_co_angle_3b - type(co_distance_2b) :: descriptor_co_distance_2b - type(cosnx) :: descriptor_cosnx - type(trihis) :: descriptor_trihis - type(water_monomer) :: descriptor_water_monomer - type(water_dimer) :: descriptor_water_dimer - type(A2_dimer) :: descriptor_A2_dimer - type(AB_dimer) :: descriptor_AB_dimer - type(atom_real_space) :: descriptor_atom_real_space - type(power_so3) :: descriptor_power_so3 - type(power_SO4) :: descriptor_power_SO4 - type(soap) :: descriptor_soap - type(rdf) :: descriptor_rdf - type(as_distance_2b) :: descriptor_as_distance_2b - type(alex) :: descriptor_alex - type(distance_Nb) :: descriptor_distance_Nb - type(soap_turbo) :: descriptor_soap_turbo -#ifdef DESCRIPTORS_NONCOMMERCIAL - type(AN_monomer) :: descriptor_AN_monomer - type(general_monomer) :: descriptor_general_monomer - type(general_dimer) :: descriptor_general_dimer - type(general_trimer) :: descriptor_general_trimer - type(water_trimer) :: descriptor_water_trimer - type(molecule_lo_d) :: descriptor_molecule_lo_d - type(com_dimer) :: descriptor_com_dimer - type(soap_express) :: descriptor_soap_express - type(bond_real_space) :: descriptor_bond_real_space -#endif - endtype - - type descriptor_data - type(descriptor_data_mono), dimension(:), allocatable :: x - endtype descriptor_data - - type cplx_1d - complex(dp), dimension(:), allocatable :: m - endtype cplx_1d - - type real_1d - real(dp), dimension(:), allocatable :: m - endtype real_1d - - type spherical_harmonics_type - type(cplx_1d), dimension(:), allocatable :: spherical_harmonics - type(cplx_2d), dimension(:), allocatable :: grad_spherical_harmonics - real(dp) :: r - real(dp), dimension(3) :: u - endtype spherical_harmonics_type - - type neighbour_type - type(spherical_harmonics_type), dimension(:), allocatable :: neighbour - endtype neighbour_type - - type grad_spherical_harmonics_overlap_type - type(cplx_3d), dimension(:), allocatable :: grad_integral - endtype grad_spherical_harmonics_overlap_type - - public :: neighbour_type, real_space_fourier_coefficients, real_space_covariance_coefficient - public :: SphericalYCartesian - - interface initialise -#ifdef DESCRIPTORS_NONCOMMERCIAL - module procedure descriptor_initialise, RadialFunction_initialise, fourier_so4_initialise, & - bispectrum_SO4_initialise, bispectrum_SO3_initialise, behler_initialise, distance_2b_initialise, & - coordination_initialise, angle_3b_initialise, co_angle_3b_initialise, co_distance_2b_initialise, cosnx_initialise, trihis_initialise, & - water_monomer_initialise, water_dimer_initialise, A2_dimer_initialise, AB_dimer_initialise, distance_Nb_initialise, rdf_initialise, as_distance_2b_initialise, alex_initialise, & - atom_real_space_initialise, power_so3_initialise, power_SO4_initialise, soap_initialise, soap_turbo_initialise, & - general_monomer_initialise, general_dimer_initialise, general_trimer_initialise, water_trimer_initialise, molecule_lo_d_initialise, AN_monomer_initialise, & - bond_real_space_initialise, transfer_initialise, com_dimer_initialise, soap_express_initialise -#else - module procedure descriptor_initialise, RadialFunction_initialise, fourier_so4_initialise, & - bispectrum_SO4_initialise, bispectrum_SO3_initialise, behler_initialise, distance_2b_initialise, & - coordination_initialise, angle_3b_initialise, co_angle_3b_initialise, co_distance_2b_initialise, cosnx_initialise, trihis_initialise, & - water_monomer_initialise, water_dimer_initialise, A2_dimer_initialise, AB_dimer_initialise, distance_Nb_initialise, rdf_initialise, as_distance_2b_initialise, alex_initialise, & - atom_real_space_initialise, power_so3_initialise, power_SO4_initialise, soap_initialise, soap_turbo_initialise -#endif - endinterface initialise - public :: initialise - - interface finalise -#ifdef DESCRIPTORS_NONCOMMERCIAL - module procedure descriptor_finalise, descriptor_data_finalise, RadialFunction_finalise, fourier_so4_finalise, cplx_2d_array1_finalise, cplx_3d_array2_finalise, & - bispectrum_SO4_finalise, bispectrum_SO3_finalise, behler_finalise, distance_2b_finalise, coordination_finalise, angle_3b_finalise, co_angle_3b_finalise, & - co_distance_2b_finalise, cosnx_finalise, trihis_finalise, water_monomer_finalise, water_dimer_finalise, rdf_finalise, as_distance_2b_finalise, alex_finalise, & - A2_dimer_finalise, AB_dimer_finalise, atom_real_space_finalise, power_so3_finalise, power_SO4_finalise, soap_finalise, distance_Nb_finalise, soap_turbo_finalise, & - AN_monomer_finalise, general_monomer_finalise, general_dimer_finalise, general_trimer_finalise, water_trimer_finalise, molecule_lo_d_finalise, com_dimer_finalise, & - bond_real_space_finalise, soap_express_finalise -#else - module procedure descriptor_finalise, descriptor_data_finalise, RadialFunction_finalise, fourier_so4_finalise, cplx_2d_array1_finalise, cplx_3d_array2_finalise, & - bispectrum_SO4_finalise, bispectrum_SO3_finalise, behler_finalise, distance_2b_finalise, coordination_finalise, angle_3b_finalise, co_angle_3b_finalise, & - co_distance_2b_finalise, cosnx_finalise, trihis_finalise, water_monomer_finalise, water_dimer_finalise, rdf_finalise, as_distance_2b_finalise, alex_finalise, & - A2_dimer_finalise, AB_dimer_finalise, atom_real_space_finalise, power_so3_finalise, power_SO4_finalise, soap_finalise, distance_Nb_finalise, soap_turbo_finalise -#endif - endinterface finalise - public :: finalise - - interface calc -#ifdef DESCRIPTORS_NONCOMMERCIAL - module procedure descriptor_calc, descriptor_calc_array, bispectrum_SO4_calc, bispectrum_SO3_calc, behler_calc, distance_2b_calc, coordination_calc, angle_3b_calc, co_angle_3b_calc, & - co_distance_2b_calc, cosnx_calc, trihis_calc, water_monomer_calc, water_dimer_calc, A2_dimer_calc, AB_dimer_calc, atom_real_space_calc, & - power_so3_calc, power_SO4_calc, soap_calc, rdf_calc, as_distance_2b_calc, & - distance_Nb_calc, alex_calc, soap_turbo_calc, & - AN_monomer_calc, soap_express_calc, general_monomer_calc, general_dimer_calc, general_trimer_calc, water_trimer_calc, molecule_lo_d_calc, com_dimer_calc, bond_real_space_calc -#else - module procedure descriptor_calc, descriptor_calc_array, bispectrum_SO4_calc, bispectrum_SO3_calc, behler_calc, distance_2b_calc, coordination_calc, angle_3b_calc, co_angle_3b_calc, & - co_distance_2b_calc, cosnx_calc, trihis_calc, water_monomer_calc, water_dimer_calc, A2_dimer_calc, AB_dimer_calc, atom_real_space_calc, & - power_so3_calc, power_SO4_calc, soap_calc, rdf_calc, as_distance_2b_calc, & - distance_Nb_calc, alex_calc, soap_turbo_calc - -#endif - endinterface calc - public :: calc - - interface cutoff -#ifdef DESCRIPTORS_NONCOMMERCIAL - module procedure descriptor_cutoff, bispectrum_SO4_cutoff, bispectrum_SO3_cutoff, behler_cutoff, distance_2b_cutoff, coordination_cutoff, angle_3b_cutoff, co_angle_3b_cutoff, & - co_distance_2b_cutoff, cosnx_cutoff, trihis_cutoff, water_monomer_cutoff, water_dimer_cutoff, A2_dimer_cutoff, AB_dimer_cutoff, atom_real_space_cutoff, & - power_so3_cutoff, power_SO4_cutoff, soap_cutoff, alex_cutoff, distance_Nb_cutoff, rdf_cutoff, as_distance_2b_cutoff, soap_turbo_cutoff, & - molecule_lo_d_cutoff, com_dimer_cutoff, soap_express_cutoff, AN_monomer_cutoff, general_monomer_cutoff, general_dimer_cutoff, general_trimer_cutoff, water_trimer_cutoff, bond_real_space_cutoff -#else - module procedure descriptor_cutoff, bispectrum_SO4_cutoff, bispectrum_SO3_cutoff, behler_cutoff, distance_2b_cutoff, coordination_cutoff, angle_3b_cutoff, co_angle_3b_cutoff, & - co_distance_2b_cutoff, cosnx_cutoff, trihis_cutoff, water_monomer_cutoff, water_dimer_cutoff, A2_dimer_cutoff, AB_dimer_cutoff, atom_real_space_cutoff, & - power_so3_cutoff, power_SO4_cutoff, soap_cutoff, alex_cutoff, distance_Nb_cutoff, rdf_cutoff, as_distance_2b_cutoff, soap_turbo_cutoff -#endif - endinterface cutoff - public :: cutoff - - interface descriptor_sizes -#ifdef DESCRIPTORS_NONCOMMERCIAL - module procedure descriptor_sizes, bispectrum_SO4_sizes, bispectrum_SO3_sizes, behler_sizes, distance_2b_sizes, coordination_sizes, angle_3b_sizes, co_angle_3b_sizes, & - co_distance_2b_sizes, cosnx_sizes, trihis_sizes, water_monomer_sizes, water_dimer_sizes, A2_dimer_sizes, AB_dimer_sizes, atom_real_space_sizes, & - power_so3_sizes, power_SO4_sizes, soap_sizes, rdf_sizes, as_distance_2b_sizes, & - alex_sizes, distance_Nb_sizes, soap_turbo_sizes, & - molecule_lo_d_sizes, com_dimer_sizes, soap_express_sizes, AN_monomer_sizes, general_monomer_sizes, general_dimer_sizes, general_trimer_sizes, water_trimer_sizes, bond_real_space_sizes -#else - module procedure descriptor_sizes, bispectrum_SO4_sizes, bispectrum_SO3_sizes, behler_sizes, distance_2b_sizes, coordination_sizes, angle_3b_sizes, co_angle_3b_sizes, & - co_distance_2b_sizes, cosnx_sizes, trihis_sizes, water_monomer_sizes, water_dimer_sizes, A2_dimer_sizes, AB_dimer_sizes, atom_real_space_sizes, & - power_so3_sizes, power_SO4_sizes, soap_sizes, rdf_sizes, as_distance_2b_sizes, & - alex_sizes, distance_Nb_sizes, soap_turbo_sizes -#endif - endinterface descriptor_sizes - public :: descriptor_sizes - - public :: descriptor_MPI_setup - - public :: descriptor, descriptor_data, descriptor_dimensions, descriptor_n_permutations, descriptor_permutations, descriptor_str_add_species - public :: real_space_covariance - public :: cplx_1d, cplx_2d - - contains - - -#ifdef DESCRIPTORS_NONCOMMERCIAL -#include "descriptors_noncommercial.inc" -#endif - - function get_descriptor_type(args_str,error) - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - integer :: get_descriptor_type - - type(Dictionary) :: params - logical :: is_bispectrum_so4, is_bispectrum_so3, is_behler, is_distance_2b, is_coordination, is_angle_3b, & - is_co_angle_3b, is_co_distance_2b, is_cosnx, is_trihis, is_water_monomer, is_water_dimer, is_A2_dimer, & - is_AB_dimer, is_bond_real_space, is_atom_real_space, is_power_so3, is_power_so4, is_soap, & - is_AN_monomer, is_general_monomer, is_general_dimer, is_general_trimer, is_water_trimer, is_rdf, is_as_distance_2b, & - is_molecule_lo_d, is_alex, is_com_dimer, is_distance_Nb, is_soap_express, is_soap_turbo - integer n_true - INIT_ERROR(error) - - call initialise(params) - call param_register(params, 'bispectrum_so4', 'false', is_bispectrum_so4, help_string="Type of descriptor is bispectrum_so4.") - call param_register(params, 'bispectrum_so3', 'false', is_bispectrum_so3, help_string="Type of descriptor is bispectrum_so3.") - call param_register(params, 'behler', 'false', is_behler, help_string="Type of descriptor is behler.") - call param_register(params, 'distance_2b', 'false', is_distance_2b, help_string="Type of descriptor is distance_2b.") - call param_register(params, 'coordination', 'false', is_coordination, help_string="Type of descriptor is coordination.") - call param_register(params, 'angle_3b', 'false', is_angle_3b, help_string="Type of descriptor is angle_3b.") - call param_register(params, 'co_angle_3b', 'false', is_co_angle_3b, help_string="Type of descriptor is co_angle_3b.") - call param_register(params, 'co_distance_2b', 'false', is_co_distance_2b, help_string="Type of descriptor is co_distance_2b.") - call param_register(params, 'cosnx', 'false', is_cosnx, help_string="Type of descriptor is cosnx.") - call param_register(params, 'trihis', 'false', is_trihis, help_string="Type of descriptor is trihis.") - call param_register(params, 'water_monomer', 'false', is_water_monomer, help_string="Type of descriptor is water_monomer.") - call param_register(params, 'water_dimer', 'false', is_water_dimer, help_string="Type of descriptor is water_dimer.") - call param_register(params, 'A2_dimer', 'false', is_A2_dimer, help_string="Type of descriptor is A2_dimer.") - call param_register(params, 'AB_dimer', 'false', is_AB_dimer, help_string="Type of descriptor is AB_dimer.") - call param_register(params, 'bond_real_space', 'false', is_bond_real_space, help_string="Type of descriptor is bond_real_space.") - call param_register(params, 'atom_real_space', 'false', is_atom_real_space, help_string="Type of descriptor is atom_real_space.") - call param_register(params, 'power_so3', 'false', is_power_so3, help_string="Type of descriptor is power_so3.") - call param_register(params, 'power_so4', 'false', is_power_so4, help_string="Type of descriptor is power_so4.") - call param_register(params, 'soap', 'false', is_soap, help_string="Type of descriptor is soap.") - call param_register(params, 'AN_monomer', 'false', is_AN_monomer, help_string="Type of descriptor is AN_monomer.") - call param_register(params, 'general_monomer', 'false', is_general_monomer, help_string="Type of descriptor is general_monomer.") - call param_register(params, 'general_dimer', 'false', is_general_dimer, help_string="Type of descriptor is general_dimer.") - call param_register(params, 'general_trimer', 'false', is_general_trimer, help_string="Type of descriptor is general_trimer.") - call param_register(params, 'water_trimer', 'false', is_water_trimer, help_string="Type of descriptor is water_trimer.") - call param_register(params, 'rdf', 'false', is_rdf, help_string="Type of descriptor is rdf.") - call param_register(params, 'as_distance_2b', 'false', is_as_distance_2b, help_string="Type of descriptor is as_distance_2b.") - call param_register(params, 'molecule_lo_d', 'false', is_molecule_lo_d, help_string="Type of descriptor is molecule_lo_d.") - call param_register(params, 'alex', 'false', is_alex, help_string="Type of descriptor is alex.") - call param_register(params, 'com_dimer', 'false', is_com_dimer, help_string="Type of descriptor is com_dimer.") - call param_register(params, 'distance_Nb', 'false', is_distance_Nb, help_string="Type of descriptor is distance_Nb.") - call param_register(params, 'soap_express', 'false', is_soap_express, help_string="Type of descriptor is soap_express.") - call param_register(params, 'soap_turbo', 'false', is_soap_turbo, help_string="Type of descriptor is soap_turbo.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='descriptor_initialise args_str')) then - RAISE_ERROR("descriptor_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - n_true = count( (/is_bispectrum_so4, is_bispectrum_so3, is_behler, is_distance_2b, is_coordination, is_angle_3b, is_co_angle_3b, is_co_distance_2b, & - is_cosnx, is_trihis, is_water_monomer, is_water_dimer, is_A2_dimer, is_AB_dimer, is_bond_real_space, is_atom_real_space, is_power_so3, is_power_so4, & - is_soap, is_AN_monomer, is_general_monomer, is_general_dimer, is_general_trimer, is_water_trimer, is_rdf, is_as_distance_2b, is_molecule_lo_d, is_alex, is_com_dimer, & - is_distance_Nb, is_soap_express, is_soap_turbo /) ) - if (n_true/= 1) then - RAISE_ERROR("descriptor_initialise found "//n_true//" IP Model types args_str='"//trim(args_str)//"'", error) - endif - - get_descriptor_type = DT_NONE - - if( is_bispectrum_so4 ) then - get_descriptor_type = DT_BISPECTRUM_SO4 - elseif( is_bispectrum_so3 ) then - get_descriptor_type = DT_BISPECTRUM_SO3 - elseif( is_behler ) then - get_descriptor_type = DT_BEHLER - elseif( is_distance_2b ) then - get_descriptor_type = DT_DISTANCE_2B - elseif( is_coordination ) then - get_descriptor_type = DT_COORDINATION - elseif( is_angle_3b ) then - get_descriptor_type = DT_ANGLE_3B - elseif( is_co_angle_3b ) then - get_descriptor_type = DT_CO_ANGLE_3B - elseif( is_co_distance_2b ) then - get_descriptor_type = DT_CO_DISTANCE_2B - elseif( is_cosnx ) then - get_descriptor_type = DT_COSNX - elseif( is_trihis ) then - get_descriptor_type = DT_TRIHIS - elseif( is_water_monomer ) then - get_descriptor_type = DT_WATER_MONOMER - elseif( is_water_dimer ) then - get_descriptor_type = DT_WATER_DIMER - elseif( is_A2_dimer ) then - get_descriptor_type = DT_A2_DIMER - elseif( is_AB_dimer ) then - get_descriptor_type = DT_AB_DIMER - elseif( is_bond_real_space ) then - get_descriptor_type = DT_BOND_REAL_SPACE - elseif( is_atom_real_space ) then - get_descriptor_type = DT_ATOM_REAL_SPACE - elseif( is_power_so3 ) then - get_descriptor_type = DT_POWER_SO3 - elseif( is_power_so4 ) then - get_descriptor_type = DT_POWER_SO4 - elseif( is_soap ) then - get_descriptor_type = DT_SOAP - elseif( is_AN_monomer ) then - get_descriptor_type = DT_AN_MONOMER - elseif( is_general_monomer ) then - get_descriptor_type = DT_GENERAL_MONOMER - elseif( is_general_dimer ) then - get_descriptor_type = DT_GENERAL_DIMER - elseif( is_general_trimer ) then - get_descriptor_type = DT_GENERAL_TRIMER - elseif( is_water_trimer ) then - get_descriptor_type = DT_WATER_TRIMER - elseif( is_rdf ) then - get_descriptor_type = DT_RDF - elseif( is_as_distance_2b ) then - get_descriptor_type = DT_AS_DISTANCE_2B - elseif( is_molecule_lo_d ) then - get_descriptor_type = DT_MOLECULE_LO_D - elseif( is_alex ) then - get_descriptor_type = DT_ALEX - elseif( is_com_dimer ) then - get_descriptor_type = DT_COM_DIMER - elseif( is_distance_Nb ) then - get_descriptor_type = DT_DISTANCE_NB - elseif( is_soap_express ) then - get_descriptor_type = DT_SOAP_EXPRESS - elseif( is_soap_turbo ) then - get_descriptor_type = DT_SOAP_TURBO - endif - - endfunction get_descriptor_type - - subroutine descriptor_initialise(this,args_str,error) - type(descriptor), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - call finalise(this) - - this%descriptor_type = get_descriptor_type(args_str,error) - - select case(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - call initialise(this%descriptor_bispectrum_SO4,args_str,error) - case(DT_BISPECTRUM_SO3) - call initialise(this%descriptor_bispectrum_SO3,args_str,error) - case(DT_BEHLER) - call initialise(this%descriptor_behler,args_str,error) - case(DT_DISTANCE_2B) - call initialise(this%descriptor_distance_2b,args_str,error) - case(DT_COORDINATION) - call initialise(this%descriptor_coordination,args_str,error) - case(DT_ANGLE_3B) - call initialise(this%descriptor_angle_3b,args_str,error) - case(DT_CO_ANGLE_3B) - call initialise(this%descriptor_co_angle_3b,args_str,error) - case(DT_CO_DISTANCE_2B) - call initialise(this%descriptor_co_distance_2b,args_str,error) - case(DT_COSNX) - call initialise(this%descriptor_cosnx,args_str,error) - case(DT_TRIHIS) - call initialise(this%descriptor_trihis,args_str,error) - case(DT_WATER_MONOMER) - call initialise(this%descriptor_water_monomer,args_str,error) - case(DT_WATER_DIMER) - call initialise(this%descriptor_water_dimer,args_str,error) - case(DT_A2_DIMER) - call initialise(this%descriptor_A2_dimer,args_str,error) - case(DT_AB_DIMER) - call initialise(this%descriptor_AB_dimer,args_str,error) - case(DT_ATOM_REAL_SPACE) - call initialise(this%descriptor_atom_real_space,args_str,error) - case(DT_POWER_SO3) - call initialise(this%descriptor_power_so3,args_str,error) - case(DT_POWER_SO4) - call initialise(this%descriptor_power_so4,args_str,error) - case(DT_SOAP) - call initialise(this%descriptor_soap,args_str,error) - case(DT_RDF) - call initialise(this%descriptor_rdf,args_str,error) - case(DT_AS_DISTANCE_2B) - call initialise(this%descriptor_as_distance_2b,args_str,error) - case(DT_ALEX) - call initialise(this%descriptor_alex,args_str,error) - case(DT_DISTANCE_NB) - call initialise(this%descriptor_distance_Nb,args_str,error) - case(DT_SOAP_TURBO) - call initialise(this%descriptor_soap_turbo,args_str,error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_BOND_REAL_SPACE) - call initialise(this%descriptor_bond_real_space,args_str,error) - case(DT_AN_MONOMER) - call initialise(this%descriptor_AN_monomer,args_str,error) - case(DT_COM_DIMER) - call initialise(this%descriptor_com_dimer,args_str,error) - case(DT_MOLECULE_LO_D) - call initialise(this%descriptor_molecule_lo_d,args_str,error) - case(DT_GENERAL_MONOMER) - call initialise(this%descriptor_general_monomer,args_str,error) - case(DT_GENERAL_DIMER) - call initialise(this%descriptor_general_dimer,args_str,error) - case(DT_GENERAL_TRIMER) - call initialise(this%descriptor_general_trimer,args_str,error) - case(DT_WATER_TRIMER) - call initialise(this%descriptor_water_trimer,args_str,error) - case(DT_SOAP_EXPRESS) - call initialise(this%descriptor_soap_express,args_str,error) -#endif - endselect - - endsubroutine descriptor_initialise - - subroutine descriptor_finalise(this,error) - type(descriptor), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - call finalise(this%descriptor_bispectrum_SO4,error) - case(DT_BISPECTRUM_SO3) - call finalise(this%descriptor_bispectrum_SO3,error) - case(DT_BEHLER) - call finalise(this%descriptor_behler,error) - case(DT_DISTANCE_2b) - call finalise(this%descriptor_distance_2b,error) - case(DT_COORDINATION) - call finalise(this%descriptor_coordination,error) - case(DT_ANGLE_3B) - call finalise(this%descriptor_angle_3b,error) - case(DT_CO_ANGLE_3B) - call finalise(this%descriptor_co_angle_3b,error) - case(DT_CO_DISTANCE_2b) - call finalise(this%descriptor_co_distance_2b,error) - case(DT_COSNX) - call finalise(this%descriptor_cosnx,error) - case(DT_TRIHIS) - call finalise(this%descriptor_trihis,error) - case(DT_WATER_MONOMER) - call finalise(this%descriptor_water_monomer,error) - case(DT_WATER_DIMER) - call finalise(this%descriptor_water_dimer,error) - case(DT_A2_dimer) - call finalise(this%descriptor_A2_dimer,error) - case(DT_AB_dimer) - call finalise(this%descriptor_AB_dimer,error) - case(DT_ATOM_REAL_SPACE) - call finalise(this%descriptor_atom_real_space,error) - case(DT_POWER_SO3) - call finalise(this%descriptor_power_so3,error) - case(DT_POWER_SO4) - call finalise(this%descriptor_power_so4,error) - case(DT_SOAP) - call finalise(this%descriptor_soap,error) - case(DT_RDF) - call finalise(this%descriptor_rdf,error) - case(DT_AS_DISTANCE_2b) - call finalise(this%descriptor_as_distance_2b,error) - case(DT_ALEX) - call finalise(this%descriptor_alex,error) - case(DT_DISTANCE_Nb) - call finalise(this%descriptor_distance_Nb,error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_COM_DIMER) - call finalise(this%descriptor_com_dimer,error) - case(DT_MOLECULE_LO_D) - call finalise(this%descriptor_molecule_lo_d,error) - case(DT_BOND_REAL_SPACE) - call finalise(this%descriptor_bond_real_space,error) - case(DT_GENERAL_MONOMER) - call finalise(this%descriptor_general_monomer,error) - case(DT_GENERAL_DIMER) - call finalise(this%descriptor_general_dimer,error) - case(DT_GENERAL_TRIMER) - call finalise(this%descriptor_general_trimer,error) - case(DT_WATER_TRIMER) - call finalise(this%descriptor_water_trimer,error) - case(DT_SOAP_EXPRESS) - call finalise(this%descriptor_soap_express,error) - case(DT_SOAP_TURBO) - call finalise(this%descriptor_soap_turbo,error) -#endif - endselect - - this%descriptor_type = DT_NONE - - endsubroutine descriptor_finalise - - subroutine descriptor_MPI_setup(this,at,mpi,mpi_mask,error) - type(descriptor), intent(in) :: this - type(atoms), intent(in) :: at - type(MPI_Context), intent(in) :: mpi - logical, dimension(:), intent(out) :: mpi_mask - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(mpi%active) then - select case(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_BISPECTRUM_SO3) - RAISE_ERROR("descriptor_MPI_setup: bispectrum_so3 not MPI ready.", error) - case(DT_BEHLER) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_DISTANCE_2B) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_COORDINATION) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_ANGLE_3B) - RAISE_ERROR("descriptor_MPI_setup: angle_3b not MPI ready.", error) - case(DT_CO_ANGLE_3B) - RAISE_ERROR("descriptor_MPI_setup: co_angle_3b not MPI ready.", error) - case(DT_CO_DISTANCE_2B) - RAISE_ERROR("descriptor_MPI_setup: co_distance_2b not MPI ready.", error) - case(DT_COSNX) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_TRIHIS) - RAISE_ERROR("descriptor_MPI_setup: trihis not MPI ready.", error) - case(DT_WATER_MONOMER) - call descriptor_water_monomer_dimer_MPI_setup(at,mpi,mpi_mask,error) - case(DT_WATER_DIMER) - call descriptor_water_monomer_dimer_MPI_setup(at,mpi,mpi_mask,error) - case(DT_A2_DIMER) - RAISE_ERROR("descriptor_MPI_setup: A2_dimer not MPI ready.", error) - case(DT_AB_DIMER) - RAISE_ERROR("descriptor_MPI_setup: AB_dimer not MPI ready.", error) - case(DT_ATOM_REAL_SPACE) - RAISE_ERROR("descriptor_MPI_setup: atom_real_space not MPI ready.", error) - case(DT_POWER_SO3) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_POWER_SO4) - RAISE_ERROR("descriptor_MPI_setup: power_SO4 not MPI ready.", error) - case(DT_SOAP) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_RDF) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_AS_DISTANCE_2B) - RAISE_ERROR("descriptor_MPI_setup: as_distance_2b not MPI ready.", error) - case(DT_ALEX) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_DISTANCE_NB) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - case(DT_SOAP_TURBO) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_MOLECULE_LO_D) - RAISE_ERROR("descriptor_MPI_setup: molecule_lo_d not MPI ready.", error) - case(DT_BOND_REAL_SPACE) - RAISE_ERROR("descriptor_MPI_setup: bond_real_space not MPI ready.", error) - case(DT_AN_MONOMER) - RAISE_ERROR("descriptor_MPI_setup: AN_monomer not MPI ready.", error) - case(DT_GENERAL_MONOMER) - call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) - case(DT_GENERAL_DIMER) - call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) - case(DT_GENERAL_TRIMER) - call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) - case(DT_COM_DIMER) - call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) - case(DT_SOAP_EXPRESS) - call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) -#endif - case default - RAISE_ERROR("descriptor_MPI_setup: descriptor type "//this%descriptor_type//" not recognised.",error) - endselect - else - mpi_mask = .true. - endif - - endsubroutine descriptor_MPI_setup - - subroutine descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) - type(atoms), intent(in) :: at - type(MPI_Context), intent(in) :: mpi - logical, dimension(:), intent(out) :: mpi_mask - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - mpi_mask = .false. - do i = 1, at%N - if( mod(i-1, mpi%n_procs) == mpi%my_proc ) mpi_mask(i) = .true. - enddo - - endsubroutine descriptor_atomic_MPI_setup - - subroutine descriptor_water_monomer_dimer_MPI_setup(at,mpi,mpi_mask,error) - type(atoms), intent(in) :: at - type(MPI_Context), intent(in) :: mpi - logical, dimension(:), intent(out) :: mpi_mask - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - mpi_mask = .false. - do i = 1, at%N - if( at%Z(i) == 8 .and. mod(i-1, mpi%n_procs) == mpi%my_proc ) mpi_mask(i) = .true. - enddo - - endsubroutine descriptor_water_monomer_dimer_MPI_setup - - - subroutine descriptor_data_finalise(this,error) - type(descriptor_data), intent(inout) :: this - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(allocated(this%x)) then - do i = 1, size(this%x) - if(allocated(this%x(i)%data)) deallocate(this%x(i)%data) - if(allocated(this%x(i)%grad_data)) deallocate(this%x(i)%grad_data) - if(allocated(this%x(i)%ci)) deallocate(this%x(i)%ci) - if(allocated(this%x(i)%ii)) deallocate(this%x(i)%ii) - if(allocated(this%x(i)%pos)) deallocate(this%x(i)%pos) - if(allocated(this%x(i)%has_grad_data)) deallocate(this%x(i)%has_grad_data) - if(allocated(this%x(i)%grad_covariance_cutoff)) deallocate(this%x(i)%grad_covariance_cutoff) - enddo - deallocate(this%x) - endif - - endsubroutine descriptor_data_finalise - - subroutine RadialFunction_initialise(this,n_max,cutoff, min_cutoff,error) - type(RadialFunction_type), intent(inout) :: this - integer, intent(in) :: n_max - real(dp), intent(in) :: cutoff, min_cutoff - integer, optional, intent(out) :: error - - real(dp), dimension(:,:), allocatable :: S, vS - real(dp), dimension(:), allocatable :: eS - integer :: i, j - - INIT_ERROR(error) - - call finalise(this) - - this%n_max = n_max - this%cutoff = cutoff - this%min_cutoff = min_cutoff - - allocate(this%RadialTransform(this%n_max,this%n_max),this%NormFunction(this%n_max)) - allocate(S(this%n_max,this%n_max), vS(this%n_max,this%n_max), eS(this%n_max)) - - do i = 1, this%n_max - this%NormFunction(i) = sqrt(this%cutoff**(2.0_dp*i+5.0_dp)/(2.0_dp*i+5.0_dp)) - do j = 1, this%n_max - S(j,i) = sqrt((2.0_dp*i+5)*(2.0_dp*j+5))/(i+j+5.0_dp) - enddo - enddo - - call diagonalise(S,eS,vS) - this%RadialTransform = matmul(matmul(vS,diag(1.0_dp/sqrt(eS))),transpose(vS)) - - if(allocated(S)) deallocate(S) - if(allocated(vS)) deallocate(vS) - if(allocated(eS)) deallocate(eS) - - this%initialised = .true. - - endsubroutine RadialFunction_initialise - - subroutine RadialFunction_finalise(this,error) - type(RadialFunction_type), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%min_cutoff = 0.0_dp - this%n_max = 0 - - if(allocated(this%RadialTransform)) deallocate(this%RadialTransform) - if(allocated(this%NormFunction)) deallocate(this%NormFunction) - - this%initialised = .false. - - endsubroutine RadialFunction_finalise - - subroutine cplx_2d_array1_finalise(this) - type(cplx_2d), dimension(:), allocatable, intent(inout) :: this - integer :: j - - if(allocated(this)) then - do j = lbound(this,1), ubound(this,1) - if(allocated(this(j)%mm)) deallocate(this(j)%mm) - enddo - deallocate(this) - endif - endsubroutine cplx_2d_array1_finalise - - subroutine cplx_3d_array2_finalise(this) - type(cplx_3d), dimension(:,:), allocatable, intent(inout) :: this - integer :: i, j - - if(allocated(this)) then - do j = lbound(this,2), ubound(this,2) - do i = lbound(this,1), ubound(this,1) - if(allocated(this(i,j)%mm)) deallocate(this(i,j)%mm) - enddo - enddo - deallocate(this) - endif - - endsubroutine cplx_3d_array2_finalise - - subroutine fourier_SO4_calc(this,at,i,U,dU,args_str,error) - type(fourier_SO4_type), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(in) :: i - type(cplx_2d), dimension(:), allocatable, intent(inout) :: U - type(cplx_3d), dimension(:,:), allocatable, intent(inout), optional :: dU - integer, optional, intent(out) :: error - character(len=*), intent(in), optional :: args_str - - complex(dp), dimension(:,:), allocatable :: Uc, Up - complex(dp), dimension(:,:,:), allocatable :: dUc, dUp - complex(dp) :: z0_pls_Iz, z0_min_Iz, x_pls_Iy, x_min_Iy - complex(dp), dimension(3) :: dz0_pls_Iz, dz0_min_Iz, dx_pls_Iy, dx_min_Iy - real(dp), dimension(3) :: diff, u_ij, dfcut, dz0, dr0 - real(dp) :: r0, r, fcut, z0, theta0 - integer :: n, n_i, ji, j, m1, m2 - integer, dimension(total_elements) :: species_map - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR('fourier_SO4_calc: object not initialised',error) - endif - - species_map = 0 - do j = 1, size(this%species_Z) - if(this%species_Z(j) == 0) then - species_map = 1 - else - species_map(this%species_Z(j)) = j - endif - enddo - - - if(allocated(U)) then - if(lbound(U,1) /= 0 .or. ubound(U,1) /= this%j_max) call finalise(U) - endif - - if(.not.allocated(U)) then - allocate( U(0:this%j_max) ) - do j = 0, this%j_max - allocate( U(j)%mm(-j:j,-j:j) ) - U(j)%mm = CPLX_ZERO - enddo - endif - - do j = 0, this%j_max - U(j)%mm = CPLX_ZERO - do m1 = -j, j, 2 - U(j)%mm(m1,m1) = CPLX_ONE - enddo - enddo - - allocate( Uc(-this%j_max:this%j_max, -this%j_max:this%j_max), & - Up(-this%j_max:this%j_max, -this%j_max:this%j_max) ) - - Uc = CPLX_ZERO - Up = CPLX_ZERO - - if(present(dU)) then - if(allocated(dU)) call finalise(dU) - - ! dU is not allocated, allocate and zero it - allocate( dU(0:this%j_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) - do j = 0, this%j_max - allocate( dU(j,0)%mm(3,-j:j,-j:j) ) - dU(j,0)%mm = CPLX_ZERO - enddo - - allocate( dUc(3,-this%j_max:this%j_max, -this%j_max:this%j_max), & - dUp(3,-this%j_max:this%j_max, -this%j_max:this%j_max) ) - dUc = CPLX_ZERO - dUp = CPLX_ZERO - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - ji = neighbour(at, i, n, distance=r, diff=diff, cosines=u_ij) - if( r >= this%cutoff ) cycle - - n_i = n_i + 1 - - theta0 = r / this%z0 - z0 = r / tan( theta0 ) - r0 = sin( theta0 ) / r - - z0_pls_Iz = ( z0 + CPLX_IMAG*diff(3) ) * r0 - z0_min_Iz = ( z0 - CPLX_IMAG*diff(3) ) * r0 - x_pls_Iy = ( diff(1) + CPLX_IMAG*diff(2) ) * r0 - x_min_Iy = ( diff(1) - CPLX_IMAG*diff(2) ) * r0 - - fcut = cos_cutoff_function(r,this%cutoff) * this%w(species_map(at%Z(ji))) - - U(0)%mm(0,0) = U(0)%mm(0,0) + fcut - Up(0:0,0:0) = CPLX_ONE - - if(present(dU)) then - - dfcut = -dcos_cutoff_function(r,this%cutoff)*u_ij * this%w(species_map(at%Z(ji))) - dz0 = ( 1.0_dp / tan( theta0 ) - theta0 / sin(theta0)**2 ) * u_ij - dr0 = ( cos( theta0 ) / (r*this%z0) - r0 / r ) * u_ij - - dz0_pls_Iz = ( z0 + CPLX_IMAG*diff(3) )*dr0 + dz0*r0 - dz0_pls_Iz(3) = dz0_pls_Iz(3) + CPLX_IMAG*r0 - - dz0_min_Iz = ( z0 - CPLX_IMAG*diff(3) )*dr0 + dz0*r0 - dz0_min_Iz(3) = dz0_min_Iz(3) - CPLX_IMAG*r0 - - dx_pls_Iy = ( diff(1) + CPLX_IMAG*diff(2) )*dr0 - dx_pls_Iy(1) = dx_pls_Iy(1) + r0 - dx_pls_Iy(2) = dx_pls_Iy(2) + CPLX_IMAG*r0 - - dx_min_Iy = ( diff(1) - CPLX_IMAG*diff(2) )*dr0 - dx_min_Iy(1) = dx_min_Iy(1) + r0 - dx_min_Iy(2) = dx_min_Iy(2) - CPLX_IMAG*r0 - - dUc = CPLX_ZERO - dUp = CPLX_ZERO - - dU(0,0)%mm(:,0,0) = dU(0,0)%mm(:,0,0) + dfcut*CPLX_ONE - - allocate( dU(0,n_i)%mm(3,-0:0,-0:0) ) - - dU(0,n_i)%mm(:,0,0) = - dfcut*CPLX_ONE - endif - - do j = 1, this%j_max - Uc(-j:j,-j:j) = CPLX_ZERO - if(present(dU)) then - dUc(:,-j:j,-j:j) = CPLX_ZERO - allocate( dU(j,n_i)%mm(3,-j:j,-j:j) ) - dU(j,n_i)%mm = CPLX_ZERO - endif - - do m1 = -j, j-2, 2 - do m2 = -j, j, 2 - if( (j-m2) /= 0 ) then - Uc(m2,m1) = Uc(m2,m1) + & - sqrt( real(j-m2,dp)/real(j-m1,dp) ) * z0_pls_Iz * Up(m2+1,m1+1) - - if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) + & - sqrt( real(j-m2,dp)/real(j-m1,dp) ) * & - ( dz0_pls_Iz * Up(m2+1,m1+1) + z0_pls_Iz * dUp(:,m2+1,m1+1) ) - endif - - if( (j+m2) /= 0 ) then - Uc(m2,m1) = Uc(m2,m1) - & - CPLX_IMAG * sqrt( real(j+m2,dp)/real(j-m1,dp) ) * x_min_Iy * Up(m2-1,m1+1) - - if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) - & - CPLX_IMAG * sqrt( real(j+m2,dp)/real(j-m1,dp) ) * & - ( dx_min_Iy * Up(m2-1,m1+1) + x_min_Iy * dUp(:,m2-1,m1+1) ) - - endif - enddo - enddo - - m1 = j - do m2 = -j, j, 2 - if( (j+m2) /= 0 ) then - Uc(m2,m1) = Uc(m2,m1) + & - sqrt( real(j+m2,dp)/real(j+m1,dp) ) * z0_min_Iz * Up(m2-1,m1-1) - - if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) + & - sqrt( real(j+m2,dp)/real(j+m1,dp) ) * & - ( dz0_min_Iz * Up(m2-1,m1-1) + z0_min_Iz * dUp(:,m2-1,m1-1) ) - endif - - if( (j-m2) /= 0 ) then - Uc(m2,m1) = Uc(m2,m1) - & - CPLX_IMAG * sqrt( real(j-m2,dp)/real(j+m1,dp) ) * x_pls_Iy * Up(m2+1,m1-1) - - if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) - & - CPLX_IMAG * sqrt( real(j-m2,dp)/real(j+m1,dp) ) * & - ( dx_pls_Iy * Up(m2+1,m1-1) + x_pls_Iy * dUp(:,m2+1,m1-1) ) - endif - enddo - - U(j)%mm = U(j)%mm + Uc(-j:j,-j:j) * fcut - Up(-j:j,-j:j) = Uc(-j:j,-j:j) - if(present(dU)) then - dUp(:,-j:j,-j:j) = dUc(:,-j:j,-j:j) - dU(j,0)%mm = dU(j,0)%mm - dUc(:,-j:j,-j:j) * fcut - dU(j,n_i)%mm = dU(j,n_i)%mm + dUc(:,-j:j,-j:j) * fcut - do m1 = -j, j, 2 - do m2 = -j, j, 2 - dU(j,0)%mm(:,m2,m1) = dU(j,0)%mm(:,m2,m1) & - + Uc(m2,m1) * dfcut - dU(j,n_i)%mm(:,m2,m1) = dU(j,n_i)%mm(:,m2,m1) & - - Uc(m2,m1) * dfcut - enddo - enddo - endif - - enddo ! j - enddo ! n - - if(allocated(Up)) deallocate(Up) - if(allocated(Uc)) deallocate(Uc) - if(allocated(dUp)) deallocate(dUp) - if(allocated(dUc)) deallocate(dUc) - - endsubroutine fourier_SO4_calc - - subroutine fourier_so4_initialise(this,args_str,error) - type(fourier_SO4_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - integer :: n_species - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '2.75', this%cutoff, help_string="Cutoff for SO4 bispectrum") - call param_register(params, 'z0_ratio', '0.0', this%z0_ratio, help_string="Ratio of radius of 4D projection sphere times PI and the cutoff.") - call param_register(params, 'j_max', '4', this%j_max, help_string="Max of expansion of bispectrum, i.e. resulution") - call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") - call param_register(params, 'n_Z_environment', '1', n_species, help_string="Number of species for the descriptor", altkey="n_species") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='fourier_so4_initialise args_str')) then - RAISE_ERROR("fourier_so4_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(this%species_Z(n_species), this%w(n_species)) - - call initialise(params) - if( n_species == 1 ) then - call param_register(params, 'Z_environment', '0', this%species_Z(1), help_string="Atomic number of species", altkey="species_Z") - call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") - else - call param_register(params, 'Z_environment', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species", altkey="species_Z") - call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") - endif - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='fourier_so4_initialise args_str')) then - RAISE_ERROR("fourier_so4_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%z0 = max(1.0_dp,this%z0_ratio) * this%cutoff/(PI-0.02_dp) - - this%initialised = .true. - - - endsubroutine fourier_so4_initialise - - subroutine fourier_so4_finalise(this,error) - type(fourier_so4_type), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - - this%cutoff = 0.0_dp - this%j_max = 0 - this%z0_ratio = 0.0_dp - this%z0 = 0.0_dp - this%Z = 0 - - if(allocated(this%species_Z)) deallocate(this%species_Z) - if(allocated(this%w)) deallocate(this%w) - - this%initialised = .false. - - endsubroutine fourier_so4_finalise - - subroutine bispectrum_so4_initialise(this,args_str,error) - type(bispectrum_so4), intent(inout), target :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - call finalise(this) - - call initialise(this%fourier_SO4,args_str,error) - - this%cutoff => this%fourier_SO4%cutoff - this%z0_ratio => this%fourier_SO4%z0_ratio - this%z0 => this%fourier_SO4%z0 - this%j_max => this%fourier_SO4%j_max - this%Z => this%fourier_SO4%Z - this%cutoff => this%fourier_SO4%cutoff - this%species_Z => this%fourier_SO4%species_Z - this%w => this%fourier_SO4%w - - this%initialised = .true. - - endsubroutine bispectrum_so4_initialise - - subroutine bispectrum_so4_finalise(this,error) - type(bispectrum_so4), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - - call finalise(this%fourier_SO4,error) - - this%cutoff => null() - this%z0_ratio => null() - this%z0 => null() - this%j_max => null() - this%Z => null() - this%cutoff => null() - this%species_Z => null() - this%w => null() - - this%initialised = .false. - - endsubroutine bispectrum_so4_finalise - - subroutine bispectrum_so3_initialise(this,args_str,error) - type(bispectrum_so3), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - integer :: n_species - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for bispectrum_so3-type descriptors") - call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Cutoff for minimal distances in bispectrum_so3-type descriptors") - call param_register(params, 'l_max', '4', this%l_max, help_string="L_max for bispectrum_so3-type descriptors") - call param_register(params, 'n_max', '4', this%n_max, help_string="N_max for bispectrum_so3-type descriptors") - call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") - call param_register(params, 'n_Z_environment', '1', n_species, help_string="Number of species for the descriptor", altkey="n_species") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='bispectrum_so3_initialise args_str')) then - RAISE_ERROR("bispectrum_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(this%species_Z(n_species), this%w(n_species)) - - call initialise(params) - if( n_species == 1 ) then - call param_register(params, 'Z_environment', '0', this%species_Z(1), help_string="Atomic number of species", altkey="species_Z") - call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") - else - call param_register(params, 'Z_environment', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species", altkey="species_Z") - call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") - endif - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='bispectrum_so3_initialise args_str')) then - RAISE_ERROR("bispectrum_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - call initialise(this%Radial,this%n_max,this%cutoff,this%min_cutoff,error) - - this%initialised = .true. - - call print('Dimensions: '//bispectrum_so3_dimensions(this,error)) - - endsubroutine bispectrum_so3_initialise - - subroutine bispectrum_so3_finalise(this,error) - type(bispectrum_so3), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - - this%cutoff = 0.0_dp - this%min_cutoff = 0.0_dp - this%l_max = 0 - this%n_max = 0 - this%Z = 0 - - if(allocated(this%species_Z)) deallocate(this%species_Z) - if(allocated(this%w)) deallocate(this%w) - - call finalise(this%Radial) - - this%initialised = .false. - - endsubroutine bispectrum_so3_finalise - - subroutine behler_initialise(this,args_str,error) - type(behler), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(len=STRING_LENGTH) :: specification_str, specification_file - logical :: has_specification,has_specification_file - integer :: n_fields, i_field, i_g2, i_g3, n, sym_type - character(len=128), dimension(:), allocatable :: specification - character(len=16), dimension(7) :: sym_func - - type(inoutput) :: specification_inout - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params,"Z","0",this%Z, help_string="Central atom") - call param_register(params,"specification","",specification_str, help_string="String to specify Parrinello-Behler descriptors", & - has_value_target=has_specification) - call param_register(params,"specification_file","",specification_file, help_string="File containing string to specify Parrinello-Behler descriptors", & - has_value_target=has_specification_file) - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='behler_initialise args_str')) then - RAISE_ERROR("behler_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_specification .or. has_specification_file ) then - if( has_specification .and. has_specification_file ) then - RAISE_ERROR("behler_initialise: both specification and specification_file specified",error) - endif - - if(has_specification_file) then - call initialise(specification_inout,trim(specification_file)) - read(specification_inout%unit,'(a)') specification_str - call finalise(specification_inout) - endif - - n_fields = num_fields_in_string_simple(specification_str,"|") - allocate(specification(n_fields)) - call split_string_simple(specification_str,specification,n_fields,"|") - - this%n_g2 = 0 - this%n_g3 = 0 - - do i_field = 1, n_fields - call split_string_simple(specification(i_field),sym_func,n,":") - sym_type = string_to_int(sym_func(1),error) - select case(sym_type) - case(2) - this%n_g2 = this%n_g2 + 1 - case(3) - this%n_g3 = this%n_g3 + 1 - case default - RAISE_ERROR("behler_initialise: unknown symmetry function type "//sym_type,error) - endselect - enddo - - allocate(this%g2(this%n_g2)) - allocate(this%g3(this%n_g3)) - - i_g2 = 0 - i_g3 = 0 - this%cutoff = 0.0_dp - do i_field = 1, n_fields - call split_string_simple(specification(i_field),sym_func,n,":") - - sym_type = string_to_int(sym_func(1),error) - select case(sym_type) - case(2) - i_g2 = i_g2 + 1 - this%g2(i_g2)%Z_n = atomic_number_from_symbol(sym_func(2)) - this%g2(i_g2)%eta = string_to_real(sym_func(3)) / BOHR**2 - this%g2(i_g2)%rs = string_to_real(sym_func(4)) * BOHR - this%g2(i_g2)%rc = string_to_real(sym_func(5)) * BOHR - this%cutoff = max(this%cutoff,this%g2(i_g2)%rc) - case(3) - i_g3 = i_g3 + 1 - this%g3(i_g3)%Z_n(1) = atomic_number_from_symbol(sym_func(2)) - this%g3(i_g3)%Z_n(2) = atomic_number_from_symbol(sym_func(3)) - this%g3(i_g3)%eta = string_to_real(sym_func(4)) / BOHR**2 - this%g3(i_g3)%lambda = string_to_real(sym_func(5)) - this%g3(i_g3)%zeta = string_to_real(sym_func(6)) - this%g3(i_g3)%rc = string_to_real(sym_func(7)) * BOHR - this%cutoff = max(this%cutoff,this%g3(i_g3)%rc) - case default - RAISE_ERROR("behler_initialise: unknown symmetry function type "//sym_type,error) - endselect - enddo - else - ! Default, for backwards compatibility - this%n_g2 = 8 - this%n_g3 = 43 - - allocate(this%g2(this%n_g2), this%g3(this%n_g3)) - do i_g2 = 1, this%n_g2 - this%g2(i_g2)%Z_n = 0 - enddo - do i_g3 = 1, this%n_g3 - this%g3(i_g3)%Z_n = 0 - enddo - - this%g2(1)%eta = 0.001_dp / BOHR**2; this%g2(1)%rs = 0.000_dp * BOHR; this%g2(1)%rc = 11.338_dp * BOHR - this%g2(2)%eta = 0.010_dp / BOHR**2; this%g2(2)%rs = 0.000_dp * BOHR; this%g2(2)%rc = 11.338_dp * BOHR - this%g2(3)%eta = 0.020_dp / BOHR**2; this%g2(3)%rs = 0.000_dp * BOHR; this%g2(3)%rc = 11.338_dp * BOHR - this%g2(4)%eta = 0.035_dp / BOHR**2; this%g2(4)%rs = 0.000_dp * BOHR; this%g2(4)%rc = 11.338_dp * BOHR - this%g2(5)%eta = 0.060_dp / BOHR**2; this%g2(5)%rs = 0.000_dp * BOHR; this%g2(5)%rc = 11.338_dp * BOHR - this%g2(6)%eta = 0.100_dp / BOHR**2; this%g2(6)%rs = 0.000_dp * BOHR; this%g2(6)%rc = 11.338_dp * BOHR - this%g2(7)%eta = 0.200_dp / BOHR**2; this%g2(7)%rs = 0.000_dp * BOHR; this%g2(7)%rc = 11.338_dp * BOHR - this%g2(8)%eta = 0.400_dp / BOHR**2; this%g2(8)%rs = 0.000_dp * BOHR; this%g2(8)%rc = 11.338_dp * BOHR - - this%g3( 1)%eta = 0.0001_dp / BOHR**2; this%g3( 1)%lambda = -1.000_dp; this%g3( 1)%zeta = 1.000_dp; this%g3( 1)%rc = 11.338_dp * BOHR - this%g3( 2)%eta = 0.0001_dp / BOHR**2; this%g3( 2)%lambda = 1.000_dp; this%g3( 2)%zeta = 1.000_dp; this%g3( 2)%rc = 11.338_dp * BOHR - this%g3( 3)%eta = 0.0001_dp / BOHR**2; this%g3( 3)%lambda = -1.000_dp; this%g3( 3)%zeta = 2.000_dp; this%g3( 3)%rc = 11.338_dp * BOHR - this%g3( 4)%eta = 0.0001_dp / BOHR**2; this%g3( 4)%lambda = 1.000_dp; this%g3( 4)%zeta = 2.000_dp; this%g3( 4)%rc = 11.338_dp * BOHR - this%g3( 5)%eta = 0.0030_dp / BOHR**2; this%g3( 5)%lambda = -1.000_dp; this%g3( 5)%zeta = 1.000_dp; this%g3( 5)%rc = 11.338_dp * BOHR - this%g3( 6)%eta = 0.0030_dp / BOHR**2; this%g3( 6)%lambda = 1.000_dp; this%g3( 6)%zeta = 1.000_dp; this%g3( 6)%rc = 11.338_dp * BOHR - this%g3( 7)%eta = 0.0030_dp / BOHR**2; this%g3( 7)%lambda = -1.000_dp; this%g3( 7)%zeta = 2.000_dp; this%g3( 7)%rc = 11.338_dp * BOHR - this%g3( 8)%eta = 0.0030_dp / BOHR**2; this%g3( 8)%lambda = 1.000_dp; this%g3( 8)%zeta = 2.000_dp; this%g3( 8)%rc = 11.338_dp * BOHR - this%g3( 9)%eta = 0.0080_dp / BOHR**2; this%g3( 9)%lambda = -1.000_dp; this%g3( 9)%zeta = 1.000_dp; this%g3( 9)%rc = 11.338_dp * BOHR - this%g3(10)%eta = 0.0080_dp / BOHR**2; this%g3(10)%lambda = 1.000_dp; this%g3(10)%zeta = 1.000_dp; this%g3(10)%rc = 11.338_dp * BOHR - this%g3(11)%eta = 0.0080_dp / BOHR**2; this%g3(11)%lambda = -1.000_dp; this%g3(11)%zeta = 2.000_dp; this%g3(11)%rc = 11.338_dp * BOHR - this%g3(12)%eta = 0.0080_dp / BOHR**2; this%g3(12)%lambda = 1.000_dp; this%g3(12)%zeta = 2.000_dp; this%g3(12)%rc = 11.338_dp * BOHR - this%g3(13)%eta = 0.0150_dp / BOHR**2; this%g3(13)%lambda = -1.000_dp; this%g3(13)%zeta = 1.000_dp; this%g3(13)%rc = 11.338_dp * BOHR - this%g3(14)%eta = 0.0150_dp / BOHR**2; this%g3(14)%lambda = 1.000_dp; this%g3(14)%zeta = 1.000_dp; this%g3(14)%rc = 11.338_dp * BOHR - this%g3(15)%eta = 0.0150_dp / BOHR**2; this%g3(15)%lambda = -1.000_dp; this%g3(15)%zeta = 2.000_dp; this%g3(15)%rc = 11.338_dp * BOHR - this%g3(16)%eta = 0.0150_dp / BOHR**2; this%g3(16)%lambda = 1.000_dp; this%g3(16)%zeta = 2.000_dp; this%g3(16)%rc = 11.338_dp * BOHR - this%g3(17)%eta = 0.0150_dp / BOHR**2; this%g3(17)%lambda = -1.000_dp; this%g3(17)%zeta = 4.000_dp; this%g3(17)%rc = 11.338_dp * BOHR - this%g3(18)%eta = 0.0150_dp / BOHR**2; this%g3(18)%lambda = 1.000_dp; this%g3(18)%zeta = 4.000_dp; this%g3(18)%rc = 11.338_dp * BOHR - this%g3(19)%eta = 0.0150_dp / BOHR**2; this%g3(19)%lambda = -1.000_dp; this%g3(19)%zeta = 16.000_dp; this%g3(19)%rc = 11.338_dp * BOHR - this%g3(20)%eta = 0.0150_dp / BOHR**2; this%g3(20)%lambda = 1.000_dp; this%g3(20)%zeta = 16.000_dp; this%g3(20)%rc = 11.338_dp * BOHR - this%g3(21)%eta = 0.0250_dp / BOHR**2; this%g3(21)%lambda = -1.000_dp; this%g3(21)%zeta = 1.000_dp; this%g3(21)%rc = 11.338_dp * BOHR - this%g3(22)%eta = 0.0250_dp / BOHR**2; this%g3(22)%lambda = 1.000_dp; this%g3(22)%zeta = 1.000_dp; this%g3(22)%rc = 11.338_dp * BOHR - this%g3(23)%eta = 0.0250_dp / BOHR**2; this%g3(23)%lambda = -1.000_dp; this%g3(23)%zeta = 2.000_dp; this%g3(23)%rc = 11.338_dp * BOHR - this%g3(24)%eta = 0.0250_dp / BOHR**2; this%g3(24)%lambda = 1.000_dp; this%g3(24)%zeta = 2.000_dp; this%g3(24)%rc = 11.338_dp * BOHR - this%g3(25)%eta = 0.0250_dp / BOHR**2; this%g3(25)%lambda = -1.000_dp; this%g3(25)%zeta = 4.000_dp; this%g3(25)%rc = 11.338_dp * BOHR - this%g3(26)%eta = 0.0250_dp / BOHR**2; this%g3(26)%lambda = 1.000_dp; this%g3(26)%zeta = 4.000_dp; this%g3(26)%rc = 11.338_dp * BOHR - this%g3(27)%eta = 0.0250_dp / BOHR**2; this%g3(27)%lambda = -1.000_dp; this%g3(27)%zeta = 16.000_dp; this%g3(27)%rc = 11.338_dp * BOHR - this%g3(28)%eta = 0.0250_dp / BOHR**2; this%g3(28)%lambda = 1.000_dp; this%g3(28)%zeta = 16.000_dp; this%g3(28)%rc = 11.338_dp * BOHR - this%g3(29)%eta = 0.0450_dp / BOHR**2; this%g3(29)%lambda = -1.000_dp; this%g3(29)%zeta = 1.000_dp; this%g3(29)%rc = 11.338_dp * BOHR - this%g3(30)%eta = 0.0450_dp / BOHR**2; this%g3(30)%lambda = 1.000_dp; this%g3(30)%zeta = 1.000_dp; this%g3(30)%rc = 11.338_dp * BOHR - this%g3(31)%eta = 0.0450_dp / BOHR**2; this%g3(31)%lambda = -1.000_dp; this%g3(31)%zeta = 2.000_dp; this%g3(31)%rc = 11.338_dp * BOHR - this%g3(32)%eta = 0.0450_dp / BOHR**2; this%g3(32)%lambda = 1.000_dp; this%g3(32)%zeta = 2.000_dp; this%g3(32)%rc = 11.338_dp * BOHR - this%g3(33)%eta = 0.0450_dp / BOHR**2; this%g3(33)%lambda = -1.000_dp; this%g3(33)%zeta = 4.000_dp; this%g3(33)%rc = 11.338_dp * BOHR - this%g3(34)%eta = 0.0450_dp / BOHR**2; this%g3(34)%lambda = 1.000_dp; this%g3(34)%zeta = 4.000_dp; this%g3(34)%rc = 11.338_dp * BOHR - this%g3(35)%eta = 0.0450_dp / BOHR**2; this%g3(35)%lambda = -1.000_dp; this%g3(35)%zeta = 16.000_dp; this%g3(35)%rc = 11.338_dp * BOHR - this%g3(36)%eta = 0.0450_dp / BOHR**2; this%g3(36)%lambda = 1.000_dp; this%g3(36)%zeta = 16.000_dp; this%g3(36)%rc = 11.338_dp * BOHR - this%g3(37)%eta = 0.0800_dp / BOHR**2; this%g3(37)%lambda = -1.000_dp; this%g3(37)%zeta = 1.000_dp; this%g3(37)%rc = 11.338_dp * BOHR - this%g3(38)%eta = 0.0800_dp / BOHR**2; this%g3(38)%lambda = 1.000_dp; this%g3(38)%zeta = 1.000_dp; this%g3(38)%rc = 11.338_dp * BOHR - this%g3(39)%eta = 0.0800_dp / BOHR**2; this%g3(39)%lambda = -1.000_dp; this%g3(39)%zeta = 2.000_dp; this%g3(39)%rc = 11.338_dp * BOHR - this%g3(40)%eta = 0.0800_dp / BOHR**2; this%g3(40)%lambda = 1.000_dp; this%g3(40)%zeta = 2.000_dp; this%g3(40)%rc = 11.338_dp * BOHR - this%g3(41)%eta = 0.0800_dp / BOHR**2; this%g3(41)%lambda = -1.000_dp; this%g3(41)%zeta = 4.000_dp; this%g3(41)%rc = 11.338_dp * BOHR - this%g3(42)%eta = 0.0800_dp / BOHR**2; this%g3(42)%lambda = 1.000_dp; this%g3(42)%zeta = 4.000_dp; this%g3(42)%rc = 11.338_dp * BOHR - this%g3(43)%eta = 0.0800_dp / BOHR**2; this%g3(43)%lambda = 1.000_dp; this%g3(43)%zeta = 16.000_dp; this%g3(43)%rc = 11.338_dp * BOHR - - this%cutoff = 11.338_dp * BOHR - endif - - if( allocated(specification) ) deallocate(specification) - - this%initialised = .true. - - endsubroutine behler_initialise - - subroutine behler_finalise(this,error) - type(behler), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - - this%cutoff = 0.0_dp - this%n_g2 = 0 - this%n_g3 = 0 - - if(allocated(this%g2)) deallocate(this%g2) - if(allocated(this%g3)) deallocate(this%g3) - - this%initialised = .false. - - endsubroutine behler_finalise - - subroutine distance_2b_initialise(this,args_str,error) - type(distance_2b), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - logical :: has_resid_name, has_exponents - integer :: i - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for distance_2b-type descriptors") - call param_register(params, 'cutoff_transition_width', '0.5', this%cutoff_transition_width, help_string="Transition width of cutoff for distance_2b-type descriptors") - call param_register(params, 'Z1', '0', this%Z1, help_string="Atom type #1 in bond") - call param_register(params, 'Z2', '0', this%Z2, help_string="Atom type #2 in bond") - call param_register(params, 'resid_name', '', this%resid_name, has_value_target=has_resid_name, help_string="Name of an integer property in the atoms object giving the residue id of the molecule to which the atom belongs.") - call param_register(params, 'only_intra', 'F', this%only_intra, help_string="Only calculate INTRAmolecular pairs with equal residue ids (bonds)") - call param_register(params, 'only_inter', 'F', this%only_inter, help_string="Only apply to INTERmolecular pairs with different residue ids (non-bonded)") - - call param_register(params, 'n_exponents', '1', this%n_exponents, help_string="Number of exponents") - call param_register(params, 'tail_range', '1.0', this%tail_range, help_string="Tail order") - call param_register(params, 'tail_exponent', '0', this%tail_exponent, & - has_value_target = this%has_tail, help_string="Tail range") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_2b_initialise args_str')) then - RAISE_ERROR("distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if (this%only_intra .and. this%only_inter) then - RAISE_ERROR("distance_2b_initialise: cannot specify both only_inter AND only_intra", error) - end if - if ((this%only_intra .or. this%only_inter) .and. (.not. has_resid_name)) then - RAISE_ERROR("distance_2b_initialise: only_intra and only_inter require resid_name to be given as well", error) - end if - - allocate(this%exponents(this%n_exponents)) - call initialise(params) - if( this%n_exponents == 1 ) then - call param_register(params, 'exponents',"1", this%exponents(1), & - has_value_target=has_exponents,help_string="Exponents") - else - call param_register(params, 'exponents',repeat(" 1 ",this%n_exponents), this%exponents, & - has_value_target=has_exponents,help_string="Exponents") - endif - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_2b_initialise args_str')) then - RAISE_ERROR("distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if( .not. has_exponents .and. this%n_exponents > 1 ) then - do i = 1, this%n_exponents - this%exponents(i) = -i - enddo - endif - - this%initialised = .true. - - endsubroutine distance_2b_initialise - - subroutine distance_2b_finalise(this,error) - type(distance_2b), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%cutoff_transition_width = 0.5_dp - this%Z1 = 0 - this%Z2 = 0 - - this%resid_name = '' - this%only_intra = .false. - this%only_inter = .false. - - this%tail_exponent = 0 - this%tail_range = 0.0_dp - this%has_tail = .false. - - this%n_exponents = 0 - if(allocated(this%exponents)) deallocate(this%exponents) - - this%initialised = .false. - - endsubroutine distance_2b_finalise - - subroutine coordination_initialise(this,args_str,error) - type(coordination), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for coordination-type descriptors") - call param_register(params, 'transition_width', '0.20', this%transition_width, help_string="Width of transition region from 1 to 0") - call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z_center") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='coordination_initialise args_str')) then - RAISE_ERROR("coordination_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine coordination_initialise - - subroutine coordination_finalise(this,error) - type(coordination), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%transition_width = 0.0_dp - this%Z = 0 - - this%initialised = .false. - - endsubroutine coordination_finalise - - subroutine angle_3b_initialise(this,args_str,error) - type(angle_3b), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for angle_3b-type descriptors") - call param_register(params, 'cutoff_transition_width', '0.50', this%cutoff_transition_width, help_string="Cutoff transition width for angle_3b-type descriptors") - call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") - call param_register(params, 'Z1', '0', this%Z1, help_string="Atomic number of neighbour #1") - call param_register(params, 'Z2', '0', this%Z2, help_string="Atomic number of neighbour #2") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='angle_3b_initialise args_str')) then - RAISE_ERROR("angle_3b_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine angle_3b_initialise - - subroutine angle_3b_finalise(this,error) - type(angle_3b), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%Z = 0 - this%Z1 = 0 - this%Z2 = 0 - - this%initialised = .false. - - endsubroutine angle_3b_finalise - - subroutine co_angle_3b_initialise(this,args_str,error) - type(co_angle_3b), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for co_angle_3b-type descriptors") - call param_register(params, 'coordination_cutoff', '0.00', this%coordination_cutoff, help_string="Cutoff for coordination function in co_angle_3b-type descriptors") - call param_register(params, 'coordination_transition_width', '0.00', this%coordination_transition_width, help_string="Transition width for co_angle_3b-type descriptors") - call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") - call param_register(params, 'Z1', '0', this%Z1, help_string="Atomic number of neighbour #1") - call param_register(params, 'Z2', '0', this%Z2, help_string="Atomic number of neighbour #2") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='co_angle_3b_initialise args_str')) then - RAISE_ERROR("co_angle_3b_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine co_angle_3b_initialise - - subroutine co_angle_3b_finalise(this,error) - type(co_angle_3b), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%coordination_cutoff = 0.0_dp - this%coordination_transition_width = 0.0_dp - this%Z = 0 - this%Z1 = 0 - this%Z2 = 0 - - this%initialised = .false. - - endsubroutine co_angle_3b_finalise - - subroutine co_distance_2b_initialise(this,args_str,error) - type(co_distance_2b), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for co_distance_2b-type descriptors") - call param_register(params, 'transition_width', '0.50', this%transition_width, help_string="Transition width of cutoff for co_distance_2b-type descriptors") - call param_register(params, 'coordination_cutoff', '0.00', this%coordination_cutoff, help_string="Cutoff for coordination function in co_distance_2b-type descriptors") - call param_register(params, 'coordination_transition_width', '0.00', this%coordination_transition_width, help_string="Transition width for co_distance_2b-type descriptors") - call param_register(params, 'Z1', '0', this%Z1, help_string="Atom type #1 in bond") - call param_register(params, 'Z2', '0', this%Z2, help_string="Atom type #2 in bond") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='co_distance_2b_initialise args_str')) then - RAISE_ERROR("co_distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine co_distance_2b_initialise - - subroutine co_distance_2b_finalise(this,error) - type(co_distance_2b), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%coordination_cutoff = 0.0_dp - this%coordination_transition_width = 0.0_dp - this%Z1 = 0 - this%Z2 = 0 - - this%initialised = .false. - - endsubroutine co_distance_2b_finalise - - subroutine cosnx_initialise(this,args_str,error) - type(cosnx), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - integer :: n_species - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for cosnx-type descriptors") - call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Cutoff for minimal distances in cosnx-type descriptors") - call param_register(params, 'l_max', '4', this%l_max, help_string="L_max for cosnx-type descriptors") - call param_register(params, 'n_max', '4', this%n_max, help_string="N_max for cosnx-type descriptors") - call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") - call param_register(params, 'n_species', '1', n_species, help_string="Number of species for the descriptor") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='cosnx_initialise args_str')) then - RAISE_ERROR("cosnx_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(this%species_Z(n_species), this%w(n_species)) - - call initialise(params) - if( n_species == 1 ) then - call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") - call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") - else - call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species") - call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") - endif - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='cosnx_initialise args_str')) then - RAISE_ERROR("cosnx_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - call initialise(this%Radial,this%n_max,this%cutoff,this%min_cutoff,error) - - this%initialised = .true. - - endsubroutine cosnx_initialise - - subroutine cosnx_finalise(this,error) - type(cosnx), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%min_cutoff = 0.0_dp - this%l_max = 0 - this%n_max = 0 - - if(allocated(this%species_Z)) deallocate(this%species_Z) - if(allocated(this%w)) deallocate(this%w) - - call finalise(this%Radial) - - this%initialised = .false. - - endsubroutine cosnx_finalise - - subroutine trihis_initialise(this,args_str,error) - type(trihis), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - real(dp), dimension(:), allocatable :: gauss_centre1D, gauss_width1D - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for trihis-type descriptors") - call param_register(params, 'n_gauss', '0', this%n_gauss, help_string="Number of Gaussians for trihis-type descriptors") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='trihis_initialise args_str')) then - RAISE_ERROR("trihis_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(gauss_centre1D(3*this%n_gauss),gauss_width1D(3*this%n_gauss)) - allocate(this%gauss_centre(3,this%n_gauss),this%gauss_width(3,this%n_gauss)) - - call initialise(params) - call param_register(params, 'trihis_gauss_centre', PARAM_MANDATORY, gauss_centre1D, help_string="Number of Gaussians for trihis-type descriptors") - call param_register(params, 'trihis_gauss_width', PARAM_MANDATORY, gauss_width1D, help_string="Number of Gaussians for trihis-type descriptors") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='trihis_initialise args_str')) then - RAISE_ERROR("trihis_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%gauss_centre = reshape(gauss_centre1D,(/3,this%n_gauss/)) - this%gauss_width = reshape(gauss_width1D,(/3,this%n_gauss/)) - - deallocate(gauss_centre1D,gauss_width1D) - - this%initialised = .true. - - endsubroutine trihis_initialise - - subroutine trihis_finalise(this,error) - type(trihis), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%n_gauss = 0 - - if(allocated(this%gauss_centre)) deallocate(this%gauss_centre) - if(allocated(this%gauss_width)) deallocate(this%gauss_width) - - this%initialised = .false. - - endsubroutine trihis_finalise - - subroutine water_monomer_initialise(this,args_str,error) - type(water_monomer), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for water_monomer-type descriptors") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='water_monomer_initialise args_str')) then - RAISE_ERROR("water_monomer_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine water_monomer_initialise - - subroutine water_monomer_finalise(this,error) - type(water_monomer), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - - this%initialised = .false. - - endsubroutine water_monomer_finalise - - subroutine water_dimer_initialise(this,args_str,error) - type(water_dimer), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for water_dimer-type descriptors") - call param_register(params, 'cutoff_transition_width', '0.50', this%cutoff_transition_width, help_string="Width of smooth cutoff region for water_dimer-type descriptors") - call param_register(params, 'monomer_cutoff', '1.50', this%monomer_cutoff, help_string="Monomer cutoff for water_dimer-type descriptors") - call param_register(params, 'OHH_ordercheck', 'T', this%OHH_ordercheck, help_string="T: find water molecules. F: use default order OHH") - call param_register(params, 'power', '1.0', this%power, help_string="Power of distances to be used in the kernel") - call param_register(params, 'dist_shift', '0.0', this%dist_shift, help_string="Distance shift for inverse distance descriptors.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='water_dimer_initialise args_str')) then - RAISE_ERROR("water_dimer_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine water_dimer_initialise - - subroutine water_dimer_finalise(this,error) - type(water_dimer), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%cutoff_transition_width = 0.0_dp - this%monomer_cutoff = 0.0_dp - this%OHH_ordercheck = .true. - this%power = 1.0_dp - this%dist_shift = 0.0_dp - - this%initialised = .false. - - endsubroutine water_dimer_finalise - - subroutine A2_dimer_initialise(this,args_str,error) - type(A2_dimer), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for A2_dimer-type descriptors") - call param_register(params, 'monomer_cutoff', '1.50', this%monomer_cutoff, help_string="Monomer cutoff for A2_dimer-type descriptors") - call param_register(params, 'atomic_number', '1', this%atomic_number, help_string="Atomic number in A2_dimer-type descriptors") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='A2_dimer_initialise args_str')) then - RAISE_ERROR("A2_dimer_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine A2_dimer_initialise - - subroutine A2_dimer_finalise(this,error) - type(A2_dimer), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%monomer_cutoff = 0.0_dp - this%atomic_number = 0 - - this%initialised = .false. - - endsubroutine A2_dimer_finalise - - subroutine AB_dimer_initialise(this,args_str,error) - type(AB_dimer), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for AB_dimer-type descriptors") - call param_register(params, 'monomer_cutoff', '1.50', this%monomer_cutoff, help_string="Monomer cutoff for AB_dimer-type descriptors") - call param_register(params, 'atomic_number1', '1', this%atomic_number1, help_string="Atomic number of atom 1 in AB_dimer-type descriptors") - call param_register(params, 'atomic_number2', '9', this%atomic_number2, help_string="Atomic number of atom 2 in AB_dimer-type descriptors") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='AB_dimer_initialise args_str')) then - RAISE_ERROR("AB_dimer_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if( this%atomic_number1 == this%atomic_number2 ) then - RAISE_ERROR("AB_dimer_initialise: AB_dimer_atomic_number1 = AB_dimer_atomic_number2 = "//this%atomic_number1//" which would require addtional permutational symmetries. Use A2_dimer descriptor instead.",error) - endif - - this%initialised = .true. - - endsubroutine AB_dimer_initialise - - subroutine AB_dimer_finalise(this,error) - type(AB_dimer), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%monomer_cutoff = 0.0_dp - this%atomic_number1 = 0 - this%atomic_number2 = 0 - - this%initialised = .false. - - endsubroutine AB_dimer_finalise - - - subroutine atom_real_space_initialise(this,args_str,error) - type(atom_real_space), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Space cutoff for atom_real_space-type descriptors") - call param_register(params, 'cutoff_transition_width', '0.00', this%cutoff_transition_width, help_string="Space transition width for atom_real_space-type descriptors") - call param_register(params, 'l_max', '0', this%l_max, help_string="Cutoff for spherical harmonics expansion") - call param_register(params, 'alpha', '1.0', this%alpha, help_string="Width of atomic Gaussians") - call param_register(params, 'zeta', '1.0', this%zeta, help_string="Exponent of covariance function") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='atom_real_space_initialise args_str')) then - RAISE_ERROR("atom_real_space_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine atom_real_space_initialise - - subroutine atom_real_space_finalise(this,error) - type(atom_real_space), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%cutoff_transition_width = 0.0_dp - this%l_max = 0 - this%alpha = 0.0_dp - this%zeta = 0.0_dp - - this%initialised = .false. - - endsubroutine atom_real_space_finalise - - subroutine power_so3_initialise(this,args_str,error) - type(power_so3), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - integer :: n_species - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for power_so3-type descriptors") - call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Cutoff for minimal distances in power_so3-type descriptors") - call param_register(params, 'l_max', '4', this%l_max, help_string="L_max for power_so3-type descriptors") - call param_register(params, 'n_max', '4', this%n_max, help_string="N_max for power_so3-type descriptors") - call param_register(params, 'Z', '0', this%Z, help_string="Atomic number of central atom") - call param_register(params, 'n_species', '1', n_species, help_string="Number of species for the descriptor") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='power_so3_initialise args_str')) then - RAISE_ERROR("power_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(this%species_Z(n_species), this%w(n_species)) - - call initialise(params) - if( n_species == 1 ) then - call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") - call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") - else - call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species") - call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") - endif - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='power_so3_initialise args_str')) then - RAISE_ERROR("power_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - call initialise(this%Radial,this%n_max,this%cutoff,this%min_cutoff,error) - - this%initialised = .true. - - endsubroutine power_so3_initialise - - subroutine power_so3_finalise(this,error) - type(power_so3), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%min_cutoff = 0.0_dp - this%l_max = 0 - this%n_max = 0 - this%Z = 0 - - if(allocated(this%species_Z)) deallocate(this%species_Z) - if(allocated(this%w)) deallocate(this%w) - - call finalise(this%Radial) - - this%initialised = .false. - - endsubroutine power_so3_finalise - - subroutine power_so4_initialise(this,args_str,error) - type(power_so4), intent(inout), target :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - call finalise(this) - - call initialise(this%fourier_SO4,args_str,error) - - this%cutoff => this%fourier_SO4%cutoff - this%z0_ratio => this%fourier_SO4%z0_ratio - this%z0 => this%fourier_SO4%z0 - this%j_max => this%fourier_SO4%j_max - this%Z => this%fourier_SO4%Z - this%cutoff => this%fourier_SO4%cutoff - this%species_Z => this%fourier_SO4%species_Z - this%w => this%fourier_SO4%w - - this%initialised = .true. - - endsubroutine power_so4_initialise - - subroutine power_so4_finalise(this,error) - type(power_so4), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - - call finalise(this%fourier_SO4,error) - - this%cutoff => null() - this%z0_ratio => null() - this%z0 => null() - this%j_max => null() - this%Z => null() - this%cutoff => null() - this%species_Z => null() - this%w => null() - - this%initialised = .false. - - endsubroutine power_so4_finalise - - subroutine soap_initialise(this,args_str,error) - type(soap), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - real(dp) :: alpha_basis, spacing_basis, cutoff_basis, basis_error_exponent - real(dp) :: N_alpha, S_alpha_beta, N_beta - real(dp), dimension(:,:,:), allocatable :: covariance_basis, overlap_basis - integer :: i, j, xml_version, info, n_radial_grid - - real(dp), dimension(:, :), allocatable :: alpha_ln, Q, R - real(dp) :: u, alpha_gto, t, Rg - integer :: l, n, l_ub - - type(LA_Matrix) :: LA_covariance_basis, LA_overlap_basis - type(LA_matrix), dimension(:), allocatable :: LA_BL_ti - character(len=STRING_LENGTH) :: species_Z_str - logical :: has_n_species, has_species_Z, has_central_reference_all_species - - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', PARAM_MANDATORY, this%cutoff, help_string="Cutoff for soap-type descriptors") - call param_register(params, 'cutoff_transition_width', '0.50', this%cutoff_transition_width, help_string="Cutoff transition width for soap-type descriptors") - - call param_register(params, 'cutoff_dexp', '0', this%cutoff_dexp, help_string="Cutoff decay exponent") - call param_register(params, 'cutoff_scale', '1.0', this%cutoff_scale, help_string="Cutoff decay scale") - call param_register(params, 'cutoff_rate', '1.0', this%cutoff_rate, help_string="Inverse cutoff decay rate") - - call param_register(params, 'l_max', PARAM_MANDATORY, this%l_max, help_string="L_max (spherical harmonics basis band limit) for soap-type descriptors") - call param_register(params, 'n_max', PARAM_MANDATORY, this%n_max, help_string="N_max (number of radial basis functions) for soap-type descriptors") - call param_register(params, 'atom_gaussian_width', PARAM_MANDATORY, this%atom_sigma, help_string="Width of atomic Gaussians for soap-type descriptors", altkey='atom_sigma') - call param_register(params, 'central_weight', '1.0', this%central_weight, help_string="Weight of central atom in environment") - call param_register(params, 'central_reference_all_species', 'F', this%central_reference_all_species, has_value_target=has_central_reference_all_species, & - help_string="Place a Gaussian reference for all atom species densities."// & - "By default (F) only consider when neighbour is the same species as centre") - call param_register(params, 'average', 'F', this%global, help_string="Whether to calculate averaged SOAP - one descriptor per atoms object. If false (default) atomic SOAP is returned.") - call param_register(params, 'diagonal_radial', 'F', this%diagonal_radial, help_string="Only return the n1=n2 elements of the power spectrum.") - - call param_register(params, 'covariance_sigma0', '0.0', this%covariance_sigma0, help_string="sigma_0 parameter in polynomial covariance function") - call param_register(params, 'normalise', 'T', this%normalise, help_string="Normalise descriptor so magnitude is 1. In this case the kernel of two equivalent environments is 1.", altkey="normalize") - call param_register(params, 'basis_error_exponent', '10.0', basis_error_exponent, help_string="10^(-basis_error_exponent) is the max difference between the target and the expanded function") - - call param_register(params, 'n_Z', '1', this%n_Z, help_string="How many different types of central atoms to consider") - call param_register(params, 'n_species', '1', this%n_species, has_value_target=has_n_species, help_string="Number of species for the descriptor") - call param_register(params, 'species_Z', '', species_Z_str, has_value_target=has_species_Z, help_string="Atomic number of species") - call param_register(params, 'xml_version', '1426512068', xml_version, help_string="Version of GAP the XML potential file was created") - - call param_register(params, 'nu_R', '2', this%nu_R, help_string="radially sensitive correlation order") - call param_register(params, 'nu_S', '2', this%nu_S, help_string="species sensitive correlation order") - call param_register(params, 'Z_mix', 'F', this%Z_mix, help_string="mix Z channels together") - call param_register(params, 'R_mix', 'F', this%R_mix, help_string="mix radial channels together") - call param_register(params, 'sym_mix', 'F', this%sym_mix, help_string="symmetric mixing") - call param_register(params, 'coupling', 'T', this%coupling, help_string="Full tensor product(=T) or Elementwise product(=F) between density channels") - call param_register(params, 'K', '0', this%K, help_string="Number of mixing channels to create") - call param_register(params, 'mix_shift', '0', this%mix_shift, help_string="shift for random number seed used to generate mixing weights") - call param_register(params, 'Z_map', '', this%Z_map_str, help_string="string defining the Zmap") - call param_register(params, 'radial_basis', '', this%radial_basis, help_string="Radial basis functions to use. Options are EQUISPACED_GAUSS, POLY and GTO (default for xml_version > 1987654320") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_initialise args_str')) then - RAISE_ERROR("soap_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - ! backwards compatibility: the default used to be different before this version number - if( xml_version < 1426512068 ) this%central_reference_all_species = .true. - - !backwards compatibility: only EQUISPACED_GAUSS allowed for old versions. default is GTO for new versions. - if (this%radial_basis == "") then - this%radial_basis = "EQUISPACED_GAUSS" - endif - - - allocate(this%species_Z(0:this%n_species)) - allocate(this%Z(this%n_Z)) - this%species_Z(0)=0 - - if( has_species_Z .and. .not. has_n_species ) then - RAISE_ERROR("soap_initialise: is species_Z is present, n_species must be present, too.",error) - endif - - call initialise(params) - - if( this%cutoff_dexp < 0 ) then - RAISE_ERROR("soap_initialise: cutoff_dexp may not be less than 0",error) - endif - - if( this%cutoff_scale <= 0.0_dp ) then - RAISE_ERROR("soap_initialise: cutoff_scale must be greater than 0",error) - endif - - if( this%cutoff_rate < 0.0_dp ) then - RAISE_ERROR("soap_initialise: cutoff_rate may not be less than 0",error) - endif - - if( has_n_species ) then - if(this%n_species == 1) then - call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") - else - call param_register(params, 'species_Z', '//MANDATORY//', this%species_Z(1:this%n_species), help_string="Atomic number of species") - endif - else - call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") - endif - - if( .not. has_central_reference_all_species .and. this%n_species == 1 ) this%central_reference_all_species = .true. - - if( this%n_Z == 1 ) then - call param_register(params, 'Z', '0', this%Z(1), help_string="Atomic number of central atom, 0 is the wild-card") - else - call param_register(params, 'Z', '//MANDATORY//', this%Z, help_string="Atomic numbers to be considered for central atom, must be a list") - endif - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_initialise args_str')) then - RAISE_ERROR("soap_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - - this%alpha = 0.5_dp / this%atom_sigma**2 - alpha_basis = this%alpha - cutoff_basis = this%cutoff + this%atom_sigma * sqrt(2.0_dp * basis_error_exponent * log(10.0_dp)) - spacing_basis = cutoff_basis / this%n_max - - if (this%radial_basis == "EQUISPACED_GAUSS") then - allocate(this%r_basis(this%n_max), this%transform_basis(this%n_max,this%n_max), & - covariance_basis(this%n_max,this%n_max, 1), overlap_basis(this%n_max,this%n_max, 1), this%cholesky_overlap_basis(this%n_max,this%n_max, 1)) - - this%r_basis(1) = 0.0_dp - do i = 2, this%n_max - this%r_basis(i) = this%r_basis(i-1) + spacing_basis - enddo - - do i = 1, this%n_max - do j = 1, this%n_max - covariance_basis(j,i, 1) = exp(-alpha_basis * (this%r_basis(i) - this%r_basis(j))**2) - overlap_basis(j,i,1) = ( exp( -alpha_basis*(this%r_basis(i)**2+this%r_basis(j)**2) ) * & - sqrt(2.0_dp) * alpha_basis**1.5_dp * (this%r_basis(i) + this%r_basis(j)) + & - alpha_basis*exp(-0.5_dp * alpha_basis * (this%r_basis(i) - this%r_basis(j))**2)*sqrt(PI)*(1.0_dp + alpha_basis*(this%r_basis(i) + this%r_basis(j))**2 ) * & - ( 1.0_dp + erf( sqrt(alpha_basis/2.0_dp) * (this%r_basis(i) + this%r_basis(j)) ) ) ) - enddo - enddo - - !overlap_basis = overlap_basis * sqrt(pi / ( 8.0_dp * alpha_basis ) ) - overlap_basis = overlap_basis / sqrt(128.0_dp * alpha_basis**5) - - call initialise(LA_covariance_basis, covariance_basis(:, :, 1)) - call initialise(LA_overlap_basis,overlap_basis(:, :, 1)) - call LA_Matrix_Factorise(LA_overlap_basis, this%cholesky_overlap_basis(:, :, 1)) - do i = 1, this%n_max - do j = 1, i-1 !i + 1, this%n_max - this%cholesky_overlap_basis(j,i,1) = 0.0_dp ! lower triangular - enddo - enddo - - call Matrix_Solve(LA_covariance_basis,this%cholesky_overlap_basis(:, :, 1),this%transform_basis) - - call finalise(LA_covariance_basis) - call finalise(LA_overlap_basis) - - if(allocated(covariance_basis)) deallocate(covariance_basis) - if(allocated(overlap_basis)) deallocate(overlap_basis) - - else - ! fine radial grid to fit radial coeficients - n_radial_grid = 3 * this%n_max - allocate(this%r_basis(n_radial_grid)) - spacing_basis = cutoff_basis / n_radial_grid - this%r_basis(1) = 0.0_dp - do i = 2, n_radial_grid - this%r_basis(i) = this%r_basis(i-1) + spacing_basis - enddo - - - ! allocations - allocate(covariance_basis(n_radial_grid, this%n_max, 0:this%l_max)) - allocate(overlap_basis(this%n_max,this%n_max, 0:this%l_max)) - allocate(this%cholesky_overlap_basis(this%n_max,this%n_max, 0:this%l_max)) - allocate(LA_BL_ti(0:this%l_max)) - allocate(Q(n_radial_grid, this%n_max), R(this%n_max, this%n_max)) - - if (this%radial_basis == "POLY") then - l_ub = 0 - ! form the overlap matrix and do cholesky decomposition - do i = 1, this%n_max - N_alpha = ((cutoff_basis**(2*i+7))/((i+3)*(2*i+5)*(2*i+7)))**0.5_dp - do j = 1, this%n_max - N_beta = ((cutoff_basis**(2*j+7))/((j+3)*(2*j+5)*(2*j+7)))**0.5_dp - S_alpha_beta = (2*cutoff_basis**(i+j+7))/((5+i+j)*(6+i+j)*(7+i+j)) - overlap_basis(j,i, 0) = S_alpha_beta/(N_alpha*N_beta) - enddo - enddo - - ! form the "covariance matrix" - do i = 1, this%n_max - N_alpha = ((cutoff_basis**(2*i+7))/((i+3)*(2*i+5)*(2*i+7)))**0.5_dp - do j = 1, n_radial_grid - covariance_basis(j, i, 0) = ((cutoff_basis-this%r_basis(j))**(i+2))/N_alpha - enddo - enddo - - elseif (this%radial_basis == "GTO") then - l_ub = this%l_max - allocate(alpha_ln(0:this%l_max+1, this%n_max)) - - spacing_basis = cutoff_basis/this%n_max - do l = 0, this%l_max - do n = 1, this%n_max - Rg = spacing_basis * n - alpha_ln(l, n) = -Rg**(-2) * (log(0.001_dp) - l*log(Rg)) - enddo - enddo - - !form the overlap matrices - do l = 0, this%l_max - do i = 1, this%n_max - do j = 1, this%n_max - alpha_gto = alpha_ln(l, i) + alpha_ln(l, j) - u = alpha_gto*cutoff_basis**2 - t = l + 1.5_dp - overlap_basis(i, j, l) = 0.5*cutoff_basis**(2*t)*u**(-t)* ( gamma(t) - gamma_incomplete_upper(t, u) ) - enddo - enddo - enddo - - !form the covariance matrices - do l = 0, this%l_max - do i = 1, this%n_max - do j = 1, n_radial_grid - covariance_basis(j, i, l) = this%r_basis(j)**l * exp(-alpha_ln(l, i)*this%r_basis(j)**2) - enddo - enddo - enddo - - else - RAISE_ERROR("soap_initialise: radial_basis not recognised: EQUISPACED_GAUSS, POLY or GTO" ,error) - endif - - !allocate(this%BL_ti(0:this%l_max, n_radial_grid, this%n_max)) - ! extract factor and tau as these are only bits needed for QR_solve - allocate(this%QR_factor( size(this%r_basis), this%n_max, 0:this%l_max)) - allocate(this%QR_tau(this%n_max, 0:this%l_max)) - - ! per l - do l = 0, l_ub - ! cholesky factorisation - call initialise(LA_covariance_basis, covariance_basis(:, :, l)) - call initialise(LA_overlap_basis,overlap_basis(:, :, l)) - call LA_Matrix_Factorise(LA_overlap_basis, this%cholesky_overlap_basis(:, :, l)) - do i = 1, this%n_max - do j = 1, i-1 !i + 1, this%n_max - this%cholesky_overlap_basis(j,i, l) = 0.0_dp ! lower triangular - enddo - enddo - - !find inverse of L^T, NOTE: reusing overlap basis in a confusing way here - overlap_basis(:, :, l) = transpose(this%cholesky_overlap_basis(:, :, l)) - call dtrtri("U", "N", this%n_max, overlap_basis(:, :, l), this%n_max, i) - ! form B(L^T)^-1 and do QR factorisation in prep for solving equations. - !this%BL_ti(l, :, :) = matmul(covariance_basis(l, :, :), overlap_basis(l, :, :)) - - call initialise(LA_BL_ti(l), matmul(covariance_basis(:, :, l), overlap_basis(:, :, l))) - call LA_Matrix_QR_Factorise(LA_BL_ti(l), Q, R, error) - - this%QR_factor(:, :, l) = LA_BL_ti(l)%factor - this%QR_tau(:, l) = LA_BL_ti(l)%tau - - call finalise(LA_covariance_basis) - call finalise(LA_overlap_basis) - enddo - - if (l_ub == 0 .and. this%l_max > 0) then - do l = 1, this%l_max - this%QR_factor(:, :, l) = this%QR_factor(:, :, 0) - this%QR_tau(:, l) = this%QR_tau(:, 0) - enddo - endif - - - if (allocated(covariance_basis)) deallocate(covariance_basis) - if (allocated(overlap_basis)) deallocate(overlap_basis) - if (allocated(Q)) deallocate(Q) - if (allocated(R)) deallocate(R) - - if (allocated(LA_BL_ti)) then - do l = 0, this%l_max - call finalise(LA_BL_ti(l)) - enddo - deallocate(LA_BL_ti) - endif - endif - - this%initialised = .true. - - endsubroutine soap_initialise - - subroutine soap_finalise(this,error) - type(soap), intent(inout) :: this - integer, optional, intent(out) :: error - integer :: l - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff_dexp = 0 - this%cutoff_scale = 1.0_dp - this%cutoff_rate = 1.0_dp - this%cutoff = 0.0_dp - this%cutoff_transition_width = 0.0_dp - this%l_max = 0 - this%alpha = 0.0_dp - this%central_weight = 0.0_dp - this%central_reference_all_species = .false. - this%global = .false. - this%diagonal_radial = .false. - this%covariance_sigma0 = 0.0_dp - this%normalise = .true. - - this%n_max = 0 - this%n_Z = 0 - this%n_species = 0 - this%nu_R = 2 - this%nu_S = 2 - - this%Z_mix = .false. - this%R_mix = .false. - this%sym_mix = .false. - this%coupling = .true. - this%K = 0 - this%mix_shift = 0 - - if(allocated(this%r_basis)) deallocate(this%r_basis) - if(allocated(this%transform_basis)) deallocate(this%transform_basis) - if(allocated(this%cholesky_overlap_basis)) deallocate(this%cholesky_overlap_basis) - if(allocated(this%species_Z)) deallocate(this%species_Z) - if(allocated(this%Z)) deallocate(this%Z) - - if (allocated(this%QR_factor)) deallocate(this%QR_factor) - if (allocated(this%QR_tau)) deallocate(this%QR_tau) - - this%initialised = .false. - - endsubroutine soap_finalise - - - subroutine rdf_initialise(this,args_str,error) - type(rdf), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - integer :: i - real(dp) :: r_min, r_max - logical :: has_r_max, has_w_gauss - - INIT_ERROR(error) - - call finalise(this) - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for rdf-type descriptors") - call param_register(params, 'transition_width', '0.20', this%transition_width, help_string="Width of transition region from 1 to 0") - call param_register(params, 'Z', '0', this%Z, help_string="Atomic number of central atom") - call param_register(params, 'r_min', '0.0', r_min, help_string="Atomic number of central atom") - call param_register(params, 'r_max', '0.0', r_max, has_value_target = has_r_max, help_string="Atomic number of central atom") - call param_register(params, 'n_gauss', '10', this%n_gauss, help_string="Atomic number of central atom") - call param_register(params, 'w_gauss', '0.0', this%w_gauss, has_value_target = has_w_gauss, help_string="Atomic number of central atom") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='rdf_initialise args_str')) then - RAISE_ERROR("rdf_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(this%r_gauss(this%n_gauss)) - if(.not. has_w_gauss) this%w_gauss = this%cutoff / this%n_gauss * 2.0_dp - if(.not. has_r_max) r_max = this%cutoff - this%w_gauss / 2.0_dp - this%r_gauss = real( (/(i,i=1,this%n_gauss)/), kind=dp ) / real(this%n_gauss,kind=dp) * (r_max - r_min) + r_min - - this%initialised = .true. - - endsubroutine rdf_initialise - - subroutine rdf_finalise(this,error) - type(rdf), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%transition_width = 0.0_dp - this%Z = 0 - this%n_gauss = 0 - if( allocated(this%r_gauss) ) deallocate(this%r_gauss) - - this%initialised = .false. - - endsubroutine rdf_finalise - - subroutine as_distance_2b_initialise(this,args_str,error) - type(as_distance_2b), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Lower cutoff for as_distance_2b-type descriptors") - call param_register(params, 'max_cutoff', PARAM_MANDATORY, this%max_cutoff, help_string="Higher cutoff for as_distance_2b-type descriptors") - call param_register(params, 'as_cutoff', PARAM_MANDATORY, this%as_cutoff, help_string="Cutoff of asymmetricity") - call param_register(params, 'overlap_alpha', '0.50', this%as_cutoff, help_string="Cutoff of asymmetricity") - call param_register(params, 'min_transition_width', '0.50', this%min_transition_width, help_string="Transition width of lower cutoff for as_distance_2b-type descriptors") - call param_register(params, 'max_transition_width', '0.50', this%max_transition_width, help_string="Transition width of higher cutoff for as_distance_2b-type descriptors") - call param_register(params, 'as_transition_width', '0.10', this%as_transition_width, help_string="Transition width of asymmetricity cutoff for as_distance_2b-type descriptors") - call param_register(params, 'coordination_cutoff', PARAM_MANDATORY, this%coordination_cutoff, help_string="Cutoff for coordination function in as_distance_2b-type descriptors") - call param_register(params, 'coordination_transition_width', '0.50', this%coordination_transition_width, help_string="Transition width for as_distance_2b-type descriptors") - call param_register(params, 'Z1', '0', this%Z1, help_string="Atom type #1 in bond") - call param_register(params, 'Z2', '0', this%Z2, help_string="Atom type #2 in bond") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='as_distance_2b_initialise args_str')) then - RAISE_ERROR("as_distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine as_distance_2b_initialise - - subroutine as_distance_2b_finalise(this,error) - type(as_distance_2b), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%min_cutoff = 0.0_dp - this%max_cutoff = 0.0_dp - this%as_cutoff = 0.0_dp - this%overlap_alpha = 0.0_dp - this%min_transition_width = 0.0_dp - this%max_transition_width = 0.0_dp - this%as_transition_width = 0.0_dp - this%coordination_cutoff = 0.0_dp - this%coordination_transition_width = 0.0_dp - this%Z1 = 0 - this%Z2 = 0 - - this%initialised = .false. - - endsubroutine as_distance_2b_finalise - - - subroutine alex_initialise(this,args_str,error) - type(alex), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for alex-type descriptors") - call param_register(params, 'Z', '0', this%Z, help_string="Atomic number of central atom") - call param_register(params, 'power_min', '5', this%power_min, help_string="Minimum power of radial basis for the descriptor") - call param_register(params, 'power_max', '10', this%power_max, help_string="Maximum power of the radial basis for the descriptor") - call param_register(params, 'n_species', '1', this%n_species, help_string="Number of species for the descriptor") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='alex_initialise args_str')) then - RAISE_ERROR("alex_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - allocate(this%species_Z(this%n_species)) - - call initialise(params) - if( this%n_species == 1 ) then - call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") - else - call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species") - endif - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='alex_initialise args_str')) then - RAISE_ERROR("alex_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - this%initialised = .true. - - endsubroutine alex_initialise - - subroutine alex_finalise(this,error) - type(alex), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - - if(allocated(this%species_Z)) deallocate(this%species_Z) - - this%initialised = .false. - - endsubroutine alex_finalise - - subroutine distance_Nb_initialise(this,args_str,error) - type(distance_Nb), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(len=STRING_LENGTH) :: default_Z = "" - integer :: i, j, k, i_p - integer :: nEdges, nConnectivities, nMonomerConnectivities - integer, dimension(:), allocatable :: n_permutations, connectivityList - integer, dimension(:,:), allocatable :: atom_permutations, distance_matrix_index, edges - integer :: xml_version - logical :: has_compact_clusters - - logical, dimension(:,:,:), allocatable :: allConnectivities - - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', PARAM_MANDATORY, this%cutoff, help_string="Cutoff for distance_Nb-type descriptors") - call param_register(params, 'cutoff_transition_width', '0.5', this%cutoff_transition_width, help_string="Transition width of cutoff for distance_Nb-type descriptors") - call param_register(params, 'order', PARAM_MANDATORY, this%order, help_string="Many-body order, in terms of number of neighbours") - call param_register(params, 'compact_clusters', "T", this%compact_clusters, help_string="If true, generate clusters where the atoms have at least one connection to the central atom. If false, only clusters where all atoms are connected are generated.", has_value_target=has_compact_clusters) - call param_register(params, 'xml_version', '1596837814', xml_version, help_string="Version of GAP the XML potential file was created") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_Nb_initialise args_str')) then - RAISE_ERROR("distance_Nb_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if( this%order < 1 ) then - RAISE_ERROR("distance_Nb_initialise: order must be greater than 0",error) - endif - - if (.not. has_compact_clusters) then - ! no compact_clusters specified explicitly, default depends on version - if (xml_version < 1596837814) then - ! before version where default was changed from false to true - this%compact_clusters = .false. - else - ! after version where default was changed from false to true - this%compact_clusters = .true. - endif - endif - - - allocate(this%Z(this%order)) - default_Z = "" - do i = 1, this%order - default_Z = trim(default_Z) // " 0" - enddo - - call initialise(params) - if( this%order == 1 ) then - call param_register(params, 'Z', trim(default_Z), this%Z(1), help_string="Atomic type of neighbours") - else - call param_register(params, 'Z', trim(default_Z), this%Z, help_string="Atomic type of neighbours") - endif - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_Nb_initialise args_str')) then - RAISE_ERROR("distance_Nb_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - call sort_array(this%Z) - call distance_Nb_n_permutations(this%Z, n_permutations) - this%n_permutations = product(factorial_int(n_permutations)) - - allocate(atom_permutations(this%order,this%n_permutations)) - call distance_Nb_permutations(n_permutations,atom_permutations) - - allocate(distance_matrix_index(this%order,this%order)) - allocate(this%permutations( max(1,(this%order - 1) * this%order / 2), this%n_permutations)) - - if( this%order == 1 ) then - this%permutations = 1 - else - k = 0 - do i = 1, this%order - do j = i+1, this%order - k = k + 1 - distance_matrix_index(j,i) = k - distance_matrix_index(i,j) = k - enddo - enddo - - do i_p = 1, this%n_permutations - k = 0 - do i = 1, this%order - do j = i+1, this%order - k = k + 1 - this%permutations(k,i_p) = distance_matrix_index(atom_permutations(j,i_p), atom_permutations(i,i_p)) - enddo - enddo - enddo - endif - - nEdges = this%order * (this%order - 1) / 2 - allocate( edges(2,nEdges)) - - k = 0 - do i = 1, this%order - do j = i+1, this%order - k = k + 1 - edges(:,k) = (/i,j/) - enddo - enddo - - nConnectivities = 2**nEdges - - allocate(allConnectivities(this%order,this%order,nConnectivities)) - allocate(connectivityList(nEdges)) - - nMonomerConnectivities = 0 - do i = 1, nConnectivities - call integerDigits(i-1,2,connectivityList) - allConnectivities(:,:,i) = .false. - do j = 1, nEdges - allConnectivities(edges(1,j),edges(2,j),i) = ( connectivityList(j) == 1 ) - allConnectivities(edges(2,j),edges(1,j),i) = ( connectivityList(j) == 1 ) - enddo - - if( graphIsConnected( allConnectivities(:,:,i) ) ) nMonomerConnectivities = nMonomerConnectivities + 1 - enddo - - allocate(this%monomerConnectivities(this%order,this%order,nMonomerConnectivities)) - j = 0 - do i = 1, nConnectivities - if( graphIsConnected( allConnectivities(:,:,i) ) ) then - j = j + 1 - this%monomerConnectivities(:,:,j) = allConnectivities(:,:,i) - endif - enddo - - if(allocated(n_permutations)) deallocate(n_permutations) - if(allocated(atom_permutations)) deallocate(atom_permutations) - if(allocated(distance_matrix_index)) deallocate(distance_matrix_index) - if(allocated(edges)) deallocate(edges) - if(allocated(allConnectivities)) deallocate(allConnectivities) - if(allocated(connectivityList)) deallocate(connectivityList) - this%initialised = .true. - - endsubroutine distance_Nb_initialise - - subroutine distance_Nb_finalise(this,error) - type(distance_Nb), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%cutoff = 0.0_dp - this%cutoff_transition_width = 0.5_dp - this%order = 0 - this%n_permutations = 0 - this%compact_clusters = .false. - if(allocated(this%Z)) deallocate(this%Z) - if(allocated(this%permutations)) deallocate(this%permutations) - if(allocated(this%monomerConnectivities)) deallocate(this%monomerConnectivities) - - this%initialised = .false. - - endsubroutine distance_Nb_finalise - - - subroutine distance_Nb_n_permutations(Z,n_permutations,error) - integer, dimension(:), intent(in) :: Z - integer, dimension(:), allocatable :: n_permutations - integer, optional, intent(out) :: error - - integer :: i - integer, dimension(:), allocatable :: uniq_Z - - INIT_ERROR(error) - - call uniq(Z,uniq_Z) - call reallocate(n_permutations,size(uniq_Z)) - - do i = 1, size(uniq_Z) - n_permutations(i) = count( uniq_Z(i) == Z ) - enddo - - if(allocated(uniq_Z)) deallocate(uniq_Z) - - endsubroutine distance_Nb_n_permutations - - recursive subroutine distance_Nb_permutations(n_permutations,permutations) - integer, dimension(:), intent(in) :: n_permutations - integer, dimension(sum(n_permutations),product(factorial_int(n_permutations))), intent(inout) :: permutations - - integer, dimension(:), allocatable, save :: current_permutation - integer :: i, j, n_lo, n_hi - integer, save :: recursion_level = 0, i_current_permutation = 0 - - recursion_level = recursion_level + 1 - - - if( recursion_level == 1 ) then - i_current_permutation = 0 - allocate(current_permutation(sum(n_permutations))) - current_permutation = 0 - endif - - - do i = 1, size(n_permutations) - if( i == 1 ) then - n_lo = 1 - else - n_lo = sum(n_permutations(1:i-1)) + 1 - endif - n_hi = sum(n_permutations(1:i)) - do j = n_lo, n_hi - if( i_current_permutation < size(permutations,2) ) then - if( .not. any(j==current_permutation) .and. recursion_level >= n_lo .and. recursion_level <= n_hi ) then - - current_permutation(recursion_level) = j - if( recursion_level == sum(n_permutations) ) then - i_current_permutation = i_current_permutation + 1 - permutations(:,i_current_permutation) = current_permutation - else - call distance_Nb_permutations(n_permutations,permutations) - endif - endif - endif - enddo - enddo - - current_permutation(recursion_level) = 0 - - recursion_level = recursion_level - 1 - - if( recursion_level == 0 ) then - deallocate(current_permutation) - endif - - endsubroutine distance_Nb_permutations - - subroutine soap_turbo_initialise(this,args_str,error) - use soap_turbo_compress_module - - type(soap_turbo), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - integer :: l, k, i, j, m, n, n_nonzero - real(dp) :: fact, fact1, fact2, ppi, atom_sigma_radial_normalised, cutoff_hard,& - s2, I_n, N_n, N_np1, N_np2, I_np1, I_np2, C2 - character(len=64) :: compress_string - - type(LA_Matrix) :: LA_overlap - real(dp), dimension(:), allocatable :: s - real(dp), dimension(:,:), allocatable :: sqrt_overlap, u, v - real(dp), parameter :: sqrt_two = sqrt(2.0_dp) - -! Variables for equivalences with regular SOAP - logical :: is_n_max_set, is_cutoff_set, is_cutoff_transition_width_set, & - is_atom_sigma_r_set, is_atom_sigma_t_set, is_atom_sigma_r_scaling_set, & - is_atom_sigma_t_scaling_set, is_central_weight_set, is_amplitude_scaling_set, & - is_atom_sigma_set, set_sigma_t_to_r, is_atom_sigma_scaling_set, set_sigma_t_to_r_scaling - character(len=STRING_LENGTH) :: var_set - - is_n_max_set = .false. - is_cutoff_set = .false. - is_cutoff_transition_width_set = .false. - is_atom_sigma_set = .false. - set_sigma_t_to_r = .false. - is_atom_sigma_scaling_set = .false. - set_sigma_t_to_r_scaling = .false. - is_atom_sigma_r_set = .false. - is_atom_sigma_t_set = .false. - is_atom_sigma_r_scaling_set = .false. - is_atom_sigma_t_scaling_set = .false. - is_central_weight_set = .false. - is_amplitude_scaling_set = .false. - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - -! Look for those parameters defined as in regular SOAP - if( index(args_str,"cutoff=") /= 0 .and. index(args_str,"rcut_hard=") == 0 )then - is_cutoff_set = .true. - call param_register(params, 'cutoff', PARAM_MANDATORY, this%rcut_hard, help_string="TODO") - else - call param_register(params, 'rcut_hard', PARAM_MANDATORY, this%rcut_hard, help_string="Hard cutoff") - end if - if( index(args_str,"rcut_soft=") == 0 )then - is_cutoff_transition_width_set = .true. -! We store the transition width in rcut_soft, then fix it later - call param_register(params, 'cutoff_transition_width', "0.5", this%rcut_soft, help_string="TODO") - else - call param_register(params, 'rcut_soft', PARAM_MANDATORY, this%rcut_soft, help_string="Soft cutoff") - end if - -! Look for the rest of scalar parameters - call param_register(params, 'l_max', PARAM_MANDATORY, this%l_max, help_string="Angular basis resolution") - call param_register(params, 'n_species', '1', this%n_species, help_string="Number of species for the descriptor") - -! These parameters are not mandatory; these are sensible defaults - call param_register(params, 'nf', "4.0", this%nf, help_string="TODO") - call param_register(params, 'radial_enhancement', "0", this%radial_enhancement, help_string="TODO") - call param_register(params, 'basis', "poly3", this%basis, help_string="poly3 or poly3gauss") - call param_register(params, 'scaling_mode', "polynomial", this%scaling_mode, help_string="TODO") - call param_register(params, 'compress_file', "None", this%compress_file, help_string="TODO") - call param_register(params, 'compress_mode', "None", this%compress_mode, help_string="TODO") - call param_register(params, 'central_index', "1", this%central_index, help_string="Index of central atom species_Z in the >species< array") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_turbo_initialise args_str')) then - RAISE_ERROR("soap_turbo_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - -! Fix the soft cutoff if needed - if( is_cutoff_transition_width_set )then - this%rcut_soft = this%rcut_hard - this%rcut_soft - end if - -! All of these hyperparameters are species-dependent and thus given as arrays -! We try to infer intended use from the regular SOAP equivalent parameters, e.g., we -! infer alpha_max(1:n_species) = n_max, UNLESS the array definitions are provided -! explicitly, in which case explicit definitions ALWAYS override implicit definitions, -! e.g., if both n_max and alpha_max are defined, the alpha_max definition will -! override the n_max definition - - allocate(this%atom_sigma_r(this%n_species)) - allocate(this%atom_sigma_r_scaling(this%n_species)) - allocate(this%atom_sigma_t(this%n_species)) - allocate(this%atom_sigma_t_scaling(this%n_species)) - allocate(this%amplitude_scaling(this%n_species)) - allocate(this%central_weight(this%n_species)) - allocate(this%alpha_max(this%n_species)) - allocate(this%species_Z(this%n_species)) - -! central_weight is special because regular SOAP and soap_turbo use the same keyword - call initialise(params) -! If it's set as a vector - if( index(args_str,"central_weight={") /= 0 )then - if( this%n_species == 1 )then - is_central_weight_set = .true. - call param_register(params, 'central_weight', "1.0", this%central_weight(1), & - help_string="Weight of central atom in environment") - end if -! If it's set as a scalar or not set - else - is_central_weight_set = .true. - call param_register(params, 'central_weight', "1.0", this%central_weight(1), & - help_string="Weight of central atom in environment") - end if - call finalise(params) - if( is_central_weight_set )then - this%central_weight = this%central_weight(1) - end if - -! Now we set the soap_turbo hypers with the explicit array definitions OR use the implicit definitions -! to set them - call initialise(params) -! alpha_max - if( index(args_str,"n_max=") /= 0 .and. index(args_str,"alpha_max=") == 0 )then - is_n_max_set = .true. - call param_register(params, 'n_max', PARAM_MANDATORY, this%alpha_max(1), help_string="TODO") - else - if( this%n_species == 1 )then - call param_register(params, 'alpha_max', PARAM_MANDATORY, this%alpha_max(1), & - help_string="Radial basis resolution for each species") - else - call param_register(params, 'alpha_max', '//MANDATORY//', this%alpha_max, & - help_string="Radial basis resultion for each species") - end if - end if -! atom_sigma_r - if( index(args_str,"atom_sigma_r={") /= 0 )then - if( this%n_species == 1 )then - call param_register(params, 'atom_sigma_r', PARAM_MANDATORY, this%atom_sigma_r(1), & - help_string="Width of atomic Gaussians for soap-type descriptors in the radial direction") - else - call param_register(params, 'atom_sigma_r', '//MANDATORY//', this%atom_sigma_r, & - help_string="Width of atomic Gaussians for soap-type descriptors in the radial direction") - end if - else if( index(args_str,"atom_sigma_r=") /= 0 )then - is_atom_sigma_r_set = .true. - call param_register(params, 'atom_sigma_r', PARAM_MANDATORY, this%atom_sigma_r(1), & - help_string="Width of atomic Gaussians for soap-type descriptors in the radial direction") - else - is_atom_sigma_r_set = .true. - is_atom_sigma_set = .true. - call param_register(params, 'atom_sigma', PARAM_MANDATORY, this%atom_sigma_r(1), & - help_string="Width of atomic Gaussians for soap-type descriptors") - end if -! atom_sigma_t - if( index(args_str,"atom_sigma_t={") /= 0 )then - if( this%n_species == 1 )then - call param_register(params, 'atom_sigma_t', PARAM_MANDATORY, this%atom_sigma_t(1), & - help_string="Width of atomic Gaussians for soap-type descriptors in the angular direction") - else - call param_register(params, 'atom_sigma_t', '//MANDATORY//', this%atom_sigma_t, & - help_string="Width of atomic Gaussians for soap-type descriptors in the angular direction") - end if - else if( index(args_str,"atom_sigma_t=") /= 0 )then - is_atom_sigma_t_set = .true. - call param_register(params, 'atom_sigma_t', PARAM_MANDATORY, this%atom_sigma_t(1), & - help_string="Width of atomic Gaussians for soap-type descriptors in the angular direction") - else - is_atom_sigma_t_set = .true. - if( is_atom_sigma_set )then - set_sigma_t_to_r = .true. - else - call param_register(params, 'atom_sigma', PARAM_MANDATORY, this%atom_sigma_t(1), & - help_string="Width of atomic Gaussians for soap-type descriptors") - end if - end if -! atom_sigma_r_scaling - if( index(args_str,"atom_sigma_r_scaling={") /= 0 )then - if( this%n_species == 1 )then - call param_register(params, 'atom_sigma_r_scaling', PARAM_MANDATORY, this%atom_sigma_r_scaling(1), & - help_string="Scaling rate of radial sigma: scaled as a function of neighbour distance") - else - call param_register(params, 'atom_sigma_r_scaling', '//MANDATORY//', this%atom_sigma_r_scaling, & - help_string="Scaling rate of radial sigma: scaled as a function of neighbour distance") - end if - else if( index(args_str,"atom_sigma_r_scaling=") /= 0 )then - is_atom_sigma_r_scaling_set = .true. - call param_register(params, 'atom_sigma_r_scaling', PARAM_MANDATORY, this%atom_sigma_r_scaling(1), & - help_string="Scaling rate of radial sigma: scaled as a function of neighbour distance") - else - is_atom_sigma_r_scaling_set = .true. - is_atom_sigma_scaling_set = .true. - call param_register(params, 'atom_sigma_scaling', "0.0", this%atom_sigma_r_scaling(1), & - help_string="Scaling rate of atom sigma: scaled as a function of neighbour distance") - end if -! atom_sigma_t_scaling - if( index(args_str,"atom_sigma_t_scaling={") /= 0 )then - if( this%n_species == 1 )then - call param_register(params, 'atom_sigma_t_scaling', PARAM_MANDATORY, this%atom_sigma_t_scaling(1), & - help_string="Scaling rate of angular sigma: scaled as a function of neighbour distance") - else - call param_register(params, 'atom_sigma_t_scaling', '//MANDATORY//', this%atom_sigma_t_scaling, & - help_string="Scaling rate of angular sigma: scaled as a function of neighbour distance") - end if - else if( index(args_str,"atom_sigma_t_scaling=") /= 0 )then - is_atom_sigma_t_scaling_set = .true. - call param_register(params, 'atom_sigma_t_scaling', PARAM_MANDATORY, this%atom_sigma_t_scaling(1), & - help_string="Scaling rate of angular sigma: scaled as a function of neighbour distance") - else - is_atom_sigma_t_scaling_set = .true. - if( is_atom_sigma_scaling_set )then - set_sigma_t_to_r_scaling = .true. - else - call param_register(params, 'atom_sigma_scaling', "0.0", this%atom_sigma_t_scaling(1), & - help_string="Scaling rate of atom sigma: scaled as a function of neighbour distance") - end if - end if -! amplitude_scaling - if( index(args_str,"amplitude_scaling={") /= 0 )then - if( this%n_species == 1 )then - call param_register(params, 'amplitude_scaling', PARAM_MANDATORY, this%amplitude_scaling(1), & - help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") - else - call param_register(params, 'amplitude_scaling', '//MANDATORY//', this%amplitude_scaling, & - help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") - end if - else if( index(args_str,"amplitude_scaling=") /= 0 )then - is_amplitude_scaling_set = .true. - call param_register(params, 'amplitude_scaling', PARAM_MANDATORY, this%amplitude_scaling(1), & - help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") - else - is_amplitude_scaling_set = .true. - call param_register(params, 'amplitude_scaling', "1.0", this%amplitude_scaling(1), & - help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") - end if -! species_Z - if( this%n_species == 1 )then - call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z(1), & - help_string="Atomic number of species, including the central atom") - else - call param_register(params, 'species_Z', '//MANDATORY//', this%species_Z, & - help_string="Atomic number of species, including the central atom") - end if -! central_weight - if( .not. is_central_weight_set )then - call param_register(params, 'central_weight', '//MANDATORY//', this%central_weight, & - help_string="Weight of central atom in environment") - end if - - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_turbo_initialise args_str')) then - RAISE_ERROR("soap_turbo_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if( is_n_max_set )then - this%alpha_max = this%alpha_max(1) - end if - if( is_atom_sigma_r_set )then - this%atom_sigma_r = this%atom_sigma_r(1) - end if - if( is_atom_sigma_t_set )then - this%atom_sigma_t = this%atom_sigma_t(1) - end if - if( is_atom_sigma_r_scaling_set )then - this%atom_sigma_r_scaling = this%atom_sigma_r_scaling(1) - end if - if( is_atom_sigma_t_scaling_set )then - this%atom_sigma_t_scaling = this%atom_sigma_t_scaling(1) - end if - if( is_amplitude_scaling_set )then - this%amplitude_scaling = this%amplitude_scaling(1) - end if - if( set_sigma_t_to_r )then - this%atom_sigma_t = this%atom_sigma_r - end if - if( set_sigma_t_to_r_scaling )then - this%atom_sigma_t_scaling = this%atom_sigma_r_scaling - end if - - -! Here we read in the compression information from a file (compress_file) or rely on a keyword provided -! by the user (compress_mode) which leads to a predefined recipe to compress the soap_turbo descriptor -! The file always takes precedence over the keyword. - if( this%compress_file /= "None" )then - this%compress = .true. - open(unit=10, file=this%compress_file, status="old") - read(10, *) (i, j=1,this%n_species), i, n - read(10, '(A)') compress_string - if( compress_string == "P_transformation" )then - n_nonzero = -1 - do while( compress_string /= "end_transformation" ) - read(10, '(A)') compress_string - n_nonzero = n_nonzero + 1 - end do - this%compress_P_nonzero = n_nonzero - allocate( this%compress_P_el(1:n_nonzero) ) - allocate( this%compress_P_i(1:n_nonzero) ) - allocate( this%compress_P_j(1:n_nonzero) ) - do i = 1, n_nonzero+1 - backspace(10) - end do - do i = 1, n_nonzero - read(10,*) this%compress_P_i(i), this%compress_P_j(i), this%compress_P_el(i) - end do - else -! Old way to handle compression for backcompatibility - backspace(10) - this%compress_P_nonzero = n - allocate( this%compress_P_el(1:n) ) - allocate( this%compress_P_i(1:n) ) - allocate( this%compress_P_j(1:n) ) - do i = 1, n - read(10, *) this%compress_P_j(i) - this%compress_P_i(i) = i - this%compress_P_el(i) = 1.0_dp - end do - end if - close(10) - else if( this%compress_mode /= "None" )then - this%compress = .true. - call get_compress_indices( this%compress_mode, this%alpha_max, this%l_max, n, this%compress_P_nonzero, & - this%compress_P_i, this%compress_P_j, this%compress_P_el, "get_dim" ) - allocate( this%compress_P_i(1:this%compress_P_nonzero) ) - allocate( this%compress_P_j(1:this%compress_P_nonzero) ) - allocate( this%compress_P_el(1:this%compress_P_nonzero) ) - call get_compress_indices( this%compress_mode, this%alpha_max, this%l_max, n, this%compress_P_nonzero, & - this%compress_P_i, this%compress_P_j, this%compress_P_el, "set_indices" ) - end if - - - this%initialised = .true. - - endsubroutine soap_turbo_initialise - - subroutine soap_turbo_finalise(this,error) - type(soap_turbo), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - this%rcut_hard = 0.0_dp - this%rcut_soft = 0.0_dp - this%nf = 0.0_dp - this%n_species = 0 - this%radial_enhancement = 0 - this%central_index = 0 - this%l_max = 0 - - if(allocated(this%alpha_max)) deallocate(this%alpha_max) - if(allocated(this%atom_sigma_r)) deallocate(this%atom_sigma_r) - if(allocated(this%atom_sigma_r_scaling)) deallocate(this%atom_sigma_r_scaling) - if(allocated(this%atom_sigma_t)) deallocate(this%atom_sigma_t) - if(allocated(this%atom_sigma_t_scaling)) deallocate(this%atom_sigma_t_scaling) - if(allocated(this%amplitude_scaling)) deallocate(this%amplitude_scaling) - if(allocated(this%central_weight)) deallocate(this%central_weight) - if(allocated(this%species_Z)) deallocate(this%species_Z) - - this%initialised = .false. - - endsubroutine soap_turbo_finalise - - subroutine soap_turbo_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(soap_turbo), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("soap_turbo_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%species_Z(this%central_index) ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%rcut_hard) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine soap_turbo_sizes - - subroutine descriptor_str_add_species(this,species,descriptor_str,error) - character(len=*), intent(in) :: this - integer, dimension(:), intent(in) :: species - character(len=STRING_LENGTH), dimension(:), allocatable, intent(out) :: descriptor_str - integer, optional, intent(out) :: error - - integer :: my_descriptor_type, i, j, k, l, n_species, order, n - integer, dimension(:,:), allocatable :: ZN - real(dp), dimension(:), allocatable :: w - type(Dictionary) :: params - - INIT_ERROR(error) - - if(allocated(descriptor_str)) deallocate(descriptor_str) - - my_descriptor_type = get_descriptor_type(this,error) - n_species = size(species) - - select case(my_descriptor_type) - case(DT_BISPECTRUM_SO4,DT_BISPECTRUM_SO3,DT_BEHLER,DT_COSNX,DT_POWER_SO3,DT_POWER_SO4) - allocate(w(n_species)) - allocate(descriptor_str(n_species)) - - if( n_species == 1 ) then - w = 1.0_dp - else - w = real( (/ (i, i=0, n_species-1) /), kind=dp ) / (n_species-1) * 0.5_dp + 0.5_dp - endif - - do i = 1, n_species - descriptor_str(i) = trim(this)//" n_species="//n_species//" Z="//species(i)//" species_Z={"//species//"} w={"//w//"}" - enddo - - deallocate(w) - case(DT_SOAP) - allocate(descriptor_str(n_species)) - do i = 1, n_species - descriptor_str(i) = trim(this)//" n_species="//n_species//" Z="//species(i)//" species_Z={"//species//"}" - enddo - case(DT_DISTANCE_2B,DT_CO_DISTANCE_2B,DT_AS_DISTANCE_2B) - allocate(descriptor_str(n_species * (n_species+1) / 2)) - - l = 0 - do i = 1, n_species - do j = i, n_species - l = l + 1 - descriptor_str(l) = trim(this)//" Z1="//species(i)//" Z2="//species(j) - enddo - enddo - - case(DT_COORDINATION,DT_RDF) - allocate(descriptor_str(n_species)) - do i = 1, n_species - descriptor_str(i) = trim(this)//" Z="//species(i) - enddo - case(DT_ANGLE_3B,DT_CO_ANGLE_3B) - allocate(descriptor_str(n_species * n_species * (n_species+1) / 2)) - l = 0 - do i = 1, n_species - do j = 1, n_species - do k = j, n_species - l = l + 1 - descriptor_str(l) = trim(this)//" Z="//species(i)//" Z1="//species(j)//" Z2="//species(k) - enddo - enddo - enddo - case(DT_GENERAL_MONOMER,DT_GENERAL_DIMER,DT_GENERAL_TRIMER,DT_WATER_TRIMER,DT_WATER_MONOMER,DT_WATER_DIMER,DT_A2_DIMER,DT_AB_DIMER,DT_TRIHIS,DT_BOND_REAL_SPACE,DT_ATOM_REAL_SPACE,DT_AN_MONOMER) - allocate(descriptor_str(1)) - descriptor_str(1) = trim(this) - case(DT_DISTANCE_NB) - call initialise(params) - call param_register(params, 'order', PARAM_MANDATORY, order, help_string="Many-body order, in terms of number of neighbours") - if (.not. param_read_line(params, this, ignore_unknown=.true.,task='descriptor_str_add_species this')) then - RAISE_ERROR("descriptor_str_add_species failed to parse descriptor string='"//trim(this)//"'", error) - endif - call finalise(params) - - n = 1 - do i = 1, order - n = n * ( n_species + i - 1 ) / i ! avoids double counting - enddo - - allocate(ZN(order,n),descriptor_str(n)) - - call descriptor_str_add_species_distance_Nb(ZN,species,order) - - do i = 1, n - descriptor_str(i) = trim(this)//" Z={"//ZN(:,i)//"}" - enddo - deallocate(ZN) - - case(DT_SOAP_EXPRESS) - RAISE_ERROR("descriptor_str_add_species: no recipe for "//my_descriptor_type//" yet.",error) - case(DT_SOAP_TURBO) -! RAISE_ERROR("descriptor_str_add_species: no recipe for "//my_descriptor_type//" yet.",error) - allocate(descriptor_str(n_species)) - do i = 1, n_species -! descriptor_str(i) = trim(this)//" n_species="//n_species//" Z="//species(i)//" species_Z={"//species//"}" - descriptor_str(i) = trim(this)//" n_species="//n_species//" species_Z={"//species//"} central_index="//i - enddo - case default - RAISE_ERROR("descriptor_str_add_species: unknown descriptor type "//my_descriptor_type,error) - endselect - - endsubroutine descriptor_str_add_species - - recursive subroutine descriptor_str_add_species_distance_Nb(ZN,species,order) - integer, dimension(:,:), intent(inout) :: ZN - integer, dimension(:), intent(in) :: species - integer, intent(in) :: order - - integer :: i_species, n_species - integer, save :: current_descriptor, current_order = 0 - integer, dimension(:), allocatable, save :: ZN_current - - n_species = size(species) - - if( current_order == 0 ) then ! first run, outermost order. - current_descriptor = 0 ! keeps track of descriptor - current_order = 1 ! keeps track of order - allocate(ZN_current(order)) ! builds/updates atomic numbers gradually for each descriptor - endif - - do i_species = 1, n_species - if( current_order > 1 ) then ! no special atom, all atoms equivalent - if( species(i_species) < ZN_current(current_order-1) ) cycle ! avoids double-counting of neighbours - endif - - ZN_current(current_order) = species(i_species) - if( current_order < order ) then ! calls recursively until we reach the last order - current_order = current_order + 1 - call descriptor_str_add_species_distance_Nb(ZN,species,order) - else ! when we reached the last order, fill the atomic numbers in the loop - current_descriptor = current_descriptor + 1 ! and add them to the output array - ZN(:,current_descriptor) = ZN_current - endif - enddo - - current_order = current_order - 1 ! when the loop finished, step one level down - - if( current_order == 0 ) deallocate(ZN_current) ! when we reach zero, we finished. - - endsubroutine descriptor_str_add_species_distance_Nb - - subroutine descriptor_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(descriptor), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(cutoff(this) > at%cutoff) then - RAISE_ERROR("descriptor_calc: descriptor cutoff ("//cutoff(this)//") larger than atoms cutoff("//at%cutoff//")",error) - endif - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - call calc(this%descriptor_bispectrum_SO4,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_BISPECTRUM_SO3) - call calc(this%descriptor_bispectrum_SO3,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error=error) - case(DT_BEHLER) - call calc(this%descriptor_behler,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error=error) - case(DT_DISTANCE_2b) - call calc(this%descriptor_distance_2b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_COORDINATION) - call calc(this%descriptor_coordination,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_ANGLE_3B) - call calc(this%descriptor_angle_3b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_CO_ANGLE_3B) - call calc(this%descriptor_co_angle_3b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_CO_DISTANCE_2b) - call calc(this%descriptor_co_distance_2b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_COSNX) - call calc(this%descriptor_cosnx,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_TRIHIS) - call calc(this%descriptor_trihis,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_WATER_MONOMER) - call calc(this%descriptor_water_monomer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_WATER_DIMER) - call calc(this%descriptor_water_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_A2_DIMER) - call calc(this%descriptor_A2_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_AB_DIMER) - call calc(this%descriptor_AB_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_ATOM_REAL_SPACE) - call calc(this%descriptor_atom_real_space,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_POWER_SO3) - call calc(this%descriptor_power_so3,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_POWER_SO4) - call calc(this%descriptor_power_so4,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_SOAP) - call calc(this%descriptor_soap,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_RDF) - call calc(this%descriptor_rdf,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_AS_DISTANCE_2b) - call calc(this%descriptor_as_distance_2b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_ALEX) - call calc(this%descriptor_alex,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_DISTANCE_Nb) - call calc(this%descriptor_distance_Nb,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_SOAP_TURBO) - call calc(this%descriptor_soap_turbo,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_BOND_REAL_SPACE) - call calc(this%descriptor_bond_real_space,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_AN_MONOMER) - call calc(this%descriptor_AN_monomer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_COM_DIMER) - call calc(this%descriptor_com_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_GENERAL_MONOMER) - call calc(this%descriptor_general_monomer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_GENERAL_DIMER) - call calc(this%descriptor_general_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_GENERAL_TRIMER) - call calc(this%descriptor_general_trimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_WATER_TRIMER) - call calc(this%descriptor_water_trimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_MOLECULE_LO_D) - call calc(this%descriptor_molecule_lo_d,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - case(DT_SOAP_EXPRESS) - call calc(this%descriptor_soap_express,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) -#endif - case default - RAISE_ERROR("descriptor_calc: unknown descriptor type "//this%descriptor_type,error) - endselect - - endsubroutine descriptor_calc - - subroutine descriptor_calc_array(this,at,descriptor_out,covariance_cutoff,descriptor_index, & - grad_descriptor_out,grad_descriptor_index,grad_descriptor_pos,grad_covariance_cutoff,args_str,error) - - type(descriptor), intent(in) :: this - type(atoms), intent(in) :: at - real(dp), dimension(:,:), intent(out), optional :: descriptor_out - real(dp), dimension(:), intent(out), optional :: covariance_cutoff - integer, dimension(:,:), intent(out), optional :: descriptor_index - real(dp), dimension(:,:,:), intent(out), optional :: grad_descriptor_out - integer, dimension(:,:), intent(out), optional :: grad_descriptor_index - real(dp), dimension(:,:), intent(out), optional :: grad_descriptor_pos - real(dp), dimension(:,:), intent(out), optional :: grad_covariance_cutoff - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(descriptor_data) :: my_descriptor_data - type(Dictionary) :: params - integer :: i, n, i_d, n_descriptors, n_cross, n_index - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - logical :: do_grad_descriptor, do_descriptor - - INIT_ERROR(error) - - do_descriptor = present(descriptor_out) - do_grad_descriptor = present(grad_descriptor_out) .or. present(grad_descriptor_index) .or. present(grad_descriptor_pos) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='descriptor_calc_array args_str')) then - RAISE_ERROR("descriptor_calc_array failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("descriptor_calc_array did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - if (associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross,mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - call calc(this,at,my_descriptor_data,do_descriptor=do_descriptor,do_grad_descriptor=do_grad_descriptor,args_str=args_str,error=error) - - if(present(descriptor_out)) & - call check_size('descriptor_out',descriptor_out, (/descriptor_dimensions(this),n_descriptors/),'descriptor_calc_array',error) - - if(present(covariance_cutoff)) & - call check_size('covariance_cutoff',covariance_cutoff,(/n_descriptors/),'descriptor_calc_array',error) - - if(present(descriptor_index)) & - call check_size('descriptor_index',descriptor_index,(/n_index,n_descriptors/),'descriptor_calc_array',error) - - if(present(grad_descriptor_out)) & - call check_size('grad_descriptor_out',grad_descriptor_out,(/descriptor_dimensions(this),3,n_cross/),'descriptor_calc_array',error) - - if(present(grad_descriptor_index)) & - call check_size('grad_descriptor_index',grad_descriptor_index,(/2,n_cross/),'descriptor_calc_array',error) - - if(present(grad_descriptor_pos)) & - call check_size('grad_descriptor_pos',grad_descriptor_pos,(/3,n_cross/),'descriptor_calc_array',error) - - if(present(grad_covariance_cutoff)) & - call check_size('grad_covariance_cutoff',grad_covariance_cutoff,(/3,n_cross/),'descriptor_calc_array',error) - - if(do_descriptor) then - do i = 1, n_descriptors - descriptor_out(:,i) = my_descriptor_data%x(i)%data - if(present(covariance_cutoff)) covariance_cutoff(i) = my_descriptor_data%x(i)%covariance_cutoff - if(present(descriptor_index)) descriptor_index(:,i) = my_descriptor_data%x(i)%ci - enddo - endif - - if(do_grad_descriptor) then - i_d = 0 - do i = 1, n_descriptors - do n = lbound(my_descriptor_data%x(i)%ii,1),ubound(my_descriptor_data%x(i)%ii,1) - i_d = i_d + 1 - if(present(grad_descriptor_index)) grad_descriptor_index(:,i_d) = (/i,my_descriptor_data%x(i)%ii(n)/) - if(present(grad_descriptor_out)) grad_descriptor_out(:,:,i_d) = my_descriptor_data%x(i)%grad_data(:,:,n) - if(present(grad_descriptor_pos)) grad_descriptor_pos(:,i_d) = my_descriptor_data%x(i)%pos(:,n) - if(present(grad_covariance_cutoff)) grad_covariance_cutoff(:,i_d) = my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) - enddo - enddo - endif - - call finalise(my_descriptor_data,error=error) - - endsubroutine descriptor_calc_array - - subroutine bispectrum_SO4_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(bispectrum_SO4), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - type(cplx_2d), dimension(:), allocatable :: U - type(cplx_3d), dimension(:,:), allocatable :: dU - - complex(dp) :: sub - complex(dp), dimension(3) :: dsub - real(dp), dimension(3) :: diff, u_ij - real(dp) :: r, tmp_cg - integer :: i, n, n_i, ji, jn, j, m1, m2, j1, j2, m11, m12, m21, m22, & - i_desc, i_bisp, d, n_descriptors, n_cross, l_n_neighbours, n_index - integer, dimension(3) :: shift - integer, dimension(total_elements) :: species_map - logical :: my_do_descriptor, my_do_grad_descriptor - - INIT_ERROR(error) - - call system_timer('bispectrum_SO4_calc') - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO4_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='bispectrum_SO4_calc args_str')) then - RAISE_ERROR("bispectrum_SO4_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("bispectrum_SO4_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - species_map = 0 - do i = 1, size(this%species_Z) - if(this%species_Z(i) == 0) then - species_map = 1 - else - species_map(this%species_Z(i)) = i - endif - enddo - - call cg_initialise(this%j_max, 2) - - call finalise(descriptor_out) - - d = bispectrum_SO4_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - i_desc = i_desc + 1 - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - - enddo - - i_desc = 0 - do i = 1, at%N - - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - - if(my_do_grad_descriptor) then - ! dU is not allocated, allocate and zero it - allocate( dU(0:this%j_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) - do j = 0, this%j_max - allocate( dU(j,0)%mm(3,-j:j,-j:j) ) - dU(j,0)%mm = CPLX_ZERO - enddo - - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - ji = neighbour(at, i, n, jn=jn, distance=r, diff=diff, cosines=u_ij,shift=shift) - if( r >= this%cutoff ) cycle - - n_i = n_i + 1 - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(n_i) = ji - descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,ji) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. - endif - enddo - - if(my_do_grad_descriptor) then - call fourier_SO4_calc(this%fourier_SO4,at,i,U,dU,args_str,error=error) - else - call fourier_SO4_calc(this%fourier_SO4,at,i,U,args_str=args_str,error=error) - endif - - if(my_do_descriptor) then - - i_bisp = 0 - do j1 = 0, this%j_max - j2 = j1 - !do j2 = 0, this%j_max - do j = abs(j1-j2), min(this%j_max,j1+j2) - if( mod(j1+j2+j,2) == 1 ) cycle - - i_bisp = i_bisp + 1 - - !do m1 = -j, j, 2 - ! do m2 = -j, j, 2 - ! sub = CPLX_ZERO - ! do m11 = max(-j1-m1,-j1), min(j1-m1,j1), 2 - ! do m21 = max(-j2-m2,-j2), min(j2-m2,j2), 2 - ! sub = sub + cg_array(j1,m11,j,m1,j1,m11+m1) & - ! * cg_array(j2,m21,j,m2,j2,m21+m2) & - ! * U(j1)%mm(m11,m11+m1) * U(j2)%mm(m21,m21+m2) - ! enddo - ! enddo - ! descriptor_out%x(i_desc)%data(i_bisp) = descriptor_out%x(i_desc)%data(i_bisp) + sub*conjg(U(j)%mm(-m2,m1))*(-1)**(m2/2) - ! enddo - !enddo - - do m1 = -j, j, 2 - do m2 = -j, j, 2 - sub = CPLX_ZERO - do m11 = max(-j1,m1-j2), min(j1,m1+j2), 2 - do m12 = max(-j1,m2-j2), min(j1,m2+j2), 2 - sub = sub + cg_array(j1,m11,j2,m1-m11,j,m1) & - * cg_array(j1,m12,j2,m2-m12,j,m2) & - * U(j1)%mm(m11,m12) * U(j2)%mm(m1-m11,m2-m12) - enddo - enddo - descriptor_out%x(i_desc)%data(i_bisp) = descriptor_out%x(i_desc)%data(i_bisp) + sub*conjg(U(j)%mm(m1,m2)) - enddo - enddo - - enddo - !enddo - enddo - endif - - if(my_do_grad_descriptor) then - n_i = 0 - do n = 0, n_neighbours(at,i) - if( n>0 ) then - ji = neighbour(at, i, n, distance=r) - if( r >= this%cutoff ) cycle - n_i = n_i + 1 - endif - i_bisp = 0 - do j1 = 0, this%j_max - j2 = j1 - !do j2 = 0, this%j_max - do j = abs(j1-j2), min(this%j_max,j1+j2) - if( mod(j1+j2+j,2) == 1 ) cycle - - i_bisp = i_bisp + 1 - - !do m1 = -j, j, 2 - ! do m2 = -j, j, 2 - ! sub = CPLX_ZERO - ! dsub = CPLX_ZERO - - ! do m11 = max(-j1-m1,-j1), min(j1-m1,j1), 2 - ! do m21 = max(-j2-m2,-j2), min(j2-m2,j2), 2 - ! tmp_cg = cg_array(j1,m11,j,m1,j1,m11+m1) & - ! * cg_array(j2,m21,j,m2,j2,m21+m2) - - ! sub = sub + tmp_cg & - ! * U(j1)%mm(m11,m1+m11) * U(j2)%mm(m21,m2+m21) - ! dsub = dsub + tmp_cg & - ! * ( dU(j1,n_i)%mm(:,m11,m1+m11) * U(j2)%mm(m21,m2+m21) + & - ! U(j1)%mm(m11,m1+m11) * dU(j2,n_i)%mm(:,m21,m2+m21) ) - ! enddo - ! enddo - ! descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) = & - ! descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) + & - ! ( dsub*conjg(U(j)%mm(-m2,m1)) + sub*conjg(dU(j,n_i)%mm(:,-m2,m1)) )*(-1)**(m2/2) - ! enddo - !enddo - do m1 = -j, j, 2 - do m2 = -j, j, 2 - sub = CPLX_ZERO - dsub = CPLX_ZERO - do m11 = max(-j1,m1-j2), min(j1,m1+j2), 2 - do m12 = max(-j1,m2-j2), min(j1,m2+j2), 2 - - tmp_cg = cg_array(j1,m11,j2,m1-m11,j,m1) & - * cg_array(j1,m12,j2,m2-m12,j,m2) - - sub = sub + tmp_cg & - * U(j1)%mm(m11,m12) * U(j2)%mm(m1-m11,m2-m12) - dsub = dsub + tmp_cg & - * ( dU(j1,n_i)%mm(:,m11,m12) * U(j2)%mm(m1-m11,m2-m12) + & - U(j1)%mm(m11,m12) * dU(j2,n_i)%mm(:,m1-m11,m2-m12) ) - enddo - enddo - descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) = & - descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) + & - dsub*conjg(U(j)%mm(m1,m2)) + sub*conjg(dU(j,n_i)%mm(:,m1,m2)) - enddo - enddo - - enddo - !enddo - enddo - enddo - endif - - call finalise(dU) - enddo ! i - - ! clear U from the memory - call finalise(U) - - call system_timer('bispectrum_SO4_calc') - - endsubroutine bispectrum_SO4_calc - - subroutine bispectrum_so3_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(bispectrum_so3), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(cplx_1d), dimension(:), allocatable :: SphericalY_ij - type(cplx_1d), dimension(:,:), allocatable :: fourier_so3 - - type(cplx_2d), dimension(:), allocatable :: dSphericalY_ij - type(cplx_2d), dimension(:,:,:), allocatable :: dfourier_so3 - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, n, a, l, m, l1, l2, m1, i_desc, i_pow, l_n_neighbours, & - n_i, n_descriptors, n_cross, n_index - integer, dimension(3) :: shift_ij - real(dp) :: r_ij - real(dp), dimension(3) :: u_ij, d_ij - real(dp), dimension(:), allocatable :: Rad_ij - real(dp), dimension(:,:), allocatable :: dRad_ij - - complex(dp) :: sub, dsub(3) - - integer, dimension(total_elements) :: species_map - - INIT_ERROR(error) - - call system_timer('bispectrum_so3_calc') - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_so3_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - species_map = 0 - do i = 1, size(this%species_Z) - if(this%species_Z(i) == 0) then - species_map = 1 - else - species_map(this%species_Z(i)) = i - endif - enddo - - call cg_initialise(this%l_max) - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='bispectrum_SO3_calc args_str')) then - RAISE_ERROR("bispectrum_SO3_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("bispectrum_SO3_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("bispectrum_SO3_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = bispectrum_so3_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - - allocate(descriptor_out%x(n_descriptors)) - - i_desc = 0 - do i = 1, at%N - - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - i_desc = i_desc + 1 - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - allocate(fourier_so3(0:this%l_max,this%n_max),SphericalY_ij(0:this%l_max),Rad_ij(this%n_max)) - do a = 1, this%n_max - do l = 0, this%l_max - allocate(fourier_so3(l,a)%m(-l:l)) - fourier_so3(l,a)%m(:) = CPLX_ZERO - enddo - enddo - do l = 0, this%l_max - allocate(SphericalY_ij(l)%m(-l:l)) - enddo - - if(my_do_grad_descriptor) then - allocate( dRad_ij(3,this%n_max), dSphericalY_ij(0:this%l_max) ) - do l = 0, this%l_max - allocate(dSphericalY_ij(l)%mm(3,-l:l)) - enddo - endif - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - i_desc = i_desc + 1 - - do a = 1, this%n_max - do l = 0, this%l_max - fourier_so3(l,a)%m(:) = CPLX_ZERO - enddo - enddo - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - - if(my_do_grad_descriptor) then - allocate( dfourier_so3(0:this%l_max,this%n_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) - do n = 0, n_neighbours(at,i,max_dist=this%cutoff) - do a = 1, this%n_max - do l = 0, this%l_max - allocate(dfourier_so3(l,a,n)%mm(3,-l:l)) - dfourier_so3(l,a,n)%mm(:,:) = CPLX_ZERO - enddo - enddo - enddo - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(n_i) = j - descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. - endif - - do a = 1, this%n_max - Rad_ij(a) = RadialFunction(this%Radial, r_ij, a) - if(my_do_grad_descriptor) dRad_ij(:,a) = GradRadialFunction(this%Radial, r_ij, a) * u_ij - enddo - - do l = 0, this%l_max - do m = -l, l - SphericalY_ij(l)%m(m) = SphericalYCartesian(l,m,d_ij) - if(my_do_grad_descriptor) dSphericalY_ij(l)%mm(:,m) = GradSphericalYCartesian(l,m,d_ij) - enddo - enddo - - do a = 1, this%n_max - do l = 0, this%l_max - do m = -l, l - fourier_so3(l,a)%m(m) = fourier_so3(l,a)%m(m) + Rad_ij(a)*SphericalY_ij(l)%m(m) - if(my_do_grad_descriptor) then - dfourier_so3(l,a,n_i)%mm(:,m) = dfourier_so3(l,a,n_i)%mm(:,m) + & - dRad_ij(:,a) * SphericalY_ij(l)%m(m) + Rad_ij(a)*dSphericalY_ij(l)%mm(:,m) - endif - enddo - enddo - enddo - - enddo ! n - - if(my_do_descriptor) then - i_pow = 0 - do a = 1, this%n_max - do l1 = 0, this%l_max - l2 = l1 - !do l2 = 0, this%l_max - do l = abs(l1-l2), min(this%l_max,l1+l2) - if( mod(l1,2)==1 .and. mod(l2,2)==1 .and. mod(l,2)==1 ) cycle - i_pow = i_pow + 1 - - do m = -l, l - sub = CPLX_ZERO - do m1 = max(-l1,m-l2),min(l1,m+l2) - sub = sub + cg_array(l1,m1,l2,m-m1,l,m) * conjg(fourier_so3(l1,a)%m(m1)) * conjg(fourier_so3(l2,a)%m(m-m1)) - enddo - - descriptor_out%x(i_desc)%data(i_pow) = descriptor_out%x(i_desc)%data(i_pow) + fourier_so3(l,a)%m(m) * sub - enddo - - enddo - !enddo - enddo - enddo - endif - - if(my_do_grad_descriptor) then - do n = 1, n_neighbours(at,i,max_dist=this%cutoff) - i_pow = 0 - do a = 1, this%n_max - do l1 = 0, this%l_max - l2 = l1 - !do l2 = 0, this%l_max - do l = abs(l1-l2), min(this%l_max,l1+l2) - if( mod(l1,2)==1 .and. mod(l2,2)==1 .and. mod(l,2)==1 ) cycle - i_pow = i_pow + 1 - - do m = -l, l - sub = CPLX_ZERO - dsub = CPLX_ZERO - do m1 = max(-l1,m-l2),min(l1,m+l2) - dsub = dsub + cg_array(l1,m1,l2,m-m1,l,m) * & - ( conjg(dfourier_so3(l1,a,n)%mm(:,m1)) * conjg(fourier_so3(l2,a)%m(m-m1)) + & - conjg(fourier_so3(l1,a)%m(m1)) * conjg(dfourier_so3(l2,a,n)%mm(:,m-m1)) ) - sub = sub + cg_array(l1,m1,l2,m-m1,l,m) * conjg(fourier_so3(l1,a)%m(m1)) * conjg(fourier_so3(l2,a)%m(m-m1)) - enddo - - descriptor_out%x(i_desc)%grad_data(i_pow,:,n) = descriptor_out%x(i_desc)%grad_data(i_pow,:,n) + & - fourier_so3(l,a)%m(m) * dsub + dfourier_so3(l,a,n)%mm(:,m) * sub - enddo - enddo - !enddo - enddo - enddo - descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,n) - enddo - endif - - if(allocated(dfourier_so3)) then - do n = lbound(dfourier_so3,3), ubound(dfourier_so3,3) - do a = lbound(dfourier_so3,2), ubound(dfourier_so3,2) - do l = lbound(dfourier_so3,1), ubound(dfourier_so3,1) - deallocate(dfourier_so3(l,a,n)%mm) - enddo - enddo - enddo - deallocate(dfourier_so3) - endif - - enddo ! i - - if(allocated(Rad_ij)) deallocate(Rad_ij) - if(allocated(dRad_ij)) deallocate(dRad_ij) - - if(allocated(fourier_so3)) then - do a = lbound(fourier_so3,2), ubound(fourier_so3,2) - do l = lbound(fourier_so3,1), ubound(fourier_so3,1) - deallocate(fourier_so3(l,a)%m) - enddo - enddo - deallocate(fourier_so3) - endif - - if(allocated(SphericalY_ij)) then - do l = lbound(SphericalY_ij,1), ubound(SphericalY_ij,1) - deallocate(SphericalY_ij(l)%m) - enddo - deallocate(SphericalY_ij) - endif - - if(allocated(dSphericalY_ij)) then - do l = lbound(dSphericalY_ij,1), ubound(dSphericalY_ij,1) - deallocate(dSphericalY_ij(l)%mm) - enddo - deallocate(dSphericalY_ij) - endif - - call system_timer('bispectrum_so3_calc') - - endsubroutine bispectrum_so3_calc - - subroutine behler_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(behler), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, k, n, m, a, b, i_desc_i, l_n_neighbours, & - n_i, m_i, n_descriptors, n_cross, n_index - integer, dimension(:), allocatable :: i_desc - integer, dimension(3) :: shift_ij - real(dp) :: r_ij, r_ik, r_jk, cos_ijk, Ang, dAng, Rad, dRad_ij, dRad_ik, dRad_jk, f_cut_ij, f_cut_ik, f_cut_jk, df_cut_ij, df_cut_ik, df_cut_jk, g2, dg2 - real(dp), dimension(3) :: u_ij, u_ik, u_jk, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik - - INIT_ERROR(error) - - call system_timer('behler_calc') - - if(.not. this%initialised) then - RAISE_ERROR("behler_calc: descriptor object not initialised", error) - endif - - if( at%cutoff < this%cutoff ) then - RAISE_ERROR("behler_calc: cutoff of atoms object ("//at%cutoff//") less than cutoff of descriptor ("//this%cutoff//")", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='behler_calc args_str')) then - RAISE_ERROR("behler_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("behler_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - call finalise(descriptor_out) - - d = behler_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - allocate(i_desc(at%N)) - - i_desc = 0 - i_desc_i = 0 - do i = 1, at%N - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - if( this%Z /= 0 .and. this%Z /= at%Z(i) ) cycle - i_desc_i = i_desc_i + 1 - i_desc(i) = i_desc_i - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc_i)%data(d)) - descriptor_out%x(i_desc_i)%data = 0.0_dp - allocate(descriptor_out%x(i_desc_i)%ci(n_index)) - descriptor_out%x(i_desc_i)%has_data = .false. - descriptor_out%x(i_desc_i)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc_i)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc_i)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc_i)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc_i)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc_i)%grad_data = 0.0_dp - descriptor_out%x(i_desc_i)%ii = 0 - descriptor_out%x(i_desc_i)%pos = 0.0_dp - descriptor_out%x(i_desc_i)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc_i)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc_i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - -!$omp parallel do schedule(dynamic) default(none) shared(this,at,descriptor_out,my_do_descriptor, my_do_grad_descriptor, d, i_desc) & -!$omp private(i,j,k,i_desc_i,n_i,n,r_ij,u_ij,d_ij,shift_ij,f_cut_ij,df_cut_ij,g2,dg2,m_i,m,r_ik,u_ik,d_ik,d_jk,r_jk,u_jk,cos_ijk) & -!$omp private(dcosijk_ij,dcosijk_ik,a,b,f_cut_ik,f_cut_jk,df_cut_ik,df_cut_jk,Ang,Rad,dAng,dRad_ij,dRad_ik,dRad_jk) - do i = 1, at%N - if( this%Z /= 0 .and. this%Z /= at%Z(i) ) cycle - - if(i_desc(i) == 0) then - cycle - else - i_desc_i = i_desc(i) - endif - - if(my_do_descriptor) then - descriptor_out%x(i_desc_i)%ci(1) = i - descriptor_out%x(i_desc_i)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc_i)%ii(0) = i - descriptor_out%x(i_desc_i)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc_i)%has_grad_data(0) = .true. - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc_i)%ii(n_i) = j - descriptor_out%x(i_desc_i)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc_i)%has_grad_data(n_i) = .true. - endif - - do a = 1, this%n_g2 - if ( r_ij >= this%g2(a)%rc .or. ( this%g2(a)%Z_n /=0 .and. this%g2(a)%Z_n /= at%Z(j) ) ) cycle - - f_cut_ij = cos_cutoff_function(r_ij,this%g2(a)%rc) - if(my_do_grad_descriptor) df_cut_ij = dcos_cutoff_function(r_ij,this%g2(a)%rc) - - g2 = exp(-this%g2(a)%eta * (r_ij-this%g2(a)%rs)**2) - if(my_do_descriptor) descriptor_out%x(i_desc_i)%data(a) = descriptor_out%x(i_desc_i)%data(a) + g2 * f_cut_ij - if(my_do_grad_descriptor) then - dg2 = -2.0_dp * this%g2(a)%eta * (r_ij-this%g2(a)%rs) * g2 - descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) = ( dg2 * f_cut_ij + g2 * df_cut_ij ) * u_ij - descriptor_out%x(i_desc_i)%grad_data(a,:,0) = descriptor_out%x(i_desc_i)%grad_data(a,:,0) - descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) - endif - enddo - - - m_i = 0 - do m = 1, n_neighbours(at,i) - k = neighbour(at, i, m, distance = r_ik, cosines=u_ik, diff=d_ik) - if( r_ik >= this%cutoff ) cycle - - m_i = m_i + 1 - - d_jk = d_ik - d_ij - r_jk = norm(d_jk) - if( r_jk .feq. 0.0_dp ) cycle - - u_jk = d_jk / r_jk - - cos_ijk = dot_product(u_ij,u_ik) - - if(my_do_grad_descriptor) then - dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij - dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik - endif - - do b = 1, this%n_g3 - if( r_ik >= this%g3(b)%rc .or. r_jk >= this%g3(b)%rc) cycle - if( this%g3(b)%Z_n(1) /= 0 .and. this%g3(b)%Z_n(2) /= 0 ) then - if( .not. ( & - ( this%g3(b)%Z_n(1) == at%Z(j) .and. this%g3(b)%Z_n(2) == at%Z(k) ) .or. & - ( this%g3(b)%Z_n(1) == at%Z(k) .and. this%g3(b)%Z_n(2) == at%Z(j) ) ) ) cycle - endif - - f_cut_ij = cos_cutoff_function(r_ij,this%g3(b)%rc) - f_cut_ik = cos_cutoff_function(r_ik,this%g3(b)%rc) - f_cut_jk = cos_cutoff_function(r_jk,this%g3(b)%rc) - if(my_do_grad_descriptor) then - df_cut_ij = dcos_cutoff_function(r_ij,this%g3(b)%rc) - df_cut_ik = dcos_cutoff_function(r_ik,this%g3(b)%rc) - df_cut_jk = dcos_cutoff_function(r_jk,this%g3(b)%rc) - endif - - a = b + this%n_g2 - - Ang = (1.0_dp + this%g3(b)%lambda * cos_ijk)**this%g3(b)%zeta - Rad = exp( -this%g3(b)%eta * (r_ij**2 + r_ik**2 + r_jk**2) ) - if(my_do_descriptor) descriptor_out%x(i_desc_i)%data(a) = descriptor_out%x(i_desc_i)%data(a) + 0.5_dp * Ang * Rad * f_cut_ij * f_cut_ik * f_cut_jk - if(my_do_grad_descriptor) then - dAng = this%g3(b)%zeta * (1.0_dp + this%g3(b)%lambda * cos_ijk)**(this%g3(b)%zeta -1.0_dp) * this%g3(b)%lambda - dRad_ij = -this%g3(b)%eta * 2.0_dp * r_ij * Rad - dRad_ik = -this%g3(b)%eta * 2.0_dp * r_ik * Rad - dRad_jk = -this%g3(b)%eta * 2.0_dp * r_jk * Rad - - descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) = descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) + 0.5_dp * & - ( ( dAng * dcosijk_ij * Rad + Ang * ( dRad_ij * u_ij - dRad_jk * u_jk ) ) * f_cut_ij * f_cut_ik * f_cut_jk + & - Ang * Rad * f_cut_ik * ( df_cut_ij * u_ij * f_cut_jk - f_cut_ij * df_cut_jk * u_jk ) ) - - descriptor_out%x(i_desc_i)%grad_data(a,:,m_i) = descriptor_out%x(i_desc_i)%grad_data(a,:,m_i) + 0.5_dp * & - ( ( dAng * dcosijk_ik * Rad + Ang * ( dRad_ik * u_ik + dRad_jk * u_jk ) ) * f_cut_ij * f_cut_ik * f_cut_jk + & - Ang * Rad * f_cut_ij * ( df_cut_ik * u_ik * f_cut_jk + f_cut_ik * df_cut_jk * u_jk ) ) - - descriptor_out%x(i_desc_i)%grad_data(a,:,0) = descriptor_out%x(i_desc_i)%grad_data(a,:,0) - 0.5_dp * & - ( ( dAng * (dcosijk_ij+dcosijk_ik) * Rad + Ang * (dRad_ij * u_ij + dRad_ik * u_ik) ) * f_cut_ij * f_cut_ik * f_cut_jk + & - Ang * Rad * f_cut_jk * ( df_cut_ij * u_ij * f_cut_ik + f_cut_ij * df_cut_ik * u_ik ) ) - endif - - - enddo - - enddo - enddo - - do b = 1, this%n_g3 - a = b + this%n_g2 - - if(my_do_descriptor) descriptor_out%x(i_desc_i)%data(a) = descriptor_out%x(i_desc_i)%data(a) * 2.0_dp**(1.0_dp-this%g3(b)%zeta) - if(my_do_grad_descriptor) descriptor_out%x(i_desc_i)%grad_data(a,:,:) = descriptor_out%x(i_desc_i)%grad_data(a,:,:) * 2.0_dp**(1.0_dp-this%g3(b)%zeta) - enddo - enddo -!$omp end parallel do - - if(allocated(i_desc)) deallocate(i_desc) - - call system_timer('behler_calc') - - endsubroutine behler_calc - - subroutine distance_2b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(distance_2b), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical :: needs_resid - logical, dimension(:), pointer :: atom_mask_pointer - integer, dimension(:), pointer :: resid_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor, Zi1, Zi2, Zj1, Zj2 - integer :: d, n_descriptors, n_cross, i_desc, i, j, n, n_index - integer, dimension(3) :: shift - real(dp) :: r_ij, covariance_cutoff, dcovariance_cutoff, tail, dtail - real(dp), dimension(3) :: u_ij - - INIT_ERROR(error) - - call system_timer('distance_2b_calc') - - if(.not. this%initialised) then - RAISE_ERROR("distance_2b_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='distance_2b_calc args_str')) then - RAISE_ERROR("distance_2b_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("distance_2b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - needs_resid = this%only_intra .or. this%only_inter - if (needs_resid) then - if (.not. assign_pointer(at, trim(this%resid_name), resid_pointer)) then - RAISE_ERROR("distance_2b_calc did not find "//trim(this%resid_name)//" property (residue id) in the atoms object.", error) - end if - else - resid_pointer => null() - end if - - d = distance_2b_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%ci = 0 - descriptor_out%x(i)%has_data = .false. - descriptor_out%x(i)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,0:1)) - allocate(descriptor_out%x(i)%ii(0:1)) - allocate(descriptor_out%x(i)%pos(3,0:1)) - allocate(descriptor_out%x(i)%has_grad_data(0:1)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,0:1)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - i_desc = 0 - do i = 1, at%N - - if(associated(atom_mask_pointer)) then ! skip if masked - if(.not. atom_mask_pointer(i)) cycle ! skip if masked - endif ! skip if masked - - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) - if( r_ij >= this%cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - if (needs_resid) then - if (this%only_intra .and. resid_pointer(i) /= resid_pointer(j)) cycle - if (this%only_inter .and. resid_pointer(i) == resid_pointer(j)) cycle - end if - - i_desc = i_desc + 1 - - covariance_cutoff = coordination_function(r_ij,this%cutoff,this%cutoff_transition_width) - if( this%has_tail .and. this%tail_exponent /= 0 ) then - tail = ( erf(this%tail_range*r_ij) / r_ij )**this%tail_exponent - else - tail = 1.0_dp - endif - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%data(:) = r_ij**this%exponents - descriptor_out%x(i_desc)%ci(1:2) = (/i,j/) - descriptor_out%x(i_desc)%has_data = .true. - - descriptor_out%x(i_desc)%covariance_cutoff = covariance_cutoff * tail - endif - if(my_do_grad_descriptor) then - dcovariance_cutoff = dcoordination_function(r_ij,this%cutoff,this%cutoff_transition_width) - if( this%has_tail .and. this%tail_exponent /= 0 ) then - dtail = tail * this%tail_exponent * ( 2.0_dp*this%tail_range*exp(-this%tail_range**2*r_ij**2) / & - sqrt(pi) / erf(this%tail_range*r_ij) - 1.0_dp / r_ij ) - else - dtail = 0.0_dp - endif - - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - descriptor_out%x(i_desc)%grad_data(:,:,0) = -( this%exponents*r_ij**(this%exponents-1) ) .outer. u_ij - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = -(dcovariance_cutoff*tail + covariance_cutoff*dtail)*u_ij - - descriptor_out%x(i_desc)%ii(1) = j - descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(1) = .true. - descriptor_out%x(i_desc)%grad_data(:,:,1) = - descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) - - endif - enddo - enddo - - call system_timer('distance_2b_calc') - - endsubroutine distance_2b_calc - - subroutine coordination_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(coordination), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, n, i_n, l_n_neighbours, i_desc, n_descriptors, n_cross, n_index - integer, dimension(3) :: shift - real(dp) :: r_ij - real(dp), dimension(3) :: u_ij, df_cut - - INIT_ERROR(error) - - call system_timer('coordination_calc') - - if(.not. this%initialised) then - RAISE_ERROR("coordination_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='coordination_calc args_str')) then - RAISE_ERROR("coordination_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("coordination_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - call finalise(descriptor_out) - - d = coordination_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - i_desc = i_desc + 1 - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - i_desc = 0 - do i = 1, at%N - - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - i_n = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) - - if( r_ij >= this%cutoff ) cycle - i_n = i_n + 1 - - if(my_do_descriptor) & - descriptor_out%x(i_desc)%data(1) = descriptor_out%x(i_desc)%data(1) + coordination_function(r_ij,this%cutoff,this%transition_width) - - if(my_do_grad_descriptor) then - df_cut = dcoordination_function(r_ij,this%cutoff,this%transition_width) * u_ij - - descriptor_out%x(i_desc)%grad_data(1,:,0) = descriptor_out%x(i_desc)%grad_data(1,:,0) - df_cut - - descriptor_out%x(i_desc)%ii(i_n) = j - descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,i_n) = df_cut - endif - enddo - enddo - - call system_timer('coordination_calc') - - endsubroutine coordination_calc - - subroutine angle_3b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(angle_3b), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor, Zk1, Zk2, Zj1, Zj2 - integer :: d, n_descriptors, n_cross, i_desc, i, j, k, n, m, n_index - integer, dimension(3) :: shift_ij, shift_ik - real(dp) :: r_ij, r_ik, r_jk, cos_ijk, fc_j, fc_k, dfc_j, dfc_k - real(dp), dimension(3) :: u_ij, u_ik, u_jk, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik - - INIT_ERROR(error) - - call system_timer('angle_3b_calc') - - if(.not. this%initialised) then - RAISE_ERROR("angle_3b_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='angle_3b_calc args_str')) then - RAISE_ERROR("angle_3b_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("angle_3b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - d = angle_3b_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%has_data = .false. - endif - - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,0:2)) - allocate(descriptor_out%x(i)%ii(0:2)) - allocate(descriptor_out%x(i)%pos(3,0:2)) - allocate(descriptor_out%x(i)%has_grad_data(0:2)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,0:2)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - i_desc = 0 - do i = 1, at%N - if(associated(atom_mask_pointer)) then ! skip if masked - if(.not. atom_mask_pointer(i)) cycle ! skip if masked - endif ! skip if masked - - if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, diff = d_ij, shift=shift_ij) - - if( r_ij >= this%cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - - fc_j = coordination_function(r_ij,this%cutoff,this%cutoff_transition_width) - dfc_j = dcoordination_function(r_ij,this%cutoff,this%cutoff_transition_width) - - do m = 1, n_neighbours(at,i) - - if( n == m ) cycle - - k = neighbour(at, i, m, distance = r_ik, cosines = u_ik, diff = d_ik, shift=shift_ik) - if( r_ik >= this%cutoff ) cycle - - Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) - Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) - - if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - d_jk = d_ij - d_ik - r_jk = norm(d_jk) - u_jk = d_jk / r_jk - - fc_k = coordination_function(r_ik,this%cutoff,this%cutoff_transition_width) - dfc_k = dcoordination_function(r_ik,this%cutoff,this%cutoff_transition_width) - - cos_ijk = dot_product(d_ij,d_ik)/(r_ij*r_ik) - - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%data(1) = r_ij + r_ik - descriptor_out%x(i_desc)%data(2) = (r_ij - r_ik)**2 - descriptor_out%x(i_desc)%data(3) = r_jk !cos_ijk - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - - descriptor_out%x(i_desc)%covariance_cutoff = fc_j*fc_k - endif - - if(my_do_grad_descriptor) then - dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij - dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik - - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,0) = - u_ij - u_ik - descriptor_out%x(i_desc)%grad_data(2,:,0) = 2.0_dp * (r_ij - r_ik)*(-u_ij + u_ik) - descriptor_out%x(i_desc)%grad_data(3,:,0) = 0.0_dp !-dcosijk_ij - dcosijk_ik - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = - dfc_j*fc_k*u_ij - dfc_k*fc_j*u_ik - - descriptor_out%x(i_desc)%ii(1) = j - descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(1) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij - descriptor_out%x(i_desc)%grad_data(2,:,1) = 2.0_dp * (r_ij - r_ik)*u_ij - descriptor_out%x(i_desc)%grad_data(3,:,1) = u_jk !dcosijk_ij - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = dfc_j*fc_k*u_ij - - descriptor_out%x(i_desc)%ii(2) = k - descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,k) + matmul(at%lattice,shift_ik) - descriptor_out%x(i_desc)%has_grad_data(2) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,2) = u_ik - descriptor_out%x(i_desc)%grad_data(2,:,2) = 2.0_dp * (r_ij - r_ik)*(-u_ik) - descriptor_out%x(i_desc)%grad_data(3,:,2) = -u_jk !dcosijk_ik - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,2) = dfc_k*fc_j*u_ik - endif - enddo - enddo - enddo - - call system_timer('angle_3b_calc') - - endsubroutine angle_3b_calc - - subroutine co_angle_3b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(co_angle_3b), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(descriptor) :: my_coordination - type(descriptor_data) :: descriptor_coordination - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor, Zk1, Zk2, Zj1, Zj2 - integer :: d, n_descriptors, n_cross, i_desc, i, j, k, n, m, & - l_n_neighbours_coordination, n_index - integer, dimension(3) :: shift_ij, shift_ik - real(dp) :: r_ij, r_ik, r_jk, cos_ijk, fc_j, fc_k, dfc_j, dfc_k - real(dp), dimension(3) :: u_ij, u_ik, u_jk, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik - - INIT_ERROR(error) - - call system_timer('co_angle_3b_calc') - - if(.not. this%initialised) then - RAISE_ERROR("co_angle_3b_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='co_angle_3b_calc args_str')) then - RAISE_ERROR("co_angle_3b_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("co_angle_3b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("co_angle_3b_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = co_angle_3b_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - i_desc = 0 - do i = 1, at%N - if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle - l_n_neighbours_coordination = n_neighbours(at,i,max_dist=this%coordination_cutoff) - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij) - if( r_ij >= this%cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - - do m = 1, n_neighbours(at,i) - - if( n == m ) cycle - - k = neighbour(at, i, m, distance = r_ik) - if( r_ik >= this%cutoff ) cycle - - Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) - Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) - - if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - i_desc = i_desc + 1 - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - endif - - if(my_do_grad_descriptor) then - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:2+l_n_neighbours_coordination)) - allocate(descriptor_out%x(i_desc)%ii(0:2+l_n_neighbours_coordination)) - allocate(descriptor_out%x(i_desc)%pos(3,0:2+l_n_neighbours_coordination)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:2+l_n_neighbours_coordination)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:2+l_n_neighbours_coordination)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - enddo - enddo - - call initialise(my_coordination,'coordination cutoff='//this%coordination_cutoff//' coordination_transition_width='//this%coordination_transition_width,error) - call calc(my_coordination,at,descriptor_coordination,do_descriptor,do_grad_descriptor,args_str,error) - - i_desc = 0 - do i = 1, at%N - if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, diff = d_ij, shift=shift_ij) - - if( r_ij >= this%cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - - fc_j = coordination_function(r_ij,this%cutoff,0.5_dp) - dfc_j = dcoordination_function(r_ij,this%cutoff,0.5_dp) - - do m = 1, n_neighbours(at,i) - if( n == m ) cycle - - k = neighbour(at, i, m, distance = r_ik, cosines = u_ik, diff = d_ik, shift=shift_ik) - if( r_ik >= this%cutoff ) cycle - - Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) - Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) - - if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - d_jk = d_ij - d_ik - r_jk = norm(d_jk) - u_jk = d_jk / r_jk - - fc_k = coordination_function(r_ik,this%cutoff,0.5_dp) - dfc_k = dcoordination_function(r_ik,this%cutoff,0.5_dp) - - cos_ijk = dot_product(d_ij,d_ik)/(r_ij*r_ik) - - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%data(1) = r_ij + r_ik - descriptor_out%x(i_desc)%data(2) = (r_ij - r_ik)**2 - descriptor_out%x(i_desc)%data(3) = r_jk !cos_ijk - descriptor_out%x(i_desc)%data(4) = descriptor_coordination%x(i)%data(1) - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - - descriptor_out%x(i_desc)%covariance_cutoff = fc_j*fc_k - endif - - if(my_do_grad_descriptor) then - dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij - dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik - - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,0) = - u_ij - u_ik - descriptor_out%x(i_desc)%grad_data(2,:,0) = 2.0_dp * (r_ij - r_ik)*(-u_ij + u_ik) - descriptor_out%x(i_desc)%grad_data(3,:,0) = 0.0_dp !-dcosijk_ij - dcosijk_ik - descriptor_out%x(i_desc)%grad_data(4,:,0) = descriptor_coordination%x(i)%grad_data(1,:,0) - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = - dfc_j*fc_k*u_ij - dfc_k*fc_j*u_ik - - descriptor_out%x(i_desc)%ii(1) = j - descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(1) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij - descriptor_out%x(i_desc)%grad_data(2,:,1) = 2.0_dp * (r_ij - r_ik)*u_ij - descriptor_out%x(i_desc)%grad_data(3,:,1) = u_jk !dcosijk_ij - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = dfc_j*fc_k*u_ij - - descriptor_out%x(i_desc)%ii(2) = k - descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,k) + matmul(at%lattice,shift_ik) - descriptor_out%x(i_desc)%has_grad_data(2) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,2) = u_ik - descriptor_out%x(i_desc)%grad_data(2,:,2) = 2.0_dp * (r_ij - r_ik)*(-u_ik) - descriptor_out%x(i_desc)%grad_data(3,:,2) = -u_jk !dcosijk_ik - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,2) = dfc_k*fc_j*u_ik - - descriptor_out%x(i_desc)%ii(3:) = descriptor_coordination%x(i)%ii(1:) - descriptor_out%x(i_desc)%pos(:,3:) = descriptor_coordination%x(i)%pos(:,1:) - descriptor_out%x(i_desc)%has_grad_data(3:) = descriptor_coordination%x(i)%has_grad_data(1:) - descriptor_out%x(i_desc)%grad_data(4,:,3:) = descriptor_coordination%x(i)%grad_data(1,:,1:) - endif - enddo - enddo - enddo - - call finalise(my_coordination) - call finalise(descriptor_coordination) - - call system_timer('co_angle_3b_calc') - - endsubroutine co_angle_3b_calc - - subroutine co_distance_2b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(co_distance_2b), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(descriptor) :: my_coordination - type(descriptor_data) :: descriptor_coordination - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor, Zi1, Zi2, Zj1, Zj2 - integer :: d, n_descriptors, n_cross, i_desc, i, j, n, & - n_neighbours_coordination_i, n_neighbours_coordination_ij, n_index - integer, dimension(3) :: shift - real(dp) :: r_ij - real(dp), dimension(3) :: u_ij - - INIT_ERROR(error) - call system_timer('co_distance_2b_calc') - - if(.not. this%initialised) then - RAISE_ERROR("co_distance_2b_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='co_distance_2b_calc args_str')) then - RAISE_ERROR("co_distance_2b_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("co_distance_2b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("co_distance_2b_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = co_distance_2b_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - i_desc = 0 - do i = 1, at%N - - if( associated(atom_mask_pointer) ) then - if( .not. atom_mask_pointer(i) ) cycle - endif - - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij) - - if(r_ij >= this%cutoff) cycle -!if(r_ij <3.5_dp) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - i_desc = i_desc + 1 - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - endif - - if(my_do_grad_descriptor) then - n_neighbours_coordination_ij = n_neighbours(at,i,max_dist=this%coordination_cutoff) + & - n_neighbours(at,j,max_dist=this%coordination_cutoff) + 2 - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:1+n_neighbours_coordination_ij)) - allocate(descriptor_out%x(i_desc)%ii(0:1+n_neighbours_coordination_ij)) - allocate(descriptor_out%x(i_desc)%pos(3,0:1+n_neighbours_coordination_ij)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:1+n_neighbours_coordination_ij)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:1+n_neighbours_coordination_ij)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - enddo - - call initialise(my_coordination,'coordination cutoff='//this%coordination_cutoff//' transition_width='//this%coordination_transition_width,error) - call calc(my_coordination,at,descriptor_coordination,.true.,do_grad_descriptor,args_str,error) - - i_desc = 0 - do i = 1, at%N - - if( associated(atom_mask_pointer) ) then - if( .not. atom_mask_pointer(i) ) cycle - endif - - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) - if( r_ij >= this%cutoff ) cycle -!if(r_ij <3.5_dp) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - i_desc = i_desc + 1 - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1:2) = (/i,j/) - - descriptor_out%x(i_desc)%has_data = .true. - - descriptor_out%x(i_desc)%data(1) = r_ij - descriptor_out%x(i_desc)%data(2) = descriptor_coordination%x(i)%data(1) + descriptor_coordination%x(j)%data(1) - descriptor_out%x(i_desc)%data(3) = (descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))**2 - - descriptor_out%x(i_desc)%covariance_cutoff = coordination_function(r_ij, this%cutoff,this%transition_width) !coordination_function(r_ij,3.5_dp, 0.5_dp, this%cutoff,this%transition_width) - endif - if(my_do_grad_descriptor) then - n_neighbours_coordination_i = n_neighbours(at,i,max_dist=this%coordination_cutoff) - - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,0) = -u_ij(:) - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = -dcoordination_function(r_ij,this%cutoff,this%transition_width)*u_ij !-dcoordination_function(r_ij,3.5_dp, 0.5_dp, this%cutoff,this%transition_width)*u_ij - - descriptor_out%x(i_desc)%ii(1) = j - descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(1) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij(:) - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) - - descriptor_out%x(i_desc)%ii(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%ii(:) - descriptor_out%x(i_desc)%pos(:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%pos(:,:) - descriptor_out%x(i_desc)%has_grad_data(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%has_grad_data(:) - descriptor_out%x(i_desc)%grad_data(2,:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%grad_data(1,:,:) - descriptor_out%x(i_desc)%grad_data(3,:,2:n_neighbours_coordination_i+2) = 2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& - descriptor_coordination%x(i)%grad_data(1,:,:) - - descriptor_out%x(i_desc)%ii(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%ii(:) - descriptor_out%x(i_desc)%pos(:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%pos(:,:) - descriptor_out%x(i_desc)%has_grad_data(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%has_grad_data(:) - descriptor_out%x(i_desc)%grad_data(2,:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%grad_data(1,:,:) - descriptor_out%x(i_desc)%grad_data(3,:,n_neighbours_coordination_i+3:) = -2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& - descriptor_coordination%x(j)%grad_data(1,:,:) - - endif - enddo - enddo - - call finalise(my_coordination) - call finalise(descriptor_coordination) - - call system_timer('co_distance_2b_calc') - - endsubroutine co_distance_2b_calc - - subroutine cosnx_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(cosnx), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, k, n, m, a, b, i_desc, i_cosnx, l_n_neighbours, n_i, & - n_descriptors, n_cross, n_index - integer, dimension(3) :: shift_ij - real(dp) :: r_ij, r_ik, r_jk, cos_ijk, T_0_cos_ijk, T_1_cos_ijk, T_n_cos_ijk, U_0_cos_ijk, U_1_cos_ijk, U_n_cos_ijk, Ang - real(dp), dimension(3) :: u_ij, u_ik, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik, dAng_ij, dAng_ik - real(dp), dimension(:), allocatable :: Rad_ij, Rad_ik, T_cos_ijk, U_cos_ijk - real(dp), dimension(:,:), allocatable :: dRad_ij, dRad_ik - integer, dimension(total_elements) :: species_map - - INIT_ERROR(error) - - call system_timer('cosnx_calc') - - if(.not. this%initialised) then - RAISE_ERROR("cosnx_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='cosnx_calc args_str')) then - RAISE_ERROR("cosnx_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("cosnx_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - species_map = 0 - do i = 1, size(this%species_Z) - if(this%species_Z(i) == 0) then - species_map = 1 - else - species_map(this%species_Z(i)) = i - endif - enddo - - call finalise(descriptor_out) - - d = cosnx_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - allocate(Rad_ij(this%n_max), Rad_ik(this%n_max)) - allocate(T_cos_ijk(0:this%l_max)) - if(my_do_grad_descriptor) then - allocate(U_cos_ijk(-1:this%l_max)) - allocate(dRad_ij(3,this%n_max), dRad_ik(3,this%n_max)) - endif - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - - do a = 1, this%n_max - Rad_ij(a) = RadialFunction(this%Radial, r_ij, a) * this%w(species_map(at%Z(j))) - if(my_do_grad_descriptor) dRad_ij(:,a) = GradRadialFunction(this%Radial, r_ij, a) * u_ij * this%w(species_map(at%Z(j))) - enddo - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(n_i) = j - descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. - endif - - do m = 1, n_neighbours(at,i) - k = neighbour(at, i, m, distance = r_ik, cosines=u_ik, diff=d_ik) - if( r_ik >= this%cutoff ) cycle - - d_jk = d_ik - d_ij - r_jk = norm(d_jk) - if( r_jk .feq. 0.0_dp ) cycle - - cos_ijk = dot_product(u_ij,u_ik) - if(my_do_grad_descriptor) then - dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij - dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik - endif - - do a = 1, this%n_max - Rad_ik(a) = RadialFunction(this%Radial, r_ik, a) * this%w(species_map(at%Z(k))) - if(my_do_grad_descriptor) dRad_ik(:,a) = GradRadialFunction(this%Radial, r_ik, a) * u_ik * this%w(species_map(at%Z(k))) - enddo - - if(this%l_max >= 0) then - T_cos_ijk(0) = 1.0_dp - T_0_cos_ijk = T_cos_ijk(0) - if(my_do_grad_descriptor) then - U_cos_ijk(-1) = 0.0_dp - U_cos_ijk(0) = 1.0_dp - U_0_cos_ijk = U_cos_ijk(0) - endif - endif - - if(this%l_max >= 1) then - T_cos_ijk(1) = cos_ijk - T_1_cos_ijk = T_cos_ijk(1) - if(my_do_grad_descriptor) then - U_cos_ijk(1) = 2.0_dp*cos_ijk - U_1_cos_ijk = U_cos_ijk(1) - endif - endif - - do b = 2, this%l_max - T_n_cos_ijk = 2*cos_ijk*T_1_cos_ijk - T_0_cos_ijk - T_0_cos_ijk = T_1_cos_ijk - T_1_cos_ijk = T_n_cos_ijk - - T_cos_ijk(b) = T_n_cos_ijk - - if(my_do_grad_descriptor) then - U_n_cos_ijk = 2*cos_ijk*U_1_cos_ijk - U_0_cos_ijk - U_0_cos_ijk = U_1_cos_ijk - U_1_cos_ijk = U_n_cos_ijk - - U_cos_ijk(b) = U_n_cos_ijk - endif - enddo - - i_cosnx = 0 - do a = 1, this%n_max - do b = 0, this%l_max - i_cosnx = i_cosnx + 1 - - Ang = T_cos_ijk(b) - - if(my_do_descriptor) & - descriptor_out%x(i_desc)%data(i_cosnx) = descriptor_out%x(i_desc)%data(i_cosnx) + Rad_ij(a)*Rad_ik(a)*Ang*0.5_dp - - if(my_do_grad_descriptor) then - - dAng_ij = b*U_cos_ijk(b-1) * dcosijk_ij - dAng_ik = b*U_cos_ijk(b-1) * dcosijk_ik - - descriptor_out%x(i_desc)%grad_data(i_cosnx,:,0) = descriptor_out%x(i_desc)%grad_data(i_cosnx,:,0) - & - ( Rad_ij(a)*Rad_ik(a)*(dAng_ij+dAng_ik) + dRad_ij(:,a)*Rad_ik(a)*Ang + Rad_ij(a)*dRad_ik(:,a)*Ang ) * 0.5_dp - - descriptor_out%x(i_desc)%grad_data(i_cosnx,:,n_i) = descriptor_out%x(i_desc)%grad_data(i_cosnx,:,n_i) + & - (Rad_ij(a)*Rad_ik(a)*dAng_ij + dRad_ij(:,a)*Rad_ik(a)*Ang) - endif - enddo - enddo - enddo - enddo - enddo - - if(allocated(Rad_ij)) deallocate(Rad_ij) - if(allocated(Rad_ik)) deallocate(Rad_ik) - if(allocated(T_cos_ijk)) deallocate(T_cos_ijk) - if(allocated(U_cos_ijk)) deallocate(U_cos_ijk) - if(allocated(dRad_ij)) deallocate(dRad_ij) - if(allocated(dRad_ik)) deallocate(dRad_ik) - - call system_timer('cosnx_calc') - - endsubroutine cosnx_calc - - subroutine trihis_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(trihis), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, k, n, m, i_desc, n_index - integer, dimension(3) :: shift_ij - real(dp) :: r_ij, r_ik, r_jk, cos_ijk, Sym_Cor_S, Sym_Cor_A, exp_desc - real(dp), dimension(3) :: u_ij, u_ik, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik, x, exp_arg, dexp_desc - real(dp), dimension(3,3) :: dx_j, dx_k - - INIT_ERROR(error) - - call system_timer('trihis_calc') - - if(.not. this%initialised) then - RAISE_ERROR("trihis_calc: descriptor object not initialised", error) - endif - RAISE_ERROR("trihis_calc: ab686 noticed that this routine needs updating. Remove this line if you know what you are doing, then proceed.", error) - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='trihis_calc args_str')) then - RAISE_ERROR("trihis_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("trihis_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("trihis_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = trihis_dimensions(this,error) - - allocate(descriptor_out%x(at%N)) - do i = 1, at%N - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%has_data = .false. - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,0:n_neighbours(at,i))) - allocate(descriptor_out%x(i)%ii(0:n_neighbours(at,i))) - allocate(descriptor_out%x(i)%pos(3,0:n_neighbours(at,i))) - allocate(descriptor_out%x(i)%has_grad_data(0:n_neighbours(at,i))) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - endif - enddo - - do i = 1, at%N - - if(my_do_descriptor) then - descriptor_out%x(i)%ci(1) = i - descriptor_out%x(i)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i)%ii(0) = i - descriptor_out%x(i)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i)%has_grad_data(0) = .true. - endif - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - if(my_do_grad_descriptor) then - descriptor_out%x(i)%ii(n) = j - descriptor_out%x(i)%pos(:,n) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i)%has_grad_data(n) = .true. - endif - - do m = 1, n_neighbours(at,i) - k = neighbour(at, i, m, distance = r_ik, cosines=u_ik, diff=d_ik) - if( r_ik >= this%cutoff ) cycle - - d_jk = d_ik - d_ij - r_jk = norm(d_jk) - if( r_jk .feq. 0.0_dp ) cycle - - cos_ijk = dot_product(u_ij,u_ik) - Sym_Cor_S = r_ij + r_ik - Sym_Cor_A = (r_ij - r_ik)**2 - - x = (/Sym_Cor_S, Sym_Cor_A, cos_ijk/) - - if(my_do_grad_descriptor) then - dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij - dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik - - dx_j(:,1) = u_ij - dx_j(:,2) = 2.0_dp*(r_ij - r_ik)*u_ij - dx_j(:,3) = dcosijk_ij - - dx_k(:,1) = u_ik - dx_k(:,2) = -2.0_dp*(r_ij - r_ik)*u_ik - dx_k(:,3) = dcosijk_ik - endif - - do i_desc = 1, this%n_gauss - - exp_arg = (x - this%gauss_centre(:,i_desc))/this%gauss_width(:,i_desc) - exp_desc = exp(-0.5_dp*sum(exp_arg**2)) - - if(my_do_descriptor) & - descriptor_out%x(i)%data(i_desc) = descriptor_out%x(i)%data(i_desc) + exp_desc - - if(my_do_grad_descriptor) then - dexp_desc = -exp_desc * exp_arg / this%gauss_width(:,i_desc) - - descriptor_out%x(i)%grad_data(i_desc,:,0) = descriptor_out%x(i)%grad_data(i_desc,:,0) - & - matmul(dx_j+dx_k,dexp_desc) - descriptor_out%x(i)%grad_data(i_desc,:,n) = descriptor_out%x(i)%grad_data(i_desc,:,n) + & - 2.0_dp*matmul(dx_j,dexp_desc) - endif - enddo - enddo - enddo - enddo - - call system_timer('trihis_calc') - - endsubroutine trihis_calc - - subroutine water_monomer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(water_monomer), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, n_descriptors, n_cross, i, iO, iH1, iH2, n_index - integer :: i_desc, mpi_n_procs, mpi_my_proc - integer, dimension(3) :: shift_1, shift_2 - integer, dimension(:,:), allocatable :: water_monomer_index - real(dp) :: r1, r2 - real(dp), dimension(3) :: v1, v2, u1, u2 - - INIT_ERROR(error) - - call system_timer('water_monomer_calc') - - if(.not. this%initialised) then - RAISE_ERROR("water_monomer_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='water_monomer_calc args_str')) then - RAISE_ERROR("water_monomer_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("water_monomer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - d = water_monomer_dimensions(this,error) - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index, error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index, error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%has_data = .false. - descriptor_out%x(i)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,3)) - allocate(descriptor_out%x(i)%ii(3)) - allocate(descriptor_out%x(i)%pos(3,3)) - allocate(descriptor_out%x(i)%has_grad_data(3)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,3)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - allocate(water_monomer_index(3,count(at%Z==8))) - call find_water_monomer(at,water_monomer_index,error=error) - - i_desc = 0 - do i = 1, count(at%Z==8) - - iO = water_monomer_index(1,i) - iH1 = water_monomer_index(2,i) - iH2 = water_monomer_index(3,i) - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(iO)) cycle - endif - i_desc = i_desc + 1 - - v1 = diff_min_image(at,iO,iH1,shift=shift_1) - v2 = diff_min_image(at,iO,iH2,shift=shift_2) - r1 = sqrt(dot_product(v1,v1)) - r2 = sqrt(dot_product(v2,v2)) - u1 = v1 / r1 - u2 = v2 / r2 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(:) = water_monomer_index(:,i) - descriptor_out%x(i_desc)%has_data = .true. - descriptor_out%x(i_desc)%data(1) = r1+r2 - descriptor_out%x(i_desc)%data(2) = (r1-r2)**2 - descriptor_out%x(i_desc)%data(3) = dot_product(v1,v2) - endif - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(:) = water_monomer_index(:,i) - descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,iO) - descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,iH1) + matmul(at%lattice,shift_1) - descriptor_out%x(i_desc)%pos(:,3) = at%pos(:,iH2) + matmul(at%lattice,shift_2) - descriptor_out%x(i_desc)%has_grad_data(:) = .true. - - descriptor_out%x(i_desc)%grad_data(1,:,1) = -u1-u2 ! 1st descriptor wrt rO - descriptor_out%x(i_desc)%grad_data(1,:,2) = u1 ! 1st descriptor wrt rH1 - descriptor_out%x(i_desc)%grad_data(1,:,3) = u2 ! 1st descriptor wrt rH2 - descriptor_out%x(i_desc)%grad_data(2,:,1) = 2.0_dp*(r1-r2)*(u2-u1) ! 2nd descriptor wrt rO - descriptor_out%x(i_desc)%grad_data(2,:,2) = 2.0_dp*(r1-r2)*u1 ! 2nd descriptor wrt rH1 - descriptor_out%x(i_desc)%grad_data(2,:,3) = -2.0_dp*(r1-r2)*u2 ! 2nd descriptor wrt rH2 - descriptor_out%x(i_desc)%grad_data(3,:,1) = -v1-v2 ! 3rd descriptor wrt rO - descriptor_out%x(i_desc)%grad_data(3,:,2) = v2 ! 3rd descriptor wrt rH1 - descriptor_out%x(i_desc)%grad_data(3,:,3) = v1 ! 3rd descriptor wrt rH2 - endif - - enddo - - deallocate(water_monomer_index) - call system_timer('water_monomer_calc') - - endsubroutine water_monomer_calc - - subroutine water_dimer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(water_dimer), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, n_descriptors, n_cross, n_monomers, i_desc, i, j, n, & - iAO, iAH1, iAH2, iBO, iBH1, iBH2, i_distance, n_index - integer :: mpi_n_procs, mpi_my_proc - integer, dimension(3) :: shift_AO_BO, shift_AO_AH1, shift_AO_AH2, shift_AO_BH1, shift_AO_BH2, & - shift_BO_AH1, shift_BO_AH2, shift_BO_BH1, shift_BO_BH2, & - shift_AH1_AH2, shift_AH1_BH1, shift_AH1_BH2, shift_AH2_BH1, shift_AH2_BH2, shift_BH1_BH2 - real(dp), dimension(3) :: diff_AO_BO, diff_AO_AH1, diff_AO_AH2, diff_AO_BH1, diff_AO_BH2, & - diff_BO_AH1, diff_BO_AH2, diff_BO_BH1, diff_BO_BH2, & - diff_AH1_AH2, diff_AH1_BH1, diff_AH1_BH2, diff_AH2_BH1, diff_AH2_BH2, diff_BH1_BH2 - integer, dimension(:,:), allocatable :: water_monomer_index - real(dp) :: r_AO_BO, r_AO_AH1, r_AO_AH2, r_AO_BH1, r_AO_BH2, r_BO_AH1, r_BO_AH2, r_BO_BH1, r_BO_BH2, & - r_AH1_AH2, r_AH1_BH1, r_AH1_BH2, r_AH2_BH1, r_AH2_BH2, r_BH1_BH2 - integer, dimension(1) :: j_array - real(dp), dimension(15) :: distances - - INIT_ERROR(error) - - call system_timer('water_dimer_calc') - - if(.not. this%initialised) then - RAISE_ERROR("water_dimer_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='water_dimer_calc args_str')) then - RAISE_ERROR("water_dimer_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("water_dimer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - d = water_dimer_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%has_data = .false. - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,6)) - allocate(descriptor_out%x(i)%ii(6)) - allocate(descriptor_out%x(i)%pos(3,6)) - allocate(descriptor_out%x(i)%has_grad_data(6)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,6)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - - endif - enddo - - n_monomers = 0 - do i = 1, at%N - if(at%Z(i) == 8) n_monomers = n_monomers+1 - enddo - - allocate(water_monomer_index(3,n_monomers)) - call find_water_monomer(at,water_monomer_index,OHH_ordercheck=this%OHH_ordercheck,monomer_cutoff=this%monomer_cutoff,error=error) - - i_desc = 0 - do i = 1, n_monomers - iAO = water_monomer_index(1,i) - iAH1 = water_monomer_index(2,i) - iAH2 = water_monomer_index(3,i) - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(iAO)) cycle - endif - - diff_AO_AH1 = diff_min_image(at,iAO,iAH1,shift=shift_AO_AH1) - diff_AO_AH2 = diff_min_image(at,iAO,iAH2,shift=shift_AO_AH2) - diff_AH1_AH2 = diff_min_image(at,iAH1,iAH2,shift=shift_AH1_AH2) - - r_AO_AH1 = norm(diff_AO_AH1) - r_AO_AH2 = norm(diff_AO_AH2) - r_AH1_AH2 = norm(diff_AH1_AH2) - - do n = 1, n_neighbours(at,iAO) - iBO = neighbour(at,iAO,n,distance=r_AO_BO, diff=diff_AO_BO, shift=shift_AO_BO ) - if(at%Z(iBO) /= 8) cycle - if( r_AO_BO >= this%cutoff ) cycle - i_desc = i_desc + 1 - j_array = find(water_monomer_index(1,:) == iBO) - j = j_array(1) - - iBH1 = water_monomer_index(2,j) - iBH2 = water_monomer_index(3,j) - - diff_BO_BH1 = diff_min_image(at,iBO,iBH1,shift=shift_BO_BH1) - diff_BO_BH2 = diff_min_image(at,iBO,iBH2,shift=shift_BO_BH2) - diff_BH1_BH2 = diff_min_image(at,iBH1,iBH2,shift=shift_BH1_BH2) - - r_BO_BH1 = norm(diff_BO_BH1) - r_BO_BH2 = norm(diff_BO_BH2) - r_BH1_BH2 = norm(diff_BH1_BH2) - - diff_AO_BH1 = diff_AO_BO + diff_BO_BH1 - diff_AO_BH2 = diff_AO_BO + diff_BO_BH2 - shift_AO_BH1 = shift_AO_BO + shift_BO_BH1 - shift_AO_BH2 = shift_AO_BO + shift_BO_BH2 - - r_AO_BH1 = norm(diff_AO_BH1) - r_AO_BH2 = norm(diff_AO_BH2) - - diff_BO_AH1 = -diff_AO_BO + diff_AO_AH1 - diff_BO_AH2 = -diff_AO_BO + diff_AO_AH2 - - shift_BO_AH1 = -shift_AO_BO + shift_AO_AH1 - shift_BO_AH2 = -shift_AO_BO + shift_AO_AH2 - - r_BO_AH1 = norm(diff_BO_AH1) - r_BO_AH2 = norm(diff_BO_AH2) - - diff_AH1_BH1 = -diff_AO_AH1 + diff_AO_BO + diff_BO_BH1 - diff_AH1_BH2 = -diff_AO_AH1 + diff_AO_BO + diff_BO_BH2 - diff_AH2_BH1 = -diff_AO_AH2 + diff_AO_BO + diff_BO_BH1 - diff_AH2_BH2 = -diff_AO_AH2 + diff_AO_BO + diff_BO_BH2 - - shift_AH1_BH1 = -shift_AO_AH1 + shift_AO_BO + shift_BO_BH1 - shift_AH1_BH2 = -shift_AO_AH1 + shift_AO_BO + shift_BO_BH2 - shift_AH2_BH1 = -shift_AO_AH2 + shift_AO_BO + shift_BO_BH1 - shift_AH2_BH2 = -shift_AO_AH2 + shift_AO_BO + shift_BO_BH2 - - r_AH1_BH1 = norm(diff_AH1_BH1) - r_AH1_BH2 = norm(diff_AH1_BH2) - r_AH2_BH1 = norm(diff_AH2_BH1) - r_AH2_BH2 = norm(diff_AH2_BH2) - - - distances = (/r_AO_BO, & - r_AO_AH1, r_AO_AH2, r_AO_BH1, r_AO_BH2, r_BO_AH1, r_BO_AH2, r_BO_BH1, r_BO_BH2, & - r_AH1_AH2, r_AH1_BH1, r_AH1_BH2, r_AH2_BH1, r_AH2_BH2, r_BH1_BH2/) - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(:) = (/ water_monomer_index(:,i),water_monomer_index(:,j) /) - descriptor_out%x(i_desc)%has_data = .true. - descriptor_out%x(i_desc)%data(:) = (distances+this%dist_shift)**this%power - - descriptor_out%x(i_desc)%covariance_cutoff = coordination_function(r_AO_BO, & - this%cutoff,this%cutoff_transition_width) - endif - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(:) = (/ water_monomer_index(:,i),water_monomer_index(:,j) /) - descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,iAO) ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,iAH1) + matmul(at%lattice,shift_AO_AH1) ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%pos(:,3) = at%pos(:,iAH2) + matmul(at%lattice,shift_AO_AH2) ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%pos(:,4) = at%pos(:,iBO) + matmul(at%lattice,shift_AO_BO) ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%pos(:,5) = at%pos(:,iBH1) + matmul(at%lattice,shift_AO_BH1) ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%pos(:,6) = at%pos(:,iBH2) + matmul(at%lattice,shift_AO_BH2) ! TODO: Have to figure out how to do this. - - descriptor_out%x(i_desc)%has_grad_data(:) = .true. - - descriptor_out%x(i_desc)%grad_data(1,:,1) = -diff_AO_BO / r_AO_BO ! 1st descriptor wrt OA - descriptor_out%x(i_desc)%grad_data(1,:,4) = -descriptor_out%x(i_desc)%grad_data(1,:,1) ! 1st descriptor wrt OB - - descriptor_out%x(i_desc)%grad_data(2,:,1) = -diff_AO_AH1 / r_AO_AH1 ! 2nd descriptor wrt OA - descriptor_out%x(i_desc)%grad_data(2,:,2) = -descriptor_out%x(i_desc)%grad_data(2,:,1) ! 2nd descriptor wrt AH1 - descriptor_out%x(i_desc)%grad_data(3,:,1) = -diff_AO_AH2 / r_AO_AH2 ! 3rd descriptor wrt OA - descriptor_out%x(i_desc)%grad_data(3,:,3) = -descriptor_out%x(i_desc)%grad_data(3,:,1) ! 3rd descriptor wrt AH2 - descriptor_out%x(i_desc)%grad_data(4,:,1) = -diff_AO_BH1 / r_AO_BH1 ! 4th descriptor wrt OA - descriptor_out%x(i_desc)%grad_data(4,:,5) = -descriptor_out%x(i_desc)%grad_data(4,:,1) ! 4th descriptor wrt BH1 - descriptor_out%x(i_desc)%grad_data(5,:,1) = -diff_AO_BH2 / r_AO_BH2 ! 5th descriptor wrt OA - descriptor_out%x(i_desc)%grad_data(5,:,6) = -descriptor_out%x(i_desc)%grad_data(5,:,1) ! 5th descriptor wrt BH2 - - descriptor_out%x(i_desc)%grad_data(6,:,4) = -diff_BO_AH1 / r_BO_AH1 ! 6th descriptor wrt OB - descriptor_out%x(i_desc)%grad_data(6,:,2) = -descriptor_out%x(i_desc)%grad_data(6,:,4) ! 6th descriptor wrt AH1 - descriptor_out%x(i_desc)%grad_data(7,:,4) = -diff_BO_AH2 / r_BO_AH2 ! 7th descriptor wrt OB - descriptor_out%x(i_desc)%grad_data(7,:,3) = -descriptor_out%x(i_desc)%grad_data(7,:,4) ! 7th descriptor wrt AH2 - descriptor_out%x(i_desc)%grad_data(8,:,4) = -diff_BO_BH1 / r_BO_BH1 ! 8th descriptor wrt OB - descriptor_out%x(i_desc)%grad_data(8,:,5) = -descriptor_out%x(i_desc)%grad_data(8,:,4) ! 8th descriptor wrt BH1 - descriptor_out%x(i_desc)%grad_data(9,:,4) = -diff_BO_BH2 / r_BO_BH2 ! 9th descriptor wrt OB - descriptor_out%x(i_desc)%grad_data(9,:,6) = -descriptor_out%x(i_desc)%grad_data(9,:,4) ! 9th descriptor wrt BH2 - - descriptor_out%x(i_desc)%grad_data(10,:,2) = -diff_AH1_AH2 / r_AH1_AH2 ! 10th descriptor wrt AH1 - descriptor_out%x(i_desc)%grad_data(10,:,3) = -descriptor_out%x(i_desc)%grad_data(10,:,2) ! 10th descriptor wrt AH2 - descriptor_out%x(i_desc)%grad_data(11,:,2) = -diff_AH1_BH1 / r_AH1_BH1 ! 11th descriptor wrt AH1 - descriptor_out%x(i_desc)%grad_data(11,:,5) = -descriptor_out%x(i_desc)%grad_data(11,:,2) ! 11th descriptor wrt BH1 - descriptor_out%x(i_desc)%grad_data(12,:,2) = -diff_AH1_BH2 / r_AH1_BH2 ! 12th descriptor wrt AH1 - descriptor_out%x(i_desc)%grad_data(12,:,6) = -descriptor_out%x(i_desc)%grad_data(12,:,2) ! 12th descriptor wrt BH2 - - descriptor_out%x(i_desc)%grad_data(13,:,3) = -diff_AH2_BH1 / r_AH2_BH1 ! 13th descriptor wrt AH2 - descriptor_out%x(i_desc)%grad_data(13,:,5) = -descriptor_out%x(i_desc)%grad_data(13,:,3) ! 13th descriptor wrt BH1 - descriptor_out%x(i_desc)%grad_data(14,:,3) = -diff_AH2_BH2 / r_AH2_BH2 ! 14th descriptor wrt AH2 - descriptor_out%x(i_desc)%grad_data(14,:,6) = -descriptor_out%x(i_desc)%grad_data(14,:,3) ! 14th descriptor wrt BH2 - - descriptor_out%x(i_desc)%grad_data(15,:,5) = -diff_BH1_BH2 / r_BH1_BH2 ! 15th descriptor wrt BH1 - descriptor_out%x(i_desc)%grad_data(15,:,6) = -descriptor_out%x(i_desc)%grad_data(15,:,5) ! 15th descriptor wrt BH2 - - do i_distance = 1, 15 - descriptor_out%x(i_desc)%grad_data(i_distance,:,:) = descriptor_out%x(i_desc)%grad_data(i_distance,:,:) * & - (distances(i_distance)+this%dist_shift)**(this%power-1.0_dp) * this%power - enddo - - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -dcoordination_function(r_AO_BO,& - this%cutoff,this%cutoff_transition_width) * diff_AO_BO / r_AO_BO - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,4) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) - endif - enddo - enddo - - deallocate(water_monomer_index) - call system_timer('water_dimer_calc') - - endsubroutine water_dimer_calc - - subroutine A2_dimer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(A2_dimer), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, n_descriptors, n_cross, n_monomers, i_desc, i, j, & - iA1, iA2, iB1, iB2, n_index - integer, dimension(3) :: shift_A1_A2, shift_A1_B1, shift_A1_B2, shift_A2_B1, shift_A2_B2, shift_B1_B2 - integer, dimension(at%N) :: A2_monomer_index - real(dp) :: r_A1_A2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2, r_B1_B2 - - INIT_ERROR(error) - - call system_timer('A2_dimer_calc') - - if(.not. this%initialised) then - RAISE_ERROR("A2_dimer_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='A2_dimer_calc args_str')) then - RAISE_ERROR("A2_dimer_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("A2_dimer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("A2_dimer_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = A2_dimer_dimensions(this,error) - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%has_data = .false. - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,4)) - allocate(descriptor_out%x(i)%ii(4)) - allocate(descriptor_out%x(i)%pos(3,4)) - allocate(descriptor_out%x(i)%has_grad_data(4)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,4)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - n_monomers = count(at%Z == this%atomic_number) / 2 - - call find_A2_monomer(at,this%atomic_number, this%monomer_cutoff, A2_monomer_index,error) - - i_desc = 0 - do i = 1, at%N - iA1 = i - iA2 = neighbour(at,i,A2_monomer_index(i),distance=r_A1_A2,shift=shift_A1_A2) - if( iA1 > iA2 ) cycle - - do j = i + 1, at%N - iB1 = j - iB2 = neighbour(at,j,A2_monomer_index(j),distance=r_B1_B2,shift=shift_B1_B2) - if( iB1 > iB2 ) cycle - - r_A1_B1 = distance_min_image(at,iA1,iB1,shift=shift_A1_B1) - r_A1_B2 = distance_min_image(at,iA1,iB2,shift=shift_A1_B2) - - r_A2_B1 = distance_min_image(at,iA2,iB1,shift=shift_A2_B1) - r_A2_B2 = distance_min_image(at,iA2,iB2,shift=shift_A2_B2) - - if( any( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) >= this%cutoff) ) cycle - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(:) = (/ iA1, iA2, iB1, iB2 /) - descriptor_out%x(i_desc)%has_data = .true. - descriptor_out%x(i_desc)%data(:) = (/ r_A1_A2, r_B1_B2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2/) - endif - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(:) = (/ iA1, iA2, iB1, iB2 /) - descriptor_out%x(i_desc)%pos(:,:) = 0.0_dp ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%has_grad_data(:) = .true. - - descriptor_out%x(i_desc)%grad_data(1,:,1) = -diff(at,iA1,iA2,shift=shift_A1_A2) / r_A1_A2 ! 1st descriptor wrt A1 - descriptor_out%x(i_desc)%grad_data(1,:,2) = -descriptor_out%x(i_desc)%grad_data(1,:,1) ! 1st descriptor wrt A2 - descriptor_out%x(i_desc)%grad_data(2,:,3) = -diff(at,iB1,iB2,shift=shift_B1_B2) / r_B1_B2 ! 2nd descriptor wrt B1 - descriptor_out%x(i_desc)%grad_data(2,:,4) = -descriptor_out%x(i_desc)%grad_data(2,:,3) ! 2nd descriptor wrt B2 - - descriptor_out%x(i_desc)%grad_data(3,:,1) = -diff(at,iA1,iB1,shift=shift_A1_B1) / r_A1_B1 ! 3rd descriptor wrt A1 - descriptor_out%x(i_desc)%grad_data(3,:,3) = -descriptor_out%x(i_desc)%grad_data(3,:,1) ! 3rd descriptor wrt B1 - descriptor_out%x(i_desc)%grad_data(4,:,1) = -diff(at,iA1,iB2,shift=shift_A1_B2) / r_A1_B2 ! 4th descriptor wrt A1 - descriptor_out%x(i_desc)%grad_data(4,:,4) = -descriptor_out%x(i_desc)%grad_data(4,:,1) ! 4th descriptor wrt B2 - - descriptor_out%x(i_desc)%grad_data(5,:,2) = -diff(at,iA2,iB1,shift=shift_A2_B1) / r_A2_B1 ! 5th descriptor wrt A2 - descriptor_out%x(i_desc)%grad_data(5,:,3) = -descriptor_out%x(i_desc)%grad_data(5,:,2) ! 5th descriptor wrt B1 - descriptor_out%x(i_desc)%grad_data(6,:,2) = -diff(at,iA2,iB2,shift=shift_A2_B2) / r_A2_B2 ! 6th descriptor wrt A2 - descriptor_out%x(i_desc)%grad_data(6,:,4) = -descriptor_out%x(i_desc)%grad_data(6,:,2) ! 6th descriptor wrt B2 - - endif - enddo - enddo - - call system_timer('A2_dimer_calc') - - endsubroutine A2_dimer_calc - - subroutine AB_dimer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(AB_dimer), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, n_descriptors, n_cross, n_monomers, i_desc, i, j, & - iA1, iA2, iB1, iB2, n_index - integer, dimension(3) :: shift_A1_A2, shift_A1_B1, shift_A1_B2, shift_A2_B1, shift_A2_B2, shift_B1_B2 - integer, dimension(:,:), allocatable :: AB_monomer_index - real(dp) :: r_A1_A2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2, r_B1_B2 - - INIT_ERROR(error) - - call system_timer('AB_dimer_calc') - - if(.not. this%initialised) then - RAISE_ERROR("AB_dimer_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='AB_dimer_calc args_str')) then - RAISE_ERROR("AB_dimer_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("AB_dimer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("AB_dimer_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = AB_dimer_dimensions(this,error) - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%has_data = .false. - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,4)) - allocate(descriptor_out%x(i)%ii(4)) - allocate(descriptor_out%x(i)%pos(3,4)) - allocate(descriptor_out%x(i)%has_grad_data(4)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,4)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - if( count(at%Z == this%atomic_number1) == count(at%Z == this%atomic_number2) ) then - n_monomers = count(at%Z == this%atomic_number1) - else - RAISE_ERROR("AB_dimer_calc: number of monomer atoms 1 ("//count(at%Z == this%atomic_number1)//") not equal to number of monomer atoms 2 ("//count(at%Z == this%atomic_number1)//")",error) - endif - - allocate(AB_monomer_index(2,n_monomers)) - call find_AB_monomer(at,(/this%atomic_number1,this%atomic_number2/), this%monomer_cutoff, AB_monomer_index,error) - - i_desc = 0 - do i = 1, n_monomers - iA1 = AB_monomer_index(1,i) - iB1 = AB_monomer_index(2,i) - do j = i + 1, n_monomers - iA2 = AB_monomer_index(1,j) - iB2 = AB_monomer_index(2,j) - - - r_A1_B1 = distance_min_image(at,iA1,iB1,shift=shift_A1_B1) - r_A2_B2 = distance_min_image(at,iA2,iB2,shift=shift_A2_B2) - - r_A1_A2 = distance_min_image(at,iA1,iA2,shift=shift_A1_A2) - r_B1_B2 = distance_min_image(at,iB1,iB2,shift=shift_B1_B2) - - r_A1_B2 = distance_min_image(at,iA1,iB2,shift=shift_A1_B2) - r_A2_B1 = distance_min_image(at,iA2,iB1,shift=shift_A2_B1) - - if( any( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) >= this%cutoff) ) cycle - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(:) = (/ AB_monomer_index(:,i),AB_monomer_index(:,j) /) - descriptor_out%x(i_desc)%has_data = .true. - descriptor_out%x(i_desc)%data(:) = (/ r_A1_B1, r_A2_B2, r_A1_A2, r_B1_B2, r_A1_B2, r_A2_B1 /) - endif - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(:) = (/ AB_monomer_index(:,i),AB_monomer_index(:,j) /) - descriptor_out%x(i_desc)%pos(:,:) = 0.0_dp ! TODO: Have to figure out how to do this. - descriptor_out%x(i_desc)%has_grad_data(:) = .true. - - descriptor_out%x(i_desc)%grad_data(1,:,1) = -diff(at,iA1,iB1,shift=shift_A1_B1) / r_A1_B1 ! 1st descriptor wrt A1 - descriptor_out%x(i_desc)%grad_data(1,:,2) = -descriptor_out%x(i_desc)%grad_data(1,:,1) ! 1st descriptor wrt B1 - descriptor_out%x(i_desc)%grad_data(2,:,3) = -diff(at,iA2,iB2,shift=shift_A2_B2) / r_A2_B2 ! 2nd descriptor wrt A2 - descriptor_out%x(i_desc)%grad_data(2,:,4) = -descriptor_out%x(i_desc)%grad_data(2,:,3) ! 2nd descriptor wrt B2 - - descriptor_out%x(i_desc)%grad_data(3,:,1) = -diff(at,iA1,iA2,shift=shift_A1_A2) / r_A1_A2 ! 1st descriptor wrt A1 - descriptor_out%x(i_desc)%grad_data(3,:,3) = -descriptor_out%x(i_desc)%grad_data(3,:,1) ! 1st descriptor wrt A2 - descriptor_out%x(i_desc)%grad_data(4,:,2) = -diff(at,iB1,iB2,shift=shift_B1_B2) / r_B1_B2 ! 2nd descriptor wrt B1 - descriptor_out%x(i_desc)%grad_data(4,:,4) = -descriptor_out%x(i_desc)%grad_data(4,:,2) ! 2nd descriptor wrt B2 - - descriptor_out%x(i_desc)%grad_data(5,:,1) = -diff(at,iA1,iB2,shift=shift_A1_B2) / r_A1_B2 ! 4th descriptor wrt A1 - descriptor_out%x(i_desc)%grad_data(5,:,4) = -descriptor_out%x(i_desc)%grad_data(5,:,1) ! 4th descriptor wrt B2 - descriptor_out%x(i_desc)%grad_data(6,:,3) = -diff(at,iA2,iB1,shift=shift_A2_B1) / r_A2_B1 ! 5th descriptor wrt A2 - descriptor_out%x(i_desc)%grad_data(6,:,2) = -descriptor_out%x(i_desc)%grad_data(6,:,3) ! 5th descriptor wrt B1 - - endif - enddo - enddo - - deallocate(AB_monomer_index) - call system_timer('AB_dimer_calc') - - endsubroutine AB_dimer_calc - - - subroutine atom_real_space_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(atom_real_space), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, grad_d, n_descriptors, n_cross, descriptor_mould_size, & - i_desc, i_data, i, j, k, n, l, m, l_n_neighbours, i_n, n_index - - real(dp) :: r - real(dp), dimension(3) :: diff - real(dp), dimension(1) :: descriptor_mould - integer, dimension(3) :: shift - - complex(dp), dimension(:), allocatable :: spherical_harmonics - complex(dp), dimension(:,:), allocatable :: grad_spherical_harmonics - - INIT_ERROR(error) - - call system_timer('atom_real_space_calc') - - if(.not. this%initialised) then - RAISE_ERROR("atom_real_space_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='atom_real_space_calc args_str')) then - RAISE_ERROR("atom_real_space_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("atom_real_space_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("atom_real_space_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - - allocate(descriptor_out%x(n_descriptors)) - - i_desc = 0 - do i = 1, at%N - i_desc = i_desc + 1 - - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - d = ( 2 * (this%l_max+1)**2 + 2 ) * l_n_neighbours - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - grad_d = 2 * (this%l_max+1)**2 + 2 - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,1:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(1:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,1:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(1:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,1:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - allocate(spherical_harmonics(-this%l_max:this%l_max)) - if( my_do_grad_descriptor ) allocate(grad_spherical_harmonics(3,-this%l_max:this%l_max)) - - i_desc = 0 - do i = 1, at%N - i_desc = i_desc + 1 - i_data = 0 - i_n = 0 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - - if(my_do_grad_descriptor) then - !descriptor_out%x(i_desc)%ii(0) = i - !descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - !descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - do n = 1, n_neighbours(at,i) - - j = neighbour(at,i,n,distance = r, diff = diff, shift=shift) - if(r >= this%cutoff) cycle - i_n = i_n + 1 - - i_data = i_data + 1 - if(my_do_descriptor) then - descriptor_out%x(i_desc)%data(i_data) = r - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(i_n) = j - descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. - descriptor_out%x(i_desc)%grad_data(i_data,:,i_n) = diff / r - endif - - i_data = i_data + 1 - if(my_do_descriptor) descriptor_out%x(i_desc)%data(i_data) = real(i_n,dp) - if(my_do_grad_descriptor) descriptor_out%x(i_desc)%grad_data(i_data,:,i_n) = real(i_n,dp) - - do l = 0, this%l_max - descriptor_mould_size = size(transfer(spherical_harmonics(-l:l),descriptor_mould)) - - do m = -l, l - if(my_do_descriptor) spherical_harmonics(m) = SphericalYCartesian(l,m,diff) - if(my_do_grad_descriptor) grad_spherical_harmonics(:,m) = GradSphericalYCartesian(l,m,diff) - enddo - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%data(i_data+1:i_data+descriptor_mould_size) = transfer(spherical_harmonics(-l:l),descriptor_mould) - endif - - if(my_do_grad_descriptor) then - do k = 1, 3 - descriptor_out%x(i_desc)%grad_data(i_data+1:i_data+descriptor_mould_size,k,i_n) = & - transfer(grad_spherical_harmonics(k,-l:l),descriptor_mould) - enddo - endif - - i_data = i_data + descriptor_mould_size - - enddo - enddo - enddo - - if(allocated(spherical_harmonics)) deallocate(spherical_harmonics) - if(allocated(grad_spherical_harmonics)) deallocate(grad_spherical_harmonics) - - call system_timer('atom_real_space_calc') - - endsubroutine atom_real_space_calc - - subroutine power_so3_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(power_so3), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - type(cplx_1d), dimension(:), allocatable :: SphericalY_ij - type(cplx_1d), dimension(:,:), allocatable :: fourier_so3 - - type(cplx_2d), dimension(:), allocatable :: dSphericalY_ij - type(cplx_2d), dimension(:,:,:), allocatable :: dfourier_so3 - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, n, a, l, m, i_desc, i_pow, l_n_neighbours, n_i, & - n_descriptors, n_cross, n_index - integer, dimension(3) :: shift_ij - real(dp) :: r_ij - real(dp), dimension(3) :: u_ij, d_ij - real(dp), dimension(:), allocatable :: Rad_ij - real(dp), dimension(:,:), allocatable :: dRad_ij - integer, dimension(total_elements) :: species_map - - INIT_ERROR(error) - - call system_timer('power_so3_calc') - - if(.not. this%initialised) then - RAISE_ERROR("power_so3_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='power_so3_calc args_str')) then - RAISE_ERROR("power_so3_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("power_so3_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - species_map = 0 - do i = 1, size(this%species_Z) - if(this%species_Z(i) == 0) then - species_map = 1 - else - species_map(this%species_Z(i)) = i - endif - enddo - - call finalise(descriptor_out) - - d = power_so3_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross,& - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - descriptor_out%x(i_desc)%has_data = .false. - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - allocate(fourier_so3(0:this%l_max,this%n_max),SphericalY_ij(0:this%l_max),Rad_ij(this%n_max)) - do a = 1, this%n_max - do l = 0, this%l_max - allocate(fourier_so3(l,a)%m(-l:l)) - fourier_so3(l,a)%m(:) = CPLX_ZERO - enddo - enddo - do l = 0, this%l_max - allocate(SphericalY_ij(l)%m(-l:l)) - enddo - - if(my_do_grad_descriptor) then - allocate( dRad_ij(3,this%n_max), dSphericalY_ij(0:this%l_max) ) - do l = 0, this%l_max - allocate(dSphericalY_ij(l)%mm(3,-l:l)) - enddo - endif - - i_desc = 0 - do i = 1, at%N - - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - do a = 1, this%n_max - do l = 0, this%l_max - fourier_so3(l,a)%m(:) = CPLX_ZERO - enddo - enddo - - if(my_do_grad_descriptor) then - allocate( dfourier_so3(0:this%l_max,this%n_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) - do n = 0, n_neighbours(at,i,max_dist=this%cutoff) - do a = 1, this%n_max - do l = 0, this%l_max - allocate(dfourier_so3(l,a,n)%mm(3,-l:l)) - dfourier_so3(l,a,n)%mm(:,:) = CPLX_ZERO - enddo - enddo - enddo - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(n_i) = j - descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. - endif - - do a = 1, this%n_max - Rad_ij(a) = RadialFunction(this%Radial, r_ij, a) - if(my_do_grad_descriptor) dRad_ij(:,a) = GradRadialFunction(this%Radial, r_ij, a) * u_ij - enddo - - do l = 0, this%l_max - do m = -l, l - SphericalY_ij(l)%m(m) = SphericalYCartesian(l,m,d_ij) - if(my_do_grad_descriptor) dSphericalY_ij(l)%mm(:,m) = GradSphericalYCartesian(l,m,d_ij) - enddo - enddo - - do a = 1, this%n_max - do l = 0, this%l_max - do m = -l, l - fourier_so3(l,a)%m(m) = fourier_so3(l,a)%m(m) + Rad_ij(a)*SphericalY_ij(l)%m(m) - if(my_do_grad_descriptor) then - dfourier_so3(l,a,n_i)%mm(:,m) = dfourier_so3(l,a,n_i)%mm(:,m) + & - dRad_ij(:,a) * SphericalY_ij(l)%m(m) + Rad_ij(a)*dSphericalY_ij(l)%mm(:,m) - endif - enddo - enddo - enddo - - enddo ! n - - if(my_do_descriptor) then - i_pow = 0 - do a = 1, this%n_max - do l = 0, this%l_max - i_pow = i_pow + 1 - - descriptor_out%x(i_desc)%data(i_pow) = dot_product(fourier_so3(l,a)%m,fourier_so3(l,a)%m) - enddo - enddo - endif - - if(my_do_grad_descriptor) then - do n = 1, n_neighbours(at,i,max_dist=this%cutoff) - i_pow = 0 - do a = 1, this%n_max - do l = 0, this%l_max - i_pow = i_pow + 1 - - descriptor_out%x(i_desc)%grad_data(i_pow,:,n) = 2.0_dp * matmul(conjg(dfourier_so3(l,a,n)%mm(:,:)),fourier_so3(l,a)%m(:)) - enddo - enddo - descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,n) - enddo - endif - - if(allocated(dfourier_so3)) then - do n = lbound(dfourier_so3,3), ubound(dfourier_so3,3) - do a = lbound(dfourier_so3,2), ubound(dfourier_so3,2) - do l = lbound(dfourier_so3,1), ubound(dfourier_so3,1) - deallocate(dfourier_so3(l,a,n)%mm) - enddo - enddo - enddo - deallocate(dfourier_so3) - endif - - enddo ! i - - if(allocated(Rad_ij)) deallocate(Rad_ij) - if(allocated(dRad_ij)) deallocate(dRad_ij) - - if(allocated(fourier_so3)) then - do a = lbound(fourier_so3,2), ubound(fourier_so3,2) - do l = lbound(fourier_so3,1), ubound(fourier_so3,1) - deallocate(fourier_so3(l,a)%m) - enddo - enddo - deallocate(fourier_so3) - endif - - if(allocated(SphericalY_ij)) then - do l = lbound(SphericalY_ij,1), ubound(SphericalY_ij,1) - deallocate(SphericalY_ij(l)%m) - enddo - deallocate(SphericalY_ij) - endif - - if(allocated(dSphericalY_ij)) then - do l = lbound(dSphericalY_ij,1), ubound(dSphericalY_ij,1) - deallocate(dSphericalY_ij(l)%mm) - enddo - deallocate(dSphericalY_ij) - endif - - call system_timer('power_so3_calc') - - endsubroutine power_so3_calc - - subroutine power_SO4_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(power_SO4), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(cplx_2d), dimension(:), allocatable :: U - type(cplx_3d), dimension(:,:), allocatable :: dU - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - real(dp), dimension(3) :: diff, u_ij - real(dp) :: r - integer :: i, n, n_i, ji, jn, k, j, i_desc, i_bisp, d, & - n_descriptors, n_cross, l_n_neighbours, n_index - integer, dimension(3) :: shift - integer, dimension(total_elements) :: species_map - logical :: my_do_descriptor, my_do_grad_descriptor - - INIT_ERROR(error) - - call system_timer('power_SO4_calc') - - if(.not. this%initialised) then - RAISE_ERROR("power_SO4_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - species_map = 0 - do i = 1, size(this%species_Z) - if(this%species_Z(i) == 0) then - species_map = 1 - else - species_map(this%species_Z(i)) = i - endif - enddo - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='power_SO4_calc args_str')) then - RAISE_ERROR("power_SO4_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("power_SO4_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("power_SO4_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = power_SO4_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - - i_desc = i_desc + 1 - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - descriptor_out%x(i_desc)%has_data = .false. - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - - enddo - - i_desc = 0 - do i = 1, at%N - - if( associated(atom_mask_pointer) ) then - if( .not. atom_mask_pointer(i) ) cycle - endif - - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - ji = neighbour(at, i, n, jn=jn, distance=r, diff=diff, cosines=u_ij,shift=shift) - if( r >= this%cutoff ) cycle - - n_i = n_i + 1 - - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(n_i) = ji - descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,ji) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. - endif - enddo - - if(my_do_grad_descriptor) then - call fourier_SO4_calc(this%fourier_SO4,at,i,U,dU,args_str,error=error) - else - call fourier_SO4_calc(this%fourier_SO4,at,i,U,args_str=args_str,error=error) - endif - - if(my_do_descriptor) then - - i_bisp = 0 - do j = 0, this%j_max - i_bisp = i_bisp + 1 - descriptor_out%x(i_desc)%data(i_bisp) = sum( conjg(U(j)%mm)*U(j)%mm ) - enddo - endif - - if(my_do_grad_descriptor) then - n_i = 0 - do n = 1, n_neighbours(at,i) - ji = neighbour(at, i, n, distance=r) - if( r >= this%cutoff ) cycle - n_i = n_i + 1 - i_bisp = 0 - do j = 0, this%j_max - i_bisp = i_bisp + 1 - do k = 1, 3 - descriptor_out%x(i_desc)%grad_data(i_bisp,k,n_i) = 2.0_dp * sum( conjg(U(j)%mm)*dU(j,n_i)%mm(k,:,:) ) - enddo - enddo - enddo - descriptor_out%x(i_desc)%grad_data(:,:,0) = -sum(descriptor_out%x(i_desc)%grad_data(:,:,:), dim=3) - endif - - call finalise(dU) - enddo ! i - - ! clear U from the memory - call finalise(U) - - call system_timer('power_SO4_calc') - - endsubroutine power_SO4_calc - - subroutine form_coupling_inds(this, K1, coupling_inds, sym_facs, error) - !forms coupling inds - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - integer, intent(in) :: K1 - - integer :: i, d, a, b, k, ik, ub, i_species, j_species - integer, dimension(:, :), allocatable :: coupling_inds - real, dimension(:), allocatable :: sym_facs - - !Z_mixing only - if (this%Z_mix .and. (.not. this%R_mix)) then - if (this%sym_mix) then - d = this%K * (this%n_max*(this%n_max+1))/2 - else - d = this%K* this%n_max**2 - endif - allocate(coupling_inds(d, 2)) - allocate(sym_facs(d)) - i = 1 - do k = 1, this%K - ik = (k-1) * this%n_max - do a = 1, this%n_max - ub = this%n_max - if (this%sym_mix) ub = a - do b = 1, ub - coupling_inds(i,:) = (/ik+a, ik+b /) - if (a /= b .and. this%sym_mix) then - sym_facs(i) = SQRT_TWO - else - sym_facs(i) = 1.0 - endif - i = i + 1 - enddo - enddo - enddo - - !radial mixing only - elseif (this%R_mix .and. (.not. this%Z_mix)) then - if (this%sym_mix) then - d = this%K * (this%n_species*(this%n_species+1))/2 - else - d = this%K * this%n_species**2 - endif - allocate(coupling_inds(d, 2)) - allocate(sym_facs(d)) - i = 1 - - do i_species = 1, this%n_species - ub = this%n_species - if (this%sym_mix) ub = i_species - do j_species = 1, ub - do k = 1, this%K - coupling_inds(i,:) = (/(i_species-1)*this%K + k, (j_species-1)*this%K + k/) - if (i_species /= j_species .and. this%sym_mix) then - sym_facs(i) = SQRT_TWO - else - sym_facs(i) = 1.0 - endif - i = i + 1 - enddo - enddo - enddo - - !everything else aka default is elementwise coupling only - else - allocate(coupling_inds(K1, 2)) - allocate(sym_facs(K1)) - do i = 1, K1 - coupling_inds(i,:) = (/i, i/) - sym_facs(i) = 1.0 - enddo - endif - - endsubroutine form_coupling_inds - - - subroutine form_nu_W(this, W, sym_desc, error) - !replacement for the old rs_index - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - integer :: K, nu_R, nu_S, i, dn, ds, ir, ic, n, s, s2, n2, n2_max, s2_max - type(real_2d), dimension(:), allocatable :: W - logical :: sym_desc - - INIT_ERROR(error) - - if (( this%nu_R > 2) .OR. (this%nu_R < 0)) then - RAISE_ERROR("nu_R outside allowed range of 0-2", error) - endif - - if (( this%nu_S > 2) .OR. (this%nu_S < 0)) then - RAISE_ERROR("nu_S outside allowed range of 0-2", error) - endif - - ! decide if the l-slices are symmetric matricies - if ((this%nu_R == 1) .OR. (this%nu_S == 1)) then - sym_desc = .false. - else - sym_desc = .true. - endif - allocate(W(2)) - - ! construct W(i) as required - nu_R = this%nu_R - nu_S = this%nu_S - do i = 1,2 - ! determine size of W(i) and allocate - K = 1 - ds = 0 - dn = 0 - n2_max = 1 - s2_max = 1 - - if (nu_R > 0) then - K = K * this%n_max - nu_R = nu_R -1 - dn = 1 - n2_max = this%n_max - endif - if (nu_S > 0) then - K = K * this%n_species - nu_S = nu_S -1 - ds = 1 - s2_max = this%n_species - endif - allocate(W(i)%mm(this%n_max * this%n_species, K)) - W(i)%mm(:,:) = 0.0_dp - - !loop over S and N, populating W. 4 Loops but just looping over rows and columns of matrix - ir = 0 - do s = 1, this%n_species - do n = 1, this%n_max - ir = ir + 1 ! row index in W - - ic = 0 - do s2 = 1, s2_max - do n2 = 1, n2_max - ic = ic + 1 - if (ds*s == ds*s2 .and. dn*n == dn*n2) then - !ic = 1 + (s2-1)*ds*n2_max + (n2-1)*dn - W(i)%mm(ir, ic) = 1.0_dp - endif - enddo - enddo - enddo - enddo - - enddo - endsubroutine form_nu_W - - subroutine form_mix_W(this, W, sym_desc, error) - !replacement for the old rs_index - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - type(real_2d), dimension(:), allocatable :: W - logical :: sym_desc - integer :: ik, in, is, ic, ir, j, r_r, r_c - real(dp), dimension(:,:), allocatable :: R - integer :: orig_seed - - !store the original random seed and reset it to this at the end - orig_seed = system_get_random_seed() - sym_desc = this%sym_mix - - INIT_ERROR(error) - - !full Z and R mixing - allocate(W(2)) - if (this%R_mix .and. this%Z_mix) then - do j = 1, 2 - allocate(W(j)%mm(this%n_species*this%n_max, this%K)) - if (this%sym_mix .and. j == 2) then - W(2)%mm = W(1)%mm - else - do is = 1, this%n_species - !seed = this%species_Z(is) - call system_reseed_rng(this%species_Z(is)+this%mix_shift+j*200) - ir = (is-1)*this%n_max - !call random_number(W(j)%mm(ir+1:ir+this%n_max, :)) - do r_r = ir+1, ir+this%n_max - do r_c = 1, this%K - W(j)%mm(r_r, r_c) = ran_normal() - enddo - enddo - - enddo - endif - enddo - - !mix elements only - elseif (this%Z_mix) then - do j = 1, 2 - allocate(W(j)%mm(this%n_species*this%n_max, this%K*this%n_max)) - W(j)%mm = 0.0_dp - if (this%sym_mix .and. j == 2) then - W(2)%mm = W(1)%mm - else - allocate(R(this%n_species, this%K)) - do is = 1, this%n_species - !call random_number(R(is,:)) - call system_reseed_rng(this%species_Z(is)+this%mix_shift+j*200) - do r_c = 1, this%K - R(is, r_c) = ran_normal() - enddo - enddo - - ir = 0 - do is = 1, this%n_species - do in = 1, this%n_max - ir = ir + 1 - do ik = 1, this%k - ic = (ik-1)*this%n_max + in - W(j)%mm(ir, ic) = R(is, ik) - enddo - enddo - enddo - deallocate(R) - endif - enddo - - !mix radial channels only - elseif (this%R_mix) then - do j = 1, 2 - allocate(W(j)%mm(this%n_species*this%n_max, this%K*this%n_species)) - W(j)%mm = 0.0_dp - if (this%sym_mix .and. j == 2) then - W(2)%mm = W(1)%mm - else - allocate(R(this%n_max, this%K)) - !call random_number(R) - call system_reseed_rng(this%n_max+this%mix_shift+j*200) - do r_r = 1, this%n_max - do r_c = 1, this%K - R(r_r, r_c) = ran_normal() - enddo - enddo - - ir = 0 - do is = 1, this%n_species - do in = 1, this%n_max - ir = ir + 1 - do ik = 1, this%K - ic = (is-1)*this%K + ik - W(j)%mm(ir, ic) = R(in, ik) - enddo - enddo - enddo - deallocate(R) - endif - enddo - - else - RAISE_ERROR("form_mix_W: not mixing anything", error) - endif - - !reset the system random seed - call system_reseed_rng(orig_seed) - - endsubroutine form_mix_W - - - subroutine form_Zmap_W(this, W, sym_desc, error) - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - logical :: sym_desc - character :: let - integer :: i, a, i_species, i_row, i_col - integer :: i_s, i_group, i_density, Z - integer :: n_groups(2), Ks(2) - type(real_2d), dimension(:), allocatable :: W - - !set how many groups there are - n_groups = 1 - i_density = 1 - do i = 1, len(this%Z_map_str) - let = this%Z_map_str(i:i) - if (let == ",") n_groups(i_density) = n_groups(i_density) + 1 - if (let == ":") i_density = i_density + 1 - enddo - !print*, "n_groups= ", n_groups - - !allocate W with the correct size - allocate(W(2)) - Ks(1) = this%n_max*n_groups(1) - if (i_density==2) then - sym_desc=.false. - Ks(2) = this%n_max*n_groups(2) - else - sym_desc=.true. - Ks(2) = this%n_max*n_groups(1) - endif - - do i_density = 1, 2 - allocate( W(i_density)%mm(this%n_max*this%n_species, Ks(i_density)) ) - W(i_density)%mm = 0.0_dp - enddo - !print*, "Ks are=", Ks - - !loop over the string populating W - i_s = 0 - i_group = 1 - i_density = 1 - do i = 1, len(this%Z_map_str) - let = this%Z_map_str(i:i) - - !any number - if (SCAN(let, "1234567890") > 0 .and. i_s == 0) then - i_s = i - endif - - !anything but a number - if (SCAN(let, "{} ,:") > 0 .and. i_s > 0 ) then - !Z -> i_species - read(this%Z_map_str(i_s:i-1), *) Z - i_species = 0 - do i_s = 1, this%n_species - if (this%species_Z(i_s) == Z) i_species = i_s - enddo - i_s = 0 - !print*, "Z is", Z, "i_group is", i_group, "i_density is", i_density, "i_species is", i_species - - !now populate the correct bit in W - do a = 1, this%n_max - i_row = (i_species-1)*this%n_max + a - i_col = (i_group-1)*this%n_max + a - !print*, "i_species=", i_species, 'this%n_max=', this%n_max, "a=", a, "i_row=", i_row - W(i_density)%mm(i_row, i_col) = 1.0_dp - enddo - endif - - !increment group and density - if (SCAN(let, ",") > 0) i_group = i_group + 1 - if (SCAN(let, ":") > 0) then - i_density = i_density + 1 - i_group = 1 - endif - - enddo - - if (sym_desc) W(2)%mm = W(1)%mm - endsubroutine form_Zmap_W - - subroutine form_W(this, W, sym_desc, error) - !replacement for the old rs_index - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - type(real_2d), dimension(:), allocatable :: W - logical :: sym_desc, using_Zmap, mixing - integer :: n - - INIT_ERROR(error) - - !print*, "Zmap_str is", trim(this%Z_map_str) - n = len(trim(this%Z_map_str)) - if (len(trim(this%Z_map_str)) > 0 ) then - using_Zmap = .true. - else - using_Zmap = .false. - endif - - - if(.not. this%initialised) then - RAISE_ERROR("form_W: descriptor object not initialised", error) - endif - - if ((this%nu_R /= 2 .OR. this%nu_R /= 2) .and. (this%R_mix .or. this%Z_mix .or. this%sym_mix)) then - RAISE_ERROR("(nu_R, nu_S) = (2,2) required to use channel mixing", error) - endif - - if ((this%nu_R /= 2 .OR. this%nu_R /= 2) .and. (this%diagonal_radial)) then - RAISE_ERROR("(nu_R, nu_S) = (2,2) required to use diagonal radial", error) - endif - - if ((this%nu_R /= 2 .OR. this%nu_R /= 2) .and. (using_Zmap)) then - RAISE_ERROR("(nu_R, nu_S) = (2,2) required to use Zmap", error) - endif - - if ((this%R_mix .or. this%Z_mix .or. this%sym_mix) .and. using_Zmap) then - RAISE_ERROR("cant' using mixing and Zmap at the same time", error) - endif - - !call the correct - if (this%R_mix .or. this%Z_mix .or. this%sym_mix) then - call form_mix_W(this, W, sym_desc, error) - elseif (using_Zmap) then - call form_Zmap_W(this, W, sym_desc, error) - else - call form_nu_W(this, W, sym_desc, error) - endif - - ! Printing these is useful for debugging and was used to check the mixing is working correctly - ! print*, "W(1) is", W(1)%mm - ! print*, "W(2) is", W(2)%mm - ! print*, "sym_desc is", sym_desc - endsubroutine form_W - - - ! main branch currently ~1000 lines long, would be nice not to blow this up - subroutine soap_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - - type real_2d_array - type(real_2d), dimension(:,:,:), allocatable :: x - endtype real_2d_array - - type real_2d_2d - type(real_2d), dimension(:,:), allocatable :: x - endtype real_2d_2d - - type(soap), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - type(cplx_1d), dimension(:), allocatable OMP_SAVE :: SphericalY_ij - type(cplx_2d), dimension(:), allocatable OMP_SAVE :: grad_SphericalY_ij - - !SPEED type(cplx_1d), dimension(:,:,:), allocatable :: fourier_so3 - !SPEED type(cplx_2d), dimension(:,:,:), allocatable :: grad_fourier_so3 - type(real_1d), dimension(:,:,:), allocatable OMP_SAVE :: fourier_so3_r, fourier_so3_i, global_fourier_so3_r, global_fourier_so3_i - type(real_2d), dimension(:,:,:), allocatable OMP_SAVE :: grad_fourier_so3_r, grad_fourier_so3_i - real(dp), allocatable :: t_g_r(:,:), t_g_i(:,:), t_f_r(:,:), t_f_i(:,:), t_g_f_rr(:,:), t_g_f_ii(:,:) - integer :: alpha - - logical :: my_do_descriptor, my_do_grad_descriptor, do_two_l_plus_one, sym_desc - integer :: d, i, j, n, a, b, k, l, m, i_pow, i_coeff, l_n_neighbours, n_i, & - n_descriptors, n_cross, i_species, j_species, ia, jb, i_desc_i, & - xml_version, sum_l_n_neighbours, i_pair, i_pair_i, n_index, ub - integer, dimension(3) :: shift_ij - integer, dimension(:), allocatable :: i_desc - integer, dimension(:,:), allocatable :: rs_index - real(dp) :: r_ij, arg_bess, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm, mo_spher_bess_fi_ki_lp, & - exp_p, exp_m, f_cut, df_cut, norm_descriptor_i, radial_decay, dradial_decay, norm_radial_decay - real(dp), dimension(3) :: u_ij, d_ij - real(dp), dimension(:,:), allocatable OMP_SAVE :: radial_fun, radial_coefficient, grad_radial_fun, grad_radial_coefficient, grad_descriptor_i - real(dp), dimension(:), allocatable OMP_SAVE :: descriptor_i - real(dp), dimension(:), allocatable :: global_fourier_so3_r_array, global_fourier_so3_i_array - type(real_2d_array), dimension(:), allocatable :: global_grad_fourier_so3_r_array, global_grad_fourier_so3_i_array - integer, dimension(total_elements) :: species_map - - complex(dp), allocatable OMP_SAVE :: sphericalycartesian_all_t(:,:), gradsphericalycartesian_all_t(:,:,:) - complex(dp) :: c_tmp(3) - integer :: max_n_neigh - - ! new variables - type(real_2d), dimension(:), allocatable, save :: X_r, X_i, W - type(real_2d), dimension(:, :), allocatable, save :: Y_r, Y_i, dT_i, dT_r - type(real_2d), dimension(:, :, :), allocatable, save :: dY_r, dY_i - type(real_2d), dimension(:, :), allocatable, save :: dX_r, dX_i - type(real_2d_2d), dimension(:), allocatable, save :: dXG_r, dXG_i !global gradients - type(real_2d_2d), dimension(:, :), allocatable, save :: dYG_r, dYG_i - real(dp), dimension(:, :), allocatable, save :: Pl, Pl_g1, Pl_g2 - integer :: ic, K1, K2, ir, ig, ik - real(dp) :: tlpo - real(dp) :: r_tmp(3) - complex(dp), dimension(:), allocatable, save :: l_tmp - logical :: original - integer, dimension(:, :), allocatable :: coupling_inds - real, dimension(:), allocatable :: sym_facs - real(dp), external :: ddot - integer :: na, ix - ! Create a thread private QR_factor here as dormqr modifies it and restores it during solve - ! and this doesn't work with OMP threading, hence the thread private copy. - real(dp), dimension(:,:,:), allocatable OMP_SAVE :: QR_factor - -!$omp threadprivate(radial_fun, radial_coefficient, grad_radial_fun, grad_radial_coefficient) -!$omp threadprivate(sphericalycartesian_all_t, gradsphericalycartesian_all_t) -!$omp threadprivate(fourier_so3_r, fourier_so3_i, X_i, X_r, Pl, Y_r, Y_i) -!$omp threadprivate(SphericalY_ij,grad_SphericalY_ij) -!$omp threadprivate(descriptor_i, grad_descriptor_i) -!$omp threadprivate(grad_fourier_so3_r, grad_fourier_so3_i, QR_factor, dY_r, dY_i, Pl_g1, Pl_g2, l_tmp, dX_r, dX_i) -!$omp threadprivate(dT_i, dT_r) - - INIT_ERROR(error) - - call system_timer('soap_calc') - - if(.not. this%initialised) then - RAISE_ERROR("soap_calc: descriptor object not initialised", error) - endif - - if (( this%nu_R > 2) .OR. (this%nu_R < 0)) then - RAISE_ERROR("nu_R outside allowed range of 0-2", error) - endif - - if (( this%nu_S > 2) .OR. (this%nu_S < 0)) then - RAISE_ERROR("nu_S outside allowed range of 0-2", error) - endif - - ! for special routines to keep original power spectrum fast - original = .false. - if (this%coupling .and. this%nu_R == 2 .and. this%nu_S == 2) original = .true. - if (this%R_mix .or. this%Z_mix .or. this%sym_mix) original = .false. - if (len(trim(this%Z_map_str)) > 0 ) original = .false. - - ! form W mixing matrices - call form_W(this, W, sym_desc, error) - K1 = size(W(1)%mm(0,:)) - K2 = size(W(2)%mm(0,:)) - if (.not. this%coupling) call form_coupling_inds(this, K1, coupling_inds, sym_facs, error) - - species_map = 0 - do i_species = 1, this%n_species - if(this%species_Z(i_species) == 0) then - species_map = 1 - else - species_map(this%species_Z(i_species)) = i_species - endif - enddo - - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - has_atom_mask_name = .false. ! allow atom mask column in the atom table - atom_mask_pointer => null() ! allow atom mask column in the atom table - xml_version = 1423143769 ! This is the version number where the 2l+1 normalisation of soap vectors was introduced - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is " // & - "true, descriptors are calculated.") - - call param_register(params, 'xml_version', '1423143769', xml_version, & - help_string="Version of GAP the XML potential file was created") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='soap_calc args_str')) then - RAISE_ERROR("soap_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("soap_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - if( this%cutoff_dexp > 0 ) then - if( this%cutoff_rate == 0.0_dp ) then - norm_radial_decay = 1.0_dp - else - norm_radial_decay = this%cutoff_rate / ( 1.0_dp + this%cutoff_rate ) - endif - else - norm_radial_decay = 1.0_dp - endif - - do_two_l_plus_one = (xml_version >= 1423143769) - - allocate(rs_index(2,this%n_max*this%n_species)) - i = 0 - do i_species = 1, this%n_species - do a = 1, this%n_max - i = i + 1 - rs_index(:,i) = (/a,i_species/) - enddo - enddo - - call finalise(descriptor_out) - - d = soap_dimensions(this, error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - allocate(i_desc(at%N)) - - max_n_neigh = 0 - do n_i = 1, at%N - max_n_neigh = max(max_n_neigh, n_neighbours(at, n_i)) - end do - - -!$omp parallel default(none) shared(this,my_do_grad_descriptor,d,max_n_neigh, K1, K2, original, sym_desc) private(i_species, a, l, n_i, ub, ik, k) - allocate(descriptor_i(d)) - if(my_do_grad_descriptor) allocate(grad_descriptor_i(d,3)) - - allocate(radial_fun(0:this%l_max, size(this%r_basis)), radial_coefficient(0:this%l_max, this%n_max)) - !SPEED allocate(fourier_so3(0:this%l_max,this%n_max,this%n_species), SphericalY_ij(0:this%l_max)) - !allocate(fourier_so3_r(0:this%l_max,0:this%n_max,0:this%n_species), fourier_so3_i(0:this%l_max,0:this%n_max,0:this%n_species)) - allocate(SphericalY_ij(0:this%l_max)) - allocate(X_r(0:this%l_max), X_i(0:this%l_max)) - allocate(l_tmp(1:2*this%l_max + 1)) - do l = 0, this%l_max - allocate(X_r(l)%mm(2*l+1, this%n_species*this%n_max)) - allocate(X_i(l)%mm(2*l+1, this%n_species*this%n_max)) - enddo - - allocate(Pl(K1, K2)) - - allocate(Y_r(2, 0:this%l_max), Y_i(2, 0:this%l_max)) - do l = 0, this%l_max - allocate(Y_r(1, l)%mm(2*l+1, K1)) - allocate(Y_i(1, l)%mm(2*l+1, K1)) - allocate(Y_r(2, l)%mm(2*l+1, K2)) - allocate(Y_i(2, l)%mm(2*l+1, K2)) - enddo - - - if(my_do_grad_descriptor) then - allocate(grad_radial_fun(0:this%l_max, size(this%r_basis)), grad_radial_coefficient(0:this%l_max, this%n_max)) - allocate(grad_SphericalY_ij(0:this%l_max)) - endif - - allocate(sphericalycartesian_all_t(0:this%l_max, -this%l_max:this%l_max)) - if(my_do_grad_descriptor) then - allocate(gradsphericalycartesian_all_t(0:this%l_max, -this%l_max:this%l_max, 3)) - endif - - if (this%radial_basis /= "EQUISPACED_GAUSS") then - allocate(QR_factor(size(this%r_basis), this%n_max, 0:this%l_max)) - do l = 0, this%l_max - QR_factor(:, :, l) = this%QR_factor(:, :, l) - enddo - endif - - do l = 0, this%l_max - allocate(SphericalY_ij(l)%m(-l:l)) - if(my_do_grad_descriptor) allocate(grad_SphericalY_ij(l)%mm(3,-l:l)) - enddo - - if (my_do_grad_descriptor) then - if (original) then - allocate(Pl_g1(K1, 3*this%n_max)) - else - allocate(Pl_g1(K1, 3*K2), Pl_g2(3*K1, K2)) - endif - - ! allocate new grad storage - if (original) then - allocate(dX_r(0:this%l_max, max_n_neigh), dX_i(0:this%l_max, max_n_neigh)) - do l = 0, this%l_max - do n_i = 1, max_n_neigh - allocate(dX_r(l, n_i)%mm(2*l+1, 3*this%n_max)) - allocate(dX_i(l, n_i)%mm(2*l+1, 3*this%n_max)) - enddo - enddo - ! general - else - allocate(dY_r(2, 0:this%l_max, max_n_neigh), dY_i(2, 0:this%l_max, max_n_neigh)) - do n_i = 1, max_n_neigh - do ik = 1, 2 - if (sym_desc .and. ik == 1) cycle - k = K1 - if (ik == 2) k = K2 - do l = 0, this%l_max - allocate(dY_r(ik, l, n_i)%mm(2*l+1, 3*k)) - allocate(dY_i(ik, l, n_i)%mm(2*l+1, 3*k)) - enddo - enddo - enddo - endif - - !temporary storage for the gradient cofficients before multiplication - allocate(dT_r(0:2, 0:this%l_max), dT_i(0:2, 0:this%l_max)) - do l = 0, this%l_max - allocate(dT_r(0, l)%mm(2*l+1, this%n_max), dT_i(0, l)%mm(2*l+1, this%n_max)) - allocate(dT_r(1, l)%mm(2*l+1, K1), dT_i(1, l)%mm(2*l+1, K1)) - allocate(dT_r(2, l)%mm(2*l+1, K2), dT_i(2, l)%mm(2*l+1, K2)) - enddo - - endif -!$omp end parallel - - i_desc = 0 - i_desc_i = 0 - do i = 1, at%N - if( .not. any( at%Z(i) == this%Z ) .and. .not. any(this%Z == 0) ) cycle - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - i_desc_i = i_desc_i + 1 - i_desc(i) = i_desc_i - - if(.not. this%global) then ! atomic SOAP - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc_i)%data(d)) - !slow, no need - !descriptor_out%x(i_desc_i)%data = 0.0_dp - allocate(descriptor_out%x(i_desc_i)%ci(n_index)) - descriptor_out%x(i_desc_i)%has_data = .false. - descriptor_out%x(i_desc_i)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc_i)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc_i)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc_i)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc_i)%has_grad_data(0:l_n_neighbours)) - ! slow, no need - ! descriptor_out%x(i_desc_i)%grad_data = 0.0_dp - descriptor_out%x(i_desc_i)%grad_data(:,:,0) = 0.0_dp - descriptor_out%x(i_desc_i)%ii = 0 - descriptor_out%x(i_desc_i)%pos = 0.0_dp - descriptor_out%x(i_desc_i)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc_i)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc_i)%grad_covariance_cutoff = 0.0_dp - endif - endif - enddo - - ! Test, might ahve to always allocate this for omp reduction... - allocate( & - global_fourier_so3_r_array((this%l_max+1)**2 * this%n_max*this%n_species), & - global_fourier_so3_i_array((this%l_max+1)**2 * this%n_max*this%n_species+1)) - - if (this%global) then - if (original) then - allocate(dXG_r(count(i_desc/=0)), dXG_i(count(i_desc/=0))) - else - allocate(dYG_r(count(i_desc/=0), 2), dYG_i(count(i_desc/=0), 2)) - endif - endif - - - if(this%global) then - if(my_do_descriptor) then - allocate(descriptor_out%x(1)%data(d)) - allocate(descriptor_out%x(1)%ci(n_index)) - if( any(this%Z == 0) ) then - descriptor_out%x(1)%ci(:) = (/ (i, i=1, at%N) /) - else - forall(i=1:at%N, any(at%Z(i) == this%Z)) descriptor_out%x(1)%ci(i_desc(i)) = i - endif - descriptor_out%x(1)%has_data = .true. - descriptor_out%x(1)%covariance_cutoff = 1.0_dp - endif ! my_do_descriptor - if(my_do_grad_descriptor) then - sum_l_n_neighbours = 0 - do i = 1, at%N - - if(i_desc(i) == 0) then - cycle - else - i_desc_i = i_desc(i) - endif - - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - sum_l_n_neighbours = sum_l_n_neighbours + l_n_neighbours + 1 ! include central atom as well! - - ! allocate( & - ! global_grad_fourier_so3_r_array(i_desc_i)%x(0:this%l_max,0:this%n_max,l_n_neighbours), & - !global_grad_fourier_so3_i_array(i_desc_i)%x(0:this%l_max,0:this%n_max,l_n_neighbours) ) - !allocate( & - !global_grad_fourier_so3_r_array(i_desc_i)%x(0:this%l_max,0:this%n_max,max_n_neigh), & - !global_grad_fourier_so3_i_array(i_desc_i)%x(0:this%l_max,0:this%n_max,max_n_neigh) ) - if (original) then - allocate(dXG_r(i_desc_i)%x(0:this%l_max, l_n_neighbours), dXG_i(i_desc_i)%x(0:this%l_max, l_n_neighbours) ) - else - do k = 1, 2 - allocate(dYG_r(i_desc_i, k)%x(0:this%l_max, l_n_neighbours), dYG_i(i_desc_i, k)%x(0:this%l_max, l_n_neighbours) ) - enddo - endif - - ! do n_i = 1, l_n_neighbours - ! do a = 0, this%n_max - ! do l = 0, this%l_max - ! !allocate( & - ! !global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm(3,-l:l), & - ! !global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm(3,-l:l) ) - - ! global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm = 0.0_dp - ! global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm = 0.0_dp - ! enddo ! l - ! enddo ! a - ! enddo ! n_i - - do l = 0,this%l_max - do n_i = 1, l_n_neighbours - if (original) then - allocate(dXG_r(i_desc_i)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) - allocate(dXG_i(i_desc_i)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) - dXG_r(i_desc_i)%x(l, n_i)%mm = 0.0_dp - dXG_i(i_desc_i)%x(l, n_i)%mm = 0.0_dp - else - do k = 1, 2 - allocate(dYG_r(i_desc_i, k)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) - allocate(dYG_i(i_desc_i, k)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) - dYG_r(i_desc_i, k)%x(l, n_i)%mm = 0.0_dp - dYG_i(i_desc_i, k)%x(l, n_i)%mm = 0.0_dp - enddo - endif - enddo - enddo - - enddo ! i - - allocate(descriptor_out%x(1)%grad_data(d,3,sum_l_n_neighbours)) - allocate(descriptor_out%x(1)%ii(sum_l_n_neighbours)) - allocate(descriptor_out%x(1)%pos(3,sum_l_n_neighbours)) - allocate(descriptor_out%x(1)%has_grad_data(sum_l_n_neighbours)) - - allocate(descriptor_out%x(1)%grad_covariance_cutoff(3,sum_l_n_neighbours)) - descriptor_out%x(1)%grad_covariance_cutoff = 0.0_dp - endif ! my_do_grad_descriptor - - global_fourier_so3_r_array = 0.0_dp - global_fourier_so3_i_array = 0.0_dp - endif ! this%global - - -!$omp parallel do schedule(dynamic) default(none) shared(this, at, descriptor_out, my_do_descriptor, my_do_grad_descriptor, d, i_desc, species_map, rs_index, do_two_l_plus_one, sym_desc, W, K1, K2, max_n_neigh) & -!$omp shared(dXG_r, dXG_i, dYG_r, dYG_i, norm_radial_decay, coupling_inds, sym_facs, original) & -!$omp private(i, j, i_species, j_species, a, b, l, m, n, n_i, r_ij, u_ij, d_ij, shift_ij, i_pow, i_coeff, ia, jb, alpha, i_desc_i, ub, ic, ir, ig, ik, k, na, ix) & -!$omp private(c_tmp, r_tmp, tlpo) & -!$omp private(t_g_r, t_g_i, t_f_r, t_f_i, t_g_f_rr, t_g_f_ii) & -!$omp private(f_cut, df_cut, arg_bess, exp_p, exp_m, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lp, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm, norm_descriptor_i) & -!$omp private(radial_decay, dradial_decay) & -!$omp reduction(+:global_fourier_so3_r_array,global_fourier_so3_i_array) - - - do i = 1, at%N - if(i_desc(i) == 0) then - cycle - else - i_desc_i = i_desc(i) - endif - - - if(.not.this%global) then - if(my_do_descriptor) then - descriptor_out%x(i_desc_i)%ci(1) = i - descriptor_out%x(i_desc_i)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc_i)%ii(0) = i - descriptor_out%x(i_desc_i)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc_i)%has_grad_data(0) = .true. - - ! zero the gradient contributions - if (original) then - do n_i= 1, max_n_neigh - do l = 0, this%l_max - dX_r(l, n_i)%mm = 0.0_dp - dX_i(l, n_i)%mm = 0.0_dp - enddo - enddo - ! general - else - do n_i = 1, max_n_neigh - do l = 0, this%l_max - do k = 1, 2 - if (sym_desc .and. k == 1) cycle - dY_r(k, l, n_i)%mm = 0.0_dp - dY_i(k, l, n_i)%mm = 0.0_dp - enddo - enddo - enddo - endif - endif - endif - - if (this%radial_basis == "EQUISPACED_GAUSS") then - ! original version - radial_fun(0,:) = 0.0_dp - radial_fun(0,1) = 1.0_dp - radial_coefficient(0,:) = matmul( radial_fun(0,:), this%cholesky_overlap_basis(:, :, 1)) - else - ! uncommented old version that I think should work... - do a = 1, size(this%r_basis) - radial_fun(0,a) = exp( -this%alpha * this%r_basis(a)**2 ) !* this%r_basis(a) - enddo - !call LA_Matrix_QR_Solve_Vector(LA_BL_ti(0), radial_fun(0, :), radial_coefficient(0, :)) - call Matrix_QR_Solve(QR_factor(:, :, 0), this%QR_tau(:, 0), radial_fun(0, :), radial_coefficient(0, :)) - ! alternative approach: don't invert L^T and multiply at the end. Doesn't work as well for POLY basis - !radial_coefficient = matmul(radial_coefficient, this%cholesky_overlap_basis(0, :, :)) - endif - - !zero the coefficients and initialise counter - do l = 0, this%l_max - X_r(l)%mm = 0.0_dp - X_i(l)%mm = 0.0_dp - enddo - - do i_species = 0, this%n_species - do a = 0, this%n_max - - if ((this%central_reference_all_species .or. this%species_Z(i_species) == at%Z(i) .or. this%species_Z(i_species) == 0) .and. i_species > 0 .and. a > 0) then - ic = (i_species-1) * this%n_max + a - X_r(0)%mm(1, ic) = this%central_weight * real(radial_coefficient(0,a) * SphericalYCartesian(0,0,(/0.0_dp, 0.0_dp, 0.0_dp/)), dp) - X_i(0)%mm(1, ic) = this%central_weight * aimag(radial_coefficient(0,a) * SphericalYCartesian(0,0,(/0.0_dp, 0.0_dp, 0.0_dp/))) - endif - enddo - enddo - - - -! soap_calc 20 takes 0.0052 s - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - - i_species = species_map(at%Z(j)) - if( i_species == 0 ) cycle - - - if(.not. this%global .and. my_do_grad_descriptor) then - descriptor_out%x(i_desc_i)%ii(n_i) = j - descriptor_out%x(i_desc_i)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc_i)%has_grad_data(n_i) = .true. - endif - - f_cut = coordination_function(r_ij, this%cutoff, this%cutoff_transition_width) - radial_decay = ( 1.0_dp + this%cutoff_rate ) / ( this%cutoff_rate + ( r_ij / this%cutoff_scale )**this%cutoff_dexp ) - radial_decay = norm_radial_decay * radial_decay - - if(my_do_grad_descriptor) then - df_cut = dcoordination_function(r_ij,this%cutoff, this%cutoff_transition_width) - dradial_decay = - this%cutoff_dexp * ( 1.0_dp + this%cutoff_rate ) * ( r_ij / this%cutoff_scale )**this%cutoff_dexp / & - ( r_ij * ( this%cutoff_rate + ( r_ij / this%cutoff_scale )**this%cutoff_dexp )**2 ) - dradial_decay = norm_radial_decay * dradial_decay - - df_cut = df_cut * radial_decay + f_cut * dradial_decay - endif - f_cut = f_cut * radial_decay - - do a = 1, size(this%r_basis) - arg_bess = 2.0_dp * this%alpha * r_ij * this%r_basis(a) - exp_p = exp( -this%alpha*( r_ij + this%r_basis(a) )**2 ) - exp_m = exp( -this%alpha*( r_ij - this%r_basis(a) )**2 ) - - do l = 0, this%l_max - if( l == 0 ) then - if(arg_bess == 0.0_dp) then - !mo_spher_bess_fi_ki_l = 1.0_dp - mo_spher_bess_fi_ki_l = exp( -this%alpha * (this%r_basis(a)**2 + r_ij**2) ) - if(my_do_grad_descriptor) mo_spher_bess_fi_ki_lp = 0.0_dp - else - !mo_spher_bess_fi_ki_lm = cosh(arg_bess)/arg_bess - !mo_spher_bess_fi_ki_l = sinh(arg_bess)/arg_bess - mo_spher_bess_fi_ki_lm = 0.5_dp * (exp_m + exp_p) / arg_bess - mo_spher_bess_fi_ki_l = 0.5_dp * (exp_m - exp_p) / arg_bess - if(my_do_grad_descriptor) mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess - endif - else - if(arg_bess == 0.0_dp) then - mo_spher_bess_fi_ki_l = 0.0_dp - if(my_do_grad_descriptor) mo_spher_bess_fi_ki_lp = 0.0_dp - else - mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm - mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l - if(my_do_grad_descriptor) then - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lp - mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess - else - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l-1)*mo_spher_bess_fi_ki_lm / arg_bess - endif - endif - endif - - !radial_fun(l,a) = exp( -this%alpha * (this%r_basis(a)**2 + r_ij**2) ) * mo_spher_bess_fi_ki_l !* this%r_basis(a) - radial_fun(l,a) = mo_spher_bess_fi_ki_l !* this%r_basis(a) - if(my_do_grad_descriptor) grad_radial_fun(l,a) = -2.0_dp * this%alpha * r_ij * mo_spher_bess_fi_ki_l + & - l*mo_spher_bess_fi_ki_l / r_ij + mo_spher_bess_fi_ki_lp * 2.0_dp * this%alpha * this%r_basis(a) - - enddo - enddo - - if (this%radial_basis == "EQUISPACED_GAUSS") then - radial_coefficient = matmul( radial_fun, this%transform_basis ) - if(my_do_grad_descriptor) grad_radial_coefficient = matmul( grad_radial_fun, this%transform_basis ) * f_cut + radial_coefficient * df_cut - radial_coefficient = radial_coefficient * f_cut - else - do l = 0, this%l_max - !call LA_Matrix_QR_Solve_Vector(LA_BL_ti(l), radial_fun(l, :), radial_coefficient(l, :)) - call Matrix_QR_Solve(QR_factor(:, :, l), this%QR_tau(:, l), radial_fun(l, :), radial_coefficient(l, :)) - !radial_coefficient(l, :) = matmul(radial_coefficient(l, :), this%cholesky_overlap_basis(l, :, :)) - enddo - if(my_do_grad_descriptor) then - !grad_radial_coefficient = matmul( grad_radial_fun, transpose(this%transform_basis )) * f_cut + radial_coefficient * df_cut - do l = 0, this%l_max - call Matrix_QR_Solve(QR_factor(:, :, l), this%QR_tau(:, l), grad_radial_fun(l, :), grad_radial_coefficient(l, :)) - enddo - grad_radial_coefficient = grad_radial_coefficient * f_cut + radial_coefficient * df_cut - endif - radial_coefficient = radial_coefficient * f_cut - endif - - sphericalycartesian_all_t = SphericalYCartesian_all(this%l_max, d_ij) - if(my_do_grad_descriptor) gradsphericalycartesian_all_t = GradSphericalYCartesian_all(this%l_max, d_ij) - do l = 0, this%l_max - do m = -l, l - SphericalY_ij(l)%m(m) = SphericalYCartesian_all_t(l,m) - if(my_do_grad_descriptor) grad_SphericalY_ij(l)%mm(:,m) = GradSphericalYCartesian_all_t(l,m,:) - enddo - enddo - - do l = 0, this%l_max - do a = 1, this%n_max - ic = (i_species-1) * this%n_max + a - X_r(l)%mm(:, ic) = X_r(l)%mm(:, ic) + radial_coefficient(l,a) * real(SphericalY_ij(l)%m(:)) - X_i(l)%mm(:, ic) = X_i(l)%mm(:, ic) + radial_coefficient(l,a) * aimag(SphericalY_ij(l)%m(:)) - enddo ! a - enddo ! l - - if(my_do_grad_descriptor .and. original) then - do k = 1, 3 - do l = 0, this%l_max - !special case for original power spectrum - do a = 1, this%n_max - ic = (a-1)*3 + k - l_tmp(1:2*l+1) = grad_radial_coefficient(l,a) * SphericalY_ij(l)%m(:) * u_ij(k) + radial_coefficient(l,a) * grad_SphericalY_ij(l)%mm(k,:) - dX_r(l, n_i)%mm(:, ic) = real(l_tmp(1:2*l+1)) - dX_i(l, n_i)%mm(:, ic) = aimag(l_tmp(1:2*l+1)) - enddo ! a - enddo ! l - enddo ! k - endif ! my_do_grad_descriptor - - if(my_do_grad_descriptor .and. (.not. original)) then - do k = 1, 3 - do l = 0, this%l_max - do a = 1, this%n_max - l_tmp(1:2*l+1) = grad_radial_coefficient(l,a) * SphericalY_ij(l)%m(:) * u_ij(k) + radial_coefficient(l,a) * grad_SphericalY_ij(l)%mm(k,:) - dT_r(0, l)%mm(:, a) = real(l_tmp(1:2*l+1)) - dT_i(0, l)%mm(:, a) = aimag(l_tmp(1:2*l+1)) - enddo ! a - - !operate on the coefficients then pack them - ic = (i_species-1) * this%n_max - do ia = 1, 2 - if (sym_desc .and. ia == 1) cycle - dT_r(ia, l)%mm = matmul(dT_r(0, l)%mm, W(ia)%mm(ic+1:ic+this%n_max, :)) - dT_i(ia, l)%mm = matmul(dT_i(0, l)%mm, W(ia)%mm(ic+1:ic+this%n_max, :)) - - ub = K1 - if (ia == 2) ub = K2 - do ik = 1, ub - ir = (ik-1)*3 + k - dY_r(ia, l, n_i)%mm(:, ir) = dT_r(ia, l)%mm(:, ik) - dY_i(ia, l, n_i)%mm(:, ir) = dT_i(ia, l)%mm(:, ik) - enddo - enddo - enddo ! l - enddo ! k - endif ! my_do_grad_descriptor - - enddo ! n - - - - if(this%global .and. my_do_grad_descriptor) then - if (original) then - dXG_r(i_desc_i)%x = dX_r(:, 1:n_neighbours(at,i,max_dist=this%cutoff)) - dXG_i(i_desc_i)%x = dX_i(:, 1:n_neighbours(at,i,max_dist=this%cutoff)) - else - ! copy the operated gradients - do k = 1, 2 - dYG_r(i_desc_i, k)%x = dY_r(k, :, 1:n_neighbours(at,i,max_dist=this%cutoff)) - dYG_i(i_desc_i, k)%x = dY_i(k, :, 1:n_neighbours(at,i,max_dist=this%cutoff)) - enddo - endif - endif - - - if(this%global) then - i_coeff = 0 - do ia = 1, this%n_species*this%n_max - a = rs_index(1,ia) - i_species = rs_index(2,ia) - do l = 0, this%l_max - global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) = global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) + X_r(l)%mm(:, ia) - global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) = global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) + X_i(l)%mm(:, ia) - i_coeff = i_coeff + 2*l+1 - enddo - enddo - endif - - if (this%coupling) then - !standard full tensor product coupling between density channels. - i_pow = 0 - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - ! special case for regular power spectrum - if (original) then - ! Pl = matmul(tranpose(X_r(l)%mm), X_r(l)%mm) - call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, X_r(l)%mm, 2*l+1, 0.0_dp, Pl, K1) - call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, X_i(l)%mm, 2*l+1, 1.0_dp, Pl, K1) - ! everything else - else - - call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_r(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_r(1, l)%mm, 2*l+1) - call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_i(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_i(1, l)%mm, 2*l+1) - - !skipping this for regular power spec saves 1e-3 - if (sym_desc) then - Y_r(2, l)%mm = Y_r(1, l)%mm - Y_i(2, l)%mm = Y_i(1, l)%mm - else - Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) - Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) - endif - - !Pl = matmul(transpose(Y_r(1, l)%mm), Y_r(2, l)%mm) + matmul(transpose(Y_i(1, l)%mm), Y_i(2, l)%mm) - call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, Y_r(2, l)%mm, 2*l+1, 0.0_dp, Pl, K1) - call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, Y_i(2, l)%mm, 2*l+1, 1.0_dp, Pl, K1) - endif - - ! unpack l-slice - i_pow = l + 1 - do ia = 1, K1 - ub = K2 - if (sym_desc) then - ub = ia - endif - if (this%diagonal_radial .and. original) a = rs_index(1,ia) - do jb = 1, ub - if (this%diagonal_radial .and. original) b = rs_index(1,jb) - if (this%diagonal_radial .and. original .and. a /= b) cycle - descriptor_i(i_pow) = Pl(ia, jb) - if( ia /= jb .and. sym_desc) descriptor_i(i_pow) = descriptor_i(i_pow) * SQRT_TWO - i_pow = i_pow + this%l_max+1 - enddo - enddo - - enddo - else - !elementwise coupling between density channels. For use with tensor-reduced compression. - do l = 0, this%l_max - - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - ! Y_r(1, l)%mm = matmul(X_r(l)%mm, W(1)%mm) - ! Y_i(1, l)%mm = matmul(X_i(l)%mm, W(1)%mm) - call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_r(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_r(1, l)%mm, 2*l+1) - call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_i(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_i(1, l)%mm, 2*l+1) - if (this%sym_mix) then - Y_r(2, l)%mm = Y_r(1, l)%mm - Y_i(2, l)%mm = Y_i(1, l)%mm - else - Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) - Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) - endif - - i_pow = l + 1 - do ik = 1, SIZE(sym_facs) - ia = coupling_inds(ik, 1) - jb = coupling_inds(ik, 2) - !descriptor_i(i_pow) = (dot_product(Y_r(1, l)%mm(:, ia), Y_r(2, l)%mm(:, jb)) + dot_product(Y_i(1, l)%mm(:, ia), Y_i(2, l)%mm(:, jb))) * sym_facs(ik) - descriptor_i(i_pow) = (ddot(2*l+1, Y_r(1, l)%mm(:, ia), 1, Y_r(2, l)%mm(:, jb), 1) + ddot(2*l+1, Y_i(1, l)%mm(:, ia), 1, Y_i(2, l)%mm(:, jb), 1)) * sym_facs(ik) - if (do_two_l_plus_one) descriptor_i(i_pow) = descriptor_i(i_pow) * tlpo - i_pow = i_pow + this%l_max + 1 - enddo - enddo - endif - - !normalise the descriptor - descriptor_i(d) = 0.0_dp - norm_descriptor_i = sqrt(dot_product(descriptor_i,descriptor_i)) - if(.not. this%global .and. my_do_descriptor) then - if(this%normalise) then - descriptor_out%x(i_desc_i)%data = descriptor_i / norm_descriptor_i - else - descriptor_out%x(i_desc_i)%data = descriptor_i - endif - descriptor_out%x(i_desc_i)%data(d) = this%covariance_sigma0 - endif - - !new gradients calcuation - if (my_do_grad_descriptor) then - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij) - if( r_ij >= this%cutoff ) cycle - n_i = n_i + 1 - if( species_map(at%Z(j)) == 0 ) cycle - grad_descriptor_i = 0.0_dp - - if (this%coupling .and. (.not. original)) then - do l = 0, this%l_max - ! call dgemm(transA, transB, M, N, K, alpha, A, LDA, B, LDB, beta, C, LDC) - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, dY_r(2, l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) - call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, dY_i(2, l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) - - ! TODO check if this is really necessary... think very likely it's not! - if (.not. sym_desc) then - Pl_g2 = matmul(transpose(dY_r(1, l, n_i)%mm), Y_r(2,l)%mm) + matmul(transpose(dY_i(1, l, n_i)%mm), Y_i(2,l)%mm) - if(do_two_l_plus_one) Pl_g2 = Pl_g2 / sqrt(2.0_dp * l + 1.0_dp) - endif - - i_pow = l + 1 - do ia = 1, K1 - ub = K2 - if (sym_desc) ub = ia - do jb = 1, ub - ic = (jb-1) * 3 - ir = (ia-1) * 3 - if (sym_desc) then - r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g1(jb, ir+1:ir+3) - else - r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g2(ir+1:ir+3, jb) - endif - - if(ia /= jb .and. sym_desc ) r_tmp = r_tmp * SQRT_TWO - grad_descriptor_i(i_pow, :) = r_tmp - i_pow = i_pow + this%l_max+1 - enddo - enddo - enddo !l - - !special case for diagonal coupling only - testing how fast I can make this - elseif(.not. this%coupling .and. this%R_mix .and. this%Z_mix) then - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - i_pow = l + 1 - - do ik = 1, this%K - r_tmp(:) = 0.0_dp - do ix = 1, 3 - ir = (ik-1)*3 + ix - do na = 1, 2*l+1 - r_tmp(ix) = r_tmp(ix) + dY_r(2, l, n_i)%mm(na,ir)*Y_r(1, l)%mm(na, ik) + dY_i(2, l, n_i)%mm(na,ir)*Y_i(1, l)%mm(na, ik) - enddo - enddo - - ! either multiply by factor of 2 for symmetric or do other way around for asym - if (this%sym_mix) then - r_tmp(:) = r_tmp(:) * 2.0_dp - else - do ix = 1, 3 - ir = (ik-1)*3 + ix - do na = 1, 2*l+1 - r_tmp(ix) = r_tmp(ix) + dY_r(1, l, n_i)%mm(na,ir)*Y_r(2, l)%mm(na, ik) + dY_i(1, l, n_i)%mm(na,ir)*Y_i(2, l)%mm(na, ik) - enddo - enddo - endif - - grad_descriptor_i(i_pow, :) = r_tmp * tlpo - i_pow = i_pow + this%l_max + 1 - enddo - enddo - - elseif(.not. this%coupling ) then - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - i_pow = l + 1 - - do ik = 1, SIZE(sym_facs) - ia = coupling_inds(ik, 1) - jb = coupling_inds(ik, 2) - ir = (jb-1) * 3 - r_tmp = matmul(transpose(dY_r(2, l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, ia)) + matmul(transpose(dY_i(2, l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, ia) ) - ir = (ia-1)*3 - if (sym_desc) then - r_tmp = r_tmp + matmul(transpose(dY_r(2, l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, jb) ) + matmul(transpose(dY_i(2, l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, jb) ) - else - r_tmp = r_tmp + matmul(transpose(dY_r(1, l, n_i)%mm(:, ir+1:ir+3)), Y_r(2, l)%mm(:, jb) ) + matmul(transpose(dY_i(1, l, n_i)%mm(:, ir+1:ir+3)), Y_i(2, l)%mm(:, jb) ) - endif - grad_descriptor_i(i_pow, :) = r_tmp * tlpo * sym_facs(ik) - i_pow = i_pow + this%l_max + 1 - enddo - enddo - - !original power spectrum gradients as special case to exploit sparsity of dX_r w.r.t the neighbour species - else - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - !TODO try swapping order here - call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, dX_r(l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) - call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, dX_i(l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) - - i_pow = l + 1 - do ia = 1, K1 - a = rs_index(1,ia) - i_species = rs_index(2,ia) - do jb = 1, ia - b = rs_index(1,jb) - j_species = rs_index(2,jb) - if (this%diagonal_radial .and. a /= b) cycle - if(at%Z(j) == this%species_Z(i_species) .or. this%species_Z(i_species)==0) then - ic = (a-1) * 3 - grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(jb, ic+1:ic+3) - endif - if(at%Z(j) == this%species_Z(j_species) .or. this%species_Z(j_species)==0) then - ic = (b-1) * 3 - grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(ia, ic+1:ic+3) - endif - - if(ia /= jb) grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) * SQRT_TWO - i_pow = i_pow + this%l_max+1 - enddo !jb - enddo !ia - enddo !l - endif - !normalise the gradients - grad_descriptor_i(d, 1:3) = 0.0_dp - if(.not. this%global) then - if( this%normalise ) then - grad_descriptor_i = grad_descriptor_i / norm_descriptor_i - c_tmp = matmul(descriptor_i,grad_descriptor_i) / norm_descriptor_i**2 - do k = 1, 3 - descriptor_out%x(i_desc_i)%grad_data(:,k,n_i) = grad_descriptor_i(:,k) - descriptor_i * c_tmp(k) - enddo - else - descriptor_out%x(i_desc_i)%grad_data(:,:,n_i) = grad_descriptor_i - endif - descriptor_out%x(i_desc_i)%grad_data(:,:,0) = descriptor_out%x(i_desc_i)%grad_data(:,:,0) - descriptor_out%x(i_desc_i)%grad_data(:,:,n_i) - endif - - enddo !n_i - endif - - enddo ! i -!$omp end parallel do - - -!$omp parallel default(none) shared(this, max_n_neigh) private(i_species, a, l, n_i, ub) - if(allocated(fourier_so3_r)) then - do i_species = lbound(fourier_so3_r,3), ubound(fourier_so3_r,3) - do a = lbound(fourier_so3_r,2), ubound(fourier_so3_r,2) - do l = lbound(fourier_so3_r,1), ubound(fourier_so3_r,1) - deallocate(fourier_so3_r(l,a,i_species)%m) - enddo - enddo - enddo - deallocate(fourier_so3_r) - endif - if(allocated(fourier_so3_i)) then - do i_species = lbound(fourier_so3_i,3), ubound(fourier_so3_i,3) - do a = lbound(fourier_so3_i,2), ubound(fourier_so3_i,2) - do l = lbound(fourier_so3_i,1), ubound(fourier_so3_i,1) - deallocate(fourier_so3_i(l,a,i_species)%m) - enddo - enddo - enddo - deallocate(fourier_so3_i) - endif - - if (allocated(l_tmp)) deallocate(l_tmp) - if (allocated(X_r)) then - do l = 0, this%l_max - if (allocated(X_r(l)%mm)) deallocate(X_r(l)%mm) - if (allocated(X_i(l)%mm)) deallocate(X_i(l)%mm) - enddo - if (allocated(X_r)) deallocate(X_r) - if (allocated(X_i)) deallocate(X_i) - endif - - if (allocated(Y_r)) then - do k = 1, 2 - do l = 0, this%l_max - if (allocated(Y_r(k, l)%mm)) deallocate(Y_r(k, l)%mm) - if (allocated(Y_i(k, l)%mm)) deallocate(Y_i(k, l)%mm) - enddo - enddo - if (allocated(Y_r)) deallocate(Y_r) - if (allocated(Y_i)) deallocate(Y_i) - endif - - if(allocated(SphericalY_ij)) then - do l = lbound(SphericalY_ij,1), ubound(SphericalY_ij,1) - deallocate(SphericalY_ij(l)%m) - enddo - deallocate(SphericalY_ij) - endif - - if(allocated(grad_SphericalY_ij)) then - do l = lbound(grad_SphericalY_ij,1), ubound(grad_SphericalY_ij,1) - deallocate(grad_SphericalY_ij(l)%mm) - enddo - deallocate(grad_SphericalY_ij) - endif - - if (allocated(sphericalycartesian_all_t)) deallocate(sphericalycartesian_all_t) - if (allocated(gradsphericalycartesian_all_t)) deallocate(gradsphericalycartesian_all_t) - - if(allocated(radial_fun)) deallocate(radial_fun) - if(allocated(radial_coefficient)) deallocate(radial_coefficient) - if(allocated(grad_radial_fun)) deallocate(grad_radial_fun) - if(allocated(grad_radial_coefficient)) deallocate(grad_radial_coefficient) - if(allocated(descriptor_i)) deallocate(descriptor_i) - - !print *, "about to deallocate grad_descriptor_i" - if(allocated(grad_descriptor_i)) deallocate(grad_descriptor_i) - - if (allocated(grad_fourier_so3_r)) then ! should really check for grad_fourier_so3_i also - do n_i = 1, max_n_neigh - do a = 0, this%n_max - do l = 0, this%l_max - !SPEED deallocate(grad_fourier_so3(l,a,n_i)%mm) - if(allocated(grad_fourier_so3_r(l,a,n_i)%mm)) deallocate(grad_fourier_so3_r(l,a,n_i)%mm) - if(allocated(grad_fourier_so3_i(l,a,n_i)%mm)) deallocate(grad_fourier_so3_i(l,a,n_i)%mm) - enddo - enddo - enddo - endif - !SPEED deallocate(grad_fourier_so3) - if (allocated(grad_fourier_so3_r)) deallocate(grad_fourier_so3_r) - if (allocated(grad_fourier_so3_i)) deallocate(grad_fourier_so3_i) - - - if (allocated(dX_r)) then - do l = 0, this%l_max - do n_i = 1, max_n_neigh - if (allocated(dX_r(l, n_i)%mm)) deallocate(dX_r(l, n_i)%mm) - if (allocated(dX_i(l, n_i)%mm)) deallocate(dX_i(l, n_i)%mm) - enddo - enddo - if (allocated(dX_r)) deallocate(dX_r) - if (allocated(dX_i)) deallocate(dX_i) - endif - - if (allocated(dY_R)) then - do n_i = 1, max_n_neigh - do ik = 1, 2 - do l = 0, this%l_max - if (allocated(dY_i(ik, l, n_i)%mm)) deallocate(dY_i(ik, l, n_i)%mm) - if (allocated(dY_r(ik, l, n_i)%mm)) deallocate(dY_r(ik, l, n_i)%mm) - enddo - enddo - enddo - if (allocated(dY_i)) deallocate(dY_i) - if (allocated(dY_r)) deallocate(dY_r) - endif - - if (allocated(dT_r)) then - do k = 0, 2 - do l = 0, this%l_max - deallocate(dT_r(k, l)%mm, dT_i(k, l)%mm) - enddo - enddo - deallocate(dT_r, dT_i) - endif - - if (allocated(Pl_g1)) deallocate(Pl_g1) - if (allocated(Pl_g2)) deallocate(Pl_g2) - if (allocated(Pl)) deallocate(Pl) - if (allocated(QR_factor)) deallocate(QR_factor) -!$omp end parallel - - if(this%global) then - !allocate(global_fourier_so3_r(0:this%l_max,0:this%n_max,0:this%n_species), global_fourier_so3_i(0:this%l_max,0:this%n_max,0:this%n_species), & - !Have to reallocate X_r and Y_r - allocate(X_r(0:this%l_max), X_i(0:this%l_max)) - do l = 0, this%l_max - allocate(X_r(l)%mm(2*l+1, this%n_species*this%n_max)) - allocate(X_i(l)%mm(2*l+1, this%n_species*this%n_max)) - enddo - - allocate(Y_r(2, 0:this%l_max), Y_i(2, 0:this%l_max)) - do l = 0, this%l_max - allocate(Y_r(1, l)%mm(2*l+1, K1)) - allocate(Y_i(1, l)%mm(2*l+1, K1)) - allocate(Y_r(2, l)%mm(2*l+1, K2)) - allocate(Y_i(2, l)%mm(2*l+1, K2)) - enddo - - if (original) then - allocate(Pl_g1(K1, 3*this%n_max)) - else - allocate(Pl_g1(K1, 3*K2), Pl_g2(3*K1, K2)) - endif - allocate(Pl(K1, K2)) - - allocate(descriptor_i(d)) - - i_coeff = 0 - do ia = 1, this%n_species*this%n_max - a = rs_index(1,ia) - i_species = rs_index(2,ia) - do l = 0, this%l_max - !allocate(global_fourier_so3_r(l,a,i_species)%m(-l:l)) - !allocate(global_fourier_so3_i(l,a,i_species)%m(-l:l)) - !global_fourier_so3_r(l,a,i_species)%m(:) = global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) - !X_r(l)%mm(2*l+1, this%n_species*this%n_max) - X_r(l)%mm(:, ia) = global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) - X_i(l)%mm(:, ia) = global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) - !global_fourier_so3_i(l,a,i_species)%m(:) = global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) - i_coeff = i_coeff + 2*l+1 - enddo - enddo - - ! *********** exact duplication of code for main power spec - if (this%coupling) then - !standard full tensor product coupling between density channels. - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - ! special case for regular power spectrum - if (original) then - ! Pl = matmul(tranpose(X_r(l)%mm), X_r(l)%mm) - call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, X_r(l)%mm, 2*l+1, 0.0_dp, Pl, K1) - call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, X_i(l)%mm, 2*l+1, 1.0_dp, Pl, K1) - ! everything else - else - call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_r(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_r(1, l)%mm, 2*l+1) - call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_i(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_i(1, l)%mm, 2*l+1) - - !skipping this for regular power spec saves 1e-3 - if (sym_desc) then - Y_r(2, l)%mm = Y_r(1, l)%mm - Y_i(2, l)%mm = Y_i(1, l)%mm - else - Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) - Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) - endif - - !Pl = matmul(transpose(Y_r(1, l)%mm), Y_r(2, l)%mm) + matmul(transpose(Y_i(1, l)%mm), Y_i(2, l)%mm) - call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, Y_r(2, l)%mm, 2*l+1, 0.0_dp, Pl, K1) - call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, Y_i(2, l)%mm, 2*l+1, 1.0_dp, Pl, K1) - endif - - ! unpack l-slice - i_pow = l + 1 - do ia = 1, K1 - ub = K2 - if (sym_desc) then - ub = ia - endif - if (this%diagonal_radial) a = rs_index(1,ia) - do jb = 1, ub - if (this%diagonal_radial) b = rs_index(1,jb) - if (this%diagonal_radial .and. a /= b) cycle - descriptor_i(i_pow) = Pl(ia, jb) - if( ia /= jb .and. sym_desc) descriptor_i(i_pow) = descriptor_i(i_pow) * SQRT_TWO - i_pow = i_pow + this%l_max+1 - enddo - enddo - - enddo - ! deallocate(Pl) - else - !elementwise coupling between density channels. For use with tensor-reduced compression. - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - Y_r(1, l)%mm = matmul(X_r(l)%mm, W(1)%mm) - Y_i(1, l)%mm = matmul(X_i(l)%mm, W(1)%mm) - if (this%sym_mix) then - Y_r(2, l)%mm = Y_r(1, l)%mm - Y_i(2, l)%mm = Y_i(1, l)%mm - else - Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) - Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) - endif - - i_pow = l + 1 - do ik = 1, SIZE(sym_facs) - ia = coupling_inds(ik, 1) - jb = coupling_inds(ik, 2) - descriptor_i(i_pow) = (dot_product(Y_r(1, l)%mm(:, ia), Y_r(2, l)%mm(:, jb)) + dot_product(Y_i(1, l)%mm(:, ia), Y_i(2, l)%mm(:, jb))) * sym_facs(ik) - if (do_two_l_plus_one) descriptor_i(i_pow) = descriptor_i(i_pow) * tlpo - i_pow = i_pow + this%l_max + 1 - enddo - - enddo - endif - ! ********** end of code duplication. Avoid with function / subroutine ?? - - - !normalise descriptor, using old block - descriptor_i(d) = 0.0_dp - norm_descriptor_i = sqrt(dot_product(descriptor_i,descriptor_i)) - if( norm_descriptor_i .feq. 0.0_dp ) norm_descriptor_i = tiny(1.0_dp) - if(my_do_descriptor) then - if(this%normalise) then - descriptor_out%x(1)%data = descriptor_i / norm_descriptor_i - else - descriptor_out%x(1)%data = descriptor_i - endif - descriptor_out%x(1)%data(d) = this%covariance_sigma0 - endif - - - if (my_do_grad_descriptor) then - allocate(grad_descriptor_i(d,3)) - i_pair = 0 - do i = 1, at%N - if (i_desc(i) == 0) cycle - i_desc_i = i_desc(i) - i_pair = i_pair + 1 - i_pair_i = i_pair ! accumulates \frac{ \partial p^{(j)} }{ \partial r_{ji\alpha} } - - descriptor_out%x(1)%ii(i_pair_i) = i - descriptor_out%x(1)%pos(:,i_pair_i) = 0.0_dp - descriptor_out%x(1)%has_grad_data(i_pair_i) = .true. - descriptor_out%x(1)%grad_data(:,:,i_pair_i) = 0.0_dp - - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, diff = d_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - i_pair = i_pair + 1 ! \frac{ \partial p^{(i)} }{ \partial r_{ij\alpha} } - - descriptor_out%x(1)%ii(i_pair) = j - descriptor_out%x(1)%pos(:,i_pair) = d_ij - descriptor_out%x(1)%has_grad_data(i_pair) = .true. - - i_pow = 0 - grad_descriptor_i = 0.0_dp - - ! beginning of new routines - if (this%coupling .and. (.not. original)) then - do l = 0, this%l_max - ! call dgemm(transA, transB, M, N, K, alpha, A, LDA, B, LDB, beta, C, LDC) - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, dYG_r(i_desc_i, 2)%x(l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) - call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, dYG_i(i_desc_i, 2)%x(l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) - - if (.not. sym_desc) then - Pl_g2 = matmul(transpose(dYG_r(i_desc_i, 1)%x(l, n_i)%mm), Y_r(2,l)%mm) + matmul(transpose(dYG_i(i_desc_i, 1)%x(l, n_i)%mm), Y_i(2,l)%mm) - if(do_two_l_plus_one) Pl_g2 = Pl_g2 / sqrt(2.0_dp * l + 1.0_dp) - endif - - i_pow = l + 1 - do ia = 1, K1 - ub = K2 - if (sym_desc) ub = ia - do jb = 1, ub - ic = (jb-1) * 3 - ir = (ia-1) * 3 - if (sym_desc) then - r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g1(jb, ir+1:ir+3) - else - r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g2(ir+1:ir+3, jb) - endif - - if(ia /= jb .and. sym_desc ) r_tmp = r_tmp * SQRT_TWO - grad_descriptor_i(i_pow, :) = r_tmp - i_pow = i_pow + this%l_max+1 - enddo - enddo - enddo !l - - - ! element-wise coupling - elseif(.not. this%coupling ) then - - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - i_pow = l + 1 - !do ik = 1, K1 - do ik = 1, SIZE(sym_facs) - ia = coupling_inds(ik, 1) - jb = coupling_inds(ik, 2) - ir = (jb-1) * 3 - r_tmp = matmul(transpose(dYG_r(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, ia)) + matmul(transpose(dYG_i(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, ia) ) - ir = (ia-1)*3 - if (sym_desc) then - r_tmp = r_tmp + matmul(transpose(dYG_r(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, jb) ) + matmul(transpose(dYG_i(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, jb) ) - else - r_tmp = r_tmp + matmul(transpose(dYG_r(i_desc_i, 1)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_r(2, l)%mm(:, jb) ) + matmul(transpose(dYG_i(i_desc_i, 1)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_i(2, l)%mm(:, jb) ) - endif - grad_descriptor_i(i_pow, :) = r_tmp * tlpo * sym_facs(ik) - i_pow = i_pow + this%l_max + 1 - enddo - enddo - - !original power spectrum gradients as special case to exploit sparsity of dX_r w.r.t the neighbour species - else - do l = 0, this%l_max - tlpo = 1.0_dp - if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) - !TODO try swapping order? - call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, dXG_r(i_desc_i)%x(l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) - call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, dXG_i(i_desc_i)%x(l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) - - i_pow = l + 1 - do ia = 1, K1 - a = rs_index(1,ia) - i_species = rs_index(2,ia) - do jb = 1, ia - b = rs_index(1,jb) - j_species = rs_index(2,jb) - if (this%diagonal_radial .and. a /= b) cycle - if(at%Z(j) == this%species_Z(i_species) .or. this%species_Z(i_species)==0) then - ic = (a-1) * 3 - grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(jb, ic+1:ic+3) - endif - if(at%Z(j) == this%species_Z(j_species) .or. this%species_Z(j_species)==0) then - ic = (b-1) * 3 - grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(ia, ic+1:ic+3) - endif - - if(ia /= jb) grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) * SQRT_TWO - i_pow = i_pow + this%l_max+1 - enddo !jb - enddo !ia - enddo !l - endif !various gradient options - - grad_descriptor_i(d, 1:3) = 0.0_dp - if( this%normalise ) then - descriptor_out%x(1)%grad_data(:,:,i_pair) = grad_descriptor_i / norm_descriptor_i - do k = 1, 3 - descriptor_out%x(1)%grad_data(:,k,i_pair) = descriptor_out%x(1)%grad_data(:,k,i_pair) - descriptor_i * dot_product(descriptor_i,grad_descriptor_i(:,k)) / norm_descriptor_i**3 - enddo - else - descriptor_out%x(1)%grad_data(:,:,i_pair) = grad_descriptor_i - endif - - descriptor_out%x(1)%grad_data(:,:,i_pair_i) = descriptor_out%x(1)%grad_data(:,:,i_pair_i) - descriptor_out%x(1)%grad_data(:,:,i_pair) - enddo !n_i - enddo !i - deallocate(grad_descriptor_i) - endif ! do gradients - - if(allocated(descriptor_i)) deallocate(descriptor_i) - endif ! this%global - - if(allocated(global_fourier_so3_r_array)) deallocate(global_fourier_so3_r_array) - if(allocated(global_fourier_so3_i_array)) deallocate(global_fourier_so3_i_array) - - if(allocated(global_grad_fourier_so3_r_array)) then - do i_desc_i = lbound(global_grad_fourier_so3_r_array,1), ubound(global_grad_fourier_so3_r_array,1) - if(allocated(global_grad_fourier_so3_r_array(i_desc_i)%x)) then - do n_i = lbound(global_grad_fourier_so3_r_array(i_desc_i)%x,3), ubound(global_grad_fourier_so3_r_array(i_desc_i)%x,3) - do a = lbound(global_grad_fourier_so3_r_array(i_desc_i)%x,2), ubound(global_grad_fourier_so3_r_array(i_desc_i)%x,2) - do l = lbound(global_grad_fourier_so3_r_array(i_desc_i)%x,1), ubound(global_grad_fourier_so3_r_array(i_desc_i)%x,1) - if(allocated(global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm)) deallocate(global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm) - enddo ! l - enddo ! a - enddo ! n_i - deallocate(global_grad_fourier_so3_r_array(i_desc_i)%x) - endif - enddo ! i_desc_i - deallocate(global_grad_fourier_so3_r_array) - endif - - if(allocated(global_grad_fourier_so3_i_array)) then - do i_desc_i = lbound(global_grad_fourier_so3_i_array,1), ubound(global_grad_fourier_so3_i_array,1) - if(allocated(global_grad_fourier_so3_i_array(i_desc_i)%x)) then - do n_i = lbound(global_grad_fourier_so3_i_array(i_desc_i)%x,3), ubound(global_grad_fourier_so3_i_array(i_desc_i)%x,3) - do a = lbound(global_grad_fourier_so3_i_array(i_desc_i)%x,2), ubound(global_grad_fourier_so3_i_array(i_desc_i)%x,2) - do l = lbound(global_grad_fourier_so3_i_array(i_desc_i)%x,1), ubound(global_grad_fourier_so3_i_array(i_desc_i)%x,1) - if(allocated(global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm)) deallocate(global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm) - enddo ! l - enddo ! a - enddo ! n_i - deallocate(global_grad_fourier_so3_i_array(i_desc_i)%x) - endif - enddo ! i_desc_i - deallocate(global_grad_fourier_so3_i_array) - endif - - !deallocate gradients for standard global soap - if (allocated(dXG_r)) then - do i_desc_i = lbound(dXG_r,1), ubound(dXG_r,1) - if (allocated(dXG_r(i_desc_i)%x)) then - do n_i = lbound(dXG_r(i_desc_i)%x,2), ubound(dXG_r(i_desc_i)%x,2) - do l = 0, this%l_max - if (allocated(dXG_r(i_desc_i)%x(l, n_i)%mm)) deallocate(dXG_r(i_desc_i)%x(l, n_i)%mm) - if (allocated(dXG_i(i_desc_i)%x(l, n_i)%mm)) deallocate(dXG_i(i_desc_i)%x(l, n_i)%mm) - enddo !l - enddo !n_i - deallocate(dXG_r(i_desc_i)%x) - deallocate(dXG_i(i_desc_i)%x) - endif - enddo - deallocate(dXG_r, dXG_i) - endif - - if (allocated(dYG_r)) then - do i_desc_i = lbound(dYG_r,1), ubound(dYG_r,1) - do k = 1, 2 - if (allocated(dYG_r(i_desc_i, k)%x)) then - do n_i = lbound(dYG_r(i_desc_i, k)%x,2), ubound(dYG_r(i_desc_i, k)%x,2) - do l = 0, this%l_max - if (allocated(dYG_r(i_desc_i, k)%x(l, n_i)%mm)) deallocate(dYG_r(i_desc_i, k)%x(l, n_i)%mm) - if (allocated(dYG_i(i_desc_i, k)%x(l, n_i)%mm)) deallocate(dYG_i(i_desc_i, k)%x(l, n_i)%mm) - enddo !l - enddo !n_i - deallocate(dYG_r(i_desc_i, k)%x) - deallocate(dYG_i(i_desc_i, k)%x) - endif - enddo - enddo - deallocate(dYG_r, dYG_i) - endif - - - !deallocate density expansion coefficients - if (allocated(X_r)) then - do l = 0, this%l_max - if (allocated(X_r(l)%mm)) deallocate(X_r(l)%mm) - if (allocated(X_i(l)%mm)) deallocate(X_i(l)%mm) - enddo - if (allocated(X_r)) deallocate(X_r) - if (allocated(X_i)) deallocate(X_i) - endif - - if (allocated(Y_r)) then - do k = 1, 2 - do l = 0, this%l_max - if (allocated(Y_r(k, l)%mm)) deallocate(Y_r(k, l)%mm) - if (allocated(Y_i(k, l)%mm)) deallocate(Y_i(k, l)%mm) - enddo - enddo - if (allocated(Y_r)) deallocate(Y_r) - if (allocated(Y_i)) deallocate(Y_i) - endif - - if (allocated(Pl_g1)) deallocate(Pl_g1) - if (allocated(Pl_g2)) deallocate(Pl_g2) - if (allocated(W)) deallocate(W) - if (allocated(Pl)) deallocate(Pl) - if (allocated(rs_index)) deallocate(rs_index) - if (allocated(i_desc)) deallocate(i_desc) - if (allocated(coupling_inds)) deallocate(coupling_inds) - if (allocated(sym_facs)) deallocate(sym_facs) - - call system_timer('soap_calc') - - endsubroutine soap_calc - - - subroutine rdf_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(rdf), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, i, j, n, i_n, l_n_neighbours, i_desc, n_descriptors, n_cross, n_index - integer, dimension(3) :: shift - real(dp) :: r_ij, f_cut, df_cut - real(dp), dimension(3) :: u_ij - real(dp), dimension(:), allocatable :: rdf_ij - - INIT_ERROR(error) - - call system_timer('rdf_calc') - - if(.not. this%initialised) then - RAISE_ERROR("rdf_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='rdf_calc args_str')) then - RAISE_ERROR("rdf_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("rdf_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - call finalise(descriptor_out) - - d = rdf_dimensions(this,error) - allocate(rdf_ij(d)) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - i_desc = i_desc + 1 - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - i_desc = 0 - do i = 1, at%N - - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - i_n = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) - - if( r_ij >= this%cutoff ) cycle - i_n = i_n + 1 - - rdf_ij = exp( -0.5_dp * (r_ij - this%r_gauss)**2 / this%w_gauss**2 ) - f_cut = coordination_function(r_ij,this%cutoff,this%transition_width) - - if(my_do_descriptor) & - descriptor_out%x(i_desc)%data = descriptor_out%x(i_desc)%data + rdf_ij * f_cut - - if(my_do_grad_descriptor) then - df_cut = dcoordination_function(r_ij,this%cutoff,this%transition_width) - - descriptor_out%x(i_desc)%ii(i_n) = j - descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift) - descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. - - descriptor_out%x(i_desc)%grad_data(:,:,i_n) = ( - ( rdf_ij * (r_ij - this%r_gauss) / this%w_gauss**2 ) * f_cut + rdf_ij * df_cut ) .outer. u_ij - descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,i_n) - endif - enddo - enddo - - if(allocated(rdf_ij)) deallocate(rdf_ij) - - call system_timer('rdf_calc') - - endsubroutine rdf_calc - - subroutine as_distance_2b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(as_distance_2b), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(descriptor) :: my_coordination - type(descriptor_data) :: descriptor_coordination - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor, Zi1, Zi2, Zj1, Zj2 - integer :: d, n_descriptors, n_cross, i_desc, i, j, k, n, m, & - n_neighbours_coordination_i, n_neighbours_coordination_ij, n_index - integer, dimension(3) :: shift - real(dp) :: r_ij, r_ik, r_jk, cos_ijk, cos_jik, f_cut_i, f_cut_j, f_cut_ij, f_cut_ik, f_cut_jk, f_cut_as_i, f_cut_as_j, rho_i, rho_j - real(dp), dimension(3) :: u_ij, u_ik, u_jk - - INIT_ERROR(error) - call system_timer('as_distance_2b_calc') - - if(.not. this%initialised) then - RAISE_ERROR("as_distance_2b_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='as_distance_2b_calc args_str')) then - RAISE_ERROR("as_distance_2b_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("as_distance_2b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - RAISE_ERROR("as_distance_2b_calc cannot use atom masks yet.",error) - else - atom_mask_pointer => null() - endif - - endif - - d = as_distance_2b_dimensions(this,error) - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - - - allocate(descriptor_out%x(n_descriptors)) - i_desc = 0 - do i = 1, at%N - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij) - - if(r_ij > this%max_cutoff .or. r_ij < this%min_cutoff) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - rho_i = 0.0_dp - f_cut_i = 0.0_dp - - do m = 1, n_neighbours(at,i) - k = neighbour(at, i, m, distance=r_ik, cosines=u_ik) - - if(r_ik > this%coordination_cutoff) cycle - - cos_ijk = dot_product(u_ij,u_ik) - f_cut_ik = coordination_function(r_ik,this%coordination_cutoff,this%coordination_transition_width) - - f_cut_i = f_cut_i + f_cut_ik - rho_i = rho_i + 0.5_dp * ( erf(cos_ijk/this%overlap_alpha) + 1.0_dp ) * f_cut_ik**2 - enddo - - rho_i = rho_i / f_cut_i - - if(rho_i > this%as_cutoff) cycle - - rho_j = 0.0_dp - f_cut_j = 0.0_dp - - do m = 1, n_neighbours(at,j) - k = neighbour(at, j, m, distance=r_jk, cosines=u_jk) - - if(r_jk > this%coordination_cutoff) cycle - - cos_jik = dot_product(-u_ij,u_jk) - f_cut_jk = coordination_function(r_jk,this%coordination_cutoff,this%coordination_transition_width) - - f_cut_j = f_cut_j + f_cut_jk - rho_j = rho_j + 0.5_dp * ( erf(cos_jik/this%overlap_alpha) + 1.0_dp ) * f_cut_jk**2 - enddo - - if(rho_j > this%as_cutoff) cycle - ! all three conditions fulfilled: pair within lower and upper cutoff, asymmetricity lower than threshold - - i_desc = i_desc + 1 - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - endif - - if(my_do_grad_descriptor) then - n_neighbours_coordination_ij = n_neighbours(at,i,max_dist=this%coordination_cutoff) + & - n_neighbours(at,j,max_dist=this%coordination_cutoff) + 2 - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:1+n_neighbours_coordination_ij)) - allocate(descriptor_out%x(i_desc)%ii(0:1+n_neighbours_coordination_ij)) - allocate(descriptor_out%x(i_desc)%pos(3,0:1+n_neighbours_coordination_ij)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:1+n_neighbours_coordination_ij)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:1+n_neighbours_coordination_ij)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - enddo - - i_desc = 0 - do i = 1, at%N - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) - - if(r_ij > this%max_cutoff .or. r_ij < this%min_cutoff) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - rho_i = 0.0_dp - f_cut_i = 0.0_dp - - do m = 1, n_neighbours(at,i) - k = neighbour(at, i, m, distance=r_ik, cosines=u_ik) - - if(r_ik > this%coordination_cutoff) cycle - - cos_ijk = dot_product(u_ij,u_ik) - f_cut_ik = coordination_function(r_ik,this%coordination_cutoff,this%coordination_transition_width) - - f_cut_i = f_cut_i + f_cut_ik - rho_i = rho_i + 0.5_dp * ( erf(cos_ijk/this%overlap_alpha) + 1.0_dp ) * f_cut_ik**2 - enddo - - rho_i = rho_i / f_cut_i - - if(rho_i > this%as_cutoff) cycle - - rho_j = 0.0_dp - f_cut_j = 0.0_dp - - do m = 1, n_neighbours(at,j) - k = neighbour(at, j, m, distance=r_jk, cosines=u_jk) - - if(r_jk > this%coordination_cutoff) cycle - - cos_jik = dot_product(-u_ij,u_jk) - f_cut_jk = coordination_function(r_jk,this%coordination_cutoff,this%coordination_transition_width) - - f_cut_j = f_cut_j + f_cut_jk - rho_j = rho_j + 0.5_dp * ( erf(cos_jik/this%overlap_alpha) + 1.0_dp ) * f_cut_jk**2 - enddo - - if(rho_j > this%as_cutoff) cycle - ! all three conditions fulfilled: pair within lower and upper cutoff, asymmetricity lower than threshold - - i_desc = i_desc + 1 - - f_cut_ij = coordination_function(r_ij,this%max_cutoff,this%max_transition_width,this%min_cutoff,this%min_transition_width) - f_cut_as_i = coordination_function(rho_i,this%as_cutoff, this%as_transition_width) - f_cut_as_j = coordination_function(rho_j,this%as_cutoff, this%as_transition_width) - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1:2) = (/i,j/) - - descriptor_out%x(i_desc)%has_data = .true. - - descriptor_out%x(i_desc)%data(1) = r_ij - descriptor_out%x(i_desc)%data(2) = f_cut_i + f_cut_j - descriptor_out%x(i_desc)%data(3) = (f_cut_i - f_cut_j)**2 - - descriptor_out%x(i_desc)%covariance_cutoff = f_cut_ij * f_cut_as_i * f_cut_as_j - endif - if(my_do_grad_descriptor) then - n_neighbours_coordination_i = n_neighbours(at,i,max_dist=this%coordination_cutoff) - - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - descriptor_out%x(i_desc)%grad_data(1,:,0) = -u_ij(:) - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = -dcoordination_function(r_ij,this%coordination_cutoff,this%coordination_transition_width)*u_ij - - !descriptor_out%x(i_desc)%ii(1) = j - !descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift) - !descriptor_out%x(i_desc)%has_grad_data(1) = .true. - !descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij(:) - !descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) - - !descriptor_out%x(i_desc)%ii(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%ii(:) - !descriptor_out%x(i_desc)%pos(:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%pos(:,:) - !descriptor_out%x(i_desc)%has_grad_data(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%has_grad_data(:) - !descriptor_out%x(i_desc)%grad_data(2,:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%grad_data(1,:,:) - !descriptor_out%x(i_desc)%grad_data(3,:,2:n_neighbours_coordination_i+2) = 2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& - ! descriptor_coordination%x(i)%grad_data(1,:,:) - - !descriptor_out%x(i_desc)%ii(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%ii(:) - !descriptor_out%x(i_desc)%pos(:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%pos(:,:) - !descriptor_out%x(i_desc)%has_grad_data(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%has_grad_data(:) - !descriptor_out%x(i_desc)%grad_data(2,:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%grad_data(1,:,:) - !descriptor_out%x(i_desc)%grad_data(3,:,n_neighbours_coordination_i+3:) = -2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& - ! descriptor_coordination%x(j)%grad_data(1,:,:) - - endif - enddo - enddo - - call finalise(my_coordination) - call finalise(descriptor_coordination) - - call system_timer('as_distance_2b_calc') - - endsubroutine as_distance_2b_calc - - - subroutine alex_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(alex), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor - - integer :: i, j, n, d, p, q, r, a, b, c, n_i, n_radial, pp, i_desc, & - l_n_neighbours, desc_index, n_cross, n_descriptors, n_index - integer, dimension(3) :: shift_ij - real(dp) :: r_ij - real(dp), dimension(3) :: d_ij - real(dp), dimension(:), allocatable :: neighbour_dists - real(dp), dimension(:,:), allocatable :: neighbour_vecs - integer, dimension(total_elements) :: species_map - real(dp), allocatable :: S0(:), S1(:,:), S2(:,:,:), S0der(:,:,:), S1der(:,:,:,:), S2der(:,:,:,:,:) - - INIT_ERROR(error) - - call system_timer('alex_calc') - - if(.not. this%initialised) then - RAISE_ERROR("alex_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='alex_calc args_str')) then - RAISE_ERROR("alex_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("alex_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - species_map = 0 - do i = 1, size(this%species_Z) - if(this%species_Z(i) == 0) then - species_map = 1 - else - species_map(this%species_Z(i)) = i - endif - enddo - - call finalise(descriptor_out) - - d = alex_dimensions(this,error) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - - n_radial = this%power_max-this%power_min+1 - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - - i_desc = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - - ! number of neighbours for the current atom within the descriptor cutoff - l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) - allocate(neighbour_vecs(3,l_n_neighbours), neighbour_dists(l_n_neighbours)) - allocate(S0(n_radial), S1(3,n_radial), S2(3,3,n_radial)) - if(my_do_grad_descriptor) then - allocate( & - S0der(n_radial,l_n_neighbours,3), & - S1der(3,n_radial,l_n_neighbours,3), & - S2der(3,3,n_radial,l_n_neighbours,3) ) - endif - - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, diff=d_ij) - if( r_ij >= this%cutoff ) cycle - n_i = n_i + 1 - neighbour_vecs(:,n_i) = d_ij - neighbour_dists(n_i) = r_ij - end do - - do p = 1,n_radial - pp = -(p+this%power_min-1) - S0(p) = sum(neighbour_dists**pp) - if(my_do_grad_descriptor) then - do n_i = 1, l_n_neighbours - S0der(p,n_i,:) = pp * neighbour_dists(n_i)**(pp-2) * neighbour_vecs(:,n_i) - enddo - endif - - S1(:,p) = matmul(neighbour_vecs, neighbour_dists**pp) - !do a = 1,3 - !S1(a, p) = sum(neighbour_vecs(a,:)*neighbour_dists**pp) - !end do - if(my_do_grad_descriptor) then - do n_i = 1, l_n_neighbours - do a = 1,3 - S1der(a,p,n_i,:) = pp * neighbour_dists(n_i)**(pp-2) * neighbour_vecs(a,n_i) * neighbour_vecs(:,n_i) - S1der(a,p,n_i,a) = S1der(a,p,n_i,a) + neighbour_dists(n_i)**pp - end do - enddo - endif - - !do a=1,3 - do b=1,3 - S2(:,b,p) = matmul(neighbour_vecs, neighbour_vecs(b,:)*neighbour_dists**pp) - !S2(a,b,p) = sum(neighbour_vecs(a,:)*neighbour_vecs(b,:)*neighbour_dists**pp) - end do - !end do - - if(my_do_grad_descriptor) then - do n_i = 1, l_n_neighbours - do a = 1,3 - do b = 1,3 - S2der(a,b,p,n_i,:) = pp * neighbour_dists(n_i)**(pp-2) * neighbour_vecs(a,n_i) * neighbour_vecs(b,n_i) * neighbour_vecs(:,n_i) - end do - end do - - do a = 1,3 - do b = 1,3 - S2der(a,b,p,n_i,b) = S2der(a,b,p,n_i,b) + neighbour_dists(n_i)**pp * neighbour_vecs(a,n_i) - S2der(a,b,p,n_i,a) = S2der(a,b,p,n_i,a) + neighbour_dists(n_i)**pp * neighbour_vecs(b,n_i) - end do - end do - enddo - endif - end do - - descriptor_out%x(i_desc)%data(1:n_radial) = S0 - descriptor_out%x(i_desc)%data(n_radial+1:n_radial+n_radial**2) = reshape(matmul(transpose(S1), S1), (/n_radial**2/)) - desc_index = n_radial+n_radial**2+1 - do p = 1,n_radial - do q = 1,n_radial - descriptor_out%x(i_desc)%data(desc_index) = sum(S2(:,:,p) * S2(:,:,q)) - desc_index = desc_index + 1 - end do - end do - - do p = 1,n_radial - do q = 1,n_radial - do r = 1,n_radial - descriptor_out%x(i_desc)%data(desc_index) = dot_product(S1(:,p), matmul(S2(:,:,q), S1(:,r))) - desc_index = desc_index + 1 - end do - end do - end do - - if(my_do_grad_descriptor) then - n_i = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, shift=shift_ij) - if( r_ij >= this%cutoff ) cycle - - n_i = n_i + 1 - - descriptor_out%x(i_desc)%ii(n_i) = j - descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. - - descriptor_out%x(i_desc)%grad_data(1:n_radial,:,n_i) = S0der(:,n_i,:) - - desc_index = n_radial + 1 - do p = 1,n_radial - do q = 1,n_radial - do a = 1, 3 - do c = 1, 3 - descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) = descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) + & - S1der(a,p,n_i,c)*S1(a,q) + S1(a,p)*S1der(a,q,n_i,c) - enddo - enddo - desc_index = desc_index + 1 - enddo - enddo - - do p = 1, n_radial - do q = 1, n_radial - do a = 1, 3 - do b = 1, 3 - do c = 1, 3 - descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) = descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) + & - S2der(a,b,p,n_i,c)*S2(a,b,q) + S2(a,b,p)*S2der(a,b,q,n_i,c) - enddo - enddo - enddo - desc_index = desc_index + 1 - enddo - enddo - - do p = 1, n_radial - do q = 1, n_radial - do r = 1, n_radial - do a = 1, 3 - do b = 1, 3 - do c = 1, 3 - descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) = descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) + & - S1der(a,p,n_i,c) * S2(a,b,q) * S1(b,r) + & - S1(a,p) * S2der(a,b,q,n_i,c) * S1(b,r) + & - S1(a,p) * S2(a,b,q) * S1der(b,r,n_i,c) - enddo - enddo - enddo - desc_index = desc_index + 1 - enddo - enddo - enddo - enddo - - descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,n_i) - deallocate(S0der, S1der, S2der) - endif - - deallocate(neighbour_vecs, neighbour_dists, S0, S1, S2) - enddo - - - call system_timer('alex_calc') - - endsubroutine alex_calc - - subroutine distance_Nb_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - type(distance_Nb), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - - logical :: my_do_descriptor, my_do_grad_descriptor - integer :: d, n_descriptors, n_cross, i_desc, i_data, i, j, ii, jj, kk, ll, & - iConnectivity, n_index - integer, dimension(3) :: s_i, s_j - real(dp) :: r_ij, fcut_connectivity - real(dp), dimension(3) :: dfcut_connectivity - real(dp), dimension(3) :: d_ij - integer, dimension(:,:,:), allocatable :: atoms_in_descriptors - real(dp), dimension(:,:), allocatable :: fcut_pair, dfcut_pair - real(dp), dimension(:,:,:), allocatable :: directions - - logical, dimension(:), pointer :: atom_mask_pointer => null() - - INIT_ERROR(error) - - call system_timer('distance_Nb_calc') - - if(.not. this%initialised) then - RAISE_ERROR("distance_Nb_calc: descriptor object not initialised", error) - endif - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - - call finalise(descriptor_out) - - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='distance_Nb_calc args_str')) then - RAISE_ERROR("distance_Nb_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - atom_mask_pointer => null() - - if( has_atom_mask_name ) then - if( .not. this%compact_clusters ) then - RAISE_ERROR("distance_Nb_calc: MPI/LAMMPS ready only for compact_clusters=T type of distance_Nb.", error) - endif - - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("distance_Nb_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - d = distance_Nb_dimensions(this,error) - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask = atom_mask_pointer,n_index=n_index, error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - do i = 1, n_descriptors - if(my_do_descriptor) then - allocate(descriptor_out%x(i)%data(d)) - descriptor_out%x(i)%data = 0.0_dp - allocate(descriptor_out%x(i)%ci(n_index)) - descriptor_out%x(i)%ci = 0 - descriptor_out%x(i)%has_data = .false. - descriptor_out%x(i)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then - allocate(descriptor_out%x(i)%grad_data(d,3,this%order)) - allocate(descriptor_out%x(i)%ii(this%order)) - allocate(descriptor_out%x(i)%pos(3,this%order)) - allocate(descriptor_out%x(i)%has_grad_data(this%order)) - descriptor_out%x(i)%grad_data = 0.0_dp - descriptor_out%x(i)%ii = 0 - descriptor_out%x(i)%pos = 0.0_dp - descriptor_out%x(i)%has_grad_data = .false. - - allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,this%order)) - descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - if(associated(atom_mask_pointer)) then - call distance_Nb_calc_get_clusters(this,at,atoms_in_descriptors=atoms_in_descriptors,mask=atom_mask_pointer,error=error) - else - call distance_Nb_calc_get_clusters(this,at,atoms_in_descriptors=atoms_in_descriptors,error=error) - endif - - allocate(fcut_pair(this%order,this%order)) - if( my_do_grad_descriptor ) then - allocate(dfcut_pair(this%order,this%order), directions(3,this%order,this%order)) - endif - - do i_desc = 1, n_descriptors - if( this%order == 1 ) then - descriptor_out%x(i_desc)%data = 0.0_dp - if( my_do_grad_descriptor ) descriptor_out%x(i_desc)%grad_data = 0.0_dp - else - i_data = 0 - do ii = 1, this%order - i = atoms_in_descriptors(1,ii,i_desc) - s_i = atoms_in_descriptors(2:4,ii,i_desc) - do jj = ii+1, this%order - i_data = i_data + 1 - j = atoms_in_descriptors(1,jj,i_desc) - s_j = atoms_in_descriptors(2:4,jj,i_desc) - d_ij = at%pos(:,j) - at%pos(:,i) + matmul(at%lattice,s_j-s_i) - r_ij = sqrt(sum(d_ij**2)) - - fcut_pair(jj,ii) = coordination_function(r_ij,this%cutoff,this%cutoff_transition_width) - fcut_pair(ii,jj) = fcut_pair(jj,ii) - - descriptor_out%x(i_desc)%data(i_data) = r_ij - if( my_do_grad_descriptor ) then - dfcut_pair(ii,jj) = dcoordination_function(r_ij,this%cutoff,this%cutoff_transition_width) - dfcut_pair(jj,ii) = dfcut_pair(ii,jj) - - directions(:,ii,jj) = d_ij / r_ij - directions(:,jj,ii) = - directions(:,ii,jj) - descriptor_out%x(i_desc)%grad_data(i_data,:,jj) = directions(:,ii,jj) - descriptor_out%x(i_desc)%grad_data(i_data,:,ii) = & - - descriptor_out%x(i_desc)%grad_data(i_data,:,jj) - endif - enddo - enddo - - descriptor_out%x(i_desc)%covariance_cutoff = 0.0_dp - if ( this%compact_clusters ) then - - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - - do jj = 2, this%order - descriptor_out%x(i_desc)%covariance_cutoff = descriptor_out%x(i_desc)%covariance_cutoff * fcut_pair(jj,1) - enddo - - if( my_do_grad_descriptor ) then - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = 0.0_dp - do kk = 2, this%order - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = 1.0_dp - do jj = 2, this%order - if( jj == kk ) then - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = & - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) * dfcut_pair(jj,1) * (-directions(:,jj,1)) - else - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = & - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) * fcut_pair(jj,1) - endif - enddo - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = & - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) - enddo - endif - - - else - do iConnectivity = 1, size(this%monomerConnectivities,3) - - fcut_connectivity = 1.0_dp - - do ii = 1, this%order - do jj = ii+1, this%order - if( this%monomerConnectivities(jj,ii,iConnectivity) ) then - fcut_connectivity = fcut_connectivity * fcut_pair(jj,ii) - else - fcut_connectivity = fcut_connectivity * ( 1.0_dp - fcut_pair(jj,ii) ) - endif - enddo - enddo - descriptor_out%x(i_desc)%covariance_cutoff = descriptor_out%x(i_desc)%covariance_cutoff + fcut_connectivity - - if( my_do_grad_descriptor ) then - do kk = 1, this%order - do ll = kk+1, this%order - dfcut_connectivity = 1.0_dp - do ii = 1, this%order - do jj = ii+1, this%order - if( this%monomerConnectivities(jj,ii,iConnectivity) ) then - if( kk == ii .and. ll == jj ) then - dfcut_connectivity = dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) - elseif( kk == jj .and. ll == ii ) then - dfcut_connectivity = dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) - else - dfcut_connectivity = dfcut_connectivity * fcut_pair(jj,ii) - endif - else - if( kk == ii .and. ll == jj ) then - dfcut_connectivity = - dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) - elseif( kk == jj .and. ll == ii) then - dfcut_connectivity = - dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) - else - dfcut_connectivity = dfcut_connectivity * ( 1.0_dp - fcut_pair(jj,ii) ) - endif - endif - enddo !jj - enddo !ii - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) + & - dfcut_connectivity - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,ll) = descriptor_out%x(i_desc)%grad_covariance_cutoff(:,ll) - & - dfcut_connectivity - enddo !ll - enddo !kk - endif - - enddo - endif - - endif - - descriptor_out%x(i_desc)%ci = atoms_in_descriptors(1,:,i_desc) - descriptor_out%x(i_desc)%has_data = .true. - if( my_do_grad_descriptor ) then - descriptor_out%x(i_desc)%ii = descriptor_out%x(i_desc)%ci - descriptor_out%x(i_desc)%pos = at%pos(:,descriptor_out%x(i_desc)%ii) + & - matmul(at%lattice,atoms_in_descriptors(2:4,:,i_desc)) - descriptor_out%x(i_desc)%has_grad_data = .true. - endif - - enddo - - if(allocated(atoms_in_descriptors)) deallocate(atoms_in_descriptors) - if(allocated(fcut_pair)) deallocate(fcut_pair) - if(allocated(dfcut_pair)) deallocate(dfcut_pair) - if(allocated(directions)) deallocate(directions) - - call system_timer('distance_Nb_calc') - - endsubroutine distance_Nb_calc - - subroutine soap_turbo_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) - use soap_turbo_desc - - type(soap_turbo), intent(in) :: this - type(atoms), intent(in) :: at - type(descriptor_data), intent(out) :: descriptor_out - logical, intent(in), optional :: do_descriptor, do_grad_descriptor - character(len=*), intent(in), optional :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - logical :: my_do_descriptor, my_do_grad_descriptor, do_timing - integer :: d, i, j, k, n, i_n, l_n_neighbours, & - i_desc, n_descriptors, n_cross, n_index, n_atom_pairs - real(dp) :: r_ij - real(dp), dimension(3) :: d_ij, u_ij - real(dp), dimension(:), allocatable :: rjs, thetas, phis, rcut_hard, rcut_soft, nf, global_scaling - real(dp), dimension(:,:), allocatable :: descriptor_i - real(dp), dimension(:,:,:), allocatable :: grad_descriptor_i - integer, dimension(:), allocatable :: species_map - integer, dimension(3) :: shift_ij - logical, dimension(:,:), allocatable :: mask - - INIT_ERROR(error) - - call system_timer('soap_turbo_calc') - - if(.not. this%initialised) then - RAISE_ERROR("soap_turbo_calc: descriptor object not initialised", error) - endif - -! This is to make the code compatible with the newest TurboGAP (which as multisoap support) - allocate( rcut_hard(this%n_species) ) - allocate( rcut_soft(this%n_species) ) - allocate( nf(this%n_species) ) - allocate( global_scaling(this%n_species) ) - rcut_hard = this%rcut_hard - rcut_soft = this%rcut_soft - nf = this%nf - global_scaling = 1.0_dp - - my_do_descriptor = optional_default(.false., do_descriptor) - my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) - - if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return - -! allocate(species_map(maxval(this%species_Z))) - allocate(species_map(1:118)) - species_map = 0 - species_map(this%species_Z) = (/(i, i = 1, this%n_species)/) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & - "calculated.") - - call param_register(params, 'do_timing', 'F', do_timing, help_string="Do timing or not") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='coordination_calc args_str')) then - RAISE_ERROR("soap_turbo_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("soap_turbo_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - endif - - call finalise(descriptor_out) - - d = soap_turbo_dimensions(this,error) - - allocate(descriptor_i(d,1)) - - if(associated(atom_mask_pointer)) then - call descriptor_sizes(this,at,n_descriptors,n_cross, & - mask=atom_mask_pointer,n_index=n_index,error=error) - else - call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) - endif - - allocate(descriptor_out%x(n_descriptors)) - i_desc = 0 - do i = 1, at%N - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - if( at%Z(i) /= this%species_Z(this%central_index) ) cycle - - i_desc = i_desc + 1 - if(my_do_descriptor) then - allocate(descriptor_out%x(i_desc)%data(d)) - descriptor_out%x(i_desc)%data = 0.0_dp - allocate(descriptor_out%x(i_desc)%ci(n_index)) - descriptor_out%x(i_desc)%has_data = .false. - - descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp - endif - if(my_do_grad_descriptor) then -! l_n_neighbours = n_neighbours(at,i,max_dist=this%rcut_hard) - l_n_neighbours = 0 - do n = 1, n_neighbours(at, i) - j = neighbour(at, i, n, distance = r_ij) -! The neighbors list past to the soap_turbo library must only contained the "seen" species - if( r_ij < this%rcut_hard .and. species_map(at%Z(j)) > 0)then - l_n_neighbours = l_n_neighbours + 1 - endif - enddo - allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) - allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_data = 0.0_dp - descriptor_out%x(i_desc)%ii = 0 - descriptor_out%x(i_desc)%pos = 0.0_dp - descriptor_out%x(i_desc)%has_grad_data = .false. - - allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) - descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp - endif - enddo - - i_desc = 0 - do i = 1, at%N - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - if( at%Z(i) /= this%species_Z(this%central_index) ) cycle - - i_desc = i_desc + 1 - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%ci(1) = i - descriptor_out%x(i_desc)%has_data = .true. - endif - if(my_do_grad_descriptor) then - descriptor_out%x(i_desc)%ii(0) = i - descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) - descriptor_out%x(i_desc)%has_grad_data(0) = .true. - endif - -! n_atom_pairs = n_neighbours(at,i, max_dist = this%rcut_hard) + 1 !Including the central atom - n_atom_pairs = 1 !Including the central atom - do n = 1, n_neighbours(at, i) - j = neighbour(at, i, n, distance = r_ij) -! The neighbors list past to the soap_turbo library must only contained the "seen" species - if( r_ij < this%rcut_hard .and. species_map(at%Z(j)) > 0)then - n_atom_pairs = n_atom_pairs + 1 - endif - enddo - allocate( rjs(n_atom_pairs) ) - allocate( thetas(n_atom_pairs) ) - allocate( phis(n_atom_pairs) ) - allocate( mask(n_atom_pairs,this%n_species) ) - mask = .false. - - i_n = 1 ! Start with central atom - rjs(i_n) = 0.0_dp - thetas(i_n) = 0.0_dp - phis(i_n) = 0.0_dp - mask(i_n,species_map(at%Z(i))) = .true. - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, diff = d_ij, cosines = u_ij) - - if( r_ij >= this%rcut_hard .or. species_map(at%Z(j)) == 0 ) cycle - i_n = i_n + 1 - - rjs(i_n) = r_ij - - thetas(i_n) = dacos( u_ij(3) ) - phis(i_n) = datan2( d_ij(2), d_ij(1) ) - mask(i_n,species_map(at%Z(j))) = .true. - enddo - - if( my_do_grad_descriptor ) then - i_n = 0 - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij, shift = shift_ij) - if( r_ij >= this%rcut_hard .or. species_map(at%Z(j)) == 0 ) cycle - i_n = i_n + 1 - descriptor_out%x(i_desc)%ii(i_n) = j - descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift_ij) - descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. - enddo - endif - - descriptor_i = 0.0_dp - if( my_do_grad_descriptor ) then - allocate(grad_descriptor_i(3,d,n_atom_pairs)) - grad_descriptor_i = 0.0_dp - endif - call get_soap(1, (/n_atom_pairs/), this%n_species, reshape( (/species_map(at%Z(i))/), (/1,1/)), (/1/), & - n_atom_pairs, mask, rjs, thetas, phis, this%alpha_max, this%l_max, rcut_hard, rcut_soft, nf, & - global_scaling, this%atom_sigma_r, this%atom_sigma_r_scaling, & - this%atom_sigma_t, this%atom_sigma_t_scaling, this%amplitude_scaling, this%radial_enhancement, this%central_weight, & - this%basis, this%scaling_mode, .false., my_do_grad_descriptor, this%compress, this%compress_P_nonzero, this%compress_P_i, & - this%compress_P_j, this%compress_P_el, descriptor_i, grad_descriptor_i) - - if(my_do_descriptor) then - descriptor_out%x(i_desc)%data = descriptor_i(:,1) - endif - - if(my_do_grad_descriptor) then - do k = 1, 3 - descriptor_out%x(i_desc)%grad_data(:,k,0:n_atom_pairs-1) = grad_descriptor_i(k,:,1:n_atom_pairs) - enddo - endif - - deallocate(rjs) - deallocate(thetas) - deallocate(phis) - deallocate(mask) - if(allocated(grad_descriptor_i)) deallocate(grad_descriptor_i) - enddo - - deallocate(descriptor_i) - deallocate(species_map) - deallocate(rcut_hard) - deallocate(rcut_soft) - deallocate(nf) - deallocate(global_scaling) - - call system_timer('soap_turbo_calc') - - endsubroutine soap_turbo_calc - - subroutine distance_Nb_calc_get_clusters(this,at,atoms_in_descriptors,n_descriptors,mask,error) - - type(distance_Nb), intent(in) :: this - type(atoms), intent(in) :: at - integer, dimension(:,:,:), intent(out), allocatable, optional :: atoms_in_descriptors - integer, intent(out), optional :: n_descriptors - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: error - - integer, dimension(:,:,:), allocatable :: my_atoms_in_descriptors - - if( present(atoms_in_descriptors) ) then - call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors,n_descriptors=n_descriptors,mask=mask,error=error) - else - call distance_Nb_calc_neighbour_loop(this,at,my_atoms_in_descriptors,n_descriptors=n_descriptors,mask=mask,error=error) - if(allocated(my_atoms_in_descriptors)) deallocate(my_atoms_in_descriptors) - endif - - endsubroutine distance_Nb_calc_get_clusters - -! recursive subroutine distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors,n_descriptors,error) -! -! type(distance_Nb), intent(in) :: this -! type(atoms), intent(in) :: at -! integer, dimension(:,:,:), intent(inout), allocatable :: atoms_in_descriptors -! integer, intent(out), optional :: n_descriptors -! integer, intent(out), optional :: error -! -! integer, save :: current_order = 0 -! integer :: i, j, n, order, i_desc, d -! real(dp) :: r_ij -! integer, dimension(3) :: shift_i, shift_j, shift_ij -! integer, dimension(:,:), allocatable :: current_descriptor -! -! type(LinkedList_i2d), pointer :: LL_atoms_in_descriptors => null() -! -! INIT_ERROR(error) -! -! current_order = current_order + 1 -! -! if( current_order == 1 ) then -! allocate(current_descriptor(4,1)) -! -! do i = 1, at%N -! if( any( at%Z(i) == this%Z ) .or. any( 0 == this%Z ) ) then -! current_descriptor(:,1) = (/i,0,0,0/) -! call append(LL_atoms_in_descriptors,current_descriptor,error) -! endif -! enddo -! -! deallocate(current_descriptor) -! call retrieve(LL_atoms_in_descriptors,atoms_in_descriptors) -! call finalise(LL_atoms_in_descriptors) -! if( this%order > 1 ) & -! call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) -! -! if( present(n_descriptors) ) n_descriptors = size(atoms_in_descriptors,3) -! else -! if( .not. allocated(atoms_in_descriptors) ) then -! RAISE_ERROR("distance_Nb_calc_neighbour_loop: atoms_in_descriptors must be allocated",error) -! endif -! -! allocate(current_descriptor(4,current_order)) -! do i_desc = 1, size(atoms_in_descriptors,3) -! do order = 1, size(atoms_in_descriptors,2) -! i = atoms_in_descriptors(1,order,i_desc) -! shift_i = atoms_in_descriptors(2:4,order,i_desc) -! loop_n: do n = 1, n_neighbours(at,i) -! j = neighbour(at,i,n,distance = r_ij, shift = shift_ij) -! -! if( r_ij > this%cutoff ) cycle -! if( .not. is_subset(this%Z, at%Z( (/j,atoms_in_descriptors(1,:,i_desc)/) ), error) .and. all(this%Z /= 0) ) cycle -! -! shift_j = shift_ij + shift_i -! -! current_descriptor(:,1:current_order-1) = atoms_in_descriptors(:,:,i_desc) -! current_descriptor(:,current_order) = (/j, shift_j/) -! if( order_and_check_for_duplicates(current_descriptor,at) ) then -! do d = current_order, 1, -1 -! current_descriptor(2:4,d) = current_descriptor(2:4,d) - current_descriptor(2:4,1) -! enddo -! if( .not. is_in_LinkedList(LL_atoms_in_descriptors,current_descriptor,error) ) & -! call append(LL_atoms_in_descriptors,current_descriptor,error) -! endif -! enddo loop_n -! enddo -! enddo -! -! deallocate(current_descriptor) -! call retrieve(LL_atoms_in_descriptors,atoms_in_descriptors) -! call finalise(LL_atoms_in_descriptors) -! if( current_order < this%order ) & -! call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) -! endif -! -! current_order = current_order - 1 -! -! endsubroutine distance_Nb_calc_neighbour_loop - - recursive subroutine distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors,n_descriptors,mask,error) - - type(distance_Nb), intent(in) :: this - type(atoms), intent(in) :: at - integer, dimension(:,:,:), intent(inout), allocatable :: atoms_in_descriptors - integer, intent(out), optional :: n_descriptors - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: error - - integer, save :: current_order = 0 - integer :: i, j, n, order, i_desc, d - real(dp) :: r_ij - integer, dimension(3) :: shift_i, shift_j, shift_ij - integer, dimension(:,:), allocatable :: current_descriptor - - type(Table) :: Table_atoms_in_descriptors, Table_atoms_in_descriptors_uniq - - INIT_ERROR(error) - - current_order = current_order + 1 - - if( current_order == 1 ) then - call initialise(Table_atoms_in_descriptors, Nint = 4*current_order, Nreal = 0, Nstr = 0, Nlogical = 0, error=error) - allocate(current_descriptor(4,1)) - - do i = 1, at%N - if( any( at%Z(i) == this%Z ) .or. any( 0 == this%Z ) ) then - if( present(mask) ) then - if( .not. mask(i) ) cycle - endif - - current_descriptor(:,1) = (/i,0,0,0/) - call append(Table_atoms_in_descriptors,current_descriptor(:,1)) - endif - enddo - - deallocate(current_descriptor) - - allocate(atoms_in_descriptors(4,1,Table_atoms_in_descriptors%N)) - atoms_in_descriptors = reshape(Table_atoms_in_descriptors%int(:,1:Table_atoms_in_descriptors%N),(/4,1,Table_atoms_in_descriptors%N/)) - - call finalise(Table_atoms_in_descriptors) - - if( this%order > 1 ) & - call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) - - if( present(n_descriptors) ) n_descriptors = size(atoms_in_descriptors,3) - else - if( .not. allocated(atoms_in_descriptors) ) then - RAISE_ERROR("distance_Nb_calc_neighbour_loop: atoms_in_descriptors must be allocated",error) - endif - - call initialise(Table_atoms_in_descriptors, Nint = 4*current_order, Nreal = 0, Nstr = 0, Nlogical = 0, error=error) - allocate(current_descriptor(4,current_order)) - - do i_desc = 1, size(atoms_in_descriptors,3) - do order = 1, merge(1,size(atoms_in_descriptors,2),this%compact_clusters) !size(atoms_in_descriptors,2) - ! if compact_clusters == T, only neighbours of the first (central) atom is considered - i = atoms_in_descriptors(1,order,i_desc) - shift_i = atoms_in_descriptors(2:4,order,i_desc) - loop_n: do n = 1, n_neighbours(at,i) - j = neighbour(at,i,n,distance = r_ij, shift = shift_ij) - - if( r_ij > this%cutoff ) cycle - if( .not. is_subset(this%Z, at%Z( (/j,atoms_in_descriptors(1,:,i_desc)/) ), error) .and. all(this%Z /= 0) ) cycle - - shift_j = shift_ij + shift_i - - current_descriptor(:,1:current_order-1) = atoms_in_descriptors(:,:,i_desc) - current_descriptor(:,current_order) = (/j, shift_j/) - if( order_and_check_for_duplicates(current_descriptor(:,merge(2,1,this%compact_clusters):),at) ) then - ! if compact_clusters == T, leave first atom alone - do d = current_order, 1, -1 - current_descriptor(2:4,d) = current_descriptor(2:4,d) - current_descriptor(2:4,1) - enddo - call append(Table_atoms_in_descriptors,reshape(current_descriptor,(/4*current_order/))) - - !if( .not. is_in_LinkedList(LL_atoms_in_descriptors,current_descriptor,error) ) & - ! call append(LL_atoms_in_descriptors,current_descriptor,error) - endif - enddo loop_n - enddo - enddo - - deallocate(current_descriptor,atoms_in_descriptors) - call initialise(Table_atoms_in_descriptors_uniq, Nint = 4*current_order, Nreal = 0, Nstr = 0, Nlogical = 0, error=error) - - if( Table_atoms_in_descriptors%N > 0 ) then - call heap_sort(Table_atoms_in_descriptors%int(:,1:Table_atoms_in_descriptors%N)) - call append(Table_atoms_in_descriptors_uniq,Table_atoms_in_descriptors%int(:,1)) - do i_desc = 2, Table_atoms_in_descriptors%N - if( .not. all( Table_atoms_in_descriptors%int(:,i_desc) == Table_atoms_in_descriptors%int(:,i_desc-1) ) ) & - call append(Table_atoms_in_descriptors_uniq,Table_atoms_in_descriptors%int(:,i_desc)) - enddo - endif - - allocate(atoms_in_descriptors(4,current_order,Table_atoms_in_descriptors_uniq%N)) - atoms_in_descriptors = reshape(Table_atoms_in_descriptors_uniq%int(:,1:Table_atoms_in_descriptors_uniq%N),(/4,current_order,Table_atoms_in_descriptors_uniq%N/)) - - call finalise(Table_atoms_in_descriptors) - call finalise(Table_atoms_in_descriptors_uniq) - - if( current_order < this%order ) & - call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) - endif - - current_order = current_order - 1 - - endsubroutine distance_Nb_calc_neighbour_loop - - function order_and_check_for_duplicates(array,at) - integer, dimension(:,:), intent(inout) :: array - type(atoms), intent(in) :: at - logical :: order_and_check_for_duplicates - - integer :: ii, jj, n - integer, dimension(size(array,1)) :: tmp - logical :: do_swap - - integer, dimension(size(array,1)+1,size(array,2)) :: Z_array - - Z_array(1,:) = at%Z(array(1,:)) - Z_array(2:,:) = array(:,:) - - call heap_sort(Z_array) - - do ii = 2, size(Z_array,2) - if( all( Z_array(:,ii-1) == Z_array(:,ii) ) ) then - order_and_check_for_duplicates = .false. - return - endif - enddo - - array(:,:) = Z_array(2:,:) - - order_and_check_for_duplicates = .true. - - endfunction order_and_check_for_duplicates - - function is_subset(set,subset,error) - logical :: is_subset - integer, dimension(:), intent(in) :: set, subset - integer, optional, intent(out) :: error - - logical, dimension(size(set)) :: found - integer :: i, j - - INIT_ERROR(error) - if( size(set) < size(subset) ) then - RAISE_ERROR("is_subset: size of set must be greater than or equal to the size of subset",error) - endif - - found = .false. - loop_i: do i = 1, size(subset) - do j = 1, size(set) - if(set(j) == subset(i) .and. .not. found(j)) then - found(j) = .true. - cycle loop_i - endif - enddo - enddo loop_i - - is_subset = ( count(found) == size(subset) ) - - endfunction is_subset - - - function descriptor_dimensions(this,error) - type(descriptor), intent(in) :: this - integer, optional, intent(out) :: error - integer :: descriptor_dimensions - - INIT_ERROR(error) - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - descriptor_dimensions = bispectrum_SO4_dimensions(this%descriptor_bispectrum_SO4,error) - case(DT_BISPECTRUM_SO3) - descriptor_dimensions = bispectrum_SO3_dimensions(this%descriptor_bispectrum_SO3,error) - case(DT_BEHLER) - descriptor_dimensions = behler_dimensions(this%descriptor_behler,error) - case(DT_DISTANCE_2b) - descriptor_dimensions = distance_2b_dimensions(this%descriptor_distance_2b,error) - case(DT_COORDINATION) - descriptor_dimensions = coordination_dimensions(this%descriptor_coordination,error) - case(DT_ANGLE_3B) - descriptor_dimensions = angle_3b_dimensions(this%descriptor_angle_3b,error) - case(DT_CO_ANGLE_3B) - descriptor_dimensions = co_angle_3b_dimensions(this%descriptor_co_angle_3b,error) - case(DT_CO_DISTANCE_2b) - descriptor_dimensions = co_distance_2b_dimensions(this%descriptor_co_distance_2b,error) - case(DT_COSNX) - descriptor_dimensions = cosnx_dimensions(this%descriptor_cosnx,error) - case(DT_TRIHIS) - descriptor_dimensions = trihis_dimensions(this%descriptor_trihis,error) - case(DT_WATER_MONOMER) - descriptor_dimensions = water_monomer_dimensions(this%descriptor_water_monomer,error) - case(DT_WATER_DIMER) - descriptor_dimensions = water_dimer_dimensions(this%descriptor_water_dimer,error) - case(DT_A2_DIMER) - descriptor_dimensions = A2_dimer_dimensions(this%descriptor_A2_dimer,error) - case(DT_AB_DIMER) - descriptor_dimensions = AB_dimer_dimensions(this%descriptor_AB_dimer,error) - case(DT_ATOM_REAL_SPACE) - descriptor_dimensions = atom_real_space_dimensions(this%descriptor_atom_real_space,error) - case(DT_POWER_SO3) - descriptor_dimensions = power_so3_dimensions(this%descriptor_power_so3,error) - case(DT_POWER_SO4) - descriptor_dimensions = power_so4_dimensions(this%descriptor_power_so4,error) - case(DT_SOAP) - descriptor_dimensions = soap_dimensions(this%descriptor_soap,error) - case(DT_RDF) - descriptor_dimensions = rdf_dimensions(this%descriptor_rdf,error) - case(DT_AS_DISTANCE_2b) - descriptor_dimensions = as_distance_2b_dimensions(this%descriptor_as_distance_2b,error) - case(DT_ALEX) - descriptor_dimensions = alex_dimensions(this%descriptor_alex,error) - case(DT_DISTANCE_Nb) - descriptor_dimensions = distance_Nb_dimensions(this%descriptor_distance_Nb,error) - case(DT_SOAP_TURBO) - descriptor_dimensions = soap_turbo_dimensions(this%descriptor_soap_turbo,error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_BOND_REAL_SPACE) - descriptor_dimensions = bond_real_space_dimensions(this%descriptor_bond_real_space,error) - case(DT_AN_MONOMER) - descriptor_dimensions = AN_monomer_dimensions(this%descriptor_AN_monomer,error) - case(DT_COM_DIMER) - descriptor_dimensions = com_dimer_dimensions(this%descriptor_com_dimer,error) - case(DT_GENERAL_MONOMER) - descriptor_dimensions = general_monomer_dimensions(this%descriptor_general_monomer,error) - case(DT_GENERAL_DIMER) - descriptor_dimensions = general_dimer_dimensions(this%descriptor_general_dimer,error) - case(DT_GENERAL_TRIMER) - descriptor_dimensions = general_trimer_dimensions(this%descriptor_general_trimer,error) - case(DT_WATER_TRIMER) - descriptor_dimensions = water_trimer_dimensions(this%descriptor_water_trimer,error) - case(DT_MOLECULE_LO_D) - descriptor_dimensions = molecule_lo_d_dimensions(this%descriptor_molecule_lo_d,error) - case(DT_SOAP_EXPRESS) - descriptor_dimensions = soap_express_dimensions(this%descriptor_soap_express,error) -#endif - case default - RAISE_ERROR("descriptor_dimensions: unknown descriptor type "//this%descriptor_type,error) - endselect - - endfunction descriptor_dimensions - - function bispectrum_SO4_dimensions(this,error) result(i) - type(bispectrum_SO4), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - integer :: j, j1, j2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO4_dimensions: descriptor object not initialised", error) - endif - - i = 0 - do j1 = 0, this%j_max - j2 = j1 - !do j2 = 0, this%j_max - do j = abs(j1-j2), min(this%j_max,j1+j2) - if( mod(j1+j2+j,2) == 1 ) cycle - i = i + 1 - enddo - !enddo - enddo - - endfunction bispectrum_SO4_dimensions - - function bispectrum_SO3_dimensions(this,error) result(i) - type(bispectrum_SO3), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - integer :: a, l1, l2, l - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO3_dimensions: descriptor object not initialised", error) - endif - - i = 0 - do a = 1, this%n_max - do l1 = 0, this%l_max - l2 = l1 - !do l2 = 0, this%l_max - do l = abs(l1-l2), min(this%l_max,l1+l2) - if( mod(l1,2)==1 .and. mod(l2,2)==1 .and. mod(l,2)==1 ) cycle - i = i + 1 - enddo - !enddo - enddo - enddo - - endfunction bispectrum_SO3_dimensions - - function behler_dimensions(this,error) result(i) - type(behler), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("behler_dimensions: descriptor object not initialised", error) - endif - - i = this%n_g2 + this%n_g3 - - endfunction behler_dimensions - - function distance_2b_dimensions(this,error) result(i) - type(distance_2b), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("distance_2b_dimensions: descriptor object not initialised", error) - endif - - i = this%n_exponents - - endfunction distance_2b_dimensions - - function coordination_dimensions(this,error) result(i) - type(coordination), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("coordination_dimensions: descriptor object not initialised", error) - endif - - i = 1 - - endfunction coordination_dimensions - - function angle_3b_dimensions(this,error) result(i) - type(angle_3b), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("angle_3b_dimensions: descriptor object not initialised", error) - endif - - i = 3 - - endfunction angle_3b_dimensions - - function co_angle_3b_dimensions(this,error) result(i) - type(co_angle_3b), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("co_angle_3b_dimensions: descriptor object not initialised", error) - endif - - i = 4 - - endfunction co_angle_3b_dimensions - - function co_distance_2b_dimensions(this,error) result(i) - type(co_distance_2b), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("co_distance_2b_dimensions: descriptor object not initialised", error) - endif - - i = 3 - - endfunction co_distance_2b_dimensions - - function cosnx_dimensions(this,error) result(i) - type(cosnx), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("cosnx_dimensions: descriptor object not initialised", error) - endif - - i = this%n_max*(this%l_max+1) - - endfunction cosnx_dimensions - - function trihis_dimensions(this,error) result(i) - type(trihis), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("trihis_dimensions: descriptor object not initialised", error) - endif - - i = this%n_gauss - - endfunction trihis_dimensions - - function water_monomer_dimensions(this,error) result(i) - type(water_monomer), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("water_monomer_dimensions: descriptor object not initialised", error) - endif - - i = 3 - - endfunction water_monomer_dimensions - - function water_dimer_dimensions(this,error) result(i) - type(water_dimer), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("water_dimer_dimensions: descriptor object not initialised", error) - endif - - i = 15 - - endfunction water_dimer_dimensions - - function A2_dimer_dimensions(this,error) result(i) - type(A2_dimer), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("A2_dimer_dimensions: descriptor object not initialised", error) - endif - - i = 6 - - endfunction A2_dimer_dimensions - - function AB_dimer_dimensions(this,error) result(i) - type(AB_dimer), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("AB_dimer_dimensions: descriptor object not initialised", error) - endif - - i = 6 - - endfunction AB_dimer_dimensions - - - function atom_real_space_dimensions(this,error) result(i) - type(atom_real_space), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("atom_real_space_dimensions: descriptor object not initialised", error) - endif - - i = 2 * (this%l_max+1)**2 + 2 - - endfunction atom_real_space_dimensions - - function power_so3_dimensions(this,error) result(i) - type(power_so3), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("power_so3_dimensions: descriptor object not initialised", error) - endif - - i = this%n_max*(this%l_max+1) - - endfunction power_so3_dimensions - - function power_SO4_dimensions(this,error) result(i) - type(power_SO4), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("power_SO4_dimensions: descriptor object not initialised", error) - endif - - i = this%j_max + 1 - - endfunction power_SO4_dimensions - - function soap_dimensions(this,error) result(i) - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i, K1, K2 - logical :: sym_desc - type(real_2d), dimension(:), allocatable :: W - integer, dimension(:, :), allocatable :: coupling_inds - real, dimension(:), allocatable :: sym_facs - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("soap_dimensions: descriptor object not initialised", error) - endif - - call form_W(this, W, sym_desc, error) - K1 = size(W(1)%mm(0,:)) - K2 = size(W(2)%mm(0,:)) - - if (this%diagonal_radial) then - if (this%Z_mix .or. this%R_mix .or. this%nu_R /= 2 .or. this%nu_S /= 2 .or. (.not. this%coupling)) then - RAISE_ERROR("soap_dimensions: can't combine diagonal radial with any other compression strategies", error) - endif - i = (this%l_max+1) * this%n_max * this%n_species * (this%n_species+1) / 2 + 1 - elseif (this%coupling) then - if (sym_desc) then - i = (this%l_max+1) * (K1 * (K1+1)) /2 + 1 - else - i = (this%l_max+1) * K1 * K2 + 1 - endif - else - if (K1 /= K2) then - RAISE_ERROR("require K1=K2 to use elementwise coupling", error) - endif - - call form_coupling_inds(this, K1, coupling_inds, sym_facs, error) - i = SIZE(sym_facs) * (this%l_max + 1) + 1 - endif - - if (allocated(W)) deallocate(W) - if (allocated(coupling_inds)) deallocate(coupling_inds) - if (allocated(sym_facs)) deallocate(sym_facs) - endfunction soap_dimensions - - - - function rdf_dimensions(this,error) result(i) - type(rdf), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("rdf_dimensions: descriptor object not initialised", error) - endif - - i = this%n_gauss - - endfunction rdf_dimensions - - function as_distance_2b_dimensions(this,error) result(i) - type(as_distance_2b), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("as_distance_2b_dimensions: descriptor object not initialised", error) - endif - - i = 3 - - endfunction as_distance_2b_dimensions - - - function alex_dimensions(this,error) result(i) - type(alex), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i, nradial - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("alex_dimensions: descriptor object not initialised", error) - endif - - nradial = this%power_max-this%power_min + 1 - i = nradial+2*nradial**2+nradial**3 - - endfunction alex_dimensions - - function distance_Nb_dimensions(this,error) result(i) - type(distance_Nb), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("distance_Nb_dimensions: descriptor object not initialised", error) - endif - - i = max(1,this%order * ( this%order - 1 ) / 2) - - endfunction distance_Nb_dimensions - - function descriptor_cutoff(this,error) - type(descriptor), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: descriptor_cutoff - - INIT_ERROR(error) - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - descriptor_cutoff = cutoff(this%descriptor_bispectrum_SO4,error) - case(DT_BISPECTRUM_SO3) - descriptor_cutoff = cutoff(this%descriptor_bispectrum_SO3,error) - case(DT_BEHLER) - descriptor_cutoff = cutoff(this%descriptor_behler,error) - case(DT_DISTANCE_2b) - descriptor_cutoff = cutoff(this%descriptor_distance_2b,error) - case(DT_COORDINATION) - descriptor_cutoff = cutoff(this%descriptor_coordination,error) - case(DT_ANGLE_3B) - descriptor_cutoff = cutoff(this%descriptor_angle_3b,error) - case(DT_CO_ANGLE_3B) - descriptor_cutoff = cutoff(this%descriptor_co_angle_3b,error) - case(DT_CO_DISTANCE_2b) - descriptor_cutoff = cutoff(this%descriptor_co_distance_2b,error) - case(DT_COSNX) - descriptor_cutoff = cutoff(this%descriptor_cosnx,error) - case(DT_TRIHIS) - descriptor_cutoff = cutoff(this%descriptor_trihis,error) - case(DT_WATER_MONOMER) - descriptor_cutoff = cutoff(this%descriptor_water_monomer,error) - case(DT_WATER_DIMER) - descriptor_cutoff = cutoff(this%descriptor_water_dimer,error) - case(DT_A2_DIMER) - descriptor_cutoff = cutoff(this%descriptor_A2_dimer,error) - case(DT_AB_DIMER) - descriptor_cutoff = cutoff(this%descriptor_AB_dimer,error) - case(DT_ATOM_REAL_SPACE) - descriptor_cutoff = cutoff(this%descriptor_atom_real_space,error) - case(DT_POWER_SO3) - descriptor_cutoff = cutoff(this%descriptor_power_so3,error) - case(DT_POWER_SO4) - descriptor_cutoff = cutoff(this%descriptor_power_so4,error) - case(DT_SOAP) - descriptor_cutoff = cutoff(this%descriptor_soap,error) - case(DT_RDF) - descriptor_cutoff = cutoff(this%descriptor_rdf,error) - case(DT_ALEX) - descriptor_cutoff = cutoff(this%descriptor_alex,error) - case(DT_DISTANCE_Nb) - descriptor_cutoff = cutoff(this%descriptor_distance_Nb,error) - case(DT_SOAP_TURBO) - descriptor_cutoff = cutoff(this%descriptor_soap_turbo,error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_BOND_REAL_SPACE) - descriptor_cutoff = cutoff(this%descriptor_bond_real_space,error) - case(DT_MOLECULE_LO_D) - descriptor_cutoff = cutoff(this%descriptor_molecule_lo_d,error) - case(DT_AN_MONOMER) - descriptor_cutoff = cutoff(this%descriptor_AN_monomer,error) - case(DT_GENERAL_MONOMER) - descriptor_cutoff = cutoff(this%descriptor_general_monomer,error) - case(DT_GENERAL_DIMER) - descriptor_cutoff = cutoff(this%descriptor_general_dimer,error) - case(DT_GENERAL_TRIMER) - descriptor_cutoff = cutoff(this%descriptor_general_trimer,error) - case(DT_WATER_TRIMER) - descriptor_cutoff = cutoff(this%descriptor_water_trimer,error) - case(DT_COM_DIMER) - descriptor_cutoff = cutoff(this%descriptor_com_dimer,error) - case(DT_SOAP_EXPRESS) - descriptor_cutoff = cutoff(this%descriptor_soap_express,error) -#endif - case default - RAISE_ERROR("descriptor_cutoff: unknown descriptor type "//this%descriptor_type,error) - endselect - - endfunction descriptor_cutoff - - function bispectrum_SO4_cutoff(this,error) - type(bispectrum_SO4), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: bispectrum_SO4_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO4_cutoff: descriptor object not initialised", error) - endif - - bispectrum_SO4_cutoff = this%cutoff - - endfunction bispectrum_SO4_cutoff - - function bispectrum_SO3_cutoff(this,error) - type(bispectrum_SO3), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: bispectrum_SO3_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO3_cutoff: descriptor object not initialised", error) - endif - - bispectrum_SO3_cutoff = this%cutoff - - endfunction bispectrum_SO3_cutoff - - function behler_cutoff(this,error) - type(behler), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: behler_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("behler_cutoff: descriptor object not initialised", error) - endif - - behler_cutoff = this%cutoff - - endfunction behler_cutoff - - function distance_2b_cutoff(this,error) - type(distance_2b), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: distance_2b_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("distance_2b_cutoff: descriptor object not initialised", error) - endif - - distance_2b_cutoff = this%cutoff - - endfunction distance_2b_cutoff - - function co_distance_2b_cutoff(this,error) - type(co_distance_2b), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: co_distance_2b_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("co_distance_2b_cutoff: descriptor object not initialised", error) - endif - - co_distance_2b_cutoff = this%cutoff - - endfunction co_distance_2b_cutoff - - function coordination_cutoff(this,error) - type(coordination), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: coordination_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("coordination_cutoff: descriptor object not initialised", error) - endif - - coordination_cutoff = this%cutoff - - endfunction coordination_cutoff - - function angle_3b_cutoff(this,error) - type(angle_3b), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: angle_3b_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("angle_3b_cutoff: descriptor object not initialised", error) - endif - - angle_3b_cutoff = this%cutoff - - endfunction angle_3b_cutoff - - function co_angle_3b_cutoff(this,error) - type(co_angle_3b), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: co_angle_3b_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("co_angle_3b_cutoff: descriptor object not initialised", error) - endif - - co_angle_3b_cutoff = this%cutoff - - endfunction co_angle_3b_cutoff - - function cosnx_cutoff(this,error) - type(cosnx), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: cosnx_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("cosnx_cutoff: descriptor object not initialised", error) - endif - - cosnx_cutoff = this%cutoff - - endfunction cosnx_cutoff - - function trihis_cutoff(this,error) - type(trihis), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: trihis_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("trihis_cutoff: descriptor object not initialised", error) - endif - - trihis_cutoff = this%cutoff - - endfunction trihis_cutoff - - function water_monomer_cutoff(this,error) - type(water_monomer), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: water_monomer_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("water_monomer_cutoff: descriptor object not initialised", error) - endif - - water_monomer_cutoff = this%cutoff - - endfunction water_monomer_cutoff - - function water_dimer_cutoff(this,error) - type(water_dimer), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: water_dimer_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("water_dimer_cutoff: descriptor object not initialised", error) - endif - - water_dimer_cutoff = this%cutoff - - endfunction water_dimer_cutoff - - function A2_dimer_cutoff(this,error) - type(A2_dimer), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: A2_dimer_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("A2_dimer_cutoff: descriptor object not initialised", error) - endif - - A2_dimer_cutoff = this%cutoff - - endfunction A2_dimer_cutoff - - function AB_dimer_cutoff(this,error) - type(AB_dimer), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: AB_dimer_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("AB_dimer_cutoff: descriptor object not initialised", error) - endif - - AB_dimer_cutoff = this%cutoff - - endfunction AB_dimer_cutoff - - - function atom_real_space_cutoff(this,error) - type(atom_real_space), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: atom_real_space_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("atom_real_space_cutoff: descriptor object not initialised", error) - endif - - atom_real_space_cutoff = this%cutoff - - endfunction atom_real_space_cutoff - - function power_so3_cutoff(this,error) - type(power_so3), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: power_so3_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("power_so3_cutoff: descriptor object not initialised", error) - endif - - power_so3_cutoff = this%cutoff - - endfunction power_so3_cutoff - - function power_so4_cutoff(this,error) - type(power_so4), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: power_so4_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("power_so4_cutoff: descriptor object not initialised", error) - endif - - power_so4_cutoff = this%cutoff - - endfunction power_so4_cutoff - - function soap_cutoff(this,error) - type(soap), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: soap_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("soap_cutoff: descriptor object not initialised", error) - endif - - soap_cutoff = this%cutoff - - endfunction soap_cutoff - - - function rdf_cutoff(this,error) - type(rdf), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: rdf_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("rdf_cutoff: descriptor object not initialised", error) - endif - - rdf_cutoff = this%cutoff - - endfunction rdf_cutoff - - function as_distance_2b_cutoff(this,error) - type(as_distance_2b), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: as_distance_2b_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("as_distance_2b_cutoff: descriptor object not initialised", error) - endif - - as_distance_2b_cutoff = this%max_cutoff - - endfunction as_distance_2b_cutoff - - - function alex_cutoff(this,error) - type(alex), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: alex_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("alex_cutoff: descriptor object not initialised", error) - endif - - alex_cutoff = this%cutoff - - endfunction alex_cutoff - - function distance_Nb_cutoff(this,error) - type(distance_Nb), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: distance_Nb_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("distance_Nb_cutoff: descriptor object not initialised", error) - endif - - distance_Nb_cutoff = this%cutoff - - endfunction distance_Nb_cutoff - - function soap_turbo_cutoff(this,error) - type(soap_turbo), intent(in) :: this - integer, optional, intent(out) :: error - real(dp) :: soap_turbo_cutoff - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("soap_turbo_cutoff: descriptor object not initialised", error) - endif - - soap_turbo_cutoff = this%rcut_hard - - endfunction soap_turbo_cutoff - - - subroutine descriptor_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(descriptor), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4) - call bispectrum_SO4_sizes(this%descriptor_bispectrum_SO4,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_BISPECTRUM_SO3) - call bispectrum_SO3_sizes(this%descriptor_bispectrum_SO3,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_BEHLER) - call behler_sizes(this%descriptor_behler,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_DISTANCE_2b) - call distance_2b_sizes(this%descriptor_distance_2b,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_COORDINATION) - call coordination_sizes(this%descriptor_coordination,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_ANGLE_3B) - call angle_3b_sizes(this%descriptor_angle_3b,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_CO_ANGLE_3B) - call co_angle_3b_sizes(this%descriptor_co_angle_3b,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_CO_DISTANCE_2b) - call co_distance_2b_sizes(this%descriptor_co_distance_2b,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_COSNX) - call cosnx_sizes(this%descriptor_cosnx,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_TRIHIS) - call trihis_sizes(this%descriptor_trihis,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_WATER_MONOMER) - call water_monomer_sizes(this%descriptor_water_monomer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_WATER_DIMER) - call water_dimer_sizes(this%descriptor_water_dimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_A2_DIMER) - call A2_dimer_sizes(this%descriptor_A2_dimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_AB_DIMER) - call AB_dimer_sizes(this%descriptor_AB_dimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_ATOM_REAL_SPACE) - call atom_real_space_sizes(this%descriptor_atom_real_space,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_POWER_SO3) - call power_so3_sizes(this%descriptor_power_so3,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_POWER_SO4) - call power_so4_sizes(this%descriptor_power_so4,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_SOAP) - call soap_sizes(this%descriptor_soap,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_RDF) - call rdf_sizes(this%descriptor_rdf,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_AS_DISTANCE_2b) - call as_distance_2b_sizes(this%descriptor_as_distance_2b,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_ALEX) - call alex_sizes(this%descriptor_alex,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_DISTANCE_Nb) - call distance_Nb_sizes(this%descriptor_distance_Nb,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_SOAP_TURBO) - call soap_turbo_sizes(this%descriptor_soap_turbo,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_BOND_REAL_SPACE) - call bond_real_space_sizes(this%descriptor_bond_real_space,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_MOLECULE_LO_D) - call molecule_lo_d_sizes(this%descriptor_molecule_lo_d,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_AN_MONOMER) - call AN_monomer_sizes(this%descriptor_AN_monomer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_GENERAL_MONOMER) - call general_monomer_sizes(this%descriptor_general_monomer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_GENERAL_DIMER) - call general_dimer_sizes(this%descriptor_general_dimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_GENERAL_TRIMER) - call general_trimer_sizes(this%descriptor_general_trimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_WATER_TRIMER) - call water_trimer_sizes(this%descriptor_water_trimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_COM_DIMER) - call com_dimer_sizes(this%descriptor_com_dimer,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) - case(DT_SOAP_EXPRESS) - call soap_express_sizes(this%descriptor_soap_express,at, & - n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) -#endif - case default - RAISE_ERROR("descriptor_sizes: unknown descriptor type "//this%descriptor_type,error) - endselect - - endsubroutine descriptor_sizes - - subroutine bispectrum_SO4_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(bispectrum_SO4), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO4_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine bispectrum_SO4_sizes - - subroutine bispectrum_SO3_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(bispectrum_SO3), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("bispectrum_SO3_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine bispectrum_SO3_sizes - - subroutine behler_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(behler), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("behler_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - do i = 1, at%N - if(present(mask)) then - if(.not. mask(i)) cycle - endif - if( this%Z /= 0 .and. this%Z /= at%Z(i) ) cycle - - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine behler_sizes - - subroutine distance_2b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(distance_2b), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, n - logical :: Zi1, Zi2, Zj1, Zj2 - real(dp) :: r_ij - - logical :: needs_resid - integer, dimension(:), pointer :: resid_pointer - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("distance_2b_sizes: descriptor object not initialised", error) - endif - - needs_resid = this%only_intra .or. this%only_inter - if (needs_resid) then - if (.not. assign_pointer(at, trim(this%resid_name), resid_pointer)) then - RAISE_ERROR("distance_2b_sizes did not find "//trim(this%resid_name)//" property (residue id) in the atoms object.", error) - end if - else - resid_pointer => null() - end if - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if(present(mask)) then - if(.not. mask(i)) cycle - endif - - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij) - if(r_ij >= this%cutoff) cycle -!if(r_ij < 3.5_dp) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - if (needs_resid) then - if (this%only_intra .and. resid_pointer(i) /= resid_pointer(j)) cycle - if (this%only_inter .and. resid_pointer(i) == resid_pointer(j)) cycle - end if - - n_descriptors = n_descriptors + 1 - enddo - enddo - - n_cross = n_descriptors*2 - - if( present(n_index) ) n_index = 2 - - endsubroutine distance_2b_sizes - - subroutine coordination_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(coordination), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("coordination_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine coordination_sizes - - subroutine angle_3b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(angle_3b), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, k, n, m - real(dp) :: r_ij, r_ik - logical :: Zk1, Zk2, Zj1, Zj2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("angle_3b_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij) - if( r_ij >= this%cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - - do m = 1, n_neighbours(at,i) - if( n == m ) cycle - - k = neighbour(at, i, m, distance = r_ik) - if( r_ik >= this%cutoff ) cycle - - Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) - Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) - if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - n_descriptors = n_descriptors + 1 - enddo - enddo - enddo - n_cross = n_descriptors * 3 - - if( present(n_index) ) n_index = 1 - - endsubroutine angle_3b_sizes - - subroutine co_angle_3b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(co_angle_3b), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, k, n, m, n_neighbours_coordination - real(dp) :: r_ij, r_ik - logical :: Zk1, Zk2, Zj1, Zj2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("co_angle_3b_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - - n_neighbours_coordination = n_neighbours(at,i,max_dist=this%coordination_cutoff) - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance = r_ij) - if( r_ij >= this%cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - - do m = 1, n_neighbours(at,i) - if( n == m ) cycle - k = neighbour(at, i, m, distance = r_ik) - if( r_ik >= this%cutoff ) cycle - - Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) - Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) - if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 3 + n_neighbours_coordination - enddo - enddo - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine co_angle_3b_sizes - - subroutine co_distance_2b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(co_distance_2b), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - real(dp) :: r_ij - integer :: i, j, n - logical :: Zi1, Zi2, Zj1, Zj2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("co_distance_2b_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if(present(mask)) then - if(.not. mask(i)) cycle - endif - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at,i,n,distance=r_ij) - if( r_ij >= this%cutoff ) cycle -!if( r_ij < 3.5_dp ) cycle - - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 4 + n_neighbours(at,i,max_dist=this%coordination_cutoff) + n_neighbours(at,j,max_dist=this%coordination_cutoff) - enddo - enddo - - if( present(n_index) ) n_index = 2 - - endsubroutine co_distance_2b_sizes - - subroutine cosnx_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(cosnx), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("cosnx_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine cosnx_sizes - - subroutine trihis_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(trihis), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("trihis_sizes: descriptor object not initialised", error) - endif - - n_descriptors = at%N - - n_cross = 0 - - do i = 1, at%N - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_cross = n_cross + n_neighbours(at,i) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine trihis_sizes - - subroutine water_monomer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(water_monomer), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("water_monomer_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if(at%Z(i) == 8) then - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 3 - endif - enddo - - if( present(n_index) ) n_index = 3 - - endsubroutine water_monomer_sizes - - subroutine water_dimer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(water_dimer), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, n - real(dp) :: r_ij - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("water_dimer_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 -call print("mask present ? "//present(mask),PRINT_NERD) - do i = 1, at%N - if(at%Z(i) == 8) then - if(present(mask)) then - if(.not. mask(i)) cycle - endif - do n = 1, n_neighbours(at,i) - j = neighbour(at,i,n,distance=r_ij) - if(at%Z(j) == 8 .and. r_ij < this%cutoff) then - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 6 - endif - enddo - endif - enddo - - if( present(n_index) ) n_index = 6 - - endsubroutine water_dimer_sizes - - subroutine A2_dimer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(A2_dimer), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, iA1, iA2, iB1, iB2 - integer, dimension(at%N) :: A2_monomer_index - real(dp) :: r_A1_A2, r_B1_B2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("A2_dimer_sizes: descriptor object not initialised", error) - endif - - call find_A2_monomer(at,this%atomic_number, this%monomer_cutoff, A2_monomer_index) - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - iA1 = i - iA2 = neighbour(at,i,A2_monomer_index(i),distance=r_A1_A2) - if( iA1 > iA2 ) cycle - - do j = i + 1, at%N - iB1 = j - iB2 = neighbour(at,j,A2_monomer_index(j),distance=r_B1_B2) - if( iB1 > iB2 ) cycle - - r_A1_B1 = distance_min_image(at,iA1,iB1) - r_A1_B2 = distance_min_image(at,iA1,iB2) - - r_A2_B1 = distance_min_image(at,iA2,iB1) - r_A2_B2 = distance_min_image(at,iA2,iB2) - - if( all( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) < this%cutoff) ) then - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 4 - endif - enddo - enddo - - if( present(n_index) ) n_index = 4 - - endsubroutine A2_dimer_sizes - - subroutine AB_dimer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(AB_dimer), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, n_monomers, iA1, iA2, iB1, iB2 - integer, dimension(:,:), allocatable :: AB_monomer_index - real(dp) :: r_A1_A2, r_B1_B2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("A2_dimer_sizes: descriptor object not initialised", error) - endif - - if( count(at%Z == this%atomic_number1) == count(at%Z == this%atomic_number2) ) then - n_monomers = count(at%Z == this%atomic_number1) - else - RAISE_ERROR("AB_dimer_sizes: number of monomer atoms 1 ("//count(at%Z == this%atomic_number1)//") not equal to number of monomer atoms 2 ("//count(at%Z == this%atomic_number1)//")",error) - endif - - allocate(AB_monomer_index(2,n_monomers)) - call find_AB_monomer(at,(/this%atomic_number1,this%atomic_number2/), this%monomer_cutoff, AB_monomer_index) - - n_descriptors = 0 - n_cross = 0 - - do i = 1, n_monomers - iA1 = AB_monomer_index(1,i) - iB1 = AB_monomer_index(2,i) - do j = i + 1, n_monomers - iA2 = AB_monomer_index(1,j) - iB2 = AB_monomer_index(2,j) - - r_A1_B1 = distance_min_image(at,iA1,iB1) - r_A2_B2 = distance_min_image(at,iA2,iB2) - - r_A1_A2 = distance_min_image(at,iA1,iA2) - r_B1_B2 = distance_min_image(at,iB1,iB2) - - r_A1_B2 = distance_min_image(at,iA1,iB2) - r_A2_B1 = distance_min_image(at,iA2,iB1) - - if( all( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) < this%cutoff) ) then - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 4 - endif - enddo - enddo - - deallocate(AB_monomer_index) - - if( present(n_index) ) n_index = 4 - - endsubroutine AB_dimer_sizes - - - subroutine atom_real_space_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(atom_real_space), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("atom_real_space_sizes: descriptor object not initialised", error) - endif - - n_descriptors = at%N - n_cross = 0 - - do i = 1, at%N - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff)*2 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine atom_real_space_sizes - - subroutine power_so3_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(power_so3), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("power_so3_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine power_so3_sizes - - subroutine power_SO4_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(power_SO4), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("power_SO4_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine power_SO4_sizes - - subroutine soap_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(soap), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("soap_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( .not. any( at%Z(i) == this%Z ) .and. .not. any(this%Z == 0) ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if(this%global) then - n_descriptors = 1 - if( present(n_index) ) then - if( any(this%Z == 0) ) then - n_index = at%N - else - n_index = count( (/(any(at%Z(i)==this%Z),i=1,at%N)/) ) - endif - endif - else - if( present(n_index) ) n_index = 1 - endif - - endsubroutine soap_sizes - - subroutine rdf_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(rdf), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("rdf_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine rdf_sizes - - subroutine as_distance_2b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(as_distance_2b), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - real(dp) :: r_ij - integer :: i, j, n - logical :: Zi1, Zi2, Zj1, Zj2 - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("as_distance_2b_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) - Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) - do n = 1, n_neighbours(at,i) - j = neighbour(at,i,n,distance=r_ij) - if( r_ij > this%max_cutoff ) cycle - - Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) - Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) - if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type - - n_descriptors = n_descriptors + 1 - n_cross = n_cross + 4 + n_neighbours(at,i,max_dist=this%coordination_cutoff) + n_neighbours(at,j,max_dist=this%coordination_cutoff) - enddo - enddo - - if( present(n_index) ) n_index = 2 - - endsubroutine as_distance_2b_sizes - - - subroutine alex_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(alex), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("alex_sizes: descriptor object not initialised", error) - endif - - n_descriptors = 0 - n_cross = 0 - - do i = 1, at%N - if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle - if(present(mask)) then - if(.not. mask(i)) cycle - endif - n_descriptors = n_descriptors + 1 - n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 - enddo - - if( present(n_index) ) n_index = 1 - - endsubroutine alex_sizes - - subroutine distance_Nb_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) - type(distance_Nb), intent(in) :: this - type(atoms), intent(in) :: at - integer, intent(out) :: n_descriptors, n_cross - logical, dimension(:), intent(in), optional :: mask - integer, intent(out), optional :: n_index - integer, optional, intent(out) :: error - - integer :: i, j, n - logical :: Zi1, Zi2, Zj1, Zj2 - real(dp) :: r_ij - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("distance_Nb_sizes: descriptor object not initialised", error) - endif - - call distance_Nb_calc_get_clusters(this,at,n_descriptors=n_descriptors,mask=mask,error=error) - n_cross = n_descriptors * this%order - - if( present(n_index) ) n_index = this%order - - endsubroutine distance_Nb_sizes - - function soap_turbo_dimensions(this,error) result(i) - type(soap_turbo), intent(in) :: this - integer, optional, intent(out) :: error - integer :: i - integer :: n_max - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR("soap_turbo_dimensions: descriptor object not initialised", error) - endif - - if( this%compress )then - i = maxval(this%compress_P_i) - else - n_max = sum(this%alpha_max) - i = ( this%l_max+1 ) * ( n_max*(n_max+1) ) / 2 - endif - - endfunction soap_turbo_dimensions - - function descriptor_n_permutations(this,error) - type(descriptor), intent(in) :: this - integer, optional, intent(out) :: error - - integer :: descriptor_n_permutations, i - - INIT_ERROR(error) - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4,DT_BISPECTRUM_SO3,DT_BEHLER,DT_DISTANCE_2b,DT_COORDINATION, & - DT_ANGLE_3B,DT_CO_ANGLE_3B,DT_CO_DISTANCE_2b,DT_COSNX,DT_TRIHIS,DT_WATER_MONOMER,DT_BOND_REAL_SPACE,& - DT_ATOM_REAL_SPACE,DT_POWER_SO3,DT_POWER_SO4,DT_SOAP,DT_RDF, DT_ALEX, DT_COM_DIMER, & - DT_SOAP_EXPRESS,DT_SOAP_TURBO) - - descriptor_n_permutations = 1 - - case(DT_WATER_DIMER) - descriptor_n_permutations = NP_WATER_DIMER - case(DT_A2_DIMER) - descriptor_n_permutations = NP_A2_DIMER - case(DT_AB_DIMER) - descriptor_n_permutations = NP_AB_DIMER -#ifdef DESCRIPTORS_NONCOMMERCIAL - case(DT_AN_MONOMER) - if(this%descriptor_AN_monomer%do_atomic) then - descriptor_n_permutations = factorial(this%descriptor_AN_monomer%N-1) - else - descriptor_n_permutations = factorial(this%descriptor_AN_monomer%N) - endif - case(DT_GENERAL_MONOMER) - if (.not. this%descriptor_general_monomer%permutation_data%initialised)then - RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) - end if - descriptor_n_permutations = this%descriptor_general_monomer%permutation_data%n_perms - case(DT_GENERAL_DIMER) - if (.not. this%descriptor_general_dimer%permutation_data%initialised)then - RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) - end if - descriptor_n_permutations = this%descriptor_general_dimer%permutation_data%n_perms - case(DT_GENERAL_TRIMER) - if (.not. this%descriptor_general_trimer%permutation_data%initialised)then - RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) - end if - descriptor_n_permutations = this%descriptor_general_trimer%permutation_data%n_perms - case(DT_WATER_TRIMER) - if (.not. this%descriptor_water_trimer%permutation_data%initialised)then - RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) - end if - descriptor_n_permutations = this%descriptor_water_trimer%permutation_data%n_perms - case(DT_MOLECULE_LO_D) - if (.not. this%descriptor_molecule_lo_d%permutation_data%initialised)then - RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) - end if - descriptor_n_permutations = this%descriptor_molecule_lo_d%permutation_data%n_perms -#endif - case(DT_DISTANCE_NB) - descriptor_n_permutations = this%descriptor_distance_Nb%n_permutations - case default - RAISE_ERROR("descriptor_n_permutations: unknown descriptor type "//this%descriptor_type,error) - endselect - - endfunction descriptor_n_permutations - - subroutine descriptor_permutations(this,permutations,error) - type(descriptor), intent(in) :: this -#ifdef DESCRIPTORS_NONCOMMERCIAL - type(permutation_data_type) :: my_permutation_data -#endif - integer, dimension(:,:), intent(out) :: permutations - integer, optional, intent(out) :: error - - integer :: i, d, np, n, m, ip, j - integer,dimension(1) :: unit_vec - integer, dimension(:), allocatable :: this_perm - integer, dimension(:,:), allocatable :: distance_matrix, atom_permutations, sliced_permutations - - INIT_ERROR(error) - - d = descriptor_dimensions(this,error) - np = descriptor_n_permutations(this,error) - call check_size('permutations',permutations, (/d,np/),'descriptor_permutations',error) - - selectcase(this%descriptor_type) - case(DT_BISPECTRUM_SO4,DT_BISPECTRUM_SO3,DT_BEHLER,DT_DISTANCE_2b,DT_COORDINATION, & - DT_ANGLE_3B,DT_CO_ANGLE_3B,DT_CO_DISTANCE_2b,DT_COSNX,DT_TRIHIS,DT_WATER_MONOMER,DT_BOND_REAL_SPACE,& - DT_ATOM_REAL_SPACE,DT_POWER_SO3,DT_POWER_SO4,DT_SOAP,DT_RDF, DT_ALEX, DT_COM_DIMER,& - DT_SOAP_EXPRESS,DT_SOAP_TURBO) - - permutations(:,1) = (/ (i, i = 1, size(permutations,1)) /) - case(DT_WATER_DIMER) - permutations(:,1) = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15/) ! original order - permutations(:,2) = (/1, 3, 2, 4, 5, 7, 6, 8, 9, 10, 13, 14, 11, 12, 15/) ! swap Hs on monomer A - permutations(:,3) = (/1, 2, 3, 5, 4, 6, 7, 9, 8, 10, 12, 11, 14, 13, 15/) ! swap Hs on monomer B - permutations(:,4) = (/1, 3, 2, 5, 4, 7, 6, 9, 8, 10, 14, 13, 12, 11, 15/) ! swap Hs on both monomers - permutations(:,5) = (/1, 8, 9, 6, 7, 4, 5, 2, 3, 15, 11, 13, 12, 14, 10/) ! swap monomers A and B - permutations(:,6) = (/1, 9, 8, 6, 7, 5, 4, 2, 3, 15, 12, 14, 11, 13, 10/) ! swap monomers and Hs on monomer A - permutations(:,7) = (/1, 8, 9, 7, 6, 4, 5, 3, 2, 15, 13, 11, 14, 12, 10/) ! swap monomers and Hs on monomer B - permutations(:,8) = (/1, 9, 8, 7, 6, 5, 4, 3, 2, 15, 14, 12, 13, 11, 10/) ! swap monomers and Hs on both monomers - - case(DT_A2_DIMER) - permutations(:,1) = (/1, 2, 3, 4, 5, 6/) ! original order - permutations(:,2) = (/1, 2, 5, 6, 3, 4/) ! swap atoms on monomer A - permutations(:,3) = (/1, 2, 4, 3, 6, 5/) ! swap atoms on monomer B - permutations(:,4) = (/1, 2, 6, 5, 4, 3/) ! swap atoms on both monomers - permutations(:,5) = (/2, 1, 3, 5, 4, 6/) ! swap monomers A and B - permutations(:,6) = (/2, 1, 5, 3, 6, 4/) ! swap monomers and atoms on monomer A - permutations(:,7) = (/2, 1, 4, 6, 3, 5/) ! swap monomers and atoms on monomer B - permutations(:,8) = (/2, 1, 6, 4, 5, 3/) ! swap monomers and atoms on both monomers - - case(DT_AB_DIMER) - permutations(:,1) = (/1, 2, 3, 4, 5, 6/) ! original order - permutations(:,2) = (/2, 1, 3, 4, 6, 5/) ! swap monomers -#ifdef DESCRIPTORS_NONCOMMERCIAL -#include "descriptors_noncommercial_permutations.inc" -#endif - case(DT_DISTANCE_NB) - permutations = this%descriptor_distance_Nb%permutations - case default - RAISE_ERROR("descriptor_permutations: unknown descriptor type "//this%descriptor_type,error) - endselect - - endsubroutine descriptor_permutations - - - subroutine real_space_fourier_coefficients(at,l_max,atom_coefficient) - type(atoms), intent(in) :: at - integer, intent(in) :: l_max - type(neighbour_type), dimension(:), allocatable :: atom_coefficient - - integer :: i, j, n, l, m - real(dp) :: r - real(dp), dimension(3) :: d - - if(.not.allocated(atom_coefficient)) allocate(atom_coefficient(at%N)) - - do i = 1, at%N - if(.not. allocated(atom_coefficient(i)%neighbour)) allocate(atom_coefficient(i)%neighbour(n_neighbours(at,i))) - do n = 1, n_neighbours(at,i) - - j = neighbour(at,i,n,distance = r, diff = d) - atom_coefficient(i)%neighbour(n)%r = r - atom_coefficient(i)%neighbour(n)%u = d / r - - if(.not. allocated(atom_coefficient(i)%neighbour(n)%spherical_harmonics)) allocate( atom_coefficient(i)%neighbour(n)%spherical_harmonics(0:l_max), & - atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(0:l_max) ) - do l = 0, l_max - if(.not. allocated(atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m)) & - allocate(atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m(-l:l)) - if(.not. allocated(atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm)) & - allocate(atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm(3,-l:l)) - - atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m = CPLX_ZERO - atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm = CPLX_ZERO - - do m = -l, l - atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m(m) = SphericalYCartesian(l,m,d) - atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm(:,m) = GradSphericalYCartesian(l,m,d) - enddo - enddo - enddo - enddo - - endsubroutine real_space_fourier_coefficients - - function real_space_covariance_coefficient(anc1,anc2,i1,i2,alpha,l_max,f1,f2) - type(neighbour_type), dimension(:), intent(in) :: anc1, anc2 - real(dp), intent(in) :: alpha - integer, intent(in) :: i1, i2, l_max - real(dp), dimension(:,:), intent(out), optional :: f1, f2 - - real(dp) :: real_space_covariance_coefficient - - complex(dp) :: real_space_covariance_in, I_lm1m2 - integer :: n1, n2, l, m1, m2, k - real(dp) :: r1, r2, arg_bess, fac_exp, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm, mo_spher_bess_fi_ki_lp, grad_mo_spher_bess_fi_ki_l - real(dp), dimension(3) :: u1, u2, grad_arg_bess1, grad_fac_exp1, grad_arg_bess2, grad_fac_exp2 - type(cplx_2d), dimension(:), allocatable :: integral_r - type(grad_spherical_harmonics_overlap_type), dimension(:), allocatable :: grad_integral_r1, grad_integral_r2 - - logical :: do_derivative - - do_derivative = (present(f1) .or. present(f2)) - - real_space_covariance_in = CPLX_ZERO - - allocate(integral_r(0:l_max)) - do l = 0, l_max - allocate(integral_r(l)%mm(-l:l,-l:l)) - integral_r(l)%mm = CPLX_ZERO - enddo - - if(present(f1)) then - allocate(grad_integral_r1(0:size(anc1(i1)%neighbour))) - do n1 = 0, size(anc1(i1)%neighbour) - allocate(grad_integral_r1(n1)%grad_integral(0:l_max)) - do l = 0, l_max - allocate(grad_integral_r1(n1)%grad_integral(l)%mm(3,-l:l,-l:l)) - grad_integral_r1(n1)%grad_integral(l)%mm = CPLX_ZERO - enddo - enddo - endif - - if(present(f2)) then - allocate(grad_integral_r2(0:size(anc2(i2)%neighbour))) - do n2 = 0, size(anc2(i2)%neighbour) - allocate(grad_integral_r2(n2)%grad_integral(0:l_max)) - do l = 0, l_max - allocate(grad_integral_r2(n2)%grad_integral(l)%mm(3,-l:l,-l:l)) - grad_integral_r2(n2)%grad_integral(l)%mm = CPLX_ZERO - enddo - enddo - endif - do n1 = 1, size(anc1(i1)%neighbour) - r1 = anc1(i1)%neighbour(n1)%r - u1 = anc1(i1)%neighbour(n1)%u - do n2 = 1, size(anc2(i2)%neighbour) - r2 = anc2(i2)%neighbour(n2)%r - - u2 = anc2(i2)%neighbour(n2)%u - - arg_bess = alpha*r1*r2 - fac_exp = exp(-0.5_dp*alpha*(r1**2+r2**2)) - - if(present(f1)) then - grad_arg_bess1 = alpha*r2*u1 - grad_fac_exp1 = -fac_exp*alpha*r1*u1 - endif - - if(present(f2)) then - grad_arg_bess2 = alpha*r1*u2 - grad_fac_exp2 = -fac_exp*alpha*r2*u2 - endif - - do l = 0, l_max - if( l == 0 ) then - mo_spher_bess_fi_ki_lm = cosh(arg_bess)/arg_bess - mo_spher_bess_fi_ki_l = sinh(arg_bess)/arg_bess - if(do_derivative) mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess - else - mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm - mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l - if(do_derivative) then - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lp - mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess - else - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l-1)*mo_spher_bess_fi_ki_lm / arg_bess - endif - - endif - - - if(do_derivative) grad_mo_spher_bess_fi_ki_l = 0.5_dp * (mo_spher_bess_fi_ki_lp - mo_spher_bess_fi_ki_l / arg_bess + mo_spher_bess_fi_ki_lm) - - do m1 = -l, l - do m2 = -l, l - I_lm1m2 = conjg(anc1(i1)%neighbour(n1)%spherical_harmonics(l)%m(m1)) * anc2(i2)%neighbour(n2)%spherical_harmonics(l)%m(m2) * mo_spher_bess_fi_ki_l*fac_exp - integral_r(l)%mm(m2,m1) = integral_r(l)%mm(m2,m1) + I_lm1m2 - if(present(f1)) then - grad_integral_r1(n1)%grad_integral(l)%mm(:,m2,m1) = grad_integral_r1(n1)%grad_integral(l)%mm(:,m2,m1) + & - anc2(i2)%neighbour(n2)%spherical_harmonics(l)%m(m2) * & - ( conjg(anc1(i1)%neighbour(n1)%grad_spherical_harmonics(l)%mm(:,m1)) * mo_spher_bess_fi_ki_l*fac_exp + & - conjg(anc1(i1)%neighbour(n1)%spherical_harmonics(l)%m(m1)) * ( grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp1 ) ) - endif - - if(present(f2)) then - grad_integral_r2(n2)%grad_integral(l)%mm(:,m2,m1) = grad_integral_r2(n2)%grad_integral(l)%mm(:,m2,m1) + & - conjg(anc1(i1)%neighbour(n1)%spherical_harmonics(l)%m(m1)) * & - ( anc2(i2)%neighbour(n2)%grad_spherical_harmonics(l)%mm(:,m2) * mo_spher_bess_fi_ki_l*fac_exp + & - anc2(i2)%neighbour(n2)%spherical_harmonics(l)%m(m2) * ( grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp2 ) ) - endif - - enddo - enddo - enddo - enddo - enddo - - if(present(f1)) then - f1 = 0.0_dp - do n1 = 0, size(anc1(i1)%neighbour) - do l = 0, l_max - do k = 1, 3 - f1(k,n1+1) = f1(k,n1+1) + real(sum(conjg(grad_integral_r1(n1)%grad_integral(l)%mm(k,:,:))*integral_r(l)%mm(:,:))) - enddo - enddo - enddo - f1 = 2.0_dp * f1 - endif - - if(present(f2)) then - f2 = 0.0_dp - do n2 = 0, size(anc2(i2)%neighbour) - do l = 0, l_max - do k = 1, 3 - f2(k,n2+1) = f2(k,n2+1) + real(sum(conjg(grad_integral_r2(n2)%grad_integral(l)%mm(k,:,:))*integral_r(l)%mm(:,:))) - enddo - enddo - enddo - f2 = 2.0_dp * f2 - endif - - do l = 0, l_max - real_space_covariance_in = real_space_covariance_in + sum(conjg(integral_r(l)%mm) * integral_r(l)%mm) - enddo - real_space_covariance_coefficient = real(real_space_covariance_in) - - do l = 0, l_max - deallocate(integral_r(l)%mm) - enddo - deallocate(integral_r) - - if(present(f1)) then - do n1 = 0, size(anc1(i1)%neighbour) - do l = 0, l_max - deallocate(grad_integral_r1(n1)%grad_integral(l)%mm) - enddo - deallocate(grad_integral_r1(n1)%grad_integral) - enddo - deallocate(grad_integral_r1) - endif - - if(present(f2)) then - do n2 = 0, size(anc2(i2)%neighbour) - do l = 0, l_max - deallocate(grad_integral_r2(n2)%grad_integral(l)%mm) - enddo - deallocate(grad_integral_r2(n2)%grad_integral) - enddo - deallocate(grad_integral_r2) - endif - - endfunction real_space_covariance_coefficient - - function real_space_covariance(at1,at2,i1,i2,alpha,l_max,f1,f2) - type(atoms), intent(in) :: at1, at2 - real(dp), intent(in) :: alpha - integer, intent(in) :: i1, i2, l_max - real(dp), dimension(:,:), intent(inout), optional :: f1, f2 - - real(dp) :: real_space_covariance - - complex(dp) :: real_space_covariance_in, I_lm1m2 - integer :: j1, j2, n1, n2, l, m1, m2 - real(dp) :: r1, r2, arg_bess, fac_exp, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm - real(dp), dimension(3) :: d1, d2 - type(cplx_2d), dimension(:), allocatable :: integral_r - - logical :: do_derivative - - do_derivative = (present(f1) .or. present(f2)) - - real_space_covariance_in = CPLX_ZERO - - allocate(integral_r(0:l_max)) - do l = 0, l_max - allocate(integral_r(l)%mm(-l:l,-l:l)) - integral_r(l)%mm = CPLX_ZERO - enddo - - do n1 = 1, n_neighbours(at1,i1) - j1 = neighbour(at1,i1,n1,distance = r1, diff = d1) - do n2 = 1, n_neighbours(at2,i2) - j2 = neighbour(at2,i2,n2,distance = r2, diff = d2) - - arg_bess = alpha*r1*r2 - fac_exp = exp(-0.5_dp*alpha*(r1**2+r2**2)) - - do l = 0, l_max - if( l == 0 ) then - mo_spher_bess_fi_ki_lmm = sinh(arg_bess)/arg_bess - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - elseif( l == 1 ) then - mo_spher_bess_fi_ki_lm = ( arg_bess*cosh(arg_bess) - sinh(arg_bess) ) / arg_bess**2 - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lm - else - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l+1)*mo_spher_bess_fi_ki_lm / arg_bess - mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l - mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm - endif - - do m1 = -l, l - do m2 = -l, l - I_lm1m2 = conjg(SphericalYCartesian(l,m1,d1)) * SphericalYCartesian(l,m2,d2)*mo_spher_bess_fi_ki_l*fac_exp - integral_r(l)%mm(m2,m1) = integral_r(l)%mm(m2,m1) + I_lm1m2 - enddo - enddo - enddo - enddo - enddo - - do l = 0, l_max - real_space_covariance_in = real_space_covariance_in + sum(conjg(integral_r(l)%mm) * integral_r(l)%mm) - enddo - real_space_covariance = real(real_space_covariance_in) - - do l = 0, l_max - deallocate(integral_r(l)%mm) - enddo - deallocate(integral_r) - - endfunction real_space_covariance - - function RadialFunction(this,r,i) - type(RadialFunction_type), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: i - - real(dp) :: RadialFunction - - real(dp), dimension(this%n_max) :: h - integer :: j - - if( r < this%cutoff ) then - do j = 1, this%n_max - h(j) = (this%cutoff-r)**(j+2) / this%NormFunction(j) - enddo - RadialFunction = dot_product(this%RadialTransform(:,i),h) - else - RadialFunction = 0.0_dp - endif - - endfunction RadialFunction - - function GradRadialFunction(this,r,i) - type(RadialFunction_type), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: i - - real(dp) :: GradRadialFunction - - real(dp), dimension(this%n_max) :: h - integer :: j - - if( r < this%cutoff ) then - do j = 1, this%n_max - h(j) = - (j+2) * (this%cutoff-r)**(j+1) / this%NormFunction(j) - enddo - GradRadialFunction = dot_product(this%RadialTransform(:,i),h) - else - GradRadialFunction = 0.0_dp - endif - - endfunction GradRadialFunction - - - - function graphIsConnected(connectivityMatrix,error) - - logical, dimension(:,:), intent(in) :: connectivityMatrix - integer, intent(out), optional :: error - logical :: graphIsConnected - - logical, dimension(:), allocatable :: visitedVertices - - INIT_ERROR(error) - - if( .not. is_square(connectivityMatrix) ) then - RAISE_ERROR("graphIsConnected: not square matrix",error) - endif - - allocate(visitedVertices(size(connectivityMatrix,1))) - - call graphBFS(connectivityMatrix,1,visitedVertices=visitedVertices,error=error) - graphIsConnected = all(visitedVertices) - - deallocate(visitedVertices) - - endfunction graphIsConnected - - subroutine graphBFS(connectivityMatrix,startVertex,visitedVertices,tree,error) - - logical, dimension(:,:), intent(in) :: connectivityMatrix - integer, intent(in) :: startVertex - logical, dimension(:), target, intent(out), optional :: visitedVertices - integer, dimension(:,:), allocatable, intent(out), optional :: tree - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: LL_edges => null(), LL_remove => null(), LL_tree => null() - - logical, dimension(:), pointer :: my_visitedVertices - integer, dimension(:), pointer :: edge - integer, dimension(2) :: vw - - INIT_ERROR(error) - - if( .not. is_square(connectivityMatrix) ) then - RAISE_ERROR("graphBFS: not square matrix",error) - endif - - if( present( visitedVertices ) ) then - my_visitedVertices => visitedVertices - else - allocate(my_visitedVertices(size(connectivityMatrix,1))) - endif - - my_visitedVertices = .false. - call graphSearch(connectivityMatrix,startVertex,LL_edges,my_visitedVertices,error) - do while( associated(LL_edges) ) - LL_remove => LL_edges - edge => retrieve_node(LL_remove) - vw = edge - call delete_node(LL_edges,LL_remove) - if( .not. my_visitedVertices(vw(2)) ) then - - if(present(tree)) call append(LL_tree,vw) - call graphSearch(connectivityMatrix, vw(2), LL_edges, my_visitedVertices,error) - endif - enddo - - if( .not. present( visitedVertices ) ) deallocate(my_visitedVertices) - - if (present(tree)) then - call retrieve(LL_tree,tree) - call finalise(LL_tree) - endif - - endsubroutine graphBFS - - subroutine graphSearch(connectivityMatrix, vertex, LL_edges, visitedVertices,error) - logical, dimension(:,:), intent(in) :: connectivityMatrix - integer, intent(in) :: vertex - type(LinkedList_i1d), pointer, intent(inout) :: LL_edges - logical, dimension(:), intent(inout) :: visitedVertices - integer, intent(out), optional :: error - - integer :: i - - INIT_ERROR(error) - - if( .not. is_square(connectivityMatrix) ) then - RAISE_ERROR("graphSearch: not square matrix",error) - endif - - visitedVertices(vertex) = .true. - - do i = 1, size(connectivityMatrix,1) - if( connectivityMatrix(i,vertex) ) call append(LL_edges,(/vertex,i/)) - enddo - - endsubroutine graphSearch - - -endmodule descriptors_module diff --git a/descriptors_wrapper.f95 b/descriptors_wrapper.f95 deleted file mode 100644 index 29a2cf8b..00000000 --- a/descriptors_wrapper.f95 +++ /dev/null @@ -1,587 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X descriptors_wrapper subroutine -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine descriptors_wrapper_distances(N,lattice,symbol,coord,descriptor_str,descriptor_str_len, & - calc_args_str,calc_args_str_len,i,fractional,previous_accepted,distances) - - use system_module - use linearalgebra_module - use dictionary_module - use periodictable_module - use atoms_types_module - use connection_module - use atoms_module - - use descriptors_module - - - implicit none - - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - integer, intent(in) :: descriptor_str_len - character(len=descriptor_str_len) :: descriptor_str - integer, intent(in) :: calc_args_str_len - character(len=calc_args_str_len) :: calc_args_str - real(dp), dimension(3,N), intent(in) :: coord - integer, intent(in) :: i - logical, intent(in) :: fractional, previous_accepted - real(dp), dimension(N,N), intent(out) :: distances - - type(atoms), save :: at - type(Connection), save :: at_connect_last_accepted, at_connect_previous - type(descriptor), save :: desc - type(descriptor_data) :: desc_data - real(dp), dimension(:,:), allocatable, save :: desc_array_last_accepted, distances_in_last_accepted, desc_array_previous, distances_in_previous - logical, dimension(:), pointer :: desc_mask - - integer, save :: d - integer :: j, k, l, n_i - - logical, save :: first_run = .true. - logical :: recalculate - - recalculate = .false. - - if( first_run ) then - call system_initialise(verbosity=PRINT_SILENT) - call initialise(desc,trim(descriptor_str)) - call initialise(at,N,lattice) - call add_property(at,'desc_mask',.true.,ptr=desc_mask) - - d = descriptor_dimensions(desc) - allocate(desc_array_previous(d,N), desc_array_last_accepted(d,N)) - allocate(distances_in_previous(N,N), distances_in_last_accepted(N,N)) - - recalculate = .true. - endif - - if( .not. first_run .and. (N /= at%N) ) then - call finalise(at) - call initialise(at,N,lattice) - call add_property(at,'desc_mask',.true.,ptr=desc_mask) - - if(allocated(desc_array_previous)) deallocate(desc_array_previous) - allocate(desc_array_previous(d,N)) - if(allocated(desc_array_last_accepted)) deallocate(desc_array_last_accepted) - allocate(desc_array_last_accepted(d,N)) - - if(allocated(distances_in_previous)) deallocate(distances_in_previous) - allocate(distances_in_previous(N,N)) - if(allocated(distances_in_last_accepted)) deallocate(distances_in_last_accepted) - allocate(distances_in_last_accepted(N,N)) - - recalculate = .true. - endif - - if( .not. first_run ) then - if( previous_accepted ) then - at_connect_last_accepted = at_connect_previous - desc_array_last_accepted = desc_array_previous - distances_in_last_accepted = distances_in_previous - else - at_connect_previous = at_connect_last_accepted - desc_array_previous = desc_array_last_accepted - distances_in_previous = distances_in_last_accepted - endif - endif - - if( at%lattice .fne. lattice ) then - call set_lattice(at,lattice, scale_positions=.false.) - recalculate = .true. - endif - - do k = 1, at%N - at%Z(k) = atomic_number_from_symbol(symbol(k)) - enddo - - if( i > 0 .and. previous_accepted .and. .not. recalculate ) then - if( fractional ) then - at%pos(:,i) = matmul(at%lattice,coord(:,i)) - else - at%pos(:,i) = coord(:,i) - endif - else - if( fractional ) then - at%pos = matmul(at%lattice,coord) - else - at%pos = coord - endif - endif - - call set_cutoff(at,cutoff(desc)+0.5_dp) - call calc_connect(at) - - if( .not. assign_pointer(at,'desc_mask',desc_mask) ) call system_abort("descriptors_wrapper: could not assign pointer desc_mask") - - if( i > 0 .and. .not. recalculate ) then - - if( i > at%N ) call system_abort("descriptors_wrapper: argument i = "//i//" greater than number of atoms "//at%N) - - desc_mask = .false. - - desc_mask(i) = .true. - - if( at_connect_previous%initialised ) then - do n_i = 1, n_neighbours(at,i,alt_connect=at_connect_previous) - desc_mask(neighbour(at,i,n_i,alt_connect=at_connect_previous)) = .true. - enddo - endif - - do n_i = 1, n_neighbours(at,i) - desc_mask(neighbour(at,i,n_i)) = .true. - enddo - - call calc(desc,at,desc_data,do_descriptor=.true.,do_grad_descriptor=.false.,args_str="atom_mask_name=desc_mask "//trim(calc_args_str)) - - do k = 1, count(desc_mask) - j = desc_data%x(k)%ci(1) - desc_array_previous(:,j) = desc_data%x(k)%data(:) - enddo - - do k = 1, count(desc_mask) - j = desc_data%x(k)%ci(1) - do l = 1, at%N - distances_in_previous(l,j) = sum( desc_array_previous(:,l) * desc_array_previous(:,j) ) - distances_in_previous(j,l) = distances_in_previous(l,j) - enddo - enddo - desc_mask = .true. - at_connect_previous = at%connect - else - call calc(desc,at,desc_data,do_descriptor=.true.,do_grad_descriptor=.false.,args_str=trim(calc_args_str)) - do j = 1, at%N - desc_array_previous(:,j) = desc_data%x(j)%data - enddo - - distances_in_previous = matmul(transpose(desc_array_previous),desc_array_previous) - - at_connect_previous = at%connect - endif - - distances = -log(distances_in_previous) - - call finalise(desc_data) - - if( first_run ) then - at_connect_last_accepted = at_connect_previous - desc_array_last_accepted = desc_array_previous - distances_in_last_accepted = distances_in_previous - endif - first_run = .false. - -endsubroutine descriptors_wrapper_distances - -module descriptors_wrapper_module - -use system_module -use periodictable_module, only : atomic_number_from_symbol -use atoms_module -use linearalgebra_module -use descriptors_module, only : descriptor, initialise, finalise, cutoff, calc, descriptor_sizes, descriptor_dimensions - -implicit none - -#ifdef HAVE_GAP -type(descriptor), save :: desc -#endif - -logical :: first_run = .true. - -contains - - subroutine descriptors_wrapper_initialise(descriptor_str) - - character(len=*) :: descriptor_str - -#ifdef HAVE_GAP - if( first_run ) then - call system_initialise(verbosity=PRINT_SILENT) - call initialise(desc,trim(descriptor_str)) - else - call finalise(desc) - call initialise(desc,trim(descriptor_str)) - endif - first_run = .false. -#endif - endsubroutine descriptors_wrapper_initialise - - subroutine descriptors_wrapper_initialise_C(descriptor_str,n_descriptor_str) bind(c) - - use iso_c_binding, only: c_int, c_char - - character(kind=c_char), intent(in) :: descriptor_str(n_descriptor_str) - integer(kind=c_int), intent(in) :: n_descriptor_str - - call descriptors_wrapper_initialise(trim(a2s(descriptor_str))) - - endsubroutine descriptors_wrapper_initialise_C - - function descriptors_wrapper_dimensions() - integer :: descriptors_wrapper_dimensions - - if(.not. first_run) then - descriptors_wrapper_dimensions = descriptor_dimensions(desc) - else - call system_abort("descriptors_wrapper_dimensions: initialise with calling descriptors_wrapper_initialise() first.") - endif - - endfunction descriptors_wrapper_dimensions - - function descriptors_wrapper_dimensions_C() bind(c) - use iso_c_binding, only: c_int - integer(kind=c_int) :: descriptors_wrapper_dimensions_C - - descriptors_wrapper_dimensions_C = descriptors_wrapper_dimensions() - endfunction descriptors_wrapper_dimensions_C - - function descriptors_wrapper_size(N,lattice,symbol,coord,fractional) - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - - integer :: descriptors_wrapper_size - - type(atoms), save :: at - integer :: n_descriptors,n_cross - - call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - call descriptor_sizes(desc,at,n_descriptors,n_cross) - - descriptors_wrapper_size = n_descriptors - - endfunction descriptors_wrapper_size - - function descriptors_wrapper_size_C(N,lattice,symbol,coord,fractional) bind(c) - - use iso_c_binding, only: c_double, c_int, c_bool, c_char - - integer(kind=c_int), intent(in) :: N - real(kind=c_double), dimension(3,3), intent(inout) :: lattice - character(kind=c_char), dimension(3,N), intent(in) :: symbol - real(kind=c_double), dimension(3,N), intent(in) :: coord - logical(kind=c_bool), intent(in) :: fractional - - integer(kind=c_int) :: descriptors_wrapper_size_C - - character(len=3), dimension(N) :: my_symbol - integer :: i - logical :: my_fractional - - do i = 1, N - my_symbol(i) = a2s(symbol(:,i)) - enddo - - my_fractional = logical(fractional,kind=kind(my_fractional)) - descriptors_wrapper_size_C = descriptors_wrapper_size(N,lattice,my_symbol,coord,my_fractional) - - endfunction descriptors_wrapper_size_C - - function descriptors_wrapper_gradient_size(N,lattice,symbol,coord,fractional) - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - - integer :: descriptors_wrapper_gradient_size - - type(atoms), save :: at - integer :: n_descriptors,n_cross - - call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - call descriptor_sizes(desc,at,n_descriptors,n_cross) - - descriptors_wrapper_gradient_size = n_cross - - endfunction descriptors_wrapper_gradient_size - - function descriptors_wrapper_gradient_size_C(N,lattice,symbol,coord,fractional) bind(c) - - use iso_c_binding, only: c_double, c_int, c_bool, c_char - - integer(kind=c_int), intent(in) :: N - real(kind=c_double), dimension(3,3), intent(inout) :: lattice - character(kind=c_char), dimension(3,N), intent(in) :: symbol - real(kind=c_double), dimension(3,N), intent(in) :: coord - logical(kind=c_bool), intent(in) :: fractional - - integer(kind=c_int) :: descriptors_wrapper_gradient_size_C - - character(len=3), dimension(N) :: my_symbol - integer :: i - logical :: my_fractional - - do i = 1, N - my_symbol(i) = a2s(symbol(:,i)) - enddo - - my_fractional = logical(fractional,kind=kind(my_fractional)) - descriptors_wrapper_gradient_size_C = descriptors_wrapper_gradient_size(N,lattice,my_symbol,coord,my_fractional) - - endfunction descriptors_wrapper_gradient_size_C - - subroutine descriptors_wrapper_both_sizes(N,lattice,symbol,coord,fractional,n_descriptors,n_cross) - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - integer, intent(out) :: n_descriptors, n_cross - - type(atoms), save :: at - - call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - call descriptor_sizes(desc,at,n_descriptors,n_cross) - - endsubroutine descriptors_wrapper_both_sizes - - subroutine descriptors_wrapper_both_sizes_C(N,lattice,symbol,coord,fractional,n_descriptors,n_cross) bind(c) - - use iso_c_binding, only: c_double, c_int, c_bool, c_char - - integer(kind=c_int), intent(in) :: N - real(kind=c_double), dimension(3,3), intent(inout) :: lattice - character(kind=c_char), dimension(3,N), intent(in) :: symbol - real(kind=c_double), dimension(3,N), intent(in) :: coord - logical(kind=c_bool), intent(in) :: fractional - integer(kind=c_int), intent(out) :: n_descriptors, n_cross - - character(len=3), dimension(N) :: my_symbol - integer :: i - logical :: my_fractional - - do i = 1, N - my_symbol(i) = a2s(symbol(:,i)) - enddo - - my_fractional = logical(fractional,kind=kind(my_fractional)) - call descriptors_wrapper_both_sizes(N,lattice,my_symbol,coord,my_fractional,n_descriptors,n_cross) - - endsubroutine descriptors_wrapper_both_sizes_C - - subroutine descriptors_wrapper_array(N,lattice,symbol,coord,fractional,descriptor_array,d_descriptor, n_descriptor) - - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - integer, intent(in) :: d_descriptor, n_descriptor - real(dp), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array - - type(atoms), save :: at - - if( first_run ) then - call system_abort("descriptors_wrapper_array: initialise with calling descriptors_wrapper_initialise() first.") - endif - - call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - call calc(desc,at,descriptor_array) - - endsubroutine descriptors_wrapper_array - - subroutine descriptors_wrapper_array_C(N,lattice,symbol,coord,fractional,descriptor_array,d_descriptor, n_descriptor) bind(c) - - use iso_c_binding, only: c_double, c_int, c_bool, c_char - - integer(kind=c_int), intent(in) :: N - real(kind=c_double), dimension(3,3), intent(inout) :: lattice - character(kind=c_char), dimension(3,N), intent(in) :: symbol - real(kind=c_double), dimension(3,N), intent(in) :: coord - logical(kind=c_bool), intent(in) :: fractional - integer(kind=c_int), intent(in) :: d_descriptor, n_descriptor - real(kind=c_double), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array - - character(len=3), dimension(N) :: my_symbol - integer :: i - logical :: my_fractional - - do i = 1, N - my_symbol(i) = a2s(symbol(:,i)) - enddo - - my_fractional = logical(fractional,kind=kind(my_fractional)) - call descriptors_wrapper_array(N,lattice,my_symbol,coord,my_fractional,descriptor_array,d_descriptor,n_descriptor) - - endsubroutine descriptors_wrapper_array_C - - subroutine descriptors_wrapper_gradient_array(N,lattice,symbol,coord,fractional,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_cross) - - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - integer, intent(in) :: d_descriptor, n_cross - real(dp), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array - integer, dimension(2,n_cross), intent(out):: grad_descriptor_index - real(dp), dimension(3,n_cross), intent(out):: grad_descriptor_pos - - type(atoms), save :: at - - if( first_run ) then - call system_abort("descriptors_wrapper_gradient_array: initialise with calling descriptors_wrapper_initialise() first.") - endif - - call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - call calc(desc,at,grad_descriptor_out=grad_descriptor_array,grad_descriptor_index=grad_descriptor_index,grad_descriptor_pos=grad_descriptor_pos) - - endsubroutine descriptors_wrapper_gradient_array - - subroutine descriptors_wrapper_gradient_array_C(N,lattice,symbol,coord,fractional,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_cross) bind(c) - - use iso_c_binding, only: c_double, c_int, c_bool, c_char - - integer(kind=c_int), intent(in) :: N - real(kind=c_double), dimension(3,3), intent(inout) :: lattice - character(kind=c_char), dimension(3,N), intent(in) :: symbol - real(kind=c_double), dimension(3,N), intent(in) :: coord - logical(kind=c_bool), intent(in) :: fractional - integer(kind=c_int), intent(in) :: d_descriptor, n_cross - real(kind=c_double), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array - integer(kind=c_int), dimension(2,n_cross), intent(out):: grad_descriptor_index - real(kind=c_double), dimension(3,n_cross), intent(out):: grad_descriptor_pos - - character(len=3), dimension(N) :: my_symbol - integer :: i - logical :: my_fractional - - do i = 1, N - my_symbol(i) = a2s(symbol(:,i)) - enddo - - my_fractional = logical(fractional,kind=kind(my_fractional)) - call descriptors_wrapper_gradient_array(N,lattice,my_symbol,coord,my_fractional,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_cross) - - endsubroutine descriptors_wrapper_gradient_array_C - - subroutine descriptors_wrapper_both_arrays(N,lattice,symbol,coord,fractional,descriptor_array,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_descriptor,n_cross) - - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - integer, intent(in) :: d_descriptor, n_descriptor, n_cross - real(dp), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array - real(dp), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array - integer, dimension(2,n_cross), intent(out):: grad_descriptor_index - real(dp), dimension(3,n_cross), intent(out):: grad_descriptor_pos - - type(atoms), save :: at - - if( first_run ) then - call system_abort("descriptors_wrapper_both_arrays: initialise with calling descriptors_wrapper_initialise() first.") - endif - - call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - call calc(desc,at,descriptor_out=descriptor_array,grad_descriptor_out=grad_descriptor_array,grad_descriptor_index=grad_descriptor_index,grad_descriptor_pos=grad_descriptor_pos) - - endsubroutine descriptors_wrapper_both_arrays - - subroutine descriptors_wrapper_both_arrays_C(N,lattice,symbol,coord,fractional,descriptor_array,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_descriptor,n_cross) bind(c) - - use iso_c_binding, only: c_double, c_int, c_bool, c_char - - integer(kind=c_int), intent(in) :: N - real(kind=c_double), dimension(3,3), intent(inout) :: lattice - character(kind=c_char), dimension(3,N), intent(in) :: symbol - real(kind=c_double), dimension(3,N), intent(in) :: coord - logical(kind=c_bool), intent(in) :: fractional - integer(kind=c_int), intent(in) :: d_descriptor, n_descriptor, n_cross - real(kind=c_double), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array - real(kind=c_double), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array - integer(kind=c_int), dimension(2,n_cross), intent(out):: grad_descriptor_index - real(kind=c_double), dimension(3,n_cross), intent(out):: grad_descriptor_pos - - character(len=3), dimension(N) :: my_symbol - integer :: i - logical :: my_fractional - - do i = 1, N - my_symbol(i) = a2s(symbol(:,i)) - enddo - - my_fractional = logical(fractional,kind=kind(my_fractional)) - call descriptors_wrapper_both_arrays(N,lattice,my_symbol,coord,my_fractional,descriptor_array,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_descriptor,n_cross) - - endsubroutine descriptors_wrapper_both_arrays_C - - subroutine copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) - type(atoms), intent(inout) :: at - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - real(dp), dimension(3,N), intent(in) :: coord - logical, intent(in) :: fractional - - integer :: k - - if( N /= at%N ) then - call finalise(at) - call initialise(at,N,lattice) - endif - - if( at%lattice .fne. lattice ) then - call set_lattice(at,lattice, scale_positions=.false.) - endif - - do k = 1, at%N - at%Z(k) = atomic_number_from_symbol(symbol(k)) - enddo - - if( fractional ) then - at%pos = matmul(at%lattice,coord) - else - at%pos = coord - endif - - call set_cutoff(at,cutoff(desc)+0.5_dp) - call calc_connect(at) - - endsubroutine copy_data_to_atoms - -endmodule descriptors_wrapper_module diff --git a/find_water_triplets_noncommercial.f95 b/find_water_triplets_noncommercial.f95 deleted file mode 100644 index e7731e6a..00000000 --- a/find_water_triplets_noncommercial.f95 +++ /dev/null @@ -1,485 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!!!!!!!! -!!! This file was written by Jonatan Öström (@sujona, jonatan.ostrom@gmail.com) and Lars G.M. Pettersson, Stockholm University -!!! Here are implementations of water-trimer search routines, that work only for orthogonal unit cells with the shortest dimension longer than 2 x (3-body cutoff) -!!!!!!!! - -module find_water_triplets - ! use backend - implicit none - integer, parameter :: dp = kind(0d0) - - interface insert - module procedure insert_i2, insert_r2, insert_i1 - end interface - - -contains - -! //////////////////////////////////////////////// -! Dynamic insert in allocatable array -! insert(a,i,x) does a(i) = x but reallocates a to length 2*i if len(a) < i - -subroutine insert_i1(array,ii,val) - integer, intent(inout), allocatable :: array(:) - integer, intent(in) :: ii, val - integer, allocatable :: tmp(:) - if (ii>size(array))then - tmp = array - deallocate(array) - allocate(array(2*ii)) - array(:size(tmp)) = tmp - endif - array(ii) = val -end -subroutine insert_i2(array,ii,val) - integer, intent(inout), allocatable :: array(:,:) - integer, intent(in) :: ii, val(:) - integer, allocatable :: tmp(:,:) - if (ii>size(array,2))then - tmp = array - deallocate(array) - allocate(array(size(tmp,1),2*ii)) - array(:,:size(tmp,2)) = tmp - endif - array(:,ii) = val -end -subroutine insert_r2(array,ii,val) - real(dp), intent(inout), allocatable :: array(:,:) - real(dp), intent(in) :: val(:) - integer, intent(in) :: ii - real(dp), allocatable :: tmp(:,:) - if (ii>size(array,2))then - tmp = array - deallocate(array) - allocate(array(size(tmp,1),2*ii)) - array(:,:size(tmp,2)) = tmp - endif - array(:,ii) = val -end - -! //////////////////////////////////////////////// -! Utilitity routines - -subroutine min_img(XO,NO,i1,i2,box,lsq,x12,s12) - real(dp), intent(in) :: XO(3,NO), box(3) - integer, intent(in) :: NO, i1, i2 - real(dp), intent(out) :: lsq - real(dp), intent(out) :: x12(3) - integer, intent(out) :: s12(3) - x12 = XO(:,i1)-XO(:,i2) - s12 = nint(x12/box) - x12 = x12 - s12*box - lsq = sum(x12**2) -end - -subroutine min_img_c(XO,XC,NO,i1,i2,box,lsq,x12,c12,s12) - real(dp), intent(in) :: XO(3,NO), XC(3,NO), box(3) - integer, intent(in) :: NO, i1, i2 - real(dp), intent(out) :: lsq - real(dp), intent(out) :: x12(3), c12(3) - integer, intent(out) :: s12(3) - c12 = XC(:,i2)-XC(:,i1) - s12 = -nint(c12/box) - x12 = XO(:,i2)-XO(:,i1) - x12 = x12 + s12*box - c12 = c12 + s12*box - lsq = sum(x12**2) -end - -subroutine average_position(NW,XW,XC,XO) - integer, intent(in) :: NW - real(dp), intent(in) :: XW(3,NW*3) - real(dp), intent(out) :: XC(3,NW),XO(3,NW) - integer ii,jj,kk - do ii = 1,NW - jj = 3*(ii-1) !+1,2,3 for O,H,H - XO(:,ii) = XW(:,jj+1) - XC(:,ii) = 0 - do kk = 1,3 - XC(:,ii) = XC(:,ii) + XW(:,jj+kk)/3 - enddo - enddo -end - -function wall_time() result(tt) - integer count,count_rate - real(dp) tt - call system_clock(count,count_rate) - tt = dble(count)/count_rate -end -subroutine take(tt,text) - real(dp), intent(inout) :: tt - real(dp) :: old - character(*), intent(in) :: text - old = tt - tt = wall_time() - print'(f6.3,a)',tt-old,"s "//text -end - - -! //////////////////////////////////////////////// -! Finding triplets - -subroutine find_triplets_brute_force(XW,NW,box,rcut,n_trip) - ! find water triplets with brute force - integer, intent(in) :: NW - real(dp), intent(in) :: XW(3,NW*3), box(3), rcut - integer, intent(out) :: n_trip - real(dp) :: rcut2, d2ij, d2ik,d2jk, XC(3,NW),XO(3,NW) - integer ii,jj,kk, n_short !n_2, n_3, - real(dp),dimension(3) :: xij,xik,xjk ! Oxygen diff - real(dp),dimension(3) :: cij,cik,cjk ! Center diff - integer, dimension(3) :: sij,sik,sjk ! Shifts - rcut2 = rcut**2 - - call average_position(NW,XW,XC,XO) - - !!! $omp parallel do private(d2ij, d2ik,d2jk,n_short) reduction(+:n_2,n_3) - write(13,'(a)') ' ' - write(13,'(a)') ' TRIPLETS' - write(13,'(a)') ' ' - do ii = 1,NW - do jj = ii+1,NW - call min_img_c(XO,XC,NW,ii,jj,box,d2ij,xij,cij,sij) - do kk = jj+1,NW - call min_img_c(XO,XC,NW,ii,kk,box,d2ik,xik,cik,sik) - call min_img_c(XO,XC,NW,jj,kk,box,d2jk,xjk,cjk,sjk) - n_short = count([d2ij,d2ik,d2jk]1)then - n_trip = n_trip+1 - write(13,'(3i5,2(3i3,2x),2(3f10.5,2x))') ii,jj,kk, sij, sik, cij,cik - endif - enddo - enddo - enddo -end - -subroutine find_pairs_jona(XW,NO,box,rcut,n_pair,id2, sh2, dx2) - integer, intent(in) :: NO - real(dp), intent(in) :: XW(3,NO*3), box(3), rcut - integer, intent(out) :: n_pair - real(dp) :: rcut2, d2ij, xij(3), cij(3), XO(3,NO*3), XC(3,NO*3) - integer ii,jj, sij(3) - integer, allocatable, dimension(:,:), intent(out) :: id2, sh2 - real(dp), allocatable, dimension(:,:), intent(out) :: dx2 - allocate(id2(2,0), sh2(3,0), dx2(3,0)) - call average_position(NO,XW,XC,XO) - rcut2 = rcut**2 - n_pair = 0 - do ii = 1,NO - do jj = ii+1,NO - call min_img_c(XO,XC,NO,ii,jj,box,d2ij,xij,cij,sij) - if (d2ijii in G(ii) - do jl = 1,ncount(ii) - jj = nindex(i0+jl) - j0 = offset(jj) - sij = sh2(:,i0+jl) - cij = dx2(:,i0+jl) - if (iijj in G(ii) to get ii=a, jj=b, kk=c - do kl = jl+1,ncount(ii) - kk = nindex(i0+kl) - n_trip = n_trip + 1 - sik = sh2(:,i0+kl) - cik = dx2(:,i0+kl) - call insert(id3, n_trip, [ii,jj,kk]) - call insert(sh3, n_trip, [sij,sik]) - call insert(dx3, n_trip, [cij,cik]) - enddo - ! 2. a-b-c & 3. a-c-b: take kk>ii in G(jj)\G(ii) so that ii=a, jj=b/c, kk=c/b - do kl = 1,ncount(jj) - kk = nindex(j0+kl) - if (ii N(i) means j runs over the (N)eighbors of i - ! case 1. c-a-b-(c-) : let i N(i) and k -> N(i) - n_trip = 0 - do ii = 1, NO - 1 - i0 = ioff(ii) - i1 = ioff(ii+1) - do jl = 1, num(ii) - 1 - jj = neighbor(i0 + jl) - ! sij = sh2(:,i0 + jl) - cij = dx2(:,i0 + jl) - do kl = jl + 1, num(ii) - kk = neighbor(i0 + kl) - n_trip = n_trip + 1 - ! sik = sh2(:,i0 + kl) - cik = dx2(:,i0 + kl) - - call insert(id3, n_trip, [ii,jj,kk]) - ! call insert(sh3, n_trip, [sij,sik]) - call insert(dx3, n_trip, [cij,cik]) - - enddo - enddo - ! case 2. a-b-c : let iN(i) and k -> N(j)\N(i) - do jl = 1, num(ii) - jj = neighbor(i0 + jl) - j0 = ioff(jj) - ! sij = sh2(:,i0 + jl) - cij = dx2(:,i0 + jl) - do kl = 1, num(jj) !(1) - kk = neighbor(j0 + kl) !(2) - if (any(neighbor(i0+1:i1)==kk)) cycle - n_trip = n_trip + 1 - - ! sik = sh2(:,i0 + jl) + sh2(:,j0 + kl) - cik = dx2(:,i0 + jl) + dx2(:,j0 + kl) - - call insert(id3, n_trip, [ii,jj,kk]) - ! call insert(sh3, n_trip, [sij,sik]) - call insert(dx3, n_trip, [cij,cik]) - enddo - ! case 3. a-c-b : let i=a < k=b < j=c, so for j->N(i) find k->N(j)\N(i) - ! since k[i+1,j-1], exclude k->N(i) and include k when j->N(k) - do kk = ii + 1, jj - 1 - k0 = ioff(kk) - do jn = 1, num(kk) - if (jj /= neighbor(k0+jn)) cycle ! include j->N(k) - if (any(kk==neighbor(i0+1:i1))) cycle ! exclude k->N(i) - n_trip = n_trip + 1 - - ! sik = sh2(:,i0 + jl) - sh2(:,k0 + jn) - cik = dx2(:,i0 + jl) - dx2(:,k0 + jn) - - ! insert in i 1) call fit_n_from_xyz(main_gap_fit) - call gap_fit_set_mpi_blocksizes(main_gap_fit) - call gap_fit_estimate_memory(main_gap_fit) - - if (main_gap_fit%dryrun) then - call print('Exit before major allocations because dryrun is true.') - call system_finalise() - stop - end if - - call set_baselines(main_gap_fit) ! sets e0 etc. - - call fit_data_from_xyz(main_gap_fit) ! converts atomic neighbourhoods (bond neighbourhoods etc.) do descriptors, and feeds those to the GP - call print('Cartesian coordinates transformed to descriptors') - - if(main_gap_fit%sparsify_only_no_fit) then - if (gap_fit_is_root(main_gap_fit)) then - call initialise(main_gap_fit%gp_sp, main_gap_fit%my_gp) - call gap_fit_print_xml(main_gap_fit, main_gap_fit%gp_file, main_gap_fit%sparseX_separate_file) - end if - call system_finalise() - stop - end if - - call enable_timing() - call system_timer('GP sparsify') - - call gp_covariance_sparse(main_gap_fit%my_gp) - call gap_fit_print_linear_system_dump_file(main_gap_fit) - call gpSparse_fit(main_gap_fit%gp_sp, main_gap_fit%my_gp, main_gap_fit%task_manager, main_gap_fit%condition_number_norm) - - if (gap_fit_is_root(main_gap_fit)) call gap_fit_print_xml(main_gap_fit, main_gap_fit%gp_file, main_gap_fit%sparseX_separate_file) - - call system_timer('GP sparsify') - call system_finalise() - -end program gap_fit_program diff --git a/gap_fit_module.f95 b/gap_fit_module.f95 deleted file mode 100644 index 047333c6..00000000 --- a/gap_fit_module.f95 +++ /dev/null @@ -1,2393 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X and Sascha Klawohn. Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module gap_fit_module - - use error_module - use libatoms_module - use descriptors_module - use gp_predict_module - use gp_fit_module - use fox_wxml - use potential_module - use ScaLAPACK_module - use task_manager_module - use MPI_context_module, only : is_root - - implicit none - - integer, parameter :: SPARSE_LENGTH = 10000 - integer, parameter :: THETA_LENGTH = 10000 - integer, parameter :: GAP_STRING_SIZE = 200 - - integer, parameter :: E0_ISOLATED = 1 - integer, parameter :: E0_AVERAGE = 2 - integer, parameter :: EXCLUDE_LOC = -1 - -#ifdef GAP_VERSION - integer, parameter, private :: gap_version = GAP_VERSION -#else - integer, parameter, private :: gap_version = huge(1) -#endif - - type gap_fit - !% everything from the command line - type(Atoms), dimension(:), allocatable :: at - - character(len=STRING_LENGTH) :: at_file='', core_ip_args = '', e0_str, local_property0_str, & - energy_parameter_name, local_property_parameter_name, force_parameter_name, virial_parameter_name, & - stress_parameter_name, hessian_parameter_name, config_type_parameter_name, sigma_parameter_name, & - config_type_sigma_string, core_param_file, gp_file, template_file, force_mask_parameter_name, & - local_property_mask_parameter_name, condition_number_norm, linear_system_dump_file, config_file - - character(len=10240) :: command_line = '' - real(dp), dimension(total_elements) :: e0, local_property0 - real(dp) :: max_cutoff - real(dp), dimension(4) :: default_sigma - real(dp) :: default_local_property_sigma - real(dp) :: sparse_jitter, e0_offset, hessian_delta - integer :: e0_method = E0_ISOLATED - logical :: do_core = .false., do_copy_at_file, has_config_type_sigma, sigma_per_atom = .true. - logical :: sparsify_only_no_fit = .false. - logical :: dryrun = .false. - integer :: n_frame = 0 - integer :: n_coordinate = 0 - integer :: n_ener = 0 - integer :: n_force = 0 - integer :: n_virial = 0 - integer :: n_hessian = 0 - integer :: n_local_property = 0 - integer :: n_species = 0 - integer :: min_save - integer :: mpi_blocksize_rows = 0 - integer :: mpi_blocksize_cols = 0 - type(extendable_str) :: quip_string, config_string - type(Potential) :: core_pot - - type(gpFull) :: my_gp - type(gpSparse) :: gp_sp - - type(MPI_Context) :: mpi_obj - type(ScaLAPACK) :: ScaLAPACK_obj - type(task_manager_type) :: task_manager - - type(descriptor), dimension(:), allocatable :: my_descriptor - character(len=STRING_LENGTH), dimension(:), allocatable :: gap_str - - real(dp), dimension(:), allocatable :: delta, f0, theta_uniform, zeta, unique_hash_tolerance, unique_descriptor_tolerance !, theta - real(dp), dimension(:,:), allocatable :: sigma - integer, dimension(:), allocatable :: n_sparseX, sparse_method, target_type, n_cross, n_descriptors, species_Z, covariance_type - integer, dimension(:,:), allocatable :: config_type_n_sparseX - character(len=STRING_LENGTH), dimension(:), allocatable :: theta_file, sparse_file, theta_fac_string, config_type, config_type_n_sparseX_string, print_sparse_index - logical, dimension(:), allocatable :: mark_sparse_atoms, add_species, has_theta_fac, has_theta_uniform, has_theta_file, has_zeta - - logical :: sparseX_separate_file - logical :: sparse_use_actual_gpcov - logical :: has_template_file, has_e0, has_local_property0, has_e0_offset, has_linear_system_dump_file, has_config_file - - endtype gap_fit - - private - - public :: fit_n_from_xyz - public :: fit_data_from_xyz - public :: e0_from_xyz - public :: w_Z_from_xyz - public :: gap_fit - public :: gap_fit_print_xml - public :: file_print_xml -! public :: print_sparse - public :: set_baselines - public :: get_n_sparseX_for_files - public :: parse_config_type_sigma - public :: parse_config_type_n_sparseX - public :: read_fit_xyz - public :: read_descriptors - public :: get_species_xyz - public :: add_multispecies_gaps - public :: add_template_string - public :: gap_fit_parse_command_line - public :: gap_fit_parse_gap_str - public :: gap_fit_read_core_param_file - - public :: gap_fit_init_mpi_scalapack - public :: gap_fit_init_task_manager - public :: gap_fit_distribute_tasks - public :: gap_fit_set_mpi_blocksizes - - public :: gap_fit_is_root - - public :: gap_fit_print_linear_system_dump_file - public :: gap_fit_estimate_memory - -contains - - subroutine gap_fit_parse_command_line(this) - !% This subroutine parses the main command line options. - type(gap_fit), intent(inout), target :: this - - type(Dictionary) :: params - - character(len=STRING_LENGTH), pointer :: at_file, e0_str, local_property0_str, & - core_param_file, core_ip_args, & - energy_parameter_name, local_property_parameter_name, force_parameter_name, & - virial_parameter_name, stress_parameter_name, hessian_parameter_name, & - config_type_parameter_name, sigma_parameter_name, config_type_sigma_string, & - gp_file, template_file, force_mask_parameter_name, condition_number_norm, & - linear_system_dump_file, config_file, local_property_mask_parameter_name - - character(len=STRING_LENGTH) :: gap_str, verbosity, sparse_method_str, covariance_type_str, e0_method, & - parameter_name_prefix - - logical, pointer :: sigma_per_atom, do_copy_at_file, sparseX_separate_file, sparse_use_actual_gpcov, sparsify_only_no_fit - logical, pointer :: dryrun, do_export_covariance - logical :: do_ip_timing, has_sparse_file, has_theta_uniform, has_at_file, has_gap, has_config_file, has_default_sigma - logical :: mpi_print_all, file_exists - - real(dp), pointer :: e0_offset, sparse_jitter, hessian_delta - real(dp), dimension(:), pointer :: default_sigma - real(dp), pointer :: default_local_property_sigma - - integer :: rnd_seed - integer, pointer :: mpi_blocksize_rows, mpi_blocksize_cols - - config_file => this%config_file - at_file => this%at_file - e0_str => this%e0_str - local_property0_str => this%local_property0_str - e0_offset => this%e0_offset - default_sigma => this%default_sigma - default_local_property_sigma => this%default_local_property_sigma - sparse_jitter => this%sparse_jitter - hessian_delta => this%hessian_delta - core_param_file => this%core_param_file - core_ip_args => this%core_ip_args - energy_parameter_name => this%energy_parameter_name - local_property_parameter_name => this%local_property_parameter_name - force_parameter_name => this%force_parameter_name - virial_parameter_name => this%virial_parameter_name - stress_parameter_name => this%stress_parameter_name - hessian_parameter_name => this%hessian_parameter_name - config_type_parameter_name => this%config_type_parameter_name - sigma_parameter_name => this%sigma_parameter_name - force_mask_parameter_name => this%force_mask_parameter_name - local_property_mask_parameter_name => this%local_property_mask_parameter_name - config_type_sigma_string => this%config_type_sigma_string - sigma_per_atom => this%sigma_per_atom - do_copy_at_file => this%do_copy_at_file - sparseX_separate_file => this%sparseX_separate_file - sparse_use_actual_gpcov => this%sparse_use_actual_gpcov - gp_file => this%gp_file - template_file => this%template_file - sparsify_only_no_fit => this%sparsify_only_no_fit - dryrun => this%dryrun - condition_number_norm => this%condition_number_norm - linear_system_dump_file => this%linear_system_dump_file - mpi_blocksize_rows => this%mpi_blocksize_rows - mpi_blocksize_cols => this%mpi_blocksize_cols - do_export_covariance => this%gp_sp%do_export_R - - call initialise(params) - - call param_register(params, 'config_file', '', config_file, has_value_target=has_config_file, & - help_string="File as alternative input (newlines converted to spaces)") - - ! check if config file is given, ignore everything else - ! prepare parsing of config file or command line string later - if (param_read_args(params, ignore_unknown=.true., command_line=this%command_line)) then - if (has_config_file) then - inquire(file=config_file, exist=file_exists) - if (.not. file_exists) call system_abort("Config file does not exist: "//config_file) - call read(this%config_string, config_file, keep_lf=.true., mpi_comm=this%mpi_obj%communicator, mpi_id=this%mpi_obj%my_proc) - end if - end if - if (.not. has_config_file) this%config_string = this%command_line - this%has_config_file = has_config_file - - call param_register(params, 'atoms_filename', '//MANDATORY//', at_file, has_value_target = has_at_file, help_string="XYZ file with fitting configurations", altkey="at_file") - call param_register(params, 'gap', '//MANDATORY//', gap_str, has_value_target = has_gap, help_string="Initialisation string for GAPs") - call param_register(params, 'e0', '0.0', e0_str, has_value_target = this%has_e0, & - help_string="Atomic energy value to be subtracted from energies before fitting (and added back on after prediction). & - & Specifiy a single number (used for all species) or by species: {Ti:-150.0:O:-320...}. energy = baseline + GAP + e0") - - call param_register(params, 'local_property0', '0.0', local_property0_str, has_value_target = this%has_local_property0, & - help_string="Local property value to be subtracted from the local property before fitting (and added back on after prediction). & - & Specifiy a single number (used for all species) or by species: {H:20.0:Cl:35.0...}.") - - call param_register(params, 'e0_offset', '0.0', e0_offset, has_value_target = this%has_e0_offset, & - help_string="Offset of baseline. If zero, the offset is the average atomic energy of the input data or the e0 specified manually.") - - call param_register(params, 'e0_method','isolated',e0_method, & - help_string="Method to determine e0, if not explicitly specified. Possible options: isolated (default, each atom & - present in the XYZ needs to have an isolated representative, with a valid energy), average (e0 is the average of & - all total energies across the XYZ)") - - call param_register(params, 'default_kernel_regularisation', '//MANDATORY//', default_sigma, has_value_target = has_default_sigma, & - help_string="error in [energies forces virials hessians]", altkey="default_sigma") - - call param_register(params, 'default_kernel_regularisation_local_property', '0.001', default_local_property_sigma, & - help_string="error in local_property", altkey="default_local_property_sigma") - - call param_register(params, 'sparse_jitter', "1.0e-10", sparse_jitter, & - help_string="Extra regulariser used to regularise the sparse covariance matrix before it is passed to the linear solver. Use something small, it really shouldn't affect your results, if it does, your sparse basis is still very ill-conditioned.") - - call param_register(params, 'hessian_displacement', "1.0e-2", hessian_delta, & - help_string="Finite displacement to use in numerical differentiation when obtaining second derivative for the Hessian covariance", altkey="hessian_delta") - - call param_register(params, 'baseline_param_filename', 'quip_params.xml', core_param_file, & - help_string="QUIP XML file which contains a potential to subtract from data (and added back after prediction)", altkey="core_param_file") - - call param_register(params, 'baseline_ip_args', '', core_ip_args, has_value_target = this%do_core, & - help_string=" QUIP init string for a potential to subtract from data (and added back after prediction)", altkey="core_ip_args") - - call param_register(params, 'energy_parameter_name', 'energy', energy_parameter_name, & - help_string="Name of energy property in the input XYZ file that describes the data") - - call param_register(params, 'local_property_parameter_name', 'local_property', local_property_parameter_name, & - help_string="Name of local_property (column) in the input XYZ file that describes the data") - - call param_register(params, 'force_parameter_name', 'force', force_parameter_name, & - help_string="Name of force property (columns) in the input XYZ file that describes the data") - - call param_register(params, 'virial_parameter_name', 'virial', virial_parameter_name, & - help_string="Name of virial property in the input XYZ file that describes the data") - - call param_register(params, 'stress_parameter_name', 'stress', stress_parameter_name, & - help_string="Name of stress property (6-vector or 9-vector) in the input XYZ file that describes the data - stress values only used if virials are not available (opposite sign, standard Voigt order)") - - call param_register(params, 'hessian_parameter_name', 'hessian', hessian_parameter_name, & - help_string="Name of hessian property (column) in the input XYZ file that describes the data") - - call param_register(params, 'config_type_parameter_name', 'config_type', config_type_parameter_name, & - help_string="Allows grouping on configurations into. This option is the name of the key that indicates the configuration type in the input XYZ file. With the default, the key-value pair config_type=blah would place that configuration into the group blah.") - - call param_register(params, 'kernel_regularisation_parameter_name', 'sigma', sigma_parameter_name, & - help_string="kernel regularisation parameters for a given configuration in the database. & - Overrides the command line values (both defaults and config-type-specific values). In the input XYZ file, it must be prepended by energy_, force_, virial_ or hessian_", altkey="sigma_parameter_name") - - call param_register(params, 'force_mask_parameter_name', 'force_mask', force_mask_parameter_name, & - help_string="To exclude forces on specific atoms from the fit. In the XYZ, it must be a logical column.") - - call param_register(params, 'local_property_mask_parameter_name', 'local_property_mask', local_property_mask_parameter_name, & - help_string="To exclude local_properties on specific atoms from the fit. In the XYZ, it must be a logical column.") - - call param_register(params, 'parameter_name_prefix', '', parameter_name_prefix, & - help_string="Prefix that gets uniformly appended in front of {energy,local_property,force,virial,...}_parameter_name") - - call param_register(params, 'config_type_kernel_regularisation', '', config_type_sigma_string, has_value_target = this%has_config_type_sigma, & - help_string="What kernel regularisation values to choose for each type of data, when the configurations are grouped into config_types. Format: {configtype1:energy:force:virial:hessian:config_type2:energy:force:virial:hessian...}", altkey="config_type_sigma") - - call param_register(params, 'kernel_regularisation_is_per_atom', 'T', sigma_per_atom, & - help_string="Interpretation of the energy and virial sigmas specified in >>default_kernel_regularisation<< and >>config_type_kernel_regularisation<<. & - If >>T<<, they are interpreted as per-atom errors, and the variance will be scaled according to the number of atoms in the configuration. & - If >>F<< they are treated as absolute errors and no scaling is performed. & - NOTE: values specified on a per-configuration basis (see >>kernel_regularisation_parameter_name<<) are always absolute, not per-atom.", altkey="sigma_per_atom") - - call param_register(params, 'do_copy_atoms_file', 'T', do_copy_at_file, & - help_string="Copy the input XYZ file into the GAP XML file (should be set to False for NetCDF input).", altkey="do_copy_at_file") - - call param_register(params, 'sparse_separate_file', 'T', sparseX_separate_file, & - help_string="Save sparse point data in separate file in binary (use it for large datasets)") - - call param_register(params, 'sparse_use_actual_gpcov', 'F', sparse_use_actual_gpcov, & - help_string="Use actual GP covariance for sparsification methods") - - call param_register(params, 'gap_file', 'gap_new.xml', gp_file, & - help_string="Name of output XML file that will contain the fitted potential", altkey="gp_file") - - call param_register(params, 'verbosity', 'NORMAL', verbosity, & - help_string="Verbosity control. Options: NORMAL, VERBOSE, NERD, ANALYSIS.") ! changed name to ANALYSIS now that we are grown up - - call param_register(params, "rnd_seed", "-1", rnd_seed, & - help_string="Random seed.") - - call param_register(params, "openmp_chunk_size", "0", openmp_chunk_size, & - help_string="Chunk size in OpenMP scheduling; 0: each thread gets a single block of similar size (default)") - - call param_register(params, 'do_ip_timing', 'F', do_ip_timing, & - help_string="To enable or not timing of the interatomic potential.") - - call param_register(params, 'template_file', 'template.xyz', template_file, has_value_target=this%has_template_file, & - help_string="Template XYZ file for initialising object") - - call param_register(params, 'sparsify_only_no_fit', 'F', sparsify_only_no_fit, & - help_string="If true, sparsification is done, but no fitting. print the sparse index by adding print_sparse_index=file.dat to the descriptor string.") - - call param_register(params, 'dryrun', 'F', dryrun, & - help_string="If true, exits after memory estimate, before major allocations.") - - call param_register(params, 'condition_number_norm', ' ', condition_number_norm, & - help_string="Norm for condition number of matrix A; O: 1-norm, I: inf-norm, : skip calculation (default)") - - call param_register(params, 'linear_system_dump_file', '', linear_system_dump_file, has_value_target=this%has_linear_system_dump_file, & - help_string="Basename prefix of linear system dump files. Skipped if empty (default).") - - call param_register(params, 'mpi_blocksize_rows', '0', mpi_blocksize_rows, & - help_string="Blocksize of MPI distributed matrix rows. Affects efficiency and memory usage slightly. Max if 0 (default).") - - call param_register(params, 'mpi_blocksize_cols', '100', mpi_blocksize_cols, & - help_string="Blocksize of MPI distributed matrix cols. Affects efficiency and memory usage considerably. Max if 0. Default: 100") - - call param_register(params, 'mpi_print_all', 'F', mpi_print_all, & - help_string="If true, each MPI processes will print its output. Otherwise, only the first process does (default).") - - call param_register(params, 'export_covariance', 'F', do_export_covariance, & - help_string="If true, posterior covariance of the GAP model is saved.") - - if (.not. param_read_line(params, replace(string(this%config_string), quip_new_line, ' '))) then - call system_abort('Exit: Mandatory argument(s) missing...') - endif - - call print_title("Input parameters") - call param_print(params) - call print_title("") - call finalise(params) - - if (mpi_print_all) then - call mpi_all_inoutput(mainlog, .true.) - call activate(mainlog) - call mpi_all_inoutput(errorlog, .true.) - call activate(errorlog) - end if - - if (len_trim(parameter_name_prefix) > 0) then - energy_parameter_name = trim(parameter_name_prefix) // trim(energy_parameter_name) - local_property_parameter_name = trim(parameter_name_prefix) // trim(local_property_parameter_name) - force_parameter_name = trim(parameter_name_prefix) // trim(force_parameter_name) - virial_parameter_name = trim(parameter_name_prefix) // trim(virial_parameter_name) - hessian_parameter_name = trim(parameter_name_prefix) // trim(hessian_parameter_name) - stress_parameter_name = trim(parameter_name_prefix) // trim(stress_parameter_name) - config_type_parameter_name = trim(parameter_name_prefix) // trim(config_type_parameter_name) - sigma_parameter_name = trim(parameter_name_prefix) // trim(sigma_parameter_name) - force_mask_parameter_name = trim(parameter_name_prefix) // trim(force_mask_parameter_name) - local_property_mask_parameter_name = trim(parameter_name_prefix) // trim(local_property_mask_parameter_name) - local_property_parameter_name = trim(parameter_name_prefix) // trim(local_property_parameter_name) - endif - - if (sparsify_only_no_fit) then - force_parameter_name = '//IGNORE//' - virial_parameter_name = '//IGNORE//' - hessian_parameter_name = '//IGNORE//' - stress_parameter_name = '//IGNORE//' - call print_warning("sparsify_only_no_fit == T: force, virial, hessian, stress parameters are ignored.") - end if - - if( len_trim(this%gp_file) > 216 ) then ! The filename's length is limited to 255 char.s in some filesystem. - ! Without this check, the fit would run but produce a core file and only a temporary xml file. - ! The limit is set to 216 as the sparse file can be 39 characters longer. - call system_abort("gap_file's name "//this%gp_file//" is too long. Please start the fit again with a shorter name.") - endif - - if(do_ip_timing) call enable_timing() - - select case(verbosity) - case ("NORMAL") - call verbosity_push(PRINT_NORMAL) - case ("VERBOSE") - call verbosity_push(PRINT_VERBOSE) - case ("NERD") - call verbosity_push(PRINT_NERD) - case ("ANALYSIS") ! changed name now that we are grown up - call verbosity_push(PRINT_ANALYSIS) ! changed name now that we are grown up - case default - call system_abort("confused by verbosity " // trim(verbosity)) - end select - - select case(lower_case(e0_method)) - case ("isolated") - this%e0_method = E0_ISOLATED - case ("average") - this%e0_method = E0_AVERAGE - case default - call system_abort("confused by e0_method " // trim(e0_method)) - end select - - if (rnd_seed >= 0) call system_set_random_seeds(rnd_seed) - - call print_title('Gaussian Approximation Potentials - Database fitting') - call print('') - call print('Initial parsing of command line arguments finished.') - - call reallocate(this%gap_str, GAP_STRING_SIZE, zero=.true.) - call split_string(gap_str,':;','{}',this%gap_str,this%n_coordinate,matching=.true.) - - call print('Found '//this%n_coordinate//' GAPs.') - - endsubroutine gap_fit_parse_command_line - - subroutine set_baselines(this) - type(gap_fit), intent(inout) :: this - - integer :: i - - this%e0 = 0.0_dp - - if( count( (/this%has_e0, this%has_e0_offset/) ) > 1 ) then - call print_warning('Both e0 and e0_offset has been specified. That means your atomic energy is e0 + e0_offset') - endif - - if( this%has_e0 ) then - call parse_atomtype_value_str(this%e0_str,this%e0) - else - call e0_from_xyz(this) ! calculates the average atomic energy so it can be subtracted later. - endif - - if( this%has_e0_offset ) this%e0 = this%e0 + this%e0_offset - - if( .not. this%has_e0 ) then - do i = 1, size(this%e0) - if( all(i/=this%species_Z) ) this%e0(i) = 0.0_dp - enddo - call print('E0/atom = '//this%e0) - endif - - if( this%has_local_property0 ) then - call parse_atomtype_value_str(this%local_property0_str,this%local_property0) - this%e0 = 0.0_dp - else - this%local_property0 = 0.0_dp - endif - - endsubroutine set_baselines - - subroutine parse_atomtype_value_str(this,values,error) - - character(len=STRING_LENGTH), intent(in) :: this - real(dp), dimension(total_elements), intent(out) :: values - integer, intent(out), optional :: error - - integer :: n_string_array, i, z - character(len=STRING_LENGTH), dimension(2*total_elements) :: string_array - - INIT_ERROR(error) - - call split_string(this,':','{}',string_array(:),n_string_array,matching=.true.) - if(n_string_array == 1) then - values = string_to_real(trim(string_array(1))) - elseif(mod(n_string_array,2) == 0) then - values = 0.0_dp - do i = 1, n_string_array / 2 - z = atomic_number(trim( string_array((i-1)*2+1) )) - if( z==0 ) then - RAISE_ERROR("parse_atomtype_value_str: invalid atomic symbol "//trim(string_array((i-1)*2+1)),error) - endif - values(z) = string_to_real(trim( string_array(2*i) )) - enddo - else - RAISE_ERROR("parse_atomtype_value_str: number of fields is an odd number. It must be a list of pairs of values, such as {Ti:-150.4:O:-345.1}",error) - endif - - endsubroutine parse_atomtype_value_str - - subroutine gap_fit_parse_gap_str(this) - !% This subroutine parses the options given in the gap string, for each GAP. - type(gap_fit), intent(inout), target :: this - type(Dictionary) :: params - - integer :: i_coordinate - - real(dp) :: delta, f0, theta_uniform, zeta, unique_hash_tolerance, unique_descriptor_tolerance - integer :: n_sparseX, sparse_method, covariance_type - character(len=STRING_LENGTH) :: config_type_n_sparseX_string, theta_fac_string, theta_file, sparse_file, print_sparse_index, & - covariance_type_str, sparse_method_str - logical :: mark_sparse_atoms, add_species, has_sparse_file - - if (.not. allocated(this%gap_str)) then - call system_abort("gap_fit_parse_gap_str: gap_str is not allocated.") - end if - - allocate(this%delta(this%n_coordinate)) - allocate(this%f0(this%n_coordinate)) - allocate(this%n_sparseX(this%n_coordinate)) - allocate(this%config_type_n_sparseX_string(this%n_coordinate)) - allocate(this%theta_fac_string(this%n_coordinate)) - allocate(this%theta_uniform(this%n_coordinate)) - allocate(this%theta_file(this%n_coordinate)) - allocate(this%has_theta_fac(this%n_coordinate)) - allocate(this%has_theta_uniform(this%n_coordinate)) - allocate(this%has_theta_file(this%n_coordinate)) - allocate(this%sparse_file(this%n_coordinate)) - allocate(this%mark_sparse_atoms(this%n_coordinate)) - allocate(this%sparse_method(this%n_coordinate)) - allocate(this%add_species(this%n_coordinate)) - allocate(this%covariance_type(this%n_coordinate)) - allocate(this%zeta(this%n_coordinate)) - allocate(this%has_zeta(this%n_coordinate)) - allocate(this%print_sparse_index(this%n_coordinate)) - allocate(this%unique_hash_tolerance(this%n_coordinate)) - allocate(this%unique_descriptor_tolerance(this%n_coordinate)) - - do i_coordinate = 1, this%n_coordinate - call initialise(params) - - call param_register(params, 'energy_scale', "//MANDATORY//", delta, & - help_string="Set the typical scale of the function you are fitting (or the specific term if you use multiple descriptors). It is equivalent to the standard deviation of the Gaussian process in the probabilistic view, and typically this would be & - set to the standard deviation (i.e. root mean square) of the function & - that is approximated with the Gaussian process. ", altkey="delta") - - call param_register(params, 'f0', '0.0', f0, & - help_string="Set the mean of the Gaussian process. Defaults to 0.") - - call param_register(params, 'n_sparse', "0", n_sparseX, & - help_string="Number of sparse points to use in the sparsification of the Gaussian process") - - call param_register(params, 'config_type_n_sparse', '', config_type_n_sparseX_string, & - help_string="Number of sparse points in each config type. Format: {type1:50:type2:100}") - - call param_register(params, 'sparse_method', 'RANDOM', sparse_method_str, & - help_string="Sparsification method. RANDOM(default), PIVOT, CLUSTER, UNIFORM, KMEANS, COVARIANCE, NONE, FUZZY, FILE, & - INDEX_FILE, CUR_COVARIANCE, CUR_POINTS") - - call param_register(params, 'lengthscale_factor', '1.0', theta_fac_string, has_value_target = this%has_theta_fac(i_coordinate), & - help_string="Set the width of Gaussians for the Gaussian and PP kernel by multiplying the range of each descriptor by lengthscale_factor. & - Can be a single number or different for each dimension. For multiple theta_fac separate each value by whitespaces.", altkey="theta_fac") - - call param_register(params, 'lengthscale_uniform', '0.0', theta_uniform, has_value_target = this%has_theta_uniform(i_coordinate), & - help_string="Set the width of Gaussians for the Gaussian and PP kernel, same in each dimension.", altkey="theta_uniform") - - call param_register(params, 'lengthscale_file', '', theta_file, has_value_target = this%has_theta_file(i_coordinate), & - help_string="Set the width of Gaussians for the Gaussian kernel from a file. & - There should be as many real numbers as the number of dimensions, in a single line", altkey="theta_file") - - call param_register(params, 'sparse_file', '', sparse_file, has_value_target = has_sparse_file, & - help_string="Sparse points from a file. If sparse_method=FILE, descriptor values (real) listed in a text file, one & - & >>element<< per line. If sparse_method=INDEX_FILE, 1-based index of sparse points, one per line.") - - call param_register(params, 'mark_sparse_atoms', 'F', mark_sparse_atoms, & - help_string="Reprints the original xyz file after sparsification process. & - sparse propery added, true for atoms associated with a sparse point.") - - call param_register(params, 'add_species', 'T', add_species, & - help_string="Create species-specific descriptor, using the descriptor string as a template.") - - call param_register(params, 'covariance_type', "//MANDATORY//", covariance_type_str, & - help_string="Type of covariance function to use. Available: Gaussian, DOT_PRODUCT, BOND_REAL_SPACE, PP (piecewise polynomial)") - - !call param_register(params, 'theta', '1.0', main_gap_fit%theta(i_coordinate), & - !help_string="Width of Gaussians for use with bond real space covariance.") - - call param_register(params, 'soap_exponent', '1.0', zeta, has_value_target = this%has_zeta(i_coordinate), & - help_string="Exponent of soap type dot product covariance kernel", altkey="zeta") - - call param_register(params, 'print_sparse_index', '', print_sparse_index, & - help_string="If given, after determinining the sparse points, their 1-based indices are appended to this file") - - call param_register(params, 'unique_hash_tolerance', '1.0e-10', unique_hash_tolerance, & - help_string="Hash tolerance when filtering out duplicate data points") - - call param_register(params, 'unique_descriptor_tolerance', '1.0e-10', unique_descriptor_tolerance, & - help_string="Descriptor tolerance when filtering out duplicate data points") - - if (.not. param_read_line(params, this%gap_str(i_coordinate), ignore_unknown=.true., task='main program gap_str('//i_coordinate//')')) then - call system_abort("main program failed to parse gap string ("//i_coordinate//")='"//trim(this%gap_str(i_coordinate))//"'") - endif - call finalise(params) - - this%delta(i_coordinate) = delta - this%f0(i_coordinate) = f0 - this%n_sparseX(i_coordinate) = n_sparseX - this%config_type_n_sparseX_string(i_coordinate) = config_type_n_sparseX_string - this%theta_fac_string(i_coordinate) = theta_fac_string - this%theta_uniform(i_coordinate) = theta_uniform - this%theta_file(i_coordinate) = theta_file - this%sparse_file(i_coordinate) = sparse_file - this%mark_sparse_atoms(i_coordinate) = mark_sparse_atoms - this%add_species(i_coordinate) = add_species - this%zeta(i_coordinate) = zeta - this%print_sparse_index(i_coordinate) = print_sparse_index - this%unique_hash_tolerance(i_coordinate) = unique_hash_tolerance - this%unique_descriptor_tolerance(i_coordinate) = unique_descriptor_tolerance - - select case(lower_case(trim(sparse_method_str))) - case('random') - this%sparse_method(i_coordinate) = GP_SPARSE_RANDOM - case('pivot') - this%sparse_method(i_coordinate) = GP_SPARSE_PIVOT - case('cluster') - this%sparse_method(i_coordinate) = GP_SPARSE_CLUSTER - case('uniform') - this%sparse_method(i_coordinate) = GP_SPARSE_UNIFORM - case('kmeans') - this%sparse_method(i_coordinate) = GP_SPARSE_KMEANS - case('covariance') - this%sparse_method(i_coordinate) = GP_SPARSE_COVARIANCE - case('uniq') - call system_abort("sparse method UNIQ is no longer in use. Use NONE instead." ) - case('fuzzy') - this%sparse_method(i_coordinate) = GP_SPARSE_FUZZY - case('file') - this%sparse_method(i_coordinate) = GP_SPARSE_FILE - case('index_file') - this%sparse_method(i_coordinate) = GP_SPARSE_INDEX_FILE - case('cur_covariance') - this%sparse_method(i_coordinate) = GP_SPARSE_CUR_COVARIANCE - case('cur_points') - this%sparse_method(i_coordinate) = GP_SPARSE_CUR_POINTS - case('none') - this%sparse_method(i_coordinate) = GP_SPARSE_NONE - case default - call system_abort("unknown sparse method "//trim(sparse_method_str)) - endselect - - if( has_sparse_file ) then - if( this%sparse_method(i_coordinate) /= GP_SPARSE_FILE .and. & - this%sparse_method(i_coordinate) /= GP_SPARSE_INDEX_FILE ) then - call system_abort('"sparse_file" specified in command line, but sparse method not "file" or "index_file"') - endif - endif - - select case(lower_case(trim(covariance_type_str))) - case('none') - call system_abort("covariance type cannot be"//trim(covariance_type_str)) - this%covariance_type(i_coordinate) = COVARIANCE_NONE - case('gaussian') - this%covariance_type(i_coordinate) = COVARIANCE_ARD_SE - case('ard_se') ! backwards compatibility - this%covariance_type(i_coordinate) = COVARIANCE_ARD_SE - case('dot_product') - this%covariance_type(i_coordinate) = COVARIANCE_DOT_PRODUCT - case('bond_real_space') - this%covariance_type(i_coordinate) = COVARIANCE_BOND_REAL_SPACE - case('pp') - this%covariance_type(i_coordinate) = COVARIANCE_PP - case default - call system_abort("unknown covariance type"//trim(covariance_type_str)//". Available: Gaussian, DOT_PRODUCT, BOND_REAL_SPACE, PP (piecewise polynomial)") - endselect - - enddo - - call print('Descriptors have been parsed') - - endsubroutine gap_fit_parse_gap_str - - subroutine read_fit_xyz(this) - - type(gap_fit), intent(inout) :: this - - type(cinoutput) :: xyzfile - integer :: n_con - logical :: file_exists - - if( allocated(this%at) ) then - do n_con = 1, this%n_frame - call finalise(this%at(n_con)) - enddo - deallocate(this%at) - this%n_frame = 0 - endif - - inquire(file=this%at_file, exist=file_exists) - if( .not. file_exists ) then - call system_abort("read_fit_xyz: at_file "//this%at_file//" could not be found") - endif - - call initialise(xyzfile,this%at_file,mpi=this%mpi_obj) - this%n_frame = xyzfile%n_frame - - allocate(this%at(this%n_frame)) - - do n_con = 1, this%n_frame - call read(xyzfile,this%at(n_con),frame=n_con-1) - call set_cutoff(this%at(n_con), this%max_cutoff) - call calc_connect(this%at(n_con)) - enddo - - call finalise(xyzfile) - - if(this%n_frame <= 0) then - call system_abort("read_fit_xyz: "//this%n_frame//" frames read from "//this%at_file//".") - endif - - endsubroutine read_fit_xyz - - subroutine read_descriptors(this) - - type(gap_fit), intent(inout) :: this - - integer :: i - - this%max_cutoff = 0.0_dp - if(allocated(this%my_descriptor)) then - do i = 1, size(this%my_descriptor) - call finalise(this%my_descriptor(i)) - enddo - deallocate(this%my_descriptor) - endif - - allocate(this%my_descriptor(this%n_coordinate)) - do i = 1, this%n_coordinate - call initialise(this%my_descriptor(i),this%gap_str(i)) - if( this%max_cutoff < cutoff(this%my_descriptor(i)) ) this%max_cutoff = cutoff(this%my_descriptor(i)) - enddo - - endsubroutine read_descriptors - - subroutine fit_n_from_xyz(this) - - type(gap_fit), intent(inout) :: this - - logical :: do_collect_tasks, do_filter_tasks - - type(Atoms) :: at - - integer :: n_con - logical :: has_ener, has_force, has_virial, has_stress_3_3, has_stress_voigt, has_hessian, has_local_property, has_force_mask, & - exclude_atom, has_local_property_mask - real(dp) :: ener, virial(3,3), stress_3_3(3,3) - real(dp) :: stress_voigt(6) - real(dp), pointer, dimension(:,:) :: f, hessian_eigenvector_j - real(dp), pointer, dimension(:) :: local_property - logical, pointer, dimension(:) :: force_mask, local_property_mask - integer :: i, j, k - integer :: n_descriptors, n_cross, n_hessian - integer :: n_current, n_last - - do_collect_tasks = (this%task_manager%active .and. .not. this%task_manager%distributed) - do_filter_tasks = (this%task_manager%active .and. this%task_manager%distributed) - - if (allocated(this%n_cross)) deallocate(this%n_cross) - if (allocated(this%n_descriptors)) deallocate(this%n_descriptors) - allocate(this%n_cross(this%n_coordinate)) - allocate(this%n_descriptors(this%n_coordinate)) - - this%n_cross = 0 - this%n_descriptors = 0 - this%n_ener = 0 - this%n_force = 0 - this%n_virial = 0 - this%n_hessian = 0 - this%n_local_property = 0 - n_last = 0 - - do n_con = 1, this%n_frame - if (do_filter_tasks) then - if (this%task_manager%tasks(n_con)%worker_id /= this%task_manager%my_worker_id) cycle - end if - - has_ener = get_value(this%at(n_con)%params,this%energy_parameter_name,ener) - has_force = assign_pointer(this%at(n_con),this%force_parameter_name, f) - has_virial = get_value(this%at(n_con)%params,this%virial_parameter_name,virial) - has_stress_voigt = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_voigt) - has_stress_3_3 = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_3_3) - has_hessian = get_value(this%at(n_con)%params,"n_"//this%hessian_parameter_name,n_hessian) - has_local_property = assign_pointer(this%at(n_con),this%local_property_parameter_name, local_property) - has_force_mask = assign_pointer(this%at(n_con),trim(this%force_mask_parameter_name),force_mask) - has_local_property_mask = assign_pointer(this%at(n_con),trim(this%local_property_mask_parameter_name),local_property_mask) - - if( has_ener ) then - this%n_ener = this%n_ener + 1 - endif - - if( has_force ) then - do i = 1, this%at(n_con)%N - exclude_atom = .false. - if(has_force_mask) exclude_atom = force_mask(i) - - if( .not. exclude_atom ) this%n_force = this%n_force + 3 - enddo - endif - - if( has_stress_voigt .or. has_stress_3_3 ) then - if( has_stress_voigt .and. has_stress_3_3 ) then - call system_abort("fit_n_from_xyz: conflict in stress between 6-vector and 9-vector (really 3x3 matrix)") - endif - ! if has_stress is true, virial is available whether or not virial - ! field has been detected - has_virial = .true. - endif - - if( has_virial ) then - this%n_virial = this%n_virial + 6 - endif - - if( has_hessian ) then - this%n_hessian = this%n_hessian + n_hessian - at = this%at(n_con) - endif - - if( has_local_property ) then - if( has_local_property_mask ) then - this%n_local_property = this%n_local_property + count(local_property_mask) - else - this%n_local_property = this%n_local_property + this%at(n_con)%N - endif - endif - -! if( has_local_property .and. ( has_ener .or. has_force .or. has_virial .or. has_hessian ) ) then -! call system_abort("fit_n_from_xyz: local_property and (energy or force or virial or hessian) present in configuration, currently not allowed.") -! endif - - do i = 1, this%n_coordinate - call descriptor_sizes(this%my_descriptor(i),this%at(n_con),n_descriptors,n_cross) - - if( has_force ) then - this%n_cross(i) = this%n_cross(i) + n_cross*3 - endif - - if( has_virial ) then - this%n_cross(i) = this%n_cross(i) + n_cross*6 - endif - - this%n_descriptors(i) = this%n_descriptors(i) + n_descriptors - - if( has_hessian ) then - do j = 1, n_hessian - if( .not. assign_pointer(this%at(n_con),trim(this%hessian_parameter_name)//j, hessian_eigenvector_j) ) & - call system_abort("fit_n_from_xyz: could not find the "//j//"th of "//n_hessian//" hessian eigenvector") - - hessian_eigenvector_j = hessian_eigenvector_j / sqrt( sum(hessian_eigenvector_j**2) ) - - do k = -1, 1, 2 - at%pos = this%at(n_con)%pos + k * this%hessian_delta * hessian_eigenvector_j - call set_cutoff(at,this%max_cutoff) - call calc_connect(at) - call descriptor_sizes(this%my_descriptor(i),at,n_descriptors,n_cross) - - this%n_descriptors(i) = this%n_descriptors(i) + n_descriptors - this%n_cross(i) = this%n_cross(i) + n_descriptors - enddo - - enddo - endif - enddo - - if (do_collect_tasks) then - n_current = this%n_ener + this%n_local_property + this%n_force + this%n_virial + this%n_hessian - call task_manager_add_task(this%task_manager, n_current - n_last) - n_last = n_current - end if - - call finalise(at) - enddo - - if (.not. do_filter_tasks) then - call print_title("Report on number of descriptors found") - do i = 1, this%n_coordinate - call print("---------------------------------------------------------------------") - call print("Descriptor "//i//": "//this%gap_str(i)) - call print("Number of descriptors: "//this%n_descriptors(i)) - call print("Number of partial derivatives of descriptors: "//this%n_cross(i)) - enddo - call print_title("") - end if - - end subroutine fit_n_from_xyz - - subroutine fit_data_from_xyz(this,error) - - type(gap_fit), intent(inout) :: this - integer, optional, intent(out) :: error - - type(inoutput) :: theta_inout - type(descriptor_data) :: my_descriptor_data - - type(Atoms) :: at - integer :: d, n_con - logical :: has_ener, has_force, has_virial, has_stress_voigt, has_stress_3_3, has_hessian, has_local_property, & - has_config_type, has_energy_sigma, has_force_sigma, has_virial_sigma, has_virial_component_sigma, has_hessian_sigma, & - has_force_atom_sigma, has_force_component_sigma, has_local_property_sigma, has_force_mask, has_local_property_mask, & - exclude_atom - real(dp) :: ener, ener_core, my_cutoff, energy_sigma, force_sigma, virial_sigma, hessian_sigma, local_property_sigma, & - grad_covariance_cutoff, use_force_sigma - real(dp), dimension(3) :: pos - real(dp), dimension(3,3) :: virial, virial_core, stress_3_3, virial_component_sigma - real(dp), dimension(6) :: stress_voigt - real(dp), dimension(:), allocatable :: theta, theta_fac, hessian, hessian_core, grad_data - real(dp), dimension(:), pointer :: force_atom_sigma - real(dp), dimension(:,:), pointer :: f, hessian_eigenvector_i, f_hessian, force_component_sigma - real(dp), dimension(:), pointer :: local_property - logical, dimension(:), pointer :: force_mask, local_property_mask - real(dp), dimension(:,:), allocatable :: f_core - integer, dimension(:,:), allocatable :: force_loc, permutations - integer :: ie, i, j, n, k, l, i_coordinate, n_hessian, n_energy_sigma, n_force_sigma, n_force_atom_sigma, & - n_force_component_sigma, n_hessian_sigma, n_virial_sigma, n_local_property_sigma, n_descriptors, n_virial_component_sigma - integer, dimension(:), allocatable :: xloc, hessian_loc, local_property_loc - integer, dimension(3,3) :: virial_loc - - integer :: i_config_type, n_config_type, n_theta_fac - character(len=STRING_LENGTH) :: config_type - character(len=THETA_LENGTH) :: theta_string - character(len=STRING_LENGTH), dimension(:), allocatable :: theta_string_array - - INIT_ERROR(error) - - if (this%task_manager%active) then - if (.not. this%task_manager%distributed) then - call system_abort("fit_data_from_xyz: Tasks are not distributed.") - end if - - do n_con = 1, this%n_frame - if (this%task_manager%tasks(n_con)%worker_id /= this%task_manager%my_worker_id) then - call finalise(this%at(n_con)) - end if - end do - end if - - this%my_gp%do_subY_subY = merge(gap_fit_is_root(this), .true., this%task_manager%active) - - my_cutoff = 0.0_dp - call gp_setParameters(this%my_gp,this%n_coordinate,this%n_ener+this%n_local_property,this%n_force+this%n_virial+this%n_hessian,this%sparse_jitter) - - do i_coordinate = 1, this%n_coordinate - d = descriptor_dimensions(this%my_descriptor(i_coordinate)) - - call gp_setParameters(this%my_gp,i_coordinate, d, this%n_descriptors(i_coordinate), this%n_cross(i_coordinate), this%delta(i_coordinate), this%f0(i_coordinate), & - covariance_type=this%covariance_type(i_coordinate) ) - call gp_addDescriptor(this%my_gp,i_coordinate,trim(this%gap_str(i_coordinate))) - - allocate(permutations(d,descriptor_n_permutations(this%my_descriptor(i_coordinate)))) - call descriptor_permutations(this%my_descriptor(i_coordinate),permutations) - call gp_setPermutations(this%my_gp,i_coordinate,permutations) - deallocate(permutations) - - my_cutoff = max(my_cutoff,cutoff(this%my_descriptor(i_coordinate))) - enddo - - call print_title("Report on number of target properties found in training XYZ:") - call print("Number of target energies (property name: "//trim(this%energy_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_ener)) - call print("Number of target local_properties (property name: "//trim(this%local_property_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_local_property)) - call print("Number of target forces (property name: "//trim(this%force_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_force)) - call print("Number of target virials (property name: "//trim(this%virial_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_virial)) - call print("Number of target Hessian eigenvalues (property name: "//trim(this%hessian_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_hessian)) - call print_title("End of report") - - if( this%do_core ) call Initialise(this%core_pot, args_str=this%core_ip_args, param_str=string(this%quip_string)) - - n_energy_sigma = 0 - n_force_sigma = 0 - n_force_atom_sigma = 0 - n_force_component_sigma = 0 - n_virial_component_sigma=0 - n_hessian_sigma = 0 - n_virial_sigma = 0 - n_local_property_sigma = 0 - - do n_con = 1, this%n_frame - if (.not. is_initialised(this%at(n_con))) cycle - - has_ener = get_value(this%at(n_con)%params,this%energy_parameter_name,ener) - has_force = assign_pointer(this%at(n_con),this%force_parameter_name, f) - has_virial = get_value(this%at(n_con)%params,this%virial_parameter_name,virial) - has_virial_component_sigma = get_value(this%at(n_con)%params,'virial_component_'//trim(this%sigma_parameter_name),virial_component_sigma) - has_stress_voigt = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_voigt) - has_stress_3_3 = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_3_3) - has_hessian = get_value(this%at(n_con)%params,"n_"//this%hessian_parameter_name,n_hessian) - has_config_type = get_value(this%at(n_con)%params,this%config_type_parameter_name,config_type) - has_local_property = assign_pointer(this%at(n_con),this%local_property_parameter_name,local_property) - - has_energy_sigma = get_value(this%at(n_con)%params,'energy_'//trim(this%sigma_parameter_name),energy_sigma) - has_force_sigma = get_value(this%at(n_con)%params,'force_'//trim(this%sigma_parameter_name),force_sigma) - has_virial_sigma = get_value(this%at(n_con)%params,'virial_'//trim(this%sigma_parameter_name),virial_sigma) - has_hessian_sigma = get_value(this%at(n_con)%params,'hessian_'//trim(this%sigma_parameter_name),hessian_sigma) - has_force_atom_sigma = assign_pointer(this%at(n_con),'force_atom_'//trim(this%sigma_parameter_name),force_atom_sigma) - has_force_component_sigma = assign_pointer(this%at(n_con),'force_component_'//trim(this%sigma_parameter_name),force_component_sigma) - has_local_property_sigma = get_value(this%at(n_con)%params,'local_property_'//trim(this%sigma_parameter_name),local_property_sigma) - has_force_mask = assign_pointer(this%at(n_con),trim(this%force_mask_parameter_name),force_mask) - has_local_property_mask = assign_pointer(this%at(n_con),trim(this%local_property_mask_parameter_name),local_property_mask) - - if ((.not. has_virial) .and. (has_stress_3_3 .or. has_stress_voigt)) then - if (has_stress_voigt) then - virial(1,1) = stress_voigt(1) - virial(2,2) = stress_voigt(2) - virial(3,3) = stress_voigt(3) - virial(2,3) = stress_voigt(4) - virial(3,1) = stress_voigt(5) - virial(1,2) = stress_voigt(6) - virial(3,2) = virial(2,3) - virial(1,3) = virial(3,1) - virial(2,1) = virial(1,2) - else if (has_stress_3_3) then - virial = stress_3_3 - else - call system_abort("Frame "//n_con//" has no virial and stress that is neither a 9-vector (3x3)"// & - " nor 6-vector (Voigt)") - endif - virial = -virial * cell_volume(this%at(n_con)) - has_virial = .true. - endif - - if( has_force_atom_sigma .and. has_force_component_sigma ) then - call print_warning("Frame "//n_con//" contains both force_atom_"//trim(this%sigma_parameter_name)// & - " and force_component_"//trim(this%sigma_parameter_name)//" parameters. Per-component values will be used.") - endif - - if( has_hessian ) then - allocate(hessian(n_hessian)) - do i = 1, n_hessian - if( .not. get_value(this%at(n_con)%params,trim(this%hessian_parameter_name)//i,hessian(i)) ) & - call system_abort("fit_data_from_xyz: did not find "//i//"th of "//n_hessian//" hessian element" ) - enddo - endif - - if( has_config_type ) then - config_type = trim(config_type) - else - config_type = "default" - endif - - if( .not. allocated(this%config_type) ) call system_abort('config_type not allocated') - n_config_type = 0 - do i_config_type = 1, size(this%config_type) - if( trim(this%config_type(i_config_type)) == trim(config_type) ) n_config_type = i_config_type - enddo - - if( n_config_type == 0 ) then ! get the number of the "default" type as default - do i_config_type = 1, size(this%config_type) - if( trim(this%config_type(i_config_type)) == "default" ) n_config_type = i_config_type - enddo - endif - - if( this%do_core ) then - allocate( f_core(3,this%at(n_con)%N) ) - ener_core = 0.0_dp - f_core = 0.0_dp - virial_core = 0.0_dp - - if( this%at(n_con)%cutoff < max(cutoff(this%core_pot),my_cutoff) ) then - call set_cutoff(this%at(n_con), max(cutoff(this%core_pot),my_cutoff)) - call calc_connect(this%at(n_con)) - endif - - if(has_virial .and. has_force) then - call calc(this%core_pot,this%at(n_con),energy=ener_core,force=f_core,virial=virial_core) - elseif(has_force) then - call calc(this%core_pot,this%at(n_con),energy=ener_core,force=f_core) - elseif(has_virial) then - call calc(this%core_pot,this%at(n_con),energy=ener_core,virial=virial_core) - else - call calc(this%core_pot,this%at(n_con),energy=ener_core) - end if - - if(has_hessian) then - allocate( hessian_core(n_hessian), f_hessian(3,this%at(n_con)%N) ) - hessian_core = 0.0_dp - at = this%at(n_con) - call set_cutoff(at, cutoff(this%core_pot)) - do i = 1, n_hessian - if( .not. assign_pointer(this%at(n_con),trim(this%hessian_parameter_name)//i, hessian_eigenvector_i) ) & - call system_abort("fit_data_from_xyz: could not find "//i//"th of "//n_hessian//" hessian eigenvector.") - - hessian_eigenvector_i = hessian_eigenvector_i / sqrt( sum(hessian_eigenvector_i**2) ) - - do j = -1, 1, 2 - at%pos = this%at(n_con)%pos + j * this%hessian_delta * hessian_eigenvector_i - call calc_connect(at) - call calc(this%core_pot,at,force = f_hessian) - hessian_core(i) = hessian_core(i) + j * sum(f_hessian*hessian_eigenvector_i) / 2.0_dp / this%hessian_delta - enddo - enddo - call finalise(at) - - hessian = hessian - hessian_core - deallocate(hessian_core, f_hessian) - endif - - if(has_ener) ener = ener - ener_core - if(has_force) f = f - f_core - if(has_virial) virial = virial - virial_core - - deallocate(f_core) - endif - - if(has_ener) then - do i = 1, this%at(n_con)%N - ener = ener - this%e0(this%at(n_con)%Z(i)) - enddo - endif - - if(has_local_property) then - do i = 1, this%at(n_con)%N - local_property(i) = local_property(i) - this%local_property0(this%at(n_con)%Z(i)) - enddo - endif - - if( has_ener .and. has_local_property ) then - RAISE_ERROR("fit_data_from_xyz: energy and local_property both present in configuration, currently not allowed.",error) - endif - - if( this%at(n_con)%cutoff < my_cutoff ) then - call set_cutoff(this%at(n_con),my_cutoff) - call calc_connect(this%at(n_con)) - endif - - if( .not. has_energy_sigma ) then - if( this%sigma_per_atom ) then - energy_sigma = this%sigma(1,n_config_type)*sqrt(1.0_dp * this%at(n_con)%N) - else - energy_sigma = this%sigma(1,n_config_type) - endif - else - n_energy_sigma = n_energy_sigma + 1 - endif - - if( .not. has_force_sigma ) then - force_sigma = this%sigma(2,n_config_type) - else - n_force_sigma = n_force_sigma + 1 - endif - - if( .not. has_virial_sigma ) then - if( this%sigma_per_atom ) then - virial_sigma = this%sigma(3,n_config_type)*sqrt(1.0_dp * this%at(n_con)%N) - else - virial_sigma = this%sigma(3,n_config_type) - endif - else - n_virial_sigma = n_virial_sigma + 1 - endif - if (has_virial_component_sigma) then - n_virial_component_sigma = n_virial_component_sigma + 9 - else - virial_component_sigma = virial_sigma - endif - - if( .not. has_hessian_sigma ) then - hessian_sigma = this%sigma(4,n_config_type) - else - n_hessian_sigma = n_hessian_sigma + 1 - endif - - if( .not. has_local_property_sigma ) then - local_property_sigma = this%default_local_property_sigma - else - n_local_property_sigma = n_local_property_sigma + 1 - endif - - if( has_ener ) then - if( energy_sigma .feq. 0.0_dp ) then - RAISE_ERROR("fit_data_from_xyz: too small energy_sigma ("//energy_sigma//"), should be greater than zero",error) - endif - ie = gp_addFunctionValue(this%my_gp,ener, energy_sigma) - elseif( has_local_property ) then - if( local_property_sigma .feq. 0.0_dp ) then - RAISE_ERROR("fit_data_from_xyz: too small local_property_sigma ("//local_property_sigma//"), should be greater than zero",error) - endif - allocate(local_property_loc(this%at(n_con)%N)) - do i = 1, this%at(n_con)%N - if(has_local_property_mask) then - if( local_property_mask(i) ) then - local_property_loc(i) = gp_addFunctionValue(this%my_gp,local_property(i),local_property_sigma) - else - local_property_loc(i) = EXCLUDE_LOC - endif - else - local_property_loc(i) = gp_addFunctionValue(this%my_gp,local_property(i),local_property_sigma) - endif - enddo - endif - - if(has_force) then - allocate(force_loc(3,this%at(n_con)%N)) - do i = 1, this%at(n_con)%N - if (has_force_component_sigma) then - n_force_component_sigma = n_force_component_sigma + 3 - use_force_sigma = huge(1.0_dp) ! Updated later, below - elseif (has_force_atom_sigma) then - use_force_sigma = force_atom_sigma(i) - n_force_atom_sigma = n_force_atom_sigma + 1 - else - use_force_sigma = force_sigma - endif - - if( use_force_sigma .feq. 0.0_dp ) then - RAISE_ERROR("fit_data_from_xyz: too small force_sigma ("//use_force_sigma//"), should be greater than zero",error) - endif - - exclude_atom = .false. - if(has_force_mask) exclude_atom = force_mask(i) - - if( exclude_atom ) then - force_loc(:,i) = EXCLUDE_LOC - else - do k = 1, 3 - if( has_force_component_sigma ) use_force_sigma = force_component_sigma(k,i) - force_loc(k,i) = gp_addFunctionDerivative(this%my_gp,-f(k,i),use_force_sigma) - enddo - endif - enddo - endif - if(has_virial) then - ! check if virial is symmetric - if( sum((virial - transpose(virial))**2) .fne. 0.0_dp ) & - call print_warning('virial not symmetric, now symmetrised') - - ! Now symmetrise matrix - virial = ( virial + transpose(virial) ) / 2.0_dp - virial_component_sigma = ( virial_component_sigma + transpose(virial_component_sigma) ) / 2.0_dp - if( virial_sigma .feq. 0.0_dp ) then - RAISE_ERROR("fit_data_from_xyz: too small virial_sigma ("//virial_sigma//"), should be greater than zero",error) - endif - - do k = 1, 3 - do l = k, 3 - if( virial_component_sigma(l,k) .feq. 0.0_dp ) then - RAISE_ERROR("fit_data_from_xyz: too small virial_sigma ("//virial_component_sigma(l,k)//"), should be greater than zero",error) - endif - virial_loc(l,k) = gp_addFunctionDerivative(this%my_gp,-virial(l,k),virial_component_sigma(l,k)) - enddo - enddo - endif - - if(has_hessian) then - if( hessian_sigma .feq. 0.0_dp ) then - RAISE_ERROR("fit_data_from_xyz: too small hessian_sigma ("//hessian_sigma//"), should be greater than zero",error) - endif - - allocate(hessian_loc(n_hessian)) - do i = 1, n_hessian - hessian_loc(i) = gp_addFunctionDerivative(this%my_gp,hessian(i),hessian_sigma) - enddo - endif - - n_descriptors = 0 - do i_coordinate = 1, this%n_coordinate - - call calc(this%my_descriptor(i_coordinate),this%at(n_con),my_descriptor_data, & - do_descriptor=.true.,do_grad_descriptor=has_force .or. has_virial) - - allocate(xloc(size(my_descriptor_data%x))) - n_descriptors = n_descriptors + size(my_descriptor_data%x) - - if( has_ener ) then - do i = 1, size(my_descriptor_data%x) - if( .not. my_descriptor_data%x(i)%has_data) cycle - xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & - cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, current_y=ie,config_type=n_config_type) - enddo - elseif( has_local_property ) then - do i = 1, size(my_descriptor_data%x) - if( .not. my_descriptor_data%x(i)%has_data) cycle - if( local_property_loc(my_descriptor_data%x(i)%ci(1)) == EXCLUDE_LOC ) then - xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & - cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, config_type=n_config_type) - else - xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & - cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, current_y=local_property_loc(my_descriptor_data%x(i)%ci(1)),config_type=n_config_type) - endif - enddo - else - do i = 1, size(my_descriptor_data%x) - if( .not. my_descriptor_data%x(i)%has_data) cycle - xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & - cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, config_type=n_config_type) - enddo - endif - - - if(has_force) then - do i = 1, size(my_descriptor_data%x) - do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) - if( .not. my_descriptor_data%x(i)%has_grad_data(n)) cycle - j = my_descriptor_data%x(i)%ii(n) - - do k = 1, 3 - if( force_loc(k,j) > EXCLUDE_LOC ) then - call gp_addCoordinateDerivatives(this%my_gp,my_descriptor_data%x(i)%grad_data(:,k,n),i_coordinate, & - force_loc(k,j), xloc(i), dcutoff_in=my_descriptor_data%x(i)%grad_covariance_cutoff(k,n) ) - endif - enddo - enddo - enddo - - endif - - if(has_virial) then - do k = 1, 3 - do l = k, 3 - - do i = 1, size(my_descriptor_data%x) - do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) - if( .not. my_descriptor_data%x(i)%has_grad_data(n)) cycle - j = my_descriptor_data%x(i)%ii(n) - pos = my_descriptor_data%x(i)%pos(:,n) - call gp_addCoordinateDerivatives(this%my_gp,my_descriptor_data%x(i)%grad_data(:,k,n)*pos(l), i_coordinate, & - virial_loc(l,k), xloc(i), dcutoff_in=my_descriptor_data%x(i)%grad_covariance_cutoff(k,n)*pos(l)) - enddo - enddo - - enddo - enddo - endif - - if(allocated(xloc)) deallocate(xloc) - enddo - - if(allocated(force_loc)) deallocate(force_loc) - if(allocated(local_property_loc)) deallocate(local_property_loc) - - if( has_hessian ) then - at = this%at(n_con) - call set_cutoff( at, my_cutoff ) - do i_coordinate = 1, this%n_coordinate - allocate( grad_data(descriptor_dimensions(this%my_descriptor(i_coordinate))) ) - - do i = 1, n_hessian - if( .not. assign_pointer(this%at(n_con),trim(this%hessian_parameter_name)//i, hessian_eigenvector_i) ) & - call system_abort("fit_data_from_xyz: could not find "//i//"th of "//n_hessian//" hessian eigenvector.") - - do j = -1, 1, 2 - at%pos = this%at(n_con)%pos + j * this%hessian_delta * hessian_eigenvector_i - call calc_connect(at) - - call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, & - do_descriptor=.true.,do_grad_descriptor=.true.) - !hessian_core(i) = hessian_core(i) + j * sum(f_hessian*hessian_eigenvector_i) / 2.0_dp / this%hessian_delta - - allocate(xloc(size(my_descriptor_data%x))) - - do k = 1, size(my_descriptor_data%x) - if( .not. my_descriptor_data%x(k)%has_data) cycle - xloc(k) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(k)%data(:),i_coordinate, & - cutoff_in=my_descriptor_data%x(k)%covariance_cutoff,config_type=EXCLUDE_CONFIG_TYPE) - !cutoff_in=my_descriptor_data%x(k)%covariance_cutoff,config_type=n_config_type) - - - grad_data = 0.0_dp - grad_covariance_cutoff = 0.0_dp - do n = lbound(my_descriptor_data%x(k)%ii,1), ubound(my_descriptor_data%x(k)%ii,1) - if( .not. my_descriptor_data%x(k)%has_grad_data(n)) cycle - l = my_descriptor_data%x(k)%ii(n) - grad_data = grad_data + j * matmul(my_descriptor_data%x(k)%grad_data(:,:,n), hessian_eigenvector_i(:,l)) / 2.0_dp / this%hessian_delta - grad_covariance_cutoff = grad_covariance_cutoff + & - dot_product(my_descriptor_data%x(k)%grad_covariance_cutoff(:,n), hessian_eigenvector_i(:,l)) / 2.0_dp / this%hessian_delta - enddo - call gp_addCoordinateDerivatives(this%my_gp, grad_data, i_coordinate, & - hessian_loc(i), xloc(k), dcutoff_in=grad_covariance_cutoff) - - enddo !k - - deallocate(xloc) - enddo !j = -1, 1, 2 - enddo ! i = 1, n_hessian - if(allocated(grad_data)) deallocate(grad_data) - enddo ! i_coordinate = 1, n_coordinate - endif !has_hessian - - if(allocated(hessian_loc)) deallocate(hessian_loc) - if(allocated(hessian)) deallocate(hessian) - call finalise(my_descriptor_data) - enddo !n_frame - - call print_title("Report on per-configuration/per-atom sigma (error parameter) settings") - call print("Number of per-configuration setting of energy_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_energy_sigma)) - call print("Number of per-configuration setting of force_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_force_sigma)) - call print("Number of per-configuration setting of virial_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_virial_sigma)) - call print("Number of per-configuration setting of hessian_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_hessian_sigma)) - call print("Number of per-configuration setting of local_propery_"//trim(this%sigma_parameter_name)//" found:"//sum(this%task_manager%MPI_obj, n_local_property_sigma)) - call print("Number of per-atom setting of force_atom_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_force_atom_sigma)) - call print("Number of per-component setting of force_component_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_force_component_sigma)) - call print("Number of per-component setting of virial_component_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_virial_component_sigma)) - call print_title("End of report") - - do i_coordinate = 1, this%n_coordinate - if( count( (/this%has_theta_file(i_coordinate), this%has_theta_uniform(i_coordinate), & - this%has_theta_fac(i_coordinate), this%has_zeta(i_coordinate) /) ) /= 1 ) then - call system_abort("fit_data_from_xyz: only one of theta_file, theta_uniform, theta_fac or zeta may be & - specified for each GAP.") - endif - if( this%covariance_type(i_coordinate) == COVARIANCE_DOT_PRODUCT ) then - if( .not. this%has_zeta(i_coordinate) ) call system_abort("fit_data_from_xyz: covariance type is DOT_PRODUCT but no zeta was specified.") - elseif( this%covariance_type(i_coordinate) == COVARIANCE_ARD_SE .or. this%covariance_type(i_coordinate) == COVARIANCE_PP ) then - if( count( (/this%has_theta_file(i_coordinate), this%has_theta_uniform(i_coordinate), this%has_theta_fac(i_coordinate) /) ) /= 1 ) then - call system_abort("fit_data_from_xyz: covariance type is Gaussian or PP, so one of theta_file, theta_uniform of theta_fac must be specified") - endif - endif - - if( this%has_theta_file(i_coordinate) ) then - allocate(theta_string_array(this%my_gp%coordinate(i_coordinate)%d)) - allocate(theta(this%my_gp%coordinate(i_coordinate)%d)) - - call initialise(theta_inout,trim(this%theta_file(i_coordinate))) - read(theta_inout%unit,'(a)') theta_string - call split_string(theta_string,' :;','{}',theta_string_array,d,matching=.true.) - if(this%my_gp%coordinate(i_coordinate)%d /= d) call system_abort('File '//trim(this%theta_file(i_coordinate))//' does not contain the right number of hyperparameters') - do i = 1, d - theta(i) = string_to_real(trim(theta_string_array(i))) - enddo - call gp_setTheta(this%my_gp,i_coordinate,theta=theta) - deallocate(theta_string_array) - deallocate(theta) - call finalise(theta_inout) - elseif(this%has_theta_uniform(i_coordinate)) then - allocate(theta(this%my_gp%coordinate(i_coordinate)%d)) - theta = this%theta_uniform(i_coordinate) - call gp_setTheta(this%my_gp,i_coordinate,theta=theta) - deallocate(theta) - elseif(this%has_theta_fac(i_coordinate)) then - allocate(theta_string_array(this%my_gp%coordinate(i_coordinate)%d)) - allocate(theta_fac(this%my_gp%coordinate(i_coordinate)%d)) - call split_string(trim(this%theta_fac_string(i_coordinate))," :;",'{}',theta_string_array,n_theta_fac,matching=.true.) - - if(n_theta_fac == 1) then - theta_fac = string_to_real(theta_string_array(1)) - elseif(n_theta_fac == this%my_gp%coordinate(i_coordinate)%d) then - do i = 1, this%my_gp%coordinate(i_coordinate)%d - theta_fac(i) = string_to_real(theta_string_array(i)) - enddo - else - call system_abort("theta_fac can only contain one value or as many as dimensions the descriptor is") - endif - call gp_setThetaFactor(this%my_gp,i_coordinate,theta_fac,useSparseX=.false.) - - deallocate(theta_fac) - deallocate(theta_string_array) - elseif( this%has_zeta(i_coordinate) ) then - call gp_setTheta(this%my_gp,i_coordinate,zeta=this%zeta(i_coordinate)) - endif - enddo - - if( this%do_core ) call Finalise(this%core_pot) - - call gp_sparsify(this%my_gp, n_sparseX=this%config_type_n_sparseX, default_all=(this%n_sparseX /= 0), & - task_manager=this%task_manager, sparse_method=this%sparse_method, sparse_file=this%sparse_file, & - use_actual_gpcov=this%sparse_use_actual_gpcov, print_sparse_index = this%print_sparse_index, & - unique_hash_tolerance=this%unique_hash_tolerance, unique_descriptor_tolerance=this%unique_descriptor_tolerance) - - end subroutine fit_data_from_xyz - - subroutine e0_from_xyz(this) - - type(gap_fit), intent(inout) :: this - - integer :: n_con, n_ener, i, my_n_neighbours - logical :: has_ener - real(dp) :: ener, ener_core - - logical, dimension(total_elements) :: found_Z, found_isolated - - if( this%do_core ) call Initialise(this%core_pot, this%core_ip_args, param_str=string(this%quip_string)) - - n_ener = 0 - - this%e0 = 0.0_dp - found_isolated = .false. - found_Z = .false. - - do n_con = 1, this%n_frame - - has_ener = get_value(this%at(n_con)%params,trim(this%energy_parameter_name),ener) - - found_Z(this%at(n_con)%Z) = .true. - - if( has_ener ) then - - ener_core = 0.0_dp - if( this%do_core ) then - if( this%at(n_con)%cutoff < cutoff(this%core_pot) ) then - call set_cutoff(this%at(n_con), cutoff(this%core_pot)) - call calc_connect(this%at(n_con)) - endif - call calc(this%core_pot,this%at(n_con),energy=ener_core) - endif - - select case(this%e0_method) - case(E0_ISOLATED) - if( this%at(n_con)%N == 1 ) then - if( this%at(n_con)%cutoff < this%max_cutoff ) then - call set_cutoff(this%at(n_con), this%max_cutoff) - endif - call calc_connect(this%at(n_con)) - if( n_neighbours(this%at(n_con),1,max_dist = this%max_cutoff) == 0 ) then - if( found_isolated(this%at(n_con)%Z(1)) ) then - call system_abort("Found more than one isolated atom configuration, which may be ambiguous.") - endif - this%e0(this%at(n_con)%Z(1)) = ener - ener_core - found_isolated(this%at(n_con)%Z(1)) = .true. - endif - endif - case(E0_AVERAGE) - this%e0 = this%e0 + (ener-ener_core) / this%at(n_con)%N - case default - call system_abort("Unknown e0_method") - endselect - - n_ener = n_ener + 1 - endif - enddo - - select case(this%e0_method) - case(E0_ISOLATED) - if( .not. all(found_isolated .eqv. found_Z) ) then - do i = 1, size(found_Z) - if( found_Z(i) .and. .not. found_isolated(i) ) then - call print("Atom species "//i//" present in teaching XYZ, but not found corresponding isolated & - representative") - endif - enddo - call system_abort("Determination of e0 was requested to be based on isolated atom energies, but not all & - & atom types present in the XYZ had an isolated representative.") - endif - case(E0_AVERAGE) - if( n_ener > 0 ) then - this%e0 = this%e0 / n_ener - else - this%e0 = 0.0_dp - endif - case default - call system_abort("Unknown e0_method") - endselect - - if( this%do_core ) call Finalise(this%core_pot) - - endsubroutine e0_from_xyz - - subroutine w_Z_from_xyz(this) - - type(gap_fit), intent(inout) :: this - - type(cinoutput) :: xyzfile - type(atoms) :: at - - call initialise(xyzfile,this%at_file,mpi=this%mpi_obj) - - call read(xyzfile,at,frame=0) - !call get_weights(at,this%w_Z) - call finalise(at) - - call finalise(xyzfile) - - end subroutine w_Z_from_xyz - - subroutine gap_fit_print_xml(this,filename,sparseX_separate_file) - - use iso_c_binding, only : C_NULL_CHAR - - type(gap_fit), intent(in) :: this - character(len=*), intent(in) :: filename - logical, intent(in), optional :: sparseX_separate_file - - type(xmlf_t) :: xf - !type(extendable_str) :: gap_string - !type(inoutput) :: gp_inout - character(len=STRING_LENGTH) :: gp_tmp_file, gp_label - integer :: i - integer, dimension(8) :: values - logical :: my_sparseX_separate_file - - call date_and_time(values=values) - ! Get totally unique label for GAP. This will be used at various places. - write(gp_label,'("GAP_"7(i0,"_")i0)') values - - ! Unique temporary file - gp_tmp_file = 'tmp_'//trim(gp_label)//'.xml' - - ! Print GAP part of the potential into the temporary file. - call xml_OpenFile(gp_tmp_file,xf,addDecl=.false.) - - call xml_NewElement(xf,"GAP_params") - call xml_AddAttribute(xf,"label",trim(gp_label)) - call xml_AddAttribute(xf,"gap_version",""//gap_version) - - call xml_NewElement(xf,"GAP_data") - call xml_AddAttribute(xf,"do_core",""//this%do_core) - - do i = 1, size(this%e0) - call xml_NewElement(xf,"e0") - call xml_AddAttribute(xf,"Z",""//i) - call xml_AddAttribute(xf,"value",""// (this%e0(i)+this%local_property0(i) )) - call xml_EndElement(xf,"e0") - enddo - - call xml_EndElement(xf,"GAP_data") - - my_sparseX_separate_file = optional_default(.false., sparseX_separate_file) - - ! Print GP bit of the potential - if (my_sparseX_separate_file) then - call gp_printXML(this%gp_sp,xf,label=gp_label,sparseX_base_filename=trim(filename)//".sparseX") - - call gp_write_covariance(this%gp_sp, trim(filename)//".R", gp_label) - else - call gp_printXML(this%gp_sp,xf,label=gp_label) - endif - - ! Print the config string (from command line or config file) used for the fitting - ! Keep for backwards compatibility - if(this%config_string%len > 0) then - call xml_NewElement(xf,"command_line") - call xml_AddCharacters(xf,trim(string(this%config_string)),parsed=.false.) - call xml_EndElement(xf,"command_line") - endif - - if(this%do_copy_at_file) then - ! Print the fitting configurations used for this potential. - if(len(trim(this%at_file)) > 0 ) call file_print_xml(this%at_file,xf,ws_significant=.false.) - endif - - call xml_EndElement(xf,"GAP_params") - call xml_Close(xf) - - !! Now read back into an extendable string what we have just printed out. - !call read(gap_string, trim(gp_tmp_file), keep_lf=.true.) - - !! Initialise the final file - !call initialise(gp_inout,trim(filename),action=OUTPUT) - - ! Open a unique root element for the xml - !call print('<'//trim(gp_label)//'>',file=gp_inout) - !!call system_command('echo "<'//trim(gp_label)//'>" >>'//trim(filename)) - call fwrite_line_to_file(trim(filename)//C_NULL_CHAR,'<'//trim(gp_label)//'>'//C_NULL_CHAR,'w'//C_NULL_CHAR) - - if(this%do_core) then - ! Create the sum potential xml entry (by hand) - !call print('',file=gp_inout) - !call system_command('echo "" >>'//trim(filename)) - call fwrite_line_to_file(trim(filename)//C_NULL_CHAR, & - ''//C_NULL_CHAR, & - 'a'//C_NULL_CHAR) - - ! Now add the core potential that was used. - !call print(string(this%quip_string),file=gp_inout) - !call system_command('echo "'//string(this%quip_string)//' >>'//trim(filename)) - call fappend_file_to_file(trim(filename)//C_NULL_CHAR,trim(this%core_param_file)//C_NULL_CHAR) - else - call fwrite_line_to_file(trim(filename)//C_NULL_CHAR, & - ''//C_NULL_CHAR,'a'//C_NULL_CHAR) - endif - - ! Add the GAP potential - !call print(string(gap_string),file=gp_inout) - !call system_command('cat '//trim(gp_tmp_file)//' >>'//trim(filename)) - call fappend_file_to_file(trim(filename)//C_NULL_CHAR,trim(gp_tmp_file)//C_NULL_CHAR) - - ! Close the root element - !call print('',file=gp_inout) - !call system_command('echo "" >>'//trim(filename)) - call fwrite_line_to_file(trim(filename)//C_NULL_CHAR,''//C_NULL_CHAR,'a'//C_NULL_CHAR) - - !call finalise(gp_inout) - !call finalise(gap_string) - - ! Delete the temporary file - !call system_command('rm -f '//trim(gp_tmp_file)) - call frm_file(trim(gp_tmp_file)//C_NULL_CHAR) - - - endsubroutine gap_fit_print_xml - - subroutine file_print_xml(this,xf,ws_significant) - character(len=*), intent(in) :: this - type(xmlf_t), intent(inout) :: xf - logical, intent(in), optional :: ws_significant - - type(inoutput) :: atfile - character(len=10240) :: line - integer :: iostat - - call initialise(atfile,trim(this)) - call xml_NewElement(xf,"XYZ_data") - call xml_AddNewLine(xf) - - do - read(atfile%unit,'(a)',iostat=iostat) line - if(iostat < 0) then - exit - elseif(iostat > 0) then - call system_abort('file_print_xml: unkown error ('//iostat//') while reading '//trim(this)) - endif - call xml_AddCharacters(xf,trim(line),parsed=.false.,ws_significant=ws_significant) - call xml_AddNewLine(xf) - enddo - call xml_EndElement(xf,"XYZ_data") - call finalise(atfile) - - endsubroutine file_print_xml - -! subroutine print_sparse(this) -! type(gap_fit), intent(in) :: this -! type(cinoutput) :: xyzfile, xyzfile_out -! type(atoms) :: at, at_out -! -! integer :: li, ui, n_con -! logical, dimension(:), allocatable :: x -! logical, dimension(:), pointer :: sparse -! -! if(this%do_mark_sparse_atoms) then -! -! allocate(x(this%n_descriptors)) -! x = .false. -! x(this%r) = .true. -! -! call initialise(xyzfile,this%at_file) -! call initialise(xyzfile_out,this%mark_sparse_atoms,action=OUTPUT) -! -! li = 0 -! ui = 0 -! do n_con = 1, xyzfile%n_frame -! call read(xyzfile,at,frame=n_con-1) -! at_out = at -! -! call add_property(at_out,'sparse',.false.,ptr=sparse) -! -! li = ui + 1 -! ui = ui + at%N -! if(any( x(li:ui) )) sparse(find_indices(x(li:ui))) = .true. -! -! call write(at_out,xyzfile_out,properties="species:pos:sparse") -! enddo -! call finalise(xyzfile) -! call finalise(xyzfile_out) -! deallocate(x) -! -! endif -! -! endsubroutine print_sparse - - subroutine get_n_sparseX_for_files(this) - type(gap_fit), intent(inout) :: this - - integer :: i, n_sparseX, d - - do i = 1, this%n_coordinate - if (all(this%sparse_method(i) /= [GP_SPARSE_FILE, GP_SPARSE_INDEX_FILE])) cycle - - d = descriptor_dimensions(this%my_descriptor(i)) - n_sparseX = count_entries_in_sparse_file(this%sparse_file(i), this%sparse_method(i), d) - - if (this%n_sparseX(i) /= 0 .and. this%n_sparseX(i) /= n_sparseX) then - call system_abort("get_n_sparseX_for_files: Given n_sparse ("//this%n_sparseX(i)//") " & - // "does not match with file ("//n_sparseX//"). ") - end if - - this%n_sparseX(i) = n_sparseX - end do - end subroutine get_n_sparseX_for_files - - subroutine parse_config_type_sigma(this) - type(gap_fit), intent(inout) :: this - character(len=STRING_LENGTH), dimension(200) :: config_type_sigma_fields - integer :: config_type_sigma_num_fields, i_default, i, n_config_type - - if( this%has_config_type_sigma ) then - call split_string(this%config_type_sigma_string,' :;','{}',config_type_sigma_fields,config_type_sigma_num_fields,matching=.true.) - - n_config_type = config_type_sigma_num_fields / 5 - - ! find "default" if present - i_default = 0 - do i = 1, config_type_sigma_num_fields, 5 - if( trim(config_type_sigma_fields(i)) == "default" ) i_default = i - enddo - - if( i_default == 0 ) then - ! no default present in the string, we add it, and it'll be the last one - n_config_type = n_config_type + 1 - i_default = n_config_type - config_type_sigma_fields(config_type_sigma_num_fields+1) = "default" - config_type_sigma_fields(config_type_sigma_num_fields+2) = ""//this%default_sigma(1) - config_type_sigma_fields(config_type_sigma_num_fields+3) = ""//this%default_sigma(2) - config_type_sigma_fields(config_type_sigma_num_fields+4) = ""//this%default_sigma(3) - config_type_sigma_fields(config_type_sigma_num_fields+5) = ""//this%default_sigma(4) - config_type_sigma_num_fields = config_type_sigma_num_fields + 5 - endif - - allocate(this%config_type(n_config_type)) - allocate(this%sigma(4,n_config_type)) - - do i = 1, n_config_type - this%config_type(i) = trim(config_type_sigma_fields(5*(i-1)+1)) - this%sigma(1,i) = string_to_real(config_type_sigma_fields(5*(i-1)+2)) - this%sigma(2,i) = string_to_real(config_type_sigma_fields(5*(i-1)+3)) - this%sigma(3,i) = string_to_real(config_type_sigma_fields(5*(i-1)+4)) - this%sigma(4,i) = string_to_real(config_type_sigma_fields(5*(i-1)+5)) - enddo - - call print('Sparse points and target errors per pre-defined types of configurations') - do i = 1, n_config_type - call print(""//trim(this%config_type(i))//" "//this%sigma(:,i)) - enddo - else - allocate(this%config_type(1)) - allocate(this%sigma(4,1)) - this%config_type(1)= "default" - this%sigma(:,1) = this%default_sigma - endif - - endsubroutine parse_config_type_sigma - - subroutine parse_config_type_n_sparseX(this) - type(gap_fit), intent(inout) :: this - - integer :: i, j, i_default, i_coordinate, i_config_type, config_type_n_sparseX_num_fields, n_config_type, new_config_types - character(len=STRING_LENGTH), dimension(200) :: config_type_n_sparseX_fields - logical :: config_type_present - - if( .not. allocated(this%config_type) ) call system_abort('config_type not allocated, call parse_config_type_sigma first') - - do i = 1, size(this%config_type) - if( trim(this%config_type(i)) == "default" ) i_default = i - enddo - - ! Check first if we have more new config types than we had from config_type_sigma - do i_coordinate = 1, this%n_coordinate - if( this%n_sparseX(i_coordinate) == 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) > 0) then - call split_string(this%config_type_n_sparseX_string(i_coordinate),' :;','{}',config_type_n_sparseX_fields,config_type_n_sparseX_num_fields,matching=.true.) - - if( mod(config_type_n_sparseX_num_fields,2) /= 0 ) then - call system_abort("parse_config_type_n_sparseX: config_type_n_sparseX could not be parsed correctly, key/value pairs must always be present") - endif - - n_config_type = size(this%config_type) - new_config_types = 0 ! Assume there are no new config_types - do j = 1, config_type_n_sparseX_num_fields, 2 ! loop over config_types in the descriptor string - config_type_present = .false. - do i = 1, n_config_type ! loop over config_types previously set - if( trim(this%config_type(i)) == trim(config_type_n_sparseX_fields(j)) ) config_type_present = .true. ! Found config_type among old ones - enddo - if(.not.config_type_present) new_config_types = new_config_types + 1 ! Increment as it's a genuine new config_type - enddo - if( new_config_types > 0 ) then - call reallocate(this%config_type, n_config_type + new_config_types, copy=.true.) - call reallocate(this%sigma,4,n_config_type + new_config_types, copy=.true.) - - i_config_type = n_config_type - do j = 1, config_type_n_sparseX_num_fields, 2 ! loop over config_types in the descriptor string - config_type_present = .false. - do i = 1, n_config_type ! loop over config_types previously set - if( trim(this%config_type(i)) == trim(config_type_n_sparseX_fields(j)) ) config_type_present = .true. ! Found config_type among old ones - enddo - if(.not.config_type_present) then ! it's a genuine new config_type - i_config_type = i_config_type + 1 - this%config_type(i_config_type) = trim(config_type_n_sparseX_fields(j)) - this%sigma(:,i_config_type) = this%sigma(:,i_default) - endif - enddo - endif - - elseif(this%n_sparseX(i_coordinate) > 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) > 0 .and. len_trim(this%sparse_file(i_coordinate)) ==0 ) then - call system_abort('Confused: cannot specify both n_sparse and config_type_n_sparse') - - - elseif(this%n_sparseX(i_coordinate) == 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) == 0 .and. len_trim(this%sparse_file(i_coordinate)) == 0) then - call system_abort('Confused: either n_sparse or config_type_n_sparse has to be specified') - endif - - enddo - - n_config_type = size(this%config_type) - allocate(this%config_type_n_sparseX(n_config_type,this%n_coordinate)) - this%config_type_n_sparseX = 0 - - do i_coordinate = 1, this%n_coordinate - if( this%n_sparseX(i_coordinate) == 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) > 0) then - call split_string(this%config_type_n_sparseX_string(i_coordinate),' :;','{}',config_type_n_sparseX_fields,config_type_n_sparseX_num_fields,matching=.true.) - - do j = 1, config_type_n_sparseX_num_fields, 2 ! loop over config_types in the descriptor string - do i = 1, n_config_type ! loop over config_types previously set - if( trim(this%config_type(i)) == trim(config_type_n_sparseX_fields(j)) ) & - this%config_type_n_sparseX(i,i_coordinate) = string_to_int( config_type_n_sparseX_fields(j+1) ) - enddo - enddo - !this%n_sparseX(i_coordinate) = sum( this%config_type_n_sparseX(:,i_coordinate) ) - - elseif( this%n_sparseX(i_coordinate) > 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) == 0) then - this%config_type_n_sparseX(i_default,i_coordinate) = this%n_sparseX(i_coordinate) - endif - enddo - - endsubroutine parse_config_type_n_sparseX - - subroutine get_species_xyz(this) - type(gap_fit), intent(inout) :: this - - integer :: n_con, i - integer, dimension(total_elements) :: species_present - - this%n_species = 0 - species_present = 0 - - do n_con = 1, this%n_frame - do i = 1, this%at(n_con)%N - if( all(this%at(n_con)%Z(i) /= species_present) ) then - this%n_species = this%n_species + 1 - species_present(this%n_species) = this%at(n_con)%Z(i) - endif - enddo - enddo - - allocate(this%species_Z(this%n_species)) - this%species_Z = species_present(1:this%n_species) - - endsubroutine get_species_xyz - - subroutine add_multispecies_gaps(this) - type(gap_fit), intent(inout) :: this - - integer :: i_coordinate, i, j, n_gap_str, i_add_species - character(STRING_LENGTH), dimension(:), allocatable :: gap_str_i, new_gap_str - - ! temporary arrays - real(dp), dimension(:), allocatable :: delta, f0, theta_uniform, zeta, unique_hash_tolerance, unique_descriptor_tolerance - integer, dimension(:), allocatable :: n_sparseX, sparse_method, covariance_type - character(len=STRING_LENGTH), dimension(:), allocatable :: theta_file, sparse_file, theta_fac_string, config_type_n_sparseX_string, print_sparse_index - logical, dimension(:), allocatable :: mark_sparse_atoms, has_theta_fac, has_theta_uniform, has_theta_file, has_zeta - - n_gap_str = 0 - do i_coordinate = 1, this%n_coordinate - if( this%add_species(i_coordinate) ) then - - call print('Old GAP: {'//trim(this%gap_str(i_coordinate))//'}') - call descriptor_str_add_species(this%gap_str(i_coordinate),this%species_Z,gap_str_i) - call reallocate(new_gap_str, n_gap_str+size(gap_str_i),copy=.true.) - - call reallocate(delta, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(f0, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(n_sparseX, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(config_type_n_sparseX_string, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(theta_fac_string, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(theta_uniform, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(theta_file, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(has_theta_fac, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(has_theta_uniform, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(has_theta_file, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(sparse_file, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(mark_sparse_atoms, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(sparse_method, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(covariance_type, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(zeta, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(has_zeta, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(print_sparse_index, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(unique_hash_tolerance, n_gap_str+size(gap_str_i),copy=.true.) - call reallocate(unique_descriptor_tolerance, n_gap_str+size(gap_str_i),copy=.true.) - - do i = 1, size(gap_str_i) - i_add_species = index(gap_str_i(i),'add_species') - if(i_add_species /= 0) then - do j = i_add_species, len_trim(gap_str_i(i)) - if( gap_str_i(i)(j:j) == " " ) exit - gap_str_i(i)(j:j) = " " - !gap_str_i(i)(i_add_species:i_add_species+len('add_species')-1) = ' ' - enddo - endif - - new_gap_str(i+n_gap_str) = trim(gap_str_i(i)) - call print('New GAP: {'//trim(gap_str_i(i))//'}') - - delta(i+n_gap_str) = this%delta(i_coordinate) - f0(i+n_gap_str) = this%f0(i_coordinate) - n_sparseX(i+n_gap_str) = this%n_sparseX(i_coordinate) - config_type_n_sparseX_string(i+n_gap_str) = this%config_type_n_sparseX_string(i_coordinate) - theta_fac_string(i+n_gap_str) = this%theta_fac_string(i_coordinate) - theta_uniform(i+n_gap_str) = this%theta_uniform(i_coordinate) - theta_file(i+n_gap_str) = this%theta_file(i_coordinate) - - has_theta_fac(i+n_gap_str) = this%has_theta_fac(i_coordinate) - has_theta_uniform(i+n_gap_str) = this%has_theta_uniform(i_coordinate) - has_theta_file(i+n_gap_str) = this%has_theta_file(i_coordinate) - - sparse_file(i+n_gap_str) = this%sparse_file(i_coordinate) - mark_sparse_atoms(i+n_gap_str) = this%mark_sparse_atoms(i_coordinate) - sparse_method(i+n_gap_str) = this%sparse_method(i_coordinate) - covariance_type(i+n_gap_str) = this%covariance_type(i_coordinate) - zeta(i+n_gap_str) = this%zeta(i_coordinate) - has_zeta(i+n_gap_str) = this%has_zeta(i_coordinate) - print_sparse_index(i+n_gap_str) = this%print_sparse_index(i_coordinate) - unique_hash_tolerance(i+n_gap_str) = this%unique_hash_tolerance(i_coordinate) - unique_descriptor_tolerance(i+n_gap_str) = this%unique_descriptor_tolerance(i_coordinate) - - enddo - n_gap_str = n_gap_str + size(gap_str_i) - deallocate(gap_str_i) - - else - n_gap_str = n_gap_str + 1 - - call reallocate(new_gap_str, n_gap_str,copy=.true.) - call reallocate(delta, n_gap_str,copy=.true.) - call reallocate(f0, n_gap_str,copy=.true.) - call reallocate(n_sparseX, n_gap_str,copy=.true.) - call reallocate(config_type_n_sparseX_string, n_gap_str,copy=.true.) - call reallocate(theta_fac_string, n_gap_str,copy=.true.) - call reallocate(theta_uniform, n_gap_str,copy=.true.) - call reallocate(theta_file, n_gap_str,copy=.true.) - - call reallocate(has_theta_fac, n_gap_str,copy=.true.) - call reallocate(has_theta_uniform, n_gap_str,copy=.true.) - call reallocate(has_theta_file, n_gap_str,copy=.true.) - - call reallocate(sparse_file, n_gap_str,copy=.true.) - call reallocate(mark_sparse_atoms, n_gap_str,copy=.true.) - call reallocate(sparse_method, n_gap_str,copy=.true.) - call reallocate(covariance_type, n_gap_str,copy=.true.) - call reallocate(zeta, n_gap_str,copy=.true.) - call reallocate(has_zeta, n_gap_str,copy=.true.) - call reallocate(print_sparse_index, n_gap_str,copy=.true.) - - call reallocate(unique_hash_tolerance, n_gap_str,copy=.true.) - call reallocate(unique_descriptor_tolerance, n_gap_str,copy=.true.) - - new_gap_str(n_gap_str) = trim(this%gap_str(i_coordinate)) - delta(n_gap_str) = this%delta(i_coordinate) - f0(n_gap_str) = this%f0(i_coordinate) - n_sparseX(n_gap_str) = this%n_sparseX(i_coordinate) - config_type_n_sparseX_string(n_gap_str) = this%config_type_n_sparseX_string(i_coordinate) - theta_fac_string(n_gap_str) = this%theta_fac_string(i_coordinate) - theta_uniform(n_gap_str) = this%theta_uniform(i_coordinate) - theta_file(n_gap_str) = this%theta_file(i_coordinate) - - has_theta_fac(n_gap_str) = this%has_theta_fac(i_coordinate) - has_theta_uniform(n_gap_str) = this%has_theta_uniform(i_coordinate) - has_theta_file(n_gap_str) = this%has_theta_file(i_coordinate) - - sparse_file(n_gap_str) = this%sparse_file(i_coordinate) - mark_sparse_atoms(n_gap_str) = this%mark_sparse_atoms(i_coordinate) - sparse_method(n_gap_str) = this%sparse_method(i_coordinate) - covariance_type(n_gap_str) = this%covariance_type(i_coordinate) - zeta(n_gap_str) = this%zeta(i_coordinate) - has_zeta(n_gap_str) = this%has_zeta(i_coordinate) - print_sparse_index(n_gap_str) = this%print_sparse_index(i_coordinate) - - unique_hash_tolerance(n_gap_str) = this%unique_hash_tolerance(i_coordinate) - unique_descriptor_tolerance(n_gap_str) = this%unique_descriptor_tolerance(i_coordinate) - - call print('Unchanged GAP: {'//trim(this%gap_str(i_coordinate))//'}') - endif - - enddo - call reallocate(this%delta, n_gap_str) - call reallocate(this%f0, n_gap_str) - call reallocate(this%n_sparseX, n_gap_str) - call reallocate(this%config_type_n_sparseX_string, n_gap_str) - call reallocate(this%theta_fac_string, n_gap_str) - call reallocate(this%theta_uniform, n_gap_str) - call reallocate(this%theta_file, n_gap_str) - - call reallocate(this%has_theta_fac, n_gap_str) - call reallocate(this%has_theta_uniform, n_gap_str) - call reallocate(this%has_theta_file, n_gap_str) - - call reallocate(this%sparse_file, n_gap_str) - call reallocate(this%mark_sparse_atoms, n_gap_str) - call reallocate(this%sparse_method, n_gap_str) - call reallocate(this%covariance_type, n_gap_str) - call reallocate(this%zeta, n_gap_str) - call reallocate(this%has_zeta, n_gap_str) - call reallocate(this%print_sparse_index, n_gap_str) - - call reallocate(this%unique_hash_tolerance, n_gap_str) - call reallocate(this%unique_descriptor_tolerance, n_gap_str) - - this%gap_str(1:n_gap_str) = new_gap_str - this%delta = delta - this%f0 = f0 - this%n_sparseX = n_sparseX - this%config_type_n_sparseX_string = config_type_n_sparseX_string - this%theta_fac_string = theta_fac_string - this%theta_uniform = theta_uniform - this%theta_file = theta_file - - this%has_theta_fac = has_theta_fac - this%has_theta_uniform = has_theta_uniform - this%has_theta_file = has_theta_file - - this%sparse_file = sparse_file - this%mark_sparse_atoms = mark_sparse_atoms - this%sparse_method = sparse_method - this%covariance_type = covariance_type - this%zeta = zeta - this%has_zeta = has_zeta - this%print_sparse_index = print_sparse_index - - this%unique_hash_tolerance = unique_hash_tolerance - this%unique_descriptor_tolerance = unique_descriptor_tolerance - - this%n_coordinate = n_gap_str - - if(allocated(delta)) deallocate(delta) - if(allocated(f0)) deallocate(f0) - if(allocated(n_sparseX)) deallocate(n_sparseX) - if(allocated(config_type_n_sparseX_string)) deallocate(config_type_n_sparseX_string) - if(allocated(theta_fac_string)) deallocate(theta_fac_string) - if(allocated(theta_uniform)) deallocate(theta_uniform) - if(allocated(theta_file)) deallocate(theta_file) - - if(allocated(has_theta_fac)) deallocate(has_theta_fac) - if(allocated(has_theta_uniform)) deallocate(has_theta_uniform) - if(allocated(has_theta_file)) deallocate(has_theta_file) - - if(allocated(sparse_file)) deallocate(sparse_file) - if(allocated(mark_sparse_atoms)) deallocate(mark_sparse_atoms) - if(allocated(sparse_method)) deallocate(sparse_method) - if(allocated(covariance_type)) deallocate(covariance_type) - if(allocated(zeta)) deallocate(zeta) - if(allocated(has_zeta)) deallocate(has_zeta) - if(allocated(print_sparse_index)) deallocate(print_sparse_index) - - if(allocated(unique_hash_tolerance)) deallocate(unique_hash_tolerance) - if(allocated(unique_descriptor_tolerance)) deallocate(unique_descriptor_tolerance) - - endsubroutine add_multispecies_gaps - - subroutine add_template_string(this) - type(gap_fit), intent(inout) :: this - character(len=STRING_LENGTH) :: template_string=' ' - character(len=STRING_LENGTH),dimension(:), allocatable :: lines_array - type(inoutput) :: tempfile - integer :: i,n_lines,total_length=0 - - if( this%has_template_file ) then - call print("adding template string, reading from file "//trim(this%template_file)) - call initialise(tempfile,trim(this%template_file)) - call read_file(tempfile,lines_array,n_lines) - - do i=1,n_lines-1 - template_string=trim(template_string)//"{"//trim(lines_array(i))//"};" - total_length = total_length + len_trim(lines_array(i)) - end do - template_string=trim(template_string)//"{"//trim(lines_array(n_lines))//"}" - total_length = total_length + len_trim(lines_array(n_lines)) - - if (total_length .ge. STRING_LENGTH) call system_abort("Template atoms object exceeds maximum string size") - - do i=1,len_trim(template_string) - if(template_string(i:i)==' ') then - template_string(i:i)='%' - end if - end do - !call print(template_string) - - do i=1,this%n_coordinate - this%gap_str(i) = trim(this%gap_str(i))//" atoms_template_string={"//trim(template_string)//"}" - end do - endif - - end subroutine add_template_string - - subroutine gap_fit_read_core_param_file(this) - type(gap_fit), intent(inout) :: this - if (this%do_core) then - call read(this%quip_string, file=trim(this%core_param_file), mpi_comm=this%mpi_obj%communicator, mpi_id=this%mpi_obj%my_proc, keep_lf=.true.) - end if - end subroutine gap_fit_read_core_param_file - - subroutine gap_fit_init_mpi_scalapack(this) - type(gap_fit), intent(inout) :: this - - call initialise(this%mpi_obj) - call initialise(this%ScaLAPACK_obj, this%mpi_obj, np_r=this%mpi_obj%n_procs, np_c=1) - if (this%mpi_obj%n_procs > 1 .and. .not. this%ScaLAPACK_obj%active) then - call system_abort('Init MPI+Scalapack: n_procs > 1 but ScaLAPACK is inactive.') - end if - end subroutine gap_fit_init_mpi_scalapack - - subroutine gap_fit_init_task_manager(this) - type(gap_fit), intent(inout) :: this - - this%task_manager%active = this%ScaLAPACK_obj%active - this%task_manager%MPI_obj = this%MPI_obj - this%task_manager%ScaLAPACK_obj = this%ScaLAPACK_obj - - call task_manager_init_workers(this%task_manager, this%ScaLAPACK_obj%n_proc_rows) - call task_manager_init_tasks(this%task_manager, this%n_frame+1) ! mind special task - this%task_manager%my_worker_id = this%ScaLAPACK_obj%my_proc_row + 1 ! mpi 0-index to tm 1-index - - if (.not. this%task_manager%active) return - - call task_manager_init_idata(this%task_manager, 3) ! space for nrows, blocksizes - end subroutine gap_fit_init_task_manager - - subroutine gap_fit_distribute_tasks(this) - type(gap_fit), intent(inout) :: this - - integer :: n_sparseX - - if (.not. this%task_manager%active) return - - n_sparseX = sum(this%config_type_n_sparseX) - - ! add special task (size, offset) for Cholesky matrix addon shared by all workers - call task_manager_add_task(this%task_manager, n_sparseX, n_idata=2, worker_id=SHARED) - call task_manager_distribute_tasks(this%task_manager) - call task_manager_check_distribution(this%task_manager) - end subroutine gap_fit_distribute_tasks - - function gap_fit_is_root(this, root) result(res) - type(gap_fit), intent(in) :: this - integer, intent(in), optional :: root - logical :: res - res = is_root(this%MPI_obj, root) - end function gap_fit_is_root - - subroutine gap_fit_print_linear_system_dump_file(this) - type(gap_fit), intent(in) :: this - if (this%has_linear_system_dump_file) then - call gpFull_print_covariances_lambda_globalY(this%my_gp, this%linear_system_dump_file, & - this%mpi_obj%my_proc, do_Kmm=is_root(this%mpi_obj)) - end if - end subroutine gap_fit_print_linear_system_dump_file - - ! set blocksize, abort if ScaLAPACK would overflow 32bit integer - subroutine gap_fit_set_mpi_blocksizes(this) - type(gap_fit), intent(inout) :: this - - integer(idp), parameter :: bit_limit = 2_idp**31 - - integer :: nrows, nrows0, trows, ncols, mb_A, nb_A, i - integer(idp) :: lwork1, lwork2, trows64, size_A_local - - if (.not. this%task_manager%active) return - - nrows0 = this%task_manager%unified_workload - ncols = sum(this%config_type_n_sparseX) - - mb_A = this%mpi_blocksize_rows - if (mb_A == 0) then - call print("Defaulting mpi_blocksize_rows (arg = 0) ...", PRINT_VERBOSE) - mb_A = nrows0 - end if - call print("mpi_blocksize_rows = "//mb_A, PRINT_VERBOSE) - - nb_A = this%mpi_blocksize_cols - if (nb_A == 0) then - call print("Defaulting mpi_blocksize_cols (arg = 0) ...", PRINT_VERBOSE) - nb_A = ncols - end if - call print("mpi_blocksize_cols = "//nb_A, PRINT_VERBOSE) - - nrows = increase_to_multiple(nrows0, mb_A) - call print("nrows = "//nrows, PRINT_VERBOSE) - i = nrows - nrows0 - call print("distA extension: "//i//" "//ncols//" memory "//i2si(8_idp * i * ncols)//"B", PRINT_VERBOSE) - - ! transfer nrows and blocksizes to gp_predict - this%task_manager%idata(1) = nrows - this%task_manager%idata(2) = mb_A - this%task_manager%idata(3) = nb_A - - if (iwp == idp) return ! ignore 32bit checks for 64bit compilation - - - trows64 = int(nrows, idp) * this%task_manager%n_workers - trows = int(trows64, isp) - if (trows > bit_limit) then - call print_warning("Total rows of distributed matrix A is too large for 32bit integer: "//trows64//" = "//trows) - end if - - lwork1 = get_lwork_pdgeqrf(this%ScaLAPACK_obj, trows, ncols, mb_A, nb_A) - call print("lwork_pdgeqrf = "//lwork1//" = "//int(lwork1, isp), PRINT_VERBOSE) - lwork2 = get_lwork_pdormqr(this%ScaLAPACK_obj, 'L', trows, 1, mb_A, nb_A, mb_A, 1) - call print("lwork_pdormqr = "//lwork2//" = "//int(lwork2, isp), PRINT_VERBOSE) - if (max(lwork1, lwork2) > bit_limit) then - call system_abort("mpi_blocksize_cols = "//nb_A//" is too large for 32bit work array in ScaLAPACK!" & - //"Set mpi_blocksize_cols to something smaller, see --help.") - end if - - size_A_local = int(nrows, idp) * ncols - if (size_A_local > bit_limit) then - i = (trows64 * ncols + bit_limit - 1) / bit_limit - call system_abort("The local part of matrix A will have "//size_A_local//" entries. " & - // "This is too large for a 32bit integer calculation. " & - // "Use at least "//i//" MPI processes instead.") - end if - - end subroutine gap_fit_set_mpi_blocksizes - - subroutine gap_fit_estimate_memory(this) - type(gap_fit), intent(in) :: this - - integer(idp), parameter :: rmem = storage_size(1.0_dp, idp) / 8_idp - - integer :: i - integer(idp) :: s1, s2, entries - integer(idp) :: mem, memt, memp1 ! scratch, total, peak - integer(idp) :: sys_total_mem, sys_free_mem - - call print_title("Memory Estimate (per process)") - - call print("Descriptors") - memt = 0 - do i = 1, this%n_coordinate - s1 = descriptor_dimensions(this%my_descriptor(i)) - - entries = s1 * this%n_descriptors(i) - mem = entries * rmem - memt = memt + mem - call print("Descriptor "//i//" :: x "//s1//" "//this%n_descriptors(i)//" memory "//i2si(mem)//"B") - - entries = s1 * this%n_cross(i) - mem = entries * rmem - memt = memt + mem - call print("Descriptor "//i//" :: xPrime "//s1//" "//this%n_cross(i)//" memory "//i2si(mem)//"B") - end do - call print("Subtotal "//i2si(memt)//"B") - call print("") - memp1 = memt - - - call print("Covariances") - memt = 0 - s1 = sum(this%config_type_n_sparseX) - s2 = (this%n_ener + this%n_local_property) + (this%n_force + this%n_virial + this%n_hessian) - - entries = s1 * s2 - mem = entries * rmem - memt = memt + mem * 2 - call print("yY "//s1//" "//s2//" memory "//i2si(mem)//"B * 2") - memp1 = memp1 + mem - - entries = s1 * s1 - mem = entries * rmem - memt = memt + mem - call print("yy "//s1//" "//s1//" memory "//i2si(mem)//"B") - - entries = s1 * (s1 + s2) - mem = entries * rmem - memt = memt + mem * 2 - call print("A "//s1//" "//(s1+s2)//" memory "//i2si(mem)//"B * 2") - call print("Subtotal "//i2si(memt)//"B") - call print("") - - - mem = max(memp1, memt) - call print("Peak1 "//i2si(memp1)//"B") - call print("Peak2 "//i2si(memt)//"B") - call print("PEAK "//i2si(mem)//"B") - call print("") - - call mem_info(sys_total_mem, sys_free_mem) - call print("Free system memory "//i2si(sys_free_mem)//"B") - call print("Total system memory "//i2si(sys_total_mem)//"B") - - mem = sys_free_mem - mem - if (mem < 0) then - call print_warning("Memory estimate exceeds free system memory by "//i2si(-mem)//"B.") - end if - - call print_title("") - end subroutine gap_fit_estimate_memory - -end module gap_fit_module diff --git a/gp_fit.f95 b/gp_fit.f95 deleted file mode 100644 index 15de0009..00000000 --- a/gp_fit.f95 +++ /dev/null @@ -1,750 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Gaussian Process module -!X -!% Module for general GP function interpolations. -!% A gp object contains the training set (fitting points and function values), -!% important temporary matrices, vectors and parameters. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module gp_fit_module - - use iso_c_binding, only : C_NULL_CHAR - use error_module - use system_module - use extendable_str_module - use linearalgebra_module - use dictionary_module, only : STRING_LENGTH - use gp_predict_module - use clustering_module - use task_manager_module, only : task_manager_type - use MPI_context_module, only: bcast, gatherv, is_root, scatterv, sum - implicit none - private - - integer, parameter, public :: EXCLUDE_CONFIG_TYPE = -10 - - interface gp_sparsify - module procedure gpFull_sparsify_array_config_type - endinterface gp_sparsify - public :: gp_sparsify - - public :: count_entries_in_sparse_file - - contains - - subroutine gpCoordinates_sparsify_config_type(this, n_sparseX, default_all, task_manager, sparse_method, sparse_file, & - use_actual_gpcov, print_sparse_index, unique_hash_tolerance, unique_descriptor_tolerance, error) - type(gpCoordinates), intent(inout), target :: this - integer, dimension(:), intent(in) :: n_sparseX - logical, intent(in) :: default_all - type(task_manager_type), intent(in) :: task_manager - integer, intent(in), optional :: sparse_method - character(len=STRING_LENGTH), intent(in), optional :: sparse_file, print_sparse_index - logical, intent(in), optional :: use_actual_gpcov - real(dp), intent(in), optional :: unique_descriptor_tolerance, unique_hash_tolerance - integer, intent(out), optional :: error - - integer :: my_sparse_method, i, j, li, ui, i_config_type, n_config_type, d, n_x - integer, dimension(:), allocatable :: config_type_index, sparseX_index, my_n_sparseX, x_index - real(dp), dimension(:,:), allocatable :: sparseX_array - - integer, dimension(:), pointer :: config_type_ptr, x_size_ptr - real(dp), dimension(:), pointer :: covdiag_x_x_ptr, cutoff_ptr - real(dp), dimension(:,:), pointer :: dm, x_ptr - - character(len=STRING_LENGTH) :: my_sparse_file - type(Inoutput) :: inout_sparse_index - - nullify(config_type_ptr, x_size_ptr) - nullify(covdiag_x_x_ptr, cutoff_ptr) - nullify(dm, x_ptr) - - INIT_ERROR(error) - - my_sparse_method = optional_default(GP_SPARSE_RANDOM,sparse_method) - my_sparse_file = optional_default("",sparse_file) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_sparsify: : object not initialised',error) - endif - - d = size(this%x, 1) - - if (task_manager%active) then - select case(my_sparse_method) - case (GP_SPARSE_NONE) ! shared task for Kmm breaks if n_sparseX increases - call system_abort("sparse_method NONE is not implemented for MPI.") - case (GP_SPARSE_INDEX_FILE) ! keeping original ordering of xyz frames would be too much effort - call system_abort("sparse_method INDEX_FILE is not implemented for MPI.") - case (GP_SPARSE_CLUSTER) ! routines depend directly on gpCoordinates - call system_abort("sparse_method CLUSTER is not implemented for MPI.") - case (GP_SPARSE_COVARIANCE) ! routines depend directly on gpCoordinates - call system_abort("sparse_method COVARIANCE is not implemented for MPI.") - case (GP_SPARSE_CUR_COVARIANCE) ! routines depend directly on gpCoordinates - call system_abort("sparse_method CUR_COVARIANCE is not implemented for MPI.") - case (GP_SPARSE_FILE) - ! use serial pointers - case default - call print("Collecting x on a single process for sparsification with MPI.") - n_x = sum(task_manager%mpi_obj, size(this%config_type), error) - - if (.not. is_root(task_manager%mpi_obj)) then - my_sparse_method = GP_SPARSE_SKIP - d = 1 - n_x = 1 - end if - - allocate(config_type_ptr(n_x)) - allocate(x_size_ptr(n_x)) - allocate(covdiag_x_x_ptr(n_x)) - allocate(cutoff_ptr(n_x)) - allocate(x_ptr(d, n_x)) - - call gatherv(task_manager%mpi_obj, this%config_type, config_type_ptr, error=error) - call gatherv(task_manager%mpi_obj, this%x, x_ptr, error=error) - call gatherv(task_manager%mpi_obj, this%cutoff, cutoff_ptr, error=error) - - if (this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - call gatherv(task_manager%mpi_obj, this%x_size, x_size_ptr, error=error) - end if - end select - end if - - if (.not. associated(config_type_ptr)) config_type_ptr => this%config_type - if (.not. associated(x_size_ptr)) x_size_ptr => this%x_size - if (.not. associated(covdiag_x_x_ptr)) covdiag_x_x_ptr => this%covarianceDiag_x_x - if (.not. associated(cutoff_ptr)) cutoff_ptr => this%cutoff - if (.not. associated(x_ptr)) x_ptr => this%x - - if (my_sparse_method /= GP_SPARSE_SKIP) then - allocate(my_n_sparseX(size(n_sparseX)), source=0) - - call exclude_duplicates(x_ptr, config_type_ptr, unique_descriptor_tolerance, unique_hash_tolerance, error) - n_x = count(EXCLUDE_CONFIG_TYPE /= config_type_ptr) - end if - - if (my_sparse_method == GP_SPARSE_SKIP) then - ! pass - elseif(my_sparse_method == GP_SPARSE_UNIQ) then - RAISE_ERROR('gpCoordinates_sparsify: UNIQ is no longer in use, please use NONE instead.',error) - - elseif(my_sparse_method == GP_SPARSE_NONE) then - - allocate(x_index(n_x)) - - j = 0 - do i = 1, size(x_ptr,2) - if( config_type_ptr(i) /= EXCLUDE_CONFIG_TYPE ) then - j = j + 1 - x_index(j) = i - endif - enddo - - this%n_sparseX = n_x - - call print('NONE type sparsification specified. The number of sparse points was changed from '//n_sparseX//' to '//this%n_sparseX//'.') - - elseif(my_sparse_method == GP_SPARSE_FILE .or. my_sparse_method == GP_SPARSE_INDEX_FILE) then - this%n_sparseX = count_entries_in_sparse_file(my_sparse_file, my_sparse_method, d, error) - else - do i_config_type = 1, size(n_sparseX) - if(default_all) then - - if( n_x < sum(n_sparseX) ) then - call print_warning('gpCoordinates_sparsify: number of data points ('//n_x//') less than the number of sparse points ('//sum(n_sparseX)//'), & - number of sparse points changed to '//n_x) - call print_warning('gpCoordinates_sparsify: affected descriptor : '//this%descriptor_str) - my_n_sparseX(1) = n_x - else - my_n_sparseX(1) = sum(n_sparseX) - endif - - else - if( n_sparseX(i_config_type) == 0 ) cycle - - n_config_type = count(i_config_type == config_type_ptr) - - if( n_config_type < n_sparseX(i_config_type) ) then - call print_warning('gpCoordinates_sparsify: number of data points ('//n_config_type//') less than the number of sparse points ('//n_sparseX(i_config_type)//'), & - number of sparse points changed to '//n_config_type) - call print_warning('gpCoordinates_sparsify: affected descriptor : '//this%descriptor_str) - my_n_sparseX(i_config_type) = n_config_type - else - my_n_sparseX(i_config_type) = n_sparseX(i_config_type) - endif - endif - - if(default_all) exit - enddo - this%n_sparseX = sum(my_n_sparseX) - endif - - if (task_manager%active .and. my_sparse_method /= GP_SPARSE_FILE) then - call bcast(task_manager%mpi_obj, this%n_sparseX, error) - end if - - call reallocate(this%sparseX, this%d, this%n_sparseX, zero = .true.) - - call reallocate(this%sparseX_index, this%n_sparseX, zero = .true.) - call reallocate(this%map_sparseX_globalSparseX, this%n_sparseX, zero = .true.) - call reallocate(this%alpha, this%n_sparseX, zero = .true.) - call reallocate(this%sparseCutoff, this%n_sparseX, zero = .true.) - this%sparseCutoff = 1.0_dp - - if (my_sparse_method == GP_SPARSE_SKIP) then - ! pass - elseif( my_sparse_method /= GP_SPARSE_FILE .and. my_sparse_method /= GP_SPARSE_INDEX_FILE) then - ui = 0 - do i_config_type = 1, size(my_n_sparseX) - - if( my_sparse_method == GP_SPARSE_NONE) exit - - if(default_all) then - - allocate(config_type_index(n_x), sparseX_index(this%n_sparseX)) - j = 0 - do i = 1, size(x_ptr,2) - if( config_type_ptr(i) /= EXCLUDE_CONFIG_TYPE ) then - j = j + 1 - config_type_index(j) = i - endif - enddo - - li = 1 - ui = this%n_sparseX - n_config_type = n_x - else - if( my_n_sparseX(i_config_type) == 0 ) cycle - - n_config_type = count(i_config_type == config_type_ptr) - - allocate(config_type_index(n_config_type),sparseX_index(my_n_sparseX(i_config_type))) - config_type_index = find(i_config_type == config_type_ptr) - - li = ui + 1 - ui = ui + my_n_sparseX(i_config_type) - endif - - select case(my_sparse_method) - case(GP_SPARSE_RANDOM) - call fill_random_integer(sparseX_index, n_config_type) - case(GP_SPARSE_PIVOT) - if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - call pivot(x_ptr(:,config_type_index), sparseX_index) - else - call pivot(x_ptr(:,config_type_index), sparseX_index, theta = this%theta) - endif - case(GP_SPARSE_CLUSTER) - if(use_actual_gpcov) then - call print('Started kernel distance matrix calculation') - dm => kernel_distance_matrix(this, config_type_index = config_type_index) - call print('Finished kernel distance matrix calculation') - endif - call print('Started kmedoids clustering') - if(use_actual_gpcov) then - call bisect_kmedoids(dm, my_n_sparseX(i_config_type), med = sparseX_index) - else - if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - call bisect_kmedoids(x_ptr(:,config_type_index), my_n_sparseX(i_config_type), med = sparseX_index, is_distance_matrix = .false.) - else - call bisect_kmedoids(x_ptr(:,config_type_index), my_n_sparseX(i_config_type), med = sparseX_index, theta = this%theta, is_distance_matrix = .false.) - endif - endif - call print('Finished kmedoids clustering') - if(use_actual_gpcov) deallocate(dm) - case(GP_SPARSE_UNIFORM) - call select_uniform(x_ptr(:,config_type_index), sparseX_index) - case(GP_SPARSE_KMEANS) - call print('Started kmeans clustering') - if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - call cluster_kmeans(x_ptr(:,config_type_index), sparseX_index) - else - call cluster_kmeans(x_ptr(:,config_type_index), sparseX_index, theta = this%theta) - endif - call print('Finished kmeans clustering') - case(GP_SPARSE_COVARIANCE) - call sparse_covariance(this,sparseX_index,config_type_index,use_actual_gpcov) - case(GP_SPARSE_FUZZY) - call print('Started fuzzy cmeans clustering') - if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - call cluster_fuzzy_cmeans(x_ptr(:,config_type_index), sparseX_index, fuzziness=2.0_dp) - else - call cluster_fuzzy_cmeans(x_ptr(:,config_type_index), sparseX_index, theta=this%theta,fuzziness=2.0_dp) - endif - call print('Finished fuzzy cmeans clustering') - case(GP_SPARSE_CUR_COVARIANCE) - call print("Started covariance matrix calculation") - dm => kernel_distance_matrix(this, config_type_index=config_type_index, covariance_only = .true.) - call print("Finished covariance matrix calculation") - call print("Started CUR decomposition") - call cur_decomposition(dm, sparseX_index) - call print("Finished CUR decomposition") - deallocate(dm) - case(GP_SPARSE_CUR_POINTS) - call print("Started CUR decomposition") - call cur_decomposition(x_ptr(:,config_type_index), sparseX_index) - call print("Finished CUR decomposition") - case default - RAISE_ERROR('gpCoordinates_sparsify: '//my_sparse_method//' method is unknown', error) - endselect - this%sparseX_index(li:ui) = config_type_index(sparseX_index) - deallocate(config_type_index,sparseX_index) - - if(default_all) exit - enddo - - elseif(my_sparse_method == GP_SPARSE_INDEX_FILE) then - call print('Started reading sparse indices from file '//trim(my_sparse_file)) - call fread_array_i(size(this%sparseX_index),this%sparseX_index(1),trim(my_sparse_file)//C_NULL_CHAR) - call print('Finished reading sparse indices from file, '//size(this%sparseX_index)//' of them.') - endif - - call reallocate(this%covarianceDiag_sparseX_sparseX, this%n_sparseX) - - if (my_sparse_method == GP_SPARSE_SKIP) then - ! pass - elseif(my_sparse_method == GP_SPARSE_FILE) then - call print('Started reading sparse descriptors from file '//trim(my_sparse_file)) - allocate(sparseX_array(d+1,this%n_sparseX)) - call fread_array_d(size(sparseX_array),sparseX_array(1,1),trim(my_sparse_file)//C_NULL_CHAR) - this%sparseCutoff = sparseX_array(1,:) - this%sparseX = sparseX_array(2:,:) - this%covarianceDiag_sparseX_sparseX = 1.0_dp ! only used for COVARIANCE_BOND_REAL_SPACE - deallocate(sparseX_array) - call print('Finished reading sparse descriptors from file, '//size(this%sparseCutoff)//' of them.') - else - if(my_sparse_method == GP_SPARSE_NONE) this%sparseX_index = x_index - - call sort_array(this%sparseX_index) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - call reallocate(this%sparseX, maxval(x_size_ptr(this%sparseX_index)), this%n_sparseX) - call reallocate(this%sparseX_size, this%n_sparseX) - this%sparseX(:,:) = x_ptr(1:maxval(x_size_ptr(this%sparseX_index)),this%sparseX_index) - this%sparseX_size = x_size_ptr(this%sparseX_index) - else - this%sparseX(:,:) = x_ptr(:,this%sparseX_index) - endif - - this%covarianceDiag_sparseX_sparseX = covdiag_x_x_ptr(this%sparseX_index) - - this%sparseCutoff = cutoff_ptr(this%sparseX_index) - - if(present(print_sparse_index)) then - if(len_trim(print_sparse_index) > 0) then - call initialise(inout_sparse_index, trim(print_sparse_index), action=OUTPUT, append=.true.) - call print(""//this%sparseX_index,file=inout_sparse_index) - call finalise(inout_sparse_index) - endif - endif - endif - - if (task_manager%active .and. my_sparse_method /= GP_SPARSE_FILE) then - call print("Distributing sparseX after sparsification with MPI.") - call bcast(task_manager%mpi_obj, this%covarianceDiag_sparseX_sparseX, error=error) - call bcast(task_manager%mpi_obj, this%sparseCutoff, error=error) - call bcast(task_manager%mpi_obj, this%sparseX, error=error) - if (allocated(this%sparseX_size)) call bcast(task_manager%mpi_obj, this%sparseX_size, error=error) - - deallocate(config_type_ptr) - deallocate(x_size_ptr) - deallocate(covdiag_x_x_ptr) - deallocate(cutoff_ptr) - deallocate(x_ptr) - end if - - if (allocated(this%config_type)) deallocate(this%config_type) - if (allocated(this%sparseX_index)) deallocate(this%sparseX_index) - this%sparsified = .true. - endsubroutine gpCoordinates_sparsify_config_type - - subroutine exclude_duplicates(x, config_type, unique_descriptor_tolerance, unique_hash_tolerance, error) - real(dp), dimension(:,:), intent(in) :: x - integer, dimension(:), intent(inout) :: config_type - real(dp), intent(in), optional :: unique_descriptor_tolerance, unique_hash_tolerance - integer, intent(out), optional :: error - - integer :: i, j, n_x - real(dp) :: my_unique_hash_tolerance, my_unique_descriptor_tolerance - real(dp) :: max_diff - - integer, dimension(:), allocatable :: x_index - real(dp), dimension(:), allocatable :: x_hash - - INIT_ERROR(error) - - my_unique_hash_tolerance = optional_default(1.0e-10_dp, unique_hash_tolerance) - my_unique_descriptor_tolerance = optional_default(1.0e-10_dp, unique_descriptor_tolerance) - - n_x = count(config_type /= EXCLUDE_CONFIG_TYPE) - allocate(x_hash(n_x)) - allocate(x_index(n_x)) - - ! Compute 1-norm hash on all descriptors that we want to include, and the mapping to the full vector - j = 0 - do i = 1, size(x,2) - if (config_type(i) /= EXCLUDE_CONFIG_TYPE) then - j = j + 1 - x_hash(j) = sum(abs(x(:,i))) - x_index(j) = i - end if - end do - - call heap_sort(x_hash, i_data=x_index) - - ! Compare neighbouring hashes. If they're within tolerance, compare the corresponding descriptors using the eucledian norm. - ! Update the config type if they're equivalent. - do j = 2, n_x - if (abs(x_hash(j-1) - x_hash(j)) < my_unique_hash_tolerance) then - max_diff = maxval(abs(x(:,x_index(j)) - x(:,x_index(j-1)))) - if (max_diff < my_unique_descriptor_tolerance) then - config_type(x_index(j-1)) = EXCLUDE_CONFIG_TYPE - end if - end if - end do - end subroutine exclude_duplicates - - function count_entries_in_sparse_file(sparse_file, sparse_method, d, error) result(res) - character(len=*), intent(in) :: sparse_file - integer, intent(in) :: sparse_method - integer, intent(in) :: d ! coordinate_length - integer, intent(out), optional :: error - integer :: res - - logical :: exist_sparse_file - integer :: n_sparse_file - - INIT_ERROR(error) - - inquire(file=trim(sparse_file), exist=exist_sparse_file) - if (.not. exist_sparse_file) then - RAISE_ERROR('count_entries_in_sparse_file: "'//trim(sparse_file)//'" does not exist', error) - end if - - call fwc_l(trim(sparse_file)//C_NULL_CHAR, n_sparse_file) - - select case (sparse_method) - case (GP_SPARSE_INDEX_FILE) - res = n_sparse_file - case (GP_SPARSE_FILE) - if (mod(n_sparse_file, d+1) /= 0) then - RAISE_ERROR('count_entries_in_sparse_file: file '//trim(sparse_file)//' contains '//n_sparse_file//" lines, not conforming with descriptor size "//d, error) - end if - res = n_sparse_file / (d + 1) - case default - RAISE_ERROR('count_entries_in_sparse_file: given sparse_method is not implemented: '//sparse_method, error) - end select - end function count_entries_in_sparse_file - - subroutine gpFull_sparsify_array_config_type(this, n_sparseX, default_all, task_manager, sparse_method, sparse_file, & - use_actual_gpcov, print_sparse_index, unique_hash_tolerance, unique_descriptor_tolerance, error) - type(gpFull), intent(inout) :: this - integer, dimension(:,:), intent(in) :: n_sparseX - logical, dimension(:), intent(in) :: default_all - type(task_manager_type), intent(in) :: task_manager - integer, dimension(:), intent(in), optional :: sparse_method - character(len=STRING_LENGTH), dimension(:), intent(in), optional :: sparse_file, print_sparse_index - logical, intent(in), optional :: use_actual_gpcov - real(dp), dimension(:), intent(in), optional :: unique_hash_tolerance, unique_descriptor_tolerance - integer, intent(out), optional :: error - - integer :: i - integer, dimension(:), allocatable :: my_sparse_method - character(len=STRING_LENGTH), dimension(:), allocatable :: my_sparse_file - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_sparsify_array: object not initialised',error) - endif - - allocate(my_sparse_method(this%n_coordinate)) - allocate(my_sparse_file(this%n_coordinate)) - my_sparse_method = optional_default((/ (GP_SPARSE_RANDOM, i=1,this%n_coordinate) /),sparse_method) - my_sparse_file = optional_default((/ ("", i=1,this%n_coordinate) /),sparse_file) - - do i = 1, this%n_coordinate - call gpCoordinates_sparsify_config_type(this%coordinate(i), n_sparseX(:,i), default_all(i), task_manager, & - sparse_method=my_sparse_method(i), sparse_file=my_sparse_file(i), use_actual_gpcov=use_actual_gpcov, & - print_sparse_index=print_sparse_index(i), unique_hash_tolerance=unique_hash_tolerance(i), & - unique_descriptor_tolerance=unique_descriptor_tolerance(i), error=error) - enddo - endsubroutine gpFull_sparsify_array_config_type - - function kernel_distance_matrix(this, config_type_index, covariance_only) result(k_nn) - type(gpCoordinates), intent(in) :: this - integer, dimension(:), intent(in), optional :: config_type_index - logical, intent(in), optional :: covariance_only - - real(dp), pointer, dimension(:,:) :: k_nn ! actually the kernel distance matrix - - !real(dp), dimension(:,:), allocatable :: k_nn - real(dp), dimension(:), allocatable :: k_self - logical :: do_kernel_distance - integer :: i, j, n, ii, jj - integer :: stat - - call system_timer('kernel_distance_matrix') - - do_kernel_distance = .not. optional_default(.false., covariance_only) - - if(present(config_type_index)) then - n = size(config_type_index) - else - n = size(this%x,2) - endif - - allocate(k_self(n)) - - allocate(k_nn(n,n), stat=stat) - if(stat /= 0) call system_abort('kernel_distance_matrix: could not allocate matrix.') - -!$omp parallel do default(none) shared(this,n,config_type_index,k_self) private(i,ii) - do i = 1, n - if(present(config_type_index)) then - ii = config_type_index(i) - else - ii = i - endif - - k_self(i) = gpCoordinates_Covariance(this, i_x = ii, j_x = ii, normalise = .false.) - enddo - - do j = 1, n - if(present(config_type_index)) then - jj = config_type_index(j) - else - jj = j - endif - - !k_nn(j,j) = 1.0_dp ! normalised kernel self-covariance - k_nn(j,j) = 0.0_dp ! distance to itself = 0 - -!$omp parallel do default(none) shared(n,this,k_nn,jj,j,k_self,config_type_index,do_kernel_distance) private(i,ii) - do i = j+1, n - if(present(config_type_index)) then - ii = config_type_index(i) - else - ii = i - endif - - ! kernel covariance - k_nn(j,i) = gpCoordinates_Covariance(this, i_x = ii, j_x = jj, normalise = .false.) - ! then normalise - k_nn(j,i) = k_nn(j,i) / sqrt(k_self(i)*k_self(j)) - - if (do_kernel_distance) then - ! now convert to distance - k_nn(j,i) = sqrt(2.0_dp * (1.0_dp - k_nn(j,i))) - endif - - ! finally, symmetrise - k_nn(i,j) = k_nn(j,i) - enddo ! i - enddo ! j - - !dm = sqrt(2.0_dp * (1.0_dp - k_nn)) - !do i = 1, n - ! do j = i+1, n - ! dm(i,j) = sqrt(2.0_dp*(1.0_dp - kij)) - ! dm(j,i) = dm(i,j) - ! end do - !end do - - !deallocate(k_nn, k_self) - deallocate(k_self) - call system_timer('kernel_distance_matrix') - end function kernel_distance_matrix - - subroutine sparse_covariance(this, index_out, config_type_index, use_actual_gpcov) - type(gpCoordinates), intent(in) :: this - integer, dimension(:), intent(out) :: index_out - integer, dimension(:), intent(in), optional :: config_type_index - logical, intent(in), optional :: use_actual_gpcov - - real(dp), dimension(:), allocatable :: score, k_self !, xI_xJ - real(dp), dimension(:,:), allocatable :: k_mn, k_mm_k_m - real(dp), dimension(1,1) :: k_mm - integer :: m, n, i, ii, j, jj, i_p, zeta_int - integer, dimension(1) :: j_loc - logical, dimension(:), allocatable :: not_yet_added - logical :: do_use_actual_gpcov - - type(LA_Matrix) :: LA_k_mm - - call system_timer('sparse_covariance') - if(present(config_type_index)) then - n = size(config_type_index) - else - n = size(this%x,2) - endif - m = size(index_out) - - do_use_actual_gpcov = optional_default(.false., use_actual_gpcov) - if(do_use_actual_gpcov) then - call print("sparse_covariance using actual gpCoordinates_Covariance") - else - call print("sparse_covariance using manual 'covariance'") - endif - - allocate(k_mn(m,n), score(n), k_mm_k_m(m,n), k_self(n), not_yet_added(n)) - k_mn = 0.0_dp - not_yet_added = .true. - - !allocate(xI_xJ(this%d)) - - j = 1 - index_out(j) = 1 !ceiling(ran_uniform() * n) - not_yet_added(index_out(j)) = .false. - - k_mm = 1.0_dp+1.0e-6_dp - zeta_int = nint(this%zeta) - call initialise(LA_k_mm,k_mm) - -!$omp parallel do default(none) shared(this,n,config_type_index,k_self,do_use_actual_gpcov,zeta_int) private(i,ii,i_p) - do i = 1, n - if(present(config_type_index)) then - ii = config_type_index(i) - else - ii = i - endif - - if(do_use_actual_gpcov) then - k_self(i) = gpCoordinates_Covariance(this, i_x = ii, j_x = ii, normalise = .false.) - else - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - if( zeta_int .feq. this%zeta ) then - k_self(i) = dot_product( this%x(:,ii), this%x(:,ii) )**zeta_int - else - k_self(i) = dot_product( this%x(:,ii), this%x(:,ii) )**this%zeta - endif - elseif( this%covariance_type == COVARIANCE_ARD_SE ) then - k_self(i) = 0.0_dp - do i_p = 1, this%n_permutations - !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp - k_self(i) = k_self(i) + exp( -0.5_dp * sum((this%x(this%permutations(:,i_p),ii) - this%x(:,ii))**2) / 16.0_dp ) - enddo - elseif( this%covariance_type == COVARIANCE_PP ) then - k_self(i) = 0.0_dp - do i_p = 1, this%n_permutations - !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp - k_self(i) = k_self(i) + covariancePP( sqrt( sum((this%x(this%permutations(:,i_p),ii) - this%x(:,ii))**2) ) / 4.0_dp, PP_Q, this%d) - enddo - endif - endif - enddo - - do j = 1, m-1 - - if(present(config_type_index)) then - jj = config_type_index(index_out(j)) - else - jj = index_out(j) - endif - -!$omp parallel do default(none) shared(n,this,k_mn,jj,j,LA_k_mm,k_mm_k_m,score,k_self,config_type_index,index_out,do_use_actual_gpcov,zeta_int) private(i,i_p,ii) - do i = 1, n - - if(present(config_type_index)) then - ii = config_type_index(i) - else - ii = i - endif - if(do_use_actual_gpcov) then - k_mn(j,i) = gpCoordinates_Covariance(this, i_x = ii, j_x = jj, normalise = .false.) - else - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - if( zeta_int .feq. this%zeta ) then - k_mn(j,i) = dot_product( this%x(:,ii), this%x(:,jj) )**zeta_int - else - k_mn(j,i) = dot_product( this%x(:,ii), this%x(:,jj) )**this%zeta - endif - elseif( this%covariance_type == COVARIANCE_ARD_SE ) then - k_mn(j,i) = 0.0_dp - do i_p = 1, this%n_permutations - !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp - k_mn(j,i) = k_mn(j,i) + exp( -0.5_dp * sum((this%x(this%permutations(:,i_p),ii) - this%x(:,jj))**2) / 16.0_dp ) - enddo - elseif( this%covariance_type == COVARIANCE_PP ) then - k_mn(j,i) = 0.0_dp - do i_p = 1, this%n_permutations - !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp - k_mn(j,i) = k_mn(j,i) + covariancePP( sqrt( sum((this%x(this%permutations(:,i_p),ii) - this%x(:,jj))**2) ) / 4.0_dp, PP_Q, this%d) - enddo - endif - endif - k_mn(j,i) = k_mn(j,i) / sqrt(k_self(i)*k_self(index_out(j))) - - call Matrix_Solve(LA_k_mm,k_mn(1:j,i),k_mm_k_m(1:j,i)) - score(i) = sum( k_mn(1:j,i) * k_mm_k_m(1:j,i) ) - enddo - - j_loc = minloc(score, mask=not_yet_added) - jj = j_loc(1) - index_out(j+1) = jj - not_yet_added(jj) = .false. - - if(j == 1) then - call print('Initial score: '//score) - endif - call print('Min score: '//minval(score)) - - !k_mm(1:j_i,j_i+1) = k_mn(1:j_i,j) - !k_mm(j_i+1,1:j_i) = k_mn(1:j_i,j) - !k_mm(j_i+1,j_i+1) = 1.0_dp - call LA_Matrix_Expand_Symmetrically(LA_k_mm,(/k_mn(1:j,jj),1.0_dp+1.0e-6_dp/)) - !call initialise(LA_k_mm,k_mm(1:j_i+1,1:j_i+1)) - - enddo - call print('Final score: '//score) - call print('Min score: '//minval(score)) - - deallocate(k_mn, score, k_mm_k_m, k_self, not_yet_added) - !if(allocated(xI_xJ)) deallocate(xI_xJ) - call finalise(LA_k_mm) - call system_timer('sparse_covariance') - - endsubroutine sparse_covariance - -end module gp_fit_module diff --git a/gp_predict.f95 b/gp_predict.f95 deleted file mode 100644 index 37b826f1..00000000 --- a/gp_predict.f95 +++ /dev/null @@ -1,5290 +0,0 @@ -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HND X -! HND X GAP (Gaussian Approximation Potental) -! HND X -! HND X -! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, -! HND X and Sascha Klawohn. Copyright 2006-2021. -! HND X -! HND X Portions of GAP were written by Noam Bernstein as part of -! HND X his employment for the U.S. Government, and are not subject -! HND X to copyright in the USA. -! HND X -! HND X GAP is published and distributed under the -! HND X Academic Software License v1.0 (ASL) -! HND X -! HND X GAP is distributed in the hope that it will be useful for non-commercial -! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied -! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! HND X ASL for more details. -! HND X -! HND X You should have received a copy of the ASL along with this program -! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, -! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at -! HND X http://github.com/gabor1/ASL -! HND X -! HND X When using this software, please cite the following reference: -! HND X -! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) -! HND X -! HND X When using the SOAP kernel or its variants, please additionally cite: -! HND X -! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) -! HND X -! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Gaussian Process module -!X -!% Module for general GP function interpolations. -!% A gp object contains the training set (fitting points and function values), -!% important temporary matrices, vectors and parameters. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module gp_predict_module - - use iso_c_binding, only : C_NULL_CHAR - ! use libatoms_module - use error_module -#ifdef _OPENMP - use omp_lib -#endif - use system_module, only : idp, dp, qp, optional_default, reallocate, NUMERICAL_ZERO, & - system_timer, string_to_numerical, print_warning, progress, progress_timer, & - current_times, InOutput, OUTPUT, increase_to_multiple, i2si, PRINT_VERBOSE - use units_module - use linearalgebra_module - use extendable_str_module - use dictionary_module - use paramreader_module - use descriptors_module - use fox_wxml - use FoX_sax, only: xml_t, dictionary_t, haskey, getvalue, parse, & - open_xml_string, close_xml_t - use CInOutput_module, only : quip_md5sum - use task_manager_module - use matrix_module - use MPI_context_module, only : scatterv - - implicit none - - private - - integer, parameter :: besseli_max_n = 20 - - real(dp), dimension(besseli_max_n), parameter :: besseli0_c = (/ & - 0.125_dp, & - 7.03125E-002_dp, & - 7.32421875E-002_dp, & - 0.112152099609375_dp, & - 0.22710800170898438_dp, & - 0.57250142097473145_dp, & - 1.7277275025844574_dp, & - 6.0740420012734830_dp, & - 24.380529699556064_dp, & - 110.01714026924674_dp, & - 551.33589612202059_dp, & - 3038.0905109223841_dp, & - 18257.755474293175_dp, & - 118838.42625678326_dp, & - 832859.30401628942_dp, & - 6252951.4934347980_dp, & - 50069589.531988934_dp, & - 425939216.50476694_dp, & - 3836255180.2304339_dp, & - 36468400807.065559_dp /) - - real(dp), dimension(besseli_max_n), parameter :: besseli1_c = (/ & - -0.375_dp, & - -0.1171875_dp, & - -0.1025390625_dp, & - -0.144195556640625_dp, & - -0.27757644653320313_dp, & - -0.67659258842468262_dp, & - -1.9935317337512970_dp, & - -6.8839142681099474_dp, & - -27.248827311268542_dp, & - -121.59789187653587_dp, & - -603.84407670507017_dp, & - -3302.2722944808525_dp, & - -19718.375912236628_dp, & - -127641.27264617461_dp, & - -890297.87670706783_dp, & - -6656367.7188176867_dp, & - -53104110.109685220_dp, & - -450278600.30503929_dp, & - -4043620325.1077542_dp, & - -38338575207.427895_dp /) - - real(dp), parameter :: besseli_max_x = 18.0_dp - - real(dp), parameter :: THETA_MIN = 1.0e-8_dp - integer, parameter, public :: GP_SPARSE_RANDOM = 1 - integer, parameter, public :: GP_SPARSE_PIVOT = 2 - integer, parameter, public :: GP_SPARSE_CLUSTER = 3 - integer, parameter, public :: GP_SPARSE_UNIFORM = 4 - integer, parameter, public :: GP_SPARSE_KMEANS = 5 - integer, parameter, public :: GP_SPARSE_COVARIANCE = 6 - integer, parameter, public :: GP_SPARSE_UNIQ = 7 - integer, parameter, public :: GP_SPARSE_FUZZY = 8 - integer, parameter, public :: GP_SPARSE_FILE = 9 - integer, parameter, public :: GP_SPARSE_INDEX_FILE = 10 - integer, parameter, public :: GP_SPARSE_CUR_COVARIANCE = 11 - integer, parameter, public :: GP_SPARSE_CUR_POINTS = 12 - integer, parameter, public :: GP_SPARSE_NONE = 13 - integer, parameter, public :: GP_SPARSE_SKIP = 99 ! internal use for MPI - - integer, parameter, public :: COVARIANCE_NONE = 0 - integer, parameter, public :: COVARIANCE_ARD_SE = 1 - integer, parameter, public :: COVARIANCE_DOT_PRODUCT = 2 - integer, parameter, public :: COVARIANCE_BOND_REAL_SPACE = 3 - integer, parameter, public :: COVARIANCE_PP = 4 - - integer, parameter, public :: PP_Q = 1 - - ! loop iterations per OpenMP thread, 0: each thread gets a single block of similar size - integer, public, save :: openmp_chunk_size = 0 - - type gpCovariance_bond_real_space - - integer :: n - real(dp) :: delta - real(dp) :: atom_sigma - - logical :: initialised = .false. - - endtype gpCovariance_bond_real_space - - type gpCovariance_atom_real_space - - integer :: l_max = 0 - real(dp) :: atom_sigma, delta, zeta - real(dp) :: cutoff, cutoff_transition_width - - logical :: initialised = .false. - - endtype gpCovariance_atom_real_space - - public :: gpCovariance_bond_real_space - public :: gpCovariance_bond_real_space_Calc - public :: gpCoordinates_gpCovariance_bond_real_space_Initialise - - public :: gpCovariance_atom_real_space - public :: gpCovariance_atom_real_space_Calc - - type gpCoordinates - - integer :: d = 0, n_x, n_xPrime, n_sparseX, n_permutations - ! dimension of descriptors, number of descriptors, number of derivatives of descriptors - - integer :: current_x, current_xPrime - ! pointers to the last added values - - real(dp), dimension(:,:), allocatable :: x, xPrime - ! descriptors (d,n_x), derivatives of descriptors (d, n_xPrime) - ! for real space covariance descriptors (max(x_size),n_x), derivatives of descriptors (max(x_size),n_xPrime) - real(dp), dimension(:), allocatable :: cutoff, cutoffPrime - integer, dimension(:), allocatable :: x_size, xPrime_size - real(dp), dimension(:), allocatable :: covarianceDiag_x_x, covarianceDiag_xPrime_xPrime - - real(dp), dimension(:,:), allocatable :: sparseX, covarianceDiag_x_xPrime - real(dp), dimension(:), allocatable :: sparseCutoff - ! sparse points stored as real array - ! for real space covariance descriptors - integer, dimension(:), allocatable :: sparseX_size - real(dp), dimension(:), allocatable :: covarianceDiag_sparseX_sparseX - - real(dp), dimension(:,:,:), allocatable :: sparseX_permuted - real(dp), dimension(:), allocatable :: sparseCovariance - - real(dp), dimension(:), allocatable :: theta - ! range parameters (d) for descriptors in each directions - real(dp) :: zeta = 0.0_dp - - real(dp), dimension(:), allocatable :: alpha - ! - - real(dp) :: delta, f0 = 0.0_dp, variance_estimate_regularisation = 0.0_dp - ! range of GP (function value) and baseline of function - - integer, dimension(:), allocatable :: map_x_y, map_xPrime_yPrime, map_xPrime_x, config_type - ! which descriptor is used for a given function value, which derivative descriptor is used for a given derivative function, which descriptor is differentiated - - integer, dimension(:), allocatable :: map_sparseX_globalSparseX - ! sparse point in this descriptor type -> all sparse points in gpFull - - integer, dimension(:), allocatable :: sparseX_index - ! sparse points stored as indices of the x array - - integer, dimension(:,:), allocatable :: permutations - ! Lists the permutations symmetries of the coordinates - logical, dimension(:,:), allocatable :: permutation_distance_mask - ! pairwise distances that may occur given all permutations - - type(gpCovariance_bond_real_space) :: bond_real_space_cov - integer :: covariance_type = COVARIANCE_NONE - - type(extendable_str) :: descriptor_str - - type(LA_Matrix) :: LA_k_mm - - logical :: initialised = .false. - logical :: sparsified = .false. - logical :: variance_estimate_initialised = .false. - logical :: sparse_covariance_initialised = .false. - - endtype gpCoordinates - - public :: gpCoordinates - - type gpFull - - integer :: n_y, n_yPrime - ! number of function values, number of derivative function values - - integer :: n_globalSparseX - ! number of all sparse points in every descriptor type - - integer :: n_coordinate - ! number of different descriptors - - integer :: current_y, current_yPrime - - real(dp) :: sparse_jitter = 1.0e-5_dp - - real(dp), dimension(:), allocatable :: y, yPrime - ! function values, derivative function values - - real(dp), dimension(:), allocatable :: sigma_y, sigma_yPrime - ! estimated error of function values, derivatives - - real(dp), dimension(:,:), allocatable :: covariance_subY_y, covariance_subY_subY, covariance_y_y - ! covariance matrix - - real(dp), dimension(:), allocatable :: covarianceDiag_y_y, lambda, alpha - ! covariance matrix - - integer, dimension(:), allocatable :: map_y_globalY, map_yPrime_globalY - - type(gpCoordinates), dimension(:), allocatable :: coordinate - - logical :: do_subY_subY = .true. - - logical :: initialised = .false. - - endtype gpFull - - type gpSparse - integer :: n_coordinate ! number of different descriptors - type(gpCoordinates), dimension(:), allocatable :: coordinate - logical :: initialised = .false. - logical :: fitted = .false. - logical :: do_export_R = .false. - real(dp), dimension(:, :), allocatable :: R - endtype gpSparse - - type cplx_1d_array - complex(dp), dimension(:), allocatable :: value - endtype cplx_1d_array - - type cplx_2d_array - complex(dp), dimension(:,:), allocatable :: value - endtype cplx_2d_array - - type neighbour_descriptor - type(cplx_1d_array), dimension(:), allocatable :: spherical_harmonics - real(dp) :: r - integer :: n - endtype neighbour_descriptor - - logical, save :: parse_matched_label, parse_in_gpCoordinates, parse_in_gpFull, parse_in_gpSparse, parse_in_sparseX, parse_sliced, parse_sparseX_separate_file - integer, save :: parse_i_sparseX, parse_i_x, parse_i_xPrime, parse_i_permutation, parse_slice_start, parse_slice_end - type(gpCoordinates), pointer :: parse_gpCoordinates - type(gpFull), pointer :: parse_gpFull - type(gpSparse), pointer :: parse_gpSparse - type(extendable_str), save :: parse_cur_data - integer, dimension(:,:), allocatable :: parse_in_permutations - character(len=1024), save :: parse_gpCoordinates_label, parse_gpFull_label, parse_gpSparse_label - - public :: gpFull, gpSparse - public :: gpFull_print_covariances_lambda_globalY - public :: gpSparse_fit - - interface initialise - module procedure gpSparse_initialise - endinterface initialise - public :: initialise - - interface finalise - module procedure gpFull_Finalise, gpCoordinates_Finalise, gpSparse_finalise, gpNeighbourDescriptor_Finalise - endinterface finalise - public :: finalise - - interface gp_setTheta - module procedure gpCoordinates_setTheta, gpFull_setTheta - endinterface gp_setTheta - public :: gp_setTheta - - interface gp_setThetaFactor - module procedure gpFull_setTheta_thetaFactor !, gpFull_setTheta_thetaFactorArray, gpFull_setTheta_thetaFactorUniform - endinterface gp_setThetaFactor - public :: gp_setThetaFactor - - interface gp_setParameters - module procedure gpFull_setParameters, gpFull_gpCoordinates_setParameters, gpCoordinates_setParameters, & - gpCoordinates_setParameters_sparse, gpSparse_setParameters - endinterface gp_setParameters - public :: gp_setParameters - - interface gp_setPermutations - module procedure gpCoordinates_setPermutations, gpFull_setPermutations, gpSparse_setPermutations - endinterface gp_setPermutations - public :: gp_setPermutations - - interface gp_addFunctionValue - module procedure gpFull_addFunctionValue - endinterface gp_addFunctionValue - public :: gp_addFunctionValue - - interface gp_addFunctionDerivative - module procedure gpFull_addFunctionDerivative - endinterface gp_addFunctionDerivative - public :: gp_addFunctionDerivative - - interface gp_addCoordinates - module procedure gpFull_addCoordinates_1Darray, gpFull_addCoordinates_2Darray - endinterface gp_addCoordinates - public :: gp_addCoordinates - - interface gp_addCoordinateDerivatives - module procedure gpFull_addCoordinateDerivatives_1Darray, gpFull_addCoordinateDerivatives_2Darray - endinterface gp_addCoordinateDerivatives - public :: gp_addCoordinateDerivatives - - interface gp_addDescriptor - module procedure gpFull_addDescriptor - endinterface gp_addDescriptor - public :: gp_addDescriptor - - interface gp_printXML - module procedure gpCoordinates_printXML, gpFull_printXML, gpSparse_printXML - endinterface gp_PrintXML - public :: gp_printXML - - interface gp_readXML - module procedure gpCoordinates_readXML, gpFull_readXML, gpSparse_readXML, & - gpCoordinates_readXML_string, gpFull_readXML_string, gpSparse_readXML_string - endinterface gp_readXML - public :: gp_readXML - - interface gp_covariance_sparse - module procedure gpFull_covarianceMatrix_sparse - endinterface gp_covariance_sparse - public :: gp_covariance_sparse - - interface gp_covariance_full - module procedure gpFull_covarianceMatrix - endinterface gp_covariance_full - public :: gp_covariance_full - - interface gp_Predict - module procedure gpCoordinates_Predict - endinterface gp_Predict - public :: gp_Predict - - interface gp_log_likelihood - module procedure gpCoordinates_log_likelihood - endinterface gp_log_likelihood - public :: gp_log_likelihood - - public :: gpCoordinates_Covariance - public :: gpCoordinates_initialise_variance_estimate - public :: covariancePP - - public :: gp_write_covariance - - contains - -#ifdef _OPENMP - function get_chunk_size(n) result(res) - integer, intent(in) :: n - integer :: res - integer :: t - - if (openmp_chunk_size == 0) then - ! We can't emulate OpenMP default exactly, so we use ceil(n / t) - t = omp_get_num_threads() - res = (n + t - 1) / t - else - res = openmp_chunk_size - end if - end function get_chunk_size -#endif - - subroutine gpFull_setParameters(this, n_coordinate, n_y, n_yPrime, sparse_jitter, error) - - type(gpFull), intent(inout) :: this - integer, intent(in) :: n_coordinate, n_y, n_yPrime - real(dp), intent(in) :: sparse_jitter - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(this%initialised) call finalise(this,error) - - this%n_coordinate = n_coordinate - this%n_y = n_y - this%n_yPrime = n_yPrime - this%current_y = 0 - this%current_yPrime = 0 - this%sparse_jitter = sparse_jitter - - allocate( this%coordinate(n_coordinate) ) - allocate( this%y(n_y), this%yPrime(n_yPrime) ) - allocate( this%map_y_globalY(n_y), this%map_yPrime_globalY(n_yPrime) ) - allocate( this%sigma_y(n_y), this%sigma_yPrime(n_yPrime) ) - - this%initialised = .true. - - endsubroutine gpFull_setParameters - - subroutine gpFull_gpCoordinates_setParameters(this, i, d, n_x, n_xPrime, delta, f0, covariance_type, x_size_max, xPrime_size_max, error) - - type(gpFull), intent(inout) :: this - integer, intent(in) :: i, d, n_x, n_xPrime - real(dp), intent(in) :: delta, f0 - integer, optional, intent(in) :: covariance_type - integer, optional, intent(in) :: x_size_max, xPrime_size_max - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_set_gpCoordinates_parameters: object not initialised',error) - endif - - if( i > this%n_coordinate ) then - RAISE_ERROR( 'gpFull_set_gpCoordinates_parameters: access to descriptor '//i//' is not possible as number of descriptors is '//this%n_coordinate,error ) - endif - - call gpCoordinates_setParameters(this%coordinate(i), d, n_x, n_xPrime, delta, f0, covariance_type = covariance_type, x_size_max=x_size_max, xPrime_size_max=xPrime_size_max, error=error) - - endsubroutine gpFull_gpCoordinates_setParameters - - subroutine gpCoordinates_setParameters(this, d, n_x, n_xPrime, delta, f0, covariance_type, x_size_max, xPrime_size_max, error) - - type(gpCoordinates), intent(inout) :: this - integer, intent(in) :: d, n_x, n_xPrime - real(dp), intent(in) :: delta, f0 - integer, optional, intent(in) :: covariance_type - integer, optional, intent(in) :: x_size_max, xPrime_size_max - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(this%initialised) call finalise(this,error) - - if( d < 0 ) then - RAISE_ERROR("gpCoordinates_setParameters: negative value of d = "//d,error) - else - this%d = d - endif - - if( n_x < 0 ) then - RAISE_ERROR("gpCoordinates_setParameters: negative value of n_x = "//n_x,error) - else - this%n_x = n_x - endif - - if( n_xPrime < 0 ) then - RAISE_ERROR("gpCoordinates_setParameters: negative value of n_xPrime = "//n_xPrime,error) - else - this%n_xPrime = n_xPrime - endif - - this%delta = delta - this%f0 = f0 - - this%current_x = 0 - this%current_xPrime = 0 - this%n_sparseX = 0 - this%n_permutations = 1 - - this%covariance_type = optional_default(COVARIANCE_ARD_SE, covariance_type) - - if(present(x_size_max)) then - allocate( this%x(x_size_max,n_x) ) - else - allocate( this%x(d,n_x) ) - endif - this%x = 0.0_dp - - if(present(xPrime_size_max)) then - allocate( this%xPrime(xPrime_size_max,n_xPrime) ) - else - allocate( this%xPrime(d,n_xPrime) ) - endif - this%xPrime = 0.0_dp - - allocate(this%cutoff(n_x)) - this%cutoff = 1.0_dp - allocate(this%cutoffPrime(n_xPrime)) - this%cutoffPrime = 0.0_dp - - allocate( this%config_type(n_x) ) - this%config_type = 0 - - allocate( this%map_x_y(n_x), this%map_xPrime_yPrime(n_xPrime), this%map_xPrime_x(n_xPrime) ) - this%map_x_y = 0 - this%map_xPrime_yPrime = 0 - this%map_xPrime_x = 0 - - allocate(this%covarianceDiag_x_x(n_x), this%covarianceDiag_xPrime_xPrime(n_xPrime)) - this%covarianceDiag_x_x = 1.0_dp - this%covarianceDiag_xPrime_xPrime = 1.0_dp - - select case(this%covariance_type) - case(COVARIANCE_BOND_REAL_SPACE) - allocate( this%x_size(n_x), this%xPrime_size(n_xPrime) ) - this%x_size = d - this%xPrime_size = 0 - allocate( this%theta(1), this%permutations(1,1) ) - this%theta = 0.0_dp - this%permutations = 1 - case(COVARIANCE_DOT_PRODUCT) - allocate( this%theta(1), this%permutations(1,1) ) - this%theta = 0.0_dp - this%permutations = 1 - case(COVARIANCE_ARD_SE,COVARIANCE_PP) - allocate( this%theta(d), this%permutations(d,1) ) - this%theta = 0.0_dp - this%permutations(:,1) = (/ (i, i=1, d) /) - - allocate(this%permutation_distance_mask(this%d,this%d)) - this%permutation_distance_mask = .false. - forall(i=1:this%d) this%permutation_distance_mask(i,i) = .true. - endselect - - this%sparsified = .false. - this%initialised = .true. - endsubroutine gpCoordinates_setParameters - - subroutine gpCoordinates_setParameters_sparse(this, d, n_sparseX, delta, f0, covariance_type, sparseX_size_max, error) - - type(gpCoordinates), intent(inout) :: this - integer, intent(in) :: d, n_sparseX - real(dp), intent(in) :: delta, f0 - integer, optional, intent(in) :: covariance_type - integer, optional, intent(in) :: sparseX_size_max - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(this%initialised) call finalise(this,error) - - this%d = d - this%n_x = 0 - this%n_xPrime = 0 - this%delta = delta - this%f0 = f0 - - this%current_x = 0 - this%current_xPrime = 0 - this%n_sparseX = n_sparseX - this%n_permutations = 1 - - this%covariance_type = optional_default(COVARIANCE_ARD_SE, covariance_type) - - if(present(sparseX_size_max)) then - allocate( this%sparseX(sparseX_size_max,n_sparseX) ) - else - allocate( this%sparseX(d,n_sparseX) ) - endif - - allocate( this%alpha(n_sparseX) ) - allocate( this%sparseCutoff(n_sparseX) ) - - allocate( this%covarianceDiag_sparseX_sparseX(n_sparseX) ) - this%covarianceDiag_sparseX_sparseX = 1.0_dp - - select case(this%covariance_type) - case(COVARIANCE_BOND_REAL_SPACE) - allocate( this%sparseX_size(n_sparseX) ) - this%sparseX_size = d - allocate( this%theta(1), this%permutations(1,1) ) - this%theta = 0.0_dp - this%permutations = 1 - case(COVARIANCE_DOT_PRODUCT) - allocate( this%theta(1), this%permutations(1,1) ) - this%theta = 0.0_dp - this%permutations = 1 - case(COVARIANCE_ARD_SE,COVARIANCE_PP) - allocate( this%theta(d), this%permutations(d,1) ) - this%theta = 0.0_dp - this%permutations(:,1) = (/ (i, i=1, d) /) - allocate(this%permutation_distance_mask(this%d,this%d)) - this%permutation_distance_mask = .false. - forall(i=1:this%d) this%permutation_distance_mask(i,i) = .true. - endselect - - this%sparsified = .true. - this%initialised = .true. - - endsubroutine gpCoordinates_setParameters_sparse - - subroutine gpSparse_setParameters(this,n_coordinate,error) - type(gpSparse), intent(inout) :: this - integer, intent(in) :: n_coordinate - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(this%initialised) call finalise(this,error) - this%n_coordinate = n_coordinate - allocate( this%coordinate(this%n_coordinate) ) - - endsubroutine gpSparse_setParameters - - subroutine gpCoordinates_setPermutations(this,permutations,error) - type(gpCoordinates), intent(inout) :: this - integer, dimension(:,:), intent(in) :: permutations - integer, optional, intent(out) :: error - - real(dp), dimension(this%d) :: theta - integer :: i, d - - INIT_ERROR(error) - - this%n_permutations = size(permutations,2) - - select case(this%covariance_type) - case(COVARIANCE_ARD_SE,COVARIANCE_PP) - call reallocate(this%permutations,this%d,this%n_permutations,zero=.true.) - this%permutations = permutations - ! Symmetrise theta wrt permutations - theta = this%theta - this%theta = 0.0_dp - do i = 1, this%n_permutations - this%theta = this%theta + theta(this%permutations(:,i)) - enddo - this%theta = this%theta / real(this%n_permutations,kind=dp) - - this%permutation_distance_mask = .false. - do i = 1, this%n_permutations - do d = 1, this%d - this%permutation_distance_mask(d,this%permutations(d,i)) = .true. - enddo - enddo - case default - - endselect - - - endsubroutine gpCoordinates_setPermutations - - subroutine gpFull_setPermutations(this,i_coordinate,permutations,error) - type(gpFull), intent(inout) :: this - integer :: i_coordinate - integer, dimension(:,:), intent(in) :: permutations - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( i_coordinate > this%n_coordinate ) then - RAISE_ERROR( 'gpFull_setPermutations: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate,error ) - endif - - call gpCoordinates_setPermutations(this%coordinate(i_coordinate),permutations,error) - - endsubroutine gpFull_setPermutations - - subroutine gpSparse_setPermutations(this,i_coordinate,permutations,error) - type(gpSparse), intent(inout) :: this - integer :: i_coordinate - integer, dimension(:,:), intent(in) :: permutations - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( i_coordinate > this%n_coordinate ) then - RAISE_ERROR( 'gpSparse_setPermutations: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate,error ) - endif - - call gpCoordinates_setPermutations(this%coordinate(i_coordinate),permutations,error) - - endsubroutine gpSparse_setPermutations - - subroutine gpSparse_initialise(this, from, error) - type(gpSparse), intent(inout) :: this - type(gpFull), intent(in) :: from - integer, optional, intent(out) :: error - - integer :: i - - if( .not. from%initialised ) then - RAISE_ERROR('gpSparse_initialise: gpFull object not initialised',error) - endif - - if(this%initialised) call finalise(this,error) - - call gpSparse_setParameters(this, from%n_coordinate) - - do i = 1, this%n_coordinate - if( from%coordinate(i)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call gpCoordinates_setParameters_sparse(this%coordinate(i), & - from%coordinate(i)%d, from%coordinate(i)%n_sparseX, from%coordinate(i)%delta, from%coordinate(i)%f0, covariance_type = from%coordinate(i)%covariance_type, & - sparseX_size_max=maxval(from%coordinate(i)%sparseX_size), error=error) - else - call gpCoordinates_setParameters_sparse(this%coordinate(i), & - from%coordinate(i)%d, from%coordinate(i)%n_sparseX, from%coordinate(i)%delta, from%coordinate(i)%f0, covariance_type = from%coordinate(i)%covariance_type, & - error=error) - endif - - this%coordinate(i)%alpha = 0.0 - this%coordinate(i)%sparseX = from%coordinate(i)%sparseX - this%coordinate(i)%covarianceDiag_sparseX_sparseX = from%coordinate(i)%covarianceDiag_sparseX_sparseX - - if(from%coordinate(i)%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - this%coordinate(i)%sparseX_size = from%coordinate(i)%sparseX_size - endif - - this%coordinate(i)%theta = from%coordinate(i)%theta - this%coordinate(i)%zeta = from%coordinate(i)%zeta - this%coordinate(i)%descriptor_str = from%coordinate(i)%descriptor_str - this%coordinate(i)%sparseCutoff = from%coordinate(i)%sparseCutoff - - call gpSparse_setPermutations(this,i,from%coordinate(i)%permutations,error) - enddo - - this%initialised = .true. - end subroutine gpSparse_initialise - - subroutine gpSparse_fit(this, from, task_manager, condition_number_norm, error) - type(gpSparse), intent(inout) :: this - type(gpFull), intent(inout) :: from ! actually input; intent(inout) to free memory early - type(task_manager_type), intent(in) :: task_manager - character(len=*), optional, intent(in) :: condition_number_norm - integer, optional, intent(out) :: error - - character(len=STRING_LENGTH) :: my_condition_number_norm - - integer :: i, j, mb_A, nb_A - integer :: i_coordinate, i_sparseX, i_global_sparseX, n_globalSparseX, n_globalY, i_y, i_yPrime, & - i_globalY, i_global_yPrime, nrows -#ifdef HAVE_QR - real(qp) :: rcond - real(qp), dimension(:,:), allocatable :: c_subYY_sqrtInverseLambda, factor_c_subYsubY, a - real(qp), dimension(:), allocatable :: globalY, alpha - type(LA_Matrix) :: LA_c_subYsubY, LA_q_subYsubY -#else - real(qp), dimension(:,:), allocatable :: c_subYY_inverseLambda, c_subYY_inverseLambda_c_YsubY!, & -! inverse_q_subYsubY, inverse_c_subYsubY - real(qp), dimension(:), allocatable :: globalY, alpha - type(LA_Matrix) :: LA_q_subYsubY -#endif - - INIT_ERROR(error) - - my_condition_number_norm = optional_default(' ', condition_number_norm) - - call gpSparse_initialise(this, from, error) - - n_globalSparseX = from%n_globalSparseX - n_globalY = from%n_y + from%n_yPrime - -#ifdef HAVE_QR - call system_timer('Build linear system') - - allocate(c_subYY_sqrtInverseLambda(n_globalSparseX,n_globalY)) - call matrix_product_vect_asdiagonal_sub(c_subYY_sqrtInverseLambda,from%covariance_subY_y,sqrt(1.0_qp/from%lambda)) ! O(NM) - if (allocated(from%covariance_subY_y)) deallocate(from%covariance_subY_y) ! free input component to save memory - - if (from%do_subY_subY) then - allocate(factor_c_subYsubY(n_globalSparseX,n_globalSparseX)) - call initialise(LA_c_subYsubY,from%covariance_subY_subY,use_allocate=.false.) - call LA_Matrix_Factorise(LA_c_subYsubY,factor_c_subYsubY,error=error) - call finalise(LA_c_subYsubY) - if (allocated(from%covariance_subY_subY)) deallocate(from%covariance_subY_subY) ! free input component to save memory - - do i = 1, n_globalSparseX-1 - do j = i+1, n_globalSparseX - factor_c_subYsubY(j,i) = 0.0_qp - end do - end do - end if - - allocate(alpha(n_globalSparseX)) - if (task_manager%active) then - nrows = task_manager%idata(1) - mb_A = task_manager%idata(2) - nb_A = task_manager%idata(3) - allocate(globalY(nrows)) - allocate(a(nrows,n_globalSparseX)) - alpha = 0.0_qp - globalY = 0.0_qp - a = 0.0_qp - else - allocate(globalY(n_globalY+n_globalSparseX)) - allocate(a(n_globalY+n_globalSparseX,n_globalSparseX)) - end if - - a(1:n_globalY,:) = transpose(c_subYY_sqrtInverseLambda) - if (allocated(c_subYY_sqrtInverseLambda)) deallocate(c_subYY_sqrtInverseLambda) - - if (task_manager%active) then - if (.not. allocated(factor_c_subYsubY)) then - ! tks: make sure we are not passing in an unallocated array as the input to - ! mpi_scatterv on the processes which are receiving data. This was found to - ! be an issue on GCC 11 with -O2 and above. - allocate(factor_c_subYsubY(0, 0)) - end if - call scatter_shared_task(task_manager, factor_c_subYsubY, a, n_globalY, n_globalSparseX, from%do_subY_subY) - else - a(n_globalY+1:,:) = factor_c_subYsubY - end if - if (allocated(factor_c_subYsubY)) deallocate(factor_c_subYsubY) - - if (my_condition_number_norm(1:1) /= ' ') then - if (task_manager%active) then - call print_warning("Condition number of distributed matrix is not implemented.") - else - rcond = matrix_condition_number(a, my_condition_number_norm(1:1)) - call print("Condition number (log10) of matrix A (norm "//my_condition_number_norm(1:1)//"): "//-log10(rcond)) - end if - end if - - globalY = 0.0_qp - do i_y = 1, from%n_y - ! loop over all function values - - i_globalY = from%map_y_globalY(i_y) - ! find unique function value/derivative identifier - - globalY(i_globalY) = from%y(i_y)*sqrt(1.0_qp/from%lambda(i_globalY)) - enddo - - do i_yPrime = 1, from%n_yPrime - ! loop over all function values - - i_global_yPrime = from%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - globalY(i_global_yPrime) = from%yPrime(i_yPrime)*sqrt(1.0_qp/from%lambda(i_global_yPrime)) - enddo - call system_timer('Build linear system') - - call system_timer('Solve linear system') - if (task_manager%active) then - call print("Using ScaLAPACK to solve QR") - call SP_Matrix_QR_Solve(a, globalY, alpha, task_manager%ScaLAPACK_obj, mb_A, nb_A, this%R, this%do_export_R) - else - call print("Using LAPACK to solve QR") - call initialise(LA_q_subYsubY, a, use_allocate=.false.) - call LA_Matrix_QR_Solve_Vector(LA_q_subYsubY, globalY, alpha) - call finalise(LA_q_subYsubY) - end if - call system_timer('Solve linear system') - - do i_coordinate = 1, from%n_coordinate - do i_sparseX = 1, from%coordinate(i_coordinate)%n_sparseX - i_global_sparseX = from%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) - this%coordinate(i_coordinate)%alpha(i_sparseX) = real(alpha(i_global_sparseX),kind=dp) - enddo - enddo - - if(allocated(a)) deallocate(a) - if(allocated(globalY)) deallocate(globalY) - if(allocated(alpha)) deallocate(alpha) -#else - allocate( c_subYY_inverseLambda(n_globalSparseX,n_globalY), c_subYY_inverseLambda_c_YsubY(n_globalSparseX,n_globalSparseX), & -! inverse_q_subYsubY(n_globalSparseX,n_globalSparseX), inverse_c_subYsubY(n_globalSparseX,n_globalSparseX), & - alpha(n_globalSparseX), globalY(n_globalY)) - - call matrix_product_vect_asdiagonal_sub(c_subYY_inverseLambda,from%covariance_subY_Y,1.0_qp/from%lambda) ! O(NM) - - c_subYY_inverseLambda_c_YsubY = matmul(c_subYY_inverseLambda,transpose(from%covariance_subY_Y)) - call initialise(LA_q_subYsubY,from%covariance_subY_subY + c_subYY_inverseLambda_c_YsubY) - - globalY = 0.0_qp - do i_y = 1, from%n_y - ! loop over all function values - - i_globalY = from%map_y_globalY(i_y) - ! find unique function value/derivative identifier - - globalY(i_globalY) = from%y(i_y) !*sqrt(1.0_qp/from%lambda(i_globalY)) - enddo - - do i_yPrime = 1, from%n_yPrime - ! loop over all function values - - i_global_yPrime = from%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - globalY(i_global_yPrime) = from%yPrime(i_yPrime) !*sqrt(1.0_qp/from%lambda(i_global_yPrime)) - enddo - - call Matrix_Solve(LA_q_subYsubY,matmul(c_subYY_inverseLambda, globalY),alpha) - call finalise(LA_q_subYsubY) - - do i_coordinate = 1, from%n_coordinate - do i_sparseX = 1, from%coordinate(i_coordinate)%n_sparseX - i_global_sparseX = from%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) - this%coordinate(i_coordinate)%alpha(i_sparseX) = real(alpha(i_global_sparseX),kind=dp) - enddo - enddo - - if(allocated(c_subYY_inverseLambda)) deallocate(c_subYY_inverseLambda) - if(allocated(c_subYY_inverseLambda_c_YsubY)) deallocate(c_subYY_inverseLambda_c_YsubY) -! if(allocated(inverse_q_subYsubY)) deallocate(inverse_q_subYsubY) -! if(allocated(inverse_c_subYsubY)) deallocate(inverse_c_subYsubY) - if(allocated(alpha)) deallocate(alpha) - if(allocated(globalY)) deallocate(globalY) -#endif - this%fitted = .true. - - endsubroutine gpSparse_fit - - ! put L part at the end of local A (take info from last task of each worker) - subroutine scatter_shared_task(task_manager, factor_c_subYsubY, a, n_globalY, n_globalSparseX, do_subY_subY) - type(task_manager_type), intent(in) :: task_manager - real(qp), intent(inout) :: factor_c_subYsubY(:,:) - real(qp), intent(inout) :: a(:,:) - integer, intent(in) :: n_globalY - integer, intent(in) :: n_globalSparseX - logical, intent(in) :: do_subY_subY - - integer :: n, t, w - integer, allocatable :: counts(:) - real(dp), allocatable :: tmp(:,:) - - ! scattering works with cols, so transposing input and output - if (do_subY_subY) then - factor_c_subYsubY = transpose(factor_c_subYsubY) - call get_shared_task_counts(task_manager, n_globalSparseX, counts) - else - allocate(counts(1), source=0) - end if - - w = task_manager%my_worker_id - t = task_manager%workers(w)%n_tasks - n = task_manager%workers(w)%tasks(t)%idata(1) - allocate(tmp(n_globalSparseX,n)) - tmp = 0.0_dp - - call scatterv(task_manager%MPI_obj, factor_c_subYsubY, tmp, counts) - a(n_globalY+1:n_globalY+n,:) = transpose(tmp) - end subroutine scatter_shared_task - - subroutine get_shared_task_counts(task_manager, ncols, counts) - type(task_manager_type), intent(in) :: task_manager - integer, intent(in) :: ncols - integer, intent(out), allocatable :: counts(:) - - integer :: n, o, t, w - - allocate(counts(task_manager%n_workers)) - counts = 0 - o = 0 - do w = 1, task_manager%n_workers - t = task_manager%workers(w)%n_tasks - n = task_manager%workers(w)%tasks(t)%idata(1) - counts(w) = n * ncols - o = o + n - if (o > ncols) then - counts(w) = (n - (o - ncols)) * ncols - call print_warning("get_shared_task_counts: Not enough data. & - &Were sparse points reduced since task distribution?") - exit - end if - end do - end subroutine get_shared_task_counts - - subroutine gpSparse_finalise(this,error) - type(gpSparse), intent(inout) :: this - integer, optional, intent(out) :: error - - integer :: i_coordinate - - INIT_ERROR(error) - - if (allocated(this%coordinate)) then - do i_coordinate = 1, this%n_coordinate - call finalise(this%coordinate(i_coordinate), error) - enddo - deallocate(this%coordinate) - end if - - this%n_coordinate = 0 - this%initialised = .false. - this%fitted = .false. - - endsubroutine gpSparse_finalise - - subroutine gpFull_Finalise(this, error) - type(gpFull), intent(inout) :: this - integer, optional, intent(out) :: error - - integer :: i - - INIT_ERROR(error) - - if(.not. this%initialised) return - - if(allocated(this%coordinate)) then - do i = 1, this%n_coordinate - call finalise(this%coordinate(i)) - enddo - deallocate( this%coordinate ) - endif - - if(allocated(this%y)) deallocate( this%y ) - if(allocated(this%yPrime)) deallocate( this%yPrime ) - if(allocated(this%sigma_y)) deallocate( this%sigma_y ) - if(allocated(this%sigma_yPrime)) deallocate( this%sigma_yPrime ) - if(allocated(this%map_y_globalY)) deallocate( this%map_y_globalY ) - if(allocated(this%map_yPrime_globalY)) deallocate( this%map_yPrime_globalY ) - if(allocated(this%covariance_subY_y)) deallocate( this%covariance_subY_y ) - if(allocated(this%covariance_subY_subY)) deallocate( this%covariance_subY_subY ) - if(allocated(this%covarianceDiag_y_y)) deallocate( this%covarianceDiag_y_y ) - if(allocated(this%lambda)) deallocate( this%lambda ) - if(allocated(this%alpha)) deallocate( this%alpha ) - - this%n_coordinate = 0 - this%n_y = 0 - this%n_yPrime = 0 - this%current_y = 0 - this%current_yPrime = 0 - - this%initialised = .false. - - endsubroutine gpFull_Finalise - - subroutine gpCoordinates_Finalise(this, error) - type(gpCoordinates), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - - if(allocated(this%x)) deallocate( this%x ) - if(allocated(this%xPrime)) deallocate( this%xPrime ) - if(allocated(this%cutoff)) deallocate( this%cutoff ) - if(allocated(this%cutoffPrime)) deallocate( this%cutoffPrime ) - if(allocated(this%theta)) deallocate( this%theta ) - - if(allocated(this%permutations)) deallocate(this%permutations) - if(allocated(this%permutation_distance_mask)) deallocate( this%permutation_distance_mask ) - - if(allocated(this%map_x_y)) deallocate( this%map_x_y ) - if(allocated(this%map_xPrime_yPrime)) deallocate( this%map_xPrime_yPrime ) - if(allocated(this%map_xPrime_x)) deallocate( this%map_xPrime_x ) - if(allocated(this%map_sparseX_globalSparseX)) deallocate( this%map_sparseX_globalSparseX ) - if(allocated(this%config_type)) deallocate( this%config_type ) - - if(allocated(this%sparseX_index)) deallocate(this%sparseX_index) - if(allocated(this%sparseX)) deallocate(this%sparseX) - if(allocated(this%alpha)) deallocate(this%alpha) - if(allocated(this%sparseCutoff)) deallocate(this%sparseCutoff) - - if(allocated(this%x_size)) deallocate( this%x_size ) - if(allocated(this%xPrime_size)) deallocate( this%xPrime_size ) - if(allocated(this%covarianceDiag_x_x)) deallocate( this%covarianceDiag_x_x ) - if(allocated(this%covarianceDiag_x_xPrime)) deallocate( this%covarianceDiag_x_xPrime ) - if(allocated(this%covarianceDiag_xPrime_xPrime)) deallocate( this%covarianceDiag_xPrime_xPrime ) - - if(allocated(this%sparseX_size)) deallocate( this%sparseX_size ) - if(allocated(this%covarianceDiag_sparseX_sparseX)) deallocate( this%covarianceDiag_sparseX_sparseX ) - - - call finalise(this%descriptor_str) - call gpCoordinates_finalise_variance_estimate(this) - - if(allocated(this%sparseX_permuted)) deallocate( this%sparseX_permuted ) - if(allocated(this%sparseCovariance)) deallocate( this%sparseCovariance ) - - - this%sparse_covariance_initialised = .false. - - this%d = 0 - this%n_x = 0 - this%n_xPrime = 0 - this%delta = 0.0_dp - this%f0 = 0.0_dp - - this%current_x = 0 - this%current_xPrime = 0 - - this%n_sparseX = 0 - this%n_permutations = 0 - - this%sparsified = .false. - this%initialised = .false. - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call gpCovariance_bond_real_space_Finalise(this%bond_real_space_cov) - - this%covariance_type = COVARIANCE_NONE - - endsubroutine gpCoordinates_Finalise - - subroutine gpCovariance_bond_real_space_Finalise(this, error) - type(gpCovariance_bond_real_space), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - this%n = 0 - this%delta = 0.0_dp - this%atom_sigma = 0.0_dp - - this%initialised = .false. - - endsubroutine gpCovariance_bond_real_space_Finalise - - subroutine gpCovariance_atom_real_space_Finalise(this, error) - type(gpCovariance_atom_real_space), intent(inout) :: this - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - this%l_max = 0 - this%delta = 0.0_dp - - this%initialised = .false. - - endsubroutine gpCovariance_atom_real_space_Finalise - - function gpFull_addFunctionValue(this,y,sigma_y, error) - - type(gpFull), intent(inout) :: this - real(dp), intent(in) :: y, sigma_y ! Function value - integer :: gpFull_addFunctionValue ! Which function value we added - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_addFunctionValue: object not initialised',error) - endif - - if( this%current_y == this%n_y ) then - RAISE_ERROR( 'gpFull_addFunctionValue: object full, no more function values can be added',error) - endif - - this%current_y = this%current_y + 1 - this%y(this%current_y) = y - this%sigma_y(this%current_y) = sigma_y - - gpFull_addFunctionValue = this%current_y - - endfunction gpFull_addFunctionValue - - function gpFull_addFunctionDerivative(this, yPrime, sigma_yPrime, error) - type(gpFull), intent(inout) :: this - real(dp), intent(in) :: yPrime, sigma_yPrime ! Function value - integer :: gpFull_addFunctionDerivative ! Which function value we added - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_addFunctionDerivative: object not initialised',error) - endif - - if( this%current_yPrime == this%n_yPrime ) then - RAISE_ERROR( 'gpFull_addFunctionDerivative: object full, no more function values can be added',error) - endif - - this%current_yPrime = this%current_yPrime + 1 - this%yPrime(this%current_yPrime) = yPrime - this%sigma_yPrime(this%current_yPrime) = sigma_yPrime - - gpFull_addFunctionDerivative = this%current_yPrime - - endfunction gpFull_addFunctionDerivative - - function gpFull_addCoordinates_2Darray(this,x,i_coordinate,cutoff_in, current_y, config_type, error) result(xLocation) - type(gpFull), intent(inout) :: this - real(dp), dimension(:,:), intent(in) :: x - integer, intent(in) :: i_coordinate - integer, optional, intent(in) :: current_y, config_type - real(dp), dimension(:), intent(in), optional :: cutoff_in - integer, optional, intent(out) :: error - - integer, dimension(:), pointer :: xLocation - - integer :: previous_x, i - real(dp), dimension(:,:), allocatable :: new_x - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_addCoordinates: object not initialised',error) - endif - - if( i_coordinate > this%n_coordinate ) then - RAISE_ERROR( 'gpFull_addCoordinates: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate ,error) - endif - - if( .not. this%coordinate(i_coordinate)%initialised ) then - RAISE_ERROR('gpFull_addCoordinates: '//i_coordinate//'th coordinate object is not initialised',error) - endif - - if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - if( size(x,1) > size(this%coordinate(i_coordinate)%x,1) ) then - allocate( new_x(size(x,1),this%coordinate(i_coordinate)%n_x) ) - new_x = 0.0_dp - new_x(1:size(this%coordinate(i_coordinate)%x,1),:) = this%coordinate(i_coordinate)%x - deallocate( this%coordinate(i_coordinate)%x ) - allocate( this%coordinate(i_coordinate)%x(size(x,1),this%coordinate(i_coordinate)%n_x) ) - this%coordinate(i_coordinate)%x = new_x - deallocate( new_x ) - this%coordinate(i_coordinate)%d = size(x,1) - end if - else -! if( size(x,1) /= this%coordinate(i_coordinate)%d ) then -! RAISE_ERROR('gpFull_addCoordinates: dimensionality of descriptors '//size(x,1)//' does not match what is given in the object '//this%coordinate(i_coordinate)%d,error) -! endif - endif - - previous_x = this%coordinate(i_coordinate)%current_x - this%coordinate(i_coordinate)%current_x = previous_x + size(x,2) - - if( this%coordinate(i_coordinate)%current_x > this%coordinate(i_coordinate)%n_x ) then - RAISE_ERROR('gpFull_addCoordinates: object full, no more descriptors can be added',error) - endif - - if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - this%coordinate(i_coordinate)%x(1:size(x,1),previous_x+1:this%coordinate(i_coordinate)%current_x) = x - this%coordinate(i_coordinate)%x_size(previous_x+1:this%coordinate(i_coordinate)%current_x) = size(x,1) - else - this%coordinate(i_coordinate)%x(:,previous_x+1:this%coordinate(i_coordinate)%current_x) = x - endif - - if(present(cutoff_in)) then - this%coordinate(i_coordinate)%cutoff(previous_x+1:this%coordinate(i_coordinate)%current_x) = cutoff_in - endif - - if(present(current_y)) & - this%coordinate(i_coordinate)%map_x_y(previous_x+1:this%coordinate(i_coordinate)%current_x) = current_y - - if(present(config_type)) & - this%coordinate(i_coordinate)%config_type(previous_x+1:this%coordinate(i_coordinate)%current_x) = config_type - - allocate(xLocation(size(x,2))) - xLocation = (/ ( i, i = previous_x+1, this%coordinate(i_coordinate)%current_x ) /) - - endfunction gpFull_addCoordinates_2Darray - - function gpFull_addCoordinates_1Darray(this,x,i_coordinate,cutoff_in,current_y,config_type, error) result(xLocation) - type(gpFull), intent(inout) :: this - real(dp), dimension(:), intent(in) :: x - integer, intent(in) :: i_coordinate - real(dp), optional, intent(in) :: cutoff_in - integer, optional, intent(in) :: current_y, config_type - integer, optional, intent(out) :: error - - integer :: xLocation - - integer, dimension(:), pointer :: xLocation_in - - INIT_ERROR(error) - - xLocation_in => gpFull_addCoordinates_2Darray(this,reshape(x,(/size(x),1/)),i_coordinate,(/cutoff_in/),current_y,config_type,error) - - xLocation = xLocation_in(1) - deallocate(xLocation_in) - - endfunction gpFull_addCoordinates_1Darray - - subroutine gpFull_addCoordinateDerivatives_2Darray(this,xPrime,i_coordinate,current_yPrime, xLocation, dcutoff_in, error) - type(gpFull), intent(inout) :: this - real(dp), dimension(:,:), intent(in) :: xPrime - integer, intent(in) :: i_coordinate, current_yPrime - integer, dimension(:), intent(in) :: xLocation - real(dp), dimension(:), optional, intent(in) :: dcutoff_in - integer, optional, intent(out) :: error - - integer :: previous_xPrime - real(dp), dimension(:,:), allocatable :: new_xPrime - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_addCoordinateDerivatives: object not initialised',error) - endif - - if( i_coordinate > this%n_coordinate ) then - RAISE_ERROR( 'gpFull_addCoordinateDerivatives: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate,error ) - endif - - if( .not. this%coordinate(i_coordinate)%initialised ) then - RAISE_ERROR('gpFull_addCoordinateDerivatives: '//i_coordinate//'th coordinate object is not initialised',error) - endif - - if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - if( size(xPrime,1) > size(this%coordinate(i_coordinate)%xPrime,1) ) then - allocate( new_xPrime(size(xPrime,1),this%coordinate(i_coordinate)%n_xPrime) ) - new_xPrime = 0.0_dp - new_xPrime(1:size(this%coordinate(i_coordinate)%xPrime,1),:) = this%coordinate(i_coordinate)%xPrime - deallocate( this%coordinate(i_coordinate)%xPrime ) - allocate( this%coordinate(i_coordinate)%xPrime(size(xPrime,1),this%coordinate(i_coordinate)%n_xPrime) ) - this%coordinate(i_coordinate)%xPrime = new_xPrime - deallocate( new_xPrime ) - end if - else - if( size(xPrime,1) /= this%coordinate(i_coordinate)%d ) then - RAISE_ERROR('gpFull_addCoordinateDerivatives: dimensionality of descriptors '//size(xPrime,1)//' does not match what is given in the object '//this%coordinate(i_coordinate)%d,error) - endif - endif - - if( size(xPrime,2) /= size(xLocation) ) then - RAISE_ERROR('gpFull_addCoordinateDerivatives: number of descriptors '//size(xPrime,2)//' has to match the dimensionality of the mapping array '//size(xLocation),error) - endif - - previous_xPrime = this%coordinate(i_coordinate)%current_xPrime - this%coordinate(i_coordinate)%current_xPrime = previous_xPrime + size(xPrime,2) - - if( this%coordinate(i_coordinate)%current_xPrime > this%coordinate(i_coordinate)%n_xPrime ) then - RAISE_ERROR('gpFull_addCoordinateDerivatives: object full, no more descriptors can be added',error) - endif - - if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - this%coordinate(i_coordinate)%xPrime(1:size(xPrime,1),previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = xPrime - this%coordinate(i_coordinate)%xPrime_size(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = size(xPrime,1) - else - this%coordinate(i_coordinate)%xPrime(:,previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = xPrime - endif - - if(present(dcutoff_in)) then - this%coordinate(i_coordinate)%cutoffPrime(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = dcutoff_in - endif - - this%coordinate(i_coordinate)%map_xPrime_yPrime(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = current_yPrime - this%coordinate(i_coordinate)%map_xPrime_x(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = xLocation - - endsubroutine gpFull_addCoordinateDerivatives_2Darray - - subroutine gpFull_addCoordinateDerivatives_1Darray(this,xPrime,i_coordinate,current_yPrime, xLocation, dcutoff_in, error) - type(gpFull), intent(inout) :: this - real(dp), dimension(:), intent(in) :: xPrime - integer, intent(in) :: i_coordinate, current_yPrime - integer, intent(in) :: xLocation - real(dp), optional, intent(in) :: dcutoff_in - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - call gpFull_addCoordinateDerivatives_2Darray(this, reshape(xPrime,(/size(xPrime),1/)),i_coordinate,current_yPrime,(/xLocation/),(/dcutoff_in/),error) - - endsubroutine gpFull_addCoordinateDerivatives_1Darray - - subroutine gpFull_addDescriptor(this,i_coordinate,descriptor_str,error) - - type(gpFull), intent(inout) :: this - integer, intent(in) :: i_coordinate - character(len=*), intent(in) :: descriptor_str - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_addDescriptor: object not initialised',error) - endif - - call gpCoordinates_addDescriptor(this%coordinate(i_coordinate),descriptor_str,error) - - endsubroutine gpFull_addDescriptor - - subroutine gpCoordinates_addDescriptor(this,descriptor_str,error) - - type(gpCoordinates), intent(inout) :: this - character(len=*), intent(in) :: descriptor_str - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_addDescriptor: object not initialised',error) - endif - - call initialise(this%descriptor_str) - call zero(this%descriptor_str) - - call concat(this%descriptor_str,descriptor_str,keep_lf=.false.,lf_to_whitespace=.true.) - - endsubroutine gpCoordinates_addDescriptor - - subroutine gpCoordinates_setTheta(this, theta, zeta, error) - type(gpCoordinates), intent(inout), target :: this - real(dp), dimension(:), intent(in), optional :: theta - real(dp), intent(in), optional :: zeta - integer, optional, intent(out) :: error - - integer :: i - real(dp) :: delta - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_setTheta: object not initialised',error) - endif - - allocate(this%covarianceDiag_x_xPrime(size(this%x,1),this%n_x)) - this%covarianceDiag_x_xPrime = 0.0_dp - - select case(this%covariance_type) - case(COVARIANCE_BOND_REAL_SPACE) - RAISE_ERROR('gpCoordinates_setTheta: this call is not appropriate. Needs to be fixed!!!', error) - !if(.not. this%bond_real_space_cov%initialised) then - ! call gpCoordinates_gpCovariance_bond_real_space_Initialise(this) - !endif - - !delta = this%bond_real_space_cov%delta - !this%bond_real_space_cov%delta = 1.0_dp - - !do i = 1, this%n_x - ! this%covarianceDiag_x_x(i) = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i = this%x(:,i), x_i_size = this%x_size(i), x_j = this%x(:,i), x_j_size = this%x_size(i)) - !enddo - -! ! do i = 1, this%n_xPrime -! ! enddo - - !this%bond_real_space_cov%delta = delta - - case(COVARIANCE_ARD_SE,COVARIANCE_PP) - call check_size('theta',theta,shape(this%theta),'gpCoordinates_setTheta',error) - if( .not. present(theta) ) then - RAISE_ERROR('gpCoordinates_setTheta: no theta present when using ARD_SE or PP for covariance', error) - endif - this%theta = theta - case(COVARIANCE_DOT_PRODUCT) - if( .not. present(zeta) ) then - RAISE_ERROR('gpCoordinates_setTheta: no zeta present when using DOT_PRODUCT for covariance', error) - endif - this%zeta = zeta - endselect - - endsubroutine gpCoordinates_setTheta - - subroutine gpCoordinates_setThetaFactor(this, thetaFactor,useSparseX,error) - type(gpCoordinates), intent(inout) :: this - real(dp), dimension(:), intent(in) :: thetaFactor - logical, optional, intent(in) :: useSparseX - integer, optional, intent(out) :: error - - integer :: i,p - logical :: my_useSparseX - real(dp), dimension(this%d) :: theta, max_vals, min_vals - - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_calculateThetaFactor: object not initialised',error) - endif - - if( .not. ( (this%covariance_type == COVARIANCE_ARD_SE) .or. (this%covariance_type == COVARIANCE_PP) ) ) then - RAISE_ERROR('gpCoordinates_calculateThetaFactor: only ARD_SE or PP type covariance may use theta_fac',error) - endif - - my_useSparseX = .false. - if( allocated(this%sparseX_index) ) then - if( sum( this%sparseX_index ) > 0 ) my_useSparseX = optional_default(.true.,useSparseX) - endif - - if( my_useSparseX ) then - do i = 1, this%d - max_vals(i) = maxval(this%x(i,this%sparseX_index)) - min_vals(i) = minval(this%x(i,this%sparseX_index)) - enddo - do p=1, this%n_permutations !get max and min value of each dimension including all permutations - do i=1, this%d - max_vals(i) = max(max_vals(i),max_vals(this%permutations(i,p))) - min_vals(i) = min(min_vals(i),min_vals(this%permutations(i,p))) - enddo - enddo - do i = 1, this%d - theta(i) = ( max_vals(i)- min_vals(i) ) * thetaFactor(i) - if( theta(i) < THETA_MIN ) theta(i) = 1.0_dp - enddo - else - do i = 1, this%d - max_vals(i) = maxval(this%x(i,:)) - min_vals(i) = minval(this%x(i,:)) - enddo - do p=1, this%n_permutations !get max and min value of each dimension including all permutations - do i=1, this%d - max_vals(i) = max(max_vals(i),max_vals(this%permutations(i,p))) - min_vals(i) = min(min_vals(i),min_vals(this%permutations(i,p))) - enddo - enddo - do i = 1, this%d - theta(i) = ( max_vals(i)- min_vals(i) ) * thetaFactor(i) - if( theta(i) < THETA_MIN ) theta(i) = 1.0_dp - enddo - endif - - call gpCoordinates_setTheta(this,theta=theta,error=error) - - endsubroutine gpCoordinates_setThetaFactor - - subroutine gpFull_setTheta(this, i_coordinate, theta, zeta, error) - type(gpFull), intent(inout) :: this - integer, intent(in) :: i_coordinate - real(dp), dimension(:), intent(in), optional :: theta - real(dp), intent(in), optional :: zeta - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_setTheta: object not initialised',error) - endif - - call gpCoordinates_setTheta(this%coordinate(i_coordinate), theta=theta, zeta=zeta, error=error) - - endsubroutine gpFull_setTheta - - subroutine gpFull_setTheta_thetaFactor(this, i_coordinate, thetaFactor, useSparseX, error) - type(gpFull), intent(inout) :: this - integer, intent(in) :: i_coordinate - real(dp), dimension(:), intent(in) :: thetaFactor - logical, optional, intent(in) :: useSparseX - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_setTheta_thetaFactor: object not initialised',error) - endif - - call gpCoordinates_setThetaFactor(this%coordinate(i_coordinate), thetaFactor, useSparseX, error) - - endsubroutine gpFull_setTheta_thetaFactor - -! subroutine gpFull_setTheta_thetaFactorArray(this, thetaFactor, useSparseX, error) -! type(gpFull), intent(inout) :: this -! real(dp), dimension(:), intent(in) :: thetaFactor -! logical, optional, intent(out) :: useSparseX -! integer, optional, intent(out) :: error -! -! integer :: i -! -! INIT_ERROR(error) -! -! if( .not. this%initialised ) then -! RAISE_ERROR('gpFull_setTheta_thetaFactorArray: object not initialised',error) -! endif -! -! call check_size('thetaFactor',thetaFactor,(/this%n_coordinate/),'gpFull_setTheta_thetaFactorArray',error) -! -! do i = 1, this%n_coordinate -! call gpCoordinates_setThetaFactor(this%coordinate(i), thetaFactor(i), useSparseX, error) -! enddo -! -! endsubroutine gpFull_setTheta_thetaFactorArray -! -! subroutine gpFull_setTheta_thetaFactorUniform(this, thetaFactor, useSparseX, error) -! type(gpFull), intent(inout) :: this -! real(dp), intent(in) :: thetaFactor -! logical, optional, intent(out) :: useSparseX -! integer, optional, intent(out) :: error -! -! integer :: i -! -! INIT_ERROR(error) -! -! if( .not. this%initialised ) then -! RAISE_ERROR('gpFull_setTheta_thetaFactorUniform: object not initialised',error) -! endif -! -! do i = 1, this%n_coordinate -! call gpCoordinates_setThetaFactor(this%coordinate(i), thetaFactor, useSparseX, error) -! enddo -! -! endsubroutine gpFull_setTheta_thetaFactorUniform - - subroutine gpFull_covarianceMatrix_sparse(this,error) - type(gpFull), intent(inout), target :: this - integer, optional, intent(out) :: error - - integer :: i_coordinate, i_global_sparseX, j_global_sparseX, i_sparseX, j_sparseX, & - n_globalY, i_globalY, i_global_yPrime, i_y, i_yPrime, i_x, j_x, n_x, i_xPrime, j_xPrime, n_xPrime - real(dp) :: covariance_xPrime_sparseX - real(dp), dimension(:,:), allocatable :: grad_Covariance_i - real(dp), dimension(:), allocatable :: covariance_x_sparseX, covariance_subY_currentX_y, covariance_subY_currentX_suby - real(dp) :: start_time, cpu_time, wall_time - - - INIT_ERROR(error) - - call system_timer('gpFull_covarianceMatrix_sparse') - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_covarianceMatrix: object not initialised',error) - endif - - this%n_globalSparseX = 0 - i_global_sparseX = 0 - - do i_coordinate = 1, this%n_coordinate - if( .not. this%coordinate(i_coordinate)%initialised ) then - RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//'th coordinate object not initialised',error) - endif - - if( .not. this%coordinate(i_coordinate)%sparsified ) then - RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//'th coordinate object not sparsified',error) - endif - - if( .not. allocated(this%coordinate(i_coordinate)%x) ) then - RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//"th coordinate's x not allocated",error) - endif - - if( .not. allocated(this%coordinate(i_coordinate)%xPrime) ) then - RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//"th coordinate's xPrime not allocated",error) - endif - - if(this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - if(.not. this%coordinate(i_coordinate)%bond_real_space_cov%initialised) then - call gpCoordinates_gpCovariance_bond_real_space_Initialise(this%coordinate(i_coordinate)) - endif - endif - - this%n_globalSparseX = this%n_globalSparseX + this%coordinate(i_coordinate)%n_sparseX - - do i_sparseX = 1, this%coordinate(i_coordinate)%n_sparseX - i_global_sparseX = i_global_sparseX + 1 - this%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) = i_global_sparseX - enddo - enddo - - n_globalY = this%n_y + this%n_yPrime - - i_globalY = 0 - do i_y = 1, this%n_y - ! loop over all function values - - i_globalY = i_globalY + 1 - this%map_y_globalY(i_y) = i_globalY - enddo - do i_yPrime = 1, this%n_yPrime - ! loop over all derivative values - - i_globalY = i_globalY + 1 - this%map_yPrime_globalY(i_yPrime) = i_globalY - enddo - - if (this%do_subY_subY) then - call reallocate(this%covariance_subY_subY, this%n_globalSparseX, this%n_globalSparseX, zero = .true.) - else - call reallocate(this%covariance_subY_subY, 1, 1, zero = .true.) - end if - - call reallocate(this%covariance_subY_y, this%n_globalSparseX, n_globalY, zero = .true.) - call reallocate(this%covarianceDiag_y_y, n_globalY, zero = .true.) - call reallocate(this%lambda, n_globalY, zero = .true.) - - allocate( covariance_subY_currentX_y(n_globalY),covariance_subY_currentX_suby(this%n_globalSparseX) ) - covariance_subY_currentX_y = 0.0_dp - covariance_subY_currentX_suby = 0.0_dp - - do i_coordinate = 1, this%n_coordinate - ! loop over different descriptor types - call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate) - call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate//'_sparse') - call print('Started sparse covariance matrix calculation of coordinate '//i_coordinate) - call current_times(cpu_time, start_time) - ! - do i_sparseX = 1, this%coordinate(i_coordinate)%n_sparseX - ! loop over sparse points of each descriptor - - i_global_sparseX = this%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) - ! find the unique number of the sparse point (to refer to it outside of the context of descriptor) - - allocate( grad_Covariance_i(this%coordinate(i_coordinate)%d,this%coordinate(i_coordinate)%n_x), & - covariance_x_sparseX(this%coordinate(i_coordinate)%n_x) ) - - covariance_subY_currentX_y = 0.0_dp - covariance_subY_currentX_suby = 0.0_dp - -!$omp parallel do schedule(static,get_chunk_size(this%coordinate(i_coordinate)%n_x)) default(none) & -!$omp shared(this,i_coordinate,covariance_x_sparseX,grad_Covariance_i,i_sparseX) & -!$omp private(i_x,i_y,i_globalY) reduction(+:covariance_subY_currentX_y) - do i_x = 1, this%coordinate(i_coordinate)%n_x - ! loop over all data - - covariance_x_sparseX(i_x) = gpCoordinates_Covariance(this%coordinate(i_coordinate), & - i_x = i_x, j_sparseX = i_sparseX, grad_Covariance_i = grad_Covariance_i(:,i_x)) - - i_y = this%coordinate(i_coordinate)%map_x_y(i_x) - ! find which function value depends on the given descriptor - - if( i_y /= 0 ) then - i_globalY = this%map_y_globalY(i_y) - ! find unique function value/derivative identifier - - !this%covariance_subY_y(i_global_sparseX, i_globalY) = this%covariance_subY_y(i_global_sparseX, i_globalY) + & - covariance_subY_currentX_y(i_globalY) = covariance_subY_currentX_y(i_globalY) + & - covariance_x_sparseX(i_x)*this%coordinate(i_coordinate)%cutoff(i_x)*this%coordinate(i_coordinate)%sparseCutoff(i_sparseX) - endif - enddo - -!$omp parallel do schedule(static,get_chunk_size(this%coordinate(i_coordinate)%n_xPrime)) default(none) & -!$omp shared(this,i_coordinate,i_sparseX,grad_Covariance_i,covariance_x_sparseX) & -!$omp private(i_xPrime,i_yPrime,i_x,i_global_yPrime,covariance_xPrime_sparseX) reduction(+:covariance_subY_currentX_y) - - do i_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime - ! loop over all derivative data - - i_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(i_xPrime) - ! find which derivative depends on the given descriptor - - i_x = this%coordinate(i_coordinate)%map_xPrime_x(i_xPrime) - if( i_yPrime /= 0 ) then - i_global_yPrime = this%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - ! on Xeon w/ ifort 12, sum is fastest . ddot is close. dot_product is terrible - ! on Opteron w/ ifort 12 acml 5.2, ddot is 14.95 s, dot_product is 22.5 s, and sum is 13.9 s - ! dgemv doesn't seem noticeably faster at Opterons (may be faster on Xeon for 'N' transpose setting) - ! covariance_xPrime_sparseX = ddot(size(this%coordinate(i_coordinate)%xPrime,1),grad_Covariance_i(first_nonzero,i_x),1,this%coordinate(i_coordinate)%xPrime(1,i_xPrime),1)*& - ! covariance_xPrime_sparseX = dot_product(grad_Covariance_i(first_nonzero:last_nonzero,i_x),this%coordinate(i_coordinate)%xPrime(:,i_xPrime))* & - covariance_xPrime_sparseX = sum(grad_Covariance_i(:,i_x)*this%coordinate(i_coordinate)%xPrime(:,i_xPrime))* & - this%coordinate(i_coordinate)%cutoff(i_x)*this%coordinate(i_coordinate)%sparseCutoff(i_sparseX) + & - covariance_x_sparseX(i_x)*this%coordinate(i_coordinate)%cutoffPrime(i_xPrime)*this%coordinate(i_coordinate)%sparseCutoff(i_sparseX) - - !this%covariance_subY_y(i_global_sparseX, i_global_yPrime) = this%covariance_subY_y(i_global_sparseX, i_global_yPrime) + covariance_xPrime_sparseX - covariance_subY_currentX_y(i_global_yPrime) = covariance_subY_currentX_y(i_global_yPrime) + covariance_xPrime_sparseX - endif - enddo - - - if(allocated(grad_Covariance_i)) deallocate(grad_Covariance_i) - if(allocated(covariance_x_sparseX)) deallocate(covariance_x_sparseX) - -!$omp parallel do schedule(static,get_chunk_size(this%coordinate(i_coordinate)%n_sparseX)) default(none) & -!$omp shared(this,i_coordinate,covariance_x_sparseX,grad_Covariance_i,i_sparseX,i_global_sparseX) & -!$omp private(j_sparseX,j_global_sparseX) reduction(+:covariance_subY_currentX_suby) - do j_sparseX = 1, this%coordinate(i_coordinate)%n_sparseX - ! loop over sparse points of each descriptor - - j_global_sparseX = this%coordinate(i_coordinate)%map_sparseX_globalSparseX(j_sparseX) - ! find the unique number of the sparse point (to refer to it outside of the context of descriptor) - covariance_subY_currentX_suby(j_global_sparseX) = covariance_subY_currentX_suby(j_global_sparseX) + & - gpCoordinates_Covariance(this%coordinate(i_coordinate), j_sparseX = j_sparseX, i_sparseX = i_sparseX) * this%coordinate(i_coordinate)%sparseCutoff(i_sparseX)*this%coordinate(i_coordinate)%sparseCutoff(j_sparseX) - enddo - - if (this%do_subY_subY) then - this%covariance_subY_subY(i_global_sparseX,i_global_sparseX) = this%covariance_subY_subY(i_global_sparseX,i_global_sparseX) + this%sparse_jitter - this%covariance_subY_subY(:,i_global_sparseX) = this%covariance_subY_subY(:,i_global_sparseX) + covariance_subY_currentX_suby - end if - - this%covariance_subY_y(i_global_sparseX,:) = this%covariance_subY_y(i_global_sparseX,:) + covariance_subY_currentX_y - - call current_times(cpu_time, wall_time) - if(mod(i_sparseX,100) == 0) call progress_timer(this%coordinate(i_coordinate)%n_sparseX, i_sparseX, "Covariance matrix", wall_time-start_time) - enddo - call current_times(cpu_time, wall_time) - call progress_timer(this%coordinate(i_coordinate)%n_sparseX, i_sparseX, "Covariance matrix", wall_time-start_time) - call print('Finished sparse covariance matrix calculation of coordinate '//i_coordinate) - call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate//'_sparse') - - this%covarianceDiag_y_y = 0.0_dp - - if (allocated(this%coordinate(i_coordinate)%x)) deallocate(this%coordinate(i_coordinate)%x) - if (allocated(this%coordinate(i_coordinate)%xPrime)) deallocate(this%coordinate(i_coordinate)%xPrime) - call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate) - enddo - - call system_timer('gpFull_covarianceMatrix_sparse_FunctionValues') - this%lambda = 0.0_dp - - do i_y = 1, this%n_y - ! loop over all function values - - i_globalY = this%map_y_globalY(i_y) - ! find unique function value/derivative identifier - - this%lambda(i_globalY) = this%lambda(i_globalY) + & - this%sigma_y(i_y)**2 - enddo - - do i_yPrime = 1, this%n_yPrime - ! loop over all function values - - i_global_yPrime = this%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - this%lambda(i_global_yPrime) = this%lambda(i_global_yPrime) + & - this%sigma_yPrime(i_yPrime)**2 - enddo - call system_timer('gpFull_covarianceMatrix_sparse_FunctionValues') - - call system_timer('gpFull_covarianceMatrix_sparse') - - endsubroutine gpFull_covarianceMatrix_sparse - - subroutine gpFull_covarianceMatrix(this,error) - type(gpFull), intent(inout) :: this - integer, optional, intent(out) :: error - - integer :: i_coordinate, n_globalY, i_globalY, j_globalY, i_global_yPrime, j_global_yPrime, i_y, j_y, i_yPrime, j_yPrime, i_x, j_x, i_xPrime, j_xPrime - real(dp) :: covariance_x_x - real(dp), dimension(:), allocatable :: globalY - real(dp), dimension(:,:), allocatable :: grad_Covariance_i - logical :: is_i_xPrime - - type(LA_matrix) :: LA_covariance_y_y - - INIT_ERROR(error) - - call system_timer('gpFull_covarianceMatrix') - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_covarianceMatrix: object not initialised',error) - endif - - do i_coordinate = 1, this%n_coordinate - if( .not. this%coordinate(i_coordinate)%initialised ) then - RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//'th coordinate object not initialised',error) - endif - - if(this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - if(.not. this%coordinate(i_coordinate)%bond_real_space_cov%initialised) then - call gpCoordinates_gpCovariance_bond_real_space_Initialise(this%coordinate(i_coordinate)) - endif - endif - enddo - - n_globalY = this%n_y + this%n_yPrime - - i_globalY = 0 - do i_y = 1, this%n_y - ! loop over all function values - - i_globalY = i_globalY + 1 - this%map_y_globalY(i_y) = i_globalY - enddo - do i_yPrime = 1, this%n_yPrime - ! loop over all derivative values - - i_globalY = i_globalY + 1 - this%map_yPrime_globalY(i_yPrime) = i_globalY - enddo - - call reallocate(this%covariance_y_y, n_globalY, n_globalY, zero = .true.) - - do i_coordinate = 1, this%n_coordinate - ! loop over different descriptor types - -!!$omp parallel schedule(dynamic) default(none) private(j_x, j_y, j_globalY, i_x, i_y, i_globalY, covariance_x_x, i_xPrime, i_yPrime, i_global_yPrime, j_global_yPrime, j_xPrime, j_yPrime) shared(this,i_coordinate) -!!$omp do - do j_x = 1, this%coordinate(i_coordinate)%n_x - ! loop over all data - - j_y = this%coordinate(i_coordinate)%map_x_y(j_x) - ! find which function value depends on the given descriptor - if( j_y /= 0 ) then - j_globalY = this%map_y_globalY(j_y) - ! find unique function value/derivative identifier - - allocate( grad_Covariance_i(this%coordinate(i_coordinate)%d,this%coordinate(i_coordinate)%n_x) ) - do i_x = 1, this%coordinate(i_coordinate)%n_x - ! loop over all data - - i_y = this%coordinate(i_coordinate)%map_x_y(i_x) - ! find which function value depends on the given descriptor - - is_i_xPrime = any(this%coordinate(i_coordinate)%map_xPrime_x == i_x) - - if( (i_y /= 0 .and. i_y <= j_y) .or. is_i_xPrime) then - - if(is_i_xPrime) then - covariance_x_x = gpCoordinates_Covariance(this%coordinate(i_coordinate), i_x = i_x, j_x = j_x, grad_Covariance_i=grad_Covariance_i(:,i_x)) - else - covariance_x_x = gpCoordinates_Covariance(this%coordinate(i_coordinate), i_x = i_x, j_x = j_x) - endif - - if( i_y /= 0 ) then - i_globalY = this%map_y_globalY(i_y) - ! find unique function value/derivative identifier - this%covariance_y_y(i_globalY, j_globalY) = this%covariance_y_y(i_globalY, j_globalY) + covariance_x_x - endif - endif - - enddo - - do i_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime - ! loop over all derivative data - - i_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(i_xPrime) - ! find which derivative depends on the given descriptor - - i_x = this%coordinate(i_coordinate)%map_xPrime_x(i_xPrime) - - if( i_yPrime /= 0 ) then - i_global_yPrime = this%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - covariance_x_x = dot_product(grad_Covariance_i(:,i_x),this%coordinate(i_coordinate)%xPrime(:,i_xPrime)) - !gpCoordinates_Covariance(this%coordinate(i_coordinate), i_xPrime = i_xPrime, j_x = j_x) - this%covariance_y_y(i_global_yPrime, j_globalY) = this%covariance_y_y(i_global_yPrime, j_globalY) + covariance_x_x - endif - enddo - endif - if(allocated(grad_Covariance_i)) deallocate(grad_Covariance_i) - - enddo -!!$omp end do - -!!$omp do - do j_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime - ! loop over all derivative data - - j_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(j_xPrime) - ! find which derivative depends on the given descriptor - - if( j_yPrime /= 0 ) then - j_global_yPrime = this%map_yPrime_globalY(j_yPrime) - ! find unique function value/derivative identifier - - do i_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime - ! loop over all derivative data - - i_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(i_xPrime) - ! find which derivative depends on the given descriptor - - if( i_yPrime /= 0 .and. i_yPrime <= j_yPrime) then - i_global_yPrime = this%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - call system_abort('not implemented yet') - !covariance_x_x = gpCoordinates_Covariance(this%coordinate(i_coordinate), i_xPrime = i_xPrime, j_xPrime = j_xPrime) - this%covariance_y_y(i_global_yPrime, j_global_yPrime) = this%covariance_y_y(i_global_yPrime, j_global_yPrime) + covariance_x_x - endif - enddo - endif - enddo -!!$omp end parallel - enddo - - do j_y = 1, size(this%covariance_y_y,2) - do i_y = j_y + 1, size(this%covariance_y_y,1) - this%covariance_y_y(i_y,j_y) = this%covariance_y_y(j_y,i_y) - enddo - enddo - - allocate( globalY(n_globalY) ) - - do i_y = 1, this%n_y - ! loop over all function values - - i_globalY = this%map_y_globalY(i_y) - ! find unique function value/derivative identifier - - this%covariance_y_y(i_globalY,i_globalY) = this%covariance_y_y(i_globalY,i_globalY) + & - this%sigma_y(i_y)**2 - - globalY(i_globalY) = this%y(i_y) - enddo - - do i_yPrime = 1, this%n_yPrime - ! loop over all function values - - i_global_yPrime = this%map_yPrime_globalY(i_yPrime) - ! find unique function value/derivative identifier - - this%covariance_y_y(i_global_yPrime,i_global_yPrime) = this%covariance_y_y(i_global_yPrime,i_global_yPrime) + & - this%sigma_yPrime(i_yPrime)**2 - - globalY(i_global_yPrime) = this%y(i_yPrime) - enddo - - call reallocate(this%alpha, n_globalY, zero = .true.) - - call initialise(LA_covariance_y_y,this%covariance_y_y) - call Matrix_Solve(LA_covariance_y_y, globalY, this%alpha ,error=error) - call finalise(LA_covariance_y_y) - - if(allocated(globalY)) deallocate(globalY) - - call system_timer('gpFull_covarianceMatrix') - - endsubroutine gpFull_covarianceMatrix - - function gpCoordinates_Covariance( this, i_x, j_x, i_sparseX, j_sparseX, grad_Covariance_i, grad_Covariance_j, grad2_Covariance, normalise, error ) - type(gpCoordinates), intent(in), target :: this - integer, intent(in), optional :: i_x, j_x, i_sparseX, j_sparseX - real(dp), dimension(:), optional, intent(out) :: grad_Covariance_i, grad_Covariance_j - real(dp), dimension(:,:), optional, intent(out) :: grad2_Covariance - logical, intent(in), optional :: normalise - integer, optional, intent(out) :: error - - real(dp) :: gpCoordinates_Covariance - - integer :: i_p, x_i_size, x_j_size, i - integer :: ii, jj, zeta_int - real(dp) :: covarianceExp, covarianceDiag_x_x_i, covarianceDiag_x_x_j, covarianceExp_ii, covarianceExp_jj, & - gpCoordinates_Covariance_ii, gpCoordinates_Covariance_jj, normalisation, & - covariancePP_ij, covariancePP_ii, covariancePP_jj, grad_covariancePP_ij, r_ij, r_ii, r_jj, grad_covariancePP_ii, grad_covariancePP_jj - real(dp), dimension(:), pointer :: x_i, x_j, grad_Covariance_Diag_i, grad_Covariance_Diag_j - !real(dp), dimension(this%d) :: inv_theta2, xI_xJ_theta2, xI_xJ, xI_xI, xI_xI_theta2, xJ_xJ, xJ_xJ_theta2, grad_Covariance_ii, grad_Covariance_jj - real(dp), dimension(:),allocatable :: inv_theta2, xI_xJ_theta2, xI_xJ, xI_xI, xI_xI_theta2, xJ_xJ, xJ_xJ_theta2, grad_Covariance_ii, grad_Covariance_jj - real(dp), dimension(:,:), allocatable :: distance_matrix - logical :: do_normalise - - INIT_ERROR(error) - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_Covariance: object not initialised', error) - endif - - do_normalise = optional_default(.true., normalise) - if( count( (/ present(i_x), present(i_sparseX) /) ) /= 1 ) then - RAISE_ERROR('gpCoordinates_Covariance: exactly one of i_x or i_sparseX can be present', error) - endif - - if( count( (/ present(j_x), present(j_sparseX) /) ) /= 1 ) then - RAISE_ERROR('gpCoordinates_Covariance: exactly one of j_x or j_sparseX can be present', error) - endif - - x_i => null() - x_j => null() - grad_Covariance_Diag_i => null() - grad_Covariance_Diag_j => null() - - x_i_size = 0 - x_j_size = 0 - - if(present(i_x)) then - x_i => this%x(:,i_x) - covarianceDiag_x_x_i = this%covarianceDiag_x_x(i_x) - grad_Covariance_Diag_i => this%covarianceDiag_x_xPrime(:,i_x) - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - x_i_size = this%x_size(i_x) - endif - endif - - if(present(j_x)) then - x_j => this%x(:,j_x) - covarianceDiag_x_x_j = this%covarianceDiag_x_x(j_x) - grad_Covariance_Diag_j => this%covarianceDiag_x_xPrime(:,j_x) - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - x_j_size = this%x_size(j_x) - endif - endif - - if(present(i_sparseX)) then - x_i => this%sparseX(:,i_sparseX) - covarianceDiag_x_x_i = this%covarianceDiag_sparseX_sparseX(i_sparseX) - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - x_i_size = this%sparseX_size(i_sparseX) - endif - endif - - if(present(j_sparseX)) then - x_j => this%sparseX(:,j_sparseX) - covarianceDiag_x_x_j = this%covarianceDiag_sparseX_sparseX(j_sparseX) - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - x_j_size = this%sparseX_size(j_sparseX) - endif - endif - - if( .not. associated(x_i) .or. .not. associated(x_j) ) then - RAISE_ERROR('gpCoordinates_Covariance: both i and j indices have to be present', error) - endif - - gpCoordinates_Covariance = 0.0_dp - if(present(grad_Covariance_i)) then - grad_Covariance_i = 0.0_dp - endif - if(present(grad_Covariance_j)) then - grad_Covariance_j = 0.0_dp - endif - if(present(grad2_Covariance)) then - grad2_Covariance = 0.0_dp - endif - - if(this%covariance_type == COVARIANCE_ARD_SE .or. this%covariance_type == COVARIANCE_PP) then - allocate(inv_theta2(this%d), & - xI_xJ(this%d), & - xI_xI(this%d), & - xJ_xJ(this%d), & - xI_xJ_theta2(this%d), & - xI_xI_theta2(this%d), & - xJ_xJ_theta2(this%d), & - grad_Covariance_ii(this%d), & - grad_Covariance_jj(this%d)) - endif - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - if(present(i_x)) then - if(present(j_x)) then - gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & - / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) - elseif(present(j_sparseX)) then - gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & - / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) - elseif(present(grad_Covariance_j)) then - RAISE_ERROR('gpCoordinates_Covariance: bond real space derivatives not implemented', error) - endif - elseif(present(i_sparseX)) then - if(present(j_x)) then - gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & - / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) - elseif(present(j_sparseX)) then - gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & - / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) - elseif(present(grad_Covariance_j)) then - RAISE_ERROR('gpCoordinates_Covariance: bond real space derivatives not implemented', error) - endif - elseif(present(grad_Covariance_i)) then - RAISE_ERROR('gpCoordinates_Covariance: bond real space derivatives not implemented', error) - endif - elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - gpCoordinates_Covariance = sum(x_i*x_j) - - zeta_int = nint(this%zeta) - if( zeta_int .feq. this%zeta ) then - if(present(grad_Covariance_i)) grad_Covariance_i = this%delta**2 * zeta_int * gpCoordinates_Covariance**(zeta_int-1) * x_j - if(present(grad_Covariance_j)) grad_Covariance_j = this%delta**2 * zeta_int * gpCoordinates_Covariance**(zeta_int-1) * x_i - gpCoordinates_Covariance = this%delta**2 * gpCoordinates_Covariance**zeta_int - else - if(present(grad_Covariance_i)) grad_Covariance_i = this%delta**2 * this%zeta * gpCoordinates_Covariance**(this%zeta-1.0_dp) * x_j - if(present(grad_Covariance_j)) grad_Covariance_j = this%delta**2 * this%zeta * gpCoordinates_Covariance**(this%zeta-1.0_dp) * x_i - gpCoordinates_Covariance = this%delta**2 * gpCoordinates_Covariance**this%zeta - endif - elseif(this%covariance_type == COVARIANCE_ARD_SE ) then - inv_theta2 = 1.0_dp / this%theta**2 - do i_p = 1, this%n_permutations - ! permute only i. theta should be symmetrised by now. - - do ii = 1, this%d - xI_xJ(ii) = x_i(this%permutations(ii,i_p)) - x_j(ii) - end do - xI_xJ_theta2 = xI_xJ * inv_theta2 - - covarianceExp = this%delta**2 * exp( -0.5_dp * dot_product(xI_xJ_theta2,xI_xJ) ) - gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp - - if(present(grad_Covariance_i)) then - do ii = 1, this%d - grad_Covariance_i(this%permutations(ii,i_p)) = grad_Covariance_i(this%permutations(ii,i_p)) - covarianceExp * xI_xJ_theta2(ii) - end do - endif - - if(present(grad_Covariance_j)) then - grad_Covariance_j = grad_Covariance_j + covarianceExp * xI_xJ_theta2 - endif - - if(present(grad2_Covariance)) then - do i = 1, this%d - grad2_Covariance(:,this%permutations(i,i_p)) = grad2_Covariance(:,this%permutations(i,i_p)) - covarianceExp * & - xI_xJ_theta2*xI_xJ_theta2(i) - grad2_Covariance(this%permutations(i,i_p),i) = grad2_Covariance(this%permutations(i,i_p),i) + covarianceExp * inv_theta2(i) - enddo - endif - - !if(present(i_xPrime) .and. .not. present(j_xPrime)) then - - ! gpCoordinates_Covariance = gpCoordinates_Covariance - covarianceExp * (dot_product(xI_xJ_theta,xPrime_i_theta(this%permutations(:,i_p)))*fc_i - dfc_i)*fc_j - - !elseif(.not. present(i_xPrime) .and. present(j_xPrime)) then - - ! gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp * (dot_product(xI_xJ_theta,xPrime_j_theta)*fc_j + dfc_j)*fc_i - - !elseif(present(i_xPrime) .and. present(j_xPrime)) then - - ! gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp * ( dot_product( xPrime_i_theta(this%permutations(:,i_p)), xPrime_j_theta )*fc_i*fc_j + & - ! ( - dot_product( xI_xJ_theta, xPrime_i_theta(this%permutations(:,i_p)) )*fc_i + dfc_i ) * & - ! ( dot_product( xI_xJ_theta, xPrime_j_theta )*fc_j + dfc_j ) ) - - !else - ! gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp*fc_i*fc_j - !endif - enddo - - if( this%n_permutations > 1 .and. do_normalise ) then - gpCoordinates_Covariance_ii = 0.0_dp - gpCoordinates_Covariance_jj = 0.0_dp - - if(present(grad_Covariance_i)) then - grad_Covariance_ii = 0.0_dp - endif - - if(present(grad_Covariance_j)) then - grad_Covariance_jj = 0.0_dp - endif - - do i_p = 1, this%n_permutations - - do ii = 1, this%d - xI_xI(ii) = x_i(this%permutations(ii,i_p)) - x_i(ii) - enddo - xI_xI_theta2 = xI_xI * inv_theta2 - - do ii = 1, this%d - xJ_xJ(ii) = x_j(this%permutations(ii,i_p)) - x_j(ii) - enddo - xJ_xJ_theta2 = xJ_xJ * inv_theta2 - - covarianceExp_ii = exp( -0.5_dp * dot_product(xI_xI_theta2,xI_xI) ) - covarianceExp_jj = exp( -0.5_dp * dot_product(xJ_xJ_theta2,xJ_xJ) ) - - gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covarianceExp_ii - gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covarianceExp_jj - - if(present(grad_Covariance_i)) then - grad_Covariance_ii = grad_Covariance_ii + covarianceExp_ii * xI_xI_theta2 - grad_Covariance_ii(this%permutations(:,i_p)) = grad_Covariance_ii(this%permutations(:,i_p)) & - - covarianceExp_ii * xI_xI_theta2 - endif - - if(present(grad_Covariance_j)) then - grad_Covariance_jj = grad_Covariance_jj + covarianceExp_jj * xJ_xJ_theta2 - grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) & - - covarianceExp_jj * xJ_xJ_theta2 - endif - - if(present(grad2_Covariance)) then - RAISE_ERROR('grad2_Covariance for n_permutations > 1 not implemented yet',error) - endif - enddo - - normalisation = sqrt(gpCoordinates_Covariance_ii * gpCoordinates_Covariance_jj) - - if(present(grad_Covariance_i)) then - grad_Covariance_i = grad_Covariance_i / normalisation - 0.5_dp * grad_Covariance_ii * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_ii - endif - - if(present(grad_Covariance_j)) then - grad_Covariance_j = grad_Covariance_j / normalisation - 0.5_dp * grad_Covariance_jj * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_jj - endif - - gpCoordinates_Covariance = gpCoordinates_Covariance / normalisation - else - normalisation = 1.0_dp - endif - - gpCoordinates_Covariance = gpCoordinates_Covariance + this%f0**2 - elseif(this%covariance_type == COVARIANCE_PP ) then - allocate(distance_matrix(this%d, this%d)) - - inv_theta2 = 1.0_dp / this%theta**2 - - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - x_j(jj) )**2 / this%theta(ii)**2 - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle - - r_ij = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) - if( r_ij >= 1.0_dp ) cycle - - covariancePP_ij = this%delta**2 * covariancePP(r_ij,PP_Q, this%d) - gpCoordinates_Covariance = gpCoordinates_Covariance + covariancePP_ij - - if( ( present(grad_Covariance_i) .or. present(grad_Covariance_j) ) .and. (r_ij > 0.0_dp) ) then - grad_covariancePP_ij = this%delta**2 * grad_covariancePP(r_ij,PP_Q, this%d) / r_ij - xI_xJ(:) = x_i(this%permutations(:,i_p)) - x_j(:) - - if(present(grad_Covariance_i)) & - grad_Covariance_i(this%permutations(:,i_p)) = grad_Covariance_i(this%permutations(:,i_p)) + grad_covariancePP_ij * xI_xJ(:) - - if(present(grad_Covariance_j)) & - grad_Covariance_j(:) = grad_Covariance_j(:) - grad_covariancePP_ij * xI_xJ(:) - endif - enddo ! i_p - - if(present(grad_Covariance_i)) grad_Covariance_i = grad_Covariance_i * inv_theta2 - if(present(grad_Covariance_j)) grad_Covariance_j = grad_Covariance_j * inv_theta2 - - do_normalise = do_normalise .and. ( gpCoordinates_Covariance .fne. 0.0_dp ) - if( this%n_permutations > 1 .and. do_normalise ) then - gpCoordinates_Covariance_ii = 0.0_dp - gpCoordinates_Covariance_jj = 0.0_dp - - if(present(grad_Covariance_i)) then - grad_Covariance_ii = 0.0_dp - endif - - if(present(grad_Covariance_j)) then - grad_Covariance_jj = 0.0_dp - endif - - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - x_i(jj) )**2 * inv_theta2(ii) - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle - - r_ii = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) - if( r_ii >= 1.0_dp ) cycle - - covariancePP_ii = covariancePP(r_ii,PP_Q, this%d) - gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covariancePP_ii - - if(present(grad_Covariance_i) .and. (r_ii > 0.0_dp)) then - xI_xI(:) = x_i(this%permutations(:,i_p)) - x_i(:) - - grad_covariancePP_ii = grad_covariancePP(r_ii,PP_Q, this%d) / r_ii - grad_Covariance_ii = grad_Covariance_ii + grad_covariancePP_ii * xI_xI(:) - grad_Covariance_ii(this%permutations(:,i_p)) = grad_Covariance_ii(this%permutations(:,i_p)) - grad_covariancePP_ii * xI_xI - endif - enddo - if(present(grad_Covariance_i)) grad_Covariance_ii = grad_Covariance_ii * inv_theta2 - - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_j(ii) - x_j(jj) )**2 * inv_theta2(ii) - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle - - r_jj = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) - if( r_jj >= 1.0_dp ) cycle - - covariancePP_jj = covariancePP(r_jj,PP_Q, this%d) - gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covariancePP_jj - - if(present(grad_Covariance_j) .and. (r_jj > 0.0_dp)) then - xJ_xJ(:) = x_j(this%permutations(:,i_p)) - x_j(:) - - grad_covariancePP_jj = grad_covariancePP(r_jj,PP_Q, this%d) / r_jj - grad_Covariance_jj = grad_Covariance_jj + grad_covariancePP_jj * xJ_xJ(:) - grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) - grad_covariancePP_jj * xJ_xJ(:) - endif - enddo - if(present(grad_Covariance_j)) grad_Covariance_jj = grad_Covariance_jj * inv_theta2 - - normalisation = sqrt(gpCoordinates_Covariance_ii * gpCoordinates_Covariance_jj) - - if(present(grad_Covariance_i)) then - grad_Covariance_i = grad_Covariance_i / normalisation - 0.5_dp * grad_Covariance_ii * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_ii - endif - - if(present(grad_Covariance_j)) then - grad_Covariance_j = grad_Covariance_j / normalisation - 0.5_dp * grad_Covariance_jj * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_jj - endif - - gpCoordinates_Covariance = gpCoordinates_Covariance / normalisation - else - normalisation = 1.0_dp - endif - - gpCoordinates_Covariance = gpCoordinates_Covariance + this%f0**2 - endif ! this%covariance_type - - if(allocated(inv_theta2)) deallocate(inv_theta2) - if(allocated(xI_xJ)) deallocate(xI_xJ) - if(allocated(xI_xI)) deallocate(xI_xI) - if(allocated(xJ_xJ)) deallocate(xJ_xJ) - if(allocated(xI_xJ_theta2)) deallocate(xI_xJ_theta2) - if(allocated(xI_xI_theta2)) deallocate(xI_xI_theta2) - if(allocated(xJ_xJ_theta2)) deallocate(xJ_xJ_theta2) - if(allocated(grad_Covariance_ii)) deallocate(grad_Covariance_ii) - if(allocated(grad_Covariance_jj)) deallocate(grad_Covariance_jj) - if( allocated( distance_matrix ) ) deallocate(distance_matrix) - - endfunction gpCoordinates_Covariance - - subroutine gpCoordinates_gpCovariance_bond_real_space_Initialise( this, error ) - type(gpCoordinates), intent(inout) :: this - integer, optional, intent(out) :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - if (.not. this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - RAISE_ERROR('gpCoordinates_gpCovariance_bond_real_space_Initialise: covariance is not bond_real_space', error) - endif - - call gpCovariance_bond_real_space_Finalise(this%bond_real_space_cov, error) - - call initialise(params) - call param_register(params, 'n', '2', this%bond_real_space_cov%n, & - help_string="Covariance degree for bond_real_space-type descriptors") - call param_register(params, 'atom_sigma', '0.0', this%bond_real_space_cov%atom_sigma, & - help_string="Atoms sigma for bond_real_space-type descriptors") - - if (.not. param_read_line(params, string(this%descriptor_str), ignore_unknown=.true., task='gpCoordinates_gpCovariance_bond_real_space_Initialise descriptor_str')) then - RAISE_ERROR("gpCoordinates_gpCovariance_bond_real_space_Initialise failed to parse descriptor_str='"//trim(string(this%descriptor_str))//"'", error) - endif - call finalise(params) - - this%bond_real_space_cov%delta = this%delta - - this%bond_real_space_cov%initialised = .true. - - endsubroutine gpCoordinates_gpCovariance_bond_real_space_Initialise - - function gpCovariance_bond_real_space_Calc( this, x_i, x_i_size, x_j, x_j_size, xPrime_i, xPrime_j, xPrime_ij, error ) - type(gpCovariance_bond_real_space), intent(in) :: this - real(dp), intent(in) :: x_i(0:), x_j(0:) - integer, intent(in) :: x_i_size, x_j_size - real(dp), dimension(:), intent(out), optional, pointer :: xPrime_i, xPrime_j - real(dp), dimension(:,:), intent(out), optional, pointer :: xPrime_ij - integer, intent(out), optional :: error - - real(dp) :: gpCovariance_bond_real_space_Calc - real(dp) :: gpCovariance_bond_real_space_Calc_compensation ! Running compensation for Kahan summation algorithm - - integer :: i, j, k, m, n - integer :: x_i_N, x_j_N - complex(dp), allocatable :: gamma_i(:,:), gamma_j(:,:) - real(dp), allocatable :: z_i(:), z_j(:), c_i(:), c_j(:) - real(dp) :: x_i_self_overlap, x_j_self_overlap - integer, allocatable :: iter_index(:) - - logical :: do_derivative, do_xPrime_i, do_xPrime_j, do_xPrime_ij - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCovariance_bond_real_space_Calc: object not initialised', error) - endif - - do_xPrime_i = .false. - do_xPrime_j = .false. - do_xPrime_ij = .false. - if(present(xPrime_i)) do_xPrime_i = associated(xPrime_i) - if(present(xPrime_j)) do_xPrime_j = associated(xPrime_j) - if(present(xPrime_ij)) do_xPrime_ij = associated(xPrime_ij) - - do_derivative = (do_xPrime_i .or. do_xPrime_j .or. do_xPrime_ij) - - if( do_derivative ) then - RAISE_ERROR('gpCovariance_bond_real_space_Calc: derivatives not implemented', error) - endif - - ! - ! x_i: get x_i_N, gamma_i, z_i, c_i, x_i_self_overlap - ! - x_i_N = nint(x_i(0)) - - allocate( gamma_i(x_i_N,x_i_N), z_i(x_i_N), c_i(x_i_N) ) - - gamma_i = cmplx(0.0_dp, 0.0_dp, dp) - z_i = 0.0_dp - c_i = 0.0_dp - - do i = 1, x_i_N - do j = 1, x_i_N - gamma_i(i,j) = cmplx(x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j) - 1), x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j)), dp) - - if (i == j) then - gamma_i(i,j) = cmplx(x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j) - 1), 0.0_dp, dp) - - z_i(i) = x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j)) - endif - enddo - enddo - - x_i_self_overlap = x_i(1) - - c_i = x_i(2:x_i_N + 1) - - ! - ! x_j: get x_j_N, gamma_j, z_j, c_j, x_j_self_overlap - ! - x_j_N = nint(x_j(0)) - - allocate( gamma_j(x_j_N,x_j_N), z_j(x_j_N), c_j(x_j_N) ) - - gamma_j = cmplx(0.0_dp, 0.0_dp, dp) - z_j = 0.0_dp - c_j = 0.0_dp - - do i = 1, x_j_N - do j = 1, x_j_N - gamma_j(i,j) = cmplx(x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j) - 1), x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j)), dp) - - if (i == j) then - gamma_j(i,j) = cmplx(x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j) - 1), 0.0_dp, dp) - - z_j(i) = x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j)) - endif - enddo - enddo - - x_j_self_overlap = x_j(1) - - c_j = x_j(2:x_j_N + 1) - - ! - ! Start with gpCovariance_bond_real_space_Calc = 0 - ! - gpCovariance_bond_real_space_Calc = 0.0_dp - gpCovariance_bond_real_space_Calc_compensation = 0.0_dp ! Running compensation for Kahan summation algorithm - - allocate( iter_index(this%n) ) - - call gpCovariance_bond_real_space_sum(1, 1) - - gpCovariance_bond_real_space_Calc = gpCovariance_bond_real_space_Calc * (2.0_dp / (x_i_self_overlap + x_j_self_overlap))**this%n - - contains - - recursive subroutine gpCovariance_bond_real_space_sum(n, iter) - integer :: n, iter - integer :: i(n), j(n), k, m, l - integer :: iter_index_sorted(n), powers(n) - real(dp) :: coefficient, arg_z, arg_r2, arg_gamma - complex(dp) :: arg_gamma_complex - real(dp) :: x, x_mirror - real(dp) :: y, t ! Intermediate variables for Kahan summation algorithm - - do k = iter, x_i_N*x_j_N - iter_index(n) = k - - if (n < this%n) then - call gpCovariance_bond_real_space_sum(n + 1, k) - else - iter_index_sorted = iter_index - powers = 1 - if (n > 1) then - ! - ! For large n could replace with heapsort? - ! - call sort_array(iter_index_sorted) - - do m = 1, (n - 1) - if (iter_index_sorted(m) == iter_index_sorted(m + 1)) then - powers(m + 1) = powers(m + 1) + powers(m) - powers(m) = 0 - endif - enddo - endif - - do m = 1, n - i(m) = 1 + ((iter_index(m) - 1) / x_i_N) - j(m) = 1 + mod(iter_index(m) - 1, x_j_N) - enddo - - coefficient = factorial(n) - arg_z = 0.0_dp - arg_r2 = 0.0_dp - arg_gamma_complex = cmplx(0.0_dp, 0.0_dp, dp) - do m = 1, n - if (powers(m) /= 0) then - coefficient = coefficient / factorial(powers(m)) - coefficient = coefficient * (c_i(i(m)) * c_j(j(m)))**powers(m) - endif - - arg_z = arg_z + z_i(i(m)) * z_j(j(m)) - arg_r2 = arg_r2 + real(gamma_i(i(m),i(m)), dp) + real(gamma_j(j(m),j(m)), dp) - arg_gamma_complex = arg_gamma_complex + gamma_i(i(m),i(m)) * conjg(gamma_j(j(m),j(m))) - if (m < n) then - do l = (m + 1), n - arg_gamma_complex = arg_gamma_complex + 2.0_dp * gamma_i(i(m),i(l)) * conjg(gamma_j(j(m),j(l))) - enddo - endif - enddo - arg_z = arg_z / (2.0_dp * this%atom_sigma**2) - arg_r2 = - arg_r2 / (4.0_dp * this%atom_sigma**2) - arg_gamma = sqrt(real(arg_gamma_complex, dp)) / (2.0_dp * this%atom_sigma**2) - - ! - ! Use asymptotic expansion of Bessel function - ! - if (arg_gamma < besseli_max_x) then - x = besseli0(arg_gamma) - - x_mirror = exp(- arg_z + arg_r2) * x - x = exp(arg_z + arg_r2) * x - else - x = 1.0_dp - do m = 1, besseli_max_n - x = x + besseli0_c(m) / arg_gamma**m - enddo - x = x / sqrt(2.0_dp * pi * arg_gamma) - - x_mirror = exp(- arg_z + arg_r2 + arg_gamma) * x - x = exp(arg_z + arg_r2 + arg_gamma) * x - endif - - x_mirror = coefficient * x_mirror - x = coefficient * x - - ! - ! Kahan summation algorithm for x_mirror - ! - y = x_mirror - gpCovariance_bond_real_space_Calc_compensation - t = gpCovariance_bond_real_space_Calc + y - gpCovariance_bond_real_space_Calc_compensation = (t - gpCovariance_bond_real_space_Calc) - y - gpCovariance_bond_real_space_Calc = t - ! - ! Kahan summation algorithm for x - ! - y = x - gpCovariance_bond_real_space_Calc_compensation - t = gpCovariance_bond_real_space_Calc + y - gpCovariance_bond_real_space_Calc_compensation = (t - gpCovariance_bond_real_space_Calc) - y - gpCovariance_bond_real_space_Calc = t - endif - enddo - - endsubroutine gpCovariance_bond_real_space_sum - - endfunction gpCovariance_bond_real_space_Calc - - function besseli0(x) - - real(dp), intent(in) :: x - real(dp) :: besseli0 - - real(dp) :: x2, r, k - integer :: i - - x2 = x**2 - - if(x == 0.0_dp) then - besseli0 = 1.0_dp - elseif( x < besseli_max_x ) then - besseli0 = 1.0_dp - r = 1.0_dp - k = 1.0_dp - do while ( abs(r/besseli0) > NUMERICAL_ZERO ) - r = 0.25_dp * r * x2 / k**2 - besseli0 = besseli0 + r - k = k + 1.0_dp - enddo - else - besseli0 = 1.0_dp - do i = 1, besseli_max_n - besseli0 = besseli0 + besseli0_c(i)/x**i - enddo - besseli0 = besseli0 * exp(x) / sqrt(2.0_dp*pi*x) - endif - - endfunction besseli0 - - function besseli1(x) - - real(dp), intent(in) :: x - real(dp) :: besseli1 - - real(dp) :: x2, r, k - integer :: i - - x2 = x**2 - - if(x == 0.0_dp) then - besseli1 = 0.0_dp - elseif( x < besseli_max_x ) then - besseli1 = 1.0_dp - r = 1.0_dp - k = 1.0_dp - do while ( abs(r/besseli1) > NUMERICAL_ZERO ) - r = 0.25_dp * r * x2 / (k*(k+1.0_dp)) - besseli1 = besseli1 + r - k = k + 1.0_dp - enddo - besseli1 = besseli1 * 0.5_dp * x - else - besseli1 = 1.0_dp - do i = 1, besseli_max_n - besseli1 = besseli1 + besseli1_c(i)/x**i - enddo - besseli1 = besseli1 * exp(x) / sqrt(2.0_dp*pi*x) - endif - - endfunction besseli1 - - pure function covariancePP(r,q,d) - real(dp), intent(in) :: r - integer, intent(in) :: q, d - real(dp) :: covariancePP - - real(dp) :: j - integer :: j_int - - j_int = d/2 + q + 1 - j = float(j_int) - - if( r > 1.0_dp ) then - covariancePP = 0.0_dp - elseif( r < 0.0_dp ) then - covariancePP = 1.0_dp - else - if( q == 0 ) then - covariancePP = (1.0_dp - r)**j_int - elseif( q == 1 ) then - covariancePP = (1.0_dp - r)**(j_int+1) * ( (j+1.0_dp)*r + 1.0_dp ) - elseif( q == 2) then - covariancePP = (1.0_dp - r)**(j_int+2) * ( (j**2 + 4.0_dp*j + 3.0_dp) * r**2 + (3.0_dp*j+6.0_dp)*r + 3.0_dp ) / 3.0_dp - elseif( q == 3) then - covariancePP = (1.0_dp - r)**(j_int+3) * & - ( (j**3 + 9.0_dp*j**2 + 23.0_dp*j + 15.0_dp)*r**3 + & - (6.0_dp * j**2 + 36.0_dp*j + 45.0_dp) * r**2 + & - (15.0_dp*j+45.0_dp)*r + 15.0_dp ) / 15.0_dp - endif - endif - - endfunction covariancePP - - pure function grad_covariancePP(r,q,d) - real(dp), intent(in) :: r - integer, intent(in) :: q, d - real(dp) :: grad_covariancePP - - real(dp) :: j - integer :: j_int - - j_int = d/2 + q + 1 - j = float(j_int) - - if( r > 1.0_dp ) then - grad_covariancePP = 0.0_dp - elseif( r < 0.0_dp ) then - grad_covariancePP = 0.0_dp - else - if( q == 0 ) then - grad_covariancePP = - j * (1.0_dp - r)**(j_int-1) - elseif( q == 1 ) then - grad_covariancePP = - (j+1.0_dp) * (1.0_dp - r)**j_int * ( (j+1.0_dp)*r + 1.0_dp ) + & - (1.0_dp - r)**(j_int+1) * (j+1.0_dp) - elseif( q == 2) then - grad_covariancePP = - (j+2.0_dp) * (1.0_dp - r)**(j_int+1) * ( (j**2 + 4.0_dp*j + 3.0_dp) * r**2 + (3.0_dp*j+6.0_dp)*r + 3.0_dp ) / 3.0_dp + & - (1.0_dp - r)**(j_int+2) * ( 2.0_dp * (j**2 + 4.0_dp*j + 3.0_dp) * r + (3.0_dp*j+6.0_dp) ) / 3.0_dp - elseif( q == 3) then - grad_covariancePP = -(j+3.0_dp) * (1.0_dp - r)**(j_int+2) * & - ( (j**3 + 9.0_dp*j**2 + 23.0_dp*j + 15.0_dp)*r**3 + & - (6.0_dp * j**2 + 36.0_dp*j + 45.0_dp) * r**2 + & - (15.0_dp*j+45.0_dp)*r + 15.0_dp ) / 15.0_dp + & - (1.0_dp - r)**(j_int+3) * & - ( 3.0_dp * (j**3 + 9.0_dp*j**2 + 23.0_dp*j + 15.0_dp)*r**2 + & - 2.0_dp * (6.0_dp * j**2 + 36.0_dp*j + 45.0_dp) * r + & - (15.0_dp*j+45.0_dp) ) / 15.0_dp - endif - endif - - endfunction grad_covariancePP - - function gpCovariance_atom_real_space_Calc( this, x_i, x_i_size, x_j, x_j_size, xPrime_i, xPrime_j, xPrime_ij, error ) - type(gpCovariance_atom_real_space), intent(in) :: this - real(dp), dimension(:), intent(in) :: x_i, x_j - integer, intent(in) :: x_i_size, x_j_size - real(dp), dimension(:), intent(out), optional, pointer :: xPrime_i, xPrime_j - real(dp), dimension(:,:), intent(out), optional, pointer :: xPrime_ij - integer, intent(out), optional :: error - - real(dp) :: gpCovariance_atom_real_space_Calc - - type(neighbour_descriptor), dimension(:), allocatable :: neighbour_i, neighbour_j, grad_spherical_i, grad_spherical_j - type(neighbour_descriptor), dimension(:,:), allocatable :: grad_spherical_i_radial_j, grad_spherical_j_radial_i - - real(dp) :: r1, r2, arg_bess, fac_exp, mo_spher_bess_fi_ki_lmm, mo_spher_bess_fi_ki_lm, & - mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lp, mo_spher_bess_fi_ki_lpp, & - grad_mo_spher_bess_fi_ki_l, grad2_mo_spher_bess_fi_ki_l, & - grad_arg_bess1, grad_arg_bess2, grad_fac_exp1, grad_fac_exp2, radial, grad_radial_i, grad_radial_j, grad2_radial_ij, & - fcut1, fcut2, dfcut1, dfcut2, fac_r1r2, grad_fac_r1r2_1, grad_fac_r1r2_2, grad2_fac_exp, grad2_fac_r1r2 - - real(dp), dimension(1) :: real_mould - - integer :: i, j, i_data, j_data, n1, n2, l, l1, l2, m1, m2, n_neighbour_i, n_neighbour_j, real_mould_size - - logical :: do_derivative, do_xPrime_i, do_xPrime_j, do_xPrime_ij - - complex(dp) :: I_lm1m2, tmp_complex - type(cplx_2d_array), dimension(:), allocatable :: integral_r - - type grad_r_type - type(cplx_2d_array), dimension(:), allocatable :: integral_r - endtype grad_r_type - - type real_1d_array - real(dp), dimension(:), allocatable :: value - endtype real_1d_array - - type(grad_r_type), dimension(:), allocatable :: grad_ri, grad_rj - type(grad_r_type), dimension(:,:), allocatable :: grad_rij - - type(real_1d_array), dimension(:,:), allocatable :: grad_spherical_ij - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCovariance_atom_real_space_Calc: object not initialised', error) - endif - - do_xPrime_i = .false. - do_xPrime_j = .false. - do_xPrime_ij = .false. - if(present(xPrime_i)) do_xPrime_i = associated(xPrime_i) - if(present(xPrime_j)) do_xPrime_j = associated(xPrime_j) - if(present(xPrime_ij)) do_xPrime_ij = associated(xPrime_ij) - - do_derivative = (do_xPrime_i .or. do_xPrime_j .or. do_xPrime_ij) - - call gpRealArray_NeighbourDescriptor(this,x_i,x_i_size,neighbour_i,n_neighbour_i) - call gpRealArray_NeighbourDescriptor(this,x_j,x_j_size,neighbour_j,n_neighbour_j) - - if(do_xPrime_i .or. do_xPrime_ij) then - allocate(grad_spherical_i(n_neighbour_i)) - allocate(grad_ri(n_neighbour_i)) - - do i = 1, n_neighbour_i - - - allocate(grad_ri(i)%integral_r(0:this%l_max)) - allocate(grad_spherical_i(i)%spherical_harmonics(0:this%l_max)) - - do l = 0, this%l_max - allocate(grad_spherical_i(i)%spherical_harmonics(l)%value(-l:l)) - grad_spherical_i(i)%spherical_harmonics(l)%value = CPLX_ZERO - - allocate(grad_ri(i)%integral_r(l)%value(-l:l,-l:l)) - grad_ri(i)%integral_r(l)%value = CPLX_ZERO - enddo - enddo - endif - - if(do_xPrime_j .or. do_xPrime_ij) then - allocate(grad_spherical_j(n_neighbour_j)) - allocate(grad_rj(n_neighbour_j)) - - do i = 1, n_neighbour_j - - allocate(grad_rj(i)%integral_r(0:this%l_max)) - allocate(grad_spherical_j(i)%spherical_harmonics(0:this%l_max)) - - do l = 0, this%l_max - allocate(grad_spherical_j(i)%spherical_harmonics(l)%value(-l:l)) - grad_spherical_j(i)%spherical_harmonics(l)%value = CPLX_ZERO - - allocate(grad_rj(i)%integral_r(l)%value(-l:l,-l:l)) - grad_rj(i)%integral_r(l)%value = CPLX_ZERO - enddo - enddo - endif - - if(do_xPrime_ij) then - allocate(grad_rij(n_neighbour_j,n_neighbour_i)) - allocate(grad_spherical_ij(n_neighbour_j,n_neighbour_i)) - allocate(grad_spherical_i_radial_j(n_neighbour_j,n_neighbour_i)) - allocate(grad_spherical_j_radial_i(n_neighbour_j,n_neighbour_i)) - - do i = 1, n_neighbour_i - do j = 1, n_neighbour_j - - allocate(grad_spherical_ij(j,i)%value(0:this%l_max)) - grad_spherical_ij(j,i)%value = 0.0_dp - - allocate(grad_rij(j,i)%integral_r(0:this%l_max)) - - allocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics(0:this%l_max)) - allocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics(0:this%l_max)) - - do l = 0, this%l_max - allocate(grad_rij(j,i)%integral_r(l)%value(-l:l,-l:l)) - grad_rij(j,i)%integral_r(l)%value = CPLX_ZERO - - allocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics(l)%value(-l:l)) - grad_spherical_i_radial_j(j,i)%spherical_harmonics(l)%value = CPLX_ZERO - - allocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value(-l:l)) - grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value = CPLX_ZERO - enddo - enddo - enddo - - endif - - allocate(integral_r(0:this%l_max)) - - do l = 0, this%l_max - allocate(integral_r(l)%value(-l:l,-l:l)) - integral_r(l)%value = CPLX_ZERO - enddo - - if(do_xPrime_i) xPrime_i = 0.0_dp - if(do_xPrime_j) xPrime_j = 0.0_dp - if(do_xPrime_ij) xPrime_ij = 0.0_dp - - ! Overlap of central atoms - integral_r(0)%value(0,0) = 0.25_dp/PI !/ this%atom_sigma**1.5_dp - - ! Overlaps of central atom of first environment with the other atoms in the second. - do n1 = 1, n_neighbour_i - r1 = neighbour_i(n1)%r - if(r1 > this%cutoff) cycle - fcut1 = coordination_function(r1,this%cutoff,this%cutoff_transition_width) - fac_exp = exp(-0.5_dp*this%atom_sigma*r1**2) * 0.25_dp/PI - fac_r1r2 = fac_exp * fcut1 - - integral_r(0)%value(0,0) = integral_r(0)%value(0,0) + fac_r1r2 - - if(do_xPrime_i) then - dfcut1 = dcoordination_function(r1,this%cutoff,this%cutoff_transition_width) - grad_fac_exp1 = -fac_exp*this%atom_sigma*r1 - grad_fac_r1r2_1 = fac_exp * dfcut1 + grad_fac_exp1 * fcut1 - grad_ri(n1)%integral_r(0)%value(0,0) = grad_ri(n1)%integral_r(0)%value(0,0) + grad_fac_r1r2_1 - endif - enddo - - ! Overlaps of central atom of second environment with the other atoms in the first. - do n2 = 1, n_neighbour_j - r2 = neighbour_j(n2)%r - if(r2 > this%cutoff) cycle - fcut2 = coordination_function(r2,this%cutoff,this%cutoff_transition_width) - fac_exp = exp(-0.5_dp*this%atom_sigma*r2**2) * 0.25_dp/PI - fac_r1r2 = fac_exp * fcut2 - - integral_r(0)%value(0,0) = integral_r(0)%value(0,0) + fac_r1r2 - - if(do_xPrime_j) then - dfcut2 = dcoordination_function(r2,this%cutoff,this%cutoff_transition_width) - grad_fac_exp2 = -fac_exp*this%atom_sigma*r2 - grad_fac_r1r2_2 = fac_exp * dfcut2 + grad_fac_exp2 * fcut2 - grad_rj(n2)%integral_r(0)%value(0,0) = grad_rj(n2)%integral_r(0)%value(0,0) + grad_fac_r1r2_2 - endif - enddo - - ! Overlaps of non-central atoms. - do n1 = 1, n_neighbour_i - r1 = neighbour_i(n1)%r - - if(r1 > this%cutoff) cycle - fcut1 = coordination_function(r1,this%cutoff,this%cutoff_transition_width) - dfcut1 = dcoordination_function(r1,this%cutoff,this%cutoff_transition_width) - do n2 = 1, n_neighbour_j - r2 = neighbour_j(n2)%r - - if(r2 > this%cutoff) cycle - fcut2 = coordination_function(r2,this%cutoff,this%cutoff_transition_width) - dfcut2 = dcoordination_function(r2,this%cutoff,this%cutoff_transition_width) - - arg_bess = this%atom_sigma*r1*r2 - fac_exp = exp(-0.5_dp*this%atom_sigma*(r1**2+r2**2)) - fac_r1r2 = fac_exp * fcut1 * fcut2 - - if(do_xPrime_i .or. do_xPrime_ij) then - grad_arg_bess1 = this%atom_sigma*r2 - grad_fac_exp1 = -fac_exp*this%atom_sigma*r1 - grad_fac_r1r2_1 = (fac_exp * dfcut1 + grad_fac_exp1 * fcut1) * fcut2 - endif - - if(do_xPrime_j .or. do_xPrime_ij) then - grad_arg_bess2 = this%atom_sigma*r1 - grad_fac_exp2 = -fac_exp*this%atom_sigma*r2 - grad_fac_r1r2_2 = (fac_exp * dfcut2 + grad_fac_exp2 * fcut2) * fcut1 - endif - - if(do_xPrime_ij) then - grad2_fac_exp = fac_exp * this%atom_sigma**2 * r1*r2 - grad2_fac_r1r2 = grad2_fac_exp*fcut1*fcut2 + grad_fac_exp1*fcut1*dfcut2 + grad_fac_exp2*dfcut1*fcut2 + fac_exp*dfcut1*dfcut2 - endif - - do l = 0, this%l_max - if( l == 0 ) then - mo_spher_bess_fi_ki_lm = cosh(arg_bess)/arg_bess - mo_spher_bess_fi_ki_l = sinh(arg_bess)/arg_bess - if(do_derivative) mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess - if(do_xPrime_ij) mo_spher_bess_fi_ki_lpp = mo_spher_bess_fi_ki_l - (2*l+3)*mo_spher_bess_fi_ki_lp / arg_bess - else - mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm - mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l - if(do_derivative) then - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lp - mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess - if(do_xPrime_ij) mo_spher_bess_fi_ki_lpp = mo_spher_bess_fi_ki_l - (2*l+3)*mo_spher_bess_fi_ki_lp / arg_bess - else - mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l-1)*mo_spher_bess_fi_ki_lm / arg_bess - endif - endif - - if(do_derivative) grad_mo_spher_bess_fi_ki_l = l * mo_spher_bess_fi_ki_l / arg_bess + mo_spher_bess_fi_ki_lp - if(do_xPrime_ij) grad2_mo_spher_bess_fi_ki_l = ( l*(2*l+3)*(l-1) + (1.0_dp+2*l)*arg_bess**2 ) * & - mo_spher_bess_fi_ki_lp / arg_bess**3 + & - ( 1.0_dp + l*(l-1)/arg_bess**2 ) * mo_spher_bess_fi_ki_lpp - - !radial = mo_spher_bess_fi_ki_l*fac_exp - radial = mo_spher_bess_fi_ki_l*fac_r1r2 - - !if(do_xPrime_i .or. do_xPrime_ij) grad_radial_i = grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp1 - if(do_xPrime_i .or. do_xPrime_ij) grad_radial_i = grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * fac_r1r2 + mo_spher_bess_fi_ki_l * grad_fac_r1r2_1 - - !if(do_xPrime_j .or. do_xPrime_ij) grad_radial_j = grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp2 - if(do_xPrime_j .or. do_xPrime_ij) grad_radial_j = grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * fac_r1r2 + mo_spher_bess_fi_ki_l * grad_fac_r1r2_2 - - if(do_xPrime_ij) then - !grad2_radial_ij = fac_exp * this%atom_sigma**2 * r1 * r2 * mo_spher_bess_fi_ki_l + & - !grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * grad_fac_exp2 + & - !grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * grad_fac_exp1 + & - !fac_exp * ( this%atom_sigma * grad_mo_spher_bess_fi_ki_l + grad_arg_bess1*grad_arg_bess2*grad2_mo_spher_bess_fi_ki_l ) - grad2_radial_ij = grad2_fac_r1r2 * mo_spher_bess_fi_ki_l + & - grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * grad_fac_r1r2_2 + & - grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * grad_fac_r1r2_1 + & - fac_r1r2 * ( this%atom_sigma * grad_mo_spher_bess_fi_ki_l + grad_arg_bess1*grad_arg_bess2*grad2_mo_spher_bess_fi_ki_l ) - - grad_spherical_ij(n2,n1)%value(l) = grad_spherical_ij(n2,n1)%value(l) + & - radial - endif - - do m1 = -l, l - if(do_xPrime_i .or. do_xPrime_ij) then - grad_spherical_i(n1)%spherical_harmonics(l)%value(m1) = & - grad_spherical_i(n1)%spherical_harmonics(l)%value(m1) + & - radial * neighbour_j(n2)%spherical_harmonics(l)%value(m1) - endif - - if(do_xPrime_j .or. do_xPrime_ij) then - grad_spherical_j(n2)%spherical_harmonics(l)%value(m1) = & - grad_spherical_j(n2)%spherical_harmonics(l)%value(m1) + & - radial * conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) - endif - - if(do_xPrime_ij) then - grad_spherical_i_radial_j(n2,n1)%spherical_harmonics(l)%value(m1) = & - grad_spherical_i_radial_j(n2,n1)%spherical_harmonics(l)%value(m1) + & - grad_radial_j * neighbour_j(n2)%spherical_harmonics(l)%value(m1) - - grad_spherical_j_radial_i(n2,n1)%spherical_harmonics(l)%value(m1) = & - grad_spherical_j_radial_i(n2,n1)%spherical_harmonics(l)%value(m1) + & - grad_radial_i * conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) - endif - - do m2 = -l, l - I_lm1m2 = radial * & - conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & - neighbour_j(n2)%spherical_harmonics(l)%value(m2) - - integral_r(l)%value(m2,m1) = integral_r(l)%value(m2,m1) + I_lm1m2 - - if(do_xPrime_i .or. do_xPrime_ij) then - grad_ri(n1)%integral_r(l)%value(m2,m1) = grad_ri(n1)%integral_r(l)%value(m2,m1) + & - grad_radial_i * & - conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & - neighbour_j(n2)%spherical_harmonics(l)%value(m2) - endif - - if(do_xPrime_j .or. do_xPrime_ij) then - grad_rj(n2)%integral_r(l)%value(m2,m1) = grad_rj(n2)%integral_r(l)%value(m2,m1) + & - grad_radial_j * & - conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & - neighbour_j(n2)%spherical_harmonics(l)%value(m2) - endif - - if(do_xPrime_ij) then - grad_rij(n2,n1)%integral_r(l)%value(m2,m1) = grad_rij(n2,n1)%integral_r(l)%value(m2,m1) + & - grad2_radial_ij * & - conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & - neighbour_j(n2)%spherical_harmonics(l)%value(m2) - endif - - enddo - enddo - enddo - enddo - enddo - - gpCovariance_atom_real_space_Calc = 0.0_dp - - do l = 0, this%l_max - gpCovariance_atom_real_space_Calc = gpCovariance_atom_real_space_Calc + sum(real(integral_r(l)%value)**2) + sum(aimag(integral_r(l)%value)**2) - enddo - - if(do_xPrime_i) then - i_data = 0 - do i = 1, n_neighbour_i - - i_data = i_data + 1 - do l = 0, this%l_max - xPrime_i(i_data) = xPrime_i(i_data) + & - sum(real(integral_r(l)%value)*real(grad_ri(i)%integral_r(l)%value)) + & - sum(aimag(integral_r(l)%value)*aimag(grad_ri(i)%integral_r(l)%value)) - enddo - i_data = i_data + 1 - xPrime_i(i_data) = 0.0_dp - - do l = 0, this%l_max - real_mould_size = size(transfer(grad_spherical_i(i)%spherical_harmonics(l)%value(-l:l),real_mould)) - xPrime_i(i_data+1:i_data+real_mould_size) = transfer(matmul(grad_spherical_i(i)%spherical_harmonics(l)%value,conjg(integral_r(l)%value)),real_mould) - i_data = i_data + real_mould_size - enddo - enddo - - xPrime_i = xPrime_i * 2.0_dp - endif - - if(do_xPrime_j) then - i_data = 0 - do i = 1, n_neighbour_j - - i_data = i_data + 1 - do l = 0, this%l_max - xPrime_j(i_data) = xPrime_j(i_data) + & - sum(real(integral_r(l)%value)*real(grad_rj(i)%integral_r(l)%value)) + & - sum(aimag(integral_r(l)%value)*aimag(grad_rj(i)%integral_r(l)%value)) - enddo - i_data = i_data + 1 - xPrime_j(i_data) = 0.0_dp - - do l = 0, this%l_max - real_mould_size = size(transfer(grad_spherical_j(i)%spherical_harmonics(l)%value(-l:l),real_mould)) - xPrime_j(i_data+1:i_data+real_mould_size) = transfer(matmul(integral_r(l)%value,conjg(grad_spherical_j(i)%spherical_harmonics(l)%value)),real_mould) - i_data = i_data + real_mould_size - enddo - enddo - - xPrime_j = xPrime_j * 2.0_dp - endif - - if(do_xPrime_ij) then - i_data = 0 - do i = 1, n_neighbour_i - i_data = i_data + 1 - - ! i-th neighbour, wrt r - j_data = 0 - do j = 1, n_neighbour_j - j_data = j_data + 1 - - ! d r_i d r_j - do l = 0, this%l_max - xPrime_ij(i_data,j_data) = xPrime_ij(i_data,j_data) + & - sum(real(grad_rj(j)%integral_r(l)%value)*real(grad_ri(i)%integral_r(l)%value)) + & - sum(aimag(grad_rj(j)%integral_r(l)%value)*aimag(grad_ri(i)%integral_r(l)%value)) + & - sum(real(integral_r(l)%value)*real(grad_rij(j,i)%integral_r(l)%value)) + & - sum(aimag(integral_r(l)%value)*aimag(grad_rij(j,i)%integral_r(l)%value)) - enddo - j_data = j_data + 1 - xPrime_ij(i_data,j_data) = 0.0_dp - - ! d r_i d Y^{lm}_j - do l = 0, this%l_max - real_mould_size = size(transfer(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value(-l:l),real_mould)) - xPrime_ij(i_data,j_data+1:j_data+real_mould_size) = transfer( & - matmul(integral_r(l)%value, conjg(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value)) + & - matmul(grad_ri(i)%integral_r(l)%value, conjg(grad_spherical_j(j)%spherical_harmonics(l)%value)), real_mould) - - j_data = j_data + real_mould_size - enddo - enddo - - i_data = i_data + 1 - xPrime_ij(i_data,:) = 0.0_dp - - do l1 = 0, this%l_max - do m1 = -l1, l1 - j_data = 0 - i_data = i_data + 1 - - ! d Y^{lm}_i d r_j - do j = 1, n_neighbour_j - j_data = j_data + 1 - - tmp_complex = dot_product(grad_rj(j)%integral_r(l1)%value(-l1:l1,m1), grad_spherical_i(i)%spherical_harmonics(l1)%value(-l1:l1)) + & - dot_product(integral_r(l1)%value(-l1:l1,m1),grad_spherical_i_radial_j(j,i)%spherical_harmonics(l1)%value(-l1:l1)) - xPrime_ij(i_data:i_data+1,j_data) = (/real(tmp_complex),aimag(tmp_complex)/) - - j_data = j_data + 1 - xPrime_ij(i_data:i_data+1,j_data) = 0.0_dp - - do l2 = 0, this%l_max - real_mould_size = size(transfer(grad_spherical_j(j)%spherical_harmonics(l2)%value(-l2:l2),real_mould)) - if(l1 == l2) then - xPrime_ij(i_data,j_data+1:j_data+real_mould_size) = transfer( & - grad_spherical_i(i)%spherical_harmonics(l1)%value*conjg(grad_spherical_j(j)%spherical_harmonics(l2)%value(m1)) + & - grad_spherical_ij(j,i)%value(l1)*integral_r(l1)%value(-l1:l1,m1), real_mould) - - xPrime_ij(i_data+1,j_data+1:j_data+real_mould_size) = transfer( & - -CPLX_IMAG*grad_spherical_i(i)%spherical_harmonics(l1)%value*conjg(grad_spherical_j(j)%spherical_harmonics(l2)%value(m1)) + & - CPLX_IMAG*grad_spherical_ij(j,i)%value(l1)*integral_r(l1)%value(-l1:l1,m1), real_mould) - endif - j_data = j_data + real_mould_size - enddo - - enddo - i_data = i_data + 1 - enddo - enddo - enddo - xPrime_ij = xPrime_ij * 2.0_dp - endif - - - if(allocated(integral_r)) then - do l = 0, this%l_max - if(allocated(integral_r(l)%value)) deallocate(integral_r(l)%value) - enddo - deallocate(integral_r) - endif - if(allocated(grad_ri)) then - do i = 1, size(grad_ri) - if(allocated(grad_ri(i)%integral_r)) then - do l = 0, this%l_max - if(allocated(grad_ri(i)%integral_r(l)%value)) deallocate(grad_ri(i)%integral_r(l)%value) - enddo - deallocate(grad_ri(i)%integral_r) - endif - enddo - deallocate(grad_ri) - endif - - if(allocated(grad_rj)) then - do i = 1, size(grad_rj) - if(allocated(grad_rj(i)%integral_r)) then - do l = 0, this%l_max - if(allocated(grad_rj(i)%integral_r(l)%value)) deallocate(grad_rj(i)%integral_r(l)%value) - enddo - deallocate(grad_rj(i)%integral_r) - endif - enddo - deallocate(grad_rj) - endif - - if(do_xPrime_ij) then - - do i = 1, n_neighbour_i - do j = 1, n_neighbour_j - - - do l = 0, this%l_max - deallocate(grad_rij(j,i)%integral_r(l)%value) - deallocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics(l)%value) - deallocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value) - enddo - - deallocate(grad_spherical_ij(j,i)%value) - deallocate(grad_rij(j,i)%integral_r) - deallocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics) - deallocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics) - enddo - enddo - - deallocate(grad_rij) - deallocate(grad_spherical_ij) - deallocate(grad_spherical_i_radial_j) - deallocate(grad_spherical_j_radial_i) - - endif - - call finalise(neighbour_i) - call finalise(neighbour_j) - call finalise(grad_spherical_i) - call finalise(grad_spherical_j) - - endfunction gpCovariance_atom_real_space_Calc - -! function gpCovariance_soap_Calc( this, x_i, x_j, xPrime_i, xPrime_j, xPrime_ij, error ) -! type(gpCovariance_soap), intent(in) :: this -! real(dp), dimension(:), intent(in) :: x_i, x_j -! real(dp), dimension(:), intent(out), optional, pointer :: xPrime_i, xPrime_j -! real(dp), dimension(:,:), intent(out), optional, pointer :: xPrime_ij -! integer, intent(out), optional :: error -! -! real(dp) :: gpCovariance_soap_Calc -! -! integer :: l, m, m1, m2, a, i -! logical :: do_xPrime_i, do_xPrime_j, do_xPrime_ij, do_derivative -! -! type(cplx_1d_array), dimension(:,:), allocatable :: fourier1_so3, fourier2_so3, dcov_dfourier1, dcov_dfourier2 -! type(cplx_2d_array), dimension(:), allocatable :: int_soap -! -! INIT_ERROR(error) -! -! if( .not. this%initialised ) then -! RAISE_ERROR('gpCovariance_soap_Calc: object not initialised', error) -! endif -! -! do_xPrime_i = .false. -! do_xPrime_j = .false. -! do_xPrime_ij = .false. -! if(present(xPrime_i)) do_xPrime_i = associated(xPrime_i) -! if(present(xPrime_j)) do_xPrime_j = associated(xPrime_j) -! if(present(xPrime_ij)) do_xPrime_ij = associated(xPrime_ij) -! -! do_derivative = (do_xPrime_i .or. do_xPrime_j .or. do_xPrime_ij) -! -! allocate( fourier1_so3(0:this%l_max,this%n_max), fourier2_so3(0:this%l_max,this%n_max), int_soap(0:this%l_max) ) -! -! if(do_xPrime_i) allocate( dcov_dfourier1(0:this%l_max,this%n_max) ) -! if(do_xPrime_j) allocate( dcov_dfourier2(0:this%l_max,this%n_max) ) -! -! do a = 1, this%n_max -! do l = 0, this%l_max -! allocate(fourier1_so3(l,a)%value(-l:l)) -! allocate(fourier2_so3(l,a)%value(-l:l)) -! if(do_xPrime_i) allocate(dcov_dfourier1(l,a)%value(-l:l)) -! if(do_xPrime_j) allocate(dcov_dfourier2(l,a)%value(-l:l)) -! enddo -! enddo -! -! do l = 0, this%l_max -! allocate(int_soap(l)%value(-l:l,-l:l)) -! int_soap(l)%value = CPLX_ZERO -! enddo -! -! -! i = 0 -! do a = 1, this%n_max -! do l = 0, this%l_max -! do m = -l, l -! fourier1_so3(l,a)%value(m) = cmplx(x_i(i+1), x_i(i+2)) -! fourier2_so3(l,a)%value(m) = cmplx(x_j(i+1), x_j(i+2)) -! i = i + 2 -! enddo -! enddo -! enddo -! -! do a = 1, this%n_max -! do l = 0, this%l_max -! do m1 = -l, l -! do m2 = -l, l -! int_soap(l)%value(m2,m1) = int_soap(l)%value(m2,m1) + & -! fourier1_so3(l,a)%value(m1) * conjg(fourier2_so3(l,a)%value(m2)) -! enddo -! enddo -! enddo -! enddo -! -! do a = 1, this%n_max -! do l = 0, this%l_max -! if(do_xPrime_i) dcov_dfourier1(l,a)%value = matmul(fourier2_so3(l,a)%value,int_soap(l)%value) -! if(do_xPrime_j) dcov_dfourier2(l,a)%value = matmul(conjg(int_soap(l)%value),fourier1_so3(l,a)%value) -! enddo -! enddo -! -! gpCovariance_soap_Calc = 0.0_dp -! do l = 0, this%l_max -! gpCovariance_soap_Calc = gpCovariance_soap_Calc + sum(real(int_soap(l)%value)**2+aimag(int_soap(l)%value)**2) -! enddo -! -! if(do_derivative) then -! i = 0 -! do a = 1, this%n_max -! do l = 0, this%l_max -! do m = -l, l -! if(do_xPrime_i) then -! xPrime_i(i+1) = real(dcov_dfourier1(l,a)%value(m)) -! xPrime_i(i+2) = aimag(dcov_dfourier1(l,a)%value(m)) -! endif -! if(do_xPrime_j) then -! xPrime_j(i+1) = real(dcov_dfourier2(l,a)%value(m)) -! xPrime_j(i+2) = aimag(dcov_dfourier2(l,a)%value(m)) -! endif -! i = i + 2 -! enddo -! enddo -! enddo -! if(do_xPrime_i) xPrime_i = xPrime_i*2.0_dp -! if(do_xPrime_j) xPrime_j = xPrime_j*2.0_dp -! endif -! -! if(allocated(fourier1_so3)) then -! do a = 1, this%n_max -! do l = 0, this%l_max -! deallocate(fourier1_so3(l,a)%value) -! enddo -! enddo -! deallocate(fourier1_so3) -! endif -! -! if(allocated(fourier2_so3)) then -! do a = 1, this%n_max -! do l = 0, this%l_max -! deallocate(fourier2_so3(l,a)%value) -! enddo -! enddo -! deallocate(fourier2_so3) -! endif -! -! if(allocated(int_soap)) then -! do l = 0, this%l_max -! deallocate(int_soap(l)%value) -! enddo -! deallocate(int_soap) -! endif -! -! if(allocated(dcov_dfourier1)) then -! do a = 1, this%n_max -! do l = 0, this%l_max -! deallocate(dcov_dfourier1(l,a)%value) -! enddo -! enddo -! deallocate(dcov_dfourier1) -! endif -! -! if(allocated(dcov_dfourier2)) then -! do a = 1, this%n_max -! do l = 0, this%l_max -! deallocate(dcov_dfourier2(l,a)%value) -! enddo -! enddo -! deallocate(dcov_dfourier2) -! endif -! -! endfunction gpCovariance_soap_Calc - - subroutine gpRealArray_NeighbourDescriptor(this,x,x_size,neighbour,n_neighbour) - type(gpCovariance_atom_real_space), intent(in) :: this - real(dp), dimension(:), intent(in) :: x - integer, intent(in) :: x_size - type(neighbour_descriptor), dimension(:), allocatable, intent(out) :: neighbour - integer, intent(out) :: n_neighbour - - integer :: l, i_data, i, real_mould_size - real(dp), dimension(1) :: real_mould - complex(dp), dimension(1) :: complex_mould - - n_neighbour = x_size / ( 2 * (this%l_max+1)**2 + 2 ) - - call finalise(neighbour) - - allocate(neighbour(n_neighbour)) - - i_data = 0 - do i = 1, n_neighbour - - i_data = i_data + 1 - neighbour(i)%r = x(i_data) - i_data = i_data + 1 - neighbour(i)%n = abs(nint(x(i_data))) - - allocate(neighbour(i)%spherical_harmonics(0:this%l_max)) - do l = 0, this%l_max - - allocate(neighbour(i)%spherical_harmonics(l)%value(-l:l)) - - real_mould_size = size(transfer(neighbour(i)%spherical_harmonics(l)%value(-l:l),real_mould)) - neighbour(i)%spherical_harmonics(l)%value = transfer(x(i_data+1:i_data+real_mould_size),complex_mould) - i_data = i_data + real_mould_size - enddo - enddo - - endsubroutine gpRealArray_NeighbourDescriptor - - subroutine gpNeighbourDescriptor_Finalise(this) - type(neighbour_descriptor), dimension(:), allocatable, intent(inout) :: this - - integer :: i, l - - if(allocated(this)) then - do i = 1, size(this) - do l = lbound(this(i)%spherical_harmonics,dim=1), ubound(this(i)%spherical_harmonics,dim=1) - if(allocated(this(i)%spherical_harmonics(l)%value)) deallocate(this(i)%spherical_harmonics(l)%value) - enddo - if(allocated(this(i)%spherical_harmonics)) deallocate(this(i)%spherical_harmonics) - enddo - deallocate(this) - endif - - endsubroutine gpNeighbourDescriptor_Finalise - - subroutine gp_atom_real_space_RealArray_XYZ(this,x_array,x_array_size,xyz_array,xyz_array_size) - type(gpCovariance_atom_real_space), intent(in) :: this - real(dp), dimension(:), intent(in), target :: x_array - integer, intent(in) :: x_array_size - real(dp), dimension(:), allocatable, intent(out) :: xyz_array - integer, intent(out) :: xyz_array_size - - integer :: l, i_data, i, n_neighbour, n, n_data, xyz_start, xyz_end - real(dp), dimension(:), pointer :: Y1_array - real(dp), pointer :: Re_Y1m1, Im_Y1m1, Re_Y10 - real(dp) :: r, x, y, z - - real(dp), parameter :: xy_factor = 0.5_dp * sqrt(1.5_dp / PI) - real(dp), parameter :: z_factor = 0.5_dp * sqrt(3.0_dp / PI) - - n_neighbour = x_array_size / ( 2 * (this%l_max+1)**2 + 2 ) - xyz_array_size = n_neighbour*3 - - if(allocated(xyz_array)) deallocate(xyz_array) - - allocate(xyz_array(xyz_array_size)) - - i_data = 0 - do i = 1, n_neighbour - - i_data = i_data + 1 - r = x_array(i_data) - i_data = i_data + 1 - n = abs(nint(x_array(i_data))) - - do l = 0, this%l_max - n_data = 2*(2*l + 1) - - if(l == 1) then - Y1_array => x_array(i_data+1:i_data+n_data) - Re_Y1m1 => Y1_array(1) - Im_Y1m1 => Y1_array(2) - Re_Y10 => Y1_array(3) - !Im_Y10 => Y1_value(4) - !Re_Y1p1 => Y1_value(5) - !Im_Y1p1 => Y1_value(6) - - z = Re_Y10 * r / z_factor - x = Re_Y1m1 * r / xy_factor - y = -Im_Y1m1 * r / xy_factor - endif - - i_data = i_data + n_data - enddo - - xyz_start = (i-1)*3+1 - xyz_end = 3*i - xyz_array(xyz_start:xyz_end) = (/x,y,z/) - enddo - - endsubroutine gp_atom_real_space_RealArray_XYZ - - subroutine gp_atom_real_space_XYZ_RealArray(this,xyz_array,xyz_array_size,x_array,x_array_size) - type(gpCovariance_atom_real_space), intent(in) :: this - real(dp), dimension(:), intent(in), target :: xyz_array - integer, intent(in) :: xyz_array_size - real(dp), dimension(:), allocatable, intent(out) :: x_array - integer, intent(out) :: x_array_size - - integer :: l, m, i_data, i, n_neighbour, xyz_start, xyz_end - real(dp), dimension(:), pointer :: xyz - complex(dp) :: Y_lm - - n_neighbour = xyz_array_size / 3 - x_array_size = n_neighbour * ( 2 * (this%l_max+1)**2 + 2 ) - - if(allocated(x_array)) deallocate(x_array) - - allocate(x_array(x_array_size)) - - i_data = 0 - do i = 1, n_neighbour - - xyz_start = (i-1)*3+1 - xyz_end = 3*i - xyz => xyz_array(xyz_start:xyz_end) - - i_data = i_data + 1 - x_array(i_data) = norm(xyz) - i_data = i_data + 1 - x_array(i_data) = real(i,dp) - - do l = 0, this%l_max - do m = -l, l - Y_lm = SphericalYCartesian(l,m,xyz) - x_array(i_data+1:i_data+2) = (/real(Y_lm),aimag(Y_lm)/) - i_data = i_data + 2 - enddo - enddo - - enddo - - endsubroutine gp_atom_real_space_XYZ_RealArray - - function fast_pow_1d(v, e) - real(dp), intent(in) :: v(:), e - real(dp) :: fast_pow_1d(size(v)) - integer :: e_int - - if (e .feq. 0) then - fast_pow_1d = 1.0_dp - elseif (e .feq. 1) then - fast_pow_1d = v - elseif (e .feq. 2) then - fast_pow_1d = v*v - elseif (e .feq. 3) then - fast_pow_1d = v*v*v - elseif (e .feq. 4) then - fast_pow_1d = v*v - fast_pow_1d = fast_pow_1d*fast_pow_1d - else - e_int = nint(e) - if (e .feq. e_int) then - fast_pow_1d = v**e_int - else - fast_pow_1d = v**e - endif - endif - end function fast_pow_1d - - function fast_pow_2d(v, e) - real(dp), intent(in) :: v(:,:), e - real(dp) :: fast_pow_2d(size(v,1),size(v,2)) - - if (e == 0.0) then - fast_pow_2d = 1.0_dp - elseif (e == 1.0) then - fast_pow_2d = v - elseif (e == 2.0) then - fast_pow_2d = v*v - elseif (e == 3.0) then - fast_pow_2d = v*v*v - elseif (e == 4.0) then - fast_pow_2d = v*v - fast_pow_2d = fast_pow_2d*fast_pow_2d - else - fast_pow_2d = v**e - endif - end function fast_pow_2d - - function gpCoordinates_Predict( this, xStar, gradPredict, variance_estimate, do_variance_estimate, grad_variance_estimate, error ) - type(gpCoordinates), intent(inout), target :: this - real(dp), dimension(:), intent(in) :: xStar - real(dp), dimension(:), intent(out), optional :: gradPredict - real(dp), intent(out), optional :: variance_estimate - logical, intent(in), optional :: do_variance_estimate - real(dp), dimension(:), intent(out), optional :: grad_variance_estimate - integer, optional, intent(out) :: error - - real(dp) :: gpCoordinates_Predict - - real(dp) :: covarianceExp, gpCoordinates_Covariance_ii, gpCoordinates_Covariance_jj, covarianceExp_ii, covarianceExp_jj, normalisation, r_ij, r_jj, covariancePP_ij, covariancePP_jj - real(dp), pointer :: fc_i - real(dp), dimension(:), pointer :: x_i - real(dp), dimension(:,:), pointer :: x_i_permuted_theta - real(dp), dimension(this%d) :: xI_xJ_theta, xStar_theta - !real(dp), dimension(this%d,this%n_permutations) :: xStar_permuted - real(dp), dimension(this%n_sparseX) :: k - integer :: i_sparseX, i_p, ii, jj - real(dp) :: delta, covariance_x_x, diag_covariance - real(dp), dimension(:), allocatable :: covariance_x_xStars, alpha_scaled, grad_Covariance_jj - real(dp), dimension(:), pointer :: xPrime_i - real(dp), dimension(:), allocatable, target :: grad_kStar, k_mm_k - real(dp), dimension(:,:), allocatable, target :: grad_k - real(dp), dimension(:,:), allocatable :: distance_matrix - logical :: my_do_variance_estimate - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_Predict: object not initialised', error) - endif - - my_do_variance_estimate = present(variance_estimate) .and. optional_default(.false.,do_variance_estimate) - - if( this%n_sparseX == 0 ) then - gpCoordinates_Predict = 0.0_dp - if( present(gradPredict) ) gradPredict = 0.0_dp - if( my_do_variance_estimate ) then - variance_estimate = 0.0_dp - if( present( grad_variance_estimate ) ) grad_variance_estimate = 0.0_dp - endif - return - endif - - - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then -#ifdef _OPENMP - if (OMP_IN_PARALLEL()) then - RAISE_ERROR('gpCoordinates_Predict: bond_real_space covariance not OpenMP/thread-safe', error) - end if -#endif - if(.not. this%bond_real_space_cov%initialised) then - call gpCoordinates_gpCovariance_bond_real_space_Initialise(this) - endif - endif - - k = 0.0_dp - xPrime_i => null() - if(present(gradPredict) .and. this%covariance_type /= COVARIANCE_DOT_PRODUCT) then - allocate(grad_k(size(xStar),this%n_sparseX)) - grad_k = 0.0_dp - if( this%n_permutations > 1 ) allocate(grad_Covariance_jj(this%d)) - endif - - covariance_ard_se_calc_cov_jj: if (this%covariance_type == COVARIANCE_ARD_SE) then - if (.not. this%sparse_covariance_initialised) then - RAISE_ERROR('gpCoordinates_Predict: gpCoordinates_precalculate_sparse needs to be called first', error) - end if - - xStar_theta = xStar / this%theta - - !do i_p = 1, this%n_permutations - ! xStar_permuted(:,i_p) = xStar(this%permutations(:,i_p)) - !end do - if( this%n_permutations > 1 ) then - gpCoordinates_Covariance_jj = 0.0_dp - if(present(gradPredict)) grad_Covariance_jj = 0.0_dp - - do i_p = 1, this%n_permutations - xI_xJ_theta = ( xStar_theta(this%permutations(:,i_p)) - xStar_theta(:) ) - covarianceExp_jj = exp( -0.5_dp * dot_product(xI_xJ_theta,xI_xJ_theta) ) - gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covarianceExp_jj - - if(present(gradPredict)) then - !grad_Covariance_jj = grad_Covariance_jj + covarianceExp_jj * xI_xJ_theta / this%theta - grad_Covariance_jj = grad_Covariance_jj + covarianceExp_jj * xI_xJ_theta / this%theta - grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) - covarianceExp_jj * xI_xJ_theta / this%theta - endif - enddo - endif - end if covariance_ard_se_calc_cov_jj - - covariance_pp_calc_cov_jj: if (this%covariance_type == COVARIANCE_PP) then - if (.not. this%sparse_covariance_initialised) then - RAISE_ERROR('gpCoordinates_Predict: gpCoordinates_precalculate_sparse needs to be called first', error) - end if - - xStar_theta = xStar / this%theta - allocate(distance_matrix(this%d, this%d)) - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) & - distance_matrix(ii,jj) = ( xStar_theta(ii) - xStar_theta(jj) )**2 - - if( this%n_permutations > 1 ) then - gpCoordinates_Covariance_jj = 0.0_dp - if(present(gradPredict)) grad_Covariance_jj = 0.0_dp - - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle - - r_jj = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) - if( r_jj >= 1.0_dp ) cycle - - covariancePP_jj = covariancePP(r_jj,PP_Q, this%d) - gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covariancePP_jj - - if(present(gradPredict) .and. ( r_jj .fne. 0.0_dp ) ) then - xI_xJ_theta = ( xStar_theta(:) - xStar_theta(this%permutations(:,i_p)) ) - - grad_Covariance_jj = grad_Covariance_jj + grad_covariancePP(r_jj,PP_Q, this%d) * xI_xJ_theta / this%theta / r_jj - grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) - grad_covariancePP(r_jj,PP_Q, this%d) * xI_xJ_theta / this%theta / r_jj - endif - enddo - endif - end if covariance_pp_calc_cov_jj - - covariance_type_calc_k: if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then - allocate(covariance_x_xStars(this%n_sparseX)) - call dgemv('T', size(this%sparseX,1), size(this%sparseX,2), 1.0_dp, this%sparseX(1,1), size(this%sparseX, 1), & - xStar(1), 1, 0.0_dp, covariance_x_xStars(1), 1) -! now a single dgemv call outside the loop -! do i_sparseX = 1, this%n_sparseX -! covariance_x_xStar = dot_product(xStar,this%sparseX(:,i_sparseX)) -! -! k(i_sparseX) = this%delta**2 * covariance_x_xStar**this%theta(1) -! -! if(present(gradPredict)) grad_k(:,i_sparseX) = this%delta**2 * this%theta(1) * covariance_x_xStar**(this%theta(1)-1.0_dp) * this%sparseX(:,i_sparseX) -! end do - - k(:) = this%delta**2 * fast_pow_1d(covariance_x_xStars(:), this%zeta) - - k = k * this%sparseCutoff - if(present(gradPredict)) then - allocate(alpha_scaled(size(this%alpha))) - alpha_scaled(:) = this%alpha(:) * this%delta**2 * this%zeta * fast_pow_1d(covariance_x_xStars, this%zeta-1.0_dp) - alpha_scaled = alpha_scaled * this%sparseCutoff - endif - deallocate(covariance_x_xStars) - - else if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then covariance_type_calc_k - xPrime_i => null() - do i_sparseX = 1, this%n_sparseX - delta = this%bond_real_space_cov%delta - this%bond_real_space_cov%delta = 1.0_dp - covariance_x_x = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=xStar, x_i_size=(size(xStar) - 1), x_j=xStar, x_j_size=(size(xStar) - 1)) - this%bond_real_space_cov%delta = delta - k(i_sparseX) = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=xStar, x_i_size=(size(xStar) - 1), x_j=this%sparseX(:,i_sparseX), x_j_size=this%sparseX_size(i_sparseX)) & - / sqrt(covariance_x_x * this%covarianceDiag_sparseX_sparseX(i_sparseX)) - enddo - - else if(this%covariance_type == COVARIANCE_ARD_SE) then covariance_type_calc_k - xPrime_i => null() - do i_sparseX = 1, this%n_sparseX - !x_i => this%sparseX(:,i_sparseX) - x_i_permuted_theta => this%sparseX_permuted(:,:,i_sparseX) - fc_i => this%sparseCutoff(i_sparseX) - do i_p = 1, this%n_permutations - - xI_xJ_theta = (x_i_permuted_theta(:,i_p) - xStar_theta(:)) - !xI_xJ_theta = (x_i(:) - xStar_permuted(:,i_p)) / this%theta - !xI_xJ_theta = (this%sparseX_permuted(:,i_p,i_sparseX) - xStar(:)) / this%theta - - covarianceExp = this%delta**2 * exp( -0.5_dp * dot_product(xI_xJ_theta,xI_xJ_theta) ) - - if(present(gradPredict)) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) + covarianceExp*xI_xJ_theta / this%theta - k(i_sparseX) = k(i_sparseX) + covarianceExp - enddo - - if( this%n_permutations > 1 ) then - - normalisation = sqrt(this%sparseCovariance(i_sparseX) * gpCoordinates_Covariance_jj) - if(present(gradPredict)) then - grad_k(:,i_sparseX) = grad_k(:,i_sparseX) / normalisation - 0.5_dp * grad_Covariance_jj * k(i_sparseX) / normalisation / gpCoordinates_Covariance_jj - endif - - k(i_sparseX) = k(i_sparseX) / normalisation - - endif - k(i_sparseX) = ( k(i_sparseX) + this%f0**2 ) * fc_i - if(present(gradPredict)) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) * fc_i - enddo - else if(this%covariance_type == COVARIANCE_PP) then covariance_type_calc_k - xPrime_i => null() - do i_sparseX = 1, this%n_sparseX - x_i => this%sparseX(:,i_sparseX) - fc_i => this%sparseCutoff(i_sparseX) - - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - xStar(jj) )**2 / this%theta(ii)**2 - - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle - - r_ij = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) - if( r_ij >= 1.0_dp ) cycle - - covariancePP_ij = this%delta**2 * covariancePP(r_ij,PP_Q, this%d) - if(present(gradPredict) .and. ( r_ij /= 0.0_dp ) ) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) + & - this%delta**2 * grad_covariancePP(r_ij,PP_Q, this%d) * ( xStar(:) - x_i(this%permutations(:,i_p)) ) / r_ij / this%theta(:)**2 - - k(i_sparseX) = k(i_sparseX) + covariancePP_ij - enddo - - if( this%n_permutations > 1 ) then - - normalisation = sqrt(this%sparseCovariance(i_sparseX) * gpCoordinates_Covariance_jj) - - if(present(gradPredict)) then - grad_k(:,i_sparseX) = grad_k(:,i_sparseX) / normalisation - 0.5_dp * grad_Covariance_jj * k(i_sparseX) / normalisation / gpCoordinates_Covariance_jj - endif - - k(i_sparseX) = k(i_sparseX) / normalisation - - endif - k(i_sparseX) = ( k(i_sparseX) + this%f0**2 ) * fc_i - if(present(gradPredict)) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) * fc_i - enddo - end if covariance_type_calc_k - gpCoordinates_Predict = dot_product( k, this%alpha ) - - if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then - if(present(gradPredict)) & - call dgemv('N', size(this%sparseX,1), size(this%sparseX,2), 1.0_dp, this%sparseX(1,1), size(this%sparseX,1), & - alpha_scaled(1), 1, 0.0_dp, gradPredict(1), 1) - else - if(present(gradPredict)) & - call dgemv('N', size(grad_k,1), size(grad_k,2), 1.0_dp, grad_k(1,1), size(grad_k,1), & - this%alpha(1), 1, 0.0_dp, gradPredict(1), 1) - endif - - if(my_do_variance_estimate) then - allocate(k_mm_k(this%n_sparseX)) - - if(.not.this%variance_estimate_initialised) then - RAISE_ERROR('gpCoordinates_Predict: variance_estimate not initialised',error) - endif - - call Matrix_Solve(this%LA_k_mm, k, k_mm_k) - diag_covariance = this%delta**2 + this%f0**2 + this%variance_estimate_regularisation**2 - - variance_estimate = diag_covariance - dot_product(k,k_mm_k) - if( variance_estimate < 0.0_dp ) then - RAISE_ERROR('gpCoordinates_Predict: variance_estimate: negative variance predicted: '//variance_estimate ,error) - endif - - if( present(gradPredict) .and. present(grad_variance_estimate) ) then - if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then - grad_variance_estimate = - 2.0_dp * matmul(this%sparseX, alpha_scaled / this%alpha * k_mm_k) - else - call dgemv('N', size(grad_k,1), size(grad_k,2), 1.0_dp, grad_k(1,1), size(grad_k,1), & - k_mm_k(1), 1, 0.0_dp, grad_variance_estimate(1), 1) - grad_variance_estimate = - 2.0_dp * grad_variance_estimate - endif - endif - if(allocated(k_mm_k)) deallocate(k_mm_k) - endif - - if(allocated(alpha_scaled)) deallocate(alpha_scaled) - if(allocated(grad_k)) deallocate(grad_k) - if(allocated(grad_kStar)) deallocate(grad_kStar) - if(allocated(grad_Covariance_jj)) deallocate(grad_Covariance_jj) - if( allocated( distance_matrix ) ) deallocate(distance_matrix) - - endfunction gpCoordinates_Predict - - subroutine gpCoordinates_precalculate_sparse(this) - type(gpCoordinates), intent(inout), target :: this - - integer :: i_sparseX, i_p, ii, jj - real(dp), dimension(:), pointer :: x_i - real(dp), dimension(:,:), pointer :: x_i_permuted_theta - real(dp) :: gpCoordinates_Covariance_ii, covarianceExp_ii, r_ii - real(dp), dimension(this%d) :: xI_xI_theta - real(dp), dimension(:,:), allocatable :: distance_matrix - - initialise_sparse_covariance: if( .not. this%sparse_covariance_initialised ) then - select case(this%covariance_type) - case(COVARIANCE_ARD_SE) - if (allocated(this%sparseX_permuted)) deallocate( this%sparseX_permuted ) - allocate(this%sparseX_permuted(this%d, this%n_permutations, this%n_sparseX)) - - do i_sparseX = 1, this%n_sparseX - x_i => this%sparseX(:,i_sparseX) - x_i_permuted_theta => this%sparseX_permuted(:,:,i_sparseX) - do i_p = 1, this%n_permutations - x_i_permuted_theta(:,i_p) = x_i(this%permutations(:,i_p)) / this%theta - end do - end do - - if( this%n_permutations > 1 ) then - call reallocate(this%sparseCovariance,this%n_sparseX) - - do i_sparseX = 1, this%n_sparseX - x_i => this%sparseX(:,i_sparseX) - x_i_permuted_theta => this%sparseX_permuted(:,:,i_sparseX) - gpCoordinates_Covariance_ii = 0.0_dp - do i_p = 1, this%n_permutations - xI_xI_theta = x_i_permuted_theta(:,i_p) - (x_i / this%theta) - covarianceExp_ii = exp( -0.5_dp * dot_product(xI_xI_theta,xI_xI_theta) ) - gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covarianceExp_ii - enddo - this%sparseCovariance(i_sparseX) = gpCoordinates_Covariance_ii - end do - end if - case(COVARIANCE_PP) - if( this%n_permutations > 1 ) then - call reallocate(this%sparseCovariance,this%n_sparseX) - allocate(distance_matrix(this%d,this%d)) - - do i_sparseX = 1, this%n_sparseX - x_i => this%sparseX(:,i_sparseX) - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) & - distance_matrix(ii,jj) = ( x_i(ii) - x_i(jj) )**2 / this%theta(ii)**2 - gpCoordinates_Covariance_ii = 0.0_dp - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(ii,this%permutations(ii,i_p)) > 1.0_dp, ii=1, this%d) /) ) ) cycle - r_ii = sqrt( sum( (/ (distance_matrix(ii,this%permutations(ii,i_p)), ii=1, this%d) /) ) ) - if( r_ii >= 1.0_dp ) cycle - - gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covariancePP(r_ii,PP_Q, this%d) - enddo - this%sparseCovariance(i_sparseX) = gpCoordinates_Covariance_ii - end do - - deallocate(distance_matrix) - end if - - endselect - - this%sparse_covariance_initialised = .true. - end if initialise_sparse_covariance - - end subroutine gpCoordinates_precalculate_sparse - - subroutine gpCoordinates_initialise_variance_estimate(this, regularisation, error) - type(gpCoordinates), intent(inout), target :: this - real(dp), intent(in) :: regularisation - integer, intent(out), optional :: error - - real(dp) :: r_ij - real(dp), dimension(:,:), allocatable :: k_mm, distance_matrix - real(dp), dimension(:), pointer :: x_i, x_j - real(dp), pointer :: fc_i, fc_j - real(dp), dimension(this%d) :: xI_xJ_theta - - integer :: i, j, i_p, ii, jj, zeta_int - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_initialise_variance_estimate: object not initialised', error) - endif - - if( this%variance_estimate_initialised ) then - if( regularisation .feq. this%variance_estimate_regularisation) then - return - else - call gpCoordinates_finalise_variance_estimate(this,error) - endif - endif - - if( this%n_sparseX == 0 ) return - - if( regularisation < 0.0_dp ) then - RAISE_ERROR("gpCoordinates_initialise_variance_estimate: regularisation ("//regularisation//") is negative.",error) - elseif( regularisation == 0.0_dp ) then - call print_warning("gpCoordinates_initialise_variance_estimate: regularisation = 0.0, proceed with caution") - endif - - this%variance_estimate_regularisation = regularisation - - allocate(k_mm(this%n_sparseX,this%n_sparseX)) - zeta_int = int(this%zeta) - - if( this%covariance_type == COVARIANCE_PP ) allocate(distance_matrix(this%d,this%d)) - - if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then - call dgemm('T', 'N', size(this%sparseX,2), size(this%sparseX,2), size(this%sparseX,1), & - 1.0_dp, this%sparseX(1,1), size(this%sparseX,1), this%sparseX(1,1), size(this%sparseX, 1), & - 0.0_dp, k_mm(1,1), size(k_mm,1)) - k_mm = fast_pow_2d(k_mm, this%zeta) - else - k_mm = 0.0_dp - do i = 1, this%n_sparseX - x_i => this%sparseX(:,i) - fc_i => this%sparseCutoff(i) - do j = i, this%n_sparseX - x_j => this%sparseX(:,j) - fc_j => this%sparseCutoff(j) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_initialise_variance_estimate: bond real space sparse score not implemented', error) - endif - elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then - if( zeta_int .feq. this%zeta ) then - k_mm(j,i) = fc_i*fc_i * sum( x_i * x_j )**zeta_int - else - k_mm(j,i) = fc_i*fc_i * sum( x_i * x_j )**this%zeta - endif - elseif( this%covariance_type == COVARIANCE_ARD_SE ) then - do i_p = 1, this%n_permutations - xI_xJ_theta = (x_i(this%permutations(:,i_p)) - x_j) / this%theta - !xI_xJ_theta = (x_i - x_j(this%permutations(:,i_p))) / this%theta - k_mm(j,i) = k_mm(j,i) + exp( -0.5_dp * dot_product(xI_xJ_theta,xI_xJ_theta) ) - enddo - elseif( this%covariance_type == COVARIANCE_PP ) then - forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - x_j(jj) )**2 / this%theta(ii)**2 - do i_p = 1, this%n_permutations - if( any( (/ (distance_matrix(ii,this%permutations(ii,i_p)) > 1.0_dp, ii=1, this%d) /) ) ) cycle - r_ij = sqrt( sum( (/ (distance_matrix(ii,this%permutations(ii,i_p)), ii=1, this%d) /) ) ) - if( r_ij >= 1.0_dp ) cycle - - k_mm(j,i) = k_mm(j,i) + covariancePP(r_ij,PP_Q, this%d) - enddo - endif - if( i /= j ) k_mm(i,j) = k_mm(j,i) - enddo - enddo - endif - - if( this%covariance_type == COVARIANCE_ARD_SE .or. this%covariance_type == COVARIANCE_PP ) then - do i = 1, this%n_sparseX - fc_i => this%sparseCutoff(i) - do j = i+1, this%n_sparseX - fc_j => this%sparseCutoff(j) - k_mm(j,i) = k_mm(j,i) * fc_i * fc_j / sqrt(k_mm(j,j)*k_mm(i,i)) - k_mm(i,j) = k_mm(j,i) - enddo - enddo - do i = 1, this%n_sparseX - fc_i => this%sparseCutoff(i) - k_mm(i,i) = fc_i**2 - enddo - endif - - k_mm = k_mm * this%delta**2 - k_mm = k_mm + this%f0**2 - - do i = 1, this%n_sparseX - k_mm(i,i) = k_mm(i,i) + regularisation**2 - enddo - - call initialise(this%LA_k_mm, k_mm) - call LA_Matrix_Factorise(this%LA_k_mm,error=error) - if(allocated(k_mm)) deallocate(k_mm) - if(allocated(distance_matrix)) deallocate(distance_matrix) - - this%variance_estimate_initialised = .true. - - endsubroutine gpCoordinates_initialise_variance_estimate - - function gpCoordinates_log_likelihood(this,regularisation,error) result(log_likelihood) - type(gpCoordinates), intent(inout) :: this - real(dp), intent(in), optional :: regularisation - integer, intent(out), optional :: error - real(dp) :: log_likelihood - - real(dp) :: my_regularisation - logical :: was_initialised - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_log_likelihood: object not initialised', error) - endif - - if( this%n_sparseX == 0 ) then - log_likelihood = 0.0_dp - return - endif - - was_initialised = this%variance_estimate_initialised - if( this%variance_estimate_initialised ) then - my_regularisation = optional_default(this%variance_estimate_regularisation,regularisation) - else - my_regularisation = optional_default(0.001_dp,regularisation) - endif - - call gpCoordinates_initialise_variance_estimate(this,my_regularisation,error) - - log_likelihood = -0.5_dp * sum(matmul(this%LA_k_mm%matrix,this%alpha)*this%alpha) & - - 0.5_dp*LA_Matrix_LogDet(this%LA_k_mm) - this%n_sparseX * log(2.0_dp*pi) - - if( .not. was_initialised ) call gpCoordinates_finalise_variance_estimate(this,error) - - endfunction gpCoordinates_log_likelihood - - subroutine gpCoordinates_finalise_variance_estimate(this,error) - type(gpCoordinates), intent(inout) :: this - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if( .not. this%variance_estimate_initialised) return - - call finalise(this%LA_k_mm) - - this%variance_estimate_regularisation = 0.0_dp - this%variance_estimate_initialised = .false. - - endsubroutine gpCoordinates_finalise_variance_estimate - - subroutine gpCoordinates_print_sparseX_file(this,sparseX_filename,error) - type(gpCoordinates), intent(in) :: this - character(len=*), intent(in) :: sparseX_filename - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call fwrite_array_d(size(this%sparseX), this%sparseX(1,1), trim(sparseX_filename)//C_NULL_CHAR) - - end subroutine gpCoordinates_print_sparseX_file - - subroutine gpFull_get_globalY(this, globalY) - type(gpFull), intent(in) :: this - real(dp), intent(inout), allocatable :: globalY(:) - - integer :: i_y, i_yPrime, i_map - - call reallocate(globalY, (this%n_y + this%n_yPrime)) - - do i_y = 1, this%n_y - i_map = this%map_y_globalY(i_y) - globalY(i_map) = this%y(i_y) - enddo - - do i_yPrime = 1, this%n_yPrime - i_map = this%map_yPrime_globalY(i_yPrime) - globalY(i_map) = this%yPrime(i_yPrime) - end do - end subroutine gpFull_get_globalY - - ! print covariances and lambda to process-dependent files, one value per line - subroutine gpFull_print_covariances_lambda_globalY(this, file_prefix, my_proc, do_Kmm) - type(gpFull), intent(in) :: this - character(*), intent(in) :: file_prefix - integer, intent(in) :: my_proc - logical, intent(in) :: do_Kmm - - real(dp), allocatable :: globalY(:) - - call fwrite_array_d(size(this%covariance_subY_y), this%covariance_subY_y, trim(file_prefix)//'_Kmn.'//my_proc//C_NULL_CHAR) - call fwrite_array_d(size(this%lambda), this%lambda, trim(file_prefix)//'_lambda.'//my_proc//C_NULL_CHAR) - - call gpFull_get_globalY(this, globalY) - call fwrite_array_d(size(globalY), globalY, trim(file_prefix)//'_globalY.'//my_proc//C_NULL_CHAR) - - if (.not. do_Kmm) return - if (.not. this%do_subY_subY) then - call print_warning("gpFull_print_covariances_lambda: Called to print Kmm but do_subY_subY is false.") - return - end if - if (.not. allocated(this%covariance_subY_subY)) then - call print_warning("gpFull_print_covariances_lambda: Called to print Kmm but not allocated.") - return - end if - - call fwrite_array_d(size(this%covariance_subY_subY), this%covariance_subY_subY, trim(file_prefix)//'_Kmm'//C_NULL_CHAR) - end subroutine gpFull_print_covariances_lambda_globalY - - subroutine gpCoordinates_printXML(this,xf,label,sparseX_base_filename,error) - type(gpCoordinates), intent(in) :: this - type(xmlf_t), intent(inout) :: xf - character(len=*), intent(in), optional :: label - character(len=*), intent(in), optional :: sparseX_base_filename - integer, intent(out), optional :: error - - integer :: i, j, j_end, slash_ind - type(extendable_str) :: sparseX_filename - character(len=32) :: sparseX_md5sum - logical :: have_sparseX_base_filename - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpCoordinates_printXML: object not initialised', error) - endif - - have_sparseX_base_filename = .false. - if (present(sparseX_base_filename)) then - if (len_trim(sparseX_base_filename) > 0) have_sparseX_base_filename = .true. - endif - - call xml_NewElement(xf,"gpCoordinates") - - if(present(label)) call xml_AddAttribute(xf,"label", trim(label)) - - call xml_AddAttribute(xf,"dimensions", ""//this%d) - call xml_AddAttribute(xf,"signal_variance", ""//this%delta) - call xml_AddAttribute(xf,"signal_mean", ""//this%f0) - call xml_AddAttribute(xf,"sparsified", ""//this%sparsified) - call xml_AddAttribute(xf,"n_permutations", ""//this%n_permutations) - call xml_AddAttribute(xf,"covariance_type", ""//this%covariance_type) - - if( this%covariance_type == COVARIANCE_DOT_PRODUCT ) & - call xml_AddAttribute(xf,"zeta", ""//this%zeta) - - if(this%sparsified) then - call xml_AddAttribute(xf,"n_sparseX",""//this%n_sparseX) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"sparseX_size_max", ""//maxval(this%sparseX_size)) - if (have_sparseX_base_filename) then - sparseX_filename = trim(sparseX_base_filename) - if (present(label)) then - call concat(sparseX_filename,"."//trim(label)) - endif - call gpCoordinates_print_sparseX_file(this,trim(string(sparseX_filename)),error=error) - call quip_md5sum(trim(string(sparseX_filename)),sparseX_md5sum) - ! remove leading path, since file will be read in from path of - ! xml file - slash_ind = index(sparseX_filename, "/") - do while (slash_ind > 0) - call substr_replace(sparseX_filename, 1, slash_ind, "") - slash_ind = index(sparseX_filename, "/") - end do - call xml_AddAttribute(xf,"sparseX_filename",trim(string(sparseX_filename))) - call xml_AddAttribute(xf,"sparseX_md5sum",trim(sparseX_md5sum)) - endif - else - call xml_AddAttribute(xf,"n_x",""//this%n_x) - call xml_AddAttribute(xf,"n_xPrime",""//this%n_xPrime) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"x_size_max", ""//maxval(this%x_size)) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"xPrime_size_max", ""//maxval(this%xPrime_size)) - endif - - if( this%covariance_type == COVARIANCE_ARD_SE .or. this%covariance_type == COVARIANCE_PP ) then - call xml_NewElement(xf,"theta") - call xml_AddCharacters(xf, ""//this%theta//" ") - call xml_EndElement(xf,"theta") - endif - - call xml_NewElement(xf,"descriptor") - call xml_AddCharacters(xf, string(this%descriptor_str)) - call xml_EndElement(xf,"descriptor") - - do i = 1, this%n_permutations - call xml_NewElement(xf,"permutation") - call xml_AddAttribute(xf,"i",""//i) - call xml_AddCharacters(xf,""//this%permutations(:,i)//" ") - call xml_EndElement(xf,"permutation") - enddo - - if(this%sparsified) then - do i = 1, this%n_sparseX - call xml_NewElement(xf,"sparseX") - call xml_AddAttribute(xf,"i", ""//i) - call xml_AddAttribute(xf,"alpha", ""//this%alpha(i)) - call xml_AddAttribute(xf,"sparseCutoff", ""//this%sparseCutoff(i)) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - call xml_AddAttribute(xf,"covariance_sparseX_sparseX", ""//this%covarianceDiag_sparseX_sparseX(i)) - endif - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then - call xml_AddAttribute(xf,"sparseX_size", ""//this%sparseX_size(i)) - call xml_AddCharacters(xf, ""//this%sparseX(:this%sparseX_size(i),i)//" ") - elseif (.not. have_sparseX_base_filename) then - if(this%d <= 50) then - call xml_AddCharacters(xf, ""//this%sparseX(:,i)//" ") - else - call xml_AddAttribute(xf,"sliced", "T") - do j = 1, this%d, 50 - j_end = min(j-1+50,this%d) - call xml_NewElement(xf,"sparseX_slice") - call xml_AddAttribute(xf,"start", ""//j) - call xml_AddAttribute(xf,"end", ""//j_end) - call xml_AddCharacters(xf, ""//this%sparseX(j:j_end,i)//" ") - call xml_EndElement(xf,"sparseX_slice") - enddo - endif - endif - call xml_EndElement(xf,"sparseX") - enddo - else - do i = 1, this%n_x - call xml_NewElement(xf,"x") - call xml_AddAttribute(xf,"i", ""//i) - call xml_AddAttribute(xf,"map_x_y", ""//this%map_x_y(i)) - call xml_AddAttribute(xf,"cutoff", ""//this%cutoff(i)) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"x_size", ""//this%x_size(i)) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"covariance_x_x", ""//this%covarianceDiag_x_x(i)) - call xml_AddCharacters(xf, ""//this%x(:,i)//" ") - call xml_EndElement(xf,"x") - enddo - do i = 1, this%n_xPrime - call xml_NewElement(xf,"xPrime") - call xml_AddAttribute(xf,"i", ""//i) - call xml_AddAttribute(xf,"map_xPrime_yPrime", ""//this%map_xPrime_yPrime(i)) - call xml_AddAttribute(xf,"map_xPrime_x", ""//this%map_xPrime_x(i)) - call xml_AddAttribute(xf,"cutoffPrime", ""//this%cutoffPrime(i)) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"xPrime_size", ""//this%xPrime_size(i)) - if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"covariance_xPrime_xPrime", ""//this%covarianceDiag_xPrime_xPrime(i)) - call xml_AddCharacters(xf, ""//this%xPrime(:,i)//" ") - call xml_EndElement(xf,"xPrime") - enddo - endif - - call xml_EndElement(xf,"gpCoordinates") - - endsubroutine gpCoordinates_printXML - - subroutine gpFull_printXML(this,xf,label,error) - type(gpFull), intent(in) :: this - type(xmlf_t), intent(inout) :: xf - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - - integer :: i - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpFull_printXML: object not initialised', error) - endif - - call xml_NewElement(xf,"gpFull") - - if(present(label)) call xml_AddAttribute(xf,"label", trim(label)) - - call xml_AddAttribute(xf,"n_y", ""//this%n_y) - call xml_AddAttribute(xf,"n_yPrime", ""//this%n_yPrime) - call xml_AddAttribute(xf,"n_globalSparseX", ""//this%n_globalSparseX) - call xml_AddAttribute(xf,"n_coordinate", ""//this%n_coordinate) - call xml_AddAttribute(xf,"sparse_jitter", ""//this%sparse_jitter) - - do i = 1, this%n_y - call xml_NewElement(xf,"y") - call xml_AddAttribute(xf,"i", ""//i) - call xml_AddAttribute(xf,"map_y_globalY", ""//this%map_y_globalY(i)) - call xml_AddAttribute(xf,"alpha", ""//this%alpha(this%map_y_globalY(i)) ) - call xml_EndElement(xf,"y") - enddo - - do i = 1, this%n_yPrime - call xml_NewElement(xf,"yPrime") - call xml_AddAttribute(xf,"i", ""//i) - call xml_AddAttribute(xf,"map_yPrime_globalY", ""//this%map_yPrime_globalY(i)) - call xml_AddAttribute(xf,"alpha", ""//this%alpha(this%map_yPrime_globalY(i)) ) - call xml_EndElement(xf,"yPrime") - enddo - - do i = 1, this%n_coordinate - call gpCoordinates_printXML(this%coordinate(i),xf,label=trim(optional_default("",label))//i,error=error) - enddo - - call xml_EndElement(xf,"gpFull") - - endsubroutine gpFull_printXML - - subroutine gpSparse_printXML(this,xf,label,sparseX_base_filename,error) - type(gpSparse), intent(in) :: this - type(xmlf_t), intent(inout) :: xf - character(len=*), intent(in), optional :: label - character(len=*), intent(in), optional :: sparseX_base_filename - integer, intent(out), optional :: error - - integer :: i - - INIT_ERROR(error) - - if( .not. this%initialised ) then - RAISE_ERROR('gpSparse_printXML: object not initialised', error) - endif - - call xml_NewElement(xf,"gpSparse") - - if(present(label)) call xml_AddAttribute(xf,"label", trim(label)) - - call xml_AddAttribute(xf,"n_coordinate", ""//this%n_coordinate) - call xml_AddAttribute(xf,"fitted", ""//this%fitted) - - do i = 1, this%n_coordinate - call gpCoordinates_printXML(this%coordinate(i),xf,label=trim(optional_default("",label))//i,& - sparseX_base_filename=sparseX_base_filename, error=error) - enddo - - call xml_EndElement(xf,"gpSparse") - - endsubroutine gpSparse_printXML - - subroutine gp_write_covariance(this, basename, label) - type(gpSparse), intent(in) :: this - character(*), intent(in) :: basename - character(*),intent(in), optional :: label - - - character(STRING_LENGTH) :: my_label, R_fname - integer :: M - - my_label = optional_default("", "." // trim(label)) - - R_fname = trim(basename) // trim(my_label) - - - - if (this%do_export_R .and. allocated(this%R)) then - M = size(this%R, 1) - call fwrite_array_d(M * M, this%R, trim(R_fname)//C_NULL_CHAR) - end if - end subroutine gp_write_covariance - - - subroutine gpCoordinates_readXML(this,xp,label,error) - type(gpCoordinates), intent(inout), target :: this - type(xml_t), intent(inout) :: xp - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if( this%initialised ) call finalise(this,error) - - parse_in_gpCoordinates = .false. - parse_matched_label = .false. - parse_gpCoordinates => this - parse_gpCoordinates_label = optional_default("",label) - - call initialise(parse_cur_data) - call parse(xp, & - characters_handler = gpCoordinates_characters_handler, & - startElement_handler = gpCoordinates_startElement_handler, & - endElement_handler = gpCoordinates_endElement_handler) - - call finalise(parse_cur_data) - - this%initialised = .true. - - endsubroutine gpCoordinates_readXML - - subroutine gpFull_readXML(this,xp,label,error) - type(gpFull), intent(inout), target :: this - type(xml_t), intent(inout) :: xp - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - - integer :: i - - INIT_ERROR(error) - - if( this%initialised ) call finalise(this,error) - - parse_in_gpFull = .false. - parse_matched_label = .false. - parse_gpFull => this - parse_gpFull_label = optional_default("",label) - - call initialise(parse_cur_data) - - call parse(xp, & - characters_handler = gpFull_characters_handler, & - startElement_handler = gpFull_startElement_handler, & - endElement_handler = gpFull_endElement_handler) - - call finalise(parse_cur_data) - - do i = 1, this%n_coordinate - call gpCoordinates_readXML(this%coordinate(i),xp,label=trim(parse_gpFull_label)//i,error=error) - enddo - - this%initialised = .true. - - endsubroutine gpFull_readXML - - subroutine gpSparse_readXML(this,xp,label,error) - type(gpSparse), intent(inout), target :: this - type(xml_t), intent(inout) :: xp - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - -! integer :: i - - INIT_ERROR(error) - - if( this%initialised ) call finalise(this,error) - - parse_in_gpSparse = .false. - parse_gpSparse => this - parse_matched_label = .false. - parse_gpSparse_label = optional_default("",label) - - call initialise(parse_cur_data) - - call parse(xp, & - characters_handler = gpSparse_characters_handler, & - startElement_handler = gpSparse_startElement_handler, & - endElement_handler = gpSparse_endElement_handler) - - call finalise(parse_cur_data) - -! do i = 1, this%n_coordinate -! call gpCoordinates_readXML(this%coordinate(i),xp,label=trim(parse_gpSparse_label)//i,error=error) -! enddo - - this%initialised = .true. - - endsubroutine gpSparse_readXML - - subroutine gpFull_readXML_string(this,params_str,label,error) - type(gpFull), intent(inout), target :: this - character(len=*), intent(in) :: params_str - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - - type(xml_t) :: xp - - INIT_ERROR(error) - - call open_xml_string(xp, params_str) - call gp_readXML(this,xp,label,error) - call close_xml_t(xp) - - endsubroutine gpFull_readXML_string - - subroutine gpCoordinates_readXML_string(this,params_str,label,error) - type(gpCoordinates), intent(inout), target :: this - character(len=*), intent(in) :: params_str - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - - type(xml_t) :: xp - - INIT_ERROR(error) - - call open_xml_string(xp, params_str) - call gp_readXML(this,xp,label,error) - call close_xml_t(xp) - - endsubroutine gpCoordinates_readXML_string - - subroutine gpSparse_readXML_string(this,params_str,label,error) - type(gpSparse), intent(inout), target :: this - character(len=*), intent(in) :: params_str - character(len=*), intent(in), optional :: label - integer, intent(out), optional :: error - - type(xml_t) :: xp - integer :: i - - INIT_ERROR(error) - - call open_xml_string(xp, params_str) - call gp_readXML(this,xp,label,error) - call close_xml_t(xp) - - do i = 1, this%n_coordinate - call gp_readXML(this%coordinate(i),params_str,label=trim(parse_gpSparse_label)//i,error=error) - call gpCoordinates_precalculate_sparse(this%coordinate(i)) - enddo - - endsubroutine gpSparse_readXML_string - - subroutine gpCoordinates_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - real(dp) :: delta, f0 - integer :: status, d, n_sparseX, n_x, n_xPrime, n_permutations, i, x_size_max, xPrime_size_max, sparseX_size_max, covariance_type - logical :: sparsified, exist_sparseX_filename - character(len=32) :: sparseX_md5sum - character(len=1024) :: value - - if(name == 'gpCoordinates') then ! new GP_data - if(parse_in_gpCoordinates) then - call system_abort("gpCoordinates_startElement_handler entered gpCoordinates with parse_in_gpCoordinates true. Probably a bug in FoX (4.0.1, e.g.)") - endif - - if(parse_matched_label) return ! we already found an exact match for this label - - call GP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if(len(trim(parse_gpCoordinates_label)) > 0) then ! we were passed in a label - if(trim(value) == trim(parse_gpCoordinates_label)) then - parse_matched_label = .true. - parse_in_gpCoordinates = .true. - else ! no match - parse_in_gpCoordinates = .false. - endif - else ! no label passed in - parse_in_gpCoordinates = .true. - endif - - if(parse_in_gpCoordinates) then - if(parse_gpCoordinates%initialised) call finalise(parse_gpCoordinates) - - call GP_FoX_get_value(attributes, 'dimensions', value, status) - if (status == 0) then - read (value,*) d - else - call system_abort("gpCoordinates_startElement_handler did not find the dimensions attribute.") - endif - - call GP_FoX_get_value(attributes, 'signal_variance', value, status) - if (status == 0) then - read (value,*) delta - else - call system_abort("gpCoordinates_startElement_handler did not find the signal_variance attribute.") - endif - - call GP_FoX_get_value(attributes, 'signal_mean', value, status) - if (status == 0) then - read (value,*) f0 - else - call system_abort("gpCoordinates_startElement_handler did not find the signal_variance attribute.") - endif - - - call GP_FoX_get_value(attributes, 'sparsified', value, status) - if (status == 0) then - read (value,*) sparsified - else - call system_abort("gpCoordinates_startElement_handler did not find the sparsified attribute.") - endif - - call GP_FoX_get_value(attributes, 'n_permutations', value, status) - if (status == 0) then - read (value,*) n_permutations - else - call system_abort("gpCoordinates_startElement_handler did not find the n_permutations attribute.") - endif - - call GP_FoX_get_value(attributes, 'covariance_type', value, status) - if (status == 0) then - read (value,*) covariance_type - else - call system_abort("gpCoordinates_startElement_handler did not find the covariance_type attribute.") - covariance_type = COVARIANCE_NONE - endif - - call GP_FoX_get_value(attributes, 'zeta', value, status) - if (status == 0) then - if (covariance_type == COVARIANCE_DOT_PRODUCT) then - read (value,*) parse_gpCoordinates%zeta - else - call system_abort("gpCoordinates_startElement_handler found zeta attribute but the covariance is not & - dot product.") - endif - else - if (covariance_type == COVARIANCE_DOT_PRODUCT) then - call print_warning("gpCoordinates_startElement_handler: covariance type is dot product, but no & - zeta attribute is present. This may mean an XML generated by an older version. If found, the single & - value from the theta element will be used, to ensure backwards compatibility") - endif - endif - - call GP_FoX_get_value(attributes, 'x_size_max', value, status) - if (status == 0) then - read (value,*) x_size_max - else - if ((covariance_type == COVARIANCE_BOND_REAL_SPACE) .and. (.not. sparsified)) call system_abort("gpCoordinates_startElement_handler did not find the x_size_max attribute.") - x_size_max = 0 - endif - - call GP_FoX_get_value(attributes, 'xPrime_size_max', value, status) - if (status == 0) then - read (value,*) xPrime_size_max - else - if ((covariance_type == COVARIANCE_BOND_REAL_SPACE) .and. (.not. sparsified)) call system_abort("gpCoordinates_startElement_handler did not find the xPrime_size_max attribute.") - xPrime_size_max = 0 - endif - - call GP_FoX_get_value(attributes, 'sparseX_size_max', value, status) - if (status == 0) then - read (value,*) sparseX_size_max - else - if ((covariance_type == COVARIANCE_BOND_REAL_SPACE) .and. sparsified) call system_abort("gpCoordinates_startElement_handler did not find the sparseX_size_max attribute.") - sparseX_size_max = 0 - endif - - if(sparsified) then - call GP_FoX_get_value(attributes, 'n_sparseX', value, status) - if (status == 0) then - read (value,*) n_sparseX - else - call system_abort("gpCoordinates_startElement_handler did not find the n_sparseX attribute.") - endif - - if (covariance_type == COVARIANCE_BOND_REAL_SPACE) then - call gpCoordinates_setParameters_sparse(parse_gpCoordinates,d,n_sparseX,delta,f0,covariance_type=covariance_type,sparseX_size_max=sparseX_size_max) - else - call gpCoordinates_setParameters_sparse(parse_gpCoordinates,d,n_sparseX,delta,f0, covariance_type=covariance_type) - call GP_FoX_get_value(attributes, 'sparseX_filename', value, status) - if (status == 0) then - inquire(file=trim(value),exist=exist_sparseX_filename) - if(.not.exist_sparseX_filename) call system_abort("gpCoordinates_startElement_handler: sparseX file "//trim(value)//" does not exist.") - - call quip_md5sum(trim(value),sparseX_md5sum) - if( len_trim(sparseX_md5sum) == 0 ) call print_warning("gpCoordinates_startElement_handler: could not obtain md5 sum of sparse file, will not be able & - & to verify consistency with the XML") - - call fread_array_d(size(parse_gpCoordinates%sparseX), parse_gpCoordinates%sparseX(1,1), trim(value)//C_NULL_CHAR) - parse_sparseX_separate_file = .true. - else - parse_sparseX_separate_file = .false. - endif - - if(parse_sparseX_separate_file) then - call GP_FoX_get_value(attributes, 'sparseX_md5sum', value, status) - if (status == 0) then - if( len_trim(value) /= 32 ) call print_warning("gpCoordinates_startElement_handler: recorded md5 sum in the XML is not 32 characters. & - & This could have happened because the md5 tool was not available when the XML was written.") - if( len_trim(value) > 0 .and. len_trim(sparseX_md5sum) > 0 .and. trim(sparseX_md5sum) /= trim(value) ) then - call system_abort("gpCoordinates_startElement_handler: md5 check sum failed. Sparse file ("//sparseX_md5sum// & - ") does not match record in XML ("//trim(value)//")") - endif - endif - endif - endif - else - call GP_FoX_get_value(attributes, 'n_x', value, status) - if (status == 0) then - read (value,*) n_x - else - call system_abort("gpCoordinates_startElement_handler did not find the n_x attribute.") - endif - - call GP_FoX_get_value(attributes, 'n_xPrime', value, status) - if (status == 0) then - read (value,*) n_xPrime - else - call system_abort("gpCoordinates_startElement_handler did not find the n_xPrime attribute.") - endif - - if (covariance_type == COVARIANCE_BOND_REAL_SPACE) then - call gpCoordinates_setParameters(parse_gpCoordinates,d,n_x,n_xPrime,delta,f0,covariance_type=covariance_type,x_size_max=x_size_max,xPrime_size_max=xPrime_size_max) - else - call gpCoordinates_setParameters(parse_gpCoordinates,d,n_x,n_xPrime,delta,f0,covariance_type=covariance_type) - endif - endif - - if (covariance_type == COVARIANCE_BOND_REAL_SPACE .or. covariance_type == COVARIANCE_DOT_PRODUCT) then - allocate(parse_in_permutations(1,n_permutations)) - else - allocate(parse_in_permutations(d,n_permutations)) - endif - - endif - - elseif(parse_in_gpCoordinates .and. name == 'theta') then - call zero(parse_cur_data) - elseif(parse_in_gpCoordinates .and. name == 'descriptor') then - call zero(parse_cur_data) - elseif(parse_in_gpCoordinates .and. name == 'permutation') then - - call GP_FoX_get_value(attributes, 'i', value, status) - if (status == 0) then - read (value,*) i - else - call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") - endif - - parse_i_permutation = i - - call zero(parse_cur_data) - - elseif(parse_in_gpCoordinates .and. name == 'sparseX') then - - parse_in_sparseX = .true. - - if( .not. parse_gpCoordinates%sparsified ) then - call system_abort("gpCoordinates_startElement_handler: not sparsified data and sparseX element found.") - endif - - call GP_FoX_get_value(attributes, 'i', value, status) - if (status == 0) then - read (value,*) i - else - call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") - endif - - call GP_FoX_get_value(attributes, 'alpha', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%alpha(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the alpha attribute.") - endif - - call GP_FoX_get_value(attributes, 'sparseCutoff', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%sparseCutoff(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the cutoff attribute.") - endif - - call GP_FoX_get_value(attributes, 'sliced', value, status) - if (status == 0) then - read (value,*) parse_sliced - else - parse_sliced = .false. - endif - - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call GP_FoX_get_value(attributes, 'sparseX_size', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%sparseX_size(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the sparseX_size attribute.") - endif - endif - - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call GP_FoX_get_value(attributes, 'covariance_sparseX_sparseX', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%covarianceDiag_sparseX_sparseX(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the covariance_sparseX_sparseX attribute.") - endif - endif - - parse_i_sparseX = i - - call zero(parse_cur_data) - - elseif(parse_in_gpCoordinates .and. parse_in_sparseX .and. name == 'sparseX_slice') then - - call GP_FoX_get_value(attributes, 'start', value, status) - if (status == 0) then - read (value,*) parse_slice_start - else - call system_abort("gpCoordinates_startElement_handler did not find the start attribute.") - endif - - call GP_FoX_get_value(attributes, 'end', value, status) - if (status == 0) then - read (value,*) parse_slice_end - else - call system_abort("gpCoordinates_startElement_handler did not find the end attribute.") - endif - - call zero(parse_cur_data) - elseif(parse_in_gpCoordinates .and. name == 'x') then - if( parse_gpCoordinates%sparsified ) then - call system_abort("gpCoordinates_startElement_handler: sparsified=T but x element found.") - endif - - call GP_FoX_get_value(attributes, 'i', value, status) - if (status == 0) then - read (value,*) i - else - call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") - endif - - call GP_FoX_get_value(attributes, 'map_x_y', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%map_x_y(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the map_x_y attribute.") - endif - - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call GP_FoX_get_value(attributes, 'x_size', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%x_size(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the x_size attribute.") - endif - endif - - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call GP_FoX_get_value(attributes, 'covariance_x_x', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%covarianceDiag_x_x(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the covariance_x_x attribute.") - endif - endif - - parse_i_x = i - - call zero(parse_cur_data) - - elseif(parse_in_gpCoordinates .and. name == 'xPrime') then - if( parse_gpCoordinates%sparsified ) then - call system_abort("gpCoordinates_startElement_handler: sparsified=T but xPrime element found.") - endif - - call GP_FoX_get_value(attributes, 'i', value, status) - if (status == 0) then - read (value,*) i - else - call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") - endif - - call GP_FoX_get_value(attributes, 'map_xPrime_yPrime', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%map_xPrime_yPrime(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the map_xPrime_yPrime attribute.") - endif - - call GP_FoX_get_value(attributes, 'map_xPrime_x', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%map_xPrime_x(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the map_xPrime_x attribute.") - endif - - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call GP_FoX_get_value(attributes, 'xPrime_size', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%xPrime_size(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the xPrime_size attribute.") - endif - endif - - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - call GP_FoX_get_value(attributes, 'covariance_xPrime_xPrime', value, status) - if (status == 0) then - read (value,*) parse_gpCoordinates%covarianceDiag_xPrime_xPrime(i) - else - call system_abort("gpCoordinates_startElement_handler did not find the covariance_xPrime_xPrime attribute.") - endif - endif - - parse_i_xPrime = i - - call zero(parse_cur_data) - - endif - - endsubroutine gpCoordinates_startElement_handler - - subroutine gpCoordinates_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if(parse_in_gpCoordinates) then - if(name == 'gpCoordinates') then - call gpCoordinates_setPermutations(parse_gpCoordinates,parse_in_permutations) - deallocate(parse_in_permutations) - parse_in_gpCoordinates = .false. - elseif(name == 'theta') then - !val = string(parse_cur_data) - !read(val,*) parse_gpCoordinates%theta - call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%theta) - if( parse_gpCoordinates%covariance_type == COVARIANCE_DOT_PRODUCT ) then - parse_gpCoordinates%zeta = parse_gpCoordinates%theta(1) - parse_gpCoordinates%theta(1) = 0.0_dp - call print_warning("gpCoordinates_endElement_handler: dot product covariance is used, but found a theta element & - in the XML. This may be a sign of an XML generated by an older version. The first and only element of theta will & - be used as zeta.") - endif - elseif(name == 'descriptor') then - parse_gpCoordinates%descriptor_str = parse_cur_data - elseif(name == 'permutation') then - - if( parse_i_permutation > size(parse_in_permutations,2) ) then - call system_abort("gpCoordinates_endElement_handler: parse_i_permutation ("//parse_i_permutation//") greater than n_permutations ("//size(parse_in_permutations,2)//")") - endif - - !val = string(parse_cur_data) - !read(val,*) parse_in_permutations(:,parse_i_permutation) - call string_to_numerical(string(parse_cur_data),parse_in_permutations(:,parse_i_permutation)) - elseif(name == 'sparseX') then - - if( .not. allocated(parse_gpCoordinates%sparseX) ) then - call system_abort("gpCoordinates_endElement_handler: sparseX not allocated") - endif - - if( parse_i_sparseX > parse_gpCoordinates%n_sparseX ) then - call system_abort("gpCoordinates_endElement_handler: parse_i_sparseX ("//parse_i_sparseX//") greater than n_sparseX ("//parse_gpCoordinates%n_sparseX//")") - endif - - !val = string(parse_cur_data) - !read(val,*) parse_gpCoordinates%sparseX(:,parse_i_sparseX) - if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then - parse_gpCoordinates%sparseX(:,parse_i_sparseX) = 0.0_dp - call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%sparseX(:parse_gpCoordinates%sparseX_size(parse_i_sparseX),parse_i_sparseX)) - else - if(.not. parse_sparseX_separate_file .and. .not. parse_sliced) call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%sparseX(:,parse_i_sparseX)) - endif - - parse_in_sparseX = .false. - elseif(name == 'sparseX_slice') then - if(parse_slice_start < 1) then - call system_abort("gpCoordinates_endElement_handler: slice start less than 1") - endif - - if(parse_slice_end > parse_gpCoordinates%d) then - call system_abort("gpCoordinates_endElement_handler: slice start greater than dimension") - endif - - if(.not. parse_sparseX_separate_file .and. parse_sliced) call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%sparseX(parse_slice_start:parse_slice_end,parse_i_sparseX)) - elseif(name == 'x') then - - if( .not. allocated(parse_gpCoordinates%x) ) then - call system_abort("gpCoordinates_endElement_handler: x not allocated") - endif - - if( parse_i_x > parse_gpCoordinates%n_x ) then - call system_abort("gpCoordinates_endElement_handler: parse_i_x ("//parse_i_x//") greater than n_x ("//parse_gpCoordinates%n_x//")") - endif - - !val = string(parse_cur_data) - !read(val,*) parse_gpCoordinates%x(:,parse_i_x) - call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%x(:,parse_i_x)) - elseif(name == 'xPrime') then - - if( .not. allocated(parse_gpCoordinates%xPrime) ) then - call system_abort("gpCoordinates_endElement_handler: xPrime not allocated") - endif - - if( parse_i_xPrime > parse_gpCoordinates%n_xPrime ) then - call system_abort("gpCoordinates_endElement_handler: parse_i_xPrime ("//parse_i_xPrime//") greater than n_xPrime ("//parse_gpCoordinates%n_xPrime//")") - endif - - !val = string(parse_cur_data) - !read(val,*) parse_gpCoordinates%xPrime(:,parse_i_xPrime) - call string_to_numerical(string(parse_cur_data), parse_gpCoordinates%xPrime(:,parse_i_xPrime)) - endif - endif - - endsubroutine gpCoordinates_endElement_handler - - subroutine gpCoordinates_characters_handler(in) - character(len=*), intent(in) :: in - - if(parse_in_gpCoordinates) then - call concat(parse_cur_data, in, keep_lf=.false.,lf_to_whitespace=.true.) - endif - endsubroutine gpCoordinates_characters_handler - - subroutine gpFull_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status, n_y, n_yPrime, n_coordinate, i - real(dp) :: sparse_jitter - character(len=1024) :: value - - if(name == 'gpFull') then ! new GP_data - if(parse_in_gpFull) then - call system_abort("gpFull_startElement_handler entered gpFull with parse_in_gpFull true. Probably a bug in FoX (4.0.1, e.g.)") - endif - - if(parse_matched_label) return ! we already found an exact match for this label - - call GP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if(len(trim(parse_gpFull_label)) > 0) then ! we were passed in a label - if(trim(value) == trim(parse_gpFull_label)) then - parse_matched_label = .true. - parse_in_gpFull = .true. - else ! no match - parse_in_gpFull = .false. - endif - else ! no label passed in - parse_in_gpFull = .true. - endif - - if(parse_in_gpFull) then - if(parse_gpFull%initialised) call finalise(parse_gpFull) - - call GP_FoX_get_value(attributes, 'n_y', value, status) - if (status == 0) then - read (value,*) n_y - else - call system_abort("gpFull_startElement_handler did not find the n_y attribute.") - endif - - call GP_FoX_get_value(attributes, 'n_yPrime', value, status) - if (status == 0) then - read (value,*) n_yPrime - else - call system_abort("gpFull_startElement_handler did not find the n_yPrime attribute.") - endif - - call GP_FoX_get_value(attributes, 'n_coordinate', value, status) - if (status == 0) then - read (value,*) n_coordinate - else - call system_abort("gpFull_startElement_handler did not find the n_coordinate attribute.") - endif - - call GP_FoX_get_value(attributes, 'sparse_jitter', value, status) - if (status == 0) then - read (value,*) sparse_jitter - else - call print_warning("gpFull_startElement_handler did not find the sparse_jitter attribute, using default value 1.0e-5.") - sparse_jitter = 1.0e-5_dp - endif - call gpFull_setParameters(parse_gpFull,n_coordinate, n_y, n_yPrime, sparse_jitter) - - endif - - elseif(parse_in_gpFull .and. name == 'y') then - - call GP_FoX_get_value(attributes, 'i', value, status) - if (status == 0) then - read (value,*) i - else - call system_abort("gpFull_startElement_handler did not find the i attribute.") - endif - - call GP_FoX_get_value(attributes, 'map_y_globalY', value, status) - if (status == 0) then - read (value,*) parse_gpFull%map_y_globalY(i) - else - call system_abort("gpFull_startElement_handler did not find the map_y_globalY attribute.") - endif - - call GP_FoX_get_value(attributes, 'alpha', value, status) - if (status == 0) then - read (value,*) parse_gpFull%alpha(parse_gpFull%map_y_globalY(i)) - else - call system_abort("gpFull_startElement_handler did not find the alpha attribute.") - endif - - elseif(parse_in_gpFull .and. name == 'yPrime') then - - call GP_FoX_get_value(attributes, 'i', value, status) - if (status == 0) then - read (value,*) i - else - call system_abort("gpFull_startElement_handler did not find the i attribute.") - endif - - call GP_FoX_get_value(attributes, 'map_yPrime_globalY', value, status) - if (status == 0) then - read (value,*) parse_gpFull%map_yPrime_globalY(i) - else - call system_abort("gpFull_startElement_handler did not find the map_yPrime_globalY attribute.") - endif - - call GP_FoX_get_value(attributes, 'alpha', value, status) - if (status == 0) then - read (value,*) parse_gpFull%alpha(parse_gpFull%map_yPrime_globalY(i)) - else - call system_abort("gpFull_startElement_handler did not find the alpha attribute.") - endif - - endif - - endsubroutine gpFull_startElement_handler - - subroutine gpFull_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if(parse_in_gpFull) then - if(name == 'gpFull') then - parse_in_gpFull = .false. - endif - elseif(name == 'y') then - - elseif(name == 'yPrime') then - - endif - - endsubroutine gpFull_endElement_handler - - subroutine gpFull_characters_handler(in) - character(len=*), intent(in) :: in - - if(parse_in_gpFull) then - call concat(parse_cur_data, in, keep_lf=.false.,lf_to_whitespace=.true.) - endif - endsubroutine gpFull_characters_handler - - subroutine gpSparse_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status, n_coordinate - character(len=1024) :: value - - if(name == 'gpSparse') then ! new GP_data - if(parse_in_gpSparse) then - call system_abort("gpSparse_startElement_handler entered gpSparse with parse_in_gpSparse true. Probably a bug in FoX (4.0.1, e.g.)") - endif - - if(parse_matched_label) return ! we already found an exact match for this label - - call GP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if(len(trim(parse_gpSparse_label)) > 0) then ! we were passed in a label - if(trim(value) == trim(parse_gpSparse_label)) then - parse_matched_label = .true. - parse_in_gpSparse = .true. - else ! no match - parse_in_gpSparse = .false. - endif - else ! no label passed in - parse_in_gpSparse = .true. - endif - - if(parse_in_gpSparse) then - if(parse_gpSparse%initialised) call finalise(parse_gpSparse) - - call GP_FoX_get_value(attributes, 'n_coordinate', value, status) - if (status == 0) then - read (value,*) n_coordinate - else - call system_abort("gpSparse_startElement_handler did not find the n_coordinate attribute.") - endif - call gpSparse_setParameters(parse_gpSparse,n_coordinate) - - call GP_FoX_get_value(attributes, 'fitted', value, status) - if (status == 0) then - read (value,*) parse_gpSparse%fitted - else - parse_gpSparse%fitted = .true. ! for backward compatibility - endif - - endif - - endif - - endsubroutine gpSparse_startElement_handler - - subroutine gpSparse_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if(parse_in_gpSparse) then - if(name == 'gpSparse') then - parse_in_gpSparse = .false. - endif - endif - - endsubroutine gpSparse_endElement_handler - - subroutine gpSparse_characters_handler(in) - character(len=*), intent(in) :: in - - if(parse_in_gpSparse) then - call concat(parse_cur_data, in, keep_lf=.false.,lf_to_whitespace=.true.) - endif - endsubroutine gpSparse_characters_handler - - subroutine gp_FoX_get_value(attributes, key, val, status) - type(dictionary_t), intent(in) :: attributes - character(len=*), intent(in) :: key - character(len=*), intent(inout) :: val - integer, intent(out), optional :: status - - if (HasKey(attributes,key)) then - val = GetValue(attributes, trim(key)) - if (present(status)) status = 0 - else - val = "" - if (present(status)) status = 1 - endif - end subroutine gp_FoX_get_value - -end module gp_predict_module diff --git a/make_permutations_noncommercial_v2.f95 b/make_permutations_noncommercial_v2.f95 deleted file mode 100644 index 329b641c..00000000 --- a/make_permutations_noncommercial_v2.f95 +++ /dev/null @@ -1,733 +0,0 @@ -!!$ -!!$------------Permutation Generator---Alan Nichol--------------------------------- - -!!$ Generate permutations of the interatomic distance vector of -!!$ a number of atoms. Information about the symmetries present in the cluster -!!$ is specified as an array called 'equivalents' - this is generated automatically -!!$ when a permutation_data_type is initialised with one or more 'signatures' which -!!$ are integer arrays of the atomic numbers. -!!$ -!!$ For systems where not all atoms of the same Z are equivalent, the symmetries can -!!$ be specified beforehand by passing an equivalents array to permutation_data_initialise -!!$ An example for toluene would be the following: -!!$ -!!$ Toluene : C_6 H_5 - CH_3 -!!$ -!!$ Atoms in order -!!$ C1 C2 H C3 H C4 H C5 H C6 H C7 H H H -!!$ -!!$ where C1 is the tertiary carbon and C2-C6 go in order about the benzene ring -!!$ C7 is the methyl carbon -!!$ -!!$ -!!$ 15 Atoms in total, and two permutational symmetries. So equivalents array is 2X15 -!!$ Symmetry of the 3 methyl hydrogens is specified by the first row: -!!$ ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 11, 111) -!!$ -!!$ And the symmetry of the benzene ring is specified by the second row: -!!$ ( 0, 1, 2, 3, 4, 0, 0, 33, 44, 11, 22, 0, 0 ,0 ,0) -!!$ -!!$-------------------------------------------------------------------------------- -!!$-------------------------------------------------------------------------------- - - -#include "error.inc" - -module permutation_maker_module - use error_module - use system_module, only : dp, print, optional_default, system_timer, operator(//) - - implicit none - -type permutation_data_type - integer :: perm_number, n_perms - integer, dimension(:), allocatable :: signature_one, signature_two, signature_three, counter, rank, dist_vec !dist_vec is internal name for descriptor - integer, dimension(:,:), allocatable :: dist_vec_permutations - integer, dimension(:,:,:), allocatable :: perm_array - logical :: internal_swaps_only, initialised -endtype permutation_data_type - -!% Overloaded assigment operators for permutation data objects. -private :: permutation_data_assignment -interface assignment(=) - module procedure permutation_data_assignment -end interface assignment(=) - -contains - -subroutine permutation_data_assignment(to,from) -!this is the slow way to copy this object, because it goes through the motions of initialisation again -! call permutation_data_copy for a much faster alternative - type(permutation_data_type), intent(inout) :: to - type(permutation_data_type), intent(in) :: from - - ! We do not fail if *from* is unitialised, since overloaded operator - ! routines are outside scope of error handling mechanism. - if(.not. from%initialised) then - call permutation_data_finalise(to) - return - end if - - call permutation_data_initialise(to,signature_one=from%signature_one,signature_two=from%signature_two,signature_three=from%signature_three,internal_swaps_only=from%internal_swaps_only) - -end subroutine permutation_data_assignment - -subroutine permutation_data_copy(to,from) - type(permutation_data_type), intent(inout) :: to - type(permutation_data_type), intent(in) :: from - - if(.not. from%initialised) then - call permutation_data_finalise(to) - return - end if - - - allocate(to%counter(size(from%counter))) - allocate(to%rank(size(from%rank))) - allocate(to%dist_vec(size(from%dist_vec))) - allocate(to%dist_vec_permutations(size(from%dist_vec_permutations,1),size(from%dist_vec_permutations,2))) - allocate(to%perm_array(size(from%perm_array,1),size(from%perm_array,2),size(from%perm_array,3))) - - if (allocated(from%signature_one)) then - allocate(to%signature_one(size(from%signature_one))) - to%signature_one = from%signature_one - if (allocated(from%signature_two)) then - allocate(to%signature_two(size(from%signature_two))) - to%signature_two = from%signature_two - if (allocated(from%signature_three)) then - allocate(to%signature_three(size(from%signature_three))) - to%signature_three = from%signature_three - end if - end if - end if - to%counter = from%counter - to%rank = from%rank - to%dist_vec = from%dist_vec - to%dist_vec_permutations = from%dist_vec_permutations - to%perm_array = from%perm_array - - to%n_perms = from%n_perms - to%internal_swaps_only = from%internal_swaps_only - - to%initialised = .true. - to%perm_number = 1 - -end subroutine permutation_data_copy - -subroutine equivalents_row_atoms(equivalents_row,signature,offset,N) - implicit none - integer, dimension(:), allocatable, intent(inout) :: equivalents_row - integer, dimension(:), intent(in) :: signature - integer, dimension(:), allocatable :: scratch_row, equivalents_temp - integer, intent(in) :: offset, N - integer :: z_index, i, j, repeats - - allocate(scratch_row(N)) - allocate(equivalents_temp(1)) - - do z_index=1,maxval(signature) - repeats=0 - scratch_row=0 - do i=1,size(signature) - if (signature(i) == z_index) then - do j=repeats,0,-1 - scratch_row(i+offset)=scratch_row(i+offset)+10**(j) - end do - repeats = repeats+1 - end if - end do - if (repeats .le. 1) cycle - - if (.not. allocated(equivalents_row)) then - allocate(equivalents_row(N)) - equivalents_row=scratch_row - else - deallocate(equivalents_temp) - allocate(equivalents_temp(size(equivalents_row))) - equivalents_temp=equivalents_row - deallocate(equivalents_row) - allocate(equivalents_row(size(equivalents_temp)+N)) - equivalents_row=(/equivalents_temp,scratch_row/) - end if - end do - -end subroutine equivalents_row_atoms - -subroutine equivalents_row_monomers(equivalents_row,N,signature,pos_a,pos_b,pos_c) - - integer,dimension(:), allocatable, intent(inout) :: equivalents_row - integer, intent(in) :: N, pos_a, pos_b - integer, intent(in), optional :: pos_c - integer :: i - integer, dimension(:), intent(in) :: signature - integer, dimension(:), allocatable :: scratch_row, equivalents_temp - - allocate(scratch_row(N)) - allocate(equivalents_temp(1)) - scratch_row=0 - - do i=1,size(signature) - scratch_row(i+pos_a) = i - scratch_row(i+pos_b) = i*11 - if (present(pos_c)) then - scratch_row(i+pos_c) = i*111 - end if - end do - - if (.not. allocated(equivalents_row)) then - allocate(equivalents_row(N)) - equivalents_row=scratch_row - else - deallocate(equivalents_temp) - allocate(equivalents_temp(size(equivalents_row))) - equivalents_temp=equivalents_row - deallocate(equivalents_row) - allocate(equivalents_row(size(equivalents_temp)+N)) - equivalents_row=(/equivalents_temp,scratch_row/) - end if - -end subroutine equivalents_row_monomers - -subroutine permutation_data_initialise(this,equivalents_input,signature_one,signature_two,signature_three,internal_swaps_only,error) - ! better make sure that all these optional things are fed in as key=value, because relying on ordering is asking for trouble - implicit none - type(permutation_data_type) :: this - integer, dimension(:), allocatable :: counter, rank, dist_vec, equivalents_row, scratch_row, & - equivalents_temp, atoms, group - integer, dimension(:), allocatable :: signature - integer, dimension(:), optional :: signature_one, signature_two, signature_three -! integer, dimension(:) :: signature_one - integer, dimension(:,:), optional :: equivalents_input - integer, dimension(:,:), allocatable :: group_array, dist_vec_permutations, equivalents - integer, dimension(:,:,:), allocatable :: perm_array - integer, optional, intent(out) :: error - integer :: repeats, num_groups, N, dist_vec_n_perms, i,j,z_index,max_rank,num_distances, & - num_perms, offset_one, offset_two, offset_three, n_atoms_one, n_atoms_two, n_atoms_three - logical, optional :: internal_swaps_only - logical :: two_monomers_given, three_monomers_given, my_internal_swaps_only - real(dp) :: cutoff - - INIT_ERROR(error) - - call permutation_data_finalise(this) - - - two_monomers_given=.false. - three_monomers_given=.false. - - ! automatic generation of equivalents array based on atomic numbers - if (present(equivalents_input)) then - if (present(signature_one)) then - RAISE_ERROR('permutation_data_initialise: mixing of automatically generated permutations and pre-specified symmetries not well defined', error) - end if - N= size(equivalents_input,2) - num_groups = size(equivalents_input,1) - allocate(equivalents(num_groups,N)) - equivalents = equivalents_input - else - if (.not. present(signature_one)) then - RAISE_ERROR('permutation_data_initialise doesnt know which permutations to do, provide a signature or equivalents array', error) - end if - - n_atoms_one=size(signature_one) - if(present(signature_two)) then - if ( size(signature_two) .ge. 1) then - two_monomers_given= .true. - n_atoms_two=size(signature_two) - if(present(signature_three)) then - if ( size(signature_three) .ge. 1) then - three_monomers_given= .true. - n_atoms_three=size(signature_three) - end if - end if - end if - end if - my_internal_swaps_only = optional_default(.true., internal_swaps_only) - - if (three_monomers_given) then - N = size(signature_one)+size(signature_two)+size(signature_three) - else if (two_monomers_given) then - N = size(signature_one)+size(signature_two) - else - N = size(signature_one) - end if - - - allocate(scratch_row(N)) - allocate(equivalents_temp(1)) - if (two_monomers_given .and. .not. three_monomers_given) then - if (n_atoms_one .eq. n_atoms_two) then - if (count(signature_one .ne. signature_two) .eq. 0) then - offset_one=0 - offset_two=size(signature_one) - call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two) - end if - end if - else if (three_monomers_given) then - if (n_atoms_one .eq. n_atoms_two) then - if (count(signature_one .ne. signature_two) .eq. 0) then - ! one and two are equivalent - if (n_atoms_one .eq. n_atoms_three) then - if (count(signature_one .ne. signature_three) .eq. 0) then - ! all three are equivalent - offset_one=0 - offset_two=size(signature_one) - offset_three =size(signature_one)+size(signature_two) - call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two,offset_three) - end if - else - ! only one and two are equivalent - offset_one=0 - offset_two=size(signature_one) - call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two) - end if - end if - else if (n_atoms_one .eq. n_atoms_three) then - if (count(signature_one .ne. signature_three) .eq. 0) then - ! only one and three are equivalent - offset_one=0 - offset_two=size(signature_one)+size(signature_two) - call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two) - end if - else if (n_atoms_two .eq. n_atoms_three) then - if (count(signature_two .ne. signature_three) .eq. 0) then - ! only two and three are equivalent - offset_one=size(signature_one) - offset_two=size(signature_one)+size(signature_two) - call equivalents_row_monomers(equivalents_row,N,signature_two,offset_one,offset_two) - end if - end if - end if - - ! if more than one signature is given, and swapping atoms between monomers is allowed - ! then the signatures get concatenated to 'signature'. Otherwise 'signature' is just set - ! to refer to signature_one - if(two_monomers_given) then - if (my_internal_swaps_only) then - allocate(signature(size(signature_one))) - signature = signature_one - else if (three_monomers_given) then - allocate(signature(size(signature_one)+size(signature_two)+size(signature_three))) - signature = (/signature_one,signature_two,signature_three/) - else - allocate(signature(size(signature_one)+size(signature_two))) - signature = (/signature_one,signature_two/) - end if - else - allocate(signature(size(signature_one))) - signature = signature_one - end if - - offset_one=0 - - call equivalents_row_atoms(equivalents_row,signature,offset_one,N) - if (two_monomers_given .and. my_internal_swaps_only) then - offset_one=size(signature) - call equivalents_row_atoms(equivalents_row,signature_two,offset_one,N) - if (three_monomers_given .and. my_internal_swaps_only) then - offset_one =size(signature)+size(signature_two) - call equivalents_row_atoms(equivalents_row,signature_three,offset_one,N) - end if - end if - - if (.not. allocated(equivalents_row)) then - num_groups=0 ! only identity permutation - else - num_groups=size(equivalents_row)/N - allocate(equivalents(num_groups,N)) - ! make the equivalents array - equivalents =transpose(reshape(equivalents_row,(/ size(equivalents, 2), size(equivalents, 1) /))) - endif - - end if - -!!$write(*,*) 'equivalents array' -!!$ do i=1,size(equivalents,1) -!!$ write(*,*) equivalents(i,:) -!!$ end do - - - - -!--------- Further Array allocations and Initialisation --------------------------! - allocate(atoms(N)) - allocate(group(N)) - do i=1,size(atoms) - atoms(i)=i - end do - - num_distances = N*(N-1)/2 - allocate(dist_vec(num_distances)) - - allocate(counter(num_groups)) - allocate(rank(num_groups)) - - !make rank vector - do i=1,num_groups - group(:) = equivalents(i,:) - num_perms = num_group_perms(group) - rank(i) = num_perms - end do - - - max_rank = maxval(rank) - - !get total number of permutations - dist_vec_n_perms = 1 - do i=1,size(rank) - dist_vec_n_perms = dist_vec_n_perms*rank(i) - end do - - !initialise counter - counter=1 - - allocate(dist_vec_permutations(num_distances,dist_vec_n_perms)) - allocate(group_array(max_rank,N)) - allocate(perm_array(num_groups,N,max_rank)) - - !initialise arrays permutations to zero - perm_array = 0 - dist_vec_permutations=0 - - -!-------------------------------------------------------------------------! -!make 2D array of permutations of each group and add to 3D array perm_array -!-------------------------------------------------------------------------! - do i = 1,num_groups - group(:) = equivalents(i,:) - group_array = permute_atoms(atoms,group,N,max_rank)!this padded with zeroes in case group is of less than max_rank - do j=1,size(group_array, 1) - perm_array(i,:,j) = group_array(j,:) - end do - end do - - -!-------------------------------------------------------------------------! -!Now assign relevant stuff to the permutation_data_type -!-------------------------------------------------------------------------! - - - if (present(signature_one)) then - allocate(this%signature_one(size(signature_one))) - this%signature_one=signature_one - end if - if (two_monomers_given) then - allocate(this%signature_two(size(signature_two))) - this%signature_two=signature_two - end if - if (three_monomers_given) then - allocate(this%signature_three(size(signature_three))) - this%signature_three=signature_three - end if - -!- If there's only one permutation then write it out explicitly here - if (num_groups == 0) then - do i=1,num_distances - dist_vec_permutations(i,1)=i - end do - end if - - allocate(this%counter(size(counter))) - allocate(this%rank(size(rank))) - allocate(this%perm_array(size(perm_array,1),size(perm_array,2),size(perm_array,3))) - allocate(this%dist_vec(num_distances)) - allocate(this%dist_vec_permutations(size(dist_vec_permutations,1),size(dist_vec_permutations,2))) - - - this%counter=counter - this%rank=rank - this%perm_array=perm_array - this%dist_vec_permutations=dist_vec_permutations - this%perm_number=1 - this%n_perms=dist_vec_n_perms - this%initialised=.true. - -end subroutine permutation_data_initialise - -subroutine permutation_data_finalise(this) - implicit none - type(permutation_data_type) :: this - - if (.not. this%initialised) return - - if(allocated(this%signature_one)) deallocate(this%signature_one) - if(allocated(this%signature_two)) deallocate(this%signature_two) - if(allocated(this%counter)) deallocate(this%counter) - if(allocated(this%rank)) deallocate(this%rank) - if(allocated(this%perm_array)) deallocate(this%perm_array) - if(allocated(this%dist_vec)) deallocate(this%dist_vec) - if(allocated(this%dist_vec_permutations)) deallocate(this%dist_vec_permutations) - this%initialised = .false. - -end subroutine permutation_data_finalise - - subroutine add_combined_permutation (counter, perm_array, dist_vec_permutations,perm_number) - implicit none - ! this gets called by the subroutine next, it should receive a vector 'counter' from which it - ! figures out which permutations to combine. It then asks combine_perms to do so and - ! gets the dist_vec vector from do_swaps - integer :: i, num_distances, N, perm_number - integer, dimension(:), intent(inout) :: counter - integer, dimension(:), allocatable :: combo, next_perm, dist_vec - integer, dimension(:,:,:), intent(in) :: perm_array - integer, dimension(:,:) :: dist_vec_permutations - - N=size(perm_array,2) - num_distances = N*(N-1)/2 - allocate(dist_vec(num_distances)) - allocate(combo(N)) - allocate(next_perm(N)) - - combo = perm_array(1,:,counter(1)) - do i=1, size(counter)-1 - next_perm = perm_array(i+1,:,counter(i+1)) - combo = combine_perms(combo,next_perm) - end do - call do_swaps(combo, dist_vec) - - dist_vec_permutations(:,perm_number)=dist_vec - - deallocate(dist_vec) - deallocate(combo) - deallocate(next_perm) - - end subroutine add_combined_permutation - - recursive subroutine next(this, m) - implicit none - type(permutation_data_type), intent(inout) :: this - integer :: m, num_groups - - num_groups = size(this%counter) - - if (m .gt. num_groups) then - - call add_combined_permutation(this%counter, this%perm_array, this%dist_vec_permutations, this%perm_number) - this%perm_number=this%perm_number+1 - - else - do while (this%counter(m) .lt. this%rank(m)) - call next(this, m+1) - this%counter(m+1:) = 1 - this%counter(m) = this%counter(m) + 1 - end do - this%counter(m+1:) = 1 - call next(this,m+1) - - end if - end subroutine next - - function num_group_perms(group) - implicit none - integer :: num_group_perms, n_members - integer, dimension(:) :: group - integer, dimension(8) :: factorial - - factorial = (/ 1,2,6,24,120,720,5040,40320 /) - n_members = ceiling(log10(real(maxval(group)))) - num_group_perms = factorial(n_members) - return - end function num_group_perms - - ! This modified from Rosetta Code - recursive subroutine update_matrix(std_perms,n_members,position,i_perm,perm_vec) - implicit none - integer :: n_members, value, position, i_perm - integer, dimension(:,:) :: std_perms - integer, dimension(:) :: perm_vec - - if (position > n_members) then - std_perms(i_perm,:) = perm_vec - i_perm=i_perm+1 - else - do value = 1, n_members - if (.not. any (perm_vec(:position - 1) == value)) then - perm_vec(position)= value - call update_matrix(std_perms,n_members,position+1,i_perm,perm_vec) - end if - end do - end if - end subroutine update_matrix - - function permute_atoms(atoms,group,N,max_rank) - implicit none - integer :: i, j, k, i_perm, n_members, num_perms, atoms_per_monomer - integer, intent(IN) :: N, max_rank - integer, dimension(N) :: atoms, group - integer, dimension(:,:), allocatable :: permute_atoms, std_perms - integer, dimension(:), allocatable :: group_vec, perm_vec, indices, offsets - integer, dimension(1) :: p, q, temp - - n_members = ceiling(log10(real(maxval(group)))) - num_perms = num_group_perms(group) - allocate(group_vec(n_members)) - allocate(perm_vec(n_members)) - !allocate(indices(n_members)) - allocate(std_perms(num_perms,n_members)) - allocate(permute_atoms(max_rank,N)) - permute_atoms = 0 - - if (num_perms .eq. 2) then - !just a pair of equivalent atoms or monomers - permute_atoms(1,:) = atoms - permute_atoms(2,:) = atoms - do i=1,count(group .lt. 10 .and. group .gt. 0) - p = minloc(group, mask=group .ge. i) - q = minloc(group, mask=group .gt. 10*i) - !write(*,*) "equivalent pair" - !write(*,'(2I3)') p,q - temp = permute_atoms(2,p(1)) - permute_atoms(2,p(1)) = permute_atoms(2,q(1)) - permute_atoms(2,q(1)) = temp(1) - end do - else - !Permutations of groups of >2 atoms, no support for >2 monomers yet - i_perm=1 - call update_matrix(std_perms,n_members,1,i_perm,perm_vec) - - - if (.not. any(group .eq. 2)) then ! permutations of identical atoms - allocate(indices(n_members)) - ! get indices of equivalent atoms - do i=1,n_members - temp =minloc(group, mask = group .ge. 10**(i-1)) - indices(i) = temp(1) - end do - - do i=1,size(std_perms,1) - perm_vec = std_perms(i,:) - group_vec = indices(perm_vec) - do j=1,n_members - permute_atoms(i,indices(j)) = group_vec(j) - end do - do j=1,N - if (permute_atoms(i,j) ==0) permute_atoms(i,j) = j - end do - end do - - else ! permutations of identical monomers - allocate(offsets(n_members)) - atoms_per_monomer = maxval(group, mask = group .lt. 10) -! allocate(indices(n_members*atoms_per_monomer)) - - do i=1,n_members - ! find the 1, 11, 111, etc. with which the monomer starts - temp =minloc(group, mask = group .ge. 10**(i-1)) - offsets(i) = temp(1)-1 -!!$ do j=1,atoms_per_monomer -!!$ indices(j+(i-1)*n_members) = j + offsets(i) -!!$ end do - end do - - do i=1,size(std_perms,1) - perm_vec = std_perms(i,:) - group_vec = offsets(perm_vec) - do j=1,n_members - do k=1,atoms_per_monomer - permute_atoms(i,k+offsets(j)) = k+group_vec(j) - end do - end do - do j=1,N - if (permute_atoms(i,j) ==0) permute_atoms(i,j) = j - end do - end do - - end if - end if - - return - - end function permute_atoms - - function combine_perms(vec1,vec2) - implicit none - integer, dimension(:), intent(in) :: vec1, vec2 - integer, dimension(:), allocatable :: combine_perms - integer :: j - allocate(combine_perms(size(vec1))) - - if (size(vec1) /= size(vec2)) then - write(*,*) "combine_perms received vectors of mismatched lengths" - call exit(1) - end if - - do j=1,size(vec1) - combine_perms(j) = vec1(vec2(j)) - end do - return - end function combine_perms - - subroutine do_swaps(atom_vec, dist_vec) - implicit none - integer :: N, start, finish, length, temp, j, i - integer, dimension(:), intent(in) :: atom_vec - integer, dimension(:) :: dist_vec - integer, dimension(1) :: i_vec - integer, dimension(:), allocatable :: temp_vec, scratch_vec!, do_swaps - integer, dimension(:,:), allocatable :: dist_mat, dist_mat_upper - - !initialise vector and matrix - N = size(atom_vec) - allocate(scratch_vec(N)) - allocate(temp_vec(N)) - do i=1,N - temp_vec(i)=i - end do - - do i=1,size(dist_vec) - dist_vec(i)=i - end do - - - allocate(dist_mat(N,N)) - allocate(dist_mat_upper(N,N)) - dist_mat=0 - dist_mat_upper = 0 - - start = 1 - do i=1,N - finish=start + N-i - dist_mat_upper(i,i+1:N) = dist_vec(start:finish-1) - start = finish - end do - - dist_mat = dist_mat_upper + transpose(dist_mat_upper) - - do while (any(temp_vec .ne. atom_vec)) - - i_vec = minloc(temp_vec, temp_vec .ne. atom_vec) - i=i_vec(1) - - ! keep track of swaps - temp = temp_vec(i) - temp_vec(i) = temp_vec(atom_vec(i)) - temp_vec(atom_vec(i)) = temp - ! now swap in array - rows then columns - scratch_vec = dist_mat(i,:) - dist_mat(i,:) = dist_mat(atom_vec(i),:) - dist_mat(atom_vec(i),:) = scratch_vec - - scratch_vec = dist_mat(:,i) - dist_mat(:,i) = dist_mat(:,atom_vec(i)) - dist_mat(:,atom_vec(i)) = scratch_vec - end do - - !convert back into vector - - start = 1 - finish=N-1 - do i=1,N-1 - dist_vec(start:finish) = dist_mat(i,i+1:N) - start = finish+1 - finish = finish+N-i-1 - end do - - - deallocate(temp_vec) - deallocate(scratch_vec) - deallocate(dist_mat) - deallocate(dist_mat_upper) - return - end subroutine do_swaps - -end module permutation_maker_module From aafbd4b8a4deb20e8b5a667da32e0bf6194f7091 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:30:55 +0100 Subject: [PATCH 2/7] Updated Makefile to treat F90 extensions appropriately --- Makefile | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/Makefile b/Makefile index 560509aa..d2fb975c 100644 --- a/Makefile +++ b/Makefile @@ -33,7 +33,7 @@ #! HND X #! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -CUSTOM_F95FLAGS += -frealloc-lhs +CUSTOM_F90FLAGS += -frealloc-lhs ifeq (${QUIP_ARCH},) include Makefile.arch @@ -46,34 +46,34 @@ include Makefile.rules ifeq (${HAVE_DESCRIPTORS_NONCOMMERCIAL},1) DEFINES += -DDESCRIPTORS_NONCOMMERCIAL - GAP1_F95_FILES = make_permutations_noncommercial_v2 + GAP1_F90_FILES = make_permutations_noncommercial_v2 else - GAP1_F95_FILES = + GAP1_F90_FILES = endif -SOAP_TURBO_F95_FILES = soap_turbo_functions soap_turbo_radial soap_turbo_angular soap_turbo_compress soap_turbo -SOAP_TURBO_F95_SOURCES = ${addsuffix .f90, ${SOAP_TURBO_F95_FILES}} -SOAP_TURBO_F95_OBJS = ${addsuffix .o, ${SOAP_TURBO_F95_FILES}} +SOAP_TURBO_F90_FILES = soap_turbo_functions soap_turbo_radial soap_turbo_angular soap_turbo_compress soap_turbo +SOAP_TURBO_F90_SOURCES = ${addsuffix .f90, ${SOAP_TURBO_F90_FILES}} +SOAP_TURBO_F90_OBJS = ${addsuffix .o, ${SOAP_TURBO_F90_FILES}} -GAP1_F95_FILES += find_water_triplets_noncommercial descriptors gp_predict descriptors_wrapper clustering -GAP1_F95_SOURCES = ${addsuffix .f95, ${GAP1_F95_FILES}} -GAP1_F95_OBJS = ${addsuffix .o, ${GAP1_F95_FILES}} +GAP1_F90_FILES += find_water_triplets_noncommercial descriptors gp_predict descriptors_wrapper clustering +GAP1_F90_SOURCES = ${addsuffix .F90, ${GAP1_F90_FILES}} +GAP1_F90_OBJS = ${addsuffix .o, ${GAP1_F90_FILES}} -GAP2_F95_FILES = gp_fit gap_fit_module -GAP2_F95_SOURCES = ${addsuffix .f95, ${GAP2_F95_FILES}} -GAP2_F95_OBJS = ${addsuffix .o, ${GAP2_F95_FILES}} +GAP2_F90_FILES = gp_fit gap_fit_module +GAP2_F90_SOURCES = ${addsuffix .F90, ${GAP2_F90_FILES}} +GAP2_F90_OBJS = ${addsuffix .o, ${GAP2_F90_FILES}} default: ${GAP_LIBFILE} ifeq (${USE_MAKEDEP},1) -GAP1_F95_FPP_FILES = ${addsuffix .fpp, ${GAP1_F95_FILES}} -GAP2_F95_FPP_FILES = ${addsuffix .fpp, ${GAP2_F95_FILES}} -GAP1.depend: ${GAP1_F95_FPP_FILES} - ${SCRIPT_PATH}/${MAKEDEP} ${MAKEDEP_ARGS} -- ${addprefix ../../src/GAP/,${GAP1_F95_SOURCES}} > GAP1.depend -GAP2.depend: ${GAP2_F95_FPP_FILES} ${GAP1_F95_FPP_FILES} - ${SCRIPT_PATH}/${MAKEDEP} ${MAKEDEP_ARGS} -- ${addprefix ../../src/GAP/,${GAP2_F95_SOURCES}} > GAP2.depend +GAP1_F90_FPP_FILES = ${addsuffix .fpp, ${GAP1_F90_FILES}} +GAP2_F90_FPP_FILES = ${addsuffix .fpp, ${GAP2_F90_FILES}} +GAP1.depend: ${GAP1_F90_FPP_FILES} + ${SCRIPT_PATH}/${MAKEDEP} ${MAKEDEP_ARGS} -- ${addprefix ../../src/GAP/,${GAP1_F90_SOURCES}} > GAP1.depend +GAP2.depend: ${GAP2_F90_FPP_FILES} ${GAP1_F90_FPP_FILES} + ${SCRIPT_PATH}/${MAKEDEP} ${MAKEDEP_ARGS} -- ${addprefix ../../src/GAP/,${GAP2_F90_SOURCES}} > GAP2.depend -include GAP1.depend -include GAP2.depend @@ -93,21 +93,21 @@ LIBFILES = libatoms.a ${GAP_LIBFILE} libquip_core.a libquiputils.a Programs: ${PROGRAMS} #cp ${QUIP_ROOT}/src/GAP/teach_sparse . -${PROGRAMS}: % : ${LIBFILES} ${GAP2_F95_OBJS} ${GAPFIT_LIBFILE} %.o - $(LINKER) $(LINKFLAGS) -o $@ ${F95OPTS} $@.o ${GAPFIT_LIBFILE} ${LIBS} ${LINKOPTS} +${PROGRAMS}: % : ${LIBFILES} ${GAP2_F90_OBJS} ${GAPFIT_LIBFILE} %.o + $(LINKER) $(LINKFLAGS) -o $@ ${F90OPTS} $@.o ${GAPFIT_LIBFILE} ${LIBS} ${LINKOPTS} -${GAP_LIBFILE}: ${SOAP_TURBO_F95_OBJS} ${GAP1_F95_OBJS} +${GAP_LIBFILE}: ${SOAP_TURBO_F90_OBJS} ${GAP1_F90_OBJS} ifneq (${LIBTOOL},) - ${LIBTOOL} -o ${GAP_LIBFILE} ${SOAP_TURBO_F95_OBJS} ${GAP1_F95_OBJS} + ${LIBTOOL} -o ${GAP_LIBFILE} ${SOAP_TURBO_F90_OBJS} ${GAP1_F90_OBJS} else ${AR} ${AR_ADD} ${GAP_LIBFILE} $? endif -${GAPFIT_LIBFILE}: ${GAP2_F95_OBJS} +${GAPFIT_LIBFILE}: ${GAP2_F90_OBJS} ifneq (${LIBTOOL},) - ${LIBTOOL} -o ${GAPFIT_LIBFILE} ${GAP2_F95_OBJS} + ${LIBTOOL} -o ${GAPFIT_LIBFILE} ${GAP2_F90_OBJS} else ${AR} ${AR_ADD} ${GAPFIT_LIBFILE} $? endif From 0b305ada6120c2dc3bb198f4b41cf1b106f01844 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:31:18 +0100 Subject: [PATCH 3/7] Initial meson.build added --- meson.build | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 meson.build diff --git a/meson.build b/meson.build new file mode 100644 index 00000000..acd4f4bc --- /dev/null +++ b/meson.build @@ -0,0 +1,23 @@ +GAP_F90_sources = [ + 'clustering.F90', + 'descriptors.F90', + 'descriptors_wrapper.F90', + 'find_water_triplets_noncommercial.F90', + 'gp_fit.F90', + 'gp_predict.F90', + 'make_permutations_noncommercial_v2.F90', + 'soap_turbo.f90', + 'soap_turbo_angular.f90', + 'soap_turbo_compress.f90', + 'soap_turbo_functions.f90', + 'soap_turbo_radial.f90', +] + +GAP = library('GAP', + GAP_F90_sources, + dependencies: [ + blas_dep, + mpi_dep, + ], + link_with : [libAtoms,fox], + ) From 76cbc023f5656afd9dacf22a6256f34d6c98ca97 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:32:29 +0100 Subject: [PATCH 4/7] .gitignore added --- .gitignore | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..b25c15b8 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ From 53e0b1b83ed62d09f9c6315ac9fad1beff072350 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:45:49 +0100 Subject: [PATCH 5/7] renamed sources to F90 --- clustering.F90 | 943 ++ descriptors.F90 | 13206 +++++++++++++++++++++++ descriptors_wrapper.F90 | 587 + find_water_triplets_noncommercial.F90 | 485 + gap_fit.F90 | 113 + gap_fit_module.F90 | 2393 ++++ gp_fit.F90 | 750 ++ gp_predict.F90 | 5290 +++++++++ make_permutations_noncommercial_v2.F90 | 733 ++ 9 files changed, 24500 insertions(+) create mode 100644 clustering.F90 create mode 100644 descriptors.F90 create mode 100644 descriptors_wrapper.F90 create mode 100644 find_water_triplets_noncommercial.F90 create mode 100644 gap_fit.F90 create mode 100644 gap_fit_module.F90 create mode 100644 gp_fit.F90 create mode 100644 gp_predict.F90 create mode 100644 make_permutations_noncommercial_v2.F90 diff --git a/clustering.F90 b/clustering.F90 new file mode 100644 index 00000000..d3ed958a --- /dev/null +++ b/clustering.F90 @@ -0,0 +1,943 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module clustering_module + + ! use libatoms_module + use error_module + use system_module ! , only : dp, optional_default, ran_uniform, reallocate + use linearalgebra_module + + implicit none + private + + public :: pivot, bisect_kmedoids, cluster_kmeans, select_uniform, cluster_fuzzy_cmeans, cur_decomposition + + integer, parameter :: n_trial = 10 + integer, parameter :: n_trial_k_med = 100 + real(dp), parameter :: cluster_jitter = 1.0e-7_dp + real(dp), parameter :: KMEANS_THRESHOLD = 1.0e-6_dp + + type lst + integer, dimension(:), allocatable :: object + integer :: medoid + real(dp) :: sse + integer :: N + endtype lst + + type clstr + type(lst), dimension(:), allocatable :: cluster + real(dp), dimension(:,:), pointer :: dm + integer :: N + endtype clstr + + contains + + subroutine distance_matrix(x,dm,theta_fac,theta) + real(dp), dimension(:,:), intent(in) :: x + real(dp), dimension(:,:), intent(out) :: dm + real(dp), intent(in), optional :: theta_fac + real(dp), dimension(:), intent(in), target, optional :: theta + + real(dp), dimension(:), pointer :: my_theta => null() + real(dp) :: my_theta_fac + integer :: i, j, d, n + + my_theta_fac = optional_default(1.0_dp, theta_fac) + d = size(x,1) + n = size(x,2) + + if( present(theta) ) then + if( size(theta) == d) then + my_theta => theta + else + allocate(my_theta(d)) + my_theta = theta(1) + endif + else + allocate(my_theta(d)) + + do i = 1, d + my_theta(i) = ( maxval(x(i,:)) - minval(x(i,:)) ) + ! theta(i) = sqrt( & !take square root + ! & sum( x(i,:)**2 ) / size(x(i,:)) - & + ! & (sum( x(i,:) ) / size(x(i,:)))**2 ) + if( my_theta(i) .feq. 0.0_dp ) my_theta(i) = 1.0_dp + enddo + my_theta = my_theta * my_theta_fac + endif + + do i = 1, n + do j = i + 1, n + dm(j,i) = cluster_jitter*ran_uniform() + enddo + dm(i,i) = 0.0_dp + enddo + +!$omp parallel do default(none) shared(dm,n,x,my_theta) private(i,j) schedule(dynamic) + do i = 1, n + do j = i + 1, n + dm(j,i) = dm(j,i) + sqrt( sum( ( (x(:,j) - x(:,i)) / my_theta )**2 ) ) + dm(i,j) = dm(j,i) + enddo + enddo +!$omp end parallel do + + do i = 1, n + do j = i + 1, n + dm(i,j) = dm(j,i) + enddo + enddo + + if( present(theta) ) then + my_theta => null() + else + deallocate(my_theta) + endif + + endsubroutine distance_matrix + + subroutine pca(x,x_mean,v) + + real(dp), dimension(:,:), intent(in) :: x + real(dp), dimension(:), intent(out) :: x_mean + real(dp), dimension(:,:), intent(out) :: v + + real(dp), dimension(:), allocatable :: diag_c + real(dp), dimension(:,:), allocatable :: cov + integer :: i, j, d, n + + d = size(x,1) + n = size(x,2) + allocate(cov(d,d),diag_c(d)) + + x_mean = sum(x,dim=2) / n ! empirical mean + + do i = 1, d + do j = 1, d + cov(j,i) = dot_product(x(i,:),x(j,:)) / n - x_mean(i)*x_mean(j) + enddo + enddo + + call diagonalise(cov,diag_c, evects=v) + + deallocate(cov, diag_c) + + endsubroutine pca + + subroutine pivot(x,pivout,theta_fac,theta) + real(dp), dimension(:,:), intent(in) :: x + integer, dimension(:), intent(out) :: pivout + real(dp), intent(in), optional :: theta_fac + real(dp), dimension(:), intent(in), optional :: theta + + real(dp), dimension(:,:), allocatable :: knn + real(dp), dimension(:), allocatable :: ktmp + integer, dimension(:), allocatable :: pivin + + integer :: stat, i, j, k, d, m, n, jtmp, jmax + real(dp) :: dmax + + d = size(x,1) + n = size(x,2) + + m = size(pivout) + + if( m > n ) call system_abort('pivot: required number of changes ('//m//') greater than possible number of changes ('//n//')') + + allocate(knn(n,n),stat=stat) + if(stat /=0 ) call system_abort('pivot: could not allocate knn matrix.') + + allocate(pivin(n),ktmp(n)) + + call distance_matrix(x,knn,theta_fac=theta_fac,theta=theta) + do i = 1, n + do j = 1, n + knn(j,i) = exp(-0.5_dp*knn(j,i)) + enddo + enddo + + pivin = (/ (i, i=1,n) /) + + do k = 1, m + dmax = 0.0_dp + do j = k, n + if( dmax < knn(j,j) ) then + jmax = j + dmax = knn(j,j) + endif + enddo + if( jmax /= k ) then + jtmp = pivin(jmax) + pivin(jmax) = pivin(k) + pivin(k) = jtmp + + ktmp = knn(k,:) + knn(k,:) = knn(jmax,:) + knn(jmax,:) = ktmp + + ktmp = knn(:,k) + knn(:,k) = knn(:,jmax) + knn(:,jmax) = ktmp + endif + + knn(k,k) = sqrt(knn(k,k)) + + knn(k+1:n,k) = knn(k+1:n,k)/knn(k,k) + do j = k+1, n + knn(j:n,j) = knn(j:n,j) - knn(j:n,k)*knn(j,k) + enddo + + do j = 1, n + do i = j+1,n + knn(j,i) = knn(i,j) + enddo + enddo + enddo + + pivout = pivin(1:m) + + deallocate(knn,pivin,ktmp) + + endsubroutine pivot + + subroutine bisect_kmedoids(dat,n_clusters_in, c,med, theta_fac,theta, is_distance_matrix) + real(dp), dimension(:,:), intent(in), target :: dat + integer, intent(in) :: n_clusters_in + integer, dimension(:), intent(out),optional :: c, med + real(dp), intent(in), optional :: theta_fac + real(dp), dimension(:), intent(in), optional :: theta + logical, intent(in), optional :: is_distance_matrix + + type(clstr) :: my_cluster, tmp + + logical :: must_calculate_distance + real(dp), dimension(:,:), allocatable, target :: dm + + real(dp), dimension(:), allocatable :: dv + real(dp) :: max_sse, min_sse, sse + + integer, dimension(:), allocatable :: sub_cluster1, sub_cluster2, sub_cluster1_min, sub_cluster2_min + integer, dimension(1) :: ml + integer :: stat, i, j, k, km, m, n, nc, & + lo_med, hi_med, lo_med_new, hi_med_new, lo_med_min, hi_med_min, n1, n2, n1_min, n2_min, iter + + must_calculate_distance = .not. optional_default(.true., is_distance_matrix) + + n = size(dat,2) + if (.not. must_calculate_distance) then + if (size(dat,1) /= n) call system_abort('is_distance_matrix but not square') + endif + + if( n_clusters_in > n ) call system_abort('bisect_kmedoids: required number of cluster greater than total number of data points') + + if(present(c) ) c = 0 + + if (must_calculate_distance) then + allocate(dm(n,n), stat=stat) + if(stat /=0 ) call system_abort('bisect_kmedoids: could not allocate dm matrix.') + + call print('Started distance matrix calculation', verbosity=PRINT_NERD) + call distance_matrix(dat, dm, theta_fac=theta_fac,theta=theta) + call print('Finished distance matrix calculation', verbosity=PRINT_NERD) + my_cluster%dm => dm + else + my_cluster%dm => dat + endif + + ! start clustering + my_cluster%N = 1 ! start with one big cluster + allocate( my_cluster%cluster(1) ) + my_cluster%cluster(1)%N = n ! put every object in the initial cluster + allocate( my_cluster%cluster(1)%object(n) ) + my_cluster%cluster(1)%object = (/(i,i=1,n)/) + + allocate(dv(n)) ! distance vector, the sum of square of distances of points from central object + dv = sum(my_cluster%dm,dim=1) + my_cluster%cluster(1)%sse = minval( dv ) ! determine initial medoid, the object that is the + ml = minloc( dv ) ! closest to any other object in cluster + my_cluster%cluster(1)%medoid = ml(1) + deallocate(dv) + + ! main loop starts here, bisects initial clusters until desired number of + ! clusters are found + + iter = 0 + do + iter = iter + 1 + call print("Starting iteration "//iter,verbosity=PRINT_NERD) + + if( my_cluster%N == n_clusters_in ) exit + max_sse = -1.0_dp ! select cluster with greatest sse + do j = 1, my_cluster%N + if( max_sse < my_cluster%cluster(j)%sse ) then + i = j + max_sse = my_cluster%cluster(j)%sse + endif + enddo + nc = my_cluster%cluster(i)%N + if( nc==1 ) cycle + allocate( sub_cluster1(nc), sub_cluster2(nc), sub_cluster1_min(nc),sub_cluster2_min(nc) ) + + min_sse = huge(1.0_dp) + do j = 1, n_trial + m = ceiling( ran_uniform()*(nc-1) ) ! choose a bisecting point randomly + ml = minloc( sum( my_cluster%dm( my_cluster%cluster(i)%object(:m), my_cluster%cluster(i)%object(:m) ), dim=1) ) + lo_med_new = my_cluster%cluster(i)%object(ml(1)) + + ml = minloc( sum( my_cluster%dm( my_cluster%cluster(i)%object(m+1:), my_cluster%cluster(i)%object(m+1:) ), dim=1) ) + + hi_med_new = my_cluster%cluster(i)%object(ml(1) + m) + + ! the median of the 2 subclusters determined + lo_med = 0 + hi_med = 0 + + ! perform k-medoid clustering on the two subclusters + do km = 1, n_trial_k_med + if( (lo_med_new == lo_med) .and. (hi_med_new == hi_med) ) exit + lo_med = lo_med_new + hi_med = hi_med_new + n1 = 0 + n2 = 0 + !n1 = 1 + !n2 = 1 + !sub_cluster1(n1) = lo_med + !sub_cluster1(n2) = hi_med + + do k = 1, my_cluster%cluster(i)%N + if( my_cluster%dm(lo_med,my_cluster%cluster(i)%object(k)) < & + & my_cluster%dm(hi_med,my_cluster%cluster(i)%object(k)) ) then + n1 = n1 + 1 + sub_cluster1(n1) = my_cluster%cluster(i)%object(k) + else + n2 = n2 + 1 + sub_cluster2(n2) = my_cluster%cluster(i)%object(k) + endif + enddo + + ml = minloc( sum( my_cluster%dm( sub_cluster1(:n1), sub_cluster1(:n1) ), dim=1) ) + lo_med_new = sub_cluster1(ml(1)) + ml = minloc( sum( my_cluster%dm( sub_cluster2(:n2), sub_cluster2(:n2) ), dim=1) ) + hi_med_new = sub_cluster2(ml(1)) + enddo + sse = sum( my_cluster%dm(lo_med_new,sub_cluster1(:n1)) ) + sum( my_cluster%dm(hi_med_new,sub_cluster2(:n2)) ) + + ! choose the clustering that resulted the smallest sse + if( sse < min_sse ) then + min_sse = sse + sub_cluster1_min = sub_cluster1 + sub_cluster2_min = sub_cluster2 + n1_min = n1 + n2_min = n2 + lo_med_min = lo_med_new + hi_med_min = hi_med_new + endif + enddo + + ! now update the the clusters with the two new subclusters + tmp = my_cluster + + do j = 1, my_cluster%N + deallocate( my_cluster%cluster(j)%object ) + enddo + deallocate( my_cluster%cluster ) + my_cluster%N = my_cluster%N + 1 + allocate( my_cluster%cluster( my_cluster%N ) ) + + do j = 1, my_cluster%N - 1 + if( i == j ) then + allocate( my_cluster%cluster(j)%object(n1_min) ) + my_cluster%cluster(j)%N = n1_min + my_cluster%cluster(j)%object = sub_cluster1_min(:n1_min) + my_cluster%cluster(j)%sse = sum( my_cluster%dm(lo_med_min,sub_cluster1_min(:n1_min)) ) + my_cluster%cluster(j)%medoid = lo_med_min + else + my_cluster%cluster(j) = tmp%cluster(j) + endif + enddo + allocate( my_cluster%cluster(my_cluster%N)%object(n2_min) ) + my_cluster%cluster(my_cluster%N)%N = n2_min + my_cluster%cluster(my_cluster%N)%object = sub_cluster2_min(:n2_min) + my_cluster%cluster(my_cluster%N)%sse = sum( my_cluster%dm(hi_med_min,sub_cluster2_min(:n2_min)) ) + my_cluster%cluster(my_cluster%N)%medoid = hi_med_min + + do j = 1, tmp%N + deallocate( tmp%cluster(j)%object ) + enddo + deallocate( tmp%cluster, sub_cluster1, sub_cluster2, sub_cluster1_min, sub_cluster2_min ) + + call kmedoid(my_cluster) + enddo + + if( present(c) ) then + do j = 1, my_cluster%N + do k = 1, my_cluster%cluster(j)%N + i = my_cluster%cluster(j)%object(k) + c(i) = j + enddo + enddo + endif + + if( present(med) ) then + do j = 1, my_cluster%N + med(j) = my_cluster%cluster(j)%medoid + enddo + endif + + do j = 1, my_cluster%N + deallocate( my_cluster%cluster(j)%object ) + enddo + deallocate(my_cluster%cluster) + if (allocated(dm)) deallocate(dm) + + endsubroutine bisect_kmedoids + + subroutine kmedoid(this) + type(clstr), intent(inout) :: this + + type(clstr) :: tmp + integer, dimension(:), allocatable :: medoids + integer, dimension(1) :: ml + integer :: n, j, k + logical :: refined + + ! k-medoid-refinement + n = size(this%dm,1) + ! n: total number of objects + + tmp%N = this%N + allocate( tmp%cluster(tmp%N), medoids(tmp%N) ) + do j = 1, tmp%N + allocate( tmp%cluster(j)%object(n) ) + medoids(j) = this%cluster(j)%medoid + enddo + + ! main loop starts here, perfom k-medoid clustering until medoids don't + ! change anymore + do + do j = 1, tmp%N + tmp%cluster(j)%N = 0 + enddo + do j = 1, n + ml = minloc( this%dm(j,medoids) ) ! determine to which medoid each object belongs + k = ml(1) + tmp%cluster(k)%N = tmp%cluster(k)%N + 1 + tmp%cluster(k)%object(tmp%cluster(k)%N) = j + enddo + + ! re-determine the medoid in each cluster + do j = 1, tmp%N + ml = minloc( sum( this%dm( tmp%cluster(j)%object(:tmp%cluster(j)%N), & + & tmp%cluster(j)%object(:tmp%cluster(j)%N) ), dim=1) ) + tmp%cluster(j)%medoid = tmp%cluster(j)%object(ml(1)) + enddo + + refined = .true. + + ! check whether medoids have changed + do j = 1, tmp%N + refined = refined .and. (tmp%cluster(j)%medoid == medoids(j)) + medoids(j) = tmp%cluster(j)%medoid + enddo + if(refined) exit + enddo + + ! write results + do j = 1, tmp%N + deallocate( this%cluster(j)%object ) + allocate( this%cluster(j)%object( tmp%cluster(j)%N ) ) + this%cluster(j)%object = tmp%cluster(j)%object(:tmp%cluster(j)%N) + this%cluster(j)%N = tmp%cluster(j)%N + this%cluster(j)%medoid = tmp%cluster(j)%medoid + this%cluster(j)%sse = sum( this%dm(this%cluster(j)%medoid,& + & this%cluster(j)%object ) ) + + deallocate( tmp%cluster(j)%object ) + enddo + deallocate( tmp%cluster, medoids ) + + endsubroutine kmedoid + + subroutine cluster_kmeans(x,cluster_index,theta_fac,theta) + real(dp), dimension(:,:), intent(in) :: x + integer, dimension(:), intent(out) :: cluster_index + real(dp), intent(in), optional :: theta_fac + real(dp), dimension(:), intent(in), target, optional :: theta + + real(dp), dimension(:), pointer :: my_theta => null() + real(dp) :: my_theta_fac, d_min, d_ij, d_total, d_total_prev + + real(dp), dimension(:,:), allocatable :: cluster_centre + integer, dimension(:), allocatable :: cluster_info + integer :: d, n, m, i, j, k, cluster_info_old, iter, n_points_cluster_j + logical :: cluster_same + + d = size(x,1) + n = size(x,2) + m = size(cluster_index) + if( m > n ) call system_abort('cluster_kmeans: required number of clusters ('//m//') greater than total number of points ('//n//')') + + my_theta_fac = optional_default(1.0_dp, theta_fac) + if( present(theta) ) then + if( size(theta) == d) then + my_theta => theta + else + allocate(my_theta(d)) + my_theta = theta(1) + endif + else + allocate(my_theta(d)) + do i = 1, d + my_theta(i) = ( maxval(x(i,:)) - minval(x(i,:)) ) + if( my_theta(i) .feq. 0.0_dp ) my_theta(i) = 1.0_dp + enddo + my_theta = my_theta * my_theta_fac + endif + + allocate(cluster_centre(d,m),cluster_info(n)) + + call fill_random_integer(cluster_index, n) !choose random points as cluster centres. + + cluster_centre = x(:,cluster_index) + cluster_info = 0 + + iter = 0 + d_total = huge(1.0_dp) + do + iter = iter + 1 + call print("iteration: "//iter,verbosity=PRINT_NERD) + cluster_same = .true. + + d_total_prev = d_total + d_total = 0.0_dp +!$omp parallel do default(none) shared(n,m,x,cluster_info,cluster_centre,my_theta) & +!$omp reduction(.and.:cluster_same) & +!$omp private(i,j,d_min,d_ij,cluster_info_old) reduction(+:d_total) + do i = 1, n + d_min = huge(0.0_dp) + cluster_info_old = cluster_info(i) + do j = 1, m + d_ij = sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2) + if( d_ij < d_min ) then + d_min = d_ij + cluster_info(i) = j + endif + enddo + if( cluster_info_old /= cluster_info(i) ) cluster_same = cluster_same .and. .false. + d_total = d_total + d_min + enddo +!$omp end parallel do + call print("cluster_kmeans iteration="//iter//" d_total="//d_total) + +!$omp parallel do default(none) shared(x,cluster_centre,cluster_info,m,d,n) private(j,k,n_points_cluster_j) + do j = 1, m + n_points_cluster_j = count(cluster_info==j) + if( n_points_cluster_j == 0 ) then + cluster_centre(:,j) = x(:,ceiling(ran_uniform()*n)) + else + do k = 1, d + cluster_centre(k,j) = sum(x(k,:),mask=(cluster_info==j)) / n_points_cluster_j + enddo + endif + enddo +!$omp end parallel do + if( cluster_same ) exit + if( abs(d_total - d_total_prev) < KMEANS_THRESHOLD * d_total ) exit + enddo + + do j = 1, m + d_min = huge(0.0_dp) + do i = 1, n + d_ij = sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2) + if( d_ij < d_min ) then + d_min = d_ij + cluster_index(j) = i + endif + enddo + enddo + + deallocate(cluster_centre, cluster_info) + + if(present(theta)) then + my_theta => null() + else + deallocate(my_theta) + endif + + endsubroutine cluster_kmeans + + ! https://sites.google.com/site/dataclusteringalgorithms/fuzzy-c-means-clustering-algorithm + subroutine cluster_fuzzy_cmeans(x,cluster_index,theta_fac,theta,fuzziness) + real(dp), dimension(:,:), intent(in) :: x + integer, dimension(:), intent(out) :: cluster_index + real(dp), intent(in), optional :: theta_fac + real(dp), dimension(:), intent(in), target, optional :: theta + real(dp), intent(in), optional :: fuzziness + + real(dp), dimension(:), pointer :: my_theta => null() + real(dp) :: my_theta_fac, d_min, d_ij, d_total, d_total_prev + + real(dp), dimension(:,:), allocatable :: cluster_centre + real(dp), dimension(:,:), allocatable :: w + real(dp), dimension(:), allocatable, save :: wx_j, d_i + real(dp) :: w_j, w_old, my_fuzziness, alpha + integer :: d, n, m, i, j, iter + logical :: cluster_same +!$omp threadprivate(d_i, wx_j) + + d = size(x,1) + n = size(x,2) + m = size(cluster_index) + if( m > n ) call system_abort('cluster_fuzzy_cmeans: required number of clusters ('//m//') greater than total number of points ('//n//')') + + my_theta_fac = optional_default(1.0_dp, theta_fac) + my_fuzziness = optional_default(4.0_dp, fuzziness) + if( present(theta) ) then + if( size(theta) == d) then + my_theta => theta + else + allocate(my_theta(d)) + my_theta = theta(1) + endif + else + allocate(my_theta(d)) + do i = 1, d + my_theta(i) = ( maxval(x(i,:)) - minval(x(i,:)) ) + if( my_theta(i) .feq. 0.0_dp ) my_theta(i) = 1.0_dp + enddo + my_theta = my_theta * my_theta_fac + endif + + allocate(cluster_centre(d,m), w(n,m)) +!$omp parallel + allocate(d_i(m), wx_j(d)) +!$omp end parallel + + call fill_random_integer(cluster_index, n) !choose random points as cluster centres. + + cluster_centre = x(:,cluster_index) + do i = 1, m + do j = 1, d + cluster_centre(j,i) = cluster_centre(j,i) + ( ran_uniform() - 0.5_dp ) * cluster_jitter + enddo + enddo + + w = 0.0_dp + + iter = 0 + d_total = huge(1.0_dp) + do + iter = iter + 1 + call print("iteration: "//iter,verbosity=PRINT_NERD) + cluster_same = .true. + + d_total_prev = d_total + d_total = 0.0_dp + ! Calculate fuzzy membership +!$omp parallel do default(none) shared(n,m,my_theta,my_fuzziness,w,x,cluster_centre) & +!$omp private(i,j,alpha,w_old) reduction(.and.:cluster_same) reduction(+:d_total) + do i = 1, n + alpha = 0.0_dp + do j = 1, m + d_i(j) = sqrt(sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2)) + alpha = alpha + 1.0_dp / d_i(j)**(2.0_dp / (my_fuzziness - 1.0_dp)) + enddo + + do j = 1, m + w_old = w(i,j) + w(i,j) = 0.0_dp + + w(i,j) = 1.0_dp / d_i(j)**(2.0_dp / (my_fuzziness - 1.0_dp)) / alpha + if( w_old .fne. w(i,j) ) cluster_same = cluster_same .and. .false. + + d_total = d_total + d_i(j)**2 * w(i,j)**my_fuzziness + enddo + enddo +!$omp end parallel do + call print("cluster_fuzzy_cmeans iteration="//iter//" d_total="//d_total) + + ! Calculate fuzzy centres +!$omp parallel do default(none) shared(m,n,w,x,my_fuzziness,cluster_centre) & +!$omp private(i,j,w_j) + do j = 1, m + w_j = 0.0_dp + wx_j = 0.0_dp + + do i = 1, n + w_j = w_j + w(i,j)**my_fuzziness + wx_j = wx_j + x(:,i) * w(i,j)**my_fuzziness + enddo + + cluster_centre(:,j) = wx_j / w_j + enddo +!$omp end parallel do + + call print("cluster_same: "//cluster_same,verbosity=PRINT_NERD) + call print("d_total: "//d_total,verbosity=PRINT_NERD) + call print("d_total_prev: "//d_total_prev,verbosity=PRINT_NERD) + call print("d_total-d_total_prev: "//(d_total-d_total_prev),verbosity=PRINT_NERD) + + if( cluster_same ) exit + if( abs(d_total - d_total_prev) < KMEANS_THRESHOLD * d_total ) exit + enddo + + ! Allocate cluster centres to nearest points + do j = 1, m + d_min = huge(0.0_dp) + do i = 1, n + d_ij = sum(( (cluster_centre(:,j) - x(:,i))/my_theta )**2) + if( d_ij < d_min ) then + d_min = d_ij + cluster_index(j) = i + endif + enddo + enddo + + deallocate(cluster_centre, w) +!$omp parallel + if(allocated(d_i)) deallocate(d_i) + if(allocated(wx_j)) deallocate(wx_j) +!$omp end parallel + + if(present(theta)) then + my_theta => null() + else + deallocate(my_theta) + endif + + endsubroutine cluster_fuzzy_cmeans + + subroutine select_uniform(x,index_out) + real(dp), dimension(:,:), intent(in) :: x + integer, dimension(:), intent(out) :: index_out + + integer :: i, d, n, m, n_grid, i_global, i_index_out, d_max + integer, dimension(:), allocatable :: p_grid, i_hist, histogram, x_histogram, index_out_histogram + real(dp), dimension(:), allocatable :: lower_bound, upper_bound, x_range + + d = size(x,1) + n = size(x,2) + m = size(index_out) + + if( n < m ) call system_abort('select_uniform: n = '//n//' < m = '//m) + + allocate(lower_bound(d), upper_bound(d), x_range(d), p_grid(d), i_hist(d)) + + lower_bound = minval(x,dim=2) + upper_bound = maxval(x,dim=2) + x_range = upper_bound - lower_bound + + n_grid = ceiling( real(m, dp)**(1.0_dp / real(d, dp)) ) + d_max = floor( log(real(huge(1), dp)) / log(real(n_grid, dp)) ) + if (d > d_max) then + call system_abort('select_uniform: Descriptor is too large ('//d//' > '//d_max//'). & + &Use another sparse method or descriptor.') + end if + p_grid = (/ ( n_grid**(i-1), i = 1, d ) /) + + allocate(histogram(n_grid**d)) + allocate(x_histogram(n),index_out_histogram(m)) + + histogram = 0 + + do i = 1, n + ! for each datapoint x(:,i) compute the bin index in each d direction + i_hist = nint( ( x(:,i) - lower_bound ) / x_range * (n_grid-1) ) + 1 + + ! map the bin index to a flat histogram bin index + i_global = sum((i_hist-1)*p_grid)+1 + histogram(i_global) = histogram(i_global) + 1 + + ! the i-th datapoint belongs to the i_global-th index in the histogram + x_histogram(i) = i_global + enddo + + index_out = 0 + i_index_out = 0 + + ! To monitor which bins the sparse points belong to. + index_out_histogram = 0 + + do i = 1, n + ! That's the exit condition if all sparse points are assigned before we + ! finish with the data points + if( all(index_out /= 0) ) exit + + if( all(x_histogram(i) /= index_out_histogram) ) then + ! We have just found a point which belongs to a bin that we haven't + ! selected yet in the sparse points + i_index_out = i_index_out + 1 + index_out(i_index_out) = i + index_out_histogram(i_index_out) = x_histogram(i) + endif + enddo + + do while ( any(index_out == 0) ) + ! We haven't yet assigned all sparse points. + + ! Select a bin randomly + i_global = ceiling( ran_uniform() * size(histogram) ) + + ! cycle if the bin is empty + if( histogram(i_global) == 0 ) cycle + + ! check if there are points belonging to this bin which we haven't + ! selected yet + if( count(x_histogram == i_global) == count(index_out_histogram == i_global) ) cycle + + do while (.true.) + ! select a point from x which belongs to that bin and add it to + ! the output. + i = ceiling( ran_uniform() * n ) + if( x_histogram(i) /= i_global .or. any(index_out == i) ) then + cycle + else + i_index_out = i_index_out + 1 + index_out(i_index_out) = i + index_out_histogram(i_index_out) = x_histogram(i) + exit + endif + enddo + enddo + + deallocate(lower_bound, upper_bound, x_range, p_grid, i_hist, histogram, x_histogram,index_out_histogram) + + if (.not. all(index_out /= 0)) call system_abort('select_uniform: could not assign all sparse points') + + endsubroutine select_uniform + + subroutine cur_decomposition(this, index_out, rank, n_iter) + ! based on 10.1073/pnas.0803205106 + + real(dp), intent(in), dimension(:,:) :: this + integer, dimension(:), intent(out) :: index_out + integer, intent(in), optional :: rank, n_iter + + integer :: n + integer :: expected_columns + integer :: my_n_iter, my_rank + type(LA_Matrix) :: LA_this + real(dp), allocatable, dimension(:) :: p, s, p_minus_ran_uniform + real(dp), allocatable, dimension(:,:) :: v + integer :: j, l + integer, allocatable, dimension(:), target :: p_index + integer, pointer, dimension(:) :: tmp_index_out => null() + real(dp), allocatable, dimension(:,:) :: C, Cp + real(dp) :: err, min_err + integer :: error + + expected_columns = size(index_out) + + if( expected_columns <= 0 ) then + call print_warning("cur_decomposition: called with expected_columns "//expected_columns//", can't be zero or less") + return + endif + + call initialise(LA_this,this) + + my_n_iter = optional_default(1, n_iter) + + if (present(rank)) then + call LA_Matrix_SVD_Allocate(LA_this,v=v,error=error) + HANDLE_ERROR(error) + call LA_Matrix_SVD(LA_this,v=v,error=error) + HANDLE_ERROR(error) + my_rank = rank + else + call LA_Matrix_SVD_Allocate(LA_this,s=s,v=v,error=error) + HANDLE_ERROR(error) + call LA_Matrix_SVD(LA_this,s=s,v=v,error=error) + HANDLE_ERROR(error) + my_rank = count(s > TOL_SVD) / 2 + endif + + n = size(v,1) + allocate(p(n), p_minus_ran_uniform(n), p_index(n)) + allocate( C(size(this,1),expected_columns), Cp(expected_columns,size(this,1)) ) + + p = sum(v(:,1:my_rank)**2, dim=2) + p = p * expected_columns + p = p / my_rank + p = min(p,1.0_dp) + + if(my_n_iter <= 0) then ! do not do probabilistic selection of columns + p_index = (/(j, j=1,n )/) + p_minus_ran_uniform = -p + call heap_sort(p_minus_ran_uniform,i_data=p_index) + index_out = p_index(1:expected_columns) + else + min_err = huge(1.0_dp) + do l = 1, my_n_iter + + ! randomly select columns according to the probabilities + do j = 1, n + p_minus_ran_uniform(j) = ran_uniform() - p(j) + p_index(j) = j ! initialise index array + end do + + call heap_sort(p_minus_ran_uniform,i_data=p_index) + tmp_index_out => p_index(1:expected_columns) + + C = this(:,tmp_index_out) + ! pinv: Moore-Penrose pseudo-inverse + call pseudo_inverse(C,Cp) + err = sum( (this - ( C .mult. Cp .mult. this))**2 ) + + call print("cur_decomposition: iteration: "//l//", error: "//err) + if(err < min_err) then ! this happens at least once + index_out = tmp_index_out + min_err = err + endif + + end do + endif + + call finalise(LA_this) + + tmp_index_out => null() + if(allocated(s)) deallocate(s) + if(allocated(v)) deallocate(v) + if(allocated(p)) deallocate(p) + if(allocated(p_minus_ran_uniform)) deallocate(p_minus_ran_uniform) + if(allocated(p_index)) deallocate(p_index) + if(allocated(C)) deallocate(C) + if(allocated(Cp)) deallocate(Cp) + + end subroutine cur_decomposition + +endmodule clustering_module diff --git a/descriptors.F90 b/descriptors.F90 new file mode 100644 index 00000000..7917c65e --- /dev/null +++ b/descriptors.F90 @@ -0,0 +1,13206 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X© +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +#ifdef _OPENMP +#define OMP_SAVE ,save +#else +#define OMP_SAVE +#endif + +module descriptors_module + + use error_module + use system_module, only : dp, print, optional_default, system_timer, operator(//), split_string, string_to_int, split_string_simple, inoutput, OUTPUT, PRINT_VERBOSE, PRINT_NERD, ran_normal, system_reseed_rng, system_get_random_seed + use linkedlist_module + use units_module + use periodictable_module + use linearalgebra_module + use dictionary_module + use paramreader_module + use atoms_module + use atoms_types_module + use topology_module + use mpi_context_module + use table_module +#ifdef DESCRIPTORS_NONCOMMERCIAL + use permutation_maker_module +#endif + use CInOutput_module + use clusters_module + use connection_module + use angular_functions_module + use gamma_module + + implicit none + + private +#ifdef GAP_VERSION + integer, parameter :: gap_version = GAP_VERSION +#else + integer, parameter :: gap_version = 0 +#endif + + + integer, parameter, public :: DT_NONE = 0 + integer, parameter, public :: DT_BISPECTRUM_SO4 = 1 + integer, parameter, public :: DT_BISPECTRUM_SO3 = 2 + integer, parameter, public :: DT_BEHLER = 3 + integer, parameter, public :: DT_DISTANCE_2B = 4 + integer, parameter, public :: DT_COORDINATION = 5 + integer, parameter, public :: DT_ANGLE_3B = 6 + integer, parameter, public :: DT_CO_ANGLE_3B = 7 + integer, parameter, public :: DT_CO_DISTANCE_2B = 8 + integer, parameter, public :: DT_COSNX = 9 + integer, parameter, public :: DT_TRIHIS = 10 + integer, parameter, public :: DT_WATER_MONOMER = 11 + integer, parameter, public :: DT_WATER_DIMER = 12 + integer, parameter, public :: DT_A2_DIMER = 13 + integer, parameter, public :: DT_AB_DIMER = 14 + integer, parameter, public :: DT_BOND_REAL_SPACE = 15 + integer, parameter, public :: DT_ATOM_REAL_SPACE = 16 + integer, parameter, public :: DT_POWER_SO3 = 17 + integer, parameter, public :: DT_POWER_SO4 = 18 + integer, parameter, public :: DT_SOAP = 19 + integer, parameter, public :: DT_AN_MONOMER = 20 + integer, parameter, public :: DT_GENERAL_MONOMER = 21 + integer, parameter, public :: DT_GENERAL_DIMER = 22 + integer, parameter, public :: DT_GENERAL_TRIMER = 23 + integer, parameter, public :: DT_RDF = 24 + integer, parameter, public :: DT_AS_DISTANCE_2B = 25 + integer, parameter, public :: DT_MOLECULE_LO_D = 26 + integer, parameter, public :: DT_alex = 27 + integer, parameter, public :: DT_COM_DIMER = 28 + integer, parameter, public :: DT_DISTANCE_NB = 29 + integer, parameter, public :: DT_SOAP_EXPRESS = 30 + integer, parameter, public :: DT_SOAP_TURBO = 31 + integer, parameter, public :: DT_WATER_TRIMER = 32 + + integer, parameter :: NP_WATER_DIMER = 8 + integer, parameter :: NP_A2_DIMER = 8 + integer, parameter :: NP_AB_DIMER = 2 + + type transfer_parameters_type + logical :: do_transfer + real(dp) :: factor, r0, width + endtype transfer_parameters_type + + type descriptor_data_mono + real(dp), dimension(:), allocatable :: data + real(dp), dimension(:,:,:), allocatable :: grad_data + ! ci : atom indices amongst which to distribute energy of descriptor + ! ii : all atoms involved in descriptor (for partial derivatives) + integer, dimension(:), allocatable :: ci, ii + real(dp), dimension(:,:), allocatable :: pos + logical :: has_data + logical, dimension(:), allocatable :: has_grad_data + + real(dp) :: covariance_cutoff = 1.0_dp + real(dp), dimension(:,:), allocatable :: grad_covariance_cutoff + endtype descriptor_data_mono + + type cplx_2d + complex(dp), dimension(:,:), allocatable :: mm + endtype cplx_2d + + type int_2d + integer , dimension(:,:), allocatable :: mm + endtype int_2d + + type real_2d + real(dp), dimension(:,:), allocatable :: mm + endtype real_2d + + type cplx_3d + complex(dp), dimension(:,:,:), allocatable :: mm + endtype cplx_3d + + !======================================================================= + !== begin descriptors + !======================================================================= + + + type RadialFunction_type + integer :: n_max + real(dp) :: cutoff, min_cutoff + real(dp), dimension(:,:), allocatable :: RadialTransform + real(dp), dimension(:), allocatable :: NormFunction + + logical :: initialised = .false. + endtype RadialFunction_type + + type fourier_SO4_type + real(dp) :: cutoff + real(dp) :: z0_ratio + real(dp) :: z0 + integer :: j_max, Z + integer, dimension(:), allocatable :: species_Z + real(dp), dimension(:), allocatable :: w + + logical :: initialised = .false. + endtype fourier_SO4_type + + type bispectrum_SO4 + real(dp), pointer :: cutoff + integer, pointer :: j_max, Z + real(dp), pointer :: z0_ratio + real(dp), pointer :: z0 + + integer, dimension(:), pointer :: species_Z + real(dp), dimension(:), pointer :: w + + type(fourier_SO4_type) :: fourier_SO4 + + logical :: initialised = .false. + + endtype bispectrum_SO4 + + type bispectrum_SO3 + + integer :: l_max, n_max, Z + real(dp) :: cutoff, min_cutoff + + type(RadialFunction_type) :: radial + + integer, dimension(:), allocatable :: species_Z + real(dp), dimension(:), allocatable :: w + + logical :: initialised = .false. + + endtype bispectrum_SO3 + + type behler_g2 + integer :: Z_n = 0 + real(dp) :: eta + real(dp) :: rs + real(dp) :: rc + endtype behler_g2 + + type behler_g3 + integer,dimension(2) :: Z_n = 0 + real(dp) :: eta + real(dp) :: lambda + real(dp) :: zeta + real(dp) :: rc + endtype behler_g3 + + type behler + + real(dp) :: cutoff = 0.0_dp + logical :: initialised = .false. + + integer :: Z = 0 + integer :: n_g2, n_g3 + type(behler_g2), dimension(:), allocatable :: g2 + type(behler_g3), dimension(:), allocatable :: g3 + + endtype behler + + type distance_2b + real(dp) :: cutoff + real(dp) :: cutoff_transition_width + integer :: Z1, Z2 + character(STRING_LENGTH) :: resid_name + logical :: only_intra, only_inter + + integer :: n_exponents, tail_exponent + real(dp) :: tail_range + integer, dimension(:), allocatable :: exponents + + logical :: has_tail + logical :: initialised = .false. + + endtype distance_2b + + type coordination + real(dp) :: cutoff + real(dp) :: transition_width + integer :: Z + + logical :: initialised = .false. + + endtype coordination + + type angle_3b + real(dp) :: cutoff + real(dp) :: cutoff_transition_width + integer :: Z, Z1, Z2 + + logical :: initialised = .false. + + endtype angle_3b + + type co_angle_3b + real(dp) :: cutoff + real(dp) :: coordination_cutoff + real(dp) :: coordination_transition_width + integer :: Z, Z1, Z2 + + logical :: initialised = .false. + + endtype co_angle_3b + + type co_distance_2b + real(dp) :: cutoff + real(dp) :: transition_width + real(dp) :: coordination_cutoff + real(dp) :: coordination_transition_width + integer :: Z1, Z2 + + logical :: initialised = .false. + + endtype co_distance_2b + + type cosnx + + integer :: l_max, n_max, Z + real(dp) :: cutoff, min_cutoff + + type(RadialFunction_type) :: radial + + integer, dimension(:), allocatable :: species_Z + real(dp), dimension(:), allocatable :: w + + logical :: initialised = .false. + + endtype cosnx + + type trihis + real(dp) :: cutoff + integer :: n_gauss + + real(dp), dimension(:,:), allocatable :: gauss_centre + real(dp), dimension(:,:), allocatable :: gauss_width + + logical :: initialised = .false. + + endtype trihis + + type water_monomer + real(dp) :: cutoff + + logical :: initialised = .false. + + endtype water_monomer + + type water_dimer + real(dp) :: cutoff, cutoff_transition_width + real(dp) :: monomer_cutoff + logical :: OHH_ordercheck + real(dp) :: power,dist_shift + + logical :: initialised = .false. + + endtype water_dimer + + type A2_dimer + real(dp) :: cutoff + real(dp) :: monomer_cutoff + integer :: atomic_number + + logical :: initialised = .false. + + endtype A2_dimer + + type AB_dimer + real(dp) :: cutoff + real(dp) :: monomer_cutoff + integer :: atomic_number1, atomic_number2 + + logical :: initialised = .false. + + endtype AB_dimer + + type atom_real_space + real(dp) :: cutoff + real(dp) :: cutoff_transition_width + integer :: l_max + real(dp) :: alpha + real(dp) :: zeta + + logical :: initialised = .false. + + endtype atom_real_space + + type power_so3 + integer :: l_max, n_max, Z + real(dp) :: cutoff, min_cutoff + + type(RadialFunction_type) :: radial + + integer, dimension(:), allocatable :: species_Z + real(dp), dimension(:), allocatable :: w + + logical :: initialised = .false. + endtype power_so3 + + type power_SO4 + real(dp), pointer :: cutoff + integer, pointer :: j_max, Z + real(dp), pointer :: z0_ratio + real(dp), pointer :: z0 + + integer, dimension(:), pointer :: species_Z + real(dp), dimension(:), pointer :: w + + type(fourier_SO4_type) :: fourier_SO4 + + logical :: initialised = .false. + + endtype power_SO4 + + type soap + real(dp) :: cutoff + real(dp) :: cutoff_transition_width + real(dp) :: alpha, atom_sigma, covariance_sigma0, central_weight + + integer :: cutoff_dexp + real(dp) :: cutoff_scale + real(dp) :: cutoff_rate + integer :: l_max, n_max, n_Z, n_species + + integer :: nu_R, nu_S + integer, dimension(:), allocatable :: species_Z, Z + real(dp), dimension(:), allocatable :: r_basis + real(dp), dimension(:,:,:), allocatable :: cholesky_overlap_basis + real(dp), dimension(:, :), allocatable :: transform_basis + + logical :: global = .false. + logical :: central_reference_all_species = .false. + logical :: diagonal_radial = .false. + logical :: normalise = .true. + logical :: initialised = .false. + + logical :: Z_mix = .false. + logical :: R_mix = .false. + logical :: sym_mix = .false. + logical :: coupling = .false. + integer :: K + integer :: mix_shift = 0 + + character(len=STRING_LENGTH) :: Z_map_str + character(len=STRING_LENGTH) :: radial_basis + real(dp), dimension(:,:,:), allocatable :: QR_factor + real(dp), dimension(:,:), allocatable :: QR_tau + endtype soap + + + type rdf + real(dp) :: cutoff + real(dp) :: transition_width, w_gauss + integer :: Z, n_gauss + real(dp), dimension(:), allocatable :: r_gauss + + logical :: initialised = .false. + + endtype rdf + + type as_distance_2b + real(dp) :: min_cutoff, max_cutoff, as_cutoff, overlap_alpha + real(dp) :: min_transition_width, max_transition_width, as_transition_width + real(dp) :: coordination_cutoff + real(dp) :: coordination_transition_width + integer :: Z1, Z2 + + logical :: initialised = .false. + + endtype as_distance_2b + + type alex + + integer :: Z, power_min, power_max + real(dp) :: cutoff + + integer :: n_species + integer, dimension(:), allocatable :: species_Z + + logical :: initialised = .false. + endtype alex + + + type distance_Nb + real(dp) :: cutoff + real(dp) :: cutoff_transition_width + integer :: order + integer, dimension(:), allocatable :: Z + integer :: n_permutations + integer, dimension(:,:), allocatable :: permutations + logical, dimension(:,:,:), allocatable :: monomerConnectivities + logical :: compact_clusters = .false. + logical :: initialised = .false. + endtype distance_Nb + + type soap_turbo + ! User controllable parameters + real(dp) :: rcut_hard, rcut_soft, nf + integer :: n_species, radial_enhancement, central_index, l_max, compress_P_nonzero + character(len=STRING_LENGTH) :: basis, scaling_mode, compress_file, compress_mode + + real(dp), dimension(:), allocatable :: atom_sigma_r, atom_sigma_r_scaling, & + atom_sigma_t, atom_sigma_t_scaling, amplitude_scaling, central_weight, compress_P_el + integer, dimension(:), allocatable :: species_Z, alpha_max, compress_P_i, compress_P_j + + logical :: initialised = .false., compress = .false. + endtype soap_turbo + +#ifdef DESCRIPTORS_NONCOMMERCIAL +#include "descriptors_noncommercial_types.inc" +#endif + + ! + ! All the descriptors need to be public so that they are visible to the python wrapper +#ifdef DESCRIPTORS_NONCOMMERCIAL + public :: soap, general_monomer, bispectrum_so4, bispectrum_so3, behler, distance_2b, & + coordination, angle_3b, co_angle_3b, co_distance_2b, cosnx, trihis, water_monomer, & + water_dimer, a2_dimer, bond_real_space, power_so3, power_so4, an_monomer, general_dimer, & + general_trimer, water_trimer, rdf, as_distance_2b, molecule_lo_d, alex, com_dimer, distance_nb, & + descriptor_data_mono, fourier_so4_type, radialfunction_type, transfer_parameters_type, & + ab_dimer, atom_real_space, spherical_harmonics_type, behler_g2, behler_g3, soap_turbo, soap_express +#else + public :: soap, bispectrum_so4, bispectrum_so3, behler, distance_2b, & + coordination, angle_3b, co_angle_3b, co_distance_2b, cosnx, trihis, water_monomer, & + water_dimer, a2_dimer, power_so3, power_so4, & + rdf, as_distance_2b, alex, distance_nb, & + descriptor_data_mono, fourier_so4_type, radialfunction_type, transfer_parameters_type, & + ab_dimer, atom_real_space, spherical_harmonics_type, behler_g2, behler_g3, & + soap_turbo +#endif + + !======================================================================= + !== end descriptors + !======================================================================= + + type descriptor + integer :: descriptor_type = DT_NONE + + type(bispectrum_SO4) :: descriptor_bispectrum_SO4 + type(bispectrum_SO3) :: descriptor_bispectrum_SO3 + type(behler) :: descriptor_behler + type(distance_2b) :: descriptor_distance_2b + type(coordination) :: descriptor_coordination + type(angle_3b) :: descriptor_angle_3b + type(co_angle_3b) :: descriptor_co_angle_3b + type(co_distance_2b) :: descriptor_co_distance_2b + type(cosnx) :: descriptor_cosnx + type(trihis) :: descriptor_trihis + type(water_monomer) :: descriptor_water_monomer + type(water_dimer) :: descriptor_water_dimer + type(A2_dimer) :: descriptor_A2_dimer + type(AB_dimer) :: descriptor_AB_dimer + type(atom_real_space) :: descriptor_atom_real_space + type(power_so3) :: descriptor_power_so3 + type(power_SO4) :: descriptor_power_SO4 + type(soap) :: descriptor_soap + type(rdf) :: descriptor_rdf + type(as_distance_2b) :: descriptor_as_distance_2b + type(alex) :: descriptor_alex + type(distance_Nb) :: descriptor_distance_Nb + type(soap_turbo) :: descriptor_soap_turbo +#ifdef DESCRIPTORS_NONCOMMERCIAL + type(AN_monomer) :: descriptor_AN_monomer + type(general_monomer) :: descriptor_general_monomer + type(general_dimer) :: descriptor_general_dimer + type(general_trimer) :: descriptor_general_trimer + type(water_trimer) :: descriptor_water_trimer + type(molecule_lo_d) :: descriptor_molecule_lo_d + type(com_dimer) :: descriptor_com_dimer + type(soap_express) :: descriptor_soap_express + type(bond_real_space) :: descriptor_bond_real_space +#endif + endtype + + type descriptor_data + type(descriptor_data_mono), dimension(:), allocatable :: x + endtype descriptor_data + + type cplx_1d + complex(dp), dimension(:), allocatable :: m + endtype cplx_1d + + type real_1d + real(dp), dimension(:), allocatable :: m + endtype real_1d + + type spherical_harmonics_type + type(cplx_1d), dimension(:), allocatable :: spherical_harmonics + type(cplx_2d), dimension(:), allocatable :: grad_spherical_harmonics + real(dp) :: r + real(dp), dimension(3) :: u + endtype spherical_harmonics_type + + type neighbour_type + type(spherical_harmonics_type), dimension(:), allocatable :: neighbour + endtype neighbour_type + + type grad_spherical_harmonics_overlap_type + type(cplx_3d), dimension(:), allocatable :: grad_integral + endtype grad_spherical_harmonics_overlap_type + + public :: neighbour_type, real_space_fourier_coefficients, real_space_covariance_coefficient + public :: SphericalYCartesian + + interface initialise +#ifdef DESCRIPTORS_NONCOMMERCIAL + module procedure descriptor_initialise, RadialFunction_initialise, fourier_so4_initialise, & + bispectrum_SO4_initialise, bispectrum_SO3_initialise, behler_initialise, distance_2b_initialise, & + coordination_initialise, angle_3b_initialise, co_angle_3b_initialise, co_distance_2b_initialise, cosnx_initialise, trihis_initialise, & + water_monomer_initialise, water_dimer_initialise, A2_dimer_initialise, AB_dimer_initialise, distance_Nb_initialise, rdf_initialise, as_distance_2b_initialise, alex_initialise, & + atom_real_space_initialise, power_so3_initialise, power_SO4_initialise, soap_initialise, soap_turbo_initialise, & + general_monomer_initialise, general_dimer_initialise, general_trimer_initialise, water_trimer_initialise, molecule_lo_d_initialise, AN_monomer_initialise, & + bond_real_space_initialise, transfer_initialise, com_dimer_initialise, soap_express_initialise +#else + module procedure descriptor_initialise, RadialFunction_initialise, fourier_so4_initialise, & + bispectrum_SO4_initialise, bispectrum_SO3_initialise, behler_initialise, distance_2b_initialise, & + coordination_initialise, angle_3b_initialise, co_angle_3b_initialise, co_distance_2b_initialise, cosnx_initialise, trihis_initialise, & + water_monomer_initialise, water_dimer_initialise, A2_dimer_initialise, AB_dimer_initialise, distance_Nb_initialise, rdf_initialise, as_distance_2b_initialise, alex_initialise, & + atom_real_space_initialise, power_so3_initialise, power_SO4_initialise, soap_initialise, soap_turbo_initialise +#endif + endinterface initialise + public :: initialise + + interface finalise +#ifdef DESCRIPTORS_NONCOMMERCIAL + module procedure descriptor_finalise, descriptor_data_finalise, RadialFunction_finalise, fourier_so4_finalise, cplx_2d_array1_finalise, cplx_3d_array2_finalise, & + bispectrum_SO4_finalise, bispectrum_SO3_finalise, behler_finalise, distance_2b_finalise, coordination_finalise, angle_3b_finalise, co_angle_3b_finalise, & + co_distance_2b_finalise, cosnx_finalise, trihis_finalise, water_monomer_finalise, water_dimer_finalise, rdf_finalise, as_distance_2b_finalise, alex_finalise, & + A2_dimer_finalise, AB_dimer_finalise, atom_real_space_finalise, power_so3_finalise, power_SO4_finalise, soap_finalise, distance_Nb_finalise, soap_turbo_finalise, & + AN_monomer_finalise, general_monomer_finalise, general_dimer_finalise, general_trimer_finalise, water_trimer_finalise, molecule_lo_d_finalise, com_dimer_finalise, & + bond_real_space_finalise, soap_express_finalise +#else + module procedure descriptor_finalise, descriptor_data_finalise, RadialFunction_finalise, fourier_so4_finalise, cplx_2d_array1_finalise, cplx_3d_array2_finalise, & + bispectrum_SO4_finalise, bispectrum_SO3_finalise, behler_finalise, distance_2b_finalise, coordination_finalise, angle_3b_finalise, co_angle_3b_finalise, & + co_distance_2b_finalise, cosnx_finalise, trihis_finalise, water_monomer_finalise, water_dimer_finalise, rdf_finalise, as_distance_2b_finalise, alex_finalise, & + A2_dimer_finalise, AB_dimer_finalise, atom_real_space_finalise, power_so3_finalise, power_SO4_finalise, soap_finalise, distance_Nb_finalise, soap_turbo_finalise +#endif + endinterface finalise + public :: finalise + + interface calc +#ifdef DESCRIPTORS_NONCOMMERCIAL + module procedure descriptor_calc, descriptor_calc_array, bispectrum_SO4_calc, bispectrum_SO3_calc, behler_calc, distance_2b_calc, coordination_calc, angle_3b_calc, co_angle_3b_calc, & + co_distance_2b_calc, cosnx_calc, trihis_calc, water_monomer_calc, water_dimer_calc, A2_dimer_calc, AB_dimer_calc, atom_real_space_calc, & + power_so3_calc, power_SO4_calc, soap_calc, rdf_calc, as_distance_2b_calc, & + distance_Nb_calc, alex_calc, soap_turbo_calc, & + AN_monomer_calc, soap_express_calc, general_monomer_calc, general_dimer_calc, general_trimer_calc, water_trimer_calc, molecule_lo_d_calc, com_dimer_calc, bond_real_space_calc +#else + module procedure descriptor_calc, descriptor_calc_array, bispectrum_SO4_calc, bispectrum_SO3_calc, behler_calc, distance_2b_calc, coordination_calc, angle_3b_calc, co_angle_3b_calc, & + co_distance_2b_calc, cosnx_calc, trihis_calc, water_monomer_calc, water_dimer_calc, A2_dimer_calc, AB_dimer_calc, atom_real_space_calc, & + power_so3_calc, power_SO4_calc, soap_calc, rdf_calc, as_distance_2b_calc, & + distance_Nb_calc, alex_calc, soap_turbo_calc + +#endif + endinterface calc + public :: calc + + interface cutoff +#ifdef DESCRIPTORS_NONCOMMERCIAL + module procedure descriptor_cutoff, bispectrum_SO4_cutoff, bispectrum_SO3_cutoff, behler_cutoff, distance_2b_cutoff, coordination_cutoff, angle_3b_cutoff, co_angle_3b_cutoff, & + co_distance_2b_cutoff, cosnx_cutoff, trihis_cutoff, water_monomer_cutoff, water_dimer_cutoff, A2_dimer_cutoff, AB_dimer_cutoff, atom_real_space_cutoff, & + power_so3_cutoff, power_SO4_cutoff, soap_cutoff, alex_cutoff, distance_Nb_cutoff, rdf_cutoff, as_distance_2b_cutoff, soap_turbo_cutoff, & + molecule_lo_d_cutoff, com_dimer_cutoff, soap_express_cutoff, AN_monomer_cutoff, general_monomer_cutoff, general_dimer_cutoff, general_trimer_cutoff, water_trimer_cutoff, bond_real_space_cutoff +#else + module procedure descriptor_cutoff, bispectrum_SO4_cutoff, bispectrum_SO3_cutoff, behler_cutoff, distance_2b_cutoff, coordination_cutoff, angle_3b_cutoff, co_angle_3b_cutoff, & + co_distance_2b_cutoff, cosnx_cutoff, trihis_cutoff, water_monomer_cutoff, water_dimer_cutoff, A2_dimer_cutoff, AB_dimer_cutoff, atom_real_space_cutoff, & + power_so3_cutoff, power_SO4_cutoff, soap_cutoff, alex_cutoff, distance_Nb_cutoff, rdf_cutoff, as_distance_2b_cutoff, soap_turbo_cutoff +#endif + endinterface cutoff + public :: cutoff + + interface descriptor_sizes +#ifdef DESCRIPTORS_NONCOMMERCIAL + module procedure descriptor_sizes, bispectrum_SO4_sizes, bispectrum_SO3_sizes, behler_sizes, distance_2b_sizes, coordination_sizes, angle_3b_sizes, co_angle_3b_sizes, & + co_distance_2b_sizes, cosnx_sizes, trihis_sizes, water_monomer_sizes, water_dimer_sizes, A2_dimer_sizes, AB_dimer_sizes, atom_real_space_sizes, & + power_so3_sizes, power_SO4_sizes, soap_sizes, rdf_sizes, as_distance_2b_sizes, & + alex_sizes, distance_Nb_sizes, soap_turbo_sizes, & + molecule_lo_d_sizes, com_dimer_sizes, soap_express_sizes, AN_monomer_sizes, general_monomer_sizes, general_dimer_sizes, general_trimer_sizes, water_trimer_sizes, bond_real_space_sizes +#else + module procedure descriptor_sizes, bispectrum_SO4_sizes, bispectrum_SO3_sizes, behler_sizes, distance_2b_sizes, coordination_sizes, angle_3b_sizes, co_angle_3b_sizes, & + co_distance_2b_sizes, cosnx_sizes, trihis_sizes, water_monomer_sizes, water_dimer_sizes, A2_dimer_sizes, AB_dimer_sizes, atom_real_space_sizes, & + power_so3_sizes, power_SO4_sizes, soap_sizes, rdf_sizes, as_distance_2b_sizes, & + alex_sizes, distance_Nb_sizes, soap_turbo_sizes +#endif + endinterface descriptor_sizes + public :: descriptor_sizes + + public :: descriptor_MPI_setup + + public :: descriptor, descriptor_data, descriptor_dimensions, descriptor_n_permutations, descriptor_permutations, descriptor_str_add_species + public :: real_space_covariance + public :: cplx_1d, cplx_2d + + contains + + +#ifdef DESCRIPTORS_NONCOMMERCIAL +#include "descriptors_noncommercial.inc" +#endif + + function get_descriptor_type(args_str,error) + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + integer :: get_descriptor_type + + type(Dictionary) :: params + logical :: is_bispectrum_so4, is_bispectrum_so3, is_behler, is_distance_2b, is_coordination, is_angle_3b, & + is_co_angle_3b, is_co_distance_2b, is_cosnx, is_trihis, is_water_monomer, is_water_dimer, is_A2_dimer, & + is_AB_dimer, is_bond_real_space, is_atom_real_space, is_power_so3, is_power_so4, is_soap, & + is_AN_monomer, is_general_monomer, is_general_dimer, is_general_trimer, is_water_trimer, is_rdf, is_as_distance_2b, & + is_molecule_lo_d, is_alex, is_com_dimer, is_distance_Nb, is_soap_express, is_soap_turbo + integer n_true + INIT_ERROR(error) + + call initialise(params) + call param_register(params, 'bispectrum_so4', 'false', is_bispectrum_so4, help_string="Type of descriptor is bispectrum_so4.") + call param_register(params, 'bispectrum_so3', 'false', is_bispectrum_so3, help_string="Type of descriptor is bispectrum_so3.") + call param_register(params, 'behler', 'false', is_behler, help_string="Type of descriptor is behler.") + call param_register(params, 'distance_2b', 'false', is_distance_2b, help_string="Type of descriptor is distance_2b.") + call param_register(params, 'coordination', 'false', is_coordination, help_string="Type of descriptor is coordination.") + call param_register(params, 'angle_3b', 'false', is_angle_3b, help_string="Type of descriptor is angle_3b.") + call param_register(params, 'co_angle_3b', 'false', is_co_angle_3b, help_string="Type of descriptor is co_angle_3b.") + call param_register(params, 'co_distance_2b', 'false', is_co_distance_2b, help_string="Type of descriptor is co_distance_2b.") + call param_register(params, 'cosnx', 'false', is_cosnx, help_string="Type of descriptor is cosnx.") + call param_register(params, 'trihis', 'false', is_trihis, help_string="Type of descriptor is trihis.") + call param_register(params, 'water_monomer', 'false', is_water_monomer, help_string="Type of descriptor is water_monomer.") + call param_register(params, 'water_dimer', 'false', is_water_dimer, help_string="Type of descriptor is water_dimer.") + call param_register(params, 'A2_dimer', 'false', is_A2_dimer, help_string="Type of descriptor is A2_dimer.") + call param_register(params, 'AB_dimer', 'false', is_AB_dimer, help_string="Type of descriptor is AB_dimer.") + call param_register(params, 'bond_real_space', 'false', is_bond_real_space, help_string="Type of descriptor is bond_real_space.") + call param_register(params, 'atom_real_space', 'false', is_atom_real_space, help_string="Type of descriptor is atom_real_space.") + call param_register(params, 'power_so3', 'false', is_power_so3, help_string="Type of descriptor is power_so3.") + call param_register(params, 'power_so4', 'false', is_power_so4, help_string="Type of descriptor is power_so4.") + call param_register(params, 'soap', 'false', is_soap, help_string="Type of descriptor is soap.") + call param_register(params, 'AN_monomer', 'false', is_AN_monomer, help_string="Type of descriptor is AN_monomer.") + call param_register(params, 'general_monomer', 'false', is_general_monomer, help_string="Type of descriptor is general_monomer.") + call param_register(params, 'general_dimer', 'false', is_general_dimer, help_string="Type of descriptor is general_dimer.") + call param_register(params, 'general_trimer', 'false', is_general_trimer, help_string="Type of descriptor is general_trimer.") + call param_register(params, 'water_trimer', 'false', is_water_trimer, help_string="Type of descriptor is water_trimer.") + call param_register(params, 'rdf', 'false', is_rdf, help_string="Type of descriptor is rdf.") + call param_register(params, 'as_distance_2b', 'false', is_as_distance_2b, help_string="Type of descriptor is as_distance_2b.") + call param_register(params, 'molecule_lo_d', 'false', is_molecule_lo_d, help_string="Type of descriptor is molecule_lo_d.") + call param_register(params, 'alex', 'false', is_alex, help_string="Type of descriptor is alex.") + call param_register(params, 'com_dimer', 'false', is_com_dimer, help_string="Type of descriptor is com_dimer.") + call param_register(params, 'distance_Nb', 'false', is_distance_Nb, help_string="Type of descriptor is distance_Nb.") + call param_register(params, 'soap_express', 'false', is_soap_express, help_string="Type of descriptor is soap_express.") + call param_register(params, 'soap_turbo', 'false', is_soap_turbo, help_string="Type of descriptor is soap_turbo.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='descriptor_initialise args_str')) then + RAISE_ERROR("descriptor_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + n_true = count( (/is_bispectrum_so4, is_bispectrum_so3, is_behler, is_distance_2b, is_coordination, is_angle_3b, is_co_angle_3b, is_co_distance_2b, & + is_cosnx, is_trihis, is_water_monomer, is_water_dimer, is_A2_dimer, is_AB_dimer, is_bond_real_space, is_atom_real_space, is_power_so3, is_power_so4, & + is_soap, is_AN_monomer, is_general_monomer, is_general_dimer, is_general_trimer, is_water_trimer, is_rdf, is_as_distance_2b, is_molecule_lo_d, is_alex, is_com_dimer, & + is_distance_Nb, is_soap_express, is_soap_turbo /) ) + if (n_true/= 1) then + RAISE_ERROR("descriptor_initialise found "//n_true//" IP Model types args_str='"//trim(args_str)//"'", error) + endif + + get_descriptor_type = DT_NONE + + if( is_bispectrum_so4 ) then + get_descriptor_type = DT_BISPECTRUM_SO4 + elseif( is_bispectrum_so3 ) then + get_descriptor_type = DT_BISPECTRUM_SO3 + elseif( is_behler ) then + get_descriptor_type = DT_BEHLER + elseif( is_distance_2b ) then + get_descriptor_type = DT_DISTANCE_2B + elseif( is_coordination ) then + get_descriptor_type = DT_COORDINATION + elseif( is_angle_3b ) then + get_descriptor_type = DT_ANGLE_3B + elseif( is_co_angle_3b ) then + get_descriptor_type = DT_CO_ANGLE_3B + elseif( is_co_distance_2b ) then + get_descriptor_type = DT_CO_DISTANCE_2B + elseif( is_cosnx ) then + get_descriptor_type = DT_COSNX + elseif( is_trihis ) then + get_descriptor_type = DT_TRIHIS + elseif( is_water_monomer ) then + get_descriptor_type = DT_WATER_MONOMER + elseif( is_water_dimer ) then + get_descriptor_type = DT_WATER_DIMER + elseif( is_A2_dimer ) then + get_descriptor_type = DT_A2_DIMER + elseif( is_AB_dimer ) then + get_descriptor_type = DT_AB_DIMER + elseif( is_bond_real_space ) then + get_descriptor_type = DT_BOND_REAL_SPACE + elseif( is_atom_real_space ) then + get_descriptor_type = DT_ATOM_REAL_SPACE + elseif( is_power_so3 ) then + get_descriptor_type = DT_POWER_SO3 + elseif( is_power_so4 ) then + get_descriptor_type = DT_POWER_SO4 + elseif( is_soap ) then + get_descriptor_type = DT_SOAP + elseif( is_AN_monomer ) then + get_descriptor_type = DT_AN_MONOMER + elseif( is_general_monomer ) then + get_descriptor_type = DT_GENERAL_MONOMER + elseif( is_general_dimer ) then + get_descriptor_type = DT_GENERAL_DIMER + elseif( is_general_trimer ) then + get_descriptor_type = DT_GENERAL_TRIMER + elseif( is_water_trimer ) then + get_descriptor_type = DT_WATER_TRIMER + elseif( is_rdf ) then + get_descriptor_type = DT_RDF + elseif( is_as_distance_2b ) then + get_descriptor_type = DT_AS_DISTANCE_2B + elseif( is_molecule_lo_d ) then + get_descriptor_type = DT_MOLECULE_LO_D + elseif( is_alex ) then + get_descriptor_type = DT_ALEX + elseif( is_com_dimer ) then + get_descriptor_type = DT_COM_DIMER + elseif( is_distance_Nb ) then + get_descriptor_type = DT_DISTANCE_NB + elseif( is_soap_express ) then + get_descriptor_type = DT_SOAP_EXPRESS + elseif( is_soap_turbo ) then + get_descriptor_type = DT_SOAP_TURBO + endif + + endfunction get_descriptor_type + + subroutine descriptor_initialise(this,args_str,error) + type(descriptor), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + call finalise(this) + + this%descriptor_type = get_descriptor_type(args_str,error) + + select case(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + call initialise(this%descriptor_bispectrum_SO4,args_str,error) + case(DT_BISPECTRUM_SO3) + call initialise(this%descriptor_bispectrum_SO3,args_str,error) + case(DT_BEHLER) + call initialise(this%descriptor_behler,args_str,error) + case(DT_DISTANCE_2B) + call initialise(this%descriptor_distance_2b,args_str,error) + case(DT_COORDINATION) + call initialise(this%descriptor_coordination,args_str,error) + case(DT_ANGLE_3B) + call initialise(this%descriptor_angle_3b,args_str,error) + case(DT_CO_ANGLE_3B) + call initialise(this%descriptor_co_angle_3b,args_str,error) + case(DT_CO_DISTANCE_2B) + call initialise(this%descriptor_co_distance_2b,args_str,error) + case(DT_COSNX) + call initialise(this%descriptor_cosnx,args_str,error) + case(DT_TRIHIS) + call initialise(this%descriptor_trihis,args_str,error) + case(DT_WATER_MONOMER) + call initialise(this%descriptor_water_monomer,args_str,error) + case(DT_WATER_DIMER) + call initialise(this%descriptor_water_dimer,args_str,error) + case(DT_A2_DIMER) + call initialise(this%descriptor_A2_dimer,args_str,error) + case(DT_AB_DIMER) + call initialise(this%descriptor_AB_dimer,args_str,error) + case(DT_ATOM_REAL_SPACE) + call initialise(this%descriptor_atom_real_space,args_str,error) + case(DT_POWER_SO3) + call initialise(this%descriptor_power_so3,args_str,error) + case(DT_POWER_SO4) + call initialise(this%descriptor_power_so4,args_str,error) + case(DT_SOAP) + call initialise(this%descriptor_soap,args_str,error) + case(DT_RDF) + call initialise(this%descriptor_rdf,args_str,error) + case(DT_AS_DISTANCE_2B) + call initialise(this%descriptor_as_distance_2b,args_str,error) + case(DT_ALEX) + call initialise(this%descriptor_alex,args_str,error) + case(DT_DISTANCE_NB) + call initialise(this%descriptor_distance_Nb,args_str,error) + case(DT_SOAP_TURBO) + call initialise(this%descriptor_soap_turbo,args_str,error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_BOND_REAL_SPACE) + call initialise(this%descriptor_bond_real_space,args_str,error) + case(DT_AN_MONOMER) + call initialise(this%descriptor_AN_monomer,args_str,error) + case(DT_COM_DIMER) + call initialise(this%descriptor_com_dimer,args_str,error) + case(DT_MOLECULE_LO_D) + call initialise(this%descriptor_molecule_lo_d,args_str,error) + case(DT_GENERAL_MONOMER) + call initialise(this%descriptor_general_monomer,args_str,error) + case(DT_GENERAL_DIMER) + call initialise(this%descriptor_general_dimer,args_str,error) + case(DT_GENERAL_TRIMER) + call initialise(this%descriptor_general_trimer,args_str,error) + case(DT_WATER_TRIMER) + call initialise(this%descriptor_water_trimer,args_str,error) + case(DT_SOAP_EXPRESS) + call initialise(this%descriptor_soap_express,args_str,error) +#endif + endselect + + endsubroutine descriptor_initialise + + subroutine descriptor_finalise(this,error) + type(descriptor), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + call finalise(this%descriptor_bispectrum_SO4,error) + case(DT_BISPECTRUM_SO3) + call finalise(this%descriptor_bispectrum_SO3,error) + case(DT_BEHLER) + call finalise(this%descriptor_behler,error) + case(DT_DISTANCE_2b) + call finalise(this%descriptor_distance_2b,error) + case(DT_COORDINATION) + call finalise(this%descriptor_coordination,error) + case(DT_ANGLE_3B) + call finalise(this%descriptor_angle_3b,error) + case(DT_CO_ANGLE_3B) + call finalise(this%descriptor_co_angle_3b,error) + case(DT_CO_DISTANCE_2b) + call finalise(this%descriptor_co_distance_2b,error) + case(DT_COSNX) + call finalise(this%descriptor_cosnx,error) + case(DT_TRIHIS) + call finalise(this%descriptor_trihis,error) + case(DT_WATER_MONOMER) + call finalise(this%descriptor_water_monomer,error) + case(DT_WATER_DIMER) + call finalise(this%descriptor_water_dimer,error) + case(DT_A2_dimer) + call finalise(this%descriptor_A2_dimer,error) + case(DT_AB_dimer) + call finalise(this%descriptor_AB_dimer,error) + case(DT_ATOM_REAL_SPACE) + call finalise(this%descriptor_atom_real_space,error) + case(DT_POWER_SO3) + call finalise(this%descriptor_power_so3,error) + case(DT_POWER_SO4) + call finalise(this%descriptor_power_so4,error) + case(DT_SOAP) + call finalise(this%descriptor_soap,error) + case(DT_RDF) + call finalise(this%descriptor_rdf,error) + case(DT_AS_DISTANCE_2b) + call finalise(this%descriptor_as_distance_2b,error) + case(DT_ALEX) + call finalise(this%descriptor_alex,error) + case(DT_DISTANCE_Nb) + call finalise(this%descriptor_distance_Nb,error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_COM_DIMER) + call finalise(this%descriptor_com_dimer,error) + case(DT_MOLECULE_LO_D) + call finalise(this%descriptor_molecule_lo_d,error) + case(DT_BOND_REAL_SPACE) + call finalise(this%descriptor_bond_real_space,error) + case(DT_GENERAL_MONOMER) + call finalise(this%descriptor_general_monomer,error) + case(DT_GENERAL_DIMER) + call finalise(this%descriptor_general_dimer,error) + case(DT_GENERAL_TRIMER) + call finalise(this%descriptor_general_trimer,error) + case(DT_WATER_TRIMER) + call finalise(this%descriptor_water_trimer,error) + case(DT_SOAP_EXPRESS) + call finalise(this%descriptor_soap_express,error) + case(DT_SOAP_TURBO) + call finalise(this%descriptor_soap_turbo,error) +#endif + endselect + + this%descriptor_type = DT_NONE + + endsubroutine descriptor_finalise + + subroutine descriptor_MPI_setup(this,at,mpi,mpi_mask,error) + type(descriptor), intent(in) :: this + type(atoms), intent(in) :: at + type(MPI_Context), intent(in) :: mpi + logical, dimension(:), intent(out) :: mpi_mask + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(mpi%active) then + select case(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_BISPECTRUM_SO3) + RAISE_ERROR("descriptor_MPI_setup: bispectrum_so3 not MPI ready.", error) + case(DT_BEHLER) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_DISTANCE_2B) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_COORDINATION) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_ANGLE_3B) + RAISE_ERROR("descriptor_MPI_setup: angle_3b not MPI ready.", error) + case(DT_CO_ANGLE_3B) + RAISE_ERROR("descriptor_MPI_setup: co_angle_3b not MPI ready.", error) + case(DT_CO_DISTANCE_2B) + RAISE_ERROR("descriptor_MPI_setup: co_distance_2b not MPI ready.", error) + case(DT_COSNX) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_TRIHIS) + RAISE_ERROR("descriptor_MPI_setup: trihis not MPI ready.", error) + case(DT_WATER_MONOMER) + call descriptor_water_monomer_dimer_MPI_setup(at,mpi,mpi_mask,error) + case(DT_WATER_DIMER) + call descriptor_water_monomer_dimer_MPI_setup(at,mpi,mpi_mask,error) + case(DT_A2_DIMER) + RAISE_ERROR("descriptor_MPI_setup: A2_dimer not MPI ready.", error) + case(DT_AB_DIMER) + RAISE_ERROR("descriptor_MPI_setup: AB_dimer not MPI ready.", error) + case(DT_ATOM_REAL_SPACE) + RAISE_ERROR("descriptor_MPI_setup: atom_real_space not MPI ready.", error) + case(DT_POWER_SO3) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_POWER_SO4) + RAISE_ERROR("descriptor_MPI_setup: power_SO4 not MPI ready.", error) + case(DT_SOAP) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_RDF) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_AS_DISTANCE_2B) + RAISE_ERROR("descriptor_MPI_setup: as_distance_2b not MPI ready.", error) + case(DT_ALEX) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_DISTANCE_NB) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + case(DT_SOAP_TURBO) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_MOLECULE_LO_D) + RAISE_ERROR("descriptor_MPI_setup: molecule_lo_d not MPI ready.", error) + case(DT_BOND_REAL_SPACE) + RAISE_ERROR("descriptor_MPI_setup: bond_real_space not MPI ready.", error) + case(DT_AN_MONOMER) + RAISE_ERROR("descriptor_MPI_setup: AN_monomer not MPI ready.", error) + case(DT_GENERAL_MONOMER) + call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) + case(DT_GENERAL_DIMER) + call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) + case(DT_GENERAL_TRIMER) + call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) + case(DT_COM_DIMER) + call descriptor_general_monomer_nmer_MPI_setup(this,at,mpi,mpi_mask,error) + case(DT_SOAP_EXPRESS) + call descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) +#endif + case default + RAISE_ERROR("descriptor_MPI_setup: descriptor type "//this%descriptor_type//" not recognised.",error) + endselect + else + mpi_mask = .true. + endif + + endsubroutine descriptor_MPI_setup + + subroutine descriptor_atomic_MPI_setup(at,mpi,mpi_mask,error) + type(atoms), intent(in) :: at + type(MPI_Context), intent(in) :: mpi + logical, dimension(:), intent(out) :: mpi_mask + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + mpi_mask = .false. + do i = 1, at%N + if( mod(i-1, mpi%n_procs) == mpi%my_proc ) mpi_mask(i) = .true. + enddo + + endsubroutine descriptor_atomic_MPI_setup + + subroutine descriptor_water_monomer_dimer_MPI_setup(at,mpi,mpi_mask,error) + type(atoms), intent(in) :: at + type(MPI_Context), intent(in) :: mpi + logical, dimension(:), intent(out) :: mpi_mask + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + mpi_mask = .false. + do i = 1, at%N + if( at%Z(i) == 8 .and. mod(i-1, mpi%n_procs) == mpi%my_proc ) mpi_mask(i) = .true. + enddo + + endsubroutine descriptor_water_monomer_dimer_MPI_setup + + + subroutine descriptor_data_finalise(this,error) + type(descriptor_data), intent(inout) :: this + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(allocated(this%x)) then + do i = 1, size(this%x) + if(allocated(this%x(i)%data)) deallocate(this%x(i)%data) + if(allocated(this%x(i)%grad_data)) deallocate(this%x(i)%grad_data) + if(allocated(this%x(i)%ci)) deallocate(this%x(i)%ci) + if(allocated(this%x(i)%ii)) deallocate(this%x(i)%ii) + if(allocated(this%x(i)%pos)) deallocate(this%x(i)%pos) + if(allocated(this%x(i)%has_grad_data)) deallocate(this%x(i)%has_grad_data) + if(allocated(this%x(i)%grad_covariance_cutoff)) deallocate(this%x(i)%grad_covariance_cutoff) + enddo + deallocate(this%x) + endif + + endsubroutine descriptor_data_finalise + + subroutine RadialFunction_initialise(this,n_max,cutoff, min_cutoff,error) + type(RadialFunction_type), intent(inout) :: this + integer, intent(in) :: n_max + real(dp), intent(in) :: cutoff, min_cutoff + integer, optional, intent(out) :: error + + real(dp), dimension(:,:), allocatable :: S, vS + real(dp), dimension(:), allocatable :: eS + integer :: i, j + + INIT_ERROR(error) + + call finalise(this) + + this%n_max = n_max + this%cutoff = cutoff + this%min_cutoff = min_cutoff + + allocate(this%RadialTransform(this%n_max,this%n_max),this%NormFunction(this%n_max)) + allocate(S(this%n_max,this%n_max), vS(this%n_max,this%n_max), eS(this%n_max)) + + do i = 1, this%n_max + this%NormFunction(i) = sqrt(this%cutoff**(2.0_dp*i+5.0_dp)/(2.0_dp*i+5.0_dp)) + do j = 1, this%n_max + S(j,i) = sqrt((2.0_dp*i+5)*(2.0_dp*j+5))/(i+j+5.0_dp) + enddo + enddo + + call diagonalise(S,eS,vS) + this%RadialTransform = matmul(matmul(vS,diag(1.0_dp/sqrt(eS))),transpose(vS)) + + if(allocated(S)) deallocate(S) + if(allocated(vS)) deallocate(vS) + if(allocated(eS)) deallocate(eS) + + this%initialised = .true. + + endsubroutine RadialFunction_initialise + + subroutine RadialFunction_finalise(this,error) + type(RadialFunction_type), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%min_cutoff = 0.0_dp + this%n_max = 0 + + if(allocated(this%RadialTransform)) deallocate(this%RadialTransform) + if(allocated(this%NormFunction)) deallocate(this%NormFunction) + + this%initialised = .false. + + endsubroutine RadialFunction_finalise + + subroutine cplx_2d_array1_finalise(this) + type(cplx_2d), dimension(:), allocatable, intent(inout) :: this + integer :: j + + if(allocated(this)) then + do j = lbound(this,1), ubound(this,1) + if(allocated(this(j)%mm)) deallocate(this(j)%mm) + enddo + deallocate(this) + endif + endsubroutine cplx_2d_array1_finalise + + subroutine cplx_3d_array2_finalise(this) + type(cplx_3d), dimension(:,:), allocatable, intent(inout) :: this + integer :: i, j + + if(allocated(this)) then + do j = lbound(this,2), ubound(this,2) + do i = lbound(this,1), ubound(this,1) + if(allocated(this(i,j)%mm)) deallocate(this(i,j)%mm) + enddo + enddo + deallocate(this) + endif + + endsubroutine cplx_3d_array2_finalise + + subroutine fourier_SO4_calc(this,at,i,U,dU,args_str,error) + type(fourier_SO4_type), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(in) :: i + type(cplx_2d), dimension(:), allocatable, intent(inout) :: U + type(cplx_3d), dimension(:,:), allocatable, intent(inout), optional :: dU + integer, optional, intent(out) :: error + character(len=*), intent(in), optional :: args_str + + complex(dp), dimension(:,:), allocatable :: Uc, Up + complex(dp), dimension(:,:,:), allocatable :: dUc, dUp + complex(dp) :: z0_pls_Iz, z0_min_Iz, x_pls_Iy, x_min_Iy + complex(dp), dimension(3) :: dz0_pls_Iz, dz0_min_Iz, dx_pls_Iy, dx_min_Iy + real(dp), dimension(3) :: diff, u_ij, dfcut, dz0, dr0 + real(dp) :: r0, r, fcut, z0, theta0 + integer :: n, n_i, ji, j, m1, m2 + integer, dimension(total_elements) :: species_map + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR('fourier_SO4_calc: object not initialised',error) + endif + + species_map = 0 + do j = 1, size(this%species_Z) + if(this%species_Z(j) == 0) then + species_map = 1 + else + species_map(this%species_Z(j)) = j + endif + enddo + + + if(allocated(U)) then + if(lbound(U,1) /= 0 .or. ubound(U,1) /= this%j_max) call finalise(U) + endif + + if(.not.allocated(U)) then + allocate( U(0:this%j_max) ) + do j = 0, this%j_max + allocate( U(j)%mm(-j:j,-j:j) ) + U(j)%mm = CPLX_ZERO + enddo + endif + + do j = 0, this%j_max + U(j)%mm = CPLX_ZERO + do m1 = -j, j, 2 + U(j)%mm(m1,m1) = CPLX_ONE + enddo + enddo + + allocate( Uc(-this%j_max:this%j_max, -this%j_max:this%j_max), & + Up(-this%j_max:this%j_max, -this%j_max:this%j_max) ) + + Uc = CPLX_ZERO + Up = CPLX_ZERO + + if(present(dU)) then + if(allocated(dU)) call finalise(dU) + + ! dU is not allocated, allocate and zero it + allocate( dU(0:this%j_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) + do j = 0, this%j_max + allocate( dU(j,0)%mm(3,-j:j,-j:j) ) + dU(j,0)%mm = CPLX_ZERO + enddo + + allocate( dUc(3,-this%j_max:this%j_max, -this%j_max:this%j_max), & + dUp(3,-this%j_max:this%j_max, -this%j_max:this%j_max) ) + dUc = CPLX_ZERO + dUp = CPLX_ZERO + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + ji = neighbour(at, i, n, distance=r, diff=diff, cosines=u_ij) + if( r >= this%cutoff ) cycle + + n_i = n_i + 1 + + theta0 = r / this%z0 + z0 = r / tan( theta0 ) + r0 = sin( theta0 ) / r + + z0_pls_Iz = ( z0 + CPLX_IMAG*diff(3) ) * r0 + z0_min_Iz = ( z0 - CPLX_IMAG*diff(3) ) * r0 + x_pls_Iy = ( diff(1) + CPLX_IMAG*diff(2) ) * r0 + x_min_Iy = ( diff(1) - CPLX_IMAG*diff(2) ) * r0 + + fcut = cos_cutoff_function(r,this%cutoff) * this%w(species_map(at%Z(ji))) + + U(0)%mm(0,0) = U(0)%mm(0,0) + fcut + Up(0:0,0:0) = CPLX_ONE + + if(present(dU)) then + + dfcut = -dcos_cutoff_function(r,this%cutoff)*u_ij * this%w(species_map(at%Z(ji))) + dz0 = ( 1.0_dp / tan( theta0 ) - theta0 / sin(theta0)**2 ) * u_ij + dr0 = ( cos( theta0 ) / (r*this%z0) - r0 / r ) * u_ij + + dz0_pls_Iz = ( z0 + CPLX_IMAG*diff(3) )*dr0 + dz0*r0 + dz0_pls_Iz(3) = dz0_pls_Iz(3) + CPLX_IMAG*r0 + + dz0_min_Iz = ( z0 - CPLX_IMAG*diff(3) )*dr0 + dz0*r0 + dz0_min_Iz(3) = dz0_min_Iz(3) - CPLX_IMAG*r0 + + dx_pls_Iy = ( diff(1) + CPLX_IMAG*diff(2) )*dr0 + dx_pls_Iy(1) = dx_pls_Iy(1) + r0 + dx_pls_Iy(2) = dx_pls_Iy(2) + CPLX_IMAG*r0 + + dx_min_Iy = ( diff(1) - CPLX_IMAG*diff(2) )*dr0 + dx_min_Iy(1) = dx_min_Iy(1) + r0 + dx_min_Iy(2) = dx_min_Iy(2) - CPLX_IMAG*r0 + + dUc = CPLX_ZERO + dUp = CPLX_ZERO + + dU(0,0)%mm(:,0,0) = dU(0,0)%mm(:,0,0) + dfcut*CPLX_ONE + + allocate( dU(0,n_i)%mm(3,-0:0,-0:0) ) + + dU(0,n_i)%mm(:,0,0) = - dfcut*CPLX_ONE + endif + + do j = 1, this%j_max + Uc(-j:j,-j:j) = CPLX_ZERO + if(present(dU)) then + dUc(:,-j:j,-j:j) = CPLX_ZERO + allocate( dU(j,n_i)%mm(3,-j:j,-j:j) ) + dU(j,n_i)%mm = CPLX_ZERO + endif + + do m1 = -j, j-2, 2 + do m2 = -j, j, 2 + if( (j-m2) /= 0 ) then + Uc(m2,m1) = Uc(m2,m1) + & + sqrt( real(j-m2,dp)/real(j-m1,dp) ) * z0_pls_Iz * Up(m2+1,m1+1) + + if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) + & + sqrt( real(j-m2,dp)/real(j-m1,dp) ) * & + ( dz0_pls_Iz * Up(m2+1,m1+1) + z0_pls_Iz * dUp(:,m2+1,m1+1) ) + endif + + if( (j+m2) /= 0 ) then + Uc(m2,m1) = Uc(m2,m1) - & + CPLX_IMAG * sqrt( real(j+m2,dp)/real(j-m1,dp) ) * x_min_Iy * Up(m2-1,m1+1) + + if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) - & + CPLX_IMAG * sqrt( real(j+m2,dp)/real(j-m1,dp) ) * & + ( dx_min_Iy * Up(m2-1,m1+1) + x_min_Iy * dUp(:,m2-1,m1+1) ) + + endif + enddo + enddo + + m1 = j + do m2 = -j, j, 2 + if( (j+m2) /= 0 ) then + Uc(m2,m1) = Uc(m2,m1) + & + sqrt( real(j+m2,dp)/real(j+m1,dp) ) * z0_min_Iz * Up(m2-1,m1-1) + + if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) + & + sqrt( real(j+m2,dp)/real(j+m1,dp) ) * & + ( dz0_min_Iz * Up(m2-1,m1-1) + z0_min_Iz * dUp(:,m2-1,m1-1) ) + endif + + if( (j-m2) /= 0 ) then + Uc(m2,m1) = Uc(m2,m1) - & + CPLX_IMAG * sqrt( real(j-m2,dp)/real(j+m1,dp) ) * x_pls_Iy * Up(m2+1,m1-1) + + if(present(dU)) dUc(:,m2,m1) = dUc(:,m2,m1) - & + CPLX_IMAG * sqrt( real(j-m2,dp)/real(j+m1,dp) ) * & + ( dx_pls_Iy * Up(m2+1,m1-1) + x_pls_Iy * dUp(:,m2+1,m1-1) ) + endif + enddo + + U(j)%mm = U(j)%mm + Uc(-j:j,-j:j) * fcut + Up(-j:j,-j:j) = Uc(-j:j,-j:j) + if(present(dU)) then + dUp(:,-j:j,-j:j) = dUc(:,-j:j,-j:j) + dU(j,0)%mm = dU(j,0)%mm - dUc(:,-j:j,-j:j) * fcut + dU(j,n_i)%mm = dU(j,n_i)%mm + dUc(:,-j:j,-j:j) * fcut + do m1 = -j, j, 2 + do m2 = -j, j, 2 + dU(j,0)%mm(:,m2,m1) = dU(j,0)%mm(:,m2,m1) & + + Uc(m2,m1) * dfcut + dU(j,n_i)%mm(:,m2,m1) = dU(j,n_i)%mm(:,m2,m1) & + - Uc(m2,m1) * dfcut + enddo + enddo + endif + + enddo ! j + enddo ! n + + if(allocated(Up)) deallocate(Up) + if(allocated(Uc)) deallocate(Uc) + if(allocated(dUp)) deallocate(dUp) + if(allocated(dUc)) deallocate(dUc) + + endsubroutine fourier_SO4_calc + + subroutine fourier_so4_initialise(this,args_str,error) + type(fourier_SO4_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + integer :: n_species + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '2.75', this%cutoff, help_string="Cutoff for SO4 bispectrum") + call param_register(params, 'z0_ratio', '0.0', this%z0_ratio, help_string="Ratio of radius of 4D projection sphere times PI and the cutoff.") + call param_register(params, 'j_max', '4', this%j_max, help_string="Max of expansion of bispectrum, i.e. resulution") + call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") + call param_register(params, 'n_Z_environment', '1', n_species, help_string="Number of species for the descriptor", altkey="n_species") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='fourier_so4_initialise args_str')) then + RAISE_ERROR("fourier_so4_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(this%species_Z(n_species), this%w(n_species)) + + call initialise(params) + if( n_species == 1 ) then + call param_register(params, 'Z_environment', '0', this%species_Z(1), help_string="Atomic number of species", altkey="species_Z") + call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") + else + call param_register(params, 'Z_environment', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species", altkey="species_Z") + call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") + endif + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='fourier_so4_initialise args_str')) then + RAISE_ERROR("fourier_so4_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%z0 = max(1.0_dp,this%z0_ratio) * this%cutoff/(PI-0.02_dp) + + this%initialised = .true. + + + endsubroutine fourier_so4_initialise + + subroutine fourier_so4_finalise(this,error) + type(fourier_so4_type), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + + this%cutoff = 0.0_dp + this%j_max = 0 + this%z0_ratio = 0.0_dp + this%z0 = 0.0_dp + this%Z = 0 + + if(allocated(this%species_Z)) deallocate(this%species_Z) + if(allocated(this%w)) deallocate(this%w) + + this%initialised = .false. + + endsubroutine fourier_so4_finalise + + subroutine bispectrum_so4_initialise(this,args_str,error) + type(bispectrum_so4), intent(inout), target :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + call finalise(this) + + call initialise(this%fourier_SO4,args_str,error) + + this%cutoff => this%fourier_SO4%cutoff + this%z0_ratio => this%fourier_SO4%z0_ratio + this%z0 => this%fourier_SO4%z0 + this%j_max => this%fourier_SO4%j_max + this%Z => this%fourier_SO4%Z + this%cutoff => this%fourier_SO4%cutoff + this%species_Z => this%fourier_SO4%species_Z + this%w => this%fourier_SO4%w + + this%initialised = .true. + + endsubroutine bispectrum_so4_initialise + + subroutine bispectrum_so4_finalise(this,error) + type(bispectrum_so4), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + + call finalise(this%fourier_SO4,error) + + this%cutoff => null() + this%z0_ratio => null() + this%z0 => null() + this%j_max => null() + this%Z => null() + this%cutoff => null() + this%species_Z => null() + this%w => null() + + this%initialised = .false. + + endsubroutine bispectrum_so4_finalise + + subroutine bispectrum_so3_initialise(this,args_str,error) + type(bispectrum_so3), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + integer :: n_species + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for bispectrum_so3-type descriptors") + call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Cutoff for minimal distances in bispectrum_so3-type descriptors") + call param_register(params, 'l_max', '4', this%l_max, help_string="L_max for bispectrum_so3-type descriptors") + call param_register(params, 'n_max', '4', this%n_max, help_string="N_max for bispectrum_so3-type descriptors") + call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") + call param_register(params, 'n_Z_environment', '1', n_species, help_string="Number of species for the descriptor", altkey="n_species") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='bispectrum_so3_initialise args_str')) then + RAISE_ERROR("bispectrum_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(this%species_Z(n_species), this%w(n_species)) + + call initialise(params) + if( n_species == 1 ) then + call param_register(params, 'Z_environment', '0', this%species_Z(1), help_string="Atomic number of species", altkey="species_Z") + call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") + else + call param_register(params, 'Z_environment', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species", altkey="species_Z") + call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") + endif + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='bispectrum_so3_initialise args_str')) then + RAISE_ERROR("bispectrum_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + call initialise(this%Radial,this%n_max,this%cutoff,this%min_cutoff,error) + + this%initialised = .true. + + call print('Dimensions: '//bispectrum_so3_dimensions(this,error)) + + endsubroutine bispectrum_so3_initialise + + subroutine bispectrum_so3_finalise(this,error) + type(bispectrum_so3), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + + this%cutoff = 0.0_dp + this%min_cutoff = 0.0_dp + this%l_max = 0 + this%n_max = 0 + this%Z = 0 + + if(allocated(this%species_Z)) deallocate(this%species_Z) + if(allocated(this%w)) deallocate(this%w) + + call finalise(this%Radial) + + this%initialised = .false. + + endsubroutine bispectrum_so3_finalise + + subroutine behler_initialise(this,args_str,error) + type(behler), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(len=STRING_LENGTH) :: specification_str, specification_file + logical :: has_specification,has_specification_file + integer :: n_fields, i_field, i_g2, i_g3, n, sym_type + character(len=128), dimension(:), allocatable :: specification + character(len=16), dimension(7) :: sym_func + + type(inoutput) :: specification_inout + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params,"Z","0",this%Z, help_string="Central atom") + call param_register(params,"specification","",specification_str, help_string="String to specify Parrinello-Behler descriptors", & + has_value_target=has_specification) + call param_register(params,"specification_file","",specification_file, help_string="File containing string to specify Parrinello-Behler descriptors", & + has_value_target=has_specification_file) + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='behler_initialise args_str')) then + RAISE_ERROR("behler_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_specification .or. has_specification_file ) then + if( has_specification .and. has_specification_file ) then + RAISE_ERROR("behler_initialise: both specification and specification_file specified",error) + endif + + if(has_specification_file) then + call initialise(specification_inout,trim(specification_file)) + read(specification_inout%unit,'(a)') specification_str + call finalise(specification_inout) + endif + + n_fields = num_fields_in_string_simple(specification_str,"|") + allocate(specification(n_fields)) + call split_string_simple(specification_str,specification,n_fields,"|") + + this%n_g2 = 0 + this%n_g3 = 0 + + do i_field = 1, n_fields + call split_string_simple(specification(i_field),sym_func,n,":") + sym_type = string_to_int(sym_func(1),error) + select case(sym_type) + case(2) + this%n_g2 = this%n_g2 + 1 + case(3) + this%n_g3 = this%n_g3 + 1 + case default + RAISE_ERROR("behler_initialise: unknown symmetry function type "//sym_type,error) + endselect + enddo + + allocate(this%g2(this%n_g2)) + allocate(this%g3(this%n_g3)) + + i_g2 = 0 + i_g3 = 0 + this%cutoff = 0.0_dp + do i_field = 1, n_fields + call split_string_simple(specification(i_field),sym_func,n,":") + + sym_type = string_to_int(sym_func(1),error) + select case(sym_type) + case(2) + i_g2 = i_g2 + 1 + this%g2(i_g2)%Z_n = atomic_number_from_symbol(sym_func(2)) + this%g2(i_g2)%eta = string_to_real(sym_func(3)) / BOHR**2 + this%g2(i_g2)%rs = string_to_real(sym_func(4)) * BOHR + this%g2(i_g2)%rc = string_to_real(sym_func(5)) * BOHR + this%cutoff = max(this%cutoff,this%g2(i_g2)%rc) + case(3) + i_g3 = i_g3 + 1 + this%g3(i_g3)%Z_n(1) = atomic_number_from_symbol(sym_func(2)) + this%g3(i_g3)%Z_n(2) = atomic_number_from_symbol(sym_func(3)) + this%g3(i_g3)%eta = string_to_real(sym_func(4)) / BOHR**2 + this%g3(i_g3)%lambda = string_to_real(sym_func(5)) + this%g3(i_g3)%zeta = string_to_real(sym_func(6)) + this%g3(i_g3)%rc = string_to_real(sym_func(7)) * BOHR + this%cutoff = max(this%cutoff,this%g3(i_g3)%rc) + case default + RAISE_ERROR("behler_initialise: unknown symmetry function type "//sym_type,error) + endselect + enddo + else + ! Default, for backwards compatibility + this%n_g2 = 8 + this%n_g3 = 43 + + allocate(this%g2(this%n_g2), this%g3(this%n_g3)) + do i_g2 = 1, this%n_g2 + this%g2(i_g2)%Z_n = 0 + enddo + do i_g3 = 1, this%n_g3 + this%g3(i_g3)%Z_n = 0 + enddo + + this%g2(1)%eta = 0.001_dp / BOHR**2; this%g2(1)%rs = 0.000_dp * BOHR; this%g2(1)%rc = 11.338_dp * BOHR + this%g2(2)%eta = 0.010_dp / BOHR**2; this%g2(2)%rs = 0.000_dp * BOHR; this%g2(2)%rc = 11.338_dp * BOHR + this%g2(3)%eta = 0.020_dp / BOHR**2; this%g2(3)%rs = 0.000_dp * BOHR; this%g2(3)%rc = 11.338_dp * BOHR + this%g2(4)%eta = 0.035_dp / BOHR**2; this%g2(4)%rs = 0.000_dp * BOHR; this%g2(4)%rc = 11.338_dp * BOHR + this%g2(5)%eta = 0.060_dp / BOHR**2; this%g2(5)%rs = 0.000_dp * BOHR; this%g2(5)%rc = 11.338_dp * BOHR + this%g2(6)%eta = 0.100_dp / BOHR**2; this%g2(6)%rs = 0.000_dp * BOHR; this%g2(6)%rc = 11.338_dp * BOHR + this%g2(7)%eta = 0.200_dp / BOHR**2; this%g2(7)%rs = 0.000_dp * BOHR; this%g2(7)%rc = 11.338_dp * BOHR + this%g2(8)%eta = 0.400_dp / BOHR**2; this%g2(8)%rs = 0.000_dp * BOHR; this%g2(8)%rc = 11.338_dp * BOHR + + this%g3( 1)%eta = 0.0001_dp / BOHR**2; this%g3( 1)%lambda = -1.000_dp; this%g3( 1)%zeta = 1.000_dp; this%g3( 1)%rc = 11.338_dp * BOHR + this%g3( 2)%eta = 0.0001_dp / BOHR**2; this%g3( 2)%lambda = 1.000_dp; this%g3( 2)%zeta = 1.000_dp; this%g3( 2)%rc = 11.338_dp * BOHR + this%g3( 3)%eta = 0.0001_dp / BOHR**2; this%g3( 3)%lambda = -1.000_dp; this%g3( 3)%zeta = 2.000_dp; this%g3( 3)%rc = 11.338_dp * BOHR + this%g3( 4)%eta = 0.0001_dp / BOHR**2; this%g3( 4)%lambda = 1.000_dp; this%g3( 4)%zeta = 2.000_dp; this%g3( 4)%rc = 11.338_dp * BOHR + this%g3( 5)%eta = 0.0030_dp / BOHR**2; this%g3( 5)%lambda = -1.000_dp; this%g3( 5)%zeta = 1.000_dp; this%g3( 5)%rc = 11.338_dp * BOHR + this%g3( 6)%eta = 0.0030_dp / BOHR**2; this%g3( 6)%lambda = 1.000_dp; this%g3( 6)%zeta = 1.000_dp; this%g3( 6)%rc = 11.338_dp * BOHR + this%g3( 7)%eta = 0.0030_dp / BOHR**2; this%g3( 7)%lambda = -1.000_dp; this%g3( 7)%zeta = 2.000_dp; this%g3( 7)%rc = 11.338_dp * BOHR + this%g3( 8)%eta = 0.0030_dp / BOHR**2; this%g3( 8)%lambda = 1.000_dp; this%g3( 8)%zeta = 2.000_dp; this%g3( 8)%rc = 11.338_dp * BOHR + this%g3( 9)%eta = 0.0080_dp / BOHR**2; this%g3( 9)%lambda = -1.000_dp; this%g3( 9)%zeta = 1.000_dp; this%g3( 9)%rc = 11.338_dp * BOHR + this%g3(10)%eta = 0.0080_dp / BOHR**2; this%g3(10)%lambda = 1.000_dp; this%g3(10)%zeta = 1.000_dp; this%g3(10)%rc = 11.338_dp * BOHR + this%g3(11)%eta = 0.0080_dp / BOHR**2; this%g3(11)%lambda = -1.000_dp; this%g3(11)%zeta = 2.000_dp; this%g3(11)%rc = 11.338_dp * BOHR + this%g3(12)%eta = 0.0080_dp / BOHR**2; this%g3(12)%lambda = 1.000_dp; this%g3(12)%zeta = 2.000_dp; this%g3(12)%rc = 11.338_dp * BOHR + this%g3(13)%eta = 0.0150_dp / BOHR**2; this%g3(13)%lambda = -1.000_dp; this%g3(13)%zeta = 1.000_dp; this%g3(13)%rc = 11.338_dp * BOHR + this%g3(14)%eta = 0.0150_dp / BOHR**2; this%g3(14)%lambda = 1.000_dp; this%g3(14)%zeta = 1.000_dp; this%g3(14)%rc = 11.338_dp * BOHR + this%g3(15)%eta = 0.0150_dp / BOHR**2; this%g3(15)%lambda = -1.000_dp; this%g3(15)%zeta = 2.000_dp; this%g3(15)%rc = 11.338_dp * BOHR + this%g3(16)%eta = 0.0150_dp / BOHR**2; this%g3(16)%lambda = 1.000_dp; this%g3(16)%zeta = 2.000_dp; this%g3(16)%rc = 11.338_dp * BOHR + this%g3(17)%eta = 0.0150_dp / BOHR**2; this%g3(17)%lambda = -1.000_dp; this%g3(17)%zeta = 4.000_dp; this%g3(17)%rc = 11.338_dp * BOHR + this%g3(18)%eta = 0.0150_dp / BOHR**2; this%g3(18)%lambda = 1.000_dp; this%g3(18)%zeta = 4.000_dp; this%g3(18)%rc = 11.338_dp * BOHR + this%g3(19)%eta = 0.0150_dp / BOHR**2; this%g3(19)%lambda = -1.000_dp; this%g3(19)%zeta = 16.000_dp; this%g3(19)%rc = 11.338_dp * BOHR + this%g3(20)%eta = 0.0150_dp / BOHR**2; this%g3(20)%lambda = 1.000_dp; this%g3(20)%zeta = 16.000_dp; this%g3(20)%rc = 11.338_dp * BOHR + this%g3(21)%eta = 0.0250_dp / BOHR**2; this%g3(21)%lambda = -1.000_dp; this%g3(21)%zeta = 1.000_dp; this%g3(21)%rc = 11.338_dp * BOHR + this%g3(22)%eta = 0.0250_dp / BOHR**2; this%g3(22)%lambda = 1.000_dp; this%g3(22)%zeta = 1.000_dp; this%g3(22)%rc = 11.338_dp * BOHR + this%g3(23)%eta = 0.0250_dp / BOHR**2; this%g3(23)%lambda = -1.000_dp; this%g3(23)%zeta = 2.000_dp; this%g3(23)%rc = 11.338_dp * BOHR + this%g3(24)%eta = 0.0250_dp / BOHR**2; this%g3(24)%lambda = 1.000_dp; this%g3(24)%zeta = 2.000_dp; this%g3(24)%rc = 11.338_dp * BOHR + this%g3(25)%eta = 0.0250_dp / BOHR**2; this%g3(25)%lambda = -1.000_dp; this%g3(25)%zeta = 4.000_dp; this%g3(25)%rc = 11.338_dp * BOHR + this%g3(26)%eta = 0.0250_dp / BOHR**2; this%g3(26)%lambda = 1.000_dp; this%g3(26)%zeta = 4.000_dp; this%g3(26)%rc = 11.338_dp * BOHR + this%g3(27)%eta = 0.0250_dp / BOHR**2; this%g3(27)%lambda = -1.000_dp; this%g3(27)%zeta = 16.000_dp; this%g3(27)%rc = 11.338_dp * BOHR + this%g3(28)%eta = 0.0250_dp / BOHR**2; this%g3(28)%lambda = 1.000_dp; this%g3(28)%zeta = 16.000_dp; this%g3(28)%rc = 11.338_dp * BOHR + this%g3(29)%eta = 0.0450_dp / BOHR**2; this%g3(29)%lambda = -1.000_dp; this%g3(29)%zeta = 1.000_dp; this%g3(29)%rc = 11.338_dp * BOHR + this%g3(30)%eta = 0.0450_dp / BOHR**2; this%g3(30)%lambda = 1.000_dp; this%g3(30)%zeta = 1.000_dp; this%g3(30)%rc = 11.338_dp * BOHR + this%g3(31)%eta = 0.0450_dp / BOHR**2; this%g3(31)%lambda = -1.000_dp; this%g3(31)%zeta = 2.000_dp; this%g3(31)%rc = 11.338_dp * BOHR + this%g3(32)%eta = 0.0450_dp / BOHR**2; this%g3(32)%lambda = 1.000_dp; this%g3(32)%zeta = 2.000_dp; this%g3(32)%rc = 11.338_dp * BOHR + this%g3(33)%eta = 0.0450_dp / BOHR**2; this%g3(33)%lambda = -1.000_dp; this%g3(33)%zeta = 4.000_dp; this%g3(33)%rc = 11.338_dp * BOHR + this%g3(34)%eta = 0.0450_dp / BOHR**2; this%g3(34)%lambda = 1.000_dp; this%g3(34)%zeta = 4.000_dp; this%g3(34)%rc = 11.338_dp * BOHR + this%g3(35)%eta = 0.0450_dp / BOHR**2; this%g3(35)%lambda = -1.000_dp; this%g3(35)%zeta = 16.000_dp; this%g3(35)%rc = 11.338_dp * BOHR + this%g3(36)%eta = 0.0450_dp / BOHR**2; this%g3(36)%lambda = 1.000_dp; this%g3(36)%zeta = 16.000_dp; this%g3(36)%rc = 11.338_dp * BOHR + this%g3(37)%eta = 0.0800_dp / BOHR**2; this%g3(37)%lambda = -1.000_dp; this%g3(37)%zeta = 1.000_dp; this%g3(37)%rc = 11.338_dp * BOHR + this%g3(38)%eta = 0.0800_dp / BOHR**2; this%g3(38)%lambda = 1.000_dp; this%g3(38)%zeta = 1.000_dp; this%g3(38)%rc = 11.338_dp * BOHR + this%g3(39)%eta = 0.0800_dp / BOHR**2; this%g3(39)%lambda = -1.000_dp; this%g3(39)%zeta = 2.000_dp; this%g3(39)%rc = 11.338_dp * BOHR + this%g3(40)%eta = 0.0800_dp / BOHR**2; this%g3(40)%lambda = 1.000_dp; this%g3(40)%zeta = 2.000_dp; this%g3(40)%rc = 11.338_dp * BOHR + this%g3(41)%eta = 0.0800_dp / BOHR**2; this%g3(41)%lambda = -1.000_dp; this%g3(41)%zeta = 4.000_dp; this%g3(41)%rc = 11.338_dp * BOHR + this%g3(42)%eta = 0.0800_dp / BOHR**2; this%g3(42)%lambda = 1.000_dp; this%g3(42)%zeta = 4.000_dp; this%g3(42)%rc = 11.338_dp * BOHR + this%g3(43)%eta = 0.0800_dp / BOHR**2; this%g3(43)%lambda = 1.000_dp; this%g3(43)%zeta = 16.000_dp; this%g3(43)%rc = 11.338_dp * BOHR + + this%cutoff = 11.338_dp * BOHR + endif + + if( allocated(specification) ) deallocate(specification) + + this%initialised = .true. + + endsubroutine behler_initialise + + subroutine behler_finalise(this,error) + type(behler), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + + this%cutoff = 0.0_dp + this%n_g2 = 0 + this%n_g3 = 0 + + if(allocated(this%g2)) deallocate(this%g2) + if(allocated(this%g3)) deallocate(this%g3) + + this%initialised = .false. + + endsubroutine behler_finalise + + subroutine distance_2b_initialise(this,args_str,error) + type(distance_2b), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + logical :: has_resid_name, has_exponents + integer :: i + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for distance_2b-type descriptors") + call param_register(params, 'cutoff_transition_width', '0.5', this%cutoff_transition_width, help_string="Transition width of cutoff for distance_2b-type descriptors") + call param_register(params, 'Z1', '0', this%Z1, help_string="Atom type #1 in bond") + call param_register(params, 'Z2', '0', this%Z2, help_string="Atom type #2 in bond") + call param_register(params, 'resid_name', '', this%resid_name, has_value_target=has_resid_name, help_string="Name of an integer property in the atoms object giving the residue id of the molecule to which the atom belongs.") + call param_register(params, 'only_intra', 'F', this%only_intra, help_string="Only calculate INTRAmolecular pairs with equal residue ids (bonds)") + call param_register(params, 'only_inter', 'F', this%only_inter, help_string="Only apply to INTERmolecular pairs with different residue ids (non-bonded)") + + call param_register(params, 'n_exponents', '1', this%n_exponents, help_string="Number of exponents") + call param_register(params, 'tail_range', '1.0', this%tail_range, help_string="Tail order") + call param_register(params, 'tail_exponent', '0', this%tail_exponent, & + has_value_target = this%has_tail, help_string="Tail range") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_2b_initialise args_str')) then + RAISE_ERROR("distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if (this%only_intra .and. this%only_inter) then + RAISE_ERROR("distance_2b_initialise: cannot specify both only_inter AND only_intra", error) + end if + if ((this%only_intra .or. this%only_inter) .and. (.not. has_resid_name)) then + RAISE_ERROR("distance_2b_initialise: only_intra and only_inter require resid_name to be given as well", error) + end if + + allocate(this%exponents(this%n_exponents)) + call initialise(params) + if( this%n_exponents == 1 ) then + call param_register(params, 'exponents',"1", this%exponents(1), & + has_value_target=has_exponents,help_string="Exponents") + else + call param_register(params, 'exponents',repeat(" 1 ",this%n_exponents), this%exponents, & + has_value_target=has_exponents,help_string="Exponents") + endif + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_2b_initialise args_str')) then + RAISE_ERROR("distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if( .not. has_exponents .and. this%n_exponents > 1 ) then + do i = 1, this%n_exponents + this%exponents(i) = -i + enddo + endif + + this%initialised = .true. + + endsubroutine distance_2b_initialise + + subroutine distance_2b_finalise(this,error) + type(distance_2b), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%cutoff_transition_width = 0.5_dp + this%Z1 = 0 + this%Z2 = 0 + + this%resid_name = '' + this%only_intra = .false. + this%only_inter = .false. + + this%tail_exponent = 0 + this%tail_range = 0.0_dp + this%has_tail = .false. + + this%n_exponents = 0 + if(allocated(this%exponents)) deallocate(this%exponents) + + this%initialised = .false. + + endsubroutine distance_2b_finalise + + subroutine coordination_initialise(this,args_str,error) + type(coordination), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for coordination-type descriptors") + call param_register(params, 'transition_width', '0.20', this%transition_width, help_string="Width of transition region from 1 to 0") + call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z_center") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='coordination_initialise args_str')) then + RAISE_ERROR("coordination_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine coordination_initialise + + subroutine coordination_finalise(this,error) + type(coordination), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%transition_width = 0.0_dp + this%Z = 0 + + this%initialised = .false. + + endsubroutine coordination_finalise + + subroutine angle_3b_initialise(this,args_str,error) + type(angle_3b), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for angle_3b-type descriptors") + call param_register(params, 'cutoff_transition_width', '0.50', this%cutoff_transition_width, help_string="Cutoff transition width for angle_3b-type descriptors") + call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") + call param_register(params, 'Z1', '0', this%Z1, help_string="Atomic number of neighbour #1") + call param_register(params, 'Z2', '0', this%Z2, help_string="Atomic number of neighbour #2") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='angle_3b_initialise args_str')) then + RAISE_ERROR("angle_3b_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine angle_3b_initialise + + subroutine angle_3b_finalise(this,error) + type(angle_3b), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%Z = 0 + this%Z1 = 0 + this%Z2 = 0 + + this%initialised = .false. + + endsubroutine angle_3b_finalise + + subroutine co_angle_3b_initialise(this,args_str,error) + type(co_angle_3b), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for co_angle_3b-type descriptors") + call param_register(params, 'coordination_cutoff', '0.00', this%coordination_cutoff, help_string="Cutoff for coordination function in co_angle_3b-type descriptors") + call param_register(params, 'coordination_transition_width', '0.00', this%coordination_transition_width, help_string="Transition width for co_angle_3b-type descriptors") + call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") + call param_register(params, 'Z1', '0', this%Z1, help_string="Atomic number of neighbour #1") + call param_register(params, 'Z2', '0', this%Z2, help_string="Atomic number of neighbour #2") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='co_angle_3b_initialise args_str')) then + RAISE_ERROR("co_angle_3b_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine co_angle_3b_initialise + + subroutine co_angle_3b_finalise(this,error) + type(co_angle_3b), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%coordination_cutoff = 0.0_dp + this%coordination_transition_width = 0.0_dp + this%Z = 0 + this%Z1 = 0 + this%Z2 = 0 + + this%initialised = .false. + + endsubroutine co_angle_3b_finalise + + subroutine co_distance_2b_initialise(this,args_str,error) + type(co_distance_2b), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for co_distance_2b-type descriptors") + call param_register(params, 'transition_width', '0.50', this%transition_width, help_string="Transition width of cutoff for co_distance_2b-type descriptors") + call param_register(params, 'coordination_cutoff', '0.00', this%coordination_cutoff, help_string="Cutoff for coordination function in co_distance_2b-type descriptors") + call param_register(params, 'coordination_transition_width', '0.00', this%coordination_transition_width, help_string="Transition width for co_distance_2b-type descriptors") + call param_register(params, 'Z1', '0', this%Z1, help_string="Atom type #1 in bond") + call param_register(params, 'Z2', '0', this%Z2, help_string="Atom type #2 in bond") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='co_distance_2b_initialise args_str')) then + RAISE_ERROR("co_distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine co_distance_2b_initialise + + subroutine co_distance_2b_finalise(this,error) + type(co_distance_2b), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%coordination_cutoff = 0.0_dp + this%coordination_transition_width = 0.0_dp + this%Z1 = 0 + this%Z2 = 0 + + this%initialised = .false. + + endsubroutine co_distance_2b_finalise + + subroutine cosnx_initialise(this,args_str,error) + type(cosnx), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + integer :: n_species + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for cosnx-type descriptors") + call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Cutoff for minimal distances in cosnx-type descriptors") + call param_register(params, 'l_max', '4', this%l_max, help_string="L_max for cosnx-type descriptors") + call param_register(params, 'n_max', '4', this%n_max, help_string="N_max for cosnx-type descriptors") + call param_register(params, 'Z_center', '0', this%Z, help_string="Atomic number of central atom", altkey="Z") + call param_register(params, 'n_species', '1', n_species, help_string="Number of species for the descriptor") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='cosnx_initialise args_str')) then + RAISE_ERROR("cosnx_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(this%species_Z(n_species), this%w(n_species)) + + call initialise(params) + if( n_species == 1 ) then + call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") + call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") + else + call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species") + call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") + endif + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='cosnx_initialise args_str')) then + RAISE_ERROR("cosnx_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + call initialise(this%Radial,this%n_max,this%cutoff,this%min_cutoff,error) + + this%initialised = .true. + + endsubroutine cosnx_initialise + + subroutine cosnx_finalise(this,error) + type(cosnx), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%min_cutoff = 0.0_dp + this%l_max = 0 + this%n_max = 0 + + if(allocated(this%species_Z)) deallocate(this%species_Z) + if(allocated(this%w)) deallocate(this%w) + + call finalise(this%Radial) + + this%initialised = .false. + + endsubroutine cosnx_finalise + + subroutine trihis_initialise(this,args_str,error) + type(trihis), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + real(dp), dimension(:), allocatable :: gauss_centre1D, gauss_width1D + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for trihis-type descriptors") + call param_register(params, 'n_gauss', '0', this%n_gauss, help_string="Number of Gaussians for trihis-type descriptors") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='trihis_initialise args_str')) then + RAISE_ERROR("trihis_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(gauss_centre1D(3*this%n_gauss),gauss_width1D(3*this%n_gauss)) + allocate(this%gauss_centre(3,this%n_gauss),this%gauss_width(3,this%n_gauss)) + + call initialise(params) + call param_register(params, 'trihis_gauss_centre', PARAM_MANDATORY, gauss_centre1D, help_string="Number of Gaussians for trihis-type descriptors") + call param_register(params, 'trihis_gauss_width', PARAM_MANDATORY, gauss_width1D, help_string="Number of Gaussians for trihis-type descriptors") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='trihis_initialise args_str')) then + RAISE_ERROR("trihis_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%gauss_centre = reshape(gauss_centre1D,(/3,this%n_gauss/)) + this%gauss_width = reshape(gauss_width1D,(/3,this%n_gauss/)) + + deallocate(gauss_centre1D,gauss_width1D) + + this%initialised = .true. + + endsubroutine trihis_initialise + + subroutine trihis_finalise(this,error) + type(trihis), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%n_gauss = 0 + + if(allocated(this%gauss_centre)) deallocate(this%gauss_centre) + if(allocated(this%gauss_width)) deallocate(this%gauss_width) + + this%initialised = .false. + + endsubroutine trihis_finalise + + subroutine water_monomer_initialise(this,args_str,error) + type(water_monomer), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for water_monomer-type descriptors") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='water_monomer_initialise args_str')) then + RAISE_ERROR("water_monomer_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine water_monomer_initialise + + subroutine water_monomer_finalise(this,error) + type(water_monomer), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + + this%initialised = .false. + + endsubroutine water_monomer_finalise + + subroutine water_dimer_initialise(this,args_str,error) + type(water_dimer), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for water_dimer-type descriptors") + call param_register(params, 'cutoff_transition_width', '0.50', this%cutoff_transition_width, help_string="Width of smooth cutoff region for water_dimer-type descriptors") + call param_register(params, 'monomer_cutoff', '1.50', this%monomer_cutoff, help_string="Monomer cutoff for water_dimer-type descriptors") + call param_register(params, 'OHH_ordercheck', 'T', this%OHH_ordercheck, help_string="T: find water molecules. F: use default order OHH") + call param_register(params, 'power', '1.0', this%power, help_string="Power of distances to be used in the kernel") + call param_register(params, 'dist_shift', '0.0', this%dist_shift, help_string="Distance shift for inverse distance descriptors.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='water_dimer_initialise args_str')) then + RAISE_ERROR("water_dimer_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine water_dimer_initialise + + subroutine water_dimer_finalise(this,error) + type(water_dimer), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%cutoff_transition_width = 0.0_dp + this%monomer_cutoff = 0.0_dp + this%OHH_ordercheck = .true. + this%power = 1.0_dp + this%dist_shift = 0.0_dp + + this%initialised = .false. + + endsubroutine water_dimer_finalise + + subroutine A2_dimer_initialise(this,args_str,error) + type(A2_dimer), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for A2_dimer-type descriptors") + call param_register(params, 'monomer_cutoff', '1.50', this%monomer_cutoff, help_string="Monomer cutoff for A2_dimer-type descriptors") + call param_register(params, 'atomic_number', '1', this%atomic_number, help_string="Atomic number in A2_dimer-type descriptors") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='A2_dimer_initialise args_str')) then + RAISE_ERROR("A2_dimer_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine A2_dimer_initialise + + subroutine A2_dimer_finalise(this,error) + type(A2_dimer), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%monomer_cutoff = 0.0_dp + this%atomic_number = 0 + + this%initialised = .false. + + endsubroutine A2_dimer_finalise + + subroutine AB_dimer_initialise(this,args_str,error) + type(AB_dimer), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for AB_dimer-type descriptors") + call param_register(params, 'monomer_cutoff', '1.50', this%monomer_cutoff, help_string="Monomer cutoff for AB_dimer-type descriptors") + call param_register(params, 'atomic_number1', '1', this%atomic_number1, help_string="Atomic number of atom 1 in AB_dimer-type descriptors") + call param_register(params, 'atomic_number2', '9', this%atomic_number2, help_string="Atomic number of atom 2 in AB_dimer-type descriptors") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='AB_dimer_initialise args_str')) then + RAISE_ERROR("AB_dimer_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if( this%atomic_number1 == this%atomic_number2 ) then + RAISE_ERROR("AB_dimer_initialise: AB_dimer_atomic_number1 = AB_dimer_atomic_number2 = "//this%atomic_number1//" which would require addtional permutational symmetries. Use A2_dimer descriptor instead.",error) + endif + + this%initialised = .true. + + endsubroutine AB_dimer_initialise + + subroutine AB_dimer_finalise(this,error) + type(AB_dimer), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%monomer_cutoff = 0.0_dp + this%atomic_number1 = 0 + this%atomic_number2 = 0 + + this%initialised = .false. + + endsubroutine AB_dimer_finalise + + + subroutine atom_real_space_initialise(this,args_str,error) + type(atom_real_space), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Space cutoff for atom_real_space-type descriptors") + call param_register(params, 'cutoff_transition_width', '0.00', this%cutoff_transition_width, help_string="Space transition width for atom_real_space-type descriptors") + call param_register(params, 'l_max', '0', this%l_max, help_string="Cutoff for spherical harmonics expansion") + call param_register(params, 'alpha', '1.0', this%alpha, help_string="Width of atomic Gaussians") + call param_register(params, 'zeta', '1.0', this%zeta, help_string="Exponent of covariance function") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='atom_real_space_initialise args_str')) then + RAISE_ERROR("atom_real_space_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine atom_real_space_initialise + + subroutine atom_real_space_finalise(this,error) + type(atom_real_space), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%cutoff_transition_width = 0.0_dp + this%l_max = 0 + this%alpha = 0.0_dp + this%zeta = 0.0_dp + + this%initialised = .false. + + endsubroutine atom_real_space_finalise + + subroutine power_so3_initialise(this,args_str,error) + type(power_so3), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + integer :: n_species + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for power_so3-type descriptors") + call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Cutoff for minimal distances in power_so3-type descriptors") + call param_register(params, 'l_max', '4', this%l_max, help_string="L_max for power_so3-type descriptors") + call param_register(params, 'n_max', '4', this%n_max, help_string="N_max for power_so3-type descriptors") + call param_register(params, 'Z', '0', this%Z, help_string="Atomic number of central atom") + call param_register(params, 'n_species', '1', n_species, help_string="Number of species for the descriptor") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='power_so3_initialise args_str')) then + RAISE_ERROR("power_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(this%species_Z(n_species), this%w(n_species)) + + call initialise(params) + if( n_species == 1 ) then + call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") + call param_register(params, 'w', '1.0', this%w(1), help_string="Weight associated to each atomic type") + else + call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species") + call param_register(params, 'w', PARAM_MANDATORY, this%w, help_string="Weight associated to each atomic type") + endif + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='power_so3_initialise args_str')) then + RAISE_ERROR("power_so3_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + call initialise(this%Radial,this%n_max,this%cutoff,this%min_cutoff,error) + + this%initialised = .true. + + endsubroutine power_so3_initialise + + subroutine power_so3_finalise(this,error) + type(power_so3), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%min_cutoff = 0.0_dp + this%l_max = 0 + this%n_max = 0 + this%Z = 0 + + if(allocated(this%species_Z)) deallocate(this%species_Z) + if(allocated(this%w)) deallocate(this%w) + + call finalise(this%Radial) + + this%initialised = .false. + + endsubroutine power_so3_finalise + + subroutine power_so4_initialise(this,args_str,error) + type(power_so4), intent(inout), target :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + call finalise(this) + + call initialise(this%fourier_SO4,args_str,error) + + this%cutoff => this%fourier_SO4%cutoff + this%z0_ratio => this%fourier_SO4%z0_ratio + this%z0 => this%fourier_SO4%z0 + this%j_max => this%fourier_SO4%j_max + this%Z => this%fourier_SO4%Z + this%cutoff => this%fourier_SO4%cutoff + this%species_Z => this%fourier_SO4%species_Z + this%w => this%fourier_SO4%w + + this%initialised = .true. + + endsubroutine power_so4_initialise + + subroutine power_so4_finalise(this,error) + type(power_so4), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + + call finalise(this%fourier_SO4,error) + + this%cutoff => null() + this%z0_ratio => null() + this%z0 => null() + this%j_max => null() + this%Z => null() + this%cutoff => null() + this%species_Z => null() + this%w => null() + + this%initialised = .false. + + endsubroutine power_so4_finalise + + subroutine soap_initialise(this,args_str,error) + type(soap), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + real(dp) :: alpha_basis, spacing_basis, cutoff_basis, basis_error_exponent + real(dp) :: N_alpha, S_alpha_beta, N_beta + real(dp), dimension(:,:,:), allocatable :: covariance_basis, overlap_basis + integer :: i, j, xml_version, info, n_radial_grid + + real(dp), dimension(:, :), allocatable :: alpha_ln, Q, R + real(dp) :: u, alpha_gto, t, Rg + integer :: l, n, l_ub + + type(LA_Matrix) :: LA_covariance_basis, LA_overlap_basis + type(LA_matrix), dimension(:), allocatable :: LA_BL_ti + character(len=STRING_LENGTH) :: species_Z_str + logical :: has_n_species, has_species_Z, has_central_reference_all_species + + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', PARAM_MANDATORY, this%cutoff, help_string="Cutoff for soap-type descriptors") + call param_register(params, 'cutoff_transition_width', '0.50', this%cutoff_transition_width, help_string="Cutoff transition width for soap-type descriptors") + + call param_register(params, 'cutoff_dexp', '0', this%cutoff_dexp, help_string="Cutoff decay exponent") + call param_register(params, 'cutoff_scale', '1.0', this%cutoff_scale, help_string="Cutoff decay scale") + call param_register(params, 'cutoff_rate', '1.0', this%cutoff_rate, help_string="Inverse cutoff decay rate") + + call param_register(params, 'l_max', PARAM_MANDATORY, this%l_max, help_string="L_max (spherical harmonics basis band limit) for soap-type descriptors") + call param_register(params, 'n_max', PARAM_MANDATORY, this%n_max, help_string="N_max (number of radial basis functions) for soap-type descriptors") + call param_register(params, 'atom_gaussian_width', PARAM_MANDATORY, this%atom_sigma, help_string="Width of atomic Gaussians for soap-type descriptors", altkey='atom_sigma') + call param_register(params, 'central_weight', '1.0', this%central_weight, help_string="Weight of central atom in environment") + call param_register(params, 'central_reference_all_species', 'F', this%central_reference_all_species, has_value_target=has_central_reference_all_species, & + help_string="Place a Gaussian reference for all atom species densities."// & + "By default (F) only consider when neighbour is the same species as centre") + call param_register(params, 'average', 'F', this%global, help_string="Whether to calculate averaged SOAP - one descriptor per atoms object. If false (default) atomic SOAP is returned.") + call param_register(params, 'diagonal_radial', 'F', this%diagonal_radial, help_string="Only return the n1=n2 elements of the power spectrum.") + + call param_register(params, 'covariance_sigma0', '0.0', this%covariance_sigma0, help_string="sigma_0 parameter in polynomial covariance function") + call param_register(params, 'normalise', 'T', this%normalise, help_string="Normalise descriptor so magnitude is 1. In this case the kernel of two equivalent environments is 1.", altkey="normalize") + call param_register(params, 'basis_error_exponent', '10.0', basis_error_exponent, help_string="10^(-basis_error_exponent) is the max difference between the target and the expanded function") + + call param_register(params, 'n_Z', '1', this%n_Z, help_string="How many different types of central atoms to consider") + call param_register(params, 'n_species', '1', this%n_species, has_value_target=has_n_species, help_string="Number of species for the descriptor") + call param_register(params, 'species_Z', '', species_Z_str, has_value_target=has_species_Z, help_string="Atomic number of species") + call param_register(params, 'xml_version', '1426512068', xml_version, help_string="Version of GAP the XML potential file was created") + + call param_register(params, 'nu_R', '2', this%nu_R, help_string="radially sensitive correlation order") + call param_register(params, 'nu_S', '2', this%nu_S, help_string="species sensitive correlation order") + call param_register(params, 'Z_mix', 'F', this%Z_mix, help_string="mix Z channels together") + call param_register(params, 'R_mix', 'F', this%R_mix, help_string="mix radial channels together") + call param_register(params, 'sym_mix', 'F', this%sym_mix, help_string="symmetric mixing") + call param_register(params, 'coupling', 'T', this%coupling, help_string="Full tensor product(=T) or Elementwise product(=F) between density channels") + call param_register(params, 'K', '0', this%K, help_string="Number of mixing channels to create") + call param_register(params, 'mix_shift', '0', this%mix_shift, help_string="shift for random number seed used to generate mixing weights") + call param_register(params, 'Z_map', '', this%Z_map_str, help_string="string defining the Zmap") + call param_register(params, 'radial_basis', '', this%radial_basis, help_string="Radial basis functions to use. Options are EQUISPACED_GAUSS, POLY and GTO (default for xml_version > 1987654320") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_initialise args_str')) then + RAISE_ERROR("soap_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + ! backwards compatibility: the default used to be different before this version number + if( xml_version < 1426512068 ) this%central_reference_all_species = .true. + + !backwards compatibility: only EQUISPACED_GAUSS allowed for old versions. default is GTO for new versions. + if (this%radial_basis == "") then + this%radial_basis = "EQUISPACED_GAUSS" + endif + + + allocate(this%species_Z(0:this%n_species)) + allocate(this%Z(this%n_Z)) + this%species_Z(0)=0 + + if( has_species_Z .and. .not. has_n_species ) then + RAISE_ERROR("soap_initialise: is species_Z is present, n_species must be present, too.",error) + endif + + call initialise(params) + + if( this%cutoff_dexp < 0 ) then + RAISE_ERROR("soap_initialise: cutoff_dexp may not be less than 0",error) + endif + + if( this%cutoff_scale <= 0.0_dp ) then + RAISE_ERROR("soap_initialise: cutoff_scale must be greater than 0",error) + endif + + if( this%cutoff_rate < 0.0_dp ) then + RAISE_ERROR("soap_initialise: cutoff_rate may not be less than 0",error) + endif + + if( has_n_species ) then + if(this%n_species == 1) then + call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") + else + call param_register(params, 'species_Z', '//MANDATORY//', this%species_Z(1:this%n_species), help_string="Atomic number of species") + endif + else + call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") + endif + + if( .not. has_central_reference_all_species .and. this%n_species == 1 ) this%central_reference_all_species = .true. + + if( this%n_Z == 1 ) then + call param_register(params, 'Z', '0', this%Z(1), help_string="Atomic number of central atom, 0 is the wild-card") + else + call param_register(params, 'Z', '//MANDATORY//', this%Z, help_string="Atomic numbers to be considered for central atom, must be a list") + endif + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_initialise args_str')) then + RAISE_ERROR("soap_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + + this%alpha = 0.5_dp / this%atom_sigma**2 + alpha_basis = this%alpha + cutoff_basis = this%cutoff + this%atom_sigma * sqrt(2.0_dp * basis_error_exponent * log(10.0_dp)) + spacing_basis = cutoff_basis / this%n_max + + if (this%radial_basis == "EQUISPACED_GAUSS") then + allocate(this%r_basis(this%n_max), this%transform_basis(this%n_max,this%n_max), & + covariance_basis(this%n_max,this%n_max, 1), overlap_basis(this%n_max,this%n_max, 1), this%cholesky_overlap_basis(this%n_max,this%n_max, 1)) + + this%r_basis(1) = 0.0_dp + do i = 2, this%n_max + this%r_basis(i) = this%r_basis(i-1) + spacing_basis + enddo + + do i = 1, this%n_max + do j = 1, this%n_max + covariance_basis(j,i, 1) = exp(-alpha_basis * (this%r_basis(i) - this%r_basis(j))**2) + overlap_basis(j,i,1) = ( exp( -alpha_basis*(this%r_basis(i)**2+this%r_basis(j)**2) ) * & + sqrt(2.0_dp) * alpha_basis**1.5_dp * (this%r_basis(i) + this%r_basis(j)) + & + alpha_basis*exp(-0.5_dp * alpha_basis * (this%r_basis(i) - this%r_basis(j))**2)*sqrt(PI)*(1.0_dp + alpha_basis*(this%r_basis(i) + this%r_basis(j))**2 ) * & + ( 1.0_dp + erf( sqrt(alpha_basis/2.0_dp) * (this%r_basis(i) + this%r_basis(j)) ) ) ) + enddo + enddo + + !overlap_basis = overlap_basis * sqrt(pi / ( 8.0_dp * alpha_basis ) ) + overlap_basis = overlap_basis / sqrt(128.0_dp * alpha_basis**5) + + call initialise(LA_covariance_basis, covariance_basis(:, :, 1)) + call initialise(LA_overlap_basis,overlap_basis(:, :, 1)) + call LA_Matrix_Factorise(LA_overlap_basis, this%cholesky_overlap_basis(:, :, 1)) + do i = 1, this%n_max + do j = 1, i-1 !i + 1, this%n_max + this%cholesky_overlap_basis(j,i,1) = 0.0_dp ! lower triangular + enddo + enddo + + call Matrix_Solve(LA_covariance_basis,this%cholesky_overlap_basis(:, :, 1),this%transform_basis) + + call finalise(LA_covariance_basis) + call finalise(LA_overlap_basis) + + if(allocated(covariance_basis)) deallocate(covariance_basis) + if(allocated(overlap_basis)) deallocate(overlap_basis) + + else + ! fine radial grid to fit radial coeficients + n_radial_grid = 3 * this%n_max + allocate(this%r_basis(n_radial_grid)) + spacing_basis = cutoff_basis / n_radial_grid + this%r_basis(1) = 0.0_dp + do i = 2, n_radial_grid + this%r_basis(i) = this%r_basis(i-1) + spacing_basis + enddo + + + ! allocations + allocate(covariance_basis(n_radial_grid, this%n_max, 0:this%l_max)) + allocate(overlap_basis(this%n_max,this%n_max, 0:this%l_max)) + allocate(this%cholesky_overlap_basis(this%n_max,this%n_max, 0:this%l_max)) + allocate(LA_BL_ti(0:this%l_max)) + allocate(Q(n_radial_grid, this%n_max), R(this%n_max, this%n_max)) + + if (this%radial_basis == "POLY") then + l_ub = 0 + ! form the overlap matrix and do cholesky decomposition + do i = 1, this%n_max + N_alpha = ((cutoff_basis**(2*i+7))/((i+3)*(2*i+5)*(2*i+7)))**0.5_dp + do j = 1, this%n_max + N_beta = ((cutoff_basis**(2*j+7))/((j+3)*(2*j+5)*(2*j+7)))**0.5_dp + S_alpha_beta = (2*cutoff_basis**(i+j+7))/((5+i+j)*(6+i+j)*(7+i+j)) + overlap_basis(j,i, 0) = S_alpha_beta/(N_alpha*N_beta) + enddo + enddo + + ! form the "covariance matrix" + do i = 1, this%n_max + N_alpha = ((cutoff_basis**(2*i+7))/((i+3)*(2*i+5)*(2*i+7)))**0.5_dp + do j = 1, n_radial_grid + covariance_basis(j, i, 0) = ((cutoff_basis-this%r_basis(j))**(i+2))/N_alpha + enddo + enddo + + elseif (this%radial_basis == "GTO") then + l_ub = this%l_max + allocate(alpha_ln(0:this%l_max+1, this%n_max)) + + spacing_basis = cutoff_basis/this%n_max + do l = 0, this%l_max + do n = 1, this%n_max + Rg = spacing_basis * n + alpha_ln(l, n) = -Rg**(-2) * (log(0.001_dp) - l*log(Rg)) + enddo + enddo + + !form the overlap matrices + do l = 0, this%l_max + do i = 1, this%n_max + do j = 1, this%n_max + alpha_gto = alpha_ln(l, i) + alpha_ln(l, j) + u = alpha_gto*cutoff_basis**2 + t = l + 1.5_dp + overlap_basis(i, j, l) = 0.5*cutoff_basis**(2*t)*u**(-t)* ( gamma(t) - gamma_incomplete_upper(t, u) ) + enddo + enddo + enddo + + !form the covariance matrices + do l = 0, this%l_max + do i = 1, this%n_max + do j = 1, n_radial_grid + covariance_basis(j, i, l) = this%r_basis(j)**l * exp(-alpha_ln(l, i)*this%r_basis(j)**2) + enddo + enddo + enddo + + else + RAISE_ERROR("soap_initialise: radial_basis not recognised: EQUISPACED_GAUSS, POLY or GTO" ,error) + endif + + !allocate(this%BL_ti(0:this%l_max, n_radial_grid, this%n_max)) + ! extract factor and tau as these are only bits needed for QR_solve + allocate(this%QR_factor( size(this%r_basis), this%n_max, 0:this%l_max)) + allocate(this%QR_tau(this%n_max, 0:this%l_max)) + + ! per l + do l = 0, l_ub + ! cholesky factorisation + call initialise(LA_covariance_basis, covariance_basis(:, :, l)) + call initialise(LA_overlap_basis,overlap_basis(:, :, l)) + call LA_Matrix_Factorise(LA_overlap_basis, this%cholesky_overlap_basis(:, :, l)) + do i = 1, this%n_max + do j = 1, i-1 !i + 1, this%n_max + this%cholesky_overlap_basis(j,i, l) = 0.0_dp ! lower triangular + enddo + enddo + + !find inverse of L^T, NOTE: reusing overlap basis in a confusing way here + overlap_basis(:, :, l) = transpose(this%cholesky_overlap_basis(:, :, l)) + call dtrtri("U", "N", this%n_max, overlap_basis(:, :, l), this%n_max, i) + ! form B(L^T)^-1 and do QR factorisation in prep for solving equations. + !this%BL_ti(l, :, :) = matmul(covariance_basis(l, :, :), overlap_basis(l, :, :)) + + call initialise(LA_BL_ti(l), matmul(covariance_basis(:, :, l), overlap_basis(:, :, l))) + call LA_Matrix_QR_Factorise(LA_BL_ti(l), Q, R, error) + + this%QR_factor(:, :, l) = LA_BL_ti(l)%factor + this%QR_tau(:, l) = LA_BL_ti(l)%tau + + call finalise(LA_covariance_basis) + call finalise(LA_overlap_basis) + enddo + + if (l_ub == 0 .and. this%l_max > 0) then + do l = 1, this%l_max + this%QR_factor(:, :, l) = this%QR_factor(:, :, 0) + this%QR_tau(:, l) = this%QR_tau(:, 0) + enddo + endif + + + if (allocated(covariance_basis)) deallocate(covariance_basis) + if (allocated(overlap_basis)) deallocate(overlap_basis) + if (allocated(Q)) deallocate(Q) + if (allocated(R)) deallocate(R) + + if (allocated(LA_BL_ti)) then + do l = 0, this%l_max + call finalise(LA_BL_ti(l)) + enddo + deallocate(LA_BL_ti) + endif + endif + + this%initialised = .true. + + endsubroutine soap_initialise + + subroutine soap_finalise(this,error) + type(soap), intent(inout) :: this + integer, optional, intent(out) :: error + integer :: l + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff_dexp = 0 + this%cutoff_scale = 1.0_dp + this%cutoff_rate = 1.0_dp + this%cutoff = 0.0_dp + this%cutoff_transition_width = 0.0_dp + this%l_max = 0 + this%alpha = 0.0_dp + this%central_weight = 0.0_dp + this%central_reference_all_species = .false. + this%global = .false. + this%diagonal_radial = .false. + this%covariance_sigma0 = 0.0_dp + this%normalise = .true. + + this%n_max = 0 + this%n_Z = 0 + this%n_species = 0 + this%nu_R = 2 + this%nu_S = 2 + + this%Z_mix = .false. + this%R_mix = .false. + this%sym_mix = .false. + this%coupling = .true. + this%K = 0 + this%mix_shift = 0 + + if(allocated(this%r_basis)) deallocate(this%r_basis) + if(allocated(this%transform_basis)) deallocate(this%transform_basis) + if(allocated(this%cholesky_overlap_basis)) deallocate(this%cholesky_overlap_basis) + if(allocated(this%species_Z)) deallocate(this%species_Z) + if(allocated(this%Z)) deallocate(this%Z) + + if (allocated(this%QR_factor)) deallocate(this%QR_factor) + if (allocated(this%QR_tau)) deallocate(this%QR_tau) + + this%initialised = .false. + + endsubroutine soap_finalise + + + subroutine rdf_initialise(this,args_str,error) + type(rdf), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + integer :: i + real(dp) :: r_min, r_max + logical :: has_r_max, has_w_gauss + + INIT_ERROR(error) + + call finalise(this) + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for rdf-type descriptors") + call param_register(params, 'transition_width', '0.20', this%transition_width, help_string="Width of transition region from 1 to 0") + call param_register(params, 'Z', '0', this%Z, help_string="Atomic number of central atom") + call param_register(params, 'r_min', '0.0', r_min, help_string="Atomic number of central atom") + call param_register(params, 'r_max', '0.0', r_max, has_value_target = has_r_max, help_string="Atomic number of central atom") + call param_register(params, 'n_gauss', '10', this%n_gauss, help_string="Atomic number of central atom") + call param_register(params, 'w_gauss', '0.0', this%w_gauss, has_value_target = has_w_gauss, help_string="Atomic number of central atom") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='rdf_initialise args_str')) then + RAISE_ERROR("rdf_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(this%r_gauss(this%n_gauss)) + if(.not. has_w_gauss) this%w_gauss = this%cutoff / this%n_gauss * 2.0_dp + if(.not. has_r_max) r_max = this%cutoff - this%w_gauss / 2.0_dp + this%r_gauss = real( (/(i,i=1,this%n_gauss)/), kind=dp ) / real(this%n_gauss,kind=dp) * (r_max - r_min) + r_min + + this%initialised = .true. + + endsubroutine rdf_initialise + + subroutine rdf_finalise(this,error) + type(rdf), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%transition_width = 0.0_dp + this%Z = 0 + this%n_gauss = 0 + if( allocated(this%r_gauss) ) deallocate(this%r_gauss) + + this%initialised = .false. + + endsubroutine rdf_finalise + + subroutine as_distance_2b_initialise(this,args_str,error) + type(as_distance_2b), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'min_cutoff', '0.00', this%min_cutoff, help_string="Lower cutoff for as_distance_2b-type descriptors") + call param_register(params, 'max_cutoff', PARAM_MANDATORY, this%max_cutoff, help_string="Higher cutoff for as_distance_2b-type descriptors") + call param_register(params, 'as_cutoff', PARAM_MANDATORY, this%as_cutoff, help_string="Cutoff of asymmetricity") + call param_register(params, 'overlap_alpha', '0.50', this%as_cutoff, help_string="Cutoff of asymmetricity") + call param_register(params, 'min_transition_width', '0.50', this%min_transition_width, help_string="Transition width of lower cutoff for as_distance_2b-type descriptors") + call param_register(params, 'max_transition_width', '0.50', this%max_transition_width, help_string="Transition width of higher cutoff for as_distance_2b-type descriptors") + call param_register(params, 'as_transition_width', '0.10', this%as_transition_width, help_string="Transition width of asymmetricity cutoff for as_distance_2b-type descriptors") + call param_register(params, 'coordination_cutoff', PARAM_MANDATORY, this%coordination_cutoff, help_string="Cutoff for coordination function in as_distance_2b-type descriptors") + call param_register(params, 'coordination_transition_width', '0.50', this%coordination_transition_width, help_string="Transition width for as_distance_2b-type descriptors") + call param_register(params, 'Z1', '0', this%Z1, help_string="Atom type #1 in bond") + call param_register(params, 'Z2', '0', this%Z2, help_string="Atom type #2 in bond") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='as_distance_2b_initialise args_str')) then + RAISE_ERROR("as_distance_2b_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine as_distance_2b_initialise + + subroutine as_distance_2b_finalise(this,error) + type(as_distance_2b), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%min_cutoff = 0.0_dp + this%max_cutoff = 0.0_dp + this%as_cutoff = 0.0_dp + this%overlap_alpha = 0.0_dp + this%min_transition_width = 0.0_dp + this%max_transition_width = 0.0_dp + this%as_transition_width = 0.0_dp + this%coordination_cutoff = 0.0_dp + this%coordination_transition_width = 0.0_dp + this%Z1 = 0 + this%Z2 = 0 + + this%initialised = .false. + + endsubroutine as_distance_2b_finalise + + + subroutine alex_initialise(this,args_str,error) + type(alex), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.00', this%cutoff, help_string="Cutoff for alex-type descriptors") + call param_register(params, 'Z', '0', this%Z, help_string="Atomic number of central atom") + call param_register(params, 'power_min', '5', this%power_min, help_string="Minimum power of radial basis for the descriptor") + call param_register(params, 'power_max', '10', this%power_max, help_string="Maximum power of the radial basis for the descriptor") + call param_register(params, 'n_species', '1', this%n_species, help_string="Number of species for the descriptor") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='alex_initialise args_str')) then + RAISE_ERROR("alex_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + allocate(this%species_Z(this%n_species)) + + call initialise(params) + if( this%n_species == 1 ) then + call param_register(params, 'species_Z', '0', this%species_Z(1), help_string="Atomic number of species") + else + call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z, help_string="Atomic number of species") + endif + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='alex_initialise args_str')) then + RAISE_ERROR("alex_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + this%initialised = .true. + + endsubroutine alex_initialise + + subroutine alex_finalise(this,error) + type(alex), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + + if(allocated(this%species_Z)) deallocate(this%species_Z) + + this%initialised = .false. + + endsubroutine alex_finalise + + subroutine distance_Nb_initialise(this,args_str,error) + type(distance_Nb), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(len=STRING_LENGTH) :: default_Z = "" + integer :: i, j, k, i_p + integer :: nEdges, nConnectivities, nMonomerConnectivities + integer, dimension(:), allocatable :: n_permutations, connectivityList + integer, dimension(:,:), allocatable :: atom_permutations, distance_matrix_index, edges + integer :: xml_version + logical :: has_compact_clusters + + logical, dimension(:,:,:), allocatable :: allConnectivities + + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', PARAM_MANDATORY, this%cutoff, help_string="Cutoff for distance_Nb-type descriptors") + call param_register(params, 'cutoff_transition_width', '0.5', this%cutoff_transition_width, help_string="Transition width of cutoff for distance_Nb-type descriptors") + call param_register(params, 'order', PARAM_MANDATORY, this%order, help_string="Many-body order, in terms of number of neighbours") + call param_register(params, 'compact_clusters', "T", this%compact_clusters, help_string="If true, generate clusters where the atoms have at least one connection to the central atom. If false, only clusters where all atoms are connected are generated.", has_value_target=has_compact_clusters) + call param_register(params, 'xml_version', '1596837814', xml_version, help_string="Version of GAP the XML potential file was created") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_Nb_initialise args_str')) then + RAISE_ERROR("distance_Nb_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if( this%order < 1 ) then + RAISE_ERROR("distance_Nb_initialise: order must be greater than 0",error) + endif + + if (.not. has_compact_clusters) then + ! no compact_clusters specified explicitly, default depends on version + if (xml_version < 1596837814) then + ! before version where default was changed from false to true + this%compact_clusters = .false. + else + ! after version where default was changed from false to true + this%compact_clusters = .true. + endif + endif + + + allocate(this%Z(this%order)) + default_Z = "" + do i = 1, this%order + default_Z = trim(default_Z) // " 0" + enddo + + call initialise(params) + if( this%order == 1 ) then + call param_register(params, 'Z', trim(default_Z), this%Z(1), help_string="Atomic type of neighbours") + else + call param_register(params, 'Z', trim(default_Z), this%Z, help_string="Atomic type of neighbours") + endif + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='distance_Nb_initialise args_str')) then + RAISE_ERROR("distance_Nb_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + call sort_array(this%Z) + call distance_Nb_n_permutations(this%Z, n_permutations) + this%n_permutations = product(factorial_int(n_permutations)) + + allocate(atom_permutations(this%order,this%n_permutations)) + call distance_Nb_permutations(n_permutations,atom_permutations) + + allocate(distance_matrix_index(this%order,this%order)) + allocate(this%permutations( max(1,(this%order - 1) * this%order / 2), this%n_permutations)) + + if( this%order == 1 ) then + this%permutations = 1 + else + k = 0 + do i = 1, this%order + do j = i+1, this%order + k = k + 1 + distance_matrix_index(j,i) = k + distance_matrix_index(i,j) = k + enddo + enddo + + do i_p = 1, this%n_permutations + k = 0 + do i = 1, this%order + do j = i+1, this%order + k = k + 1 + this%permutations(k,i_p) = distance_matrix_index(atom_permutations(j,i_p), atom_permutations(i,i_p)) + enddo + enddo + enddo + endif + + nEdges = this%order * (this%order - 1) / 2 + allocate( edges(2,nEdges)) + + k = 0 + do i = 1, this%order + do j = i+1, this%order + k = k + 1 + edges(:,k) = (/i,j/) + enddo + enddo + + nConnectivities = 2**nEdges + + allocate(allConnectivities(this%order,this%order,nConnectivities)) + allocate(connectivityList(nEdges)) + + nMonomerConnectivities = 0 + do i = 1, nConnectivities + call integerDigits(i-1,2,connectivityList) + allConnectivities(:,:,i) = .false. + do j = 1, nEdges + allConnectivities(edges(1,j),edges(2,j),i) = ( connectivityList(j) == 1 ) + allConnectivities(edges(2,j),edges(1,j),i) = ( connectivityList(j) == 1 ) + enddo + + if( graphIsConnected( allConnectivities(:,:,i) ) ) nMonomerConnectivities = nMonomerConnectivities + 1 + enddo + + allocate(this%monomerConnectivities(this%order,this%order,nMonomerConnectivities)) + j = 0 + do i = 1, nConnectivities + if( graphIsConnected( allConnectivities(:,:,i) ) ) then + j = j + 1 + this%monomerConnectivities(:,:,j) = allConnectivities(:,:,i) + endif + enddo + + if(allocated(n_permutations)) deallocate(n_permutations) + if(allocated(atom_permutations)) deallocate(atom_permutations) + if(allocated(distance_matrix_index)) deallocate(distance_matrix_index) + if(allocated(edges)) deallocate(edges) + if(allocated(allConnectivities)) deallocate(allConnectivities) + if(allocated(connectivityList)) deallocate(connectivityList) + this%initialised = .true. + + endsubroutine distance_Nb_initialise + + subroutine distance_Nb_finalise(this,error) + type(distance_Nb), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%cutoff = 0.0_dp + this%cutoff_transition_width = 0.5_dp + this%order = 0 + this%n_permutations = 0 + this%compact_clusters = .false. + if(allocated(this%Z)) deallocate(this%Z) + if(allocated(this%permutations)) deallocate(this%permutations) + if(allocated(this%monomerConnectivities)) deallocate(this%monomerConnectivities) + + this%initialised = .false. + + endsubroutine distance_Nb_finalise + + + subroutine distance_Nb_n_permutations(Z,n_permutations,error) + integer, dimension(:), intent(in) :: Z + integer, dimension(:), allocatable :: n_permutations + integer, optional, intent(out) :: error + + integer :: i + integer, dimension(:), allocatable :: uniq_Z + + INIT_ERROR(error) + + call uniq(Z,uniq_Z) + call reallocate(n_permutations,size(uniq_Z)) + + do i = 1, size(uniq_Z) + n_permutations(i) = count( uniq_Z(i) == Z ) + enddo + + if(allocated(uniq_Z)) deallocate(uniq_Z) + + endsubroutine distance_Nb_n_permutations + + recursive subroutine distance_Nb_permutations(n_permutations,permutations) + integer, dimension(:), intent(in) :: n_permutations + integer, dimension(sum(n_permutations),product(factorial_int(n_permutations))), intent(inout) :: permutations + + integer, dimension(:), allocatable, save :: current_permutation + integer :: i, j, n_lo, n_hi + integer, save :: recursion_level = 0, i_current_permutation = 0 + + recursion_level = recursion_level + 1 + + + if( recursion_level == 1 ) then + i_current_permutation = 0 + allocate(current_permutation(sum(n_permutations))) + current_permutation = 0 + endif + + + do i = 1, size(n_permutations) + if( i == 1 ) then + n_lo = 1 + else + n_lo = sum(n_permutations(1:i-1)) + 1 + endif + n_hi = sum(n_permutations(1:i)) + do j = n_lo, n_hi + if( i_current_permutation < size(permutations,2) ) then + if( .not. any(j==current_permutation) .and. recursion_level >= n_lo .and. recursion_level <= n_hi ) then + + current_permutation(recursion_level) = j + if( recursion_level == sum(n_permutations) ) then + i_current_permutation = i_current_permutation + 1 + permutations(:,i_current_permutation) = current_permutation + else + call distance_Nb_permutations(n_permutations,permutations) + endif + endif + endif + enddo + enddo + + current_permutation(recursion_level) = 0 + + recursion_level = recursion_level - 1 + + if( recursion_level == 0 ) then + deallocate(current_permutation) + endif + + endsubroutine distance_Nb_permutations + + subroutine soap_turbo_initialise(this,args_str,error) + use soap_turbo_compress_module + + type(soap_turbo), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + integer :: l, k, i, j, m, n, n_nonzero + real(dp) :: fact, fact1, fact2, ppi, atom_sigma_radial_normalised, cutoff_hard,& + s2, I_n, N_n, N_np1, N_np2, I_np1, I_np2, C2 + character(len=64) :: compress_string + + type(LA_Matrix) :: LA_overlap + real(dp), dimension(:), allocatable :: s + real(dp), dimension(:,:), allocatable :: sqrt_overlap, u, v + real(dp), parameter :: sqrt_two = sqrt(2.0_dp) + +! Variables for equivalences with regular SOAP + logical :: is_n_max_set, is_cutoff_set, is_cutoff_transition_width_set, & + is_atom_sigma_r_set, is_atom_sigma_t_set, is_atom_sigma_r_scaling_set, & + is_atom_sigma_t_scaling_set, is_central_weight_set, is_amplitude_scaling_set, & + is_atom_sigma_set, set_sigma_t_to_r, is_atom_sigma_scaling_set, set_sigma_t_to_r_scaling + character(len=STRING_LENGTH) :: var_set + + is_n_max_set = .false. + is_cutoff_set = .false. + is_cutoff_transition_width_set = .false. + is_atom_sigma_set = .false. + set_sigma_t_to_r = .false. + is_atom_sigma_scaling_set = .false. + set_sigma_t_to_r_scaling = .false. + is_atom_sigma_r_set = .false. + is_atom_sigma_t_set = .false. + is_atom_sigma_r_scaling_set = .false. + is_atom_sigma_t_scaling_set = .false. + is_central_weight_set = .false. + is_amplitude_scaling_set = .false. + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + +! Look for those parameters defined as in regular SOAP + if( index(args_str,"cutoff=") /= 0 .and. index(args_str,"rcut_hard=") == 0 )then + is_cutoff_set = .true. + call param_register(params, 'cutoff', PARAM_MANDATORY, this%rcut_hard, help_string="TODO") + else + call param_register(params, 'rcut_hard', PARAM_MANDATORY, this%rcut_hard, help_string="Hard cutoff") + end if + if( index(args_str,"rcut_soft=") == 0 )then + is_cutoff_transition_width_set = .true. +! We store the transition width in rcut_soft, then fix it later + call param_register(params, 'cutoff_transition_width', "0.5", this%rcut_soft, help_string="TODO") + else + call param_register(params, 'rcut_soft', PARAM_MANDATORY, this%rcut_soft, help_string="Soft cutoff") + end if + +! Look for the rest of scalar parameters + call param_register(params, 'l_max', PARAM_MANDATORY, this%l_max, help_string="Angular basis resolution") + call param_register(params, 'n_species', '1', this%n_species, help_string="Number of species for the descriptor") + +! These parameters are not mandatory; these are sensible defaults + call param_register(params, 'nf', "4.0", this%nf, help_string="TODO") + call param_register(params, 'radial_enhancement', "0", this%radial_enhancement, help_string="TODO") + call param_register(params, 'basis', "poly3", this%basis, help_string="poly3 or poly3gauss") + call param_register(params, 'scaling_mode', "polynomial", this%scaling_mode, help_string="TODO") + call param_register(params, 'compress_file', "None", this%compress_file, help_string="TODO") + call param_register(params, 'compress_mode', "None", this%compress_mode, help_string="TODO") + call param_register(params, 'central_index', "1", this%central_index, help_string="Index of central atom species_Z in the >species< array") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_turbo_initialise args_str')) then + RAISE_ERROR("soap_turbo_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + +! Fix the soft cutoff if needed + if( is_cutoff_transition_width_set )then + this%rcut_soft = this%rcut_hard - this%rcut_soft + end if + +! All of these hyperparameters are species-dependent and thus given as arrays +! We try to infer intended use from the regular SOAP equivalent parameters, e.g., we +! infer alpha_max(1:n_species) = n_max, UNLESS the array definitions are provided +! explicitly, in which case explicit definitions ALWAYS override implicit definitions, +! e.g., if both n_max and alpha_max are defined, the alpha_max definition will +! override the n_max definition + + allocate(this%atom_sigma_r(this%n_species)) + allocate(this%atom_sigma_r_scaling(this%n_species)) + allocate(this%atom_sigma_t(this%n_species)) + allocate(this%atom_sigma_t_scaling(this%n_species)) + allocate(this%amplitude_scaling(this%n_species)) + allocate(this%central_weight(this%n_species)) + allocate(this%alpha_max(this%n_species)) + allocate(this%species_Z(this%n_species)) + +! central_weight is special because regular SOAP and soap_turbo use the same keyword + call initialise(params) +! If it's set as a vector + if( index(args_str,"central_weight={") /= 0 )then + if( this%n_species == 1 )then + is_central_weight_set = .true. + call param_register(params, 'central_weight', "1.0", this%central_weight(1), & + help_string="Weight of central atom in environment") + end if +! If it's set as a scalar or not set + else + is_central_weight_set = .true. + call param_register(params, 'central_weight', "1.0", this%central_weight(1), & + help_string="Weight of central atom in environment") + end if + call finalise(params) + if( is_central_weight_set )then + this%central_weight = this%central_weight(1) + end if + +! Now we set the soap_turbo hypers with the explicit array definitions OR use the implicit definitions +! to set them + call initialise(params) +! alpha_max + if( index(args_str,"n_max=") /= 0 .and. index(args_str,"alpha_max=") == 0 )then + is_n_max_set = .true. + call param_register(params, 'n_max', PARAM_MANDATORY, this%alpha_max(1), help_string="TODO") + else + if( this%n_species == 1 )then + call param_register(params, 'alpha_max', PARAM_MANDATORY, this%alpha_max(1), & + help_string="Radial basis resolution for each species") + else + call param_register(params, 'alpha_max', '//MANDATORY//', this%alpha_max, & + help_string="Radial basis resultion for each species") + end if + end if +! atom_sigma_r + if( index(args_str,"atom_sigma_r={") /= 0 )then + if( this%n_species == 1 )then + call param_register(params, 'atom_sigma_r', PARAM_MANDATORY, this%atom_sigma_r(1), & + help_string="Width of atomic Gaussians for soap-type descriptors in the radial direction") + else + call param_register(params, 'atom_sigma_r', '//MANDATORY//', this%atom_sigma_r, & + help_string="Width of atomic Gaussians for soap-type descriptors in the radial direction") + end if + else if( index(args_str,"atom_sigma_r=") /= 0 )then + is_atom_sigma_r_set = .true. + call param_register(params, 'atom_sigma_r', PARAM_MANDATORY, this%atom_sigma_r(1), & + help_string="Width of atomic Gaussians for soap-type descriptors in the radial direction") + else + is_atom_sigma_r_set = .true. + is_atom_sigma_set = .true. + call param_register(params, 'atom_sigma', PARAM_MANDATORY, this%atom_sigma_r(1), & + help_string="Width of atomic Gaussians for soap-type descriptors") + end if +! atom_sigma_t + if( index(args_str,"atom_sigma_t={") /= 0 )then + if( this%n_species == 1 )then + call param_register(params, 'atom_sigma_t', PARAM_MANDATORY, this%atom_sigma_t(1), & + help_string="Width of atomic Gaussians for soap-type descriptors in the angular direction") + else + call param_register(params, 'atom_sigma_t', '//MANDATORY//', this%atom_sigma_t, & + help_string="Width of atomic Gaussians for soap-type descriptors in the angular direction") + end if + else if( index(args_str,"atom_sigma_t=") /= 0 )then + is_atom_sigma_t_set = .true. + call param_register(params, 'atom_sigma_t', PARAM_MANDATORY, this%atom_sigma_t(1), & + help_string="Width of atomic Gaussians for soap-type descriptors in the angular direction") + else + is_atom_sigma_t_set = .true. + if( is_atom_sigma_set )then + set_sigma_t_to_r = .true. + else + call param_register(params, 'atom_sigma', PARAM_MANDATORY, this%atom_sigma_t(1), & + help_string="Width of atomic Gaussians for soap-type descriptors") + end if + end if +! atom_sigma_r_scaling + if( index(args_str,"atom_sigma_r_scaling={") /= 0 )then + if( this%n_species == 1 )then + call param_register(params, 'atom_sigma_r_scaling', PARAM_MANDATORY, this%atom_sigma_r_scaling(1), & + help_string="Scaling rate of radial sigma: scaled as a function of neighbour distance") + else + call param_register(params, 'atom_sigma_r_scaling', '//MANDATORY//', this%atom_sigma_r_scaling, & + help_string="Scaling rate of radial sigma: scaled as a function of neighbour distance") + end if + else if( index(args_str,"atom_sigma_r_scaling=") /= 0 )then + is_atom_sigma_r_scaling_set = .true. + call param_register(params, 'atom_sigma_r_scaling', PARAM_MANDATORY, this%atom_sigma_r_scaling(1), & + help_string="Scaling rate of radial sigma: scaled as a function of neighbour distance") + else + is_atom_sigma_r_scaling_set = .true. + is_atom_sigma_scaling_set = .true. + call param_register(params, 'atom_sigma_scaling', "0.0", this%atom_sigma_r_scaling(1), & + help_string="Scaling rate of atom sigma: scaled as a function of neighbour distance") + end if +! atom_sigma_t_scaling + if( index(args_str,"atom_sigma_t_scaling={") /= 0 )then + if( this%n_species == 1 )then + call param_register(params, 'atom_sigma_t_scaling', PARAM_MANDATORY, this%atom_sigma_t_scaling(1), & + help_string="Scaling rate of angular sigma: scaled as a function of neighbour distance") + else + call param_register(params, 'atom_sigma_t_scaling', '//MANDATORY//', this%atom_sigma_t_scaling, & + help_string="Scaling rate of angular sigma: scaled as a function of neighbour distance") + end if + else if( index(args_str,"atom_sigma_t_scaling=") /= 0 )then + is_atom_sigma_t_scaling_set = .true. + call param_register(params, 'atom_sigma_t_scaling', PARAM_MANDATORY, this%atom_sigma_t_scaling(1), & + help_string="Scaling rate of angular sigma: scaled as a function of neighbour distance") + else + is_atom_sigma_t_scaling_set = .true. + if( is_atom_sigma_scaling_set )then + set_sigma_t_to_r_scaling = .true. + else + call param_register(params, 'atom_sigma_scaling', "0.0", this%atom_sigma_t_scaling(1), & + help_string="Scaling rate of atom sigma: scaled as a function of neighbour distance") + end if + end if +! amplitude_scaling + if( index(args_str,"amplitude_scaling={") /= 0 )then + if( this%n_species == 1 )then + call param_register(params, 'amplitude_scaling', PARAM_MANDATORY, this%amplitude_scaling(1), & + help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") + else + call param_register(params, 'amplitude_scaling', '//MANDATORY//', this%amplitude_scaling, & + help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") + end if + else if( index(args_str,"amplitude_scaling=") /= 0 )then + is_amplitude_scaling_set = .true. + call param_register(params, 'amplitude_scaling', PARAM_MANDATORY, this%amplitude_scaling(1), & + help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") + else + is_amplitude_scaling_set = .true. + call param_register(params, 'amplitude_scaling', "1.0", this%amplitude_scaling(1), & + help_string="Scaling rate of amplitude: scaled as an inverse function of neighbour distance") + end if +! species_Z + if( this%n_species == 1 )then + call param_register(params, 'species_Z', PARAM_MANDATORY, this%species_Z(1), & + help_string="Atomic number of species, including the central atom") + else + call param_register(params, 'species_Z', '//MANDATORY//', this%species_Z, & + help_string="Atomic number of species, including the central atom") + end if +! central_weight + if( .not. is_central_weight_set )then + call param_register(params, 'central_weight', '//MANDATORY//', this%central_weight, & + help_string="Weight of central atom in environment") + end if + + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='soap_turbo_initialise args_str')) then + RAISE_ERROR("soap_turbo_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if( is_n_max_set )then + this%alpha_max = this%alpha_max(1) + end if + if( is_atom_sigma_r_set )then + this%atom_sigma_r = this%atom_sigma_r(1) + end if + if( is_atom_sigma_t_set )then + this%atom_sigma_t = this%atom_sigma_t(1) + end if + if( is_atom_sigma_r_scaling_set )then + this%atom_sigma_r_scaling = this%atom_sigma_r_scaling(1) + end if + if( is_atom_sigma_t_scaling_set )then + this%atom_sigma_t_scaling = this%atom_sigma_t_scaling(1) + end if + if( is_amplitude_scaling_set )then + this%amplitude_scaling = this%amplitude_scaling(1) + end if + if( set_sigma_t_to_r )then + this%atom_sigma_t = this%atom_sigma_r + end if + if( set_sigma_t_to_r_scaling )then + this%atom_sigma_t_scaling = this%atom_sigma_r_scaling + end if + + +! Here we read in the compression information from a file (compress_file) or rely on a keyword provided +! by the user (compress_mode) which leads to a predefined recipe to compress the soap_turbo descriptor +! The file always takes precedence over the keyword. + if( this%compress_file /= "None" )then + this%compress = .true. + open(unit=10, file=this%compress_file, status="old") + read(10, *) (i, j=1,this%n_species), i, n + read(10, '(A)') compress_string + if( compress_string == "P_transformation" )then + n_nonzero = -1 + do while( compress_string /= "end_transformation" ) + read(10, '(A)') compress_string + n_nonzero = n_nonzero + 1 + end do + this%compress_P_nonzero = n_nonzero + allocate( this%compress_P_el(1:n_nonzero) ) + allocate( this%compress_P_i(1:n_nonzero) ) + allocate( this%compress_P_j(1:n_nonzero) ) + do i = 1, n_nonzero+1 + backspace(10) + end do + do i = 1, n_nonzero + read(10,*) this%compress_P_i(i), this%compress_P_j(i), this%compress_P_el(i) + end do + else +! Old way to handle compression for backcompatibility + backspace(10) + this%compress_P_nonzero = n + allocate( this%compress_P_el(1:n) ) + allocate( this%compress_P_i(1:n) ) + allocate( this%compress_P_j(1:n) ) + do i = 1, n + read(10, *) this%compress_P_j(i) + this%compress_P_i(i) = i + this%compress_P_el(i) = 1.0_dp + end do + end if + close(10) + else if( this%compress_mode /= "None" )then + this%compress = .true. + call get_compress_indices( this%compress_mode, this%alpha_max, this%l_max, n, this%compress_P_nonzero, & + this%compress_P_i, this%compress_P_j, this%compress_P_el, "get_dim" ) + allocate( this%compress_P_i(1:this%compress_P_nonzero) ) + allocate( this%compress_P_j(1:this%compress_P_nonzero) ) + allocate( this%compress_P_el(1:this%compress_P_nonzero) ) + call get_compress_indices( this%compress_mode, this%alpha_max, this%l_max, n, this%compress_P_nonzero, & + this%compress_P_i, this%compress_P_j, this%compress_P_el, "set_indices" ) + end if + + + this%initialised = .true. + + endsubroutine soap_turbo_initialise + + subroutine soap_turbo_finalise(this,error) + type(soap_turbo), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + this%rcut_hard = 0.0_dp + this%rcut_soft = 0.0_dp + this%nf = 0.0_dp + this%n_species = 0 + this%radial_enhancement = 0 + this%central_index = 0 + this%l_max = 0 + + if(allocated(this%alpha_max)) deallocate(this%alpha_max) + if(allocated(this%atom_sigma_r)) deallocate(this%atom_sigma_r) + if(allocated(this%atom_sigma_r_scaling)) deallocate(this%atom_sigma_r_scaling) + if(allocated(this%atom_sigma_t)) deallocate(this%atom_sigma_t) + if(allocated(this%atom_sigma_t_scaling)) deallocate(this%atom_sigma_t_scaling) + if(allocated(this%amplitude_scaling)) deallocate(this%amplitude_scaling) + if(allocated(this%central_weight)) deallocate(this%central_weight) + if(allocated(this%species_Z)) deallocate(this%species_Z) + + this%initialised = .false. + + endsubroutine soap_turbo_finalise + + subroutine soap_turbo_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(soap_turbo), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("soap_turbo_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%species_Z(this%central_index) ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%rcut_hard) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine soap_turbo_sizes + + subroutine descriptor_str_add_species(this,species,descriptor_str,error) + character(len=*), intent(in) :: this + integer, dimension(:), intent(in) :: species + character(len=STRING_LENGTH), dimension(:), allocatable, intent(out) :: descriptor_str + integer, optional, intent(out) :: error + + integer :: my_descriptor_type, i, j, k, l, n_species, order, n + integer, dimension(:,:), allocatable :: ZN + real(dp), dimension(:), allocatable :: w + type(Dictionary) :: params + + INIT_ERROR(error) + + if(allocated(descriptor_str)) deallocate(descriptor_str) + + my_descriptor_type = get_descriptor_type(this,error) + n_species = size(species) + + select case(my_descriptor_type) + case(DT_BISPECTRUM_SO4,DT_BISPECTRUM_SO3,DT_BEHLER,DT_COSNX,DT_POWER_SO3,DT_POWER_SO4) + allocate(w(n_species)) + allocate(descriptor_str(n_species)) + + if( n_species == 1 ) then + w = 1.0_dp + else + w = real( (/ (i, i=0, n_species-1) /), kind=dp ) / (n_species-1) * 0.5_dp + 0.5_dp + endif + + do i = 1, n_species + descriptor_str(i) = trim(this)//" n_species="//n_species//" Z="//species(i)//" species_Z={"//species//"} w={"//w//"}" + enddo + + deallocate(w) + case(DT_SOAP) + allocate(descriptor_str(n_species)) + do i = 1, n_species + descriptor_str(i) = trim(this)//" n_species="//n_species//" Z="//species(i)//" species_Z={"//species//"}" + enddo + case(DT_DISTANCE_2B,DT_CO_DISTANCE_2B,DT_AS_DISTANCE_2B) + allocate(descriptor_str(n_species * (n_species+1) / 2)) + + l = 0 + do i = 1, n_species + do j = i, n_species + l = l + 1 + descriptor_str(l) = trim(this)//" Z1="//species(i)//" Z2="//species(j) + enddo + enddo + + case(DT_COORDINATION,DT_RDF) + allocate(descriptor_str(n_species)) + do i = 1, n_species + descriptor_str(i) = trim(this)//" Z="//species(i) + enddo + case(DT_ANGLE_3B,DT_CO_ANGLE_3B) + allocate(descriptor_str(n_species * n_species * (n_species+1) / 2)) + l = 0 + do i = 1, n_species + do j = 1, n_species + do k = j, n_species + l = l + 1 + descriptor_str(l) = trim(this)//" Z="//species(i)//" Z1="//species(j)//" Z2="//species(k) + enddo + enddo + enddo + case(DT_GENERAL_MONOMER,DT_GENERAL_DIMER,DT_GENERAL_TRIMER,DT_WATER_TRIMER,DT_WATER_MONOMER,DT_WATER_DIMER,DT_A2_DIMER,DT_AB_DIMER,DT_TRIHIS,DT_BOND_REAL_SPACE,DT_ATOM_REAL_SPACE,DT_AN_MONOMER) + allocate(descriptor_str(1)) + descriptor_str(1) = trim(this) + case(DT_DISTANCE_NB) + call initialise(params) + call param_register(params, 'order', PARAM_MANDATORY, order, help_string="Many-body order, in terms of number of neighbours") + if (.not. param_read_line(params, this, ignore_unknown=.true.,task='descriptor_str_add_species this')) then + RAISE_ERROR("descriptor_str_add_species failed to parse descriptor string='"//trim(this)//"'", error) + endif + call finalise(params) + + n = 1 + do i = 1, order + n = n * ( n_species + i - 1 ) / i ! avoids double counting + enddo + + allocate(ZN(order,n),descriptor_str(n)) + + call descriptor_str_add_species_distance_Nb(ZN,species,order) + + do i = 1, n + descriptor_str(i) = trim(this)//" Z={"//ZN(:,i)//"}" + enddo + deallocate(ZN) + + case(DT_SOAP_EXPRESS) + RAISE_ERROR("descriptor_str_add_species: no recipe for "//my_descriptor_type//" yet.",error) + case(DT_SOAP_TURBO) +! RAISE_ERROR("descriptor_str_add_species: no recipe for "//my_descriptor_type//" yet.",error) + allocate(descriptor_str(n_species)) + do i = 1, n_species +! descriptor_str(i) = trim(this)//" n_species="//n_species//" Z="//species(i)//" species_Z={"//species//"}" + descriptor_str(i) = trim(this)//" n_species="//n_species//" species_Z={"//species//"} central_index="//i + enddo + case default + RAISE_ERROR("descriptor_str_add_species: unknown descriptor type "//my_descriptor_type,error) + endselect + + endsubroutine descriptor_str_add_species + + recursive subroutine descriptor_str_add_species_distance_Nb(ZN,species,order) + integer, dimension(:,:), intent(inout) :: ZN + integer, dimension(:), intent(in) :: species + integer, intent(in) :: order + + integer :: i_species, n_species + integer, save :: current_descriptor, current_order = 0 + integer, dimension(:), allocatable, save :: ZN_current + + n_species = size(species) + + if( current_order == 0 ) then ! first run, outermost order. + current_descriptor = 0 ! keeps track of descriptor + current_order = 1 ! keeps track of order + allocate(ZN_current(order)) ! builds/updates atomic numbers gradually for each descriptor + endif + + do i_species = 1, n_species + if( current_order > 1 ) then ! no special atom, all atoms equivalent + if( species(i_species) < ZN_current(current_order-1) ) cycle ! avoids double-counting of neighbours + endif + + ZN_current(current_order) = species(i_species) + if( current_order < order ) then ! calls recursively until we reach the last order + current_order = current_order + 1 + call descriptor_str_add_species_distance_Nb(ZN,species,order) + else ! when we reached the last order, fill the atomic numbers in the loop + current_descriptor = current_descriptor + 1 ! and add them to the output array + ZN(:,current_descriptor) = ZN_current + endif + enddo + + current_order = current_order - 1 ! when the loop finished, step one level down + + if( current_order == 0 ) deallocate(ZN_current) ! when we reach zero, we finished. + + endsubroutine descriptor_str_add_species_distance_Nb + + subroutine descriptor_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(descriptor), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(cutoff(this) > at%cutoff) then + RAISE_ERROR("descriptor_calc: descriptor cutoff ("//cutoff(this)//") larger than atoms cutoff("//at%cutoff//")",error) + endif + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + call calc(this%descriptor_bispectrum_SO4,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_BISPECTRUM_SO3) + call calc(this%descriptor_bispectrum_SO3,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error=error) + case(DT_BEHLER) + call calc(this%descriptor_behler,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error=error) + case(DT_DISTANCE_2b) + call calc(this%descriptor_distance_2b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_COORDINATION) + call calc(this%descriptor_coordination,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_ANGLE_3B) + call calc(this%descriptor_angle_3b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_CO_ANGLE_3B) + call calc(this%descriptor_co_angle_3b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_CO_DISTANCE_2b) + call calc(this%descriptor_co_distance_2b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_COSNX) + call calc(this%descriptor_cosnx,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_TRIHIS) + call calc(this%descriptor_trihis,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_WATER_MONOMER) + call calc(this%descriptor_water_monomer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_WATER_DIMER) + call calc(this%descriptor_water_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_A2_DIMER) + call calc(this%descriptor_A2_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_AB_DIMER) + call calc(this%descriptor_AB_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_ATOM_REAL_SPACE) + call calc(this%descriptor_atom_real_space,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_POWER_SO3) + call calc(this%descriptor_power_so3,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_POWER_SO4) + call calc(this%descriptor_power_so4,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_SOAP) + call calc(this%descriptor_soap,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_RDF) + call calc(this%descriptor_rdf,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_AS_DISTANCE_2b) + call calc(this%descriptor_as_distance_2b,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_ALEX) + call calc(this%descriptor_alex,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_DISTANCE_Nb) + call calc(this%descriptor_distance_Nb,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_SOAP_TURBO) + call calc(this%descriptor_soap_turbo,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_BOND_REAL_SPACE) + call calc(this%descriptor_bond_real_space,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_AN_MONOMER) + call calc(this%descriptor_AN_monomer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_COM_DIMER) + call calc(this%descriptor_com_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_GENERAL_MONOMER) + call calc(this%descriptor_general_monomer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_GENERAL_DIMER) + call calc(this%descriptor_general_dimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_GENERAL_TRIMER) + call calc(this%descriptor_general_trimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_WATER_TRIMER) + call calc(this%descriptor_water_trimer,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_MOLECULE_LO_D) + call calc(this%descriptor_molecule_lo_d,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + case(DT_SOAP_EXPRESS) + call calc(this%descriptor_soap_express,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) +#endif + case default + RAISE_ERROR("descriptor_calc: unknown descriptor type "//this%descriptor_type,error) + endselect + + endsubroutine descriptor_calc + + subroutine descriptor_calc_array(this,at,descriptor_out,covariance_cutoff,descriptor_index, & + grad_descriptor_out,grad_descriptor_index,grad_descriptor_pos,grad_covariance_cutoff,args_str,error) + + type(descriptor), intent(in) :: this + type(atoms), intent(in) :: at + real(dp), dimension(:,:), intent(out), optional :: descriptor_out + real(dp), dimension(:), intent(out), optional :: covariance_cutoff + integer, dimension(:,:), intent(out), optional :: descriptor_index + real(dp), dimension(:,:,:), intent(out), optional :: grad_descriptor_out + integer, dimension(:,:), intent(out), optional :: grad_descriptor_index + real(dp), dimension(:,:), intent(out), optional :: grad_descriptor_pos + real(dp), dimension(:,:), intent(out), optional :: grad_covariance_cutoff + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(descriptor_data) :: my_descriptor_data + type(Dictionary) :: params + integer :: i, n, i_d, n_descriptors, n_cross, n_index + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + logical :: do_grad_descriptor, do_descriptor + + INIT_ERROR(error) + + do_descriptor = present(descriptor_out) + do_grad_descriptor = present(grad_descriptor_out) .or. present(grad_descriptor_index) .or. present(grad_descriptor_pos) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='descriptor_calc_array args_str')) then + RAISE_ERROR("descriptor_calc_array failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("descriptor_calc_array did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + if (associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross,mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + call calc(this,at,my_descriptor_data,do_descriptor=do_descriptor,do_grad_descriptor=do_grad_descriptor,args_str=args_str,error=error) + + if(present(descriptor_out)) & + call check_size('descriptor_out',descriptor_out, (/descriptor_dimensions(this),n_descriptors/),'descriptor_calc_array',error) + + if(present(covariance_cutoff)) & + call check_size('covariance_cutoff',covariance_cutoff,(/n_descriptors/),'descriptor_calc_array',error) + + if(present(descriptor_index)) & + call check_size('descriptor_index',descriptor_index,(/n_index,n_descriptors/),'descriptor_calc_array',error) + + if(present(grad_descriptor_out)) & + call check_size('grad_descriptor_out',grad_descriptor_out,(/descriptor_dimensions(this),3,n_cross/),'descriptor_calc_array',error) + + if(present(grad_descriptor_index)) & + call check_size('grad_descriptor_index',grad_descriptor_index,(/2,n_cross/),'descriptor_calc_array',error) + + if(present(grad_descriptor_pos)) & + call check_size('grad_descriptor_pos',grad_descriptor_pos,(/3,n_cross/),'descriptor_calc_array',error) + + if(present(grad_covariance_cutoff)) & + call check_size('grad_covariance_cutoff',grad_covariance_cutoff,(/3,n_cross/),'descriptor_calc_array',error) + + if(do_descriptor) then + do i = 1, n_descriptors + descriptor_out(:,i) = my_descriptor_data%x(i)%data + if(present(covariance_cutoff)) covariance_cutoff(i) = my_descriptor_data%x(i)%covariance_cutoff + if(present(descriptor_index)) descriptor_index(:,i) = my_descriptor_data%x(i)%ci + enddo + endif + + if(do_grad_descriptor) then + i_d = 0 + do i = 1, n_descriptors + do n = lbound(my_descriptor_data%x(i)%ii,1),ubound(my_descriptor_data%x(i)%ii,1) + i_d = i_d + 1 + if(present(grad_descriptor_index)) grad_descriptor_index(:,i_d) = (/i,my_descriptor_data%x(i)%ii(n)/) + if(present(grad_descriptor_out)) grad_descriptor_out(:,:,i_d) = my_descriptor_data%x(i)%grad_data(:,:,n) + if(present(grad_descriptor_pos)) grad_descriptor_pos(:,i_d) = my_descriptor_data%x(i)%pos(:,n) + if(present(grad_covariance_cutoff)) grad_covariance_cutoff(:,i_d) = my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) + enddo + enddo + endif + + call finalise(my_descriptor_data,error=error) + + endsubroutine descriptor_calc_array + + subroutine bispectrum_SO4_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(bispectrum_SO4), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + type(cplx_2d), dimension(:), allocatable :: U + type(cplx_3d), dimension(:,:), allocatable :: dU + + complex(dp) :: sub + complex(dp), dimension(3) :: dsub + real(dp), dimension(3) :: diff, u_ij + real(dp) :: r, tmp_cg + integer :: i, n, n_i, ji, jn, j, m1, m2, j1, j2, m11, m12, m21, m22, & + i_desc, i_bisp, d, n_descriptors, n_cross, l_n_neighbours, n_index + integer, dimension(3) :: shift + integer, dimension(total_elements) :: species_map + logical :: my_do_descriptor, my_do_grad_descriptor + + INIT_ERROR(error) + + call system_timer('bispectrum_SO4_calc') + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO4_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='bispectrum_SO4_calc args_str')) then + RAISE_ERROR("bispectrum_SO4_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("bispectrum_SO4_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + species_map = 0 + do i = 1, size(this%species_Z) + if(this%species_Z(i) == 0) then + species_map = 1 + else + species_map(this%species_Z(i)) = i + endif + enddo + + call cg_initialise(this%j_max, 2) + + call finalise(descriptor_out) + + d = bispectrum_SO4_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + i_desc = i_desc + 1 + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + + enddo + + i_desc = 0 + do i = 1, at%N + + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + + if(my_do_grad_descriptor) then + ! dU is not allocated, allocate and zero it + allocate( dU(0:this%j_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) + do j = 0, this%j_max + allocate( dU(j,0)%mm(3,-j:j,-j:j) ) + dU(j,0)%mm = CPLX_ZERO + enddo + + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + ji = neighbour(at, i, n, jn=jn, distance=r, diff=diff, cosines=u_ij,shift=shift) + if( r >= this%cutoff ) cycle + + n_i = n_i + 1 + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(n_i) = ji + descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,ji) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. + endif + enddo + + if(my_do_grad_descriptor) then + call fourier_SO4_calc(this%fourier_SO4,at,i,U,dU,args_str,error=error) + else + call fourier_SO4_calc(this%fourier_SO4,at,i,U,args_str=args_str,error=error) + endif + + if(my_do_descriptor) then + + i_bisp = 0 + do j1 = 0, this%j_max + j2 = j1 + !do j2 = 0, this%j_max + do j = abs(j1-j2), min(this%j_max,j1+j2) + if( mod(j1+j2+j,2) == 1 ) cycle + + i_bisp = i_bisp + 1 + + !do m1 = -j, j, 2 + ! do m2 = -j, j, 2 + ! sub = CPLX_ZERO + ! do m11 = max(-j1-m1,-j1), min(j1-m1,j1), 2 + ! do m21 = max(-j2-m2,-j2), min(j2-m2,j2), 2 + ! sub = sub + cg_array(j1,m11,j,m1,j1,m11+m1) & + ! * cg_array(j2,m21,j,m2,j2,m21+m2) & + ! * U(j1)%mm(m11,m11+m1) * U(j2)%mm(m21,m21+m2) + ! enddo + ! enddo + ! descriptor_out%x(i_desc)%data(i_bisp) = descriptor_out%x(i_desc)%data(i_bisp) + sub*conjg(U(j)%mm(-m2,m1))*(-1)**(m2/2) + ! enddo + !enddo + + do m1 = -j, j, 2 + do m2 = -j, j, 2 + sub = CPLX_ZERO + do m11 = max(-j1,m1-j2), min(j1,m1+j2), 2 + do m12 = max(-j1,m2-j2), min(j1,m2+j2), 2 + sub = sub + cg_array(j1,m11,j2,m1-m11,j,m1) & + * cg_array(j1,m12,j2,m2-m12,j,m2) & + * U(j1)%mm(m11,m12) * U(j2)%mm(m1-m11,m2-m12) + enddo + enddo + descriptor_out%x(i_desc)%data(i_bisp) = descriptor_out%x(i_desc)%data(i_bisp) + sub*conjg(U(j)%mm(m1,m2)) + enddo + enddo + + enddo + !enddo + enddo + endif + + if(my_do_grad_descriptor) then + n_i = 0 + do n = 0, n_neighbours(at,i) + if( n>0 ) then + ji = neighbour(at, i, n, distance=r) + if( r >= this%cutoff ) cycle + n_i = n_i + 1 + endif + i_bisp = 0 + do j1 = 0, this%j_max + j2 = j1 + !do j2 = 0, this%j_max + do j = abs(j1-j2), min(this%j_max,j1+j2) + if( mod(j1+j2+j,2) == 1 ) cycle + + i_bisp = i_bisp + 1 + + !do m1 = -j, j, 2 + ! do m2 = -j, j, 2 + ! sub = CPLX_ZERO + ! dsub = CPLX_ZERO + + ! do m11 = max(-j1-m1,-j1), min(j1-m1,j1), 2 + ! do m21 = max(-j2-m2,-j2), min(j2-m2,j2), 2 + ! tmp_cg = cg_array(j1,m11,j,m1,j1,m11+m1) & + ! * cg_array(j2,m21,j,m2,j2,m21+m2) + + ! sub = sub + tmp_cg & + ! * U(j1)%mm(m11,m1+m11) * U(j2)%mm(m21,m2+m21) + ! dsub = dsub + tmp_cg & + ! * ( dU(j1,n_i)%mm(:,m11,m1+m11) * U(j2)%mm(m21,m2+m21) + & + ! U(j1)%mm(m11,m1+m11) * dU(j2,n_i)%mm(:,m21,m2+m21) ) + ! enddo + ! enddo + ! descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) = & + ! descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) + & + ! ( dsub*conjg(U(j)%mm(-m2,m1)) + sub*conjg(dU(j,n_i)%mm(:,-m2,m1)) )*(-1)**(m2/2) + ! enddo + !enddo + do m1 = -j, j, 2 + do m2 = -j, j, 2 + sub = CPLX_ZERO + dsub = CPLX_ZERO + do m11 = max(-j1,m1-j2), min(j1,m1+j2), 2 + do m12 = max(-j1,m2-j2), min(j1,m2+j2), 2 + + tmp_cg = cg_array(j1,m11,j2,m1-m11,j,m1) & + * cg_array(j1,m12,j2,m2-m12,j,m2) + + sub = sub + tmp_cg & + * U(j1)%mm(m11,m12) * U(j2)%mm(m1-m11,m2-m12) + dsub = dsub + tmp_cg & + * ( dU(j1,n_i)%mm(:,m11,m12) * U(j2)%mm(m1-m11,m2-m12) + & + U(j1)%mm(m11,m12) * dU(j2,n_i)%mm(:,m1-m11,m2-m12) ) + enddo + enddo + descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) = & + descriptor_out%x(i_desc)%grad_data(i_bisp,:,n_i) + & + dsub*conjg(U(j)%mm(m1,m2)) + sub*conjg(dU(j,n_i)%mm(:,m1,m2)) + enddo + enddo + + enddo + !enddo + enddo + enddo + endif + + call finalise(dU) + enddo ! i + + ! clear U from the memory + call finalise(U) + + call system_timer('bispectrum_SO4_calc') + + endsubroutine bispectrum_SO4_calc + + subroutine bispectrum_so3_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(bispectrum_so3), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(cplx_1d), dimension(:), allocatable :: SphericalY_ij + type(cplx_1d), dimension(:,:), allocatable :: fourier_so3 + + type(cplx_2d), dimension(:), allocatable :: dSphericalY_ij + type(cplx_2d), dimension(:,:,:), allocatable :: dfourier_so3 + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, n, a, l, m, l1, l2, m1, i_desc, i_pow, l_n_neighbours, & + n_i, n_descriptors, n_cross, n_index + integer, dimension(3) :: shift_ij + real(dp) :: r_ij + real(dp), dimension(3) :: u_ij, d_ij + real(dp), dimension(:), allocatable :: Rad_ij + real(dp), dimension(:,:), allocatable :: dRad_ij + + complex(dp) :: sub, dsub(3) + + integer, dimension(total_elements) :: species_map + + INIT_ERROR(error) + + call system_timer('bispectrum_so3_calc') + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_so3_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + species_map = 0 + do i = 1, size(this%species_Z) + if(this%species_Z(i) == 0) then + species_map = 1 + else + species_map(this%species_Z(i)) = i + endif + enddo + + call cg_initialise(this%l_max) + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='bispectrum_SO3_calc args_str')) then + RAISE_ERROR("bispectrum_SO3_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("bispectrum_SO3_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("bispectrum_SO3_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = bispectrum_so3_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + + allocate(descriptor_out%x(n_descriptors)) + + i_desc = 0 + do i = 1, at%N + + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + i_desc = i_desc + 1 + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + allocate(fourier_so3(0:this%l_max,this%n_max),SphericalY_ij(0:this%l_max),Rad_ij(this%n_max)) + do a = 1, this%n_max + do l = 0, this%l_max + allocate(fourier_so3(l,a)%m(-l:l)) + fourier_so3(l,a)%m(:) = CPLX_ZERO + enddo + enddo + do l = 0, this%l_max + allocate(SphericalY_ij(l)%m(-l:l)) + enddo + + if(my_do_grad_descriptor) then + allocate( dRad_ij(3,this%n_max), dSphericalY_ij(0:this%l_max) ) + do l = 0, this%l_max + allocate(dSphericalY_ij(l)%mm(3,-l:l)) + enddo + endif + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + i_desc = i_desc + 1 + + do a = 1, this%n_max + do l = 0, this%l_max + fourier_so3(l,a)%m(:) = CPLX_ZERO + enddo + enddo + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + + if(my_do_grad_descriptor) then + allocate( dfourier_so3(0:this%l_max,this%n_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) + do n = 0, n_neighbours(at,i,max_dist=this%cutoff) + do a = 1, this%n_max + do l = 0, this%l_max + allocate(dfourier_so3(l,a,n)%mm(3,-l:l)) + dfourier_so3(l,a,n)%mm(:,:) = CPLX_ZERO + enddo + enddo + enddo + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(n_i) = j + descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. + endif + + do a = 1, this%n_max + Rad_ij(a) = RadialFunction(this%Radial, r_ij, a) + if(my_do_grad_descriptor) dRad_ij(:,a) = GradRadialFunction(this%Radial, r_ij, a) * u_ij + enddo + + do l = 0, this%l_max + do m = -l, l + SphericalY_ij(l)%m(m) = SphericalYCartesian(l,m,d_ij) + if(my_do_grad_descriptor) dSphericalY_ij(l)%mm(:,m) = GradSphericalYCartesian(l,m,d_ij) + enddo + enddo + + do a = 1, this%n_max + do l = 0, this%l_max + do m = -l, l + fourier_so3(l,a)%m(m) = fourier_so3(l,a)%m(m) + Rad_ij(a)*SphericalY_ij(l)%m(m) + if(my_do_grad_descriptor) then + dfourier_so3(l,a,n_i)%mm(:,m) = dfourier_so3(l,a,n_i)%mm(:,m) + & + dRad_ij(:,a) * SphericalY_ij(l)%m(m) + Rad_ij(a)*dSphericalY_ij(l)%mm(:,m) + endif + enddo + enddo + enddo + + enddo ! n + + if(my_do_descriptor) then + i_pow = 0 + do a = 1, this%n_max + do l1 = 0, this%l_max + l2 = l1 + !do l2 = 0, this%l_max + do l = abs(l1-l2), min(this%l_max,l1+l2) + if( mod(l1,2)==1 .and. mod(l2,2)==1 .and. mod(l,2)==1 ) cycle + i_pow = i_pow + 1 + + do m = -l, l + sub = CPLX_ZERO + do m1 = max(-l1,m-l2),min(l1,m+l2) + sub = sub + cg_array(l1,m1,l2,m-m1,l,m) * conjg(fourier_so3(l1,a)%m(m1)) * conjg(fourier_so3(l2,a)%m(m-m1)) + enddo + + descriptor_out%x(i_desc)%data(i_pow) = descriptor_out%x(i_desc)%data(i_pow) + fourier_so3(l,a)%m(m) * sub + enddo + + enddo + !enddo + enddo + enddo + endif + + if(my_do_grad_descriptor) then + do n = 1, n_neighbours(at,i,max_dist=this%cutoff) + i_pow = 0 + do a = 1, this%n_max + do l1 = 0, this%l_max + l2 = l1 + !do l2 = 0, this%l_max + do l = abs(l1-l2), min(this%l_max,l1+l2) + if( mod(l1,2)==1 .and. mod(l2,2)==1 .and. mod(l,2)==1 ) cycle + i_pow = i_pow + 1 + + do m = -l, l + sub = CPLX_ZERO + dsub = CPLX_ZERO + do m1 = max(-l1,m-l2),min(l1,m+l2) + dsub = dsub + cg_array(l1,m1,l2,m-m1,l,m) * & + ( conjg(dfourier_so3(l1,a,n)%mm(:,m1)) * conjg(fourier_so3(l2,a)%m(m-m1)) + & + conjg(fourier_so3(l1,a)%m(m1)) * conjg(dfourier_so3(l2,a,n)%mm(:,m-m1)) ) + sub = sub + cg_array(l1,m1,l2,m-m1,l,m) * conjg(fourier_so3(l1,a)%m(m1)) * conjg(fourier_so3(l2,a)%m(m-m1)) + enddo + + descriptor_out%x(i_desc)%grad_data(i_pow,:,n) = descriptor_out%x(i_desc)%grad_data(i_pow,:,n) + & + fourier_so3(l,a)%m(m) * dsub + dfourier_so3(l,a,n)%mm(:,m) * sub + enddo + enddo + !enddo + enddo + enddo + descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,n) + enddo + endif + + if(allocated(dfourier_so3)) then + do n = lbound(dfourier_so3,3), ubound(dfourier_so3,3) + do a = lbound(dfourier_so3,2), ubound(dfourier_so3,2) + do l = lbound(dfourier_so3,1), ubound(dfourier_so3,1) + deallocate(dfourier_so3(l,a,n)%mm) + enddo + enddo + enddo + deallocate(dfourier_so3) + endif + + enddo ! i + + if(allocated(Rad_ij)) deallocate(Rad_ij) + if(allocated(dRad_ij)) deallocate(dRad_ij) + + if(allocated(fourier_so3)) then + do a = lbound(fourier_so3,2), ubound(fourier_so3,2) + do l = lbound(fourier_so3,1), ubound(fourier_so3,1) + deallocate(fourier_so3(l,a)%m) + enddo + enddo + deallocate(fourier_so3) + endif + + if(allocated(SphericalY_ij)) then + do l = lbound(SphericalY_ij,1), ubound(SphericalY_ij,1) + deallocate(SphericalY_ij(l)%m) + enddo + deallocate(SphericalY_ij) + endif + + if(allocated(dSphericalY_ij)) then + do l = lbound(dSphericalY_ij,1), ubound(dSphericalY_ij,1) + deallocate(dSphericalY_ij(l)%mm) + enddo + deallocate(dSphericalY_ij) + endif + + call system_timer('bispectrum_so3_calc') + + endsubroutine bispectrum_so3_calc + + subroutine behler_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(behler), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, k, n, m, a, b, i_desc_i, l_n_neighbours, & + n_i, m_i, n_descriptors, n_cross, n_index + integer, dimension(:), allocatable :: i_desc + integer, dimension(3) :: shift_ij + real(dp) :: r_ij, r_ik, r_jk, cos_ijk, Ang, dAng, Rad, dRad_ij, dRad_ik, dRad_jk, f_cut_ij, f_cut_ik, f_cut_jk, df_cut_ij, df_cut_ik, df_cut_jk, g2, dg2 + real(dp), dimension(3) :: u_ij, u_ik, u_jk, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik + + INIT_ERROR(error) + + call system_timer('behler_calc') + + if(.not. this%initialised) then + RAISE_ERROR("behler_calc: descriptor object not initialised", error) + endif + + if( at%cutoff < this%cutoff ) then + RAISE_ERROR("behler_calc: cutoff of atoms object ("//at%cutoff//") less than cutoff of descriptor ("//this%cutoff//")", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='behler_calc args_str')) then + RAISE_ERROR("behler_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("behler_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + call finalise(descriptor_out) + + d = behler_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + allocate(i_desc(at%N)) + + i_desc = 0 + i_desc_i = 0 + do i = 1, at%N + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + if( this%Z /= 0 .and. this%Z /= at%Z(i) ) cycle + i_desc_i = i_desc_i + 1 + i_desc(i) = i_desc_i + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc_i)%data(d)) + descriptor_out%x(i_desc_i)%data = 0.0_dp + allocate(descriptor_out%x(i_desc_i)%ci(n_index)) + descriptor_out%x(i_desc_i)%has_data = .false. + descriptor_out%x(i_desc_i)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc_i)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc_i)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc_i)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc_i)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc_i)%grad_data = 0.0_dp + descriptor_out%x(i_desc_i)%ii = 0 + descriptor_out%x(i_desc_i)%pos = 0.0_dp + descriptor_out%x(i_desc_i)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc_i)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc_i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + +!$omp parallel do schedule(dynamic) default(none) shared(this,at,descriptor_out,my_do_descriptor, my_do_grad_descriptor, d, i_desc) & +!$omp private(i,j,k,i_desc_i,n_i,n,r_ij,u_ij,d_ij,shift_ij,f_cut_ij,df_cut_ij,g2,dg2,m_i,m,r_ik,u_ik,d_ik,d_jk,r_jk,u_jk,cos_ijk) & +!$omp private(dcosijk_ij,dcosijk_ik,a,b,f_cut_ik,f_cut_jk,df_cut_ik,df_cut_jk,Ang,Rad,dAng,dRad_ij,dRad_ik,dRad_jk) + do i = 1, at%N + if( this%Z /= 0 .and. this%Z /= at%Z(i) ) cycle + + if(i_desc(i) == 0) then + cycle + else + i_desc_i = i_desc(i) + endif + + if(my_do_descriptor) then + descriptor_out%x(i_desc_i)%ci(1) = i + descriptor_out%x(i_desc_i)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc_i)%ii(0) = i + descriptor_out%x(i_desc_i)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc_i)%has_grad_data(0) = .true. + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc_i)%ii(n_i) = j + descriptor_out%x(i_desc_i)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc_i)%has_grad_data(n_i) = .true. + endif + + do a = 1, this%n_g2 + if ( r_ij >= this%g2(a)%rc .or. ( this%g2(a)%Z_n /=0 .and. this%g2(a)%Z_n /= at%Z(j) ) ) cycle + + f_cut_ij = cos_cutoff_function(r_ij,this%g2(a)%rc) + if(my_do_grad_descriptor) df_cut_ij = dcos_cutoff_function(r_ij,this%g2(a)%rc) + + g2 = exp(-this%g2(a)%eta * (r_ij-this%g2(a)%rs)**2) + if(my_do_descriptor) descriptor_out%x(i_desc_i)%data(a) = descriptor_out%x(i_desc_i)%data(a) + g2 * f_cut_ij + if(my_do_grad_descriptor) then + dg2 = -2.0_dp * this%g2(a)%eta * (r_ij-this%g2(a)%rs) * g2 + descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) = ( dg2 * f_cut_ij + g2 * df_cut_ij ) * u_ij + descriptor_out%x(i_desc_i)%grad_data(a,:,0) = descriptor_out%x(i_desc_i)%grad_data(a,:,0) - descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) + endif + enddo + + + m_i = 0 + do m = 1, n_neighbours(at,i) + k = neighbour(at, i, m, distance = r_ik, cosines=u_ik, diff=d_ik) + if( r_ik >= this%cutoff ) cycle + + m_i = m_i + 1 + + d_jk = d_ik - d_ij + r_jk = norm(d_jk) + if( r_jk .feq. 0.0_dp ) cycle + + u_jk = d_jk / r_jk + + cos_ijk = dot_product(u_ij,u_ik) + + if(my_do_grad_descriptor) then + dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij + dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik + endif + + do b = 1, this%n_g3 + if( r_ik >= this%g3(b)%rc .or. r_jk >= this%g3(b)%rc) cycle + if( this%g3(b)%Z_n(1) /= 0 .and. this%g3(b)%Z_n(2) /= 0 ) then + if( .not. ( & + ( this%g3(b)%Z_n(1) == at%Z(j) .and. this%g3(b)%Z_n(2) == at%Z(k) ) .or. & + ( this%g3(b)%Z_n(1) == at%Z(k) .and. this%g3(b)%Z_n(2) == at%Z(j) ) ) ) cycle + endif + + f_cut_ij = cos_cutoff_function(r_ij,this%g3(b)%rc) + f_cut_ik = cos_cutoff_function(r_ik,this%g3(b)%rc) + f_cut_jk = cos_cutoff_function(r_jk,this%g3(b)%rc) + if(my_do_grad_descriptor) then + df_cut_ij = dcos_cutoff_function(r_ij,this%g3(b)%rc) + df_cut_ik = dcos_cutoff_function(r_ik,this%g3(b)%rc) + df_cut_jk = dcos_cutoff_function(r_jk,this%g3(b)%rc) + endif + + a = b + this%n_g2 + + Ang = (1.0_dp + this%g3(b)%lambda * cos_ijk)**this%g3(b)%zeta + Rad = exp( -this%g3(b)%eta * (r_ij**2 + r_ik**2 + r_jk**2) ) + if(my_do_descriptor) descriptor_out%x(i_desc_i)%data(a) = descriptor_out%x(i_desc_i)%data(a) + 0.5_dp * Ang * Rad * f_cut_ij * f_cut_ik * f_cut_jk + if(my_do_grad_descriptor) then + dAng = this%g3(b)%zeta * (1.0_dp + this%g3(b)%lambda * cos_ijk)**(this%g3(b)%zeta -1.0_dp) * this%g3(b)%lambda + dRad_ij = -this%g3(b)%eta * 2.0_dp * r_ij * Rad + dRad_ik = -this%g3(b)%eta * 2.0_dp * r_ik * Rad + dRad_jk = -this%g3(b)%eta * 2.0_dp * r_jk * Rad + + descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) = descriptor_out%x(i_desc_i)%grad_data(a,:,n_i) + 0.5_dp * & + ( ( dAng * dcosijk_ij * Rad + Ang * ( dRad_ij * u_ij - dRad_jk * u_jk ) ) * f_cut_ij * f_cut_ik * f_cut_jk + & + Ang * Rad * f_cut_ik * ( df_cut_ij * u_ij * f_cut_jk - f_cut_ij * df_cut_jk * u_jk ) ) + + descriptor_out%x(i_desc_i)%grad_data(a,:,m_i) = descriptor_out%x(i_desc_i)%grad_data(a,:,m_i) + 0.5_dp * & + ( ( dAng * dcosijk_ik * Rad + Ang * ( dRad_ik * u_ik + dRad_jk * u_jk ) ) * f_cut_ij * f_cut_ik * f_cut_jk + & + Ang * Rad * f_cut_ij * ( df_cut_ik * u_ik * f_cut_jk + f_cut_ik * df_cut_jk * u_jk ) ) + + descriptor_out%x(i_desc_i)%grad_data(a,:,0) = descriptor_out%x(i_desc_i)%grad_data(a,:,0) - 0.5_dp * & + ( ( dAng * (dcosijk_ij+dcosijk_ik) * Rad + Ang * (dRad_ij * u_ij + dRad_ik * u_ik) ) * f_cut_ij * f_cut_ik * f_cut_jk + & + Ang * Rad * f_cut_jk * ( df_cut_ij * u_ij * f_cut_ik + f_cut_ij * df_cut_ik * u_ik ) ) + endif + + + enddo + + enddo + enddo + + do b = 1, this%n_g3 + a = b + this%n_g2 + + if(my_do_descriptor) descriptor_out%x(i_desc_i)%data(a) = descriptor_out%x(i_desc_i)%data(a) * 2.0_dp**(1.0_dp-this%g3(b)%zeta) + if(my_do_grad_descriptor) descriptor_out%x(i_desc_i)%grad_data(a,:,:) = descriptor_out%x(i_desc_i)%grad_data(a,:,:) * 2.0_dp**(1.0_dp-this%g3(b)%zeta) + enddo + enddo +!$omp end parallel do + + if(allocated(i_desc)) deallocate(i_desc) + + call system_timer('behler_calc') + + endsubroutine behler_calc + + subroutine distance_2b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(distance_2b), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical :: needs_resid + logical, dimension(:), pointer :: atom_mask_pointer + integer, dimension(:), pointer :: resid_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor, Zi1, Zi2, Zj1, Zj2 + integer :: d, n_descriptors, n_cross, i_desc, i, j, n, n_index + integer, dimension(3) :: shift + real(dp) :: r_ij, covariance_cutoff, dcovariance_cutoff, tail, dtail + real(dp), dimension(3) :: u_ij + + INIT_ERROR(error) + + call system_timer('distance_2b_calc') + + if(.not. this%initialised) then + RAISE_ERROR("distance_2b_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='distance_2b_calc args_str')) then + RAISE_ERROR("distance_2b_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("distance_2b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + needs_resid = this%only_intra .or. this%only_inter + if (needs_resid) then + if (.not. assign_pointer(at, trim(this%resid_name), resid_pointer)) then + RAISE_ERROR("distance_2b_calc did not find "//trim(this%resid_name)//" property (residue id) in the atoms object.", error) + end if + else + resid_pointer => null() + end if + + d = distance_2b_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%ci = 0 + descriptor_out%x(i)%has_data = .false. + descriptor_out%x(i)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,0:1)) + allocate(descriptor_out%x(i)%ii(0:1)) + allocate(descriptor_out%x(i)%pos(3,0:1)) + allocate(descriptor_out%x(i)%has_grad_data(0:1)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,0:1)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + i_desc = 0 + do i = 1, at%N + + if(associated(atom_mask_pointer)) then ! skip if masked + if(.not. atom_mask_pointer(i)) cycle ! skip if masked + endif ! skip if masked + + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) + if( r_ij >= this%cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + if (needs_resid) then + if (this%only_intra .and. resid_pointer(i) /= resid_pointer(j)) cycle + if (this%only_inter .and. resid_pointer(i) == resid_pointer(j)) cycle + end if + + i_desc = i_desc + 1 + + covariance_cutoff = coordination_function(r_ij,this%cutoff,this%cutoff_transition_width) + if( this%has_tail .and. this%tail_exponent /= 0 ) then + tail = ( erf(this%tail_range*r_ij) / r_ij )**this%tail_exponent + else + tail = 1.0_dp + endif + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%data(:) = r_ij**this%exponents + descriptor_out%x(i_desc)%ci(1:2) = (/i,j/) + descriptor_out%x(i_desc)%has_data = .true. + + descriptor_out%x(i_desc)%covariance_cutoff = covariance_cutoff * tail + endif + if(my_do_grad_descriptor) then + dcovariance_cutoff = dcoordination_function(r_ij,this%cutoff,this%cutoff_transition_width) + if( this%has_tail .and. this%tail_exponent /= 0 ) then + dtail = tail * this%tail_exponent * ( 2.0_dp*this%tail_range*exp(-this%tail_range**2*r_ij**2) / & + sqrt(pi) / erf(this%tail_range*r_ij) - 1.0_dp / r_ij ) + else + dtail = 0.0_dp + endif + + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + descriptor_out%x(i_desc)%grad_data(:,:,0) = -( this%exponents*r_ij**(this%exponents-1) ) .outer. u_ij + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = -(dcovariance_cutoff*tail + covariance_cutoff*dtail)*u_ij + + descriptor_out%x(i_desc)%ii(1) = j + descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(1) = .true. + descriptor_out%x(i_desc)%grad_data(:,:,1) = - descriptor_out%x(i_desc)%grad_data(:,:,0) + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) + + endif + enddo + enddo + + call system_timer('distance_2b_calc') + + endsubroutine distance_2b_calc + + subroutine coordination_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(coordination), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, n, i_n, l_n_neighbours, i_desc, n_descriptors, n_cross, n_index + integer, dimension(3) :: shift + real(dp) :: r_ij + real(dp), dimension(3) :: u_ij, df_cut + + INIT_ERROR(error) + + call system_timer('coordination_calc') + + if(.not. this%initialised) then + RAISE_ERROR("coordination_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='coordination_calc args_str')) then + RAISE_ERROR("coordination_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("coordination_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + call finalise(descriptor_out) + + d = coordination_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + i_desc = i_desc + 1 + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + i_desc = 0 + do i = 1, at%N + + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + i_n = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) + + if( r_ij >= this%cutoff ) cycle + i_n = i_n + 1 + + if(my_do_descriptor) & + descriptor_out%x(i_desc)%data(1) = descriptor_out%x(i_desc)%data(1) + coordination_function(r_ij,this%cutoff,this%transition_width) + + if(my_do_grad_descriptor) then + df_cut = dcoordination_function(r_ij,this%cutoff,this%transition_width) * u_ij + + descriptor_out%x(i_desc)%grad_data(1,:,0) = descriptor_out%x(i_desc)%grad_data(1,:,0) - df_cut + + descriptor_out%x(i_desc)%ii(i_n) = j + descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,i_n) = df_cut + endif + enddo + enddo + + call system_timer('coordination_calc') + + endsubroutine coordination_calc + + subroutine angle_3b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(angle_3b), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor, Zk1, Zk2, Zj1, Zj2 + integer :: d, n_descriptors, n_cross, i_desc, i, j, k, n, m, n_index + integer, dimension(3) :: shift_ij, shift_ik + real(dp) :: r_ij, r_ik, r_jk, cos_ijk, fc_j, fc_k, dfc_j, dfc_k + real(dp), dimension(3) :: u_ij, u_ik, u_jk, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik + + INIT_ERROR(error) + + call system_timer('angle_3b_calc') + + if(.not. this%initialised) then + RAISE_ERROR("angle_3b_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='angle_3b_calc args_str')) then + RAISE_ERROR("angle_3b_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("angle_3b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + d = angle_3b_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%has_data = .false. + endif + + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,0:2)) + allocate(descriptor_out%x(i)%ii(0:2)) + allocate(descriptor_out%x(i)%pos(3,0:2)) + allocate(descriptor_out%x(i)%has_grad_data(0:2)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,0:2)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + i_desc = 0 + do i = 1, at%N + if(associated(atom_mask_pointer)) then ! skip if masked + if(.not. atom_mask_pointer(i)) cycle ! skip if masked + endif ! skip if masked + + if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, diff = d_ij, shift=shift_ij) + + if( r_ij >= this%cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + + fc_j = coordination_function(r_ij,this%cutoff,this%cutoff_transition_width) + dfc_j = dcoordination_function(r_ij,this%cutoff,this%cutoff_transition_width) + + do m = 1, n_neighbours(at,i) + + if( n == m ) cycle + + k = neighbour(at, i, m, distance = r_ik, cosines = u_ik, diff = d_ik, shift=shift_ik) + if( r_ik >= this%cutoff ) cycle + + Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) + Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) + + if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + d_jk = d_ij - d_ik + r_jk = norm(d_jk) + u_jk = d_jk / r_jk + + fc_k = coordination_function(r_ik,this%cutoff,this%cutoff_transition_width) + dfc_k = dcoordination_function(r_ik,this%cutoff,this%cutoff_transition_width) + + cos_ijk = dot_product(d_ij,d_ik)/(r_ij*r_ik) + + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%data(1) = r_ij + r_ik + descriptor_out%x(i_desc)%data(2) = (r_ij - r_ik)**2 + descriptor_out%x(i_desc)%data(3) = r_jk !cos_ijk + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + + descriptor_out%x(i_desc)%covariance_cutoff = fc_j*fc_k + endif + + if(my_do_grad_descriptor) then + dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij + dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik + + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,0) = - u_ij - u_ik + descriptor_out%x(i_desc)%grad_data(2,:,0) = 2.0_dp * (r_ij - r_ik)*(-u_ij + u_ik) + descriptor_out%x(i_desc)%grad_data(3,:,0) = 0.0_dp !-dcosijk_ij - dcosijk_ik + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = - dfc_j*fc_k*u_ij - dfc_k*fc_j*u_ik + + descriptor_out%x(i_desc)%ii(1) = j + descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(1) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij + descriptor_out%x(i_desc)%grad_data(2,:,1) = 2.0_dp * (r_ij - r_ik)*u_ij + descriptor_out%x(i_desc)%grad_data(3,:,1) = u_jk !dcosijk_ij + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = dfc_j*fc_k*u_ij + + descriptor_out%x(i_desc)%ii(2) = k + descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,k) + matmul(at%lattice,shift_ik) + descriptor_out%x(i_desc)%has_grad_data(2) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,2) = u_ik + descriptor_out%x(i_desc)%grad_data(2,:,2) = 2.0_dp * (r_ij - r_ik)*(-u_ik) + descriptor_out%x(i_desc)%grad_data(3,:,2) = -u_jk !dcosijk_ik + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,2) = dfc_k*fc_j*u_ik + endif + enddo + enddo + enddo + + call system_timer('angle_3b_calc') + + endsubroutine angle_3b_calc + + subroutine co_angle_3b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(co_angle_3b), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(descriptor) :: my_coordination + type(descriptor_data) :: descriptor_coordination + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor, Zk1, Zk2, Zj1, Zj2 + integer :: d, n_descriptors, n_cross, i_desc, i, j, k, n, m, & + l_n_neighbours_coordination, n_index + integer, dimension(3) :: shift_ij, shift_ik + real(dp) :: r_ij, r_ik, r_jk, cos_ijk, fc_j, fc_k, dfc_j, dfc_k + real(dp), dimension(3) :: u_ij, u_ik, u_jk, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik + + INIT_ERROR(error) + + call system_timer('co_angle_3b_calc') + + if(.not. this%initialised) then + RAISE_ERROR("co_angle_3b_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='co_angle_3b_calc args_str')) then + RAISE_ERROR("co_angle_3b_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("co_angle_3b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("co_angle_3b_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = co_angle_3b_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + i_desc = 0 + do i = 1, at%N + if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle + l_n_neighbours_coordination = n_neighbours(at,i,max_dist=this%coordination_cutoff) + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij) + if( r_ij >= this%cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + + do m = 1, n_neighbours(at,i) + + if( n == m ) cycle + + k = neighbour(at, i, m, distance = r_ik) + if( r_ik >= this%cutoff ) cycle + + Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) + Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) + + if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + i_desc = i_desc + 1 + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + endif + + if(my_do_grad_descriptor) then + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:2+l_n_neighbours_coordination)) + allocate(descriptor_out%x(i_desc)%ii(0:2+l_n_neighbours_coordination)) + allocate(descriptor_out%x(i_desc)%pos(3,0:2+l_n_neighbours_coordination)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:2+l_n_neighbours_coordination)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:2+l_n_neighbours_coordination)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + enddo + enddo + + call initialise(my_coordination,'coordination cutoff='//this%coordination_cutoff//' coordination_transition_width='//this%coordination_transition_width,error) + call calc(my_coordination,at,descriptor_coordination,do_descriptor,do_grad_descriptor,args_str,error) + + i_desc = 0 + do i = 1, at%N + if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, diff = d_ij, shift=shift_ij) + + if( r_ij >= this%cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + + fc_j = coordination_function(r_ij,this%cutoff,0.5_dp) + dfc_j = dcoordination_function(r_ij,this%cutoff,0.5_dp) + + do m = 1, n_neighbours(at,i) + if( n == m ) cycle + + k = neighbour(at, i, m, distance = r_ik, cosines = u_ik, diff = d_ik, shift=shift_ik) + if( r_ik >= this%cutoff ) cycle + + Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) + Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) + + if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + d_jk = d_ij - d_ik + r_jk = norm(d_jk) + u_jk = d_jk / r_jk + + fc_k = coordination_function(r_ik,this%cutoff,0.5_dp) + dfc_k = dcoordination_function(r_ik,this%cutoff,0.5_dp) + + cos_ijk = dot_product(d_ij,d_ik)/(r_ij*r_ik) + + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%data(1) = r_ij + r_ik + descriptor_out%x(i_desc)%data(2) = (r_ij - r_ik)**2 + descriptor_out%x(i_desc)%data(3) = r_jk !cos_ijk + descriptor_out%x(i_desc)%data(4) = descriptor_coordination%x(i)%data(1) + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + + descriptor_out%x(i_desc)%covariance_cutoff = fc_j*fc_k + endif + + if(my_do_grad_descriptor) then + dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij + dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik + + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,0) = - u_ij - u_ik + descriptor_out%x(i_desc)%grad_data(2,:,0) = 2.0_dp * (r_ij - r_ik)*(-u_ij + u_ik) + descriptor_out%x(i_desc)%grad_data(3,:,0) = 0.0_dp !-dcosijk_ij - dcosijk_ik + descriptor_out%x(i_desc)%grad_data(4,:,0) = descriptor_coordination%x(i)%grad_data(1,:,0) + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = - dfc_j*fc_k*u_ij - dfc_k*fc_j*u_ik + + descriptor_out%x(i_desc)%ii(1) = j + descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(1) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij + descriptor_out%x(i_desc)%grad_data(2,:,1) = 2.0_dp * (r_ij - r_ik)*u_ij + descriptor_out%x(i_desc)%grad_data(3,:,1) = u_jk !dcosijk_ij + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = dfc_j*fc_k*u_ij + + descriptor_out%x(i_desc)%ii(2) = k + descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,k) + matmul(at%lattice,shift_ik) + descriptor_out%x(i_desc)%has_grad_data(2) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,2) = u_ik + descriptor_out%x(i_desc)%grad_data(2,:,2) = 2.0_dp * (r_ij - r_ik)*(-u_ik) + descriptor_out%x(i_desc)%grad_data(3,:,2) = -u_jk !dcosijk_ik + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,2) = dfc_k*fc_j*u_ik + + descriptor_out%x(i_desc)%ii(3:) = descriptor_coordination%x(i)%ii(1:) + descriptor_out%x(i_desc)%pos(:,3:) = descriptor_coordination%x(i)%pos(:,1:) + descriptor_out%x(i_desc)%has_grad_data(3:) = descriptor_coordination%x(i)%has_grad_data(1:) + descriptor_out%x(i_desc)%grad_data(4,:,3:) = descriptor_coordination%x(i)%grad_data(1,:,1:) + endif + enddo + enddo + enddo + + call finalise(my_coordination) + call finalise(descriptor_coordination) + + call system_timer('co_angle_3b_calc') + + endsubroutine co_angle_3b_calc + + subroutine co_distance_2b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(co_distance_2b), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(descriptor) :: my_coordination + type(descriptor_data) :: descriptor_coordination + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor, Zi1, Zi2, Zj1, Zj2 + integer :: d, n_descriptors, n_cross, i_desc, i, j, n, & + n_neighbours_coordination_i, n_neighbours_coordination_ij, n_index + integer, dimension(3) :: shift + real(dp) :: r_ij + real(dp), dimension(3) :: u_ij + + INIT_ERROR(error) + call system_timer('co_distance_2b_calc') + + if(.not. this%initialised) then + RAISE_ERROR("co_distance_2b_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='co_distance_2b_calc args_str')) then + RAISE_ERROR("co_distance_2b_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("co_distance_2b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("co_distance_2b_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = co_distance_2b_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + i_desc = 0 + do i = 1, at%N + + if( associated(atom_mask_pointer) ) then + if( .not. atom_mask_pointer(i) ) cycle + endif + + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij) + + if(r_ij >= this%cutoff) cycle +!if(r_ij <3.5_dp) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + i_desc = i_desc + 1 + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + endif + + if(my_do_grad_descriptor) then + n_neighbours_coordination_ij = n_neighbours(at,i,max_dist=this%coordination_cutoff) + & + n_neighbours(at,j,max_dist=this%coordination_cutoff) + 2 + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:1+n_neighbours_coordination_ij)) + allocate(descriptor_out%x(i_desc)%ii(0:1+n_neighbours_coordination_ij)) + allocate(descriptor_out%x(i_desc)%pos(3,0:1+n_neighbours_coordination_ij)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:1+n_neighbours_coordination_ij)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:1+n_neighbours_coordination_ij)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + enddo + + call initialise(my_coordination,'coordination cutoff='//this%coordination_cutoff//' transition_width='//this%coordination_transition_width,error) + call calc(my_coordination,at,descriptor_coordination,.true.,do_grad_descriptor,args_str,error) + + i_desc = 0 + do i = 1, at%N + + if( associated(atom_mask_pointer) ) then + if( .not. atom_mask_pointer(i) ) cycle + endif + + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) + if( r_ij >= this%cutoff ) cycle +!if(r_ij <3.5_dp) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + i_desc = i_desc + 1 + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1:2) = (/i,j/) + + descriptor_out%x(i_desc)%has_data = .true. + + descriptor_out%x(i_desc)%data(1) = r_ij + descriptor_out%x(i_desc)%data(2) = descriptor_coordination%x(i)%data(1) + descriptor_coordination%x(j)%data(1) + descriptor_out%x(i_desc)%data(3) = (descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))**2 + + descriptor_out%x(i_desc)%covariance_cutoff = coordination_function(r_ij, this%cutoff,this%transition_width) !coordination_function(r_ij,3.5_dp, 0.5_dp, this%cutoff,this%transition_width) + endif + if(my_do_grad_descriptor) then + n_neighbours_coordination_i = n_neighbours(at,i,max_dist=this%coordination_cutoff) + + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,0) = -u_ij(:) + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = -dcoordination_function(r_ij,this%cutoff,this%transition_width)*u_ij !-dcoordination_function(r_ij,3.5_dp, 0.5_dp, this%cutoff,this%transition_width)*u_ij + + descriptor_out%x(i_desc)%ii(1) = j + descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(1) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij(:) + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) + + descriptor_out%x(i_desc)%ii(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%ii(:) + descriptor_out%x(i_desc)%pos(:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%pos(:,:) + descriptor_out%x(i_desc)%has_grad_data(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%has_grad_data(:) + descriptor_out%x(i_desc)%grad_data(2,:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%grad_data(1,:,:) + descriptor_out%x(i_desc)%grad_data(3,:,2:n_neighbours_coordination_i+2) = 2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& + descriptor_coordination%x(i)%grad_data(1,:,:) + + descriptor_out%x(i_desc)%ii(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%ii(:) + descriptor_out%x(i_desc)%pos(:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%pos(:,:) + descriptor_out%x(i_desc)%has_grad_data(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%has_grad_data(:) + descriptor_out%x(i_desc)%grad_data(2,:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%grad_data(1,:,:) + descriptor_out%x(i_desc)%grad_data(3,:,n_neighbours_coordination_i+3:) = -2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& + descriptor_coordination%x(j)%grad_data(1,:,:) + + endif + enddo + enddo + + call finalise(my_coordination) + call finalise(descriptor_coordination) + + call system_timer('co_distance_2b_calc') + + endsubroutine co_distance_2b_calc + + subroutine cosnx_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(cosnx), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, k, n, m, a, b, i_desc, i_cosnx, l_n_neighbours, n_i, & + n_descriptors, n_cross, n_index + integer, dimension(3) :: shift_ij + real(dp) :: r_ij, r_ik, r_jk, cos_ijk, T_0_cos_ijk, T_1_cos_ijk, T_n_cos_ijk, U_0_cos_ijk, U_1_cos_ijk, U_n_cos_ijk, Ang + real(dp), dimension(3) :: u_ij, u_ik, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik, dAng_ij, dAng_ik + real(dp), dimension(:), allocatable :: Rad_ij, Rad_ik, T_cos_ijk, U_cos_ijk + real(dp), dimension(:,:), allocatable :: dRad_ij, dRad_ik + integer, dimension(total_elements) :: species_map + + INIT_ERROR(error) + + call system_timer('cosnx_calc') + + if(.not. this%initialised) then + RAISE_ERROR("cosnx_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='cosnx_calc args_str')) then + RAISE_ERROR("cosnx_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("cosnx_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + species_map = 0 + do i = 1, size(this%species_Z) + if(this%species_Z(i) == 0) then + species_map = 1 + else + species_map(this%species_Z(i)) = i + endif + enddo + + call finalise(descriptor_out) + + d = cosnx_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + allocate(Rad_ij(this%n_max), Rad_ik(this%n_max)) + allocate(T_cos_ijk(0:this%l_max)) + if(my_do_grad_descriptor) then + allocate(U_cos_ijk(-1:this%l_max)) + allocate(dRad_ij(3,this%n_max), dRad_ik(3,this%n_max)) + endif + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + + do a = 1, this%n_max + Rad_ij(a) = RadialFunction(this%Radial, r_ij, a) * this%w(species_map(at%Z(j))) + if(my_do_grad_descriptor) dRad_ij(:,a) = GradRadialFunction(this%Radial, r_ij, a) * u_ij * this%w(species_map(at%Z(j))) + enddo + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(n_i) = j + descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. + endif + + do m = 1, n_neighbours(at,i) + k = neighbour(at, i, m, distance = r_ik, cosines=u_ik, diff=d_ik) + if( r_ik >= this%cutoff ) cycle + + d_jk = d_ik - d_ij + r_jk = norm(d_jk) + if( r_jk .feq. 0.0_dp ) cycle + + cos_ijk = dot_product(u_ij,u_ik) + if(my_do_grad_descriptor) then + dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij + dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik + endif + + do a = 1, this%n_max + Rad_ik(a) = RadialFunction(this%Radial, r_ik, a) * this%w(species_map(at%Z(k))) + if(my_do_grad_descriptor) dRad_ik(:,a) = GradRadialFunction(this%Radial, r_ik, a) * u_ik * this%w(species_map(at%Z(k))) + enddo + + if(this%l_max >= 0) then + T_cos_ijk(0) = 1.0_dp + T_0_cos_ijk = T_cos_ijk(0) + if(my_do_grad_descriptor) then + U_cos_ijk(-1) = 0.0_dp + U_cos_ijk(0) = 1.0_dp + U_0_cos_ijk = U_cos_ijk(0) + endif + endif + + if(this%l_max >= 1) then + T_cos_ijk(1) = cos_ijk + T_1_cos_ijk = T_cos_ijk(1) + if(my_do_grad_descriptor) then + U_cos_ijk(1) = 2.0_dp*cos_ijk + U_1_cos_ijk = U_cos_ijk(1) + endif + endif + + do b = 2, this%l_max + T_n_cos_ijk = 2*cos_ijk*T_1_cos_ijk - T_0_cos_ijk + T_0_cos_ijk = T_1_cos_ijk + T_1_cos_ijk = T_n_cos_ijk + + T_cos_ijk(b) = T_n_cos_ijk + + if(my_do_grad_descriptor) then + U_n_cos_ijk = 2*cos_ijk*U_1_cos_ijk - U_0_cos_ijk + U_0_cos_ijk = U_1_cos_ijk + U_1_cos_ijk = U_n_cos_ijk + + U_cos_ijk(b) = U_n_cos_ijk + endif + enddo + + i_cosnx = 0 + do a = 1, this%n_max + do b = 0, this%l_max + i_cosnx = i_cosnx + 1 + + Ang = T_cos_ijk(b) + + if(my_do_descriptor) & + descriptor_out%x(i_desc)%data(i_cosnx) = descriptor_out%x(i_desc)%data(i_cosnx) + Rad_ij(a)*Rad_ik(a)*Ang*0.5_dp + + if(my_do_grad_descriptor) then + + dAng_ij = b*U_cos_ijk(b-1) * dcosijk_ij + dAng_ik = b*U_cos_ijk(b-1) * dcosijk_ik + + descriptor_out%x(i_desc)%grad_data(i_cosnx,:,0) = descriptor_out%x(i_desc)%grad_data(i_cosnx,:,0) - & + ( Rad_ij(a)*Rad_ik(a)*(dAng_ij+dAng_ik) + dRad_ij(:,a)*Rad_ik(a)*Ang + Rad_ij(a)*dRad_ik(:,a)*Ang ) * 0.5_dp + + descriptor_out%x(i_desc)%grad_data(i_cosnx,:,n_i) = descriptor_out%x(i_desc)%grad_data(i_cosnx,:,n_i) + & + (Rad_ij(a)*Rad_ik(a)*dAng_ij + dRad_ij(:,a)*Rad_ik(a)*Ang) + endif + enddo + enddo + enddo + enddo + enddo + + if(allocated(Rad_ij)) deallocate(Rad_ij) + if(allocated(Rad_ik)) deallocate(Rad_ik) + if(allocated(T_cos_ijk)) deallocate(T_cos_ijk) + if(allocated(U_cos_ijk)) deallocate(U_cos_ijk) + if(allocated(dRad_ij)) deallocate(dRad_ij) + if(allocated(dRad_ik)) deallocate(dRad_ik) + + call system_timer('cosnx_calc') + + endsubroutine cosnx_calc + + subroutine trihis_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(trihis), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, k, n, m, i_desc, n_index + integer, dimension(3) :: shift_ij + real(dp) :: r_ij, r_ik, r_jk, cos_ijk, Sym_Cor_S, Sym_Cor_A, exp_desc + real(dp), dimension(3) :: u_ij, u_ik, d_ij, d_ik, d_jk, dcosijk_ij, dcosijk_ik, x, exp_arg, dexp_desc + real(dp), dimension(3,3) :: dx_j, dx_k + + INIT_ERROR(error) + + call system_timer('trihis_calc') + + if(.not. this%initialised) then + RAISE_ERROR("trihis_calc: descriptor object not initialised", error) + endif + RAISE_ERROR("trihis_calc: ab686 noticed that this routine needs updating. Remove this line if you know what you are doing, then proceed.", error) + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='trihis_calc args_str')) then + RAISE_ERROR("trihis_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("trihis_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("trihis_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = trihis_dimensions(this,error) + + allocate(descriptor_out%x(at%N)) + do i = 1, at%N + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%has_data = .false. + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,0:n_neighbours(at,i))) + allocate(descriptor_out%x(i)%ii(0:n_neighbours(at,i))) + allocate(descriptor_out%x(i)%pos(3,0:n_neighbours(at,i))) + allocate(descriptor_out%x(i)%has_grad_data(0:n_neighbours(at,i))) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + endif + enddo + + do i = 1, at%N + + if(my_do_descriptor) then + descriptor_out%x(i)%ci(1) = i + descriptor_out%x(i)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i)%ii(0) = i + descriptor_out%x(i)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i)%has_grad_data(0) = .true. + endif + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + if(my_do_grad_descriptor) then + descriptor_out%x(i)%ii(n) = j + descriptor_out%x(i)%pos(:,n) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i)%has_grad_data(n) = .true. + endif + + do m = 1, n_neighbours(at,i) + k = neighbour(at, i, m, distance = r_ik, cosines=u_ik, diff=d_ik) + if( r_ik >= this%cutoff ) cycle + + d_jk = d_ik - d_ij + r_jk = norm(d_jk) + if( r_jk .feq. 0.0_dp ) cycle + + cos_ijk = dot_product(u_ij,u_ik) + Sym_Cor_S = r_ij + r_ik + Sym_Cor_A = (r_ij - r_ik)**2 + + x = (/Sym_Cor_S, Sym_Cor_A, cos_ijk/) + + if(my_do_grad_descriptor) then + dcosijk_ij = ( u_ik - cos_ijk * u_ij ) / r_ij + dcosijk_ik = ( u_ij - cos_ijk * u_ik ) / r_ik + + dx_j(:,1) = u_ij + dx_j(:,2) = 2.0_dp*(r_ij - r_ik)*u_ij + dx_j(:,3) = dcosijk_ij + + dx_k(:,1) = u_ik + dx_k(:,2) = -2.0_dp*(r_ij - r_ik)*u_ik + dx_k(:,3) = dcosijk_ik + endif + + do i_desc = 1, this%n_gauss + + exp_arg = (x - this%gauss_centre(:,i_desc))/this%gauss_width(:,i_desc) + exp_desc = exp(-0.5_dp*sum(exp_arg**2)) + + if(my_do_descriptor) & + descriptor_out%x(i)%data(i_desc) = descriptor_out%x(i)%data(i_desc) + exp_desc + + if(my_do_grad_descriptor) then + dexp_desc = -exp_desc * exp_arg / this%gauss_width(:,i_desc) + + descriptor_out%x(i)%grad_data(i_desc,:,0) = descriptor_out%x(i)%grad_data(i_desc,:,0) - & + matmul(dx_j+dx_k,dexp_desc) + descriptor_out%x(i)%grad_data(i_desc,:,n) = descriptor_out%x(i)%grad_data(i_desc,:,n) + & + 2.0_dp*matmul(dx_j,dexp_desc) + endif + enddo + enddo + enddo + enddo + + call system_timer('trihis_calc') + + endsubroutine trihis_calc + + subroutine water_monomer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(water_monomer), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, n_descriptors, n_cross, i, iO, iH1, iH2, n_index + integer :: i_desc, mpi_n_procs, mpi_my_proc + integer, dimension(3) :: shift_1, shift_2 + integer, dimension(:,:), allocatable :: water_monomer_index + real(dp) :: r1, r2 + real(dp), dimension(3) :: v1, v2, u1, u2 + + INIT_ERROR(error) + + call system_timer('water_monomer_calc') + + if(.not. this%initialised) then + RAISE_ERROR("water_monomer_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='water_monomer_calc args_str')) then + RAISE_ERROR("water_monomer_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("water_monomer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + d = water_monomer_dimensions(this,error) + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index, error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index, error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%has_data = .false. + descriptor_out%x(i)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,3)) + allocate(descriptor_out%x(i)%ii(3)) + allocate(descriptor_out%x(i)%pos(3,3)) + allocate(descriptor_out%x(i)%has_grad_data(3)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,3)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + allocate(water_monomer_index(3,count(at%Z==8))) + call find_water_monomer(at,water_monomer_index,error=error) + + i_desc = 0 + do i = 1, count(at%Z==8) + + iO = water_monomer_index(1,i) + iH1 = water_monomer_index(2,i) + iH2 = water_monomer_index(3,i) + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(iO)) cycle + endif + i_desc = i_desc + 1 + + v1 = diff_min_image(at,iO,iH1,shift=shift_1) + v2 = diff_min_image(at,iO,iH2,shift=shift_2) + r1 = sqrt(dot_product(v1,v1)) + r2 = sqrt(dot_product(v2,v2)) + u1 = v1 / r1 + u2 = v2 / r2 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(:) = water_monomer_index(:,i) + descriptor_out%x(i_desc)%has_data = .true. + descriptor_out%x(i_desc)%data(1) = r1+r2 + descriptor_out%x(i_desc)%data(2) = (r1-r2)**2 + descriptor_out%x(i_desc)%data(3) = dot_product(v1,v2) + endif + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(:) = water_monomer_index(:,i) + descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,iO) + descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,iH1) + matmul(at%lattice,shift_1) + descriptor_out%x(i_desc)%pos(:,3) = at%pos(:,iH2) + matmul(at%lattice,shift_2) + descriptor_out%x(i_desc)%has_grad_data(:) = .true. + + descriptor_out%x(i_desc)%grad_data(1,:,1) = -u1-u2 ! 1st descriptor wrt rO + descriptor_out%x(i_desc)%grad_data(1,:,2) = u1 ! 1st descriptor wrt rH1 + descriptor_out%x(i_desc)%grad_data(1,:,3) = u2 ! 1st descriptor wrt rH2 + descriptor_out%x(i_desc)%grad_data(2,:,1) = 2.0_dp*(r1-r2)*(u2-u1) ! 2nd descriptor wrt rO + descriptor_out%x(i_desc)%grad_data(2,:,2) = 2.0_dp*(r1-r2)*u1 ! 2nd descriptor wrt rH1 + descriptor_out%x(i_desc)%grad_data(2,:,3) = -2.0_dp*(r1-r2)*u2 ! 2nd descriptor wrt rH2 + descriptor_out%x(i_desc)%grad_data(3,:,1) = -v1-v2 ! 3rd descriptor wrt rO + descriptor_out%x(i_desc)%grad_data(3,:,2) = v2 ! 3rd descriptor wrt rH1 + descriptor_out%x(i_desc)%grad_data(3,:,3) = v1 ! 3rd descriptor wrt rH2 + endif + + enddo + + deallocate(water_monomer_index) + call system_timer('water_monomer_calc') + + endsubroutine water_monomer_calc + + subroutine water_dimer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(water_dimer), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, n_descriptors, n_cross, n_monomers, i_desc, i, j, n, & + iAO, iAH1, iAH2, iBO, iBH1, iBH2, i_distance, n_index + integer :: mpi_n_procs, mpi_my_proc + integer, dimension(3) :: shift_AO_BO, shift_AO_AH1, shift_AO_AH2, shift_AO_BH1, shift_AO_BH2, & + shift_BO_AH1, shift_BO_AH2, shift_BO_BH1, shift_BO_BH2, & + shift_AH1_AH2, shift_AH1_BH1, shift_AH1_BH2, shift_AH2_BH1, shift_AH2_BH2, shift_BH1_BH2 + real(dp), dimension(3) :: diff_AO_BO, diff_AO_AH1, diff_AO_AH2, diff_AO_BH1, diff_AO_BH2, & + diff_BO_AH1, diff_BO_AH2, diff_BO_BH1, diff_BO_BH2, & + diff_AH1_AH2, diff_AH1_BH1, diff_AH1_BH2, diff_AH2_BH1, diff_AH2_BH2, diff_BH1_BH2 + integer, dimension(:,:), allocatable :: water_monomer_index + real(dp) :: r_AO_BO, r_AO_AH1, r_AO_AH2, r_AO_BH1, r_AO_BH2, r_BO_AH1, r_BO_AH2, r_BO_BH1, r_BO_BH2, & + r_AH1_AH2, r_AH1_BH1, r_AH1_BH2, r_AH2_BH1, r_AH2_BH2, r_BH1_BH2 + integer, dimension(1) :: j_array + real(dp), dimension(15) :: distances + + INIT_ERROR(error) + + call system_timer('water_dimer_calc') + + if(.not. this%initialised) then + RAISE_ERROR("water_dimer_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='water_dimer_calc args_str')) then + RAISE_ERROR("water_dimer_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("water_dimer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + d = water_dimer_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%has_data = .false. + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,6)) + allocate(descriptor_out%x(i)%ii(6)) + allocate(descriptor_out%x(i)%pos(3,6)) + allocate(descriptor_out%x(i)%has_grad_data(6)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,6)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + + endif + enddo + + n_monomers = 0 + do i = 1, at%N + if(at%Z(i) == 8) n_monomers = n_monomers+1 + enddo + + allocate(water_monomer_index(3,n_monomers)) + call find_water_monomer(at,water_monomer_index,OHH_ordercheck=this%OHH_ordercheck,monomer_cutoff=this%monomer_cutoff,error=error) + + i_desc = 0 + do i = 1, n_monomers + iAO = water_monomer_index(1,i) + iAH1 = water_monomer_index(2,i) + iAH2 = water_monomer_index(3,i) + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(iAO)) cycle + endif + + diff_AO_AH1 = diff_min_image(at,iAO,iAH1,shift=shift_AO_AH1) + diff_AO_AH2 = diff_min_image(at,iAO,iAH2,shift=shift_AO_AH2) + diff_AH1_AH2 = diff_min_image(at,iAH1,iAH2,shift=shift_AH1_AH2) + + r_AO_AH1 = norm(diff_AO_AH1) + r_AO_AH2 = norm(diff_AO_AH2) + r_AH1_AH2 = norm(diff_AH1_AH2) + + do n = 1, n_neighbours(at,iAO) + iBO = neighbour(at,iAO,n,distance=r_AO_BO, diff=diff_AO_BO, shift=shift_AO_BO ) + if(at%Z(iBO) /= 8) cycle + if( r_AO_BO >= this%cutoff ) cycle + i_desc = i_desc + 1 + j_array = find(water_monomer_index(1,:) == iBO) + j = j_array(1) + + iBH1 = water_monomer_index(2,j) + iBH2 = water_monomer_index(3,j) + + diff_BO_BH1 = diff_min_image(at,iBO,iBH1,shift=shift_BO_BH1) + diff_BO_BH2 = diff_min_image(at,iBO,iBH2,shift=shift_BO_BH2) + diff_BH1_BH2 = diff_min_image(at,iBH1,iBH2,shift=shift_BH1_BH2) + + r_BO_BH1 = norm(diff_BO_BH1) + r_BO_BH2 = norm(diff_BO_BH2) + r_BH1_BH2 = norm(diff_BH1_BH2) + + diff_AO_BH1 = diff_AO_BO + diff_BO_BH1 + diff_AO_BH2 = diff_AO_BO + diff_BO_BH2 + shift_AO_BH1 = shift_AO_BO + shift_BO_BH1 + shift_AO_BH2 = shift_AO_BO + shift_BO_BH2 + + r_AO_BH1 = norm(diff_AO_BH1) + r_AO_BH2 = norm(diff_AO_BH2) + + diff_BO_AH1 = -diff_AO_BO + diff_AO_AH1 + diff_BO_AH2 = -diff_AO_BO + diff_AO_AH2 + + shift_BO_AH1 = -shift_AO_BO + shift_AO_AH1 + shift_BO_AH2 = -shift_AO_BO + shift_AO_AH2 + + r_BO_AH1 = norm(diff_BO_AH1) + r_BO_AH2 = norm(diff_BO_AH2) + + diff_AH1_BH1 = -diff_AO_AH1 + diff_AO_BO + diff_BO_BH1 + diff_AH1_BH2 = -diff_AO_AH1 + diff_AO_BO + diff_BO_BH2 + diff_AH2_BH1 = -diff_AO_AH2 + diff_AO_BO + diff_BO_BH1 + diff_AH2_BH2 = -diff_AO_AH2 + diff_AO_BO + diff_BO_BH2 + + shift_AH1_BH1 = -shift_AO_AH1 + shift_AO_BO + shift_BO_BH1 + shift_AH1_BH2 = -shift_AO_AH1 + shift_AO_BO + shift_BO_BH2 + shift_AH2_BH1 = -shift_AO_AH2 + shift_AO_BO + shift_BO_BH1 + shift_AH2_BH2 = -shift_AO_AH2 + shift_AO_BO + shift_BO_BH2 + + r_AH1_BH1 = norm(diff_AH1_BH1) + r_AH1_BH2 = norm(diff_AH1_BH2) + r_AH2_BH1 = norm(diff_AH2_BH1) + r_AH2_BH2 = norm(diff_AH2_BH2) + + + distances = (/r_AO_BO, & + r_AO_AH1, r_AO_AH2, r_AO_BH1, r_AO_BH2, r_BO_AH1, r_BO_AH2, r_BO_BH1, r_BO_BH2, & + r_AH1_AH2, r_AH1_BH1, r_AH1_BH2, r_AH2_BH1, r_AH2_BH2, r_BH1_BH2/) + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(:) = (/ water_monomer_index(:,i),water_monomer_index(:,j) /) + descriptor_out%x(i_desc)%has_data = .true. + descriptor_out%x(i_desc)%data(:) = (distances+this%dist_shift)**this%power + + descriptor_out%x(i_desc)%covariance_cutoff = coordination_function(r_AO_BO, & + this%cutoff,this%cutoff_transition_width) + endif + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(:) = (/ water_monomer_index(:,i),water_monomer_index(:,j) /) + descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,iAO) ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%pos(:,2) = at%pos(:,iAH1) + matmul(at%lattice,shift_AO_AH1) ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%pos(:,3) = at%pos(:,iAH2) + matmul(at%lattice,shift_AO_AH2) ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%pos(:,4) = at%pos(:,iBO) + matmul(at%lattice,shift_AO_BO) ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%pos(:,5) = at%pos(:,iBH1) + matmul(at%lattice,shift_AO_BH1) ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%pos(:,6) = at%pos(:,iBH2) + matmul(at%lattice,shift_AO_BH2) ! TODO: Have to figure out how to do this. + + descriptor_out%x(i_desc)%has_grad_data(:) = .true. + + descriptor_out%x(i_desc)%grad_data(1,:,1) = -diff_AO_BO / r_AO_BO ! 1st descriptor wrt OA + descriptor_out%x(i_desc)%grad_data(1,:,4) = -descriptor_out%x(i_desc)%grad_data(1,:,1) ! 1st descriptor wrt OB + + descriptor_out%x(i_desc)%grad_data(2,:,1) = -diff_AO_AH1 / r_AO_AH1 ! 2nd descriptor wrt OA + descriptor_out%x(i_desc)%grad_data(2,:,2) = -descriptor_out%x(i_desc)%grad_data(2,:,1) ! 2nd descriptor wrt AH1 + descriptor_out%x(i_desc)%grad_data(3,:,1) = -diff_AO_AH2 / r_AO_AH2 ! 3rd descriptor wrt OA + descriptor_out%x(i_desc)%grad_data(3,:,3) = -descriptor_out%x(i_desc)%grad_data(3,:,1) ! 3rd descriptor wrt AH2 + descriptor_out%x(i_desc)%grad_data(4,:,1) = -diff_AO_BH1 / r_AO_BH1 ! 4th descriptor wrt OA + descriptor_out%x(i_desc)%grad_data(4,:,5) = -descriptor_out%x(i_desc)%grad_data(4,:,1) ! 4th descriptor wrt BH1 + descriptor_out%x(i_desc)%grad_data(5,:,1) = -diff_AO_BH2 / r_AO_BH2 ! 5th descriptor wrt OA + descriptor_out%x(i_desc)%grad_data(5,:,6) = -descriptor_out%x(i_desc)%grad_data(5,:,1) ! 5th descriptor wrt BH2 + + descriptor_out%x(i_desc)%grad_data(6,:,4) = -diff_BO_AH1 / r_BO_AH1 ! 6th descriptor wrt OB + descriptor_out%x(i_desc)%grad_data(6,:,2) = -descriptor_out%x(i_desc)%grad_data(6,:,4) ! 6th descriptor wrt AH1 + descriptor_out%x(i_desc)%grad_data(7,:,4) = -diff_BO_AH2 / r_BO_AH2 ! 7th descriptor wrt OB + descriptor_out%x(i_desc)%grad_data(7,:,3) = -descriptor_out%x(i_desc)%grad_data(7,:,4) ! 7th descriptor wrt AH2 + descriptor_out%x(i_desc)%grad_data(8,:,4) = -diff_BO_BH1 / r_BO_BH1 ! 8th descriptor wrt OB + descriptor_out%x(i_desc)%grad_data(8,:,5) = -descriptor_out%x(i_desc)%grad_data(8,:,4) ! 8th descriptor wrt BH1 + descriptor_out%x(i_desc)%grad_data(9,:,4) = -diff_BO_BH2 / r_BO_BH2 ! 9th descriptor wrt OB + descriptor_out%x(i_desc)%grad_data(9,:,6) = -descriptor_out%x(i_desc)%grad_data(9,:,4) ! 9th descriptor wrt BH2 + + descriptor_out%x(i_desc)%grad_data(10,:,2) = -diff_AH1_AH2 / r_AH1_AH2 ! 10th descriptor wrt AH1 + descriptor_out%x(i_desc)%grad_data(10,:,3) = -descriptor_out%x(i_desc)%grad_data(10,:,2) ! 10th descriptor wrt AH2 + descriptor_out%x(i_desc)%grad_data(11,:,2) = -diff_AH1_BH1 / r_AH1_BH1 ! 11th descriptor wrt AH1 + descriptor_out%x(i_desc)%grad_data(11,:,5) = -descriptor_out%x(i_desc)%grad_data(11,:,2) ! 11th descriptor wrt BH1 + descriptor_out%x(i_desc)%grad_data(12,:,2) = -diff_AH1_BH2 / r_AH1_BH2 ! 12th descriptor wrt AH1 + descriptor_out%x(i_desc)%grad_data(12,:,6) = -descriptor_out%x(i_desc)%grad_data(12,:,2) ! 12th descriptor wrt BH2 + + descriptor_out%x(i_desc)%grad_data(13,:,3) = -diff_AH2_BH1 / r_AH2_BH1 ! 13th descriptor wrt AH2 + descriptor_out%x(i_desc)%grad_data(13,:,5) = -descriptor_out%x(i_desc)%grad_data(13,:,3) ! 13th descriptor wrt BH1 + descriptor_out%x(i_desc)%grad_data(14,:,3) = -diff_AH2_BH2 / r_AH2_BH2 ! 14th descriptor wrt AH2 + descriptor_out%x(i_desc)%grad_data(14,:,6) = -descriptor_out%x(i_desc)%grad_data(14,:,3) ! 14th descriptor wrt BH2 + + descriptor_out%x(i_desc)%grad_data(15,:,5) = -diff_BH1_BH2 / r_BH1_BH2 ! 15th descriptor wrt BH1 + descriptor_out%x(i_desc)%grad_data(15,:,6) = -descriptor_out%x(i_desc)%grad_data(15,:,5) ! 15th descriptor wrt BH2 + + do i_distance = 1, 15 + descriptor_out%x(i_desc)%grad_data(i_distance,:,:) = descriptor_out%x(i_desc)%grad_data(i_distance,:,:) * & + (distances(i_distance)+this%dist_shift)**(this%power-1.0_dp) * this%power + enddo + + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -dcoordination_function(r_AO_BO,& + this%cutoff,this%cutoff_transition_width) * diff_AO_BO / r_AO_BO + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,4) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) + endif + enddo + enddo + + deallocate(water_monomer_index) + call system_timer('water_dimer_calc') + + endsubroutine water_dimer_calc + + subroutine A2_dimer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(A2_dimer), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, n_descriptors, n_cross, n_monomers, i_desc, i, j, & + iA1, iA2, iB1, iB2, n_index + integer, dimension(3) :: shift_A1_A2, shift_A1_B1, shift_A1_B2, shift_A2_B1, shift_A2_B2, shift_B1_B2 + integer, dimension(at%N) :: A2_monomer_index + real(dp) :: r_A1_A2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2, r_B1_B2 + + INIT_ERROR(error) + + call system_timer('A2_dimer_calc') + + if(.not. this%initialised) then + RAISE_ERROR("A2_dimer_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='A2_dimer_calc args_str')) then + RAISE_ERROR("A2_dimer_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("A2_dimer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("A2_dimer_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = A2_dimer_dimensions(this,error) + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%has_data = .false. + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,4)) + allocate(descriptor_out%x(i)%ii(4)) + allocate(descriptor_out%x(i)%pos(3,4)) + allocate(descriptor_out%x(i)%has_grad_data(4)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,4)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + n_monomers = count(at%Z == this%atomic_number) / 2 + + call find_A2_monomer(at,this%atomic_number, this%monomer_cutoff, A2_monomer_index,error) + + i_desc = 0 + do i = 1, at%N + iA1 = i + iA2 = neighbour(at,i,A2_monomer_index(i),distance=r_A1_A2,shift=shift_A1_A2) + if( iA1 > iA2 ) cycle + + do j = i + 1, at%N + iB1 = j + iB2 = neighbour(at,j,A2_monomer_index(j),distance=r_B1_B2,shift=shift_B1_B2) + if( iB1 > iB2 ) cycle + + r_A1_B1 = distance_min_image(at,iA1,iB1,shift=shift_A1_B1) + r_A1_B2 = distance_min_image(at,iA1,iB2,shift=shift_A1_B2) + + r_A2_B1 = distance_min_image(at,iA2,iB1,shift=shift_A2_B1) + r_A2_B2 = distance_min_image(at,iA2,iB2,shift=shift_A2_B2) + + if( any( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) >= this%cutoff) ) cycle + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(:) = (/ iA1, iA2, iB1, iB2 /) + descriptor_out%x(i_desc)%has_data = .true. + descriptor_out%x(i_desc)%data(:) = (/ r_A1_A2, r_B1_B2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2/) + endif + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(:) = (/ iA1, iA2, iB1, iB2 /) + descriptor_out%x(i_desc)%pos(:,:) = 0.0_dp ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%has_grad_data(:) = .true. + + descriptor_out%x(i_desc)%grad_data(1,:,1) = -diff(at,iA1,iA2,shift=shift_A1_A2) / r_A1_A2 ! 1st descriptor wrt A1 + descriptor_out%x(i_desc)%grad_data(1,:,2) = -descriptor_out%x(i_desc)%grad_data(1,:,1) ! 1st descriptor wrt A2 + descriptor_out%x(i_desc)%grad_data(2,:,3) = -diff(at,iB1,iB2,shift=shift_B1_B2) / r_B1_B2 ! 2nd descriptor wrt B1 + descriptor_out%x(i_desc)%grad_data(2,:,4) = -descriptor_out%x(i_desc)%grad_data(2,:,3) ! 2nd descriptor wrt B2 + + descriptor_out%x(i_desc)%grad_data(3,:,1) = -diff(at,iA1,iB1,shift=shift_A1_B1) / r_A1_B1 ! 3rd descriptor wrt A1 + descriptor_out%x(i_desc)%grad_data(3,:,3) = -descriptor_out%x(i_desc)%grad_data(3,:,1) ! 3rd descriptor wrt B1 + descriptor_out%x(i_desc)%grad_data(4,:,1) = -diff(at,iA1,iB2,shift=shift_A1_B2) / r_A1_B2 ! 4th descriptor wrt A1 + descriptor_out%x(i_desc)%grad_data(4,:,4) = -descriptor_out%x(i_desc)%grad_data(4,:,1) ! 4th descriptor wrt B2 + + descriptor_out%x(i_desc)%grad_data(5,:,2) = -diff(at,iA2,iB1,shift=shift_A2_B1) / r_A2_B1 ! 5th descriptor wrt A2 + descriptor_out%x(i_desc)%grad_data(5,:,3) = -descriptor_out%x(i_desc)%grad_data(5,:,2) ! 5th descriptor wrt B1 + descriptor_out%x(i_desc)%grad_data(6,:,2) = -diff(at,iA2,iB2,shift=shift_A2_B2) / r_A2_B2 ! 6th descriptor wrt A2 + descriptor_out%x(i_desc)%grad_data(6,:,4) = -descriptor_out%x(i_desc)%grad_data(6,:,2) ! 6th descriptor wrt B2 + + endif + enddo + enddo + + call system_timer('A2_dimer_calc') + + endsubroutine A2_dimer_calc + + subroutine AB_dimer_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(AB_dimer), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, n_descriptors, n_cross, n_monomers, i_desc, i, j, & + iA1, iA2, iB1, iB2, n_index + integer, dimension(3) :: shift_A1_A2, shift_A1_B1, shift_A1_B2, shift_A2_B1, shift_A2_B2, shift_B1_B2 + integer, dimension(:,:), allocatable :: AB_monomer_index + real(dp) :: r_A1_A2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2, r_B1_B2 + + INIT_ERROR(error) + + call system_timer('AB_dimer_calc') + + if(.not. this%initialised) then + RAISE_ERROR("AB_dimer_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='AB_dimer_calc args_str')) then + RAISE_ERROR("AB_dimer_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("AB_dimer_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("AB_dimer_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = AB_dimer_dimensions(this,error) + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%has_data = .false. + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,4)) + allocate(descriptor_out%x(i)%ii(4)) + allocate(descriptor_out%x(i)%pos(3,4)) + allocate(descriptor_out%x(i)%has_grad_data(4)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,4)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + if( count(at%Z == this%atomic_number1) == count(at%Z == this%atomic_number2) ) then + n_monomers = count(at%Z == this%atomic_number1) + else + RAISE_ERROR("AB_dimer_calc: number of monomer atoms 1 ("//count(at%Z == this%atomic_number1)//") not equal to number of monomer atoms 2 ("//count(at%Z == this%atomic_number1)//")",error) + endif + + allocate(AB_monomer_index(2,n_monomers)) + call find_AB_monomer(at,(/this%atomic_number1,this%atomic_number2/), this%monomer_cutoff, AB_monomer_index,error) + + i_desc = 0 + do i = 1, n_monomers + iA1 = AB_monomer_index(1,i) + iB1 = AB_monomer_index(2,i) + do j = i + 1, n_monomers + iA2 = AB_monomer_index(1,j) + iB2 = AB_monomer_index(2,j) + + + r_A1_B1 = distance_min_image(at,iA1,iB1,shift=shift_A1_B1) + r_A2_B2 = distance_min_image(at,iA2,iB2,shift=shift_A2_B2) + + r_A1_A2 = distance_min_image(at,iA1,iA2,shift=shift_A1_A2) + r_B1_B2 = distance_min_image(at,iB1,iB2,shift=shift_B1_B2) + + r_A1_B2 = distance_min_image(at,iA1,iB2,shift=shift_A1_B2) + r_A2_B1 = distance_min_image(at,iA2,iB1,shift=shift_A2_B1) + + if( any( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) >= this%cutoff) ) cycle + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(:) = (/ AB_monomer_index(:,i),AB_monomer_index(:,j) /) + descriptor_out%x(i_desc)%has_data = .true. + descriptor_out%x(i_desc)%data(:) = (/ r_A1_B1, r_A2_B2, r_A1_A2, r_B1_B2, r_A1_B2, r_A2_B1 /) + endif + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(:) = (/ AB_monomer_index(:,i),AB_monomer_index(:,j) /) + descriptor_out%x(i_desc)%pos(:,:) = 0.0_dp ! TODO: Have to figure out how to do this. + descriptor_out%x(i_desc)%has_grad_data(:) = .true. + + descriptor_out%x(i_desc)%grad_data(1,:,1) = -diff(at,iA1,iB1,shift=shift_A1_B1) / r_A1_B1 ! 1st descriptor wrt A1 + descriptor_out%x(i_desc)%grad_data(1,:,2) = -descriptor_out%x(i_desc)%grad_data(1,:,1) ! 1st descriptor wrt B1 + descriptor_out%x(i_desc)%grad_data(2,:,3) = -diff(at,iA2,iB2,shift=shift_A2_B2) / r_A2_B2 ! 2nd descriptor wrt A2 + descriptor_out%x(i_desc)%grad_data(2,:,4) = -descriptor_out%x(i_desc)%grad_data(2,:,3) ! 2nd descriptor wrt B2 + + descriptor_out%x(i_desc)%grad_data(3,:,1) = -diff(at,iA1,iA2,shift=shift_A1_A2) / r_A1_A2 ! 1st descriptor wrt A1 + descriptor_out%x(i_desc)%grad_data(3,:,3) = -descriptor_out%x(i_desc)%grad_data(3,:,1) ! 1st descriptor wrt A2 + descriptor_out%x(i_desc)%grad_data(4,:,2) = -diff(at,iB1,iB2,shift=shift_B1_B2) / r_B1_B2 ! 2nd descriptor wrt B1 + descriptor_out%x(i_desc)%grad_data(4,:,4) = -descriptor_out%x(i_desc)%grad_data(4,:,2) ! 2nd descriptor wrt B2 + + descriptor_out%x(i_desc)%grad_data(5,:,1) = -diff(at,iA1,iB2,shift=shift_A1_B2) / r_A1_B2 ! 4th descriptor wrt A1 + descriptor_out%x(i_desc)%grad_data(5,:,4) = -descriptor_out%x(i_desc)%grad_data(5,:,1) ! 4th descriptor wrt B2 + descriptor_out%x(i_desc)%grad_data(6,:,3) = -diff(at,iA2,iB1,shift=shift_A2_B1) / r_A2_B1 ! 5th descriptor wrt A2 + descriptor_out%x(i_desc)%grad_data(6,:,2) = -descriptor_out%x(i_desc)%grad_data(6,:,3) ! 5th descriptor wrt B1 + + endif + enddo + enddo + + deallocate(AB_monomer_index) + call system_timer('AB_dimer_calc') + + endsubroutine AB_dimer_calc + + + subroutine atom_real_space_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(atom_real_space), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, grad_d, n_descriptors, n_cross, descriptor_mould_size, & + i_desc, i_data, i, j, k, n, l, m, l_n_neighbours, i_n, n_index + + real(dp) :: r + real(dp), dimension(3) :: diff + real(dp), dimension(1) :: descriptor_mould + integer, dimension(3) :: shift + + complex(dp), dimension(:), allocatable :: spherical_harmonics + complex(dp), dimension(:,:), allocatable :: grad_spherical_harmonics + + INIT_ERROR(error) + + call system_timer('atom_real_space_calc') + + if(.not. this%initialised) then + RAISE_ERROR("atom_real_space_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='atom_real_space_calc args_str')) then + RAISE_ERROR("atom_real_space_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("atom_real_space_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("atom_real_space_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + + allocate(descriptor_out%x(n_descriptors)) + + i_desc = 0 + do i = 1, at%N + i_desc = i_desc + 1 + + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + d = ( 2 * (this%l_max+1)**2 + 2 ) * l_n_neighbours + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + grad_d = 2 * (this%l_max+1)**2 + 2 + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,1:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(1:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,1:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(1:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,1:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + allocate(spherical_harmonics(-this%l_max:this%l_max)) + if( my_do_grad_descriptor ) allocate(grad_spherical_harmonics(3,-this%l_max:this%l_max)) + + i_desc = 0 + do i = 1, at%N + i_desc = i_desc + 1 + i_data = 0 + i_n = 0 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + + if(my_do_grad_descriptor) then + !descriptor_out%x(i_desc)%ii(0) = i + !descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + !descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + do n = 1, n_neighbours(at,i) + + j = neighbour(at,i,n,distance = r, diff = diff, shift=shift) + if(r >= this%cutoff) cycle + i_n = i_n + 1 + + i_data = i_data + 1 + if(my_do_descriptor) then + descriptor_out%x(i_desc)%data(i_data) = r + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(i_n) = j + descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. + descriptor_out%x(i_desc)%grad_data(i_data,:,i_n) = diff / r + endif + + i_data = i_data + 1 + if(my_do_descriptor) descriptor_out%x(i_desc)%data(i_data) = real(i_n,dp) + if(my_do_grad_descriptor) descriptor_out%x(i_desc)%grad_data(i_data,:,i_n) = real(i_n,dp) + + do l = 0, this%l_max + descriptor_mould_size = size(transfer(spherical_harmonics(-l:l),descriptor_mould)) + + do m = -l, l + if(my_do_descriptor) spherical_harmonics(m) = SphericalYCartesian(l,m,diff) + if(my_do_grad_descriptor) grad_spherical_harmonics(:,m) = GradSphericalYCartesian(l,m,diff) + enddo + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%data(i_data+1:i_data+descriptor_mould_size) = transfer(spherical_harmonics(-l:l),descriptor_mould) + endif + + if(my_do_grad_descriptor) then + do k = 1, 3 + descriptor_out%x(i_desc)%grad_data(i_data+1:i_data+descriptor_mould_size,k,i_n) = & + transfer(grad_spherical_harmonics(k,-l:l),descriptor_mould) + enddo + endif + + i_data = i_data + descriptor_mould_size + + enddo + enddo + enddo + + if(allocated(spherical_harmonics)) deallocate(spherical_harmonics) + if(allocated(grad_spherical_harmonics)) deallocate(grad_spherical_harmonics) + + call system_timer('atom_real_space_calc') + + endsubroutine atom_real_space_calc + + subroutine power_so3_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(power_so3), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + type(cplx_1d), dimension(:), allocatable :: SphericalY_ij + type(cplx_1d), dimension(:,:), allocatable :: fourier_so3 + + type(cplx_2d), dimension(:), allocatable :: dSphericalY_ij + type(cplx_2d), dimension(:,:,:), allocatable :: dfourier_so3 + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, n, a, l, m, i_desc, i_pow, l_n_neighbours, n_i, & + n_descriptors, n_cross, n_index + integer, dimension(3) :: shift_ij + real(dp) :: r_ij + real(dp), dimension(3) :: u_ij, d_ij + real(dp), dimension(:), allocatable :: Rad_ij + real(dp), dimension(:,:), allocatable :: dRad_ij + integer, dimension(total_elements) :: species_map + + INIT_ERROR(error) + + call system_timer('power_so3_calc') + + if(.not. this%initialised) then + RAISE_ERROR("power_so3_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='power_so3_calc args_str')) then + RAISE_ERROR("power_so3_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("power_so3_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + species_map = 0 + do i = 1, size(this%species_Z) + if(this%species_Z(i) == 0) then + species_map = 1 + else + species_map(this%species_Z(i)) = i + endif + enddo + + call finalise(descriptor_out) + + d = power_so3_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross,& + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + descriptor_out%x(i_desc)%has_data = .false. + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + allocate(fourier_so3(0:this%l_max,this%n_max),SphericalY_ij(0:this%l_max),Rad_ij(this%n_max)) + do a = 1, this%n_max + do l = 0, this%l_max + allocate(fourier_so3(l,a)%m(-l:l)) + fourier_so3(l,a)%m(:) = CPLX_ZERO + enddo + enddo + do l = 0, this%l_max + allocate(SphericalY_ij(l)%m(-l:l)) + enddo + + if(my_do_grad_descriptor) then + allocate( dRad_ij(3,this%n_max), dSphericalY_ij(0:this%l_max) ) + do l = 0, this%l_max + allocate(dSphericalY_ij(l)%mm(3,-l:l)) + enddo + endif + + i_desc = 0 + do i = 1, at%N + + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + do a = 1, this%n_max + do l = 0, this%l_max + fourier_so3(l,a)%m(:) = CPLX_ZERO + enddo + enddo + + if(my_do_grad_descriptor) then + allocate( dfourier_so3(0:this%l_max,this%n_max,0:n_neighbours(at,i,max_dist=this%cutoff)) ) + do n = 0, n_neighbours(at,i,max_dist=this%cutoff) + do a = 1, this%n_max + do l = 0, this%l_max + allocate(dfourier_so3(l,a,n)%mm(3,-l:l)) + dfourier_so3(l,a,n)%mm(:,:) = CPLX_ZERO + enddo + enddo + enddo + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(n_i) = j + descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. + endif + + do a = 1, this%n_max + Rad_ij(a) = RadialFunction(this%Radial, r_ij, a) + if(my_do_grad_descriptor) dRad_ij(:,a) = GradRadialFunction(this%Radial, r_ij, a) * u_ij + enddo + + do l = 0, this%l_max + do m = -l, l + SphericalY_ij(l)%m(m) = SphericalYCartesian(l,m,d_ij) + if(my_do_grad_descriptor) dSphericalY_ij(l)%mm(:,m) = GradSphericalYCartesian(l,m,d_ij) + enddo + enddo + + do a = 1, this%n_max + do l = 0, this%l_max + do m = -l, l + fourier_so3(l,a)%m(m) = fourier_so3(l,a)%m(m) + Rad_ij(a)*SphericalY_ij(l)%m(m) + if(my_do_grad_descriptor) then + dfourier_so3(l,a,n_i)%mm(:,m) = dfourier_so3(l,a,n_i)%mm(:,m) + & + dRad_ij(:,a) * SphericalY_ij(l)%m(m) + Rad_ij(a)*dSphericalY_ij(l)%mm(:,m) + endif + enddo + enddo + enddo + + enddo ! n + + if(my_do_descriptor) then + i_pow = 0 + do a = 1, this%n_max + do l = 0, this%l_max + i_pow = i_pow + 1 + + descriptor_out%x(i_desc)%data(i_pow) = dot_product(fourier_so3(l,a)%m,fourier_so3(l,a)%m) + enddo + enddo + endif + + if(my_do_grad_descriptor) then + do n = 1, n_neighbours(at,i,max_dist=this%cutoff) + i_pow = 0 + do a = 1, this%n_max + do l = 0, this%l_max + i_pow = i_pow + 1 + + descriptor_out%x(i_desc)%grad_data(i_pow,:,n) = 2.0_dp * matmul(conjg(dfourier_so3(l,a,n)%mm(:,:)),fourier_so3(l,a)%m(:)) + enddo + enddo + descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,n) + enddo + endif + + if(allocated(dfourier_so3)) then + do n = lbound(dfourier_so3,3), ubound(dfourier_so3,3) + do a = lbound(dfourier_so3,2), ubound(dfourier_so3,2) + do l = lbound(dfourier_so3,1), ubound(dfourier_so3,1) + deallocate(dfourier_so3(l,a,n)%mm) + enddo + enddo + enddo + deallocate(dfourier_so3) + endif + + enddo ! i + + if(allocated(Rad_ij)) deallocate(Rad_ij) + if(allocated(dRad_ij)) deallocate(dRad_ij) + + if(allocated(fourier_so3)) then + do a = lbound(fourier_so3,2), ubound(fourier_so3,2) + do l = lbound(fourier_so3,1), ubound(fourier_so3,1) + deallocate(fourier_so3(l,a)%m) + enddo + enddo + deallocate(fourier_so3) + endif + + if(allocated(SphericalY_ij)) then + do l = lbound(SphericalY_ij,1), ubound(SphericalY_ij,1) + deallocate(SphericalY_ij(l)%m) + enddo + deallocate(SphericalY_ij) + endif + + if(allocated(dSphericalY_ij)) then + do l = lbound(dSphericalY_ij,1), ubound(dSphericalY_ij,1) + deallocate(dSphericalY_ij(l)%mm) + enddo + deallocate(dSphericalY_ij) + endif + + call system_timer('power_so3_calc') + + endsubroutine power_so3_calc + + subroutine power_SO4_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(power_SO4), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(cplx_2d), dimension(:), allocatable :: U + type(cplx_3d), dimension(:,:), allocatable :: dU + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + real(dp), dimension(3) :: diff, u_ij + real(dp) :: r + integer :: i, n, n_i, ji, jn, k, j, i_desc, i_bisp, d, & + n_descriptors, n_cross, l_n_neighbours, n_index + integer, dimension(3) :: shift + integer, dimension(total_elements) :: species_map + logical :: my_do_descriptor, my_do_grad_descriptor + + INIT_ERROR(error) + + call system_timer('power_SO4_calc') + + if(.not. this%initialised) then + RAISE_ERROR("power_SO4_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + species_map = 0 + do i = 1, size(this%species_Z) + if(this%species_Z(i) == 0) then + species_map = 1 + else + species_map(this%species_Z(i)) = i + endif + enddo + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='power_SO4_calc args_str')) then + RAISE_ERROR("power_SO4_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("power_SO4_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("power_SO4_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = power_SO4_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + + i_desc = i_desc + 1 + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + descriptor_out%x(i_desc)%has_data = .false. + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + + enddo + + i_desc = 0 + do i = 1, at%N + + if( associated(atom_mask_pointer) ) then + if( .not. atom_mask_pointer(i) ) cycle + endif + + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + ji = neighbour(at, i, n, jn=jn, distance=r, diff=diff, cosines=u_ij,shift=shift) + if( r >= this%cutoff ) cycle + + n_i = n_i + 1 + + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(n_i) = ji + descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,ji) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. + endif + enddo + + if(my_do_grad_descriptor) then + call fourier_SO4_calc(this%fourier_SO4,at,i,U,dU,args_str,error=error) + else + call fourier_SO4_calc(this%fourier_SO4,at,i,U,args_str=args_str,error=error) + endif + + if(my_do_descriptor) then + + i_bisp = 0 + do j = 0, this%j_max + i_bisp = i_bisp + 1 + descriptor_out%x(i_desc)%data(i_bisp) = sum( conjg(U(j)%mm)*U(j)%mm ) + enddo + endif + + if(my_do_grad_descriptor) then + n_i = 0 + do n = 1, n_neighbours(at,i) + ji = neighbour(at, i, n, distance=r) + if( r >= this%cutoff ) cycle + n_i = n_i + 1 + i_bisp = 0 + do j = 0, this%j_max + i_bisp = i_bisp + 1 + do k = 1, 3 + descriptor_out%x(i_desc)%grad_data(i_bisp,k,n_i) = 2.0_dp * sum( conjg(U(j)%mm)*dU(j,n_i)%mm(k,:,:) ) + enddo + enddo + enddo + descriptor_out%x(i_desc)%grad_data(:,:,0) = -sum(descriptor_out%x(i_desc)%grad_data(:,:,:), dim=3) + endif + + call finalise(dU) + enddo ! i + + ! clear U from the memory + call finalise(U) + + call system_timer('power_SO4_calc') + + endsubroutine power_SO4_calc + + subroutine form_coupling_inds(this, K1, coupling_inds, sym_facs, error) + !forms coupling inds + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + integer, intent(in) :: K1 + + integer :: i, d, a, b, k, ik, ub, i_species, j_species + integer, dimension(:, :), allocatable :: coupling_inds + real, dimension(:), allocatable :: sym_facs + + !Z_mixing only + if (this%Z_mix .and. (.not. this%R_mix)) then + if (this%sym_mix) then + d = this%K * (this%n_max*(this%n_max+1))/2 + else + d = this%K* this%n_max**2 + endif + allocate(coupling_inds(d, 2)) + allocate(sym_facs(d)) + i = 1 + do k = 1, this%K + ik = (k-1) * this%n_max + do a = 1, this%n_max + ub = this%n_max + if (this%sym_mix) ub = a + do b = 1, ub + coupling_inds(i,:) = (/ik+a, ik+b /) + if (a /= b .and. this%sym_mix) then + sym_facs(i) = SQRT_TWO + else + sym_facs(i) = 1.0 + endif + i = i + 1 + enddo + enddo + enddo + + !radial mixing only + elseif (this%R_mix .and. (.not. this%Z_mix)) then + if (this%sym_mix) then + d = this%K * (this%n_species*(this%n_species+1))/2 + else + d = this%K * this%n_species**2 + endif + allocate(coupling_inds(d, 2)) + allocate(sym_facs(d)) + i = 1 + + do i_species = 1, this%n_species + ub = this%n_species + if (this%sym_mix) ub = i_species + do j_species = 1, ub + do k = 1, this%K + coupling_inds(i,:) = (/(i_species-1)*this%K + k, (j_species-1)*this%K + k/) + if (i_species /= j_species .and. this%sym_mix) then + sym_facs(i) = SQRT_TWO + else + sym_facs(i) = 1.0 + endif + i = i + 1 + enddo + enddo + enddo + + !everything else aka default is elementwise coupling only + else + allocate(coupling_inds(K1, 2)) + allocate(sym_facs(K1)) + do i = 1, K1 + coupling_inds(i,:) = (/i, i/) + sym_facs(i) = 1.0 + enddo + endif + + endsubroutine form_coupling_inds + + + subroutine form_nu_W(this, W, sym_desc, error) + !replacement for the old rs_index + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + integer :: K, nu_R, nu_S, i, dn, ds, ir, ic, n, s, s2, n2, n2_max, s2_max + type(real_2d), dimension(:), allocatable :: W + logical :: sym_desc + + INIT_ERROR(error) + + if (( this%nu_R > 2) .OR. (this%nu_R < 0)) then + RAISE_ERROR("nu_R outside allowed range of 0-2", error) + endif + + if (( this%nu_S > 2) .OR. (this%nu_S < 0)) then + RAISE_ERROR("nu_S outside allowed range of 0-2", error) + endif + + ! decide if the l-slices are symmetric matricies + if ((this%nu_R == 1) .OR. (this%nu_S == 1)) then + sym_desc = .false. + else + sym_desc = .true. + endif + allocate(W(2)) + + ! construct W(i) as required + nu_R = this%nu_R + nu_S = this%nu_S + do i = 1,2 + ! determine size of W(i) and allocate + K = 1 + ds = 0 + dn = 0 + n2_max = 1 + s2_max = 1 + + if (nu_R > 0) then + K = K * this%n_max + nu_R = nu_R -1 + dn = 1 + n2_max = this%n_max + endif + if (nu_S > 0) then + K = K * this%n_species + nu_S = nu_S -1 + ds = 1 + s2_max = this%n_species + endif + allocate(W(i)%mm(this%n_max * this%n_species, K)) + W(i)%mm(:,:) = 0.0_dp + + !loop over S and N, populating W. 4 Loops but just looping over rows and columns of matrix + ir = 0 + do s = 1, this%n_species + do n = 1, this%n_max + ir = ir + 1 ! row index in W + + ic = 0 + do s2 = 1, s2_max + do n2 = 1, n2_max + ic = ic + 1 + if (ds*s == ds*s2 .and. dn*n == dn*n2) then + !ic = 1 + (s2-1)*ds*n2_max + (n2-1)*dn + W(i)%mm(ir, ic) = 1.0_dp + endif + enddo + enddo + enddo + enddo + + enddo + endsubroutine form_nu_W + + subroutine form_mix_W(this, W, sym_desc, error) + !replacement for the old rs_index + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + type(real_2d), dimension(:), allocatable :: W + logical :: sym_desc + integer :: ik, in, is, ic, ir, j, r_r, r_c + real(dp), dimension(:,:), allocatable :: R + integer :: orig_seed + + !store the original random seed and reset it to this at the end + orig_seed = system_get_random_seed() + sym_desc = this%sym_mix + + INIT_ERROR(error) + + !full Z and R mixing + allocate(W(2)) + if (this%R_mix .and. this%Z_mix) then + do j = 1, 2 + allocate(W(j)%mm(this%n_species*this%n_max, this%K)) + if (this%sym_mix .and. j == 2) then + W(2)%mm = W(1)%mm + else + do is = 1, this%n_species + !seed = this%species_Z(is) + call system_reseed_rng(this%species_Z(is)+this%mix_shift+j*200) + ir = (is-1)*this%n_max + !call random_number(W(j)%mm(ir+1:ir+this%n_max, :)) + do r_r = ir+1, ir+this%n_max + do r_c = 1, this%K + W(j)%mm(r_r, r_c) = ran_normal() + enddo + enddo + + enddo + endif + enddo + + !mix elements only + elseif (this%Z_mix) then + do j = 1, 2 + allocate(W(j)%mm(this%n_species*this%n_max, this%K*this%n_max)) + W(j)%mm = 0.0_dp + if (this%sym_mix .and. j == 2) then + W(2)%mm = W(1)%mm + else + allocate(R(this%n_species, this%K)) + do is = 1, this%n_species + !call random_number(R(is,:)) + call system_reseed_rng(this%species_Z(is)+this%mix_shift+j*200) + do r_c = 1, this%K + R(is, r_c) = ran_normal() + enddo + enddo + + ir = 0 + do is = 1, this%n_species + do in = 1, this%n_max + ir = ir + 1 + do ik = 1, this%k + ic = (ik-1)*this%n_max + in + W(j)%mm(ir, ic) = R(is, ik) + enddo + enddo + enddo + deallocate(R) + endif + enddo + + !mix radial channels only + elseif (this%R_mix) then + do j = 1, 2 + allocate(W(j)%mm(this%n_species*this%n_max, this%K*this%n_species)) + W(j)%mm = 0.0_dp + if (this%sym_mix .and. j == 2) then + W(2)%mm = W(1)%mm + else + allocate(R(this%n_max, this%K)) + !call random_number(R) + call system_reseed_rng(this%n_max+this%mix_shift+j*200) + do r_r = 1, this%n_max + do r_c = 1, this%K + R(r_r, r_c) = ran_normal() + enddo + enddo + + ir = 0 + do is = 1, this%n_species + do in = 1, this%n_max + ir = ir + 1 + do ik = 1, this%K + ic = (is-1)*this%K + ik + W(j)%mm(ir, ic) = R(in, ik) + enddo + enddo + enddo + deallocate(R) + endif + enddo + + else + RAISE_ERROR("form_mix_W: not mixing anything", error) + endif + + !reset the system random seed + call system_reseed_rng(orig_seed) + + endsubroutine form_mix_W + + + subroutine form_Zmap_W(this, W, sym_desc, error) + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + logical :: sym_desc + character :: let + integer :: i, a, i_species, i_row, i_col + integer :: i_s, i_group, i_density, Z + integer :: n_groups(2), Ks(2) + type(real_2d), dimension(:), allocatable :: W + + !set how many groups there are + n_groups = 1 + i_density = 1 + do i = 1, len(this%Z_map_str) + let = this%Z_map_str(i:i) + if (let == ",") n_groups(i_density) = n_groups(i_density) + 1 + if (let == ":") i_density = i_density + 1 + enddo + !print*, "n_groups= ", n_groups + + !allocate W with the correct size + allocate(W(2)) + Ks(1) = this%n_max*n_groups(1) + if (i_density==2) then + sym_desc=.false. + Ks(2) = this%n_max*n_groups(2) + else + sym_desc=.true. + Ks(2) = this%n_max*n_groups(1) + endif + + do i_density = 1, 2 + allocate( W(i_density)%mm(this%n_max*this%n_species, Ks(i_density)) ) + W(i_density)%mm = 0.0_dp + enddo + !print*, "Ks are=", Ks + + !loop over the string populating W + i_s = 0 + i_group = 1 + i_density = 1 + do i = 1, len(this%Z_map_str) + let = this%Z_map_str(i:i) + + !any number + if (SCAN(let, "1234567890") > 0 .and. i_s == 0) then + i_s = i + endif + + !anything but a number + if (SCAN(let, "{} ,:") > 0 .and. i_s > 0 ) then + !Z -> i_species + read(this%Z_map_str(i_s:i-1), *) Z + i_species = 0 + do i_s = 1, this%n_species + if (this%species_Z(i_s) == Z) i_species = i_s + enddo + i_s = 0 + !print*, "Z is", Z, "i_group is", i_group, "i_density is", i_density, "i_species is", i_species + + !now populate the correct bit in W + do a = 1, this%n_max + i_row = (i_species-1)*this%n_max + a + i_col = (i_group-1)*this%n_max + a + !print*, "i_species=", i_species, 'this%n_max=', this%n_max, "a=", a, "i_row=", i_row + W(i_density)%mm(i_row, i_col) = 1.0_dp + enddo + endif + + !increment group and density + if (SCAN(let, ",") > 0) i_group = i_group + 1 + if (SCAN(let, ":") > 0) then + i_density = i_density + 1 + i_group = 1 + endif + + enddo + + if (sym_desc) W(2)%mm = W(1)%mm + endsubroutine form_Zmap_W + + subroutine form_W(this, W, sym_desc, error) + !replacement for the old rs_index + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + type(real_2d), dimension(:), allocatable :: W + logical :: sym_desc, using_Zmap, mixing + integer :: n + + INIT_ERROR(error) + + !print*, "Zmap_str is", trim(this%Z_map_str) + n = len(trim(this%Z_map_str)) + if (len(trim(this%Z_map_str)) > 0 ) then + using_Zmap = .true. + else + using_Zmap = .false. + endif + + + if(.not. this%initialised) then + RAISE_ERROR("form_W: descriptor object not initialised", error) + endif + + if ((this%nu_R /= 2 .OR. this%nu_R /= 2) .and. (this%R_mix .or. this%Z_mix .or. this%sym_mix)) then + RAISE_ERROR("(nu_R, nu_S) = (2,2) required to use channel mixing", error) + endif + + if ((this%nu_R /= 2 .OR. this%nu_R /= 2) .and. (this%diagonal_radial)) then + RAISE_ERROR("(nu_R, nu_S) = (2,2) required to use diagonal radial", error) + endif + + if ((this%nu_R /= 2 .OR. this%nu_R /= 2) .and. (using_Zmap)) then + RAISE_ERROR("(nu_R, nu_S) = (2,2) required to use Zmap", error) + endif + + if ((this%R_mix .or. this%Z_mix .or. this%sym_mix) .and. using_Zmap) then + RAISE_ERROR("cant' using mixing and Zmap at the same time", error) + endif + + !call the correct + if (this%R_mix .or. this%Z_mix .or. this%sym_mix) then + call form_mix_W(this, W, sym_desc, error) + elseif (using_Zmap) then + call form_Zmap_W(this, W, sym_desc, error) + else + call form_nu_W(this, W, sym_desc, error) + endif + + ! Printing these is useful for debugging and was used to check the mixing is working correctly + ! print*, "W(1) is", W(1)%mm + ! print*, "W(2) is", W(2)%mm + ! print*, "sym_desc is", sym_desc + endsubroutine form_W + + + ! main branch currently ~1000 lines long, would be nice not to blow this up + subroutine soap_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + + type real_2d_array + type(real_2d), dimension(:,:,:), allocatable :: x + endtype real_2d_array + + type real_2d_2d + type(real_2d), dimension(:,:), allocatable :: x + endtype real_2d_2d + + type(soap), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + type(cplx_1d), dimension(:), allocatable OMP_SAVE :: SphericalY_ij + type(cplx_2d), dimension(:), allocatable OMP_SAVE :: grad_SphericalY_ij + + !SPEED type(cplx_1d), dimension(:,:,:), allocatable :: fourier_so3 + !SPEED type(cplx_2d), dimension(:,:,:), allocatable :: grad_fourier_so3 + type(real_1d), dimension(:,:,:), allocatable OMP_SAVE :: fourier_so3_r, fourier_so3_i, global_fourier_so3_r, global_fourier_so3_i + type(real_2d), dimension(:,:,:), allocatable OMP_SAVE :: grad_fourier_so3_r, grad_fourier_so3_i + real(dp), allocatable :: t_g_r(:,:), t_g_i(:,:), t_f_r(:,:), t_f_i(:,:), t_g_f_rr(:,:), t_g_f_ii(:,:) + integer :: alpha + + logical :: my_do_descriptor, my_do_grad_descriptor, do_two_l_plus_one, sym_desc + integer :: d, i, j, n, a, b, k, l, m, i_pow, i_coeff, l_n_neighbours, n_i, & + n_descriptors, n_cross, i_species, j_species, ia, jb, i_desc_i, & + xml_version, sum_l_n_neighbours, i_pair, i_pair_i, n_index, ub + integer, dimension(3) :: shift_ij + integer, dimension(:), allocatable :: i_desc + integer, dimension(:,:), allocatable :: rs_index + real(dp) :: r_ij, arg_bess, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm, mo_spher_bess_fi_ki_lp, & + exp_p, exp_m, f_cut, df_cut, norm_descriptor_i, radial_decay, dradial_decay, norm_radial_decay + real(dp), dimension(3) :: u_ij, d_ij + real(dp), dimension(:,:), allocatable OMP_SAVE :: radial_fun, radial_coefficient, grad_radial_fun, grad_radial_coefficient, grad_descriptor_i + real(dp), dimension(:), allocatable OMP_SAVE :: descriptor_i + real(dp), dimension(:), allocatable :: global_fourier_so3_r_array, global_fourier_so3_i_array + type(real_2d_array), dimension(:), allocatable :: global_grad_fourier_so3_r_array, global_grad_fourier_so3_i_array + integer, dimension(total_elements) :: species_map + + complex(dp), allocatable OMP_SAVE :: sphericalycartesian_all_t(:,:), gradsphericalycartesian_all_t(:,:,:) + complex(dp) :: c_tmp(3) + integer :: max_n_neigh + + ! new variables + type(real_2d), dimension(:), allocatable, save :: X_r, X_i, W + type(real_2d), dimension(:, :), allocatable, save :: Y_r, Y_i, dT_i, dT_r + type(real_2d), dimension(:, :, :), allocatable, save :: dY_r, dY_i + type(real_2d), dimension(:, :), allocatable, save :: dX_r, dX_i + type(real_2d_2d), dimension(:), allocatable, save :: dXG_r, dXG_i !global gradients + type(real_2d_2d), dimension(:, :), allocatable, save :: dYG_r, dYG_i + real(dp), dimension(:, :), allocatable, save :: Pl, Pl_g1, Pl_g2 + integer :: ic, K1, K2, ir, ig, ik + real(dp) :: tlpo + real(dp) :: r_tmp(3) + complex(dp), dimension(:), allocatable, save :: l_tmp + logical :: original + integer, dimension(:, :), allocatable :: coupling_inds + real, dimension(:), allocatable :: sym_facs + real(dp), external :: ddot + integer :: na, ix + ! Create a thread private QR_factor here as dormqr modifies it and restores it during solve + ! and this doesn't work with OMP threading, hence the thread private copy. + real(dp), dimension(:,:,:), allocatable OMP_SAVE :: QR_factor + +!$omp threadprivate(radial_fun, radial_coefficient, grad_radial_fun, grad_radial_coefficient) +!$omp threadprivate(sphericalycartesian_all_t, gradsphericalycartesian_all_t) +!$omp threadprivate(fourier_so3_r, fourier_so3_i, X_i, X_r, Pl, Y_r, Y_i) +!$omp threadprivate(SphericalY_ij,grad_SphericalY_ij) +!$omp threadprivate(descriptor_i, grad_descriptor_i) +!$omp threadprivate(grad_fourier_so3_r, grad_fourier_so3_i, QR_factor, dY_r, dY_i, Pl_g1, Pl_g2, l_tmp, dX_r, dX_i) +!$omp threadprivate(dT_i, dT_r) + + INIT_ERROR(error) + + call system_timer('soap_calc') + + if(.not. this%initialised) then + RAISE_ERROR("soap_calc: descriptor object not initialised", error) + endif + + if (( this%nu_R > 2) .OR. (this%nu_R < 0)) then + RAISE_ERROR("nu_R outside allowed range of 0-2", error) + endif + + if (( this%nu_S > 2) .OR. (this%nu_S < 0)) then + RAISE_ERROR("nu_S outside allowed range of 0-2", error) + endif + + ! for special routines to keep original power spectrum fast + original = .false. + if (this%coupling .and. this%nu_R == 2 .and. this%nu_S == 2) original = .true. + if (this%R_mix .or. this%Z_mix .or. this%sym_mix) original = .false. + if (len(trim(this%Z_map_str)) > 0 ) original = .false. + + ! form W mixing matrices + call form_W(this, W, sym_desc, error) + K1 = size(W(1)%mm(0,:)) + K2 = size(W(2)%mm(0,:)) + if (.not. this%coupling) call form_coupling_inds(this, K1, coupling_inds, sym_facs, error) + + species_map = 0 + do i_species = 1, this%n_species + if(this%species_Z(i_species) == 0) then + species_map = 1 + else + species_map(this%species_Z(i_species)) = i_species + endif + enddo + + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + has_atom_mask_name = .false. ! allow atom mask column in the atom table + atom_mask_pointer => null() ! allow atom mask column in the atom table + xml_version = 1423143769 ! This is the version number where the 2l+1 normalisation of soap vectors was introduced + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is " // & + "true, descriptors are calculated.") + + call param_register(params, 'xml_version', '1423143769', xml_version, & + help_string="Version of GAP the XML potential file was created") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='soap_calc args_str')) then + RAISE_ERROR("soap_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("soap_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + if( this%cutoff_dexp > 0 ) then + if( this%cutoff_rate == 0.0_dp ) then + norm_radial_decay = 1.0_dp + else + norm_radial_decay = this%cutoff_rate / ( 1.0_dp + this%cutoff_rate ) + endif + else + norm_radial_decay = 1.0_dp + endif + + do_two_l_plus_one = (xml_version >= 1423143769) + + allocate(rs_index(2,this%n_max*this%n_species)) + i = 0 + do i_species = 1, this%n_species + do a = 1, this%n_max + i = i + 1 + rs_index(:,i) = (/a,i_species/) + enddo + enddo + + call finalise(descriptor_out) + + d = soap_dimensions(this, error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + allocate(i_desc(at%N)) + + max_n_neigh = 0 + do n_i = 1, at%N + max_n_neigh = max(max_n_neigh, n_neighbours(at, n_i)) + end do + + +!$omp parallel default(none) shared(this,my_do_grad_descriptor,d,max_n_neigh, K1, K2, original, sym_desc) private(i_species, a, l, n_i, ub, ik, k) + allocate(descriptor_i(d)) + if(my_do_grad_descriptor) allocate(grad_descriptor_i(d,3)) + + allocate(radial_fun(0:this%l_max, size(this%r_basis)), radial_coefficient(0:this%l_max, this%n_max)) + !SPEED allocate(fourier_so3(0:this%l_max,this%n_max,this%n_species), SphericalY_ij(0:this%l_max)) + !allocate(fourier_so3_r(0:this%l_max,0:this%n_max,0:this%n_species), fourier_so3_i(0:this%l_max,0:this%n_max,0:this%n_species)) + allocate(SphericalY_ij(0:this%l_max)) + allocate(X_r(0:this%l_max), X_i(0:this%l_max)) + allocate(l_tmp(1:2*this%l_max + 1)) + do l = 0, this%l_max + allocate(X_r(l)%mm(2*l+1, this%n_species*this%n_max)) + allocate(X_i(l)%mm(2*l+1, this%n_species*this%n_max)) + enddo + + allocate(Pl(K1, K2)) + + allocate(Y_r(2, 0:this%l_max), Y_i(2, 0:this%l_max)) + do l = 0, this%l_max + allocate(Y_r(1, l)%mm(2*l+1, K1)) + allocate(Y_i(1, l)%mm(2*l+1, K1)) + allocate(Y_r(2, l)%mm(2*l+1, K2)) + allocate(Y_i(2, l)%mm(2*l+1, K2)) + enddo + + + if(my_do_grad_descriptor) then + allocate(grad_radial_fun(0:this%l_max, size(this%r_basis)), grad_radial_coefficient(0:this%l_max, this%n_max)) + allocate(grad_SphericalY_ij(0:this%l_max)) + endif + + allocate(sphericalycartesian_all_t(0:this%l_max, -this%l_max:this%l_max)) + if(my_do_grad_descriptor) then + allocate(gradsphericalycartesian_all_t(0:this%l_max, -this%l_max:this%l_max, 3)) + endif + + if (this%radial_basis /= "EQUISPACED_GAUSS") then + allocate(QR_factor(size(this%r_basis), this%n_max, 0:this%l_max)) + do l = 0, this%l_max + QR_factor(:, :, l) = this%QR_factor(:, :, l) + enddo + endif + + do l = 0, this%l_max + allocate(SphericalY_ij(l)%m(-l:l)) + if(my_do_grad_descriptor) allocate(grad_SphericalY_ij(l)%mm(3,-l:l)) + enddo + + if (my_do_grad_descriptor) then + if (original) then + allocate(Pl_g1(K1, 3*this%n_max)) + else + allocate(Pl_g1(K1, 3*K2), Pl_g2(3*K1, K2)) + endif + + ! allocate new grad storage + if (original) then + allocate(dX_r(0:this%l_max, max_n_neigh), dX_i(0:this%l_max, max_n_neigh)) + do l = 0, this%l_max + do n_i = 1, max_n_neigh + allocate(dX_r(l, n_i)%mm(2*l+1, 3*this%n_max)) + allocate(dX_i(l, n_i)%mm(2*l+1, 3*this%n_max)) + enddo + enddo + ! general + else + allocate(dY_r(2, 0:this%l_max, max_n_neigh), dY_i(2, 0:this%l_max, max_n_neigh)) + do n_i = 1, max_n_neigh + do ik = 1, 2 + if (sym_desc .and. ik == 1) cycle + k = K1 + if (ik == 2) k = K2 + do l = 0, this%l_max + allocate(dY_r(ik, l, n_i)%mm(2*l+1, 3*k)) + allocate(dY_i(ik, l, n_i)%mm(2*l+1, 3*k)) + enddo + enddo + enddo + endif + + !temporary storage for the gradient cofficients before multiplication + allocate(dT_r(0:2, 0:this%l_max), dT_i(0:2, 0:this%l_max)) + do l = 0, this%l_max + allocate(dT_r(0, l)%mm(2*l+1, this%n_max), dT_i(0, l)%mm(2*l+1, this%n_max)) + allocate(dT_r(1, l)%mm(2*l+1, K1), dT_i(1, l)%mm(2*l+1, K1)) + allocate(dT_r(2, l)%mm(2*l+1, K2), dT_i(2, l)%mm(2*l+1, K2)) + enddo + + endif +!$omp end parallel + + i_desc = 0 + i_desc_i = 0 + do i = 1, at%N + if( .not. any( at%Z(i) == this%Z ) .and. .not. any(this%Z == 0) ) cycle + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + i_desc_i = i_desc_i + 1 + i_desc(i) = i_desc_i + + if(.not. this%global) then ! atomic SOAP + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc_i)%data(d)) + !slow, no need + !descriptor_out%x(i_desc_i)%data = 0.0_dp + allocate(descriptor_out%x(i_desc_i)%ci(n_index)) + descriptor_out%x(i_desc_i)%has_data = .false. + descriptor_out%x(i_desc_i)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc_i)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc_i)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc_i)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc_i)%has_grad_data(0:l_n_neighbours)) + ! slow, no need + ! descriptor_out%x(i_desc_i)%grad_data = 0.0_dp + descriptor_out%x(i_desc_i)%grad_data(:,:,0) = 0.0_dp + descriptor_out%x(i_desc_i)%ii = 0 + descriptor_out%x(i_desc_i)%pos = 0.0_dp + descriptor_out%x(i_desc_i)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc_i)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc_i)%grad_covariance_cutoff = 0.0_dp + endif + endif + enddo + + ! Test, might ahve to always allocate this for omp reduction... + allocate( & + global_fourier_so3_r_array((this%l_max+1)**2 * this%n_max*this%n_species), & + global_fourier_so3_i_array((this%l_max+1)**2 * this%n_max*this%n_species+1)) + + if (this%global) then + if (original) then + allocate(dXG_r(count(i_desc/=0)), dXG_i(count(i_desc/=0))) + else + allocate(dYG_r(count(i_desc/=0), 2), dYG_i(count(i_desc/=0), 2)) + endif + endif + + + if(this%global) then + if(my_do_descriptor) then + allocate(descriptor_out%x(1)%data(d)) + allocate(descriptor_out%x(1)%ci(n_index)) + if( any(this%Z == 0) ) then + descriptor_out%x(1)%ci(:) = (/ (i, i=1, at%N) /) + else + forall(i=1:at%N, any(at%Z(i) == this%Z)) descriptor_out%x(1)%ci(i_desc(i)) = i + endif + descriptor_out%x(1)%has_data = .true. + descriptor_out%x(1)%covariance_cutoff = 1.0_dp + endif ! my_do_descriptor + if(my_do_grad_descriptor) then + sum_l_n_neighbours = 0 + do i = 1, at%N + + if(i_desc(i) == 0) then + cycle + else + i_desc_i = i_desc(i) + endif + + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + sum_l_n_neighbours = sum_l_n_neighbours + l_n_neighbours + 1 ! include central atom as well! + + ! allocate( & + ! global_grad_fourier_so3_r_array(i_desc_i)%x(0:this%l_max,0:this%n_max,l_n_neighbours), & + !global_grad_fourier_so3_i_array(i_desc_i)%x(0:this%l_max,0:this%n_max,l_n_neighbours) ) + !allocate( & + !global_grad_fourier_so3_r_array(i_desc_i)%x(0:this%l_max,0:this%n_max,max_n_neigh), & + !global_grad_fourier_so3_i_array(i_desc_i)%x(0:this%l_max,0:this%n_max,max_n_neigh) ) + if (original) then + allocate(dXG_r(i_desc_i)%x(0:this%l_max, l_n_neighbours), dXG_i(i_desc_i)%x(0:this%l_max, l_n_neighbours) ) + else + do k = 1, 2 + allocate(dYG_r(i_desc_i, k)%x(0:this%l_max, l_n_neighbours), dYG_i(i_desc_i, k)%x(0:this%l_max, l_n_neighbours) ) + enddo + endif + + ! do n_i = 1, l_n_neighbours + ! do a = 0, this%n_max + ! do l = 0, this%l_max + ! !allocate( & + ! !global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm(3,-l:l), & + ! !global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm(3,-l:l) ) + + ! global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm = 0.0_dp + ! global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm = 0.0_dp + ! enddo ! l + ! enddo ! a + ! enddo ! n_i + + do l = 0,this%l_max + do n_i = 1, l_n_neighbours + if (original) then + allocate(dXG_r(i_desc_i)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) + allocate(dXG_i(i_desc_i)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) + dXG_r(i_desc_i)%x(l, n_i)%mm = 0.0_dp + dXG_i(i_desc_i)%x(l, n_i)%mm = 0.0_dp + else + do k = 1, 2 + allocate(dYG_r(i_desc_i, k)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) + allocate(dYG_i(i_desc_i, k)%x(l, n_i)%mm(0:2*l+1, 3*this%n_max)) + dYG_r(i_desc_i, k)%x(l, n_i)%mm = 0.0_dp + dYG_i(i_desc_i, k)%x(l, n_i)%mm = 0.0_dp + enddo + endif + enddo + enddo + + enddo ! i + + allocate(descriptor_out%x(1)%grad_data(d,3,sum_l_n_neighbours)) + allocate(descriptor_out%x(1)%ii(sum_l_n_neighbours)) + allocate(descriptor_out%x(1)%pos(3,sum_l_n_neighbours)) + allocate(descriptor_out%x(1)%has_grad_data(sum_l_n_neighbours)) + + allocate(descriptor_out%x(1)%grad_covariance_cutoff(3,sum_l_n_neighbours)) + descriptor_out%x(1)%grad_covariance_cutoff = 0.0_dp + endif ! my_do_grad_descriptor + + global_fourier_so3_r_array = 0.0_dp + global_fourier_so3_i_array = 0.0_dp + endif ! this%global + + +!$omp parallel do schedule(dynamic) default(none) shared(this, at, descriptor_out, my_do_descriptor, my_do_grad_descriptor, d, i_desc, species_map, rs_index, do_two_l_plus_one, sym_desc, W, K1, K2, max_n_neigh) & +!$omp shared(dXG_r, dXG_i, dYG_r, dYG_i, norm_radial_decay, coupling_inds, sym_facs, original) & +!$omp private(i, j, i_species, j_species, a, b, l, m, n, n_i, r_ij, u_ij, d_ij, shift_ij, i_pow, i_coeff, ia, jb, alpha, i_desc_i, ub, ic, ir, ig, ik, k, na, ix) & +!$omp private(c_tmp, r_tmp, tlpo) & +!$omp private(t_g_r, t_g_i, t_f_r, t_f_i, t_g_f_rr, t_g_f_ii) & +!$omp private(f_cut, df_cut, arg_bess, exp_p, exp_m, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lp, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm, norm_descriptor_i) & +!$omp private(radial_decay, dradial_decay) & +!$omp reduction(+:global_fourier_so3_r_array,global_fourier_so3_i_array) + + + do i = 1, at%N + if(i_desc(i) == 0) then + cycle + else + i_desc_i = i_desc(i) + endif + + + if(.not.this%global) then + if(my_do_descriptor) then + descriptor_out%x(i_desc_i)%ci(1) = i + descriptor_out%x(i_desc_i)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc_i)%ii(0) = i + descriptor_out%x(i_desc_i)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc_i)%has_grad_data(0) = .true. + + ! zero the gradient contributions + if (original) then + do n_i= 1, max_n_neigh + do l = 0, this%l_max + dX_r(l, n_i)%mm = 0.0_dp + dX_i(l, n_i)%mm = 0.0_dp + enddo + enddo + ! general + else + do n_i = 1, max_n_neigh + do l = 0, this%l_max + do k = 1, 2 + if (sym_desc .and. k == 1) cycle + dY_r(k, l, n_i)%mm = 0.0_dp + dY_i(k, l, n_i)%mm = 0.0_dp + enddo + enddo + enddo + endif + endif + endif + + if (this%radial_basis == "EQUISPACED_GAUSS") then + ! original version + radial_fun(0,:) = 0.0_dp + radial_fun(0,1) = 1.0_dp + radial_coefficient(0,:) = matmul( radial_fun(0,:), this%cholesky_overlap_basis(:, :, 1)) + else + ! uncommented old version that I think should work... + do a = 1, size(this%r_basis) + radial_fun(0,a) = exp( -this%alpha * this%r_basis(a)**2 ) !* this%r_basis(a) + enddo + !call LA_Matrix_QR_Solve_Vector(LA_BL_ti(0), radial_fun(0, :), radial_coefficient(0, :)) + call Matrix_QR_Solve(QR_factor(:, :, 0), this%QR_tau(:, 0), radial_fun(0, :), radial_coefficient(0, :)) + ! alternative approach: don't invert L^T and multiply at the end. Doesn't work as well for POLY basis + !radial_coefficient = matmul(radial_coefficient, this%cholesky_overlap_basis(0, :, :)) + endif + + !zero the coefficients and initialise counter + do l = 0, this%l_max + X_r(l)%mm = 0.0_dp + X_i(l)%mm = 0.0_dp + enddo + + do i_species = 0, this%n_species + do a = 0, this%n_max + + if ((this%central_reference_all_species .or. this%species_Z(i_species) == at%Z(i) .or. this%species_Z(i_species) == 0) .and. i_species > 0 .and. a > 0) then + ic = (i_species-1) * this%n_max + a + X_r(0)%mm(1, ic) = this%central_weight * real(radial_coefficient(0,a) * SphericalYCartesian(0,0,(/0.0_dp, 0.0_dp, 0.0_dp/)), dp) + X_i(0)%mm(1, ic) = this%central_weight * aimag(radial_coefficient(0,a) * SphericalYCartesian(0,0,(/0.0_dp, 0.0_dp, 0.0_dp/))) + endif + enddo + enddo + + + +! soap_calc 20 takes 0.0052 s + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines=u_ij, diff=d_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + + i_species = species_map(at%Z(j)) + if( i_species == 0 ) cycle + + + if(.not. this%global .and. my_do_grad_descriptor) then + descriptor_out%x(i_desc_i)%ii(n_i) = j + descriptor_out%x(i_desc_i)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc_i)%has_grad_data(n_i) = .true. + endif + + f_cut = coordination_function(r_ij, this%cutoff, this%cutoff_transition_width) + radial_decay = ( 1.0_dp + this%cutoff_rate ) / ( this%cutoff_rate + ( r_ij / this%cutoff_scale )**this%cutoff_dexp ) + radial_decay = norm_radial_decay * radial_decay + + if(my_do_grad_descriptor) then + df_cut = dcoordination_function(r_ij,this%cutoff, this%cutoff_transition_width) + dradial_decay = - this%cutoff_dexp * ( 1.0_dp + this%cutoff_rate ) * ( r_ij / this%cutoff_scale )**this%cutoff_dexp / & + ( r_ij * ( this%cutoff_rate + ( r_ij / this%cutoff_scale )**this%cutoff_dexp )**2 ) + dradial_decay = norm_radial_decay * dradial_decay + + df_cut = df_cut * radial_decay + f_cut * dradial_decay + endif + f_cut = f_cut * radial_decay + + do a = 1, size(this%r_basis) + arg_bess = 2.0_dp * this%alpha * r_ij * this%r_basis(a) + exp_p = exp( -this%alpha*( r_ij + this%r_basis(a) )**2 ) + exp_m = exp( -this%alpha*( r_ij - this%r_basis(a) )**2 ) + + do l = 0, this%l_max + if( l == 0 ) then + if(arg_bess == 0.0_dp) then + !mo_spher_bess_fi_ki_l = 1.0_dp + mo_spher_bess_fi_ki_l = exp( -this%alpha * (this%r_basis(a)**2 + r_ij**2) ) + if(my_do_grad_descriptor) mo_spher_bess_fi_ki_lp = 0.0_dp + else + !mo_spher_bess_fi_ki_lm = cosh(arg_bess)/arg_bess + !mo_spher_bess_fi_ki_l = sinh(arg_bess)/arg_bess + mo_spher_bess_fi_ki_lm = 0.5_dp * (exp_m + exp_p) / arg_bess + mo_spher_bess_fi_ki_l = 0.5_dp * (exp_m - exp_p) / arg_bess + if(my_do_grad_descriptor) mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess + endif + else + if(arg_bess == 0.0_dp) then + mo_spher_bess_fi_ki_l = 0.0_dp + if(my_do_grad_descriptor) mo_spher_bess_fi_ki_lp = 0.0_dp + else + mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm + mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l + if(my_do_grad_descriptor) then + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lp + mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess + else + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l-1)*mo_spher_bess_fi_ki_lm / arg_bess + endif + endif + endif + + !radial_fun(l,a) = exp( -this%alpha * (this%r_basis(a)**2 + r_ij**2) ) * mo_spher_bess_fi_ki_l !* this%r_basis(a) + radial_fun(l,a) = mo_spher_bess_fi_ki_l !* this%r_basis(a) + if(my_do_grad_descriptor) grad_radial_fun(l,a) = -2.0_dp * this%alpha * r_ij * mo_spher_bess_fi_ki_l + & + l*mo_spher_bess_fi_ki_l / r_ij + mo_spher_bess_fi_ki_lp * 2.0_dp * this%alpha * this%r_basis(a) + + enddo + enddo + + if (this%radial_basis == "EQUISPACED_GAUSS") then + radial_coefficient = matmul( radial_fun, this%transform_basis ) + if(my_do_grad_descriptor) grad_radial_coefficient = matmul( grad_radial_fun, this%transform_basis ) * f_cut + radial_coefficient * df_cut + radial_coefficient = radial_coefficient * f_cut + else + do l = 0, this%l_max + !call LA_Matrix_QR_Solve_Vector(LA_BL_ti(l), radial_fun(l, :), radial_coefficient(l, :)) + call Matrix_QR_Solve(QR_factor(:, :, l), this%QR_tau(:, l), radial_fun(l, :), radial_coefficient(l, :)) + !radial_coefficient(l, :) = matmul(radial_coefficient(l, :), this%cholesky_overlap_basis(l, :, :)) + enddo + if(my_do_grad_descriptor) then + !grad_radial_coefficient = matmul( grad_radial_fun, transpose(this%transform_basis )) * f_cut + radial_coefficient * df_cut + do l = 0, this%l_max + call Matrix_QR_Solve(QR_factor(:, :, l), this%QR_tau(:, l), grad_radial_fun(l, :), grad_radial_coefficient(l, :)) + enddo + grad_radial_coefficient = grad_radial_coefficient * f_cut + radial_coefficient * df_cut + endif + radial_coefficient = radial_coefficient * f_cut + endif + + sphericalycartesian_all_t = SphericalYCartesian_all(this%l_max, d_ij) + if(my_do_grad_descriptor) gradsphericalycartesian_all_t = GradSphericalYCartesian_all(this%l_max, d_ij) + do l = 0, this%l_max + do m = -l, l + SphericalY_ij(l)%m(m) = SphericalYCartesian_all_t(l,m) + if(my_do_grad_descriptor) grad_SphericalY_ij(l)%mm(:,m) = GradSphericalYCartesian_all_t(l,m,:) + enddo + enddo + + do l = 0, this%l_max + do a = 1, this%n_max + ic = (i_species-1) * this%n_max + a + X_r(l)%mm(:, ic) = X_r(l)%mm(:, ic) + radial_coefficient(l,a) * real(SphericalY_ij(l)%m(:)) + X_i(l)%mm(:, ic) = X_i(l)%mm(:, ic) + radial_coefficient(l,a) * aimag(SphericalY_ij(l)%m(:)) + enddo ! a + enddo ! l + + if(my_do_grad_descriptor .and. original) then + do k = 1, 3 + do l = 0, this%l_max + !special case for original power spectrum + do a = 1, this%n_max + ic = (a-1)*3 + k + l_tmp(1:2*l+1) = grad_radial_coefficient(l,a) * SphericalY_ij(l)%m(:) * u_ij(k) + radial_coefficient(l,a) * grad_SphericalY_ij(l)%mm(k,:) + dX_r(l, n_i)%mm(:, ic) = real(l_tmp(1:2*l+1)) + dX_i(l, n_i)%mm(:, ic) = aimag(l_tmp(1:2*l+1)) + enddo ! a + enddo ! l + enddo ! k + endif ! my_do_grad_descriptor + + if(my_do_grad_descriptor .and. (.not. original)) then + do k = 1, 3 + do l = 0, this%l_max + do a = 1, this%n_max + l_tmp(1:2*l+1) = grad_radial_coefficient(l,a) * SphericalY_ij(l)%m(:) * u_ij(k) + radial_coefficient(l,a) * grad_SphericalY_ij(l)%mm(k,:) + dT_r(0, l)%mm(:, a) = real(l_tmp(1:2*l+1)) + dT_i(0, l)%mm(:, a) = aimag(l_tmp(1:2*l+1)) + enddo ! a + + !operate on the coefficients then pack them + ic = (i_species-1) * this%n_max + do ia = 1, 2 + if (sym_desc .and. ia == 1) cycle + dT_r(ia, l)%mm = matmul(dT_r(0, l)%mm, W(ia)%mm(ic+1:ic+this%n_max, :)) + dT_i(ia, l)%mm = matmul(dT_i(0, l)%mm, W(ia)%mm(ic+1:ic+this%n_max, :)) + + ub = K1 + if (ia == 2) ub = K2 + do ik = 1, ub + ir = (ik-1)*3 + k + dY_r(ia, l, n_i)%mm(:, ir) = dT_r(ia, l)%mm(:, ik) + dY_i(ia, l, n_i)%mm(:, ir) = dT_i(ia, l)%mm(:, ik) + enddo + enddo + enddo ! l + enddo ! k + endif ! my_do_grad_descriptor + + enddo ! n + + + + if(this%global .and. my_do_grad_descriptor) then + if (original) then + dXG_r(i_desc_i)%x = dX_r(:, 1:n_neighbours(at,i,max_dist=this%cutoff)) + dXG_i(i_desc_i)%x = dX_i(:, 1:n_neighbours(at,i,max_dist=this%cutoff)) + else + ! copy the operated gradients + do k = 1, 2 + dYG_r(i_desc_i, k)%x = dY_r(k, :, 1:n_neighbours(at,i,max_dist=this%cutoff)) + dYG_i(i_desc_i, k)%x = dY_i(k, :, 1:n_neighbours(at,i,max_dist=this%cutoff)) + enddo + endif + endif + + + if(this%global) then + i_coeff = 0 + do ia = 1, this%n_species*this%n_max + a = rs_index(1,ia) + i_species = rs_index(2,ia) + do l = 0, this%l_max + global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) = global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) + X_r(l)%mm(:, ia) + global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) = global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) + X_i(l)%mm(:, ia) + i_coeff = i_coeff + 2*l+1 + enddo + enddo + endif + + if (this%coupling) then + !standard full tensor product coupling between density channels. + i_pow = 0 + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + ! special case for regular power spectrum + if (original) then + ! Pl = matmul(tranpose(X_r(l)%mm), X_r(l)%mm) + call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, X_r(l)%mm, 2*l+1, 0.0_dp, Pl, K1) + call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, X_i(l)%mm, 2*l+1, 1.0_dp, Pl, K1) + ! everything else + else + + call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_r(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_r(1, l)%mm, 2*l+1) + call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_i(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_i(1, l)%mm, 2*l+1) + + !skipping this for regular power spec saves 1e-3 + if (sym_desc) then + Y_r(2, l)%mm = Y_r(1, l)%mm + Y_i(2, l)%mm = Y_i(1, l)%mm + else + Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) + Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) + endif + + !Pl = matmul(transpose(Y_r(1, l)%mm), Y_r(2, l)%mm) + matmul(transpose(Y_i(1, l)%mm), Y_i(2, l)%mm) + call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, Y_r(2, l)%mm, 2*l+1, 0.0_dp, Pl, K1) + call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, Y_i(2, l)%mm, 2*l+1, 1.0_dp, Pl, K1) + endif + + ! unpack l-slice + i_pow = l + 1 + do ia = 1, K1 + ub = K2 + if (sym_desc) then + ub = ia + endif + if (this%diagonal_radial .and. original) a = rs_index(1,ia) + do jb = 1, ub + if (this%diagonal_radial .and. original) b = rs_index(1,jb) + if (this%diagonal_radial .and. original .and. a /= b) cycle + descriptor_i(i_pow) = Pl(ia, jb) + if( ia /= jb .and. sym_desc) descriptor_i(i_pow) = descriptor_i(i_pow) * SQRT_TWO + i_pow = i_pow + this%l_max+1 + enddo + enddo + + enddo + else + !elementwise coupling between density channels. For use with tensor-reduced compression. + do l = 0, this%l_max + + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + ! Y_r(1, l)%mm = matmul(X_r(l)%mm, W(1)%mm) + ! Y_i(1, l)%mm = matmul(X_i(l)%mm, W(1)%mm) + call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_r(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_r(1, l)%mm, 2*l+1) + call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_i(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_i(1, l)%mm, 2*l+1) + if (this%sym_mix) then + Y_r(2, l)%mm = Y_r(1, l)%mm + Y_i(2, l)%mm = Y_i(1, l)%mm + else + Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) + Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) + endif + + i_pow = l + 1 + do ik = 1, SIZE(sym_facs) + ia = coupling_inds(ik, 1) + jb = coupling_inds(ik, 2) + !descriptor_i(i_pow) = (dot_product(Y_r(1, l)%mm(:, ia), Y_r(2, l)%mm(:, jb)) + dot_product(Y_i(1, l)%mm(:, ia), Y_i(2, l)%mm(:, jb))) * sym_facs(ik) + descriptor_i(i_pow) = (ddot(2*l+1, Y_r(1, l)%mm(:, ia), 1, Y_r(2, l)%mm(:, jb), 1) + ddot(2*l+1, Y_i(1, l)%mm(:, ia), 1, Y_i(2, l)%mm(:, jb), 1)) * sym_facs(ik) + if (do_two_l_plus_one) descriptor_i(i_pow) = descriptor_i(i_pow) * tlpo + i_pow = i_pow + this%l_max + 1 + enddo + enddo + endif + + !normalise the descriptor + descriptor_i(d) = 0.0_dp + norm_descriptor_i = sqrt(dot_product(descriptor_i,descriptor_i)) + if(.not. this%global .and. my_do_descriptor) then + if(this%normalise) then + descriptor_out%x(i_desc_i)%data = descriptor_i / norm_descriptor_i + else + descriptor_out%x(i_desc_i)%data = descriptor_i + endif + descriptor_out%x(i_desc_i)%data(d) = this%covariance_sigma0 + endif + + !new gradients calcuation + if (my_do_grad_descriptor) then + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij) + if( r_ij >= this%cutoff ) cycle + n_i = n_i + 1 + if( species_map(at%Z(j)) == 0 ) cycle + grad_descriptor_i = 0.0_dp + + if (this%coupling .and. (.not. original)) then + do l = 0, this%l_max + ! call dgemm(transA, transB, M, N, K, alpha, A, LDA, B, LDB, beta, C, LDC) + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, dY_r(2, l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) + call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, dY_i(2, l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) + + ! TODO check if this is really necessary... think very likely it's not! + if (.not. sym_desc) then + Pl_g2 = matmul(transpose(dY_r(1, l, n_i)%mm), Y_r(2,l)%mm) + matmul(transpose(dY_i(1, l, n_i)%mm), Y_i(2,l)%mm) + if(do_two_l_plus_one) Pl_g2 = Pl_g2 / sqrt(2.0_dp * l + 1.0_dp) + endif + + i_pow = l + 1 + do ia = 1, K1 + ub = K2 + if (sym_desc) ub = ia + do jb = 1, ub + ic = (jb-1) * 3 + ir = (ia-1) * 3 + if (sym_desc) then + r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g1(jb, ir+1:ir+3) + else + r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g2(ir+1:ir+3, jb) + endif + + if(ia /= jb .and. sym_desc ) r_tmp = r_tmp * SQRT_TWO + grad_descriptor_i(i_pow, :) = r_tmp + i_pow = i_pow + this%l_max+1 + enddo + enddo + enddo !l + + !special case for diagonal coupling only - testing how fast I can make this + elseif(.not. this%coupling .and. this%R_mix .and. this%Z_mix) then + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + i_pow = l + 1 + + do ik = 1, this%K + r_tmp(:) = 0.0_dp + do ix = 1, 3 + ir = (ik-1)*3 + ix + do na = 1, 2*l+1 + r_tmp(ix) = r_tmp(ix) + dY_r(2, l, n_i)%mm(na,ir)*Y_r(1, l)%mm(na, ik) + dY_i(2, l, n_i)%mm(na,ir)*Y_i(1, l)%mm(na, ik) + enddo + enddo + + ! either multiply by factor of 2 for symmetric or do other way around for asym + if (this%sym_mix) then + r_tmp(:) = r_tmp(:) * 2.0_dp + else + do ix = 1, 3 + ir = (ik-1)*3 + ix + do na = 1, 2*l+1 + r_tmp(ix) = r_tmp(ix) + dY_r(1, l, n_i)%mm(na,ir)*Y_r(2, l)%mm(na, ik) + dY_i(1, l, n_i)%mm(na,ir)*Y_i(2, l)%mm(na, ik) + enddo + enddo + endif + + grad_descriptor_i(i_pow, :) = r_tmp * tlpo + i_pow = i_pow + this%l_max + 1 + enddo + enddo + + elseif(.not. this%coupling ) then + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + i_pow = l + 1 + + do ik = 1, SIZE(sym_facs) + ia = coupling_inds(ik, 1) + jb = coupling_inds(ik, 2) + ir = (jb-1) * 3 + r_tmp = matmul(transpose(dY_r(2, l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, ia)) + matmul(transpose(dY_i(2, l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, ia) ) + ir = (ia-1)*3 + if (sym_desc) then + r_tmp = r_tmp + matmul(transpose(dY_r(2, l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, jb) ) + matmul(transpose(dY_i(2, l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, jb) ) + else + r_tmp = r_tmp + matmul(transpose(dY_r(1, l, n_i)%mm(:, ir+1:ir+3)), Y_r(2, l)%mm(:, jb) ) + matmul(transpose(dY_i(1, l, n_i)%mm(:, ir+1:ir+3)), Y_i(2, l)%mm(:, jb) ) + endif + grad_descriptor_i(i_pow, :) = r_tmp * tlpo * sym_facs(ik) + i_pow = i_pow + this%l_max + 1 + enddo + enddo + + !original power spectrum gradients as special case to exploit sparsity of dX_r w.r.t the neighbour species + else + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + !TODO try swapping order here + call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, dX_r(l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) + call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, dX_i(l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) + + i_pow = l + 1 + do ia = 1, K1 + a = rs_index(1,ia) + i_species = rs_index(2,ia) + do jb = 1, ia + b = rs_index(1,jb) + j_species = rs_index(2,jb) + if (this%diagonal_radial .and. a /= b) cycle + if(at%Z(j) == this%species_Z(i_species) .or. this%species_Z(i_species)==0) then + ic = (a-1) * 3 + grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(jb, ic+1:ic+3) + endif + if(at%Z(j) == this%species_Z(j_species) .or. this%species_Z(j_species)==0) then + ic = (b-1) * 3 + grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(ia, ic+1:ic+3) + endif + + if(ia /= jb) grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) * SQRT_TWO + i_pow = i_pow + this%l_max+1 + enddo !jb + enddo !ia + enddo !l + endif + !normalise the gradients + grad_descriptor_i(d, 1:3) = 0.0_dp + if(.not. this%global) then + if( this%normalise ) then + grad_descriptor_i = grad_descriptor_i / norm_descriptor_i + c_tmp = matmul(descriptor_i,grad_descriptor_i) / norm_descriptor_i**2 + do k = 1, 3 + descriptor_out%x(i_desc_i)%grad_data(:,k,n_i) = grad_descriptor_i(:,k) - descriptor_i * c_tmp(k) + enddo + else + descriptor_out%x(i_desc_i)%grad_data(:,:,n_i) = grad_descriptor_i + endif + descriptor_out%x(i_desc_i)%grad_data(:,:,0) = descriptor_out%x(i_desc_i)%grad_data(:,:,0) - descriptor_out%x(i_desc_i)%grad_data(:,:,n_i) + endif + + enddo !n_i + endif + + enddo ! i +!$omp end parallel do + + +!$omp parallel default(none) shared(this, max_n_neigh) private(i_species, a, l, n_i, ub) + if(allocated(fourier_so3_r)) then + do i_species = lbound(fourier_so3_r,3), ubound(fourier_so3_r,3) + do a = lbound(fourier_so3_r,2), ubound(fourier_so3_r,2) + do l = lbound(fourier_so3_r,1), ubound(fourier_so3_r,1) + deallocate(fourier_so3_r(l,a,i_species)%m) + enddo + enddo + enddo + deallocate(fourier_so3_r) + endif + if(allocated(fourier_so3_i)) then + do i_species = lbound(fourier_so3_i,3), ubound(fourier_so3_i,3) + do a = lbound(fourier_so3_i,2), ubound(fourier_so3_i,2) + do l = lbound(fourier_so3_i,1), ubound(fourier_so3_i,1) + deallocate(fourier_so3_i(l,a,i_species)%m) + enddo + enddo + enddo + deallocate(fourier_so3_i) + endif + + if (allocated(l_tmp)) deallocate(l_tmp) + if (allocated(X_r)) then + do l = 0, this%l_max + if (allocated(X_r(l)%mm)) deallocate(X_r(l)%mm) + if (allocated(X_i(l)%mm)) deallocate(X_i(l)%mm) + enddo + if (allocated(X_r)) deallocate(X_r) + if (allocated(X_i)) deallocate(X_i) + endif + + if (allocated(Y_r)) then + do k = 1, 2 + do l = 0, this%l_max + if (allocated(Y_r(k, l)%mm)) deallocate(Y_r(k, l)%mm) + if (allocated(Y_i(k, l)%mm)) deallocate(Y_i(k, l)%mm) + enddo + enddo + if (allocated(Y_r)) deallocate(Y_r) + if (allocated(Y_i)) deallocate(Y_i) + endif + + if(allocated(SphericalY_ij)) then + do l = lbound(SphericalY_ij,1), ubound(SphericalY_ij,1) + deallocate(SphericalY_ij(l)%m) + enddo + deallocate(SphericalY_ij) + endif + + if(allocated(grad_SphericalY_ij)) then + do l = lbound(grad_SphericalY_ij,1), ubound(grad_SphericalY_ij,1) + deallocate(grad_SphericalY_ij(l)%mm) + enddo + deallocate(grad_SphericalY_ij) + endif + + if (allocated(sphericalycartesian_all_t)) deallocate(sphericalycartesian_all_t) + if (allocated(gradsphericalycartesian_all_t)) deallocate(gradsphericalycartesian_all_t) + + if(allocated(radial_fun)) deallocate(radial_fun) + if(allocated(radial_coefficient)) deallocate(radial_coefficient) + if(allocated(grad_radial_fun)) deallocate(grad_radial_fun) + if(allocated(grad_radial_coefficient)) deallocate(grad_radial_coefficient) + if(allocated(descriptor_i)) deallocate(descriptor_i) + + !print *, "about to deallocate grad_descriptor_i" + if(allocated(grad_descriptor_i)) deallocate(grad_descriptor_i) + + if (allocated(grad_fourier_so3_r)) then ! should really check for grad_fourier_so3_i also + do n_i = 1, max_n_neigh + do a = 0, this%n_max + do l = 0, this%l_max + !SPEED deallocate(grad_fourier_so3(l,a,n_i)%mm) + if(allocated(grad_fourier_so3_r(l,a,n_i)%mm)) deallocate(grad_fourier_so3_r(l,a,n_i)%mm) + if(allocated(grad_fourier_so3_i(l,a,n_i)%mm)) deallocate(grad_fourier_so3_i(l,a,n_i)%mm) + enddo + enddo + enddo + endif + !SPEED deallocate(grad_fourier_so3) + if (allocated(grad_fourier_so3_r)) deallocate(grad_fourier_so3_r) + if (allocated(grad_fourier_so3_i)) deallocate(grad_fourier_so3_i) + + + if (allocated(dX_r)) then + do l = 0, this%l_max + do n_i = 1, max_n_neigh + if (allocated(dX_r(l, n_i)%mm)) deallocate(dX_r(l, n_i)%mm) + if (allocated(dX_i(l, n_i)%mm)) deallocate(dX_i(l, n_i)%mm) + enddo + enddo + if (allocated(dX_r)) deallocate(dX_r) + if (allocated(dX_i)) deallocate(dX_i) + endif + + if (allocated(dY_R)) then + do n_i = 1, max_n_neigh + do ik = 1, 2 + do l = 0, this%l_max + if (allocated(dY_i(ik, l, n_i)%mm)) deallocate(dY_i(ik, l, n_i)%mm) + if (allocated(dY_r(ik, l, n_i)%mm)) deallocate(dY_r(ik, l, n_i)%mm) + enddo + enddo + enddo + if (allocated(dY_i)) deallocate(dY_i) + if (allocated(dY_r)) deallocate(dY_r) + endif + + if (allocated(dT_r)) then + do k = 0, 2 + do l = 0, this%l_max + deallocate(dT_r(k, l)%mm, dT_i(k, l)%mm) + enddo + enddo + deallocate(dT_r, dT_i) + endif + + if (allocated(Pl_g1)) deallocate(Pl_g1) + if (allocated(Pl_g2)) deallocate(Pl_g2) + if (allocated(Pl)) deallocate(Pl) + if (allocated(QR_factor)) deallocate(QR_factor) +!$omp end parallel + + if(this%global) then + !allocate(global_fourier_so3_r(0:this%l_max,0:this%n_max,0:this%n_species), global_fourier_so3_i(0:this%l_max,0:this%n_max,0:this%n_species), & + !Have to reallocate X_r and Y_r + allocate(X_r(0:this%l_max), X_i(0:this%l_max)) + do l = 0, this%l_max + allocate(X_r(l)%mm(2*l+1, this%n_species*this%n_max)) + allocate(X_i(l)%mm(2*l+1, this%n_species*this%n_max)) + enddo + + allocate(Y_r(2, 0:this%l_max), Y_i(2, 0:this%l_max)) + do l = 0, this%l_max + allocate(Y_r(1, l)%mm(2*l+1, K1)) + allocate(Y_i(1, l)%mm(2*l+1, K1)) + allocate(Y_r(2, l)%mm(2*l+1, K2)) + allocate(Y_i(2, l)%mm(2*l+1, K2)) + enddo + + if (original) then + allocate(Pl_g1(K1, 3*this%n_max)) + else + allocate(Pl_g1(K1, 3*K2), Pl_g2(3*K1, K2)) + endif + allocate(Pl(K1, K2)) + + allocate(descriptor_i(d)) + + i_coeff = 0 + do ia = 1, this%n_species*this%n_max + a = rs_index(1,ia) + i_species = rs_index(2,ia) + do l = 0, this%l_max + !allocate(global_fourier_so3_r(l,a,i_species)%m(-l:l)) + !allocate(global_fourier_so3_i(l,a,i_species)%m(-l:l)) + !global_fourier_so3_r(l,a,i_species)%m(:) = global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) + !X_r(l)%mm(2*l+1, this%n_species*this%n_max) + X_r(l)%mm(:, ia) = global_fourier_so3_r_array(i_coeff+1:i_coeff+2*l+1) + X_i(l)%mm(:, ia) = global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) + !global_fourier_so3_i(l,a,i_species)%m(:) = global_fourier_so3_i_array(i_coeff+1:i_coeff+2*l+1) + i_coeff = i_coeff + 2*l+1 + enddo + enddo + + ! *********** exact duplication of code for main power spec + if (this%coupling) then + !standard full tensor product coupling between density channels. + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + ! special case for regular power spectrum + if (original) then + ! Pl = matmul(tranpose(X_r(l)%mm), X_r(l)%mm) + call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, X_r(l)%mm, 2*l+1, 0.0_dp, Pl, K1) + call dgemm('T', 'N', K1, K1, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, X_i(l)%mm, 2*l+1, 1.0_dp, Pl, K1) + ! everything else + else + call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_r(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_r(1, l)%mm, 2*l+1) + call dgemm('N', 'N', 2*l+1, K1, this%n_max*this%n_species, 1.0_dp, X_i(l)%mm, 2*l+1, W(1)%mm, this%n_max*this%n_species, 0.0_dp, Y_i(1, l)%mm, 2*l+1) + + !skipping this for regular power spec saves 1e-3 + if (sym_desc) then + Y_r(2, l)%mm = Y_r(1, l)%mm + Y_i(2, l)%mm = Y_i(1, l)%mm + else + Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) + Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) + endif + + !Pl = matmul(transpose(Y_r(1, l)%mm), Y_r(2, l)%mm) + matmul(transpose(Y_i(1, l)%mm), Y_i(2, l)%mm) + call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, Y_r(2, l)%mm, 2*l+1, 0.0_dp, Pl, K1) + call dgemm('T', 'N', K1, K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, Y_i(2, l)%mm, 2*l+1, 1.0_dp, Pl, K1) + endif + + ! unpack l-slice + i_pow = l + 1 + do ia = 1, K1 + ub = K2 + if (sym_desc) then + ub = ia + endif + if (this%diagonal_radial) a = rs_index(1,ia) + do jb = 1, ub + if (this%diagonal_radial) b = rs_index(1,jb) + if (this%diagonal_radial .and. a /= b) cycle + descriptor_i(i_pow) = Pl(ia, jb) + if( ia /= jb .and. sym_desc) descriptor_i(i_pow) = descriptor_i(i_pow) * SQRT_TWO + i_pow = i_pow + this%l_max+1 + enddo + enddo + + enddo + ! deallocate(Pl) + else + !elementwise coupling between density channels. For use with tensor-reduced compression. + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + Y_r(1, l)%mm = matmul(X_r(l)%mm, W(1)%mm) + Y_i(1, l)%mm = matmul(X_i(l)%mm, W(1)%mm) + if (this%sym_mix) then + Y_r(2, l)%mm = Y_r(1, l)%mm + Y_i(2, l)%mm = Y_i(1, l)%mm + else + Y_r(2, l)%mm = matmul(X_r(l)%mm, W(2)%mm) + Y_i(2, l)%mm = matmul(X_i(l)%mm, W(2)%mm) + endif + + i_pow = l + 1 + do ik = 1, SIZE(sym_facs) + ia = coupling_inds(ik, 1) + jb = coupling_inds(ik, 2) + descriptor_i(i_pow) = (dot_product(Y_r(1, l)%mm(:, ia), Y_r(2, l)%mm(:, jb)) + dot_product(Y_i(1, l)%mm(:, ia), Y_i(2, l)%mm(:, jb))) * sym_facs(ik) + if (do_two_l_plus_one) descriptor_i(i_pow) = descriptor_i(i_pow) * tlpo + i_pow = i_pow + this%l_max + 1 + enddo + + enddo + endif + ! ********** end of code duplication. Avoid with function / subroutine ?? + + + !normalise descriptor, using old block + descriptor_i(d) = 0.0_dp + norm_descriptor_i = sqrt(dot_product(descriptor_i,descriptor_i)) + if( norm_descriptor_i .feq. 0.0_dp ) norm_descriptor_i = tiny(1.0_dp) + if(my_do_descriptor) then + if(this%normalise) then + descriptor_out%x(1)%data = descriptor_i / norm_descriptor_i + else + descriptor_out%x(1)%data = descriptor_i + endif + descriptor_out%x(1)%data(d) = this%covariance_sigma0 + endif + + + if (my_do_grad_descriptor) then + allocate(grad_descriptor_i(d,3)) + i_pair = 0 + do i = 1, at%N + if (i_desc(i) == 0) cycle + i_desc_i = i_desc(i) + i_pair = i_pair + 1 + i_pair_i = i_pair ! accumulates \frac{ \partial p^{(j)} }{ \partial r_{ji\alpha} } + + descriptor_out%x(1)%ii(i_pair_i) = i + descriptor_out%x(1)%pos(:,i_pair_i) = 0.0_dp + descriptor_out%x(1)%has_grad_data(i_pair_i) = .true. + descriptor_out%x(1)%grad_data(:,:,i_pair_i) = 0.0_dp + + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, diff = d_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + i_pair = i_pair + 1 ! \frac{ \partial p^{(i)} }{ \partial r_{ij\alpha} } + + descriptor_out%x(1)%ii(i_pair) = j + descriptor_out%x(1)%pos(:,i_pair) = d_ij + descriptor_out%x(1)%has_grad_data(i_pair) = .true. + + i_pow = 0 + grad_descriptor_i = 0.0_dp + + ! beginning of new routines + if (this%coupling .and. (.not. original)) then + do l = 0, this%l_max + ! call dgemm(transA, transB, M, N, K, alpha, A, LDA, B, LDB, beta, C, LDC) + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_r(1, l)%mm, 2*l+1, dYG_r(i_desc_i, 2)%x(l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) + call dgemm('T','N', K1, 3 * K2, 2*l+1, tlpo, Y_i(1, l)%mm, 2*l+1, dYG_i(i_desc_i, 2)%x(l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) + + if (.not. sym_desc) then + Pl_g2 = matmul(transpose(dYG_r(i_desc_i, 1)%x(l, n_i)%mm), Y_r(2,l)%mm) + matmul(transpose(dYG_i(i_desc_i, 1)%x(l, n_i)%mm), Y_i(2,l)%mm) + if(do_two_l_plus_one) Pl_g2 = Pl_g2 / sqrt(2.0_dp * l + 1.0_dp) + endif + + i_pow = l + 1 + do ia = 1, K1 + ub = K2 + if (sym_desc) ub = ia + do jb = 1, ub + ic = (jb-1) * 3 + ir = (ia-1) * 3 + if (sym_desc) then + r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g1(jb, ir+1:ir+3) + else + r_tmp = Pl_g1(ia, ic+1:ic+3) + Pl_g2(ir+1:ir+3, jb) + endif + + if(ia /= jb .and. sym_desc ) r_tmp = r_tmp * SQRT_TWO + grad_descriptor_i(i_pow, :) = r_tmp + i_pow = i_pow + this%l_max+1 + enddo + enddo + enddo !l + + + ! element-wise coupling + elseif(.not. this%coupling ) then + + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + i_pow = l + 1 + !do ik = 1, K1 + do ik = 1, SIZE(sym_facs) + ia = coupling_inds(ik, 1) + jb = coupling_inds(ik, 2) + ir = (jb-1) * 3 + r_tmp = matmul(transpose(dYG_r(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, ia)) + matmul(transpose(dYG_i(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, ia) ) + ir = (ia-1)*3 + if (sym_desc) then + r_tmp = r_tmp + matmul(transpose(dYG_r(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_r(1, l)%mm(:, jb) ) + matmul(transpose(dYG_i(i_desc_i, 2)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_i(1, l)%mm(:, jb) ) + else + r_tmp = r_tmp + matmul(transpose(dYG_r(i_desc_i, 1)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_r(2, l)%mm(:, jb) ) + matmul(transpose(dYG_i(i_desc_i, 1)%x(l, n_i)%mm(:, ir+1:ir+3)), Y_i(2, l)%mm(:, jb) ) + endif + grad_descriptor_i(i_pow, :) = r_tmp * tlpo * sym_facs(ik) + i_pow = i_pow + this%l_max + 1 + enddo + enddo + + !original power spectrum gradients as special case to exploit sparsity of dX_r w.r.t the neighbour species + else + do l = 0, this%l_max + tlpo = 1.0_dp + if (do_two_l_plus_one) tlpo = 1.0_dp / sqrt(2.0_dp * l + 1.0_dp) + !TODO try swapping order? + call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_r(l)%mm, 2*l+1, dXG_r(i_desc_i)%x(l, n_i)%mm, 2*l+1, 0.0_dp, Pl_g1, K1) + call dgemm('T','N', K1, 3 * this%n_max, 2*l+1, tlpo, X_i(l)%mm, 2*l+1, dXG_i(i_desc_i)%x(l, n_i)%mm, 2*l+1, 1.0_dp, Pl_g1, K1) + + i_pow = l + 1 + do ia = 1, K1 + a = rs_index(1,ia) + i_species = rs_index(2,ia) + do jb = 1, ia + b = rs_index(1,jb) + j_species = rs_index(2,jb) + if (this%diagonal_radial .and. a /= b) cycle + if(at%Z(j) == this%species_Z(i_species) .or. this%species_Z(i_species)==0) then + ic = (a-1) * 3 + grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(jb, ic+1:ic+3) + endif + if(at%Z(j) == this%species_Z(j_species) .or. this%species_Z(j_species)==0) then + ic = (b-1) * 3 + grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) + Pl_g1(ia, ic+1:ic+3) + endif + + if(ia /= jb) grad_descriptor_i(i_pow, :) = grad_descriptor_i(i_pow, :) * SQRT_TWO + i_pow = i_pow + this%l_max+1 + enddo !jb + enddo !ia + enddo !l + endif !various gradient options + + grad_descriptor_i(d, 1:3) = 0.0_dp + if( this%normalise ) then + descriptor_out%x(1)%grad_data(:,:,i_pair) = grad_descriptor_i / norm_descriptor_i + do k = 1, 3 + descriptor_out%x(1)%grad_data(:,k,i_pair) = descriptor_out%x(1)%grad_data(:,k,i_pair) - descriptor_i * dot_product(descriptor_i,grad_descriptor_i(:,k)) / norm_descriptor_i**3 + enddo + else + descriptor_out%x(1)%grad_data(:,:,i_pair) = grad_descriptor_i + endif + + descriptor_out%x(1)%grad_data(:,:,i_pair_i) = descriptor_out%x(1)%grad_data(:,:,i_pair_i) - descriptor_out%x(1)%grad_data(:,:,i_pair) + enddo !n_i + enddo !i + deallocate(grad_descriptor_i) + endif ! do gradients + + if(allocated(descriptor_i)) deallocate(descriptor_i) + endif ! this%global + + if(allocated(global_fourier_so3_r_array)) deallocate(global_fourier_so3_r_array) + if(allocated(global_fourier_so3_i_array)) deallocate(global_fourier_so3_i_array) + + if(allocated(global_grad_fourier_so3_r_array)) then + do i_desc_i = lbound(global_grad_fourier_so3_r_array,1), ubound(global_grad_fourier_so3_r_array,1) + if(allocated(global_grad_fourier_so3_r_array(i_desc_i)%x)) then + do n_i = lbound(global_grad_fourier_so3_r_array(i_desc_i)%x,3), ubound(global_grad_fourier_so3_r_array(i_desc_i)%x,3) + do a = lbound(global_grad_fourier_so3_r_array(i_desc_i)%x,2), ubound(global_grad_fourier_so3_r_array(i_desc_i)%x,2) + do l = lbound(global_grad_fourier_so3_r_array(i_desc_i)%x,1), ubound(global_grad_fourier_so3_r_array(i_desc_i)%x,1) + if(allocated(global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm)) deallocate(global_grad_fourier_so3_r_array(i_desc_i)%x(l,a,n_i)%mm) + enddo ! l + enddo ! a + enddo ! n_i + deallocate(global_grad_fourier_so3_r_array(i_desc_i)%x) + endif + enddo ! i_desc_i + deallocate(global_grad_fourier_so3_r_array) + endif + + if(allocated(global_grad_fourier_so3_i_array)) then + do i_desc_i = lbound(global_grad_fourier_so3_i_array,1), ubound(global_grad_fourier_so3_i_array,1) + if(allocated(global_grad_fourier_so3_i_array(i_desc_i)%x)) then + do n_i = lbound(global_grad_fourier_so3_i_array(i_desc_i)%x,3), ubound(global_grad_fourier_so3_i_array(i_desc_i)%x,3) + do a = lbound(global_grad_fourier_so3_i_array(i_desc_i)%x,2), ubound(global_grad_fourier_so3_i_array(i_desc_i)%x,2) + do l = lbound(global_grad_fourier_so3_i_array(i_desc_i)%x,1), ubound(global_grad_fourier_so3_i_array(i_desc_i)%x,1) + if(allocated(global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm)) deallocate(global_grad_fourier_so3_i_array(i_desc_i)%x(l,a,n_i)%mm) + enddo ! l + enddo ! a + enddo ! n_i + deallocate(global_grad_fourier_so3_i_array(i_desc_i)%x) + endif + enddo ! i_desc_i + deallocate(global_grad_fourier_so3_i_array) + endif + + !deallocate gradients for standard global soap + if (allocated(dXG_r)) then + do i_desc_i = lbound(dXG_r,1), ubound(dXG_r,1) + if (allocated(dXG_r(i_desc_i)%x)) then + do n_i = lbound(dXG_r(i_desc_i)%x,2), ubound(dXG_r(i_desc_i)%x,2) + do l = 0, this%l_max + if (allocated(dXG_r(i_desc_i)%x(l, n_i)%mm)) deallocate(dXG_r(i_desc_i)%x(l, n_i)%mm) + if (allocated(dXG_i(i_desc_i)%x(l, n_i)%mm)) deallocate(dXG_i(i_desc_i)%x(l, n_i)%mm) + enddo !l + enddo !n_i + deallocate(dXG_r(i_desc_i)%x) + deallocate(dXG_i(i_desc_i)%x) + endif + enddo + deallocate(dXG_r, dXG_i) + endif + + if (allocated(dYG_r)) then + do i_desc_i = lbound(dYG_r,1), ubound(dYG_r,1) + do k = 1, 2 + if (allocated(dYG_r(i_desc_i, k)%x)) then + do n_i = lbound(dYG_r(i_desc_i, k)%x,2), ubound(dYG_r(i_desc_i, k)%x,2) + do l = 0, this%l_max + if (allocated(dYG_r(i_desc_i, k)%x(l, n_i)%mm)) deallocate(dYG_r(i_desc_i, k)%x(l, n_i)%mm) + if (allocated(dYG_i(i_desc_i, k)%x(l, n_i)%mm)) deallocate(dYG_i(i_desc_i, k)%x(l, n_i)%mm) + enddo !l + enddo !n_i + deallocate(dYG_r(i_desc_i, k)%x) + deallocate(dYG_i(i_desc_i, k)%x) + endif + enddo + enddo + deallocate(dYG_r, dYG_i) + endif + + + !deallocate density expansion coefficients + if (allocated(X_r)) then + do l = 0, this%l_max + if (allocated(X_r(l)%mm)) deallocate(X_r(l)%mm) + if (allocated(X_i(l)%mm)) deallocate(X_i(l)%mm) + enddo + if (allocated(X_r)) deallocate(X_r) + if (allocated(X_i)) deallocate(X_i) + endif + + if (allocated(Y_r)) then + do k = 1, 2 + do l = 0, this%l_max + if (allocated(Y_r(k, l)%mm)) deallocate(Y_r(k, l)%mm) + if (allocated(Y_i(k, l)%mm)) deallocate(Y_i(k, l)%mm) + enddo + enddo + if (allocated(Y_r)) deallocate(Y_r) + if (allocated(Y_i)) deallocate(Y_i) + endif + + if (allocated(Pl_g1)) deallocate(Pl_g1) + if (allocated(Pl_g2)) deallocate(Pl_g2) + if (allocated(W)) deallocate(W) + if (allocated(Pl)) deallocate(Pl) + if (allocated(rs_index)) deallocate(rs_index) + if (allocated(i_desc)) deallocate(i_desc) + if (allocated(coupling_inds)) deallocate(coupling_inds) + if (allocated(sym_facs)) deallocate(sym_facs) + + call system_timer('soap_calc') + + endsubroutine soap_calc + + + subroutine rdf_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(rdf), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, i, j, n, i_n, l_n_neighbours, i_desc, n_descriptors, n_cross, n_index + integer, dimension(3) :: shift + real(dp) :: r_ij, f_cut, df_cut + real(dp), dimension(3) :: u_ij + real(dp), dimension(:), allocatable :: rdf_ij + + INIT_ERROR(error) + + call system_timer('rdf_calc') + + if(.not. this%initialised) then + RAISE_ERROR("rdf_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='rdf_calc args_str')) then + RAISE_ERROR("rdf_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("rdf_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + call finalise(descriptor_out) + + d = rdf_dimensions(this,error) + allocate(rdf_ij(d)) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + i_desc = i_desc + 1 + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + i_desc = 0 + do i = 1, at%N + + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + i_n = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) + + if( r_ij >= this%cutoff ) cycle + i_n = i_n + 1 + + rdf_ij = exp( -0.5_dp * (r_ij - this%r_gauss)**2 / this%w_gauss**2 ) + f_cut = coordination_function(r_ij,this%cutoff,this%transition_width) + + if(my_do_descriptor) & + descriptor_out%x(i_desc)%data = descriptor_out%x(i_desc)%data + rdf_ij * f_cut + + if(my_do_grad_descriptor) then + df_cut = dcoordination_function(r_ij,this%cutoff,this%transition_width) + + descriptor_out%x(i_desc)%ii(i_n) = j + descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift) + descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. + + descriptor_out%x(i_desc)%grad_data(:,:,i_n) = ( - ( rdf_ij * (r_ij - this%r_gauss) / this%w_gauss**2 ) * f_cut + rdf_ij * df_cut ) .outer. u_ij + descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,i_n) + endif + enddo + enddo + + if(allocated(rdf_ij)) deallocate(rdf_ij) + + call system_timer('rdf_calc') + + endsubroutine rdf_calc + + subroutine as_distance_2b_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(as_distance_2b), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(descriptor) :: my_coordination + type(descriptor_data) :: descriptor_coordination + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor, Zi1, Zi2, Zj1, Zj2 + integer :: d, n_descriptors, n_cross, i_desc, i, j, k, n, m, & + n_neighbours_coordination_i, n_neighbours_coordination_ij, n_index + integer, dimension(3) :: shift + real(dp) :: r_ij, r_ik, r_jk, cos_ijk, cos_jik, f_cut_i, f_cut_j, f_cut_ij, f_cut_ik, f_cut_jk, f_cut_as_i, f_cut_as_j, rho_i, rho_j + real(dp), dimension(3) :: u_ij, u_ik, u_jk + + INIT_ERROR(error) + call system_timer('as_distance_2b_calc') + + if(.not. this%initialised) then + RAISE_ERROR("as_distance_2b_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='as_distance_2b_calc args_str')) then + RAISE_ERROR("as_distance_2b_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("as_distance_2b_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + RAISE_ERROR("as_distance_2b_calc cannot use atom masks yet.",error) + else + atom_mask_pointer => null() + endif + + endif + + d = as_distance_2b_dimensions(this,error) + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + + + allocate(descriptor_out%x(n_descriptors)) + i_desc = 0 + do i = 1, at%N + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij) + + if(r_ij > this%max_cutoff .or. r_ij < this%min_cutoff) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + rho_i = 0.0_dp + f_cut_i = 0.0_dp + + do m = 1, n_neighbours(at,i) + k = neighbour(at, i, m, distance=r_ik, cosines=u_ik) + + if(r_ik > this%coordination_cutoff) cycle + + cos_ijk = dot_product(u_ij,u_ik) + f_cut_ik = coordination_function(r_ik,this%coordination_cutoff,this%coordination_transition_width) + + f_cut_i = f_cut_i + f_cut_ik + rho_i = rho_i + 0.5_dp * ( erf(cos_ijk/this%overlap_alpha) + 1.0_dp ) * f_cut_ik**2 + enddo + + rho_i = rho_i / f_cut_i + + if(rho_i > this%as_cutoff) cycle + + rho_j = 0.0_dp + f_cut_j = 0.0_dp + + do m = 1, n_neighbours(at,j) + k = neighbour(at, j, m, distance=r_jk, cosines=u_jk) + + if(r_jk > this%coordination_cutoff) cycle + + cos_jik = dot_product(-u_ij,u_jk) + f_cut_jk = coordination_function(r_jk,this%coordination_cutoff,this%coordination_transition_width) + + f_cut_j = f_cut_j + f_cut_jk + rho_j = rho_j + 0.5_dp * ( erf(cos_jik/this%overlap_alpha) + 1.0_dp ) * f_cut_jk**2 + enddo + + if(rho_j > this%as_cutoff) cycle + ! all three conditions fulfilled: pair within lower and upper cutoff, asymmetricity lower than threshold + + i_desc = i_desc + 1 + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + endif + + if(my_do_grad_descriptor) then + n_neighbours_coordination_ij = n_neighbours(at,i,max_dist=this%coordination_cutoff) + & + n_neighbours(at,j,max_dist=this%coordination_cutoff) + 2 + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:1+n_neighbours_coordination_ij)) + allocate(descriptor_out%x(i_desc)%ii(0:1+n_neighbours_coordination_ij)) + allocate(descriptor_out%x(i_desc)%pos(3,0:1+n_neighbours_coordination_ij)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:1+n_neighbours_coordination_ij)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:1+n_neighbours_coordination_ij)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + enddo + + i_desc = 0 + do i = 1, at%N + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, cosines = u_ij, shift=shift) + + if(r_ij > this%max_cutoff .or. r_ij < this%min_cutoff) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + rho_i = 0.0_dp + f_cut_i = 0.0_dp + + do m = 1, n_neighbours(at,i) + k = neighbour(at, i, m, distance=r_ik, cosines=u_ik) + + if(r_ik > this%coordination_cutoff) cycle + + cos_ijk = dot_product(u_ij,u_ik) + f_cut_ik = coordination_function(r_ik,this%coordination_cutoff,this%coordination_transition_width) + + f_cut_i = f_cut_i + f_cut_ik + rho_i = rho_i + 0.5_dp * ( erf(cos_ijk/this%overlap_alpha) + 1.0_dp ) * f_cut_ik**2 + enddo + + rho_i = rho_i / f_cut_i + + if(rho_i > this%as_cutoff) cycle + + rho_j = 0.0_dp + f_cut_j = 0.0_dp + + do m = 1, n_neighbours(at,j) + k = neighbour(at, j, m, distance=r_jk, cosines=u_jk) + + if(r_jk > this%coordination_cutoff) cycle + + cos_jik = dot_product(-u_ij,u_jk) + f_cut_jk = coordination_function(r_jk,this%coordination_cutoff,this%coordination_transition_width) + + f_cut_j = f_cut_j + f_cut_jk + rho_j = rho_j + 0.5_dp * ( erf(cos_jik/this%overlap_alpha) + 1.0_dp ) * f_cut_jk**2 + enddo + + if(rho_j > this%as_cutoff) cycle + ! all three conditions fulfilled: pair within lower and upper cutoff, asymmetricity lower than threshold + + i_desc = i_desc + 1 + + f_cut_ij = coordination_function(r_ij,this%max_cutoff,this%max_transition_width,this%min_cutoff,this%min_transition_width) + f_cut_as_i = coordination_function(rho_i,this%as_cutoff, this%as_transition_width) + f_cut_as_j = coordination_function(rho_j,this%as_cutoff, this%as_transition_width) + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1:2) = (/i,j/) + + descriptor_out%x(i_desc)%has_data = .true. + + descriptor_out%x(i_desc)%data(1) = r_ij + descriptor_out%x(i_desc)%data(2) = f_cut_i + f_cut_j + descriptor_out%x(i_desc)%data(3) = (f_cut_i - f_cut_j)**2 + + descriptor_out%x(i_desc)%covariance_cutoff = f_cut_ij * f_cut_as_i * f_cut_as_j + endif + if(my_do_grad_descriptor) then + n_neighbours_coordination_i = n_neighbours(at,i,max_dist=this%coordination_cutoff) + + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + descriptor_out%x(i_desc)%grad_data(1,:,0) = -u_ij(:) + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) = -dcoordination_function(r_ij,this%coordination_cutoff,this%coordination_transition_width)*u_ij + + !descriptor_out%x(i_desc)%ii(1) = j + !descriptor_out%x(i_desc)%pos(:,1) = at%pos(:,j) + matmul(at%lattice,shift) + !descriptor_out%x(i_desc)%has_grad_data(1) = .true. + !descriptor_out%x(i_desc)%grad_data(1,:,1) = u_ij(:) + !descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = -descriptor_out%x(i_desc)%grad_covariance_cutoff(:,0) + + !descriptor_out%x(i_desc)%ii(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%ii(:) + !descriptor_out%x(i_desc)%pos(:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%pos(:,:) + !descriptor_out%x(i_desc)%has_grad_data(2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%has_grad_data(:) + !descriptor_out%x(i_desc)%grad_data(2,:,2:n_neighbours_coordination_i+2) = descriptor_coordination%x(i)%grad_data(1,:,:) + !descriptor_out%x(i_desc)%grad_data(3,:,2:n_neighbours_coordination_i+2) = 2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& + ! descriptor_coordination%x(i)%grad_data(1,:,:) + + !descriptor_out%x(i_desc)%ii(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%ii(:) + !descriptor_out%x(i_desc)%pos(:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%pos(:,:) + !descriptor_out%x(i_desc)%has_grad_data(n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%has_grad_data(:) + !descriptor_out%x(i_desc)%grad_data(2,:,n_neighbours_coordination_i+3:) = descriptor_coordination%x(j)%grad_data(1,:,:) + !descriptor_out%x(i_desc)%grad_data(3,:,n_neighbours_coordination_i+3:) = -2.0_dp*(descriptor_coordination%x(i)%data(1) - descriptor_coordination%x(j)%data(1))*& + ! descriptor_coordination%x(j)%grad_data(1,:,:) + + endif + enddo + enddo + + call finalise(my_coordination) + call finalise(descriptor_coordination) + + call system_timer('as_distance_2b_calc') + + endsubroutine as_distance_2b_calc + + + subroutine alex_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(alex), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor + + integer :: i, j, n, d, p, q, r, a, b, c, n_i, n_radial, pp, i_desc, & + l_n_neighbours, desc_index, n_cross, n_descriptors, n_index + integer, dimension(3) :: shift_ij + real(dp) :: r_ij + real(dp), dimension(3) :: d_ij + real(dp), dimension(:), allocatable :: neighbour_dists + real(dp), dimension(:,:), allocatable :: neighbour_vecs + integer, dimension(total_elements) :: species_map + real(dp), allocatable :: S0(:), S1(:,:), S2(:,:,:), S0der(:,:,:), S1der(:,:,:,:), S2der(:,:,:,:,:) + + INIT_ERROR(error) + + call system_timer('alex_calc') + + if(.not. this%initialised) then + RAISE_ERROR("alex_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='alex_calc args_str')) then + RAISE_ERROR("alex_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("alex_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + species_map = 0 + do i = 1, size(this%species_Z) + if(this%species_Z(i) == 0) then + species_map = 1 + else + species_map(this%species_Z(i)) = i + endif + enddo + + call finalise(descriptor_out) + + d = alex_dimensions(this,error) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + + n_radial = this%power_max-this%power_min+1 + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + + i_desc = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + + ! number of neighbours for the current atom within the descriptor cutoff + l_n_neighbours = n_neighbours(at,i,max_dist=this%cutoff) + allocate(neighbour_vecs(3,l_n_neighbours), neighbour_dists(l_n_neighbours)) + allocate(S0(n_radial), S1(3,n_radial), S2(3,3,n_radial)) + if(my_do_grad_descriptor) then + allocate( & + S0der(n_radial,l_n_neighbours,3), & + S1der(3,n_radial,l_n_neighbours,3), & + S2der(3,3,n_radial,l_n_neighbours,3) ) + endif + + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, diff=d_ij) + if( r_ij >= this%cutoff ) cycle + n_i = n_i + 1 + neighbour_vecs(:,n_i) = d_ij + neighbour_dists(n_i) = r_ij + end do + + do p = 1,n_radial + pp = -(p+this%power_min-1) + S0(p) = sum(neighbour_dists**pp) + if(my_do_grad_descriptor) then + do n_i = 1, l_n_neighbours + S0der(p,n_i,:) = pp * neighbour_dists(n_i)**(pp-2) * neighbour_vecs(:,n_i) + enddo + endif + + S1(:,p) = matmul(neighbour_vecs, neighbour_dists**pp) + !do a = 1,3 + !S1(a, p) = sum(neighbour_vecs(a,:)*neighbour_dists**pp) + !end do + if(my_do_grad_descriptor) then + do n_i = 1, l_n_neighbours + do a = 1,3 + S1der(a,p,n_i,:) = pp * neighbour_dists(n_i)**(pp-2) * neighbour_vecs(a,n_i) * neighbour_vecs(:,n_i) + S1der(a,p,n_i,a) = S1der(a,p,n_i,a) + neighbour_dists(n_i)**pp + end do + enddo + endif + + !do a=1,3 + do b=1,3 + S2(:,b,p) = matmul(neighbour_vecs, neighbour_vecs(b,:)*neighbour_dists**pp) + !S2(a,b,p) = sum(neighbour_vecs(a,:)*neighbour_vecs(b,:)*neighbour_dists**pp) + end do + !end do + + if(my_do_grad_descriptor) then + do n_i = 1, l_n_neighbours + do a = 1,3 + do b = 1,3 + S2der(a,b,p,n_i,:) = pp * neighbour_dists(n_i)**(pp-2) * neighbour_vecs(a,n_i) * neighbour_vecs(b,n_i) * neighbour_vecs(:,n_i) + end do + end do + + do a = 1,3 + do b = 1,3 + S2der(a,b,p,n_i,b) = S2der(a,b,p,n_i,b) + neighbour_dists(n_i)**pp * neighbour_vecs(a,n_i) + S2der(a,b,p,n_i,a) = S2der(a,b,p,n_i,a) + neighbour_dists(n_i)**pp * neighbour_vecs(b,n_i) + end do + end do + enddo + endif + end do + + descriptor_out%x(i_desc)%data(1:n_radial) = S0 + descriptor_out%x(i_desc)%data(n_radial+1:n_radial+n_radial**2) = reshape(matmul(transpose(S1), S1), (/n_radial**2/)) + desc_index = n_radial+n_radial**2+1 + do p = 1,n_radial + do q = 1,n_radial + descriptor_out%x(i_desc)%data(desc_index) = sum(S2(:,:,p) * S2(:,:,q)) + desc_index = desc_index + 1 + end do + end do + + do p = 1,n_radial + do q = 1,n_radial + do r = 1,n_radial + descriptor_out%x(i_desc)%data(desc_index) = dot_product(S1(:,p), matmul(S2(:,:,q), S1(:,r))) + desc_index = desc_index + 1 + end do + end do + end do + + if(my_do_grad_descriptor) then + n_i = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, shift=shift_ij) + if( r_ij >= this%cutoff ) cycle + + n_i = n_i + 1 + + descriptor_out%x(i_desc)%ii(n_i) = j + descriptor_out%x(i_desc)%pos(:,n_i) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(n_i) = .true. + + descriptor_out%x(i_desc)%grad_data(1:n_radial,:,n_i) = S0der(:,n_i,:) + + desc_index = n_radial + 1 + do p = 1,n_radial + do q = 1,n_radial + do a = 1, 3 + do c = 1, 3 + descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) = descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) + & + S1der(a,p,n_i,c)*S1(a,q) + S1(a,p)*S1der(a,q,n_i,c) + enddo + enddo + desc_index = desc_index + 1 + enddo + enddo + + do p = 1, n_radial + do q = 1, n_radial + do a = 1, 3 + do b = 1, 3 + do c = 1, 3 + descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) = descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) + & + S2der(a,b,p,n_i,c)*S2(a,b,q) + S2(a,b,p)*S2der(a,b,q,n_i,c) + enddo + enddo + enddo + desc_index = desc_index + 1 + enddo + enddo + + do p = 1, n_radial + do q = 1, n_radial + do r = 1, n_radial + do a = 1, 3 + do b = 1, 3 + do c = 1, 3 + descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) = descriptor_out%x(i_desc)%grad_data(desc_index,c,n_i) + & + S1der(a,p,n_i,c) * S2(a,b,q) * S1(b,r) + & + S1(a,p) * S2der(a,b,q,n_i,c) * S1(b,r) + & + S1(a,p) * S2(a,b,q) * S1der(b,r,n_i,c) + enddo + enddo + enddo + desc_index = desc_index + 1 + enddo + enddo + enddo + enddo + + descriptor_out%x(i_desc)%grad_data(:,:,0) = descriptor_out%x(i_desc)%grad_data(:,:,0) - descriptor_out%x(i_desc)%grad_data(:,:,n_i) + deallocate(S0der, S1der, S2der) + endif + + deallocate(neighbour_vecs, neighbour_dists, S0, S1, S2) + enddo + + + call system_timer('alex_calc') + + endsubroutine alex_calc + + subroutine distance_Nb_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + type(distance_Nb), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + + logical :: my_do_descriptor, my_do_grad_descriptor + integer :: d, n_descriptors, n_cross, i_desc, i_data, i, j, ii, jj, kk, ll, & + iConnectivity, n_index + integer, dimension(3) :: s_i, s_j + real(dp) :: r_ij, fcut_connectivity + real(dp), dimension(3) :: dfcut_connectivity + real(dp), dimension(3) :: d_ij + integer, dimension(:,:,:), allocatable :: atoms_in_descriptors + real(dp), dimension(:,:), allocatable :: fcut_pair, dfcut_pair + real(dp), dimension(:,:,:), allocatable :: directions + + logical, dimension(:), pointer :: atom_mask_pointer => null() + + INIT_ERROR(error) + + call system_timer('distance_Nb_calc') + + if(.not. this%initialised) then + RAISE_ERROR("distance_Nb_calc: descriptor object not initialised", error) + endif + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + + call finalise(descriptor_out) + + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='distance_Nb_calc args_str')) then + RAISE_ERROR("distance_Nb_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + atom_mask_pointer => null() + + if( has_atom_mask_name ) then + if( .not. this%compact_clusters ) then + RAISE_ERROR("distance_Nb_calc: MPI/LAMMPS ready only for compact_clusters=T type of distance_Nb.", error) + endif + + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("distance_Nb_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + d = distance_Nb_dimensions(this,error) + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask = atom_mask_pointer,n_index=n_index, error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + do i = 1, n_descriptors + if(my_do_descriptor) then + allocate(descriptor_out%x(i)%data(d)) + descriptor_out%x(i)%data = 0.0_dp + allocate(descriptor_out%x(i)%ci(n_index)) + descriptor_out%x(i)%ci = 0 + descriptor_out%x(i)%has_data = .false. + descriptor_out%x(i)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then + allocate(descriptor_out%x(i)%grad_data(d,3,this%order)) + allocate(descriptor_out%x(i)%ii(this%order)) + allocate(descriptor_out%x(i)%pos(3,this%order)) + allocate(descriptor_out%x(i)%has_grad_data(this%order)) + descriptor_out%x(i)%grad_data = 0.0_dp + descriptor_out%x(i)%ii = 0 + descriptor_out%x(i)%pos = 0.0_dp + descriptor_out%x(i)%has_grad_data = .false. + + allocate(descriptor_out%x(i)%grad_covariance_cutoff(3,this%order)) + descriptor_out%x(i)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + if(associated(atom_mask_pointer)) then + call distance_Nb_calc_get_clusters(this,at,atoms_in_descriptors=atoms_in_descriptors,mask=atom_mask_pointer,error=error) + else + call distance_Nb_calc_get_clusters(this,at,atoms_in_descriptors=atoms_in_descriptors,error=error) + endif + + allocate(fcut_pair(this%order,this%order)) + if( my_do_grad_descriptor ) then + allocate(dfcut_pair(this%order,this%order), directions(3,this%order,this%order)) + endif + + do i_desc = 1, n_descriptors + if( this%order == 1 ) then + descriptor_out%x(i_desc)%data = 0.0_dp + if( my_do_grad_descriptor ) descriptor_out%x(i_desc)%grad_data = 0.0_dp + else + i_data = 0 + do ii = 1, this%order + i = atoms_in_descriptors(1,ii,i_desc) + s_i = atoms_in_descriptors(2:4,ii,i_desc) + do jj = ii+1, this%order + i_data = i_data + 1 + j = atoms_in_descriptors(1,jj,i_desc) + s_j = atoms_in_descriptors(2:4,jj,i_desc) + d_ij = at%pos(:,j) - at%pos(:,i) + matmul(at%lattice,s_j-s_i) + r_ij = sqrt(sum(d_ij**2)) + + fcut_pair(jj,ii) = coordination_function(r_ij,this%cutoff,this%cutoff_transition_width) + fcut_pair(ii,jj) = fcut_pair(jj,ii) + + descriptor_out%x(i_desc)%data(i_data) = r_ij + if( my_do_grad_descriptor ) then + dfcut_pair(ii,jj) = dcoordination_function(r_ij,this%cutoff,this%cutoff_transition_width) + dfcut_pair(jj,ii) = dfcut_pair(ii,jj) + + directions(:,ii,jj) = d_ij / r_ij + directions(:,jj,ii) = - directions(:,ii,jj) + descriptor_out%x(i_desc)%grad_data(i_data,:,jj) = directions(:,ii,jj) + descriptor_out%x(i_desc)%grad_data(i_data,:,ii) = & + - descriptor_out%x(i_desc)%grad_data(i_data,:,jj) + endif + enddo + enddo + + descriptor_out%x(i_desc)%covariance_cutoff = 0.0_dp + if ( this%compact_clusters ) then + + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + + do jj = 2, this%order + descriptor_out%x(i_desc)%covariance_cutoff = descriptor_out%x(i_desc)%covariance_cutoff * fcut_pair(jj,1) + enddo + + if( my_do_grad_descriptor ) then + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = 0.0_dp + do kk = 2, this%order + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = 1.0_dp + do jj = 2, this%order + if( jj == kk ) then + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = & + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) * dfcut_pair(jj,1) * (-directions(:,jj,1)) + else + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = & + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) * fcut_pair(jj,1) + endif + enddo + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) = & + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,1) - descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) + enddo + endif + + + else + do iConnectivity = 1, size(this%monomerConnectivities,3) + + fcut_connectivity = 1.0_dp + + do ii = 1, this%order + do jj = ii+1, this%order + if( this%monomerConnectivities(jj,ii,iConnectivity) ) then + fcut_connectivity = fcut_connectivity * fcut_pair(jj,ii) + else + fcut_connectivity = fcut_connectivity * ( 1.0_dp - fcut_pair(jj,ii) ) + endif + enddo + enddo + descriptor_out%x(i_desc)%covariance_cutoff = descriptor_out%x(i_desc)%covariance_cutoff + fcut_connectivity + + if( my_do_grad_descriptor ) then + do kk = 1, this%order + do ll = kk+1, this%order + dfcut_connectivity = 1.0_dp + do ii = 1, this%order + do jj = ii+1, this%order + if( this%monomerConnectivities(jj,ii,iConnectivity) ) then + if( kk == ii .and. ll == jj ) then + dfcut_connectivity = dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) + elseif( kk == jj .and. ll == ii ) then + dfcut_connectivity = dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) + else + dfcut_connectivity = dfcut_connectivity * fcut_pair(jj,ii) + endif + else + if( kk == ii .and. ll == jj ) then + dfcut_connectivity = - dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) + elseif( kk == jj .and. ll == ii) then + dfcut_connectivity = - dfcut_connectivity * dfcut_pair(jj,ii) * directions(:,ll,kk) + else + dfcut_connectivity = dfcut_connectivity * ( 1.0_dp - fcut_pair(jj,ii) ) + endif + endif + enddo !jj + enddo !ii + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) = descriptor_out%x(i_desc)%grad_covariance_cutoff(:,kk) + & + dfcut_connectivity + descriptor_out%x(i_desc)%grad_covariance_cutoff(:,ll) = descriptor_out%x(i_desc)%grad_covariance_cutoff(:,ll) - & + dfcut_connectivity + enddo !ll + enddo !kk + endif + + enddo + endif + + endif + + descriptor_out%x(i_desc)%ci = atoms_in_descriptors(1,:,i_desc) + descriptor_out%x(i_desc)%has_data = .true. + if( my_do_grad_descriptor ) then + descriptor_out%x(i_desc)%ii = descriptor_out%x(i_desc)%ci + descriptor_out%x(i_desc)%pos = at%pos(:,descriptor_out%x(i_desc)%ii) + & + matmul(at%lattice,atoms_in_descriptors(2:4,:,i_desc)) + descriptor_out%x(i_desc)%has_grad_data = .true. + endif + + enddo + + if(allocated(atoms_in_descriptors)) deallocate(atoms_in_descriptors) + if(allocated(fcut_pair)) deallocate(fcut_pair) + if(allocated(dfcut_pair)) deallocate(dfcut_pair) + if(allocated(directions)) deallocate(directions) + + call system_timer('distance_Nb_calc') + + endsubroutine distance_Nb_calc + + subroutine soap_turbo_calc(this,at,descriptor_out,do_descriptor,do_grad_descriptor,args_str,error) + use soap_turbo_desc + + type(soap_turbo), intent(in) :: this + type(atoms), intent(in) :: at + type(descriptor_data), intent(out) :: descriptor_out + logical, intent(in), optional :: do_descriptor, do_grad_descriptor + character(len=*), intent(in), optional :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + logical :: my_do_descriptor, my_do_grad_descriptor, do_timing + integer :: d, i, j, k, n, i_n, l_n_neighbours, & + i_desc, n_descriptors, n_cross, n_index, n_atom_pairs + real(dp) :: r_ij + real(dp), dimension(3) :: d_ij, u_ij + real(dp), dimension(:), allocatable :: rjs, thetas, phis, rcut_hard, rcut_soft, nf, global_scaling + real(dp), dimension(:,:), allocatable :: descriptor_i + real(dp), dimension(:,:,:), allocatable :: grad_descriptor_i + integer, dimension(:), allocatable :: species_map + integer, dimension(3) :: shift_ij + logical, dimension(:,:), allocatable :: mask + + INIT_ERROR(error) + + call system_timer('soap_turbo_calc') + + if(.not. this%initialised) then + RAISE_ERROR("soap_turbo_calc: descriptor object not initialised", error) + endif + +! This is to make the code compatible with the newest TurboGAP (which as multisoap support) + allocate( rcut_hard(this%n_species) ) + allocate( rcut_soft(this%n_species) ) + allocate( nf(this%n_species) ) + allocate( global_scaling(this%n_species) ) + rcut_hard = this%rcut_hard + rcut_soft = this%rcut_soft + nf = this%nf + global_scaling = 1.0_dp + + my_do_descriptor = optional_default(.false., do_descriptor) + my_do_grad_descriptor = optional_default(.false., do_grad_descriptor) + + if( .not. my_do_descriptor .and. .not. my_do_grad_descriptor ) return + +! allocate(species_map(maxval(this%species_Z))) + allocate(species_map(1:118)) + species_map = 0 + species_map(this%species_Z) = (/(i, i = 1, this%n_species)/) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true descriptors are " // & + "calculated.") + + call param_register(params, 'do_timing', 'F', do_timing, help_string="Do timing or not") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='coordination_calc args_str')) then + RAISE_ERROR("soap_turbo_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("soap_turbo_calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + endif + + call finalise(descriptor_out) + + d = soap_turbo_dimensions(this,error) + + allocate(descriptor_i(d,1)) + + if(associated(atom_mask_pointer)) then + call descriptor_sizes(this,at,n_descriptors,n_cross, & + mask=atom_mask_pointer,n_index=n_index,error=error) + else + call descriptor_sizes(this,at,n_descriptors,n_cross,n_index=n_index,error=error) + endif + + allocate(descriptor_out%x(n_descriptors)) + i_desc = 0 + do i = 1, at%N + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + if( at%Z(i) /= this%species_Z(this%central_index) ) cycle + + i_desc = i_desc + 1 + if(my_do_descriptor) then + allocate(descriptor_out%x(i_desc)%data(d)) + descriptor_out%x(i_desc)%data = 0.0_dp + allocate(descriptor_out%x(i_desc)%ci(n_index)) + descriptor_out%x(i_desc)%has_data = .false. + + descriptor_out%x(i_desc)%covariance_cutoff = 1.0_dp + endif + if(my_do_grad_descriptor) then +! l_n_neighbours = n_neighbours(at,i,max_dist=this%rcut_hard) + l_n_neighbours = 0 + do n = 1, n_neighbours(at, i) + j = neighbour(at, i, n, distance = r_ij) +! The neighbors list past to the soap_turbo library must only contained the "seen" species + if( r_ij < this%rcut_hard .and. species_map(at%Z(j)) > 0)then + l_n_neighbours = l_n_neighbours + 1 + endif + enddo + allocate(descriptor_out%x(i_desc)%grad_data(d,3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%ii(0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%pos(3,0:l_n_neighbours)) + allocate(descriptor_out%x(i_desc)%has_grad_data(0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_data = 0.0_dp + descriptor_out%x(i_desc)%ii = 0 + descriptor_out%x(i_desc)%pos = 0.0_dp + descriptor_out%x(i_desc)%has_grad_data = .false. + + allocate(descriptor_out%x(i_desc)%grad_covariance_cutoff(3,0:l_n_neighbours)) + descriptor_out%x(i_desc)%grad_covariance_cutoff = 0.0_dp + endif + enddo + + i_desc = 0 + do i = 1, at%N + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + if( at%Z(i) /= this%species_Z(this%central_index) ) cycle + + i_desc = i_desc + 1 + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%ci(1) = i + descriptor_out%x(i_desc)%has_data = .true. + endif + if(my_do_grad_descriptor) then + descriptor_out%x(i_desc)%ii(0) = i + descriptor_out%x(i_desc)%pos(:,0) = at%pos(:,i) + descriptor_out%x(i_desc)%has_grad_data(0) = .true. + endif + +! n_atom_pairs = n_neighbours(at,i, max_dist = this%rcut_hard) + 1 !Including the central atom + n_atom_pairs = 1 !Including the central atom + do n = 1, n_neighbours(at, i) + j = neighbour(at, i, n, distance = r_ij) +! The neighbors list past to the soap_turbo library must only contained the "seen" species + if( r_ij < this%rcut_hard .and. species_map(at%Z(j)) > 0)then + n_atom_pairs = n_atom_pairs + 1 + endif + enddo + allocate( rjs(n_atom_pairs) ) + allocate( thetas(n_atom_pairs) ) + allocate( phis(n_atom_pairs) ) + allocate( mask(n_atom_pairs,this%n_species) ) + mask = .false. + + i_n = 1 ! Start with central atom + rjs(i_n) = 0.0_dp + thetas(i_n) = 0.0_dp + phis(i_n) = 0.0_dp + mask(i_n,species_map(at%Z(i))) = .true. + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, diff = d_ij, cosines = u_ij) + + if( r_ij >= this%rcut_hard .or. species_map(at%Z(j)) == 0 ) cycle + i_n = i_n + 1 + + rjs(i_n) = r_ij + + thetas(i_n) = dacos( u_ij(3) ) + phis(i_n) = datan2( d_ij(2), d_ij(1) ) + mask(i_n,species_map(at%Z(j))) = .true. + enddo + + if( my_do_grad_descriptor ) then + i_n = 0 + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij, shift = shift_ij) + if( r_ij >= this%rcut_hard .or. species_map(at%Z(j)) == 0 ) cycle + i_n = i_n + 1 + descriptor_out%x(i_desc)%ii(i_n) = j + descriptor_out%x(i_desc)%pos(:,i_n) = at%pos(:,j) + matmul(at%lattice,shift_ij) + descriptor_out%x(i_desc)%has_grad_data(i_n) = .true. + enddo + endif + + descriptor_i = 0.0_dp + if( my_do_grad_descriptor ) then + allocate(grad_descriptor_i(3,d,n_atom_pairs)) + grad_descriptor_i = 0.0_dp + endif + call get_soap(1, (/n_atom_pairs/), this%n_species, reshape( (/species_map(at%Z(i))/), (/1,1/)), (/1/), & + n_atom_pairs, mask, rjs, thetas, phis, this%alpha_max, this%l_max, rcut_hard, rcut_soft, nf, & + global_scaling, this%atom_sigma_r, this%atom_sigma_r_scaling, & + this%atom_sigma_t, this%atom_sigma_t_scaling, this%amplitude_scaling, this%radial_enhancement, this%central_weight, & + this%basis, this%scaling_mode, .false., my_do_grad_descriptor, this%compress, this%compress_P_nonzero, this%compress_P_i, & + this%compress_P_j, this%compress_P_el, descriptor_i, grad_descriptor_i) + + if(my_do_descriptor) then + descriptor_out%x(i_desc)%data = descriptor_i(:,1) + endif + + if(my_do_grad_descriptor) then + do k = 1, 3 + descriptor_out%x(i_desc)%grad_data(:,k,0:n_atom_pairs-1) = grad_descriptor_i(k,:,1:n_atom_pairs) + enddo + endif + + deallocate(rjs) + deallocate(thetas) + deallocate(phis) + deallocate(mask) + if(allocated(grad_descriptor_i)) deallocate(grad_descriptor_i) + enddo + + deallocate(descriptor_i) + deallocate(species_map) + deallocate(rcut_hard) + deallocate(rcut_soft) + deallocate(nf) + deallocate(global_scaling) + + call system_timer('soap_turbo_calc') + + endsubroutine soap_turbo_calc + + subroutine distance_Nb_calc_get_clusters(this,at,atoms_in_descriptors,n_descriptors,mask,error) + + type(distance_Nb), intent(in) :: this + type(atoms), intent(in) :: at + integer, dimension(:,:,:), intent(out), allocatable, optional :: atoms_in_descriptors + integer, intent(out), optional :: n_descriptors + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: error + + integer, dimension(:,:,:), allocatable :: my_atoms_in_descriptors + + if( present(atoms_in_descriptors) ) then + call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors,n_descriptors=n_descriptors,mask=mask,error=error) + else + call distance_Nb_calc_neighbour_loop(this,at,my_atoms_in_descriptors,n_descriptors=n_descriptors,mask=mask,error=error) + if(allocated(my_atoms_in_descriptors)) deallocate(my_atoms_in_descriptors) + endif + + endsubroutine distance_Nb_calc_get_clusters + +! recursive subroutine distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors,n_descriptors,error) +! +! type(distance_Nb), intent(in) :: this +! type(atoms), intent(in) :: at +! integer, dimension(:,:,:), intent(inout), allocatable :: atoms_in_descriptors +! integer, intent(out), optional :: n_descriptors +! integer, intent(out), optional :: error +! +! integer, save :: current_order = 0 +! integer :: i, j, n, order, i_desc, d +! real(dp) :: r_ij +! integer, dimension(3) :: shift_i, shift_j, shift_ij +! integer, dimension(:,:), allocatable :: current_descriptor +! +! type(LinkedList_i2d), pointer :: LL_atoms_in_descriptors => null() +! +! INIT_ERROR(error) +! +! current_order = current_order + 1 +! +! if( current_order == 1 ) then +! allocate(current_descriptor(4,1)) +! +! do i = 1, at%N +! if( any( at%Z(i) == this%Z ) .or. any( 0 == this%Z ) ) then +! current_descriptor(:,1) = (/i,0,0,0/) +! call append(LL_atoms_in_descriptors,current_descriptor,error) +! endif +! enddo +! +! deallocate(current_descriptor) +! call retrieve(LL_atoms_in_descriptors,atoms_in_descriptors) +! call finalise(LL_atoms_in_descriptors) +! if( this%order > 1 ) & +! call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) +! +! if( present(n_descriptors) ) n_descriptors = size(atoms_in_descriptors,3) +! else +! if( .not. allocated(atoms_in_descriptors) ) then +! RAISE_ERROR("distance_Nb_calc_neighbour_loop: atoms_in_descriptors must be allocated",error) +! endif +! +! allocate(current_descriptor(4,current_order)) +! do i_desc = 1, size(atoms_in_descriptors,3) +! do order = 1, size(atoms_in_descriptors,2) +! i = atoms_in_descriptors(1,order,i_desc) +! shift_i = atoms_in_descriptors(2:4,order,i_desc) +! loop_n: do n = 1, n_neighbours(at,i) +! j = neighbour(at,i,n,distance = r_ij, shift = shift_ij) +! +! if( r_ij > this%cutoff ) cycle +! if( .not. is_subset(this%Z, at%Z( (/j,atoms_in_descriptors(1,:,i_desc)/) ), error) .and. all(this%Z /= 0) ) cycle +! +! shift_j = shift_ij + shift_i +! +! current_descriptor(:,1:current_order-1) = atoms_in_descriptors(:,:,i_desc) +! current_descriptor(:,current_order) = (/j, shift_j/) +! if( order_and_check_for_duplicates(current_descriptor,at) ) then +! do d = current_order, 1, -1 +! current_descriptor(2:4,d) = current_descriptor(2:4,d) - current_descriptor(2:4,1) +! enddo +! if( .not. is_in_LinkedList(LL_atoms_in_descriptors,current_descriptor,error) ) & +! call append(LL_atoms_in_descriptors,current_descriptor,error) +! endif +! enddo loop_n +! enddo +! enddo +! +! deallocate(current_descriptor) +! call retrieve(LL_atoms_in_descriptors,atoms_in_descriptors) +! call finalise(LL_atoms_in_descriptors) +! if( current_order < this%order ) & +! call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) +! endif +! +! current_order = current_order - 1 +! +! endsubroutine distance_Nb_calc_neighbour_loop + + recursive subroutine distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors,n_descriptors,mask,error) + + type(distance_Nb), intent(in) :: this + type(atoms), intent(in) :: at + integer, dimension(:,:,:), intent(inout), allocatable :: atoms_in_descriptors + integer, intent(out), optional :: n_descriptors + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: error + + integer, save :: current_order = 0 + integer :: i, j, n, order, i_desc, d + real(dp) :: r_ij + integer, dimension(3) :: shift_i, shift_j, shift_ij + integer, dimension(:,:), allocatable :: current_descriptor + + type(Table) :: Table_atoms_in_descriptors, Table_atoms_in_descriptors_uniq + + INIT_ERROR(error) + + current_order = current_order + 1 + + if( current_order == 1 ) then + call initialise(Table_atoms_in_descriptors, Nint = 4*current_order, Nreal = 0, Nstr = 0, Nlogical = 0, error=error) + allocate(current_descriptor(4,1)) + + do i = 1, at%N + if( any( at%Z(i) == this%Z ) .or. any( 0 == this%Z ) ) then + if( present(mask) ) then + if( .not. mask(i) ) cycle + endif + + current_descriptor(:,1) = (/i,0,0,0/) + call append(Table_atoms_in_descriptors,current_descriptor(:,1)) + endif + enddo + + deallocate(current_descriptor) + + allocate(atoms_in_descriptors(4,1,Table_atoms_in_descriptors%N)) + atoms_in_descriptors = reshape(Table_atoms_in_descriptors%int(:,1:Table_atoms_in_descriptors%N),(/4,1,Table_atoms_in_descriptors%N/)) + + call finalise(Table_atoms_in_descriptors) + + if( this%order > 1 ) & + call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) + + if( present(n_descriptors) ) n_descriptors = size(atoms_in_descriptors,3) + else + if( .not. allocated(atoms_in_descriptors) ) then + RAISE_ERROR("distance_Nb_calc_neighbour_loop: atoms_in_descriptors must be allocated",error) + endif + + call initialise(Table_atoms_in_descriptors, Nint = 4*current_order, Nreal = 0, Nstr = 0, Nlogical = 0, error=error) + allocate(current_descriptor(4,current_order)) + + do i_desc = 1, size(atoms_in_descriptors,3) + do order = 1, merge(1,size(atoms_in_descriptors,2),this%compact_clusters) !size(atoms_in_descriptors,2) + ! if compact_clusters == T, only neighbours of the first (central) atom is considered + i = atoms_in_descriptors(1,order,i_desc) + shift_i = atoms_in_descriptors(2:4,order,i_desc) + loop_n: do n = 1, n_neighbours(at,i) + j = neighbour(at,i,n,distance = r_ij, shift = shift_ij) + + if( r_ij > this%cutoff ) cycle + if( .not. is_subset(this%Z, at%Z( (/j,atoms_in_descriptors(1,:,i_desc)/) ), error) .and. all(this%Z /= 0) ) cycle + + shift_j = shift_ij + shift_i + + current_descriptor(:,1:current_order-1) = atoms_in_descriptors(:,:,i_desc) + current_descriptor(:,current_order) = (/j, shift_j/) + if( order_and_check_for_duplicates(current_descriptor(:,merge(2,1,this%compact_clusters):),at) ) then + ! if compact_clusters == T, leave first atom alone + do d = current_order, 1, -1 + current_descriptor(2:4,d) = current_descriptor(2:4,d) - current_descriptor(2:4,1) + enddo + call append(Table_atoms_in_descriptors,reshape(current_descriptor,(/4*current_order/))) + + !if( .not. is_in_LinkedList(LL_atoms_in_descriptors,current_descriptor,error) ) & + ! call append(LL_atoms_in_descriptors,current_descriptor,error) + endif + enddo loop_n + enddo + enddo + + deallocate(current_descriptor,atoms_in_descriptors) + call initialise(Table_atoms_in_descriptors_uniq, Nint = 4*current_order, Nreal = 0, Nstr = 0, Nlogical = 0, error=error) + + if( Table_atoms_in_descriptors%N > 0 ) then + call heap_sort(Table_atoms_in_descriptors%int(:,1:Table_atoms_in_descriptors%N)) + call append(Table_atoms_in_descriptors_uniq,Table_atoms_in_descriptors%int(:,1)) + do i_desc = 2, Table_atoms_in_descriptors%N + if( .not. all( Table_atoms_in_descriptors%int(:,i_desc) == Table_atoms_in_descriptors%int(:,i_desc-1) ) ) & + call append(Table_atoms_in_descriptors_uniq,Table_atoms_in_descriptors%int(:,i_desc)) + enddo + endif + + allocate(atoms_in_descriptors(4,current_order,Table_atoms_in_descriptors_uniq%N)) + atoms_in_descriptors = reshape(Table_atoms_in_descriptors_uniq%int(:,1:Table_atoms_in_descriptors_uniq%N),(/4,current_order,Table_atoms_in_descriptors_uniq%N/)) + + call finalise(Table_atoms_in_descriptors) + call finalise(Table_atoms_in_descriptors_uniq) + + if( current_order < this%order ) & + call distance_Nb_calc_neighbour_loop(this,at,atoms_in_descriptors = atoms_in_descriptors,n_descriptors=n_descriptors,error=error) + endif + + current_order = current_order - 1 + + endsubroutine distance_Nb_calc_neighbour_loop + + function order_and_check_for_duplicates(array,at) + integer, dimension(:,:), intent(inout) :: array + type(atoms), intent(in) :: at + logical :: order_and_check_for_duplicates + + integer :: ii, jj, n + integer, dimension(size(array,1)) :: tmp + logical :: do_swap + + integer, dimension(size(array,1)+1,size(array,2)) :: Z_array + + Z_array(1,:) = at%Z(array(1,:)) + Z_array(2:,:) = array(:,:) + + call heap_sort(Z_array) + + do ii = 2, size(Z_array,2) + if( all( Z_array(:,ii-1) == Z_array(:,ii) ) ) then + order_and_check_for_duplicates = .false. + return + endif + enddo + + array(:,:) = Z_array(2:,:) + + order_and_check_for_duplicates = .true. + + endfunction order_and_check_for_duplicates + + function is_subset(set,subset,error) + logical :: is_subset + integer, dimension(:), intent(in) :: set, subset + integer, optional, intent(out) :: error + + logical, dimension(size(set)) :: found + integer :: i, j + + INIT_ERROR(error) + if( size(set) < size(subset) ) then + RAISE_ERROR("is_subset: size of set must be greater than or equal to the size of subset",error) + endif + + found = .false. + loop_i: do i = 1, size(subset) + do j = 1, size(set) + if(set(j) == subset(i) .and. .not. found(j)) then + found(j) = .true. + cycle loop_i + endif + enddo + enddo loop_i + + is_subset = ( count(found) == size(subset) ) + + endfunction is_subset + + + function descriptor_dimensions(this,error) + type(descriptor), intent(in) :: this + integer, optional, intent(out) :: error + integer :: descriptor_dimensions + + INIT_ERROR(error) + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + descriptor_dimensions = bispectrum_SO4_dimensions(this%descriptor_bispectrum_SO4,error) + case(DT_BISPECTRUM_SO3) + descriptor_dimensions = bispectrum_SO3_dimensions(this%descriptor_bispectrum_SO3,error) + case(DT_BEHLER) + descriptor_dimensions = behler_dimensions(this%descriptor_behler,error) + case(DT_DISTANCE_2b) + descriptor_dimensions = distance_2b_dimensions(this%descriptor_distance_2b,error) + case(DT_COORDINATION) + descriptor_dimensions = coordination_dimensions(this%descriptor_coordination,error) + case(DT_ANGLE_3B) + descriptor_dimensions = angle_3b_dimensions(this%descriptor_angle_3b,error) + case(DT_CO_ANGLE_3B) + descriptor_dimensions = co_angle_3b_dimensions(this%descriptor_co_angle_3b,error) + case(DT_CO_DISTANCE_2b) + descriptor_dimensions = co_distance_2b_dimensions(this%descriptor_co_distance_2b,error) + case(DT_COSNX) + descriptor_dimensions = cosnx_dimensions(this%descriptor_cosnx,error) + case(DT_TRIHIS) + descriptor_dimensions = trihis_dimensions(this%descriptor_trihis,error) + case(DT_WATER_MONOMER) + descriptor_dimensions = water_monomer_dimensions(this%descriptor_water_monomer,error) + case(DT_WATER_DIMER) + descriptor_dimensions = water_dimer_dimensions(this%descriptor_water_dimer,error) + case(DT_A2_DIMER) + descriptor_dimensions = A2_dimer_dimensions(this%descriptor_A2_dimer,error) + case(DT_AB_DIMER) + descriptor_dimensions = AB_dimer_dimensions(this%descriptor_AB_dimer,error) + case(DT_ATOM_REAL_SPACE) + descriptor_dimensions = atom_real_space_dimensions(this%descriptor_atom_real_space,error) + case(DT_POWER_SO3) + descriptor_dimensions = power_so3_dimensions(this%descriptor_power_so3,error) + case(DT_POWER_SO4) + descriptor_dimensions = power_so4_dimensions(this%descriptor_power_so4,error) + case(DT_SOAP) + descriptor_dimensions = soap_dimensions(this%descriptor_soap,error) + case(DT_RDF) + descriptor_dimensions = rdf_dimensions(this%descriptor_rdf,error) + case(DT_AS_DISTANCE_2b) + descriptor_dimensions = as_distance_2b_dimensions(this%descriptor_as_distance_2b,error) + case(DT_ALEX) + descriptor_dimensions = alex_dimensions(this%descriptor_alex,error) + case(DT_DISTANCE_Nb) + descriptor_dimensions = distance_Nb_dimensions(this%descriptor_distance_Nb,error) + case(DT_SOAP_TURBO) + descriptor_dimensions = soap_turbo_dimensions(this%descriptor_soap_turbo,error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_BOND_REAL_SPACE) + descriptor_dimensions = bond_real_space_dimensions(this%descriptor_bond_real_space,error) + case(DT_AN_MONOMER) + descriptor_dimensions = AN_monomer_dimensions(this%descriptor_AN_monomer,error) + case(DT_COM_DIMER) + descriptor_dimensions = com_dimer_dimensions(this%descriptor_com_dimer,error) + case(DT_GENERAL_MONOMER) + descriptor_dimensions = general_monomer_dimensions(this%descriptor_general_monomer,error) + case(DT_GENERAL_DIMER) + descriptor_dimensions = general_dimer_dimensions(this%descriptor_general_dimer,error) + case(DT_GENERAL_TRIMER) + descriptor_dimensions = general_trimer_dimensions(this%descriptor_general_trimer,error) + case(DT_WATER_TRIMER) + descriptor_dimensions = water_trimer_dimensions(this%descriptor_water_trimer,error) + case(DT_MOLECULE_LO_D) + descriptor_dimensions = molecule_lo_d_dimensions(this%descriptor_molecule_lo_d,error) + case(DT_SOAP_EXPRESS) + descriptor_dimensions = soap_express_dimensions(this%descriptor_soap_express,error) +#endif + case default + RAISE_ERROR("descriptor_dimensions: unknown descriptor type "//this%descriptor_type,error) + endselect + + endfunction descriptor_dimensions + + function bispectrum_SO4_dimensions(this,error) result(i) + type(bispectrum_SO4), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + integer :: j, j1, j2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO4_dimensions: descriptor object not initialised", error) + endif + + i = 0 + do j1 = 0, this%j_max + j2 = j1 + !do j2 = 0, this%j_max + do j = abs(j1-j2), min(this%j_max,j1+j2) + if( mod(j1+j2+j,2) == 1 ) cycle + i = i + 1 + enddo + !enddo + enddo + + endfunction bispectrum_SO4_dimensions + + function bispectrum_SO3_dimensions(this,error) result(i) + type(bispectrum_SO3), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + integer :: a, l1, l2, l + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO3_dimensions: descriptor object not initialised", error) + endif + + i = 0 + do a = 1, this%n_max + do l1 = 0, this%l_max + l2 = l1 + !do l2 = 0, this%l_max + do l = abs(l1-l2), min(this%l_max,l1+l2) + if( mod(l1,2)==1 .and. mod(l2,2)==1 .and. mod(l,2)==1 ) cycle + i = i + 1 + enddo + !enddo + enddo + enddo + + endfunction bispectrum_SO3_dimensions + + function behler_dimensions(this,error) result(i) + type(behler), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("behler_dimensions: descriptor object not initialised", error) + endif + + i = this%n_g2 + this%n_g3 + + endfunction behler_dimensions + + function distance_2b_dimensions(this,error) result(i) + type(distance_2b), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("distance_2b_dimensions: descriptor object not initialised", error) + endif + + i = this%n_exponents + + endfunction distance_2b_dimensions + + function coordination_dimensions(this,error) result(i) + type(coordination), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("coordination_dimensions: descriptor object not initialised", error) + endif + + i = 1 + + endfunction coordination_dimensions + + function angle_3b_dimensions(this,error) result(i) + type(angle_3b), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("angle_3b_dimensions: descriptor object not initialised", error) + endif + + i = 3 + + endfunction angle_3b_dimensions + + function co_angle_3b_dimensions(this,error) result(i) + type(co_angle_3b), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("co_angle_3b_dimensions: descriptor object not initialised", error) + endif + + i = 4 + + endfunction co_angle_3b_dimensions + + function co_distance_2b_dimensions(this,error) result(i) + type(co_distance_2b), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("co_distance_2b_dimensions: descriptor object not initialised", error) + endif + + i = 3 + + endfunction co_distance_2b_dimensions + + function cosnx_dimensions(this,error) result(i) + type(cosnx), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("cosnx_dimensions: descriptor object not initialised", error) + endif + + i = this%n_max*(this%l_max+1) + + endfunction cosnx_dimensions + + function trihis_dimensions(this,error) result(i) + type(trihis), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("trihis_dimensions: descriptor object not initialised", error) + endif + + i = this%n_gauss + + endfunction trihis_dimensions + + function water_monomer_dimensions(this,error) result(i) + type(water_monomer), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("water_monomer_dimensions: descriptor object not initialised", error) + endif + + i = 3 + + endfunction water_monomer_dimensions + + function water_dimer_dimensions(this,error) result(i) + type(water_dimer), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("water_dimer_dimensions: descriptor object not initialised", error) + endif + + i = 15 + + endfunction water_dimer_dimensions + + function A2_dimer_dimensions(this,error) result(i) + type(A2_dimer), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("A2_dimer_dimensions: descriptor object not initialised", error) + endif + + i = 6 + + endfunction A2_dimer_dimensions + + function AB_dimer_dimensions(this,error) result(i) + type(AB_dimer), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("AB_dimer_dimensions: descriptor object not initialised", error) + endif + + i = 6 + + endfunction AB_dimer_dimensions + + + function atom_real_space_dimensions(this,error) result(i) + type(atom_real_space), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("atom_real_space_dimensions: descriptor object not initialised", error) + endif + + i = 2 * (this%l_max+1)**2 + 2 + + endfunction atom_real_space_dimensions + + function power_so3_dimensions(this,error) result(i) + type(power_so3), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("power_so3_dimensions: descriptor object not initialised", error) + endif + + i = this%n_max*(this%l_max+1) + + endfunction power_so3_dimensions + + function power_SO4_dimensions(this,error) result(i) + type(power_SO4), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("power_SO4_dimensions: descriptor object not initialised", error) + endif + + i = this%j_max + 1 + + endfunction power_SO4_dimensions + + function soap_dimensions(this,error) result(i) + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i, K1, K2 + logical :: sym_desc + type(real_2d), dimension(:), allocatable :: W + integer, dimension(:, :), allocatable :: coupling_inds + real, dimension(:), allocatable :: sym_facs + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("soap_dimensions: descriptor object not initialised", error) + endif + + call form_W(this, W, sym_desc, error) + K1 = size(W(1)%mm(0,:)) + K2 = size(W(2)%mm(0,:)) + + if (this%diagonal_radial) then + if (this%Z_mix .or. this%R_mix .or. this%nu_R /= 2 .or. this%nu_S /= 2 .or. (.not. this%coupling)) then + RAISE_ERROR("soap_dimensions: can't combine diagonal radial with any other compression strategies", error) + endif + i = (this%l_max+1) * this%n_max * this%n_species * (this%n_species+1) / 2 + 1 + elseif (this%coupling) then + if (sym_desc) then + i = (this%l_max+1) * (K1 * (K1+1)) /2 + 1 + else + i = (this%l_max+1) * K1 * K2 + 1 + endif + else + if (K1 /= K2) then + RAISE_ERROR("require K1=K2 to use elementwise coupling", error) + endif + + call form_coupling_inds(this, K1, coupling_inds, sym_facs, error) + i = SIZE(sym_facs) * (this%l_max + 1) + 1 + endif + + if (allocated(W)) deallocate(W) + if (allocated(coupling_inds)) deallocate(coupling_inds) + if (allocated(sym_facs)) deallocate(sym_facs) + endfunction soap_dimensions + + + + function rdf_dimensions(this,error) result(i) + type(rdf), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("rdf_dimensions: descriptor object not initialised", error) + endif + + i = this%n_gauss + + endfunction rdf_dimensions + + function as_distance_2b_dimensions(this,error) result(i) + type(as_distance_2b), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("as_distance_2b_dimensions: descriptor object not initialised", error) + endif + + i = 3 + + endfunction as_distance_2b_dimensions + + + function alex_dimensions(this,error) result(i) + type(alex), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i, nradial + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("alex_dimensions: descriptor object not initialised", error) + endif + + nradial = this%power_max-this%power_min + 1 + i = nradial+2*nradial**2+nradial**3 + + endfunction alex_dimensions + + function distance_Nb_dimensions(this,error) result(i) + type(distance_Nb), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("distance_Nb_dimensions: descriptor object not initialised", error) + endif + + i = max(1,this%order * ( this%order - 1 ) / 2) + + endfunction distance_Nb_dimensions + + function descriptor_cutoff(this,error) + type(descriptor), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: descriptor_cutoff + + INIT_ERROR(error) + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + descriptor_cutoff = cutoff(this%descriptor_bispectrum_SO4,error) + case(DT_BISPECTRUM_SO3) + descriptor_cutoff = cutoff(this%descriptor_bispectrum_SO3,error) + case(DT_BEHLER) + descriptor_cutoff = cutoff(this%descriptor_behler,error) + case(DT_DISTANCE_2b) + descriptor_cutoff = cutoff(this%descriptor_distance_2b,error) + case(DT_COORDINATION) + descriptor_cutoff = cutoff(this%descriptor_coordination,error) + case(DT_ANGLE_3B) + descriptor_cutoff = cutoff(this%descriptor_angle_3b,error) + case(DT_CO_ANGLE_3B) + descriptor_cutoff = cutoff(this%descriptor_co_angle_3b,error) + case(DT_CO_DISTANCE_2b) + descriptor_cutoff = cutoff(this%descriptor_co_distance_2b,error) + case(DT_COSNX) + descriptor_cutoff = cutoff(this%descriptor_cosnx,error) + case(DT_TRIHIS) + descriptor_cutoff = cutoff(this%descriptor_trihis,error) + case(DT_WATER_MONOMER) + descriptor_cutoff = cutoff(this%descriptor_water_monomer,error) + case(DT_WATER_DIMER) + descriptor_cutoff = cutoff(this%descriptor_water_dimer,error) + case(DT_A2_DIMER) + descriptor_cutoff = cutoff(this%descriptor_A2_dimer,error) + case(DT_AB_DIMER) + descriptor_cutoff = cutoff(this%descriptor_AB_dimer,error) + case(DT_ATOM_REAL_SPACE) + descriptor_cutoff = cutoff(this%descriptor_atom_real_space,error) + case(DT_POWER_SO3) + descriptor_cutoff = cutoff(this%descriptor_power_so3,error) + case(DT_POWER_SO4) + descriptor_cutoff = cutoff(this%descriptor_power_so4,error) + case(DT_SOAP) + descriptor_cutoff = cutoff(this%descriptor_soap,error) + case(DT_RDF) + descriptor_cutoff = cutoff(this%descriptor_rdf,error) + case(DT_ALEX) + descriptor_cutoff = cutoff(this%descriptor_alex,error) + case(DT_DISTANCE_Nb) + descriptor_cutoff = cutoff(this%descriptor_distance_Nb,error) + case(DT_SOAP_TURBO) + descriptor_cutoff = cutoff(this%descriptor_soap_turbo,error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_BOND_REAL_SPACE) + descriptor_cutoff = cutoff(this%descriptor_bond_real_space,error) + case(DT_MOLECULE_LO_D) + descriptor_cutoff = cutoff(this%descriptor_molecule_lo_d,error) + case(DT_AN_MONOMER) + descriptor_cutoff = cutoff(this%descriptor_AN_monomer,error) + case(DT_GENERAL_MONOMER) + descriptor_cutoff = cutoff(this%descriptor_general_monomer,error) + case(DT_GENERAL_DIMER) + descriptor_cutoff = cutoff(this%descriptor_general_dimer,error) + case(DT_GENERAL_TRIMER) + descriptor_cutoff = cutoff(this%descriptor_general_trimer,error) + case(DT_WATER_TRIMER) + descriptor_cutoff = cutoff(this%descriptor_water_trimer,error) + case(DT_COM_DIMER) + descriptor_cutoff = cutoff(this%descriptor_com_dimer,error) + case(DT_SOAP_EXPRESS) + descriptor_cutoff = cutoff(this%descriptor_soap_express,error) +#endif + case default + RAISE_ERROR("descriptor_cutoff: unknown descriptor type "//this%descriptor_type,error) + endselect + + endfunction descriptor_cutoff + + function bispectrum_SO4_cutoff(this,error) + type(bispectrum_SO4), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: bispectrum_SO4_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO4_cutoff: descriptor object not initialised", error) + endif + + bispectrum_SO4_cutoff = this%cutoff + + endfunction bispectrum_SO4_cutoff + + function bispectrum_SO3_cutoff(this,error) + type(bispectrum_SO3), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: bispectrum_SO3_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO3_cutoff: descriptor object not initialised", error) + endif + + bispectrum_SO3_cutoff = this%cutoff + + endfunction bispectrum_SO3_cutoff + + function behler_cutoff(this,error) + type(behler), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: behler_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("behler_cutoff: descriptor object not initialised", error) + endif + + behler_cutoff = this%cutoff + + endfunction behler_cutoff + + function distance_2b_cutoff(this,error) + type(distance_2b), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: distance_2b_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("distance_2b_cutoff: descriptor object not initialised", error) + endif + + distance_2b_cutoff = this%cutoff + + endfunction distance_2b_cutoff + + function co_distance_2b_cutoff(this,error) + type(co_distance_2b), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: co_distance_2b_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("co_distance_2b_cutoff: descriptor object not initialised", error) + endif + + co_distance_2b_cutoff = this%cutoff + + endfunction co_distance_2b_cutoff + + function coordination_cutoff(this,error) + type(coordination), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: coordination_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("coordination_cutoff: descriptor object not initialised", error) + endif + + coordination_cutoff = this%cutoff + + endfunction coordination_cutoff + + function angle_3b_cutoff(this,error) + type(angle_3b), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: angle_3b_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("angle_3b_cutoff: descriptor object not initialised", error) + endif + + angle_3b_cutoff = this%cutoff + + endfunction angle_3b_cutoff + + function co_angle_3b_cutoff(this,error) + type(co_angle_3b), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: co_angle_3b_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("co_angle_3b_cutoff: descriptor object not initialised", error) + endif + + co_angle_3b_cutoff = this%cutoff + + endfunction co_angle_3b_cutoff + + function cosnx_cutoff(this,error) + type(cosnx), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: cosnx_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("cosnx_cutoff: descriptor object not initialised", error) + endif + + cosnx_cutoff = this%cutoff + + endfunction cosnx_cutoff + + function trihis_cutoff(this,error) + type(trihis), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: trihis_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("trihis_cutoff: descriptor object not initialised", error) + endif + + trihis_cutoff = this%cutoff + + endfunction trihis_cutoff + + function water_monomer_cutoff(this,error) + type(water_monomer), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: water_monomer_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("water_monomer_cutoff: descriptor object not initialised", error) + endif + + water_monomer_cutoff = this%cutoff + + endfunction water_monomer_cutoff + + function water_dimer_cutoff(this,error) + type(water_dimer), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: water_dimer_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("water_dimer_cutoff: descriptor object not initialised", error) + endif + + water_dimer_cutoff = this%cutoff + + endfunction water_dimer_cutoff + + function A2_dimer_cutoff(this,error) + type(A2_dimer), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: A2_dimer_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("A2_dimer_cutoff: descriptor object not initialised", error) + endif + + A2_dimer_cutoff = this%cutoff + + endfunction A2_dimer_cutoff + + function AB_dimer_cutoff(this,error) + type(AB_dimer), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: AB_dimer_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("AB_dimer_cutoff: descriptor object not initialised", error) + endif + + AB_dimer_cutoff = this%cutoff + + endfunction AB_dimer_cutoff + + + function atom_real_space_cutoff(this,error) + type(atom_real_space), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: atom_real_space_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("atom_real_space_cutoff: descriptor object not initialised", error) + endif + + atom_real_space_cutoff = this%cutoff + + endfunction atom_real_space_cutoff + + function power_so3_cutoff(this,error) + type(power_so3), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: power_so3_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("power_so3_cutoff: descriptor object not initialised", error) + endif + + power_so3_cutoff = this%cutoff + + endfunction power_so3_cutoff + + function power_so4_cutoff(this,error) + type(power_so4), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: power_so4_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("power_so4_cutoff: descriptor object not initialised", error) + endif + + power_so4_cutoff = this%cutoff + + endfunction power_so4_cutoff + + function soap_cutoff(this,error) + type(soap), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: soap_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("soap_cutoff: descriptor object not initialised", error) + endif + + soap_cutoff = this%cutoff + + endfunction soap_cutoff + + + function rdf_cutoff(this,error) + type(rdf), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: rdf_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("rdf_cutoff: descriptor object not initialised", error) + endif + + rdf_cutoff = this%cutoff + + endfunction rdf_cutoff + + function as_distance_2b_cutoff(this,error) + type(as_distance_2b), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: as_distance_2b_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("as_distance_2b_cutoff: descriptor object not initialised", error) + endif + + as_distance_2b_cutoff = this%max_cutoff + + endfunction as_distance_2b_cutoff + + + function alex_cutoff(this,error) + type(alex), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: alex_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("alex_cutoff: descriptor object not initialised", error) + endif + + alex_cutoff = this%cutoff + + endfunction alex_cutoff + + function distance_Nb_cutoff(this,error) + type(distance_Nb), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: distance_Nb_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("distance_Nb_cutoff: descriptor object not initialised", error) + endif + + distance_Nb_cutoff = this%cutoff + + endfunction distance_Nb_cutoff + + function soap_turbo_cutoff(this,error) + type(soap_turbo), intent(in) :: this + integer, optional, intent(out) :: error + real(dp) :: soap_turbo_cutoff + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("soap_turbo_cutoff: descriptor object not initialised", error) + endif + + soap_turbo_cutoff = this%rcut_hard + + endfunction soap_turbo_cutoff + + + subroutine descriptor_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(descriptor), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4) + call bispectrum_SO4_sizes(this%descriptor_bispectrum_SO4,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_BISPECTRUM_SO3) + call bispectrum_SO3_sizes(this%descriptor_bispectrum_SO3,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_BEHLER) + call behler_sizes(this%descriptor_behler,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_DISTANCE_2b) + call distance_2b_sizes(this%descriptor_distance_2b,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_COORDINATION) + call coordination_sizes(this%descriptor_coordination,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_ANGLE_3B) + call angle_3b_sizes(this%descriptor_angle_3b,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_CO_ANGLE_3B) + call co_angle_3b_sizes(this%descriptor_co_angle_3b,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_CO_DISTANCE_2b) + call co_distance_2b_sizes(this%descriptor_co_distance_2b,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_COSNX) + call cosnx_sizes(this%descriptor_cosnx,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_TRIHIS) + call trihis_sizes(this%descriptor_trihis,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_WATER_MONOMER) + call water_monomer_sizes(this%descriptor_water_monomer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_WATER_DIMER) + call water_dimer_sizes(this%descriptor_water_dimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_A2_DIMER) + call A2_dimer_sizes(this%descriptor_A2_dimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_AB_DIMER) + call AB_dimer_sizes(this%descriptor_AB_dimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_ATOM_REAL_SPACE) + call atom_real_space_sizes(this%descriptor_atom_real_space,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_POWER_SO3) + call power_so3_sizes(this%descriptor_power_so3,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_POWER_SO4) + call power_so4_sizes(this%descriptor_power_so4,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_SOAP) + call soap_sizes(this%descriptor_soap,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_RDF) + call rdf_sizes(this%descriptor_rdf,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_AS_DISTANCE_2b) + call as_distance_2b_sizes(this%descriptor_as_distance_2b,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_ALEX) + call alex_sizes(this%descriptor_alex,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_DISTANCE_Nb) + call distance_Nb_sizes(this%descriptor_distance_Nb,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_SOAP_TURBO) + call soap_turbo_sizes(this%descriptor_soap_turbo,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_BOND_REAL_SPACE) + call bond_real_space_sizes(this%descriptor_bond_real_space,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_MOLECULE_LO_D) + call molecule_lo_d_sizes(this%descriptor_molecule_lo_d,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_AN_MONOMER) + call AN_monomer_sizes(this%descriptor_AN_monomer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_GENERAL_MONOMER) + call general_monomer_sizes(this%descriptor_general_monomer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_GENERAL_DIMER) + call general_dimer_sizes(this%descriptor_general_dimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_GENERAL_TRIMER) + call general_trimer_sizes(this%descriptor_general_trimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_WATER_TRIMER) + call water_trimer_sizes(this%descriptor_water_trimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_COM_DIMER) + call com_dimer_sizes(this%descriptor_com_dimer,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) + case(DT_SOAP_EXPRESS) + call soap_express_sizes(this%descriptor_soap_express,at, & + n_descriptors,n_cross,mask=mask,n_index=n_index,error=error) +#endif + case default + RAISE_ERROR("descriptor_sizes: unknown descriptor type "//this%descriptor_type,error) + endselect + + endsubroutine descriptor_sizes + + subroutine bispectrum_SO4_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(bispectrum_SO4), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO4_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine bispectrum_SO4_sizes + + subroutine bispectrum_SO3_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(bispectrum_SO3), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("bispectrum_SO3_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine bispectrum_SO3_sizes + + subroutine behler_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(behler), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("behler_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + do i = 1, at%N + if(present(mask)) then + if(.not. mask(i)) cycle + endif + if( this%Z /= 0 .and. this%Z /= at%Z(i) ) cycle + + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine behler_sizes + + subroutine distance_2b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(distance_2b), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, n + logical :: Zi1, Zi2, Zj1, Zj2 + real(dp) :: r_ij + + logical :: needs_resid + integer, dimension(:), pointer :: resid_pointer + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("distance_2b_sizes: descriptor object not initialised", error) + endif + + needs_resid = this%only_intra .or. this%only_inter + if (needs_resid) then + if (.not. assign_pointer(at, trim(this%resid_name), resid_pointer)) then + RAISE_ERROR("distance_2b_sizes did not find "//trim(this%resid_name)//" property (residue id) in the atoms object.", error) + end if + else + resid_pointer => null() + end if + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if(present(mask)) then + if(.not. mask(i)) cycle + endif + + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij) + if(r_ij >= this%cutoff) cycle +!if(r_ij < 3.5_dp) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + if (needs_resid) then + if (this%only_intra .and. resid_pointer(i) /= resid_pointer(j)) cycle + if (this%only_inter .and. resid_pointer(i) == resid_pointer(j)) cycle + end if + + n_descriptors = n_descriptors + 1 + enddo + enddo + + n_cross = n_descriptors*2 + + if( present(n_index) ) n_index = 2 + + endsubroutine distance_2b_sizes + + subroutine coordination_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(coordination), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("coordination_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine coordination_sizes + + subroutine angle_3b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(angle_3b), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, k, n, m + real(dp) :: r_ij, r_ik + logical :: Zk1, Zk2, Zj1, Zj2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("angle_3b_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij) + if( r_ij >= this%cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + + do m = 1, n_neighbours(at,i) + if( n == m ) cycle + + k = neighbour(at, i, m, distance = r_ik) + if( r_ik >= this%cutoff ) cycle + + Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) + Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) + if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + n_descriptors = n_descriptors + 1 + enddo + enddo + enddo + n_cross = n_descriptors * 3 + + if( present(n_index) ) n_index = 1 + + endsubroutine angle_3b_sizes + + subroutine co_angle_3b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(co_angle_3b), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, k, n, m, n_neighbours_coordination + real(dp) :: r_ij, r_ik + logical :: Zk1, Zk2, Zj1, Zj2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("co_angle_3b_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( (this%Z /=0) .and. (at%Z(i) /= this%Z) ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + + n_neighbours_coordination = n_neighbours(at,i,max_dist=this%coordination_cutoff) + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance = r_ij) + if( r_ij >= this%cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + + do m = 1, n_neighbours(at,i) + if( n == m ) cycle + k = neighbour(at, i, m, distance = r_ik) + if( r_ik >= this%cutoff ) cycle + + Zk1 = (this%Z1 == 0) .or. (at%Z(k) == this%Z1) + Zk2 = (this%Z2 == 0) .or. (at%Z(k) == this%Z2) + if( .not. ( ( Zk1 .and. Zj2 ) .or. ( Zk2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 3 + n_neighbours_coordination + enddo + enddo + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine co_angle_3b_sizes + + subroutine co_distance_2b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(co_distance_2b), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + real(dp) :: r_ij + integer :: i, j, n + logical :: Zi1, Zi2, Zj1, Zj2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("co_distance_2b_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if(present(mask)) then + if(.not. mask(i)) cycle + endif + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at,i,n,distance=r_ij) + if( r_ij >= this%cutoff ) cycle +!if( r_ij < 3.5_dp ) cycle + + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 4 + n_neighbours(at,i,max_dist=this%coordination_cutoff) + n_neighbours(at,j,max_dist=this%coordination_cutoff) + enddo + enddo + + if( present(n_index) ) n_index = 2 + + endsubroutine co_distance_2b_sizes + + subroutine cosnx_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(cosnx), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("cosnx_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine cosnx_sizes + + subroutine trihis_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(trihis), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("trihis_sizes: descriptor object not initialised", error) + endif + + n_descriptors = at%N + + n_cross = 0 + + do i = 1, at%N + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_cross = n_cross + n_neighbours(at,i) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine trihis_sizes + + subroutine water_monomer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(water_monomer), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("water_monomer_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if(at%Z(i) == 8) then + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 3 + endif + enddo + + if( present(n_index) ) n_index = 3 + + endsubroutine water_monomer_sizes + + subroutine water_dimer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(water_dimer), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, n + real(dp) :: r_ij + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("water_dimer_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 +call print("mask present ? "//present(mask),PRINT_NERD) + do i = 1, at%N + if(at%Z(i) == 8) then + if(present(mask)) then + if(.not. mask(i)) cycle + endif + do n = 1, n_neighbours(at,i) + j = neighbour(at,i,n,distance=r_ij) + if(at%Z(j) == 8 .and. r_ij < this%cutoff) then + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 6 + endif + enddo + endif + enddo + + if( present(n_index) ) n_index = 6 + + endsubroutine water_dimer_sizes + + subroutine A2_dimer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(A2_dimer), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, iA1, iA2, iB1, iB2 + integer, dimension(at%N) :: A2_monomer_index + real(dp) :: r_A1_A2, r_B1_B2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("A2_dimer_sizes: descriptor object not initialised", error) + endif + + call find_A2_monomer(at,this%atomic_number, this%monomer_cutoff, A2_monomer_index) + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + iA1 = i + iA2 = neighbour(at,i,A2_monomer_index(i),distance=r_A1_A2) + if( iA1 > iA2 ) cycle + + do j = i + 1, at%N + iB1 = j + iB2 = neighbour(at,j,A2_monomer_index(j),distance=r_B1_B2) + if( iB1 > iB2 ) cycle + + r_A1_B1 = distance_min_image(at,iA1,iB1) + r_A1_B2 = distance_min_image(at,iA1,iB2) + + r_A2_B1 = distance_min_image(at,iA2,iB1) + r_A2_B2 = distance_min_image(at,iA2,iB2) + + if( all( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) < this%cutoff) ) then + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 4 + endif + enddo + enddo + + if( present(n_index) ) n_index = 4 + + endsubroutine A2_dimer_sizes + + subroutine AB_dimer_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(AB_dimer), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, n_monomers, iA1, iA2, iB1, iB2 + integer, dimension(:,:), allocatable :: AB_monomer_index + real(dp) :: r_A1_A2, r_B1_B2, r_A1_B1, r_A1_B2, r_A2_B1, r_A2_B2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("A2_dimer_sizes: descriptor object not initialised", error) + endif + + if( count(at%Z == this%atomic_number1) == count(at%Z == this%atomic_number2) ) then + n_monomers = count(at%Z == this%atomic_number1) + else + RAISE_ERROR("AB_dimer_sizes: number of monomer atoms 1 ("//count(at%Z == this%atomic_number1)//") not equal to number of monomer atoms 2 ("//count(at%Z == this%atomic_number1)//")",error) + endif + + allocate(AB_monomer_index(2,n_monomers)) + call find_AB_monomer(at,(/this%atomic_number1,this%atomic_number2/), this%monomer_cutoff, AB_monomer_index) + + n_descriptors = 0 + n_cross = 0 + + do i = 1, n_monomers + iA1 = AB_monomer_index(1,i) + iB1 = AB_monomer_index(2,i) + do j = i + 1, n_monomers + iA2 = AB_monomer_index(1,j) + iB2 = AB_monomer_index(2,j) + + r_A1_B1 = distance_min_image(at,iA1,iB1) + r_A2_B2 = distance_min_image(at,iA2,iB2) + + r_A1_A2 = distance_min_image(at,iA1,iA2) + r_B1_B2 = distance_min_image(at,iB1,iB2) + + r_A1_B2 = distance_min_image(at,iA1,iB2) + r_A2_B1 = distance_min_image(at,iA2,iB1) + + if( all( (/r_A1_A2,r_B1_B2,r_A1_B1,r_A1_B2,r_A2_B1,r_A2_B2/) < this%cutoff) ) then + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 4 + endif + enddo + enddo + + deallocate(AB_monomer_index) + + if( present(n_index) ) n_index = 4 + + endsubroutine AB_dimer_sizes + + + subroutine atom_real_space_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(atom_real_space), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("atom_real_space_sizes: descriptor object not initialised", error) + endif + + n_descriptors = at%N + n_cross = 0 + + do i = 1, at%N + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff)*2 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine atom_real_space_sizes + + subroutine power_so3_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(power_so3), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("power_so3_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine power_so3_sizes + + subroutine power_SO4_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(power_SO4), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("power_SO4_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine power_SO4_sizes + + subroutine soap_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(soap), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("soap_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( .not. any( at%Z(i) == this%Z ) .and. .not. any(this%Z == 0) ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if(this%global) then + n_descriptors = 1 + if( present(n_index) ) then + if( any(this%Z == 0) ) then + n_index = at%N + else + n_index = count( (/(any(at%Z(i)==this%Z),i=1,at%N)/) ) + endif + endif + else + if( present(n_index) ) n_index = 1 + endif + + endsubroutine soap_sizes + + subroutine rdf_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(rdf), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("rdf_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine rdf_sizes + + subroutine as_distance_2b_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(as_distance_2b), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + real(dp) :: r_ij + integer :: i, j, n + logical :: Zi1, Zi2, Zj1, Zj2 + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("as_distance_2b_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + Zi1 = (this%Z1 == 0) .or. (at%Z(i) == this%Z1) + Zi2 = (this%Z2 == 0) .or. (at%Z(i) == this%Z2) + do n = 1, n_neighbours(at,i) + j = neighbour(at,i,n,distance=r_ij) + if( r_ij > this%max_cutoff ) cycle + + Zj1 = (this%Z1 == 0) .or. (at%Z(j) == this%Z1) + Zj2 = (this%Z2 == 0) .or. (at%Z(j) == this%Z2) + if( .not. ( ( Zi1 .and. Zj2 ) .or. ( Zi2 .and. Zj1 ) ) ) cycle ! this pair doesn't belong to the descriptor type + + n_descriptors = n_descriptors + 1 + n_cross = n_cross + 4 + n_neighbours(at,i,max_dist=this%coordination_cutoff) + n_neighbours(at,j,max_dist=this%coordination_cutoff) + enddo + enddo + + if( present(n_index) ) n_index = 2 + + endsubroutine as_distance_2b_sizes + + + subroutine alex_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(alex), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("alex_sizes: descriptor object not initialised", error) + endif + + n_descriptors = 0 + n_cross = 0 + + do i = 1, at%N + if( at%Z(i) /= this%Z .and. this%Z /=0 ) cycle + if(present(mask)) then + if(.not. mask(i)) cycle + endif + n_descriptors = n_descriptors + 1 + n_cross = n_cross + n_neighbours(at,i,max_dist=this%cutoff) + 1 + enddo + + if( present(n_index) ) n_index = 1 + + endsubroutine alex_sizes + + subroutine distance_Nb_sizes(this,at,n_descriptors,n_cross,mask,n_index,error) + type(distance_Nb), intent(in) :: this + type(atoms), intent(in) :: at + integer, intent(out) :: n_descriptors, n_cross + logical, dimension(:), intent(in), optional :: mask + integer, intent(out), optional :: n_index + integer, optional, intent(out) :: error + + integer :: i, j, n + logical :: Zi1, Zi2, Zj1, Zj2 + real(dp) :: r_ij + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("distance_Nb_sizes: descriptor object not initialised", error) + endif + + call distance_Nb_calc_get_clusters(this,at,n_descriptors=n_descriptors,mask=mask,error=error) + n_cross = n_descriptors * this%order + + if( present(n_index) ) n_index = this%order + + endsubroutine distance_Nb_sizes + + function soap_turbo_dimensions(this,error) result(i) + type(soap_turbo), intent(in) :: this + integer, optional, intent(out) :: error + integer :: i + integer :: n_max + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR("soap_turbo_dimensions: descriptor object not initialised", error) + endif + + if( this%compress )then + i = maxval(this%compress_P_i) + else + n_max = sum(this%alpha_max) + i = ( this%l_max+1 ) * ( n_max*(n_max+1) ) / 2 + endif + + endfunction soap_turbo_dimensions + + function descriptor_n_permutations(this,error) + type(descriptor), intent(in) :: this + integer, optional, intent(out) :: error + + integer :: descriptor_n_permutations, i + + INIT_ERROR(error) + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4,DT_BISPECTRUM_SO3,DT_BEHLER,DT_DISTANCE_2b,DT_COORDINATION, & + DT_ANGLE_3B,DT_CO_ANGLE_3B,DT_CO_DISTANCE_2b,DT_COSNX,DT_TRIHIS,DT_WATER_MONOMER,DT_BOND_REAL_SPACE,& + DT_ATOM_REAL_SPACE,DT_POWER_SO3,DT_POWER_SO4,DT_SOAP,DT_RDF, DT_ALEX, DT_COM_DIMER, & + DT_SOAP_EXPRESS,DT_SOAP_TURBO) + + descriptor_n_permutations = 1 + + case(DT_WATER_DIMER) + descriptor_n_permutations = NP_WATER_DIMER + case(DT_A2_DIMER) + descriptor_n_permutations = NP_A2_DIMER + case(DT_AB_DIMER) + descriptor_n_permutations = NP_AB_DIMER +#ifdef DESCRIPTORS_NONCOMMERCIAL + case(DT_AN_MONOMER) + if(this%descriptor_AN_monomer%do_atomic) then + descriptor_n_permutations = factorial(this%descriptor_AN_monomer%N-1) + else + descriptor_n_permutations = factorial(this%descriptor_AN_monomer%N) + endif + case(DT_GENERAL_MONOMER) + if (.not. this%descriptor_general_monomer%permutation_data%initialised)then + RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) + end if + descriptor_n_permutations = this%descriptor_general_monomer%permutation_data%n_perms + case(DT_GENERAL_DIMER) + if (.not. this%descriptor_general_dimer%permutation_data%initialised)then + RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) + end if + descriptor_n_permutations = this%descriptor_general_dimer%permutation_data%n_perms + case(DT_GENERAL_TRIMER) + if (.not. this%descriptor_general_trimer%permutation_data%initialised)then + RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) + end if + descriptor_n_permutations = this%descriptor_general_trimer%permutation_data%n_perms + case(DT_WATER_TRIMER) + if (.not. this%descriptor_water_trimer%permutation_data%initialised)then + RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) + end if + descriptor_n_permutations = this%descriptor_water_trimer%permutation_data%n_perms + case(DT_MOLECULE_LO_D) + if (.not. this%descriptor_molecule_lo_d%permutation_data%initialised)then + RAISE_ERROR("descriptor_n_permutations: permutation_data not initialised "//this%descriptor_type,error) + end if + descriptor_n_permutations = this%descriptor_molecule_lo_d%permutation_data%n_perms +#endif + case(DT_DISTANCE_NB) + descriptor_n_permutations = this%descriptor_distance_Nb%n_permutations + case default + RAISE_ERROR("descriptor_n_permutations: unknown descriptor type "//this%descriptor_type,error) + endselect + + endfunction descriptor_n_permutations + + subroutine descriptor_permutations(this,permutations,error) + type(descriptor), intent(in) :: this +#ifdef DESCRIPTORS_NONCOMMERCIAL + type(permutation_data_type) :: my_permutation_data +#endif + integer, dimension(:,:), intent(out) :: permutations + integer, optional, intent(out) :: error + + integer :: i, d, np, n, m, ip, j + integer,dimension(1) :: unit_vec + integer, dimension(:), allocatable :: this_perm + integer, dimension(:,:), allocatable :: distance_matrix, atom_permutations, sliced_permutations + + INIT_ERROR(error) + + d = descriptor_dimensions(this,error) + np = descriptor_n_permutations(this,error) + call check_size('permutations',permutations, (/d,np/),'descriptor_permutations',error) + + selectcase(this%descriptor_type) + case(DT_BISPECTRUM_SO4,DT_BISPECTRUM_SO3,DT_BEHLER,DT_DISTANCE_2b,DT_COORDINATION, & + DT_ANGLE_3B,DT_CO_ANGLE_3B,DT_CO_DISTANCE_2b,DT_COSNX,DT_TRIHIS,DT_WATER_MONOMER,DT_BOND_REAL_SPACE,& + DT_ATOM_REAL_SPACE,DT_POWER_SO3,DT_POWER_SO4,DT_SOAP,DT_RDF, DT_ALEX, DT_COM_DIMER,& + DT_SOAP_EXPRESS,DT_SOAP_TURBO) + + permutations(:,1) = (/ (i, i = 1, size(permutations,1)) /) + case(DT_WATER_DIMER) + permutations(:,1) = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15/) ! original order + permutations(:,2) = (/1, 3, 2, 4, 5, 7, 6, 8, 9, 10, 13, 14, 11, 12, 15/) ! swap Hs on monomer A + permutations(:,3) = (/1, 2, 3, 5, 4, 6, 7, 9, 8, 10, 12, 11, 14, 13, 15/) ! swap Hs on monomer B + permutations(:,4) = (/1, 3, 2, 5, 4, 7, 6, 9, 8, 10, 14, 13, 12, 11, 15/) ! swap Hs on both monomers + permutations(:,5) = (/1, 8, 9, 6, 7, 4, 5, 2, 3, 15, 11, 13, 12, 14, 10/) ! swap monomers A and B + permutations(:,6) = (/1, 9, 8, 6, 7, 5, 4, 2, 3, 15, 12, 14, 11, 13, 10/) ! swap monomers and Hs on monomer A + permutations(:,7) = (/1, 8, 9, 7, 6, 4, 5, 3, 2, 15, 13, 11, 14, 12, 10/) ! swap monomers and Hs on monomer B + permutations(:,8) = (/1, 9, 8, 7, 6, 5, 4, 3, 2, 15, 14, 12, 13, 11, 10/) ! swap monomers and Hs on both monomers + + case(DT_A2_DIMER) + permutations(:,1) = (/1, 2, 3, 4, 5, 6/) ! original order + permutations(:,2) = (/1, 2, 5, 6, 3, 4/) ! swap atoms on monomer A + permutations(:,3) = (/1, 2, 4, 3, 6, 5/) ! swap atoms on monomer B + permutations(:,4) = (/1, 2, 6, 5, 4, 3/) ! swap atoms on both monomers + permutations(:,5) = (/2, 1, 3, 5, 4, 6/) ! swap monomers A and B + permutations(:,6) = (/2, 1, 5, 3, 6, 4/) ! swap monomers and atoms on monomer A + permutations(:,7) = (/2, 1, 4, 6, 3, 5/) ! swap monomers and atoms on monomer B + permutations(:,8) = (/2, 1, 6, 4, 5, 3/) ! swap monomers and atoms on both monomers + + case(DT_AB_DIMER) + permutations(:,1) = (/1, 2, 3, 4, 5, 6/) ! original order + permutations(:,2) = (/2, 1, 3, 4, 6, 5/) ! swap monomers +#ifdef DESCRIPTORS_NONCOMMERCIAL +#include "descriptors_noncommercial_permutations.inc" +#endif + case(DT_DISTANCE_NB) + permutations = this%descriptor_distance_Nb%permutations + case default + RAISE_ERROR("descriptor_permutations: unknown descriptor type "//this%descriptor_type,error) + endselect + + endsubroutine descriptor_permutations + + + subroutine real_space_fourier_coefficients(at,l_max,atom_coefficient) + type(atoms), intent(in) :: at + integer, intent(in) :: l_max + type(neighbour_type), dimension(:), allocatable :: atom_coefficient + + integer :: i, j, n, l, m + real(dp) :: r + real(dp), dimension(3) :: d + + if(.not.allocated(atom_coefficient)) allocate(atom_coefficient(at%N)) + + do i = 1, at%N + if(.not. allocated(atom_coefficient(i)%neighbour)) allocate(atom_coefficient(i)%neighbour(n_neighbours(at,i))) + do n = 1, n_neighbours(at,i) + + j = neighbour(at,i,n,distance = r, diff = d) + atom_coefficient(i)%neighbour(n)%r = r + atom_coefficient(i)%neighbour(n)%u = d / r + + if(.not. allocated(atom_coefficient(i)%neighbour(n)%spherical_harmonics)) allocate( atom_coefficient(i)%neighbour(n)%spherical_harmonics(0:l_max), & + atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(0:l_max) ) + do l = 0, l_max + if(.not. allocated(atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m)) & + allocate(atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m(-l:l)) + if(.not. allocated(atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm)) & + allocate(atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm(3,-l:l)) + + atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m = CPLX_ZERO + atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm = CPLX_ZERO + + do m = -l, l + atom_coefficient(i)%neighbour(n)%spherical_harmonics(l)%m(m) = SphericalYCartesian(l,m,d) + atom_coefficient(i)%neighbour(n)%grad_spherical_harmonics(l)%mm(:,m) = GradSphericalYCartesian(l,m,d) + enddo + enddo + enddo + enddo + + endsubroutine real_space_fourier_coefficients + + function real_space_covariance_coefficient(anc1,anc2,i1,i2,alpha,l_max,f1,f2) + type(neighbour_type), dimension(:), intent(in) :: anc1, anc2 + real(dp), intent(in) :: alpha + integer, intent(in) :: i1, i2, l_max + real(dp), dimension(:,:), intent(out), optional :: f1, f2 + + real(dp) :: real_space_covariance_coefficient + + complex(dp) :: real_space_covariance_in, I_lm1m2 + integer :: n1, n2, l, m1, m2, k + real(dp) :: r1, r2, arg_bess, fac_exp, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm, mo_spher_bess_fi_ki_lp, grad_mo_spher_bess_fi_ki_l + real(dp), dimension(3) :: u1, u2, grad_arg_bess1, grad_fac_exp1, grad_arg_bess2, grad_fac_exp2 + type(cplx_2d), dimension(:), allocatable :: integral_r + type(grad_spherical_harmonics_overlap_type), dimension(:), allocatable :: grad_integral_r1, grad_integral_r2 + + logical :: do_derivative + + do_derivative = (present(f1) .or. present(f2)) + + real_space_covariance_in = CPLX_ZERO + + allocate(integral_r(0:l_max)) + do l = 0, l_max + allocate(integral_r(l)%mm(-l:l,-l:l)) + integral_r(l)%mm = CPLX_ZERO + enddo + + if(present(f1)) then + allocate(grad_integral_r1(0:size(anc1(i1)%neighbour))) + do n1 = 0, size(anc1(i1)%neighbour) + allocate(grad_integral_r1(n1)%grad_integral(0:l_max)) + do l = 0, l_max + allocate(grad_integral_r1(n1)%grad_integral(l)%mm(3,-l:l,-l:l)) + grad_integral_r1(n1)%grad_integral(l)%mm = CPLX_ZERO + enddo + enddo + endif + + if(present(f2)) then + allocate(grad_integral_r2(0:size(anc2(i2)%neighbour))) + do n2 = 0, size(anc2(i2)%neighbour) + allocate(grad_integral_r2(n2)%grad_integral(0:l_max)) + do l = 0, l_max + allocate(grad_integral_r2(n2)%grad_integral(l)%mm(3,-l:l,-l:l)) + grad_integral_r2(n2)%grad_integral(l)%mm = CPLX_ZERO + enddo + enddo + endif + do n1 = 1, size(anc1(i1)%neighbour) + r1 = anc1(i1)%neighbour(n1)%r + u1 = anc1(i1)%neighbour(n1)%u + do n2 = 1, size(anc2(i2)%neighbour) + r2 = anc2(i2)%neighbour(n2)%r + + u2 = anc2(i2)%neighbour(n2)%u + + arg_bess = alpha*r1*r2 + fac_exp = exp(-0.5_dp*alpha*(r1**2+r2**2)) + + if(present(f1)) then + grad_arg_bess1 = alpha*r2*u1 + grad_fac_exp1 = -fac_exp*alpha*r1*u1 + endif + + if(present(f2)) then + grad_arg_bess2 = alpha*r1*u2 + grad_fac_exp2 = -fac_exp*alpha*r2*u2 + endif + + do l = 0, l_max + if( l == 0 ) then + mo_spher_bess_fi_ki_lm = cosh(arg_bess)/arg_bess + mo_spher_bess_fi_ki_l = sinh(arg_bess)/arg_bess + if(do_derivative) mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess + else + mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm + mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l + if(do_derivative) then + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lp + mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess + else + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l-1)*mo_spher_bess_fi_ki_lm / arg_bess + endif + + endif + + + if(do_derivative) grad_mo_spher_bess_fi_ki_l = 0.5_dp * (mo_spher_bess_fi_ki_lp - mo_spher_bess_fi_ki_l / arg_bess + mo_spher_bess_fi_ki_lm) + + do m1 = -l, l + do m2 = -l, l + I_lm1m2 = conjg(anc1(i1)%neighbour(n1)%spherical_harmonics(l)%m(m1)) * anc2(i2)%neighbour(n2)%spherical_harmonics(l)%m(m2) * mo_spher_bess_fi_ki_l*fac_exp + integral_r(l)%mm(m2,m1) = integral_r(l)%mm(m2,m1) + I_lm1m2 + if(present(f1)) then + grad_integral_r1(n1)%grad_integral(l)%mm(:,m2,m1) = grad_integral_r1(n1)%grad_integral(l)%mm(:,m2,m1) + & + anc2(i2)%neighbour(n2)%spherical_harmonics(l)%m(m2) * & + ( conjg(anc1(i1)%neighbour(n1)%grad_spherical_harmonics(l)%mm(:,m1)) * mo_spher_bess_fi_ki_l*fac_exp + & + conjg(anc1(i1)%neighbour(n1)%spherical_harmonics(l)%m(m1)) * ( grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp1 ) ) + endif + + if(present(f2)) then + grad_integral_r2(n2)%grad_integral(l)%mm(:,m2,m1) = grad_integral_r2(n2)%grad_integral(l)%mm(:,m2,m1) + & + conjg(anc1(i1)%neighbour(n1)%spherical_harmonics(l)%m(m1)) * & + ( anc2(i2)%neighbour(n2)%grad_spherical_harmonics(l)%mm(:,m2) * mo_spher_bess_fi_ki_l*fac_exp + & + anc2(i2)%neighbour(n2)%spherical_harmonics(l)%m(m2) * ( grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp2 ) ) + endif + + enddo + enddo + enddo + enddo + enddo + + if(present(f1)) then + f1 = 0.0_dp + do n1 = 0, size(anc1(i1)%neighbour) + do l = 0, l_max + do k = 1, 3 + f1(k,n1+1) = f1(k,n1+1) + real(sum(conjg(grad_integral_r1(n1)%grad_integral(l)%mm(k,:,:))*integral_r(l)%mm(:,:))) + enddo + enddo + enddo + f1 = 2.0_dp * f1 + endif + + if(present(f2)) then + f2 = 0.0_dp + do n2 = 0, size(anc2(i2)%neighbour) + do l = 0, l_max + do k = 1, 3 + f2(k,n2+1) = f2(k,n2+1) + real(sum(conjg(grad_integral_r2(n2)%grad_integral(l)%mm(k,:,:))*integral_r(l)%mm(:,:))) + enddo + enddo + enddo + f2 = 2.0_dp * f2 + endif + + do l = 0, l_max + real_space_covariance_in = real_space_covariance_in + sum(conjg(integral_r(l)%mm) * integral_r(l)%mm) + enddo + real_space_covariance_coefficient = real(real_space_covariance_in) + + do l = 0, l_max + deallocate(integral_r(l)%mm) + enddo + deallocate(integral_r) + + if(present(f1)) then + do n1 = 0, size(anc1(i1)%neighbour) + do l = 0, l_max + deallocate(grad_integral_r1(n1)%grad_integral(l)%mm) + enddo + deallocate(grad_integral_r1(n1)%grad_integral) + enddo + deallocate(grad_integral_r1) + endif + + if(present(f2)) then + do n2 = 0, size(anc2(i2)%neighbour) + do l = 0, l_max + deallocate(grad_integral_r2(n2)%grad_integral(l)%mm) + enddo + deallocate(grad_integral_r2(n2)%grad_integral) + enddo + deallocate(grad_integral_r2) + endif + + endfunction real_space_covariance_coefficient + + function real_space_covariance(at1,at2,i1,i2,alpha,l_max,f1,f2) + type(atoms), intent(in) :: at1, at2 + real(dp), intent(in) :: alpha + integer, intent(in) :: i1, i2, l_max + real(dp), dimension(:,:), intent(inout), optional :: f1, f2 + + real(dp) :: real_space_covariance + + complex(dp) :: real_space_covariance_in, I_lm1m2 + integer :: j1, j2, n1, n2, l, m1, m2 + real(dp) :: r1, r2, arg_bess, fac_exp, mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lm, mo_spher_bess_fi_ki_lmm + real(dp), dimension(3) :: d1, d2 + type(cplx_2d), dimension(:), allocatable :: integral_r + + logical :: do_derivative + + do_derivative = (present(f1) .or. present(f2)) + + real_space_covariance_in = CPLX_ZERO + + allocate(integral_r(0:l_max)) + do l = 0, l_max + allocate(integral_r(l)%mm(-l:l,-l:l)) + integral_r(l)%mm = CPLX_ZERO + enddo + + do n1 = 1, n_neighbours(at1,i1) + j1 = neighbour(at1,i1,n1,distance = r1, diff = d1) + do n2 = 1, n_neighbours(at2,i2) + j2 = neighbour(at2,i2,n2,distance = r2, diff = d2) + + arg_bess = alpha*r1*r2 + fac_exp = exp(-0.5_dp*alpha*(r1**2+r2**2)) + + do l = 0, l_max + if( l == 0 ) then + mo_spher_bess_fi_ki_lmm = sinh(arg_bess)/arg_bess + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm + elseif( l == 1 ) then + mo_spher_bess_fi_ki_lm = ( arg_bess*cosh(arg_bess) - sinh(arg_bess) ) / arg_bess**2 + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lm + else + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l+1)*mo_spher_bess_fi_ki_lm / arg_bess + mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l + mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm + endif + + do m1 = -l, l + do m2 = -l, l + I_lm1m2 = conjg(SphericalYCartesian(l,m1,d1)) * SphericalYCartesian(l,m2,d2)*mo_spher_bess_fi_ki_l*fac_exp + integral_r(l)%mm(m2,m1) = integral_r(l)%mm(m2,m1) + I_lm1m2 + enddo + enddo + enddo + enddo + enddo + + do l = 0, l_max + real_space_covariance_in = real_space_covariance_in + sum(conjg(integral_r(l)%mm) * integral_r(l)%mm) + enddo + real_space_covariance = real(real_space_covariance_in) + + do l = 0, l_max + deallocate(integral_r(l)%mm) + enddo + deallocate(integral_r) + + endfunction real_space_covariance + + function RadialFunction(this,r,i) + type(RadialFunction_type), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: i + + real(dp) :: RadialFunction + + real(dp), dimension(this%n_max) :: h + integer :: j + + if( r < this%cutoff ) then + do j = 1, this%n_max + h(j) = (this%cutoff-r)**(j+2) / this%NormFunction(j) + enddo + RadialFunction = dot_product(this%RadialTransform(:,i),h) + else + RadialFunction = 0.0_dp + endif + + endfunction RadialFunction + + function GradRadialFunction(this,r,i) + type(RadialFunction_type), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: i + + real(dp) :: GradRadialFunction + + real(dp), dimension(this%n_max) :: h + integer :: j + + if( r < this%cutoff ) then + do j = 1, this%n_max + h(j) = - (j+2) * (this%cutoff-r)**(j+1) / this%NormFunction(j) + enddo + GradRadialFunction = dot_product(this%RadialTransform(:,i),h) + else + GradRadialFunction = 0.0_dp + endif + + endfunction GradRadialFunction + + + + function graphIsConnected(connectivityMatrix,error) + + logical, dimension(:,:), intent(in) :: connectivityMatrix + integer, intent(out), optional :: error + logical :: graphIsConnected + + logical, dimension(:), allocatable :: visitedVertices + + INIT_ERROR(error) + + if( .not. is_square(connectivityMatrix) ) then + RAISE_ERROR("graphIsConnected: not square matrix",error) + endif + + allocate(visitedVertices(size(connectivityMatrix,1))) + + call graphBFS(connectivityMatrix,1,visitedVertices=visitedVertices,error=error) + graphIsConnected = all(visitedVertices) + + deallocate(visitedVertices) + + endfunction graphIsConnected + + subroutine graphBFS(connectivityMatrix,startVertex,visitedVertices,tree,error) + + logical, dimension(:,:), intent(in) :: connectivityMatrix + integer, intent(in) :: startVertex + logical, dimension(:), target, intent(out), optional :: visitedVertices + integer, dimension(:,:), allocatable, intent(out), optional :: tree + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: LL_edges => null(), LL_remove => null(), LL_tree => null() + + logical, dimension(:), pointer :: my_visitedVertices + integer, dimension(:), pointer :: edge + integer, dimension(2) :: vw + + INIT_ERROR(error) + + if( .not. is_square(connectivityMatrix) ) then + RAISE_ERROR("graphBFS: not square matrix",error) + endif + + if( present( visitedVertices ) ) then + my_visitedVertices => visitedVertices + else + allocate(my_visitedVertices(size(connectivityMatrix,1))) + endif + + my_visitedVertices = .false. + call graphSearch(connectivityMatrix,startVertex,LL_edges,my_visitedVertices,error) + do while( associated(LL_edges) ) + LL_remove => LL_edges + edge => retrieve_node(LL_remove) + vw = edge + call delete_node(LL_edges,LL_remove) + if( .not. my_visitedVertices(vw(2)) ) then + + if(present(tree)) call append(LL_tree,vw) + call graphSearch(connectivityMatrix, vw(2), LL_edges, my_visitedVertices,error) + endif + enddo + + if( .not. present( visitedVertices ) ) deallocate(my_visitedVertices) + + if (present(tree)) then + call retrieve(LL_tree,tree) + call finalise(LL_tree) + endif + + endsubroutine graphBFS + + subroutine graphSearch(connectivityMatrix, vertex, LL_edges, visitedVertices,error) + logical, dimension(:,:), intent(in) :: connectivityMatrix + integer, intent(in) :: vertex + type(LinkedList_i1d), pointer, intent(inout) :: LL_edges + logical, dimension(:), intent(inout) :: visitedVertices + integer, intent(out), optional :: error + + integer :: i + + INIT_ERROR(error) + + if( .not. is_square(connectivityMatrix) ) then + RAISE_ERROR("graphSearch: not square matrix",error) + endif + + visitedVertices(vertex) = .true. + + do i = 1, size(connectivityMatrix,1) + if( connectivityMatrix(i,vertex) ) call append(LL_edges,(/vertex,i/)) + enddo + + endsubroutine graphSearch + + +endmodule descriptors_module diff --git a/descriptors_wrapper.F90 b/descriptors_wrapper.F90 new file mode 100644 index 00000000..29a2cf8b --- /dev/null +++ b/descriptors_wrapper.F90 @@ -0,0 +1,587 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X descriptors_wrapper subroutine +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine descriptors_wrapper_distances(N,lattice,symbol,coord,descriptor_str,descriptor_str_len, & + calc_args_str,calc_args_str_len,i,fractional,previous_accepted,distances) + + use system_module + use linearalgebra_module + use dictionary_module + use periodictable_module + use atoms_types_module + use connection_module + use atoms_module + + use descriptors_module + + + implicit none + + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + integer, intent(in) :: descriptor_str_len + character(len=descriptor_str_len) :: descriptor_str + integer, intent(in) :: calc_args_str_len + character(len=calc_args_str_len) :: calc_args_str + real(dp), dimension(3,N), intent(in) :: coord + integer, intent(in) :: i + logical, intent(in) :: fractional, previous_accepted + real(dp), dimension(N,N), intent(out) :: distances + + type(atoms), save :: at + type(Connection), save :: at_connect_last_accepted, at_connect_previous + type(descriptor), save :: desc + type(descriptor_data) :: desc_data + real(dp), dimension(:,:), allocatable, save :: desc_array_last_accepted, distances_in_last_accepted, desc_array_previous, distances_in_previous + logical, dimension(:), pointer :: desc_mask + + integer, save :: d + integer :: j, k, l, n_i + + logical, save :: first_run = .true. + logical :: recalculate + + recalculate = .false. + + if( first_run ) then + call system_initialise(verbosity=PRINT_SILENT) + call initialise(desc,trim(descriptor_str)) + call initialise(at,N,lattice) + call add_property(at,'desc_mask',.true.,ptr=desc_mask) + + d = descriptor_dimensions(desc) + allocate(desc_array_previous(d,N), desc_array_last_accepted(d,N)) + allocate(distances_in_previous(N,N), distances_in_last_accepted(N,N)) + + recalculate = .true. + endif + + if( .not. first_run .and. (N /= at%N) ) then + call finalise(at) + call initialise(at,N,lattice) + call add_property(at,'desc_mask',.true.,ptr=desc_mask) + + if(allocated(desc_array_previous)) deallocate(desc_array_previous) + allocate(desc_array_previous(d,N)) + if(allocated(desc_array_last_accepted)) deallocate(desc_array_last_accepted) + allocate(desc_array_last_accepted(d,N)) + + if(allocated(distances_in_previous)) deallocate(distances_in_previous) + allocate(distances_in_previous(N,N)) + if(allocated(distances_in_last_accepted)) deallocate(distances_in_last_accepted) + allocate(distances_in_last_accepted(N,N)) + + recalculate = .true. + endif + + if( .not. first_run ) then + if( previous_accepted ) then + at_connect_last_accepted = at_connect_previous + desc_array_last_accepted = desc_array_previous + distances_in_last_accepted = distances_in_previous + else + at_connect_previous = at_connect_last_accepted + desc_array_previous = desc_array_last_accepted + distances_in_previous = distances_in_last_accepted + endif + endif + + if( at%lattice .fne. lattice ) then + call set_lattice(at,lattice, scale_positions=.false.) + recalculate = .true. + endif + + do k = 1, at%N + at%Z(k) = atomic_number_from_symbol(symbol(k)) + enddo + + if( i > 0 .and. previous_accepted .and. .not. recalculate ) then + if( fractional ) then + at%pos(:,i) = matmul(at%lattice,coord(:,i)) + else + at%pos(:,i) = coord(:,i) + endif + else + if( fractional ) then + at%pos = matmul(at%lattice,coord) + else + at%pos = coord + endif + endif + + call set_cutoff(at,cutoff(desc)+0.5_dp) + call calc_connect(at) + + if( .not. assign_pointer(at,'desc_mask',desc_mask) ) call system_abort("descriptors_wrapper: could not assign pointer desc_mask") + + if( i > 0 .and. .not. recalculate ) then + + if( i > at%N ) call system_abort("descriptors_wrapper: argument i = "//i//" greater than number of atoms "//at%N) + + desc_mask = .false. + + desc_mask(i) = .true. + + if( at_connect_previous%initialised ) then + do n_i = 1, n_neighbours(at,i,alt_connect=at_connect_previous) + desc_mask(neighbour(at,i,n_i,alt_connect=at_connect_previous)) = .true. + enddo + endif + + do n_i = 1, n_neighbours(at,i) + desc_mask(neighbour(at,i,n_i)) = .true. + enddo + + call calc(desc,at,desc_data,do_descriptor=.true.,do_grad_descriptor=.false.,args_str="atom_mask_name=desc_mask "//trim(calc_args_str)) + + do k = 1, count(desc_mask) + j = desc_data%x(k)%ci(1) + desc_array_previous(:,j) = desc_data%x(k)%data(:) + enddo + + do k = 1, count(desc_mask) + j = desc_data%x(k)%ci(1) + do l = 1, at%N + distances_in_previous(l,j) = sum( desc_array_previous(:,l) * desc_array_previous(:,j) ) + distances_in_previous(j,l) = distances_in_previous(l,j) + enddo + enddo + desc_mask = .true. + at_connect_previous = at%connect + else + call calc(desc,at,desc_data,do_descriptor=.true.,do_grad_descriptor=.false.,args_str=trim(calc_args_str)) + do j = 1, at%N + desc_array_previous(:,j) = desc_data%x(j)%data + enddo + + distances_in_previous = matmul(transpose(desc_array_previous),desc_array_previous) + + at_connect_previous = at%connect + endif + + distances = -log(distances_in_previous) + + call finalise(desc_data) + + if( first_run ) then + at_connect_last_accepted = at_connect_previous + desc_array_last_accepted = desc_array_previous + distances_in_last_accepted = distances_in_previous + endif + first_run = .false. + +endsubroutine descriptors_wrapper_distances + +module descriptors_wrapper_module + +use system_module +use periodictable_module, only : atomic_number_from_symbol +use atoms_module +use linearalgebra_module +use descriptors_module, only : descriptor, initialise, finalise, cutoff, calc, descriptor_sizes, descriptor_dimensions + +implicit none + +#ifdef HAVE_GAP +type(descriptor), save :: desc +#endif + +logical :: first_run = .true. + +contains + + subroutine descriptors_wrapper_initialise(descriptor_str) + + character(len=*) :: descriptor_str + +#ifdef HAVE_GAP + if( first_run ) then + call system_initialise(verbosity=PRINT_SILENT) + call initialise(desc,trim(descriptor_str)) + else + call finalise(desc) + call initialise(desc,trim(descriptor_str)) + endif + first_run = .false. +#endif + endsubroutine descriptors_wrapper_initialise + + subroutine descriptors_wrapper_initialise_C(descriptor_str,n_descriptor_str) bind(c) + + use iso_c_binding, only: c_int, c_char + + character(kind=c_char), intent(in) :: descriptor_str(n_descriptor_str) + integer(kind=c_int), intent(in) :: n_descriptor_str + + call descriptors_wrapper_initialise(trim(a2s(descriptor_str))) + + endsubroutine descriptors_wrapper_initialise_C + + function descriptors_wrapper_dimensions() + integer :: descriptors_wrapper_dimensions + + if(.not. first_run) then + descriptors_wrapper_dimensions = descriptor_dimensions(desc) + else + call system_abort("descriptors_wrapper_dimensions: initialise with calling descriptors_wrapper_initialise() first.") + endif + + endfunction descriptors_wrapper_dimensions + + function descriptors_wrapper_dimensions_C() bind(c) + use iso_c_binding, only: c_int + integer(kind=c_int) :: descriptors_wrapper_dimensions_C + + descriptors_wrapper_dimensions_C = descriptors_wrapper_dimensions() + endfunction descriptors_wrapper_dimensions_C + + function descriptors_wrapper_size(N,lattice,symbol,coord,fractional) + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + + integer :: descriptors_wrapper_size + + type(atoms), save :: at + integer :: n_descriptors,n_cross + + call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + call descriptor_sizes(desc,at,n_descriptors,n_cross) + + descriptors_wrapper_size = n_descriptors + + endfunction descriptors_wrapper_size + + function descriptors_wrapper_size_C(N,lattice,symbol,coord,fractional) bind(c) + + use iso_c_binding, only: c_double, c_int, c_bool, c_char + + integer(kind=c_int), intent(in) :: N + real(kind=c_double), dimension(3,3), intent(inout) :: lattice + character(kind=c_char), dimension(3,N), intent(in) :: symbol + real(kind=c_double), dimension(3,N), intent(in) :: coord + logical(kind=c_bool), intent(in) :: fractional + + integer(kind=c_int) :: descriptors_wrapper_size_C + + character(len=3), dimension(N) :: my_symbol + integer :: i + logical :: my_fractional + + do i = 1, N + my_symbol(i) = a2s(symbol(:,i)) + enddo + + my_fractional = logical(fractional,kind=kind(my_fractional)) + descriptors_wrapper_size_C = descriptors_wrapper_size(N,lattice,my_symbol,coord,my_fractional) + + endfunction descriptors_wrapper_size_C + + function descriptors_wrapper_gradient_size(N,lattice,symbol,coord,fractional) + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + + integer :: descriptors_wrapper_gradient_size + + type(atoms), save :: at + integer :: n_descriptors,n_cross + + call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + call descriptor_sizes(desc,at,n_descriptors,n_cross) + + descriptors_wrapper_gradient_size = n_cross + + endfunction descriptors_wrapper_gradient_size + + function descriptors_wrapper_gradient_size_C(N,lattice,symbol,coord,fractional) bind(c) + + use iso_c_binding, only: c_double, c_int, c_bool, c_char + + integer(kind=c_int), intent(in) :: N + real(kind=c_double), dimension(3,3), intent(inout) :: lattice + character(kind=c_char), dimension(3,N), intent(in) :: symbol + real(kind=c_double), dimension(3,N), intent(in) :: coord + logical(kind=c_bool), intent(in) :: fractional + + integer(kind=c_int) :: descriptors_wrapper_gradient_size_C + + character(len=3), dimension(N) :: my_symbol + integer :: i + logical :: my_fractional + + do i = 1, N + my_symbol(i) = a2s(symbol(:,i)) + enddo + + my_fractional = logical(fractional,kind=kind(my_fractional)) + descriptors_wrapper_gradient_size_C = descriptors_wrapper_gradient_size(N,lattice,my_symbol,coord,my_fractional) + + endfunction descriptors_wrapper_gradient_size_C + + subroutine descriptors_wrapper_both_sizes(N,lattice,symbol,coord,fractional,n_descriptors,n_cross) + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + integer, intent(out) :: n_descriptors, n_cross + + type(atoms), save :: at + + call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + call descriptor_sizes(desc,at,n_descriptors,n_cross) + + endsubroutine descriptors_wrapper_both_sizes + + subroutine descriptors_wrapper_both_sizes_C(N,lattice,symbol,coord,fractional,n_descriptors,n_cross) bind(c) + + use iso_c_binding, only: c_double, c_int, c_bool, c_char + + integer(kind=c_int), intent(in) :: N + real(kind=c_double), dimension(3,3), intent(inout) :: lattice + character(kind=c_char), dimension(3,N), intent(in) :: symbol + real(kind=c_double), dimension(3,N), intent(in) :: coord + logical(kind=c_bool), intent(in) :: fractional + integer(kind=c_int), intent(out) :: n_descriptors, n_cross + + character(len=3), dimension(N) :: my_symbol + integer :: i + logical :: my_fractional + + do i = 1, N + my_symbol(i) = a2s(symbol(:,i)) + enddo + + my_fractional = logical(fractional,kind=kind(my_fractional)) + call descriptors_wrapper_both_sizes(N,lattice,my_symbol,coord,my_fractional,n_descriptors,n_cross) + + endsubroutine descriptors_wrapper_both_sizes_C + + subroutine descriptors_wrapper_array(N,lattice,symbol,coord,fractional,descriptor_array,d_descriptor, n_descriptor) + + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + integer, intent(in) :: d_descriptor, n_descriptor + real(dp), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array + + type(atoms), save :: at + + if( first_run ) then + call system_abort("descriptors_wrapper_array: initialise with calling descriptors_wrapper_initialise() first.") + endif + + call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + call calc(desc,at,descriptor_array) + + endsubroutine descriptors_wrapper_array + + subroutine descriptors_wrapper_array_C(N,lattice,symbol,coord,fractional,descriptor_array,d_descriptor, n_descriptor) bind(c) + + use iso_c_binding, only: c_double, c_int, c_bool, c_char + + integer(kind=c_int), intent(in) :: N + real(kind=c_double), dimension(3,3), intent(inout) :: lattice + character(kind=c_char), dimension(3,N), intent(in) :: symbol + real(kind=c_double), dimension(3,N), intent(in) :: coord + logical(kind=c_bool), intent(in) :: fractional + integer(kind=c_int), intent(in) :: d_descriptor, n_descriptor + real(kind=c_double), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array + + character(len=3), dimension(N) :: my_symbol + integer :: i + logical :: my_fractional + + do i = 1, N + my_symbol(i) = a2s(symbol(:,i)) + enddo + + my_fractional = logical(fractional,kind=kind(my_fractional)) + call descriptors_wrapper_array(N,lattice,my_symbol,coord,my_fractional,descriptor_array,d_descriptor,n_descriptor) + + endsubroutine descriptors_wrapper_array_C + + subroutine descriptors_wrapper_gradient_array(N,lattice,symbol,coord,fractional,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_cross) + + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + integer, intent(in) :: d_descriptor, n_cross + real(dp), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array + integer, dimension(2,n_cross), intent(out):: grad_descriptor_index + real(dp), dimension(3,n_cross), intent(out):: grad_descriptor_pos + + type(atoms), save :: at + + if( first_run ) then + call system_abort("descriptors_wrapper_gradient_array: initialise with calling descriptors_wrapper_initialise() first.") + endif + + call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + call calc(desc,at,grad_descriptor_out=grad_descriptor_array,grad_descriptor_index=grad_descriptor_index,grad_descriptor_pos=grad_descriptor_pos) + + endsubroutine descriptors_wrapper_gradient_array + + subroutine descriptors_wrapper_gradient_array_C(N,lattice,symbol,coord,fractional,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_cross) bind(c) + + use iso_c_binding, only: c_double, c_int, c_bool, c_char + + integer(kind=c_int), intent(in) :: N + real(kind=c_double), dimension(3,3), intent(inout) :: lattice + character(kind=c_char), dimension(3,N), intent(in) :: symbol + real(kind=c_double), dimension(3,N), intent(in) :: coord + logical(kind=c_bool), intent(in) :: fractional + integer(kind=c_int), intent(in) :: d_descriptor, n_cross + real(kind=c_double), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array + integer(kind=c_int), dimension(2,n_cross), intent(out):: grad_descriptor_index + real(kind=c_double), dimension(3,n_cross), intent(out):: grad_descriptor_pos + + character(len=3), dimension(N) :: my_symbol + integer :: i + logical :: my_fractional + + do i = 1, N + my_symbol(i) = a2s(symbol(:,i)) + enddo + + my_fractional = logical(fractional,kind=kind(my_fractional)) + call descriptors_wrapper_gradient_array(N,lattice,my_symbol,coord,my_fractional,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_cross) + + endsubroutine descriptors_wrapper_gradient_array_C + + subroutine descriptors_wrapper_both_arrays(N,lattice,symbol,coord,fractional,descriptor_array,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_descriptor,n_cross) + + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + integer, intent(in) :: d_descriptor, n_descriptor, n_cross + real(dp), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array + real(dp), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array + integer, dimension(2,n_cross), intent(out):: grad_descriptor_index + real(dp), dimension(3,n_cross), intent(out):: grad_descriptor_pos + + type(atoms), save :: at + + if( first_run ) then + call system_abort("descriptors_wrapper_both_arrays: initialise with calling descriptors_wrapper_initialise() first.") + endif + + call copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + call calc(desc,at,descriptor_out=descriptor_array,grad_descriptor_out=grad_descriptor_array,grad_descriptor_index=grad_descriptor_index,grad_descriptor_pos=grad_descriptor_pos) + + endsubroutine descriptors_wrapper_both_arrays + + subroutine descriptors_wrapper_both_arrays_C(N,lattice,symbol,coord,fractional,descriptor_array,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_descriptor,n_cross) bind(c) + + use iso_c_binding, only: c_double, c_int, c_bool, c_char + + integer(kind=c_int), intent(in) :: N + real(kind=c_double), dimension(3,3), intent(inout) :: lattice + character(kind=c_char), dimension(3,N), intent(in) :: symbol + real(kind=c_double), dimension(3,N), intent(in) :: coord + logical(kind=c_bool), intent(in) :: fractional + integer(kind=c_int), intent(in) :: d_descriptor, n_descriptor, n_cross + real(kind=c_double), dimension(d_descriptor,n_descriptor), intent(out):: descriptor_array + real(kind=c_double), dimension(d_descriptor,3,n_cross), intent(out):: grad_descriptor_array + integer(kind=c_int), dimension(2,n_cross), intent(out):: grad_descriptor_index + real(kind=c_double), dimension(3,n_cross), intent(out):: grad_descriptor_pos + + character(len=3), dimension(N) :: my_symbol + integer :: i + logical :: my_fractional + + do i = 1, N + my_symbol(i) = a2s(symbol(:,i)) + enddo + + my_fractional = logical(fractional,kind=kind(my_fractional)) + call descriptors_wrapper_both_arrays(N,lattice,my_symbol,coord,my_fractional,descriptor_array,grad_descriptor_array,grad_descriptor_index,grad_descriptor_pos,d_descriptor,n_descriptor,n_cross) + + endsubroutine descriptors_wrapper_both_arrays_C + + subroutine copy_data_to_atoms(at,N,lattice,symbol,coord,fractional) + type(atoms), intent(inout) :: at + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + real(dp), dimension(3,N), intent(in) :: coord + logical, intent(in) :: fractional + + integer :: k + + if( N /= at%N ) then + call finalise(at) + call initialise(at,N,lattice) + endif + + if( at%lattice .fne. lattice ) then + call set_lattice(at,lattice, scale_positions=.false.) + endif + + do k = 1, at%N + at%Z(k) = atomic_number_from_symbol(symbol(k)) + enddo + + if( fractional ) then + at%pos = matmul(at%lattice,coord) + else + at%pos = coord + endif + + call set_cutoff(at,cutoff(desc)+0.5_dp) + call calc_connect(at) + + endsubroutine copy_data_to_atoms + +endmodule descriptors_wrapper_module diff --git a/find_water_triplets_noncommercial.F90 b/find_water_triplets_noncommercial.F90 new file mode 100644 index 00000000..e7731e6a --- /dev/null +++ b/find_water_triplets_noncommercial.F90 @@ -0,0 +1,485 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!!!!!!!! +!!! This file was written by Jonatan Öström (@sujona, jonatan.ostrom@gmail.com) and Lars G.M. Pettersson, Stockholm University +!!! Here are implementations of water-trimer search routines, that work only for orthogonal unit cells with the shortest dimension longer than 2 x (3-body cutoff) +!!!!!!!! + +module find_water_triplets + ! use backend + implicit none + integer, parameter :: dp = kind(0d0) + + interface insert + module procedure insert_i2, insert_r2, insert_i1 + end interface + + +contains + +! //////////////////////////////////////////////// +! Dynamic insert in allocatable array +! insert(a,i,x) does a(i) = x but reallocates a to length 2*i if len(a) < i + +subroutine insert_i1(array,ii,val) + integer, intent(inout), allocatable :: array(:) + integer, intent(in) :: ii, val + integer, allocatable :: tmp(:) + if (ii>size(array))then + tmp = array + deallocate(array) + allocate(array(2*ii)) + array(:size(tmp)) = tmp + endif + array(ii) = val +end +subroutine insert_i2(array,ii,val) + integer, intent(inout), allocatable :: array(:,:) + integer, intent(in) :: ii, val(:) + integer, allocatable :: tmp(:,:) + if (ii>size(array,2))then + tmp = array + deallocate(array) + allocate(array(size(tmp,1),2*ii)) + array(:,:size(tmp,2)) = tmp + endif + array(:,ii) = val +end +subroutine insert_r2(array,ii,val) + real(dp), intent(inout), allocatable :: array(:,:) + real(dp), intent(in) :: val(:) + integer, intent(in) :: ii + real(dp), allocatable :: tmp(:,:) + if (ii>size(array,2))then + tmp = array + deallocate(array) + allocate(array(size(tmp,1),2*ii)) + array(:,:size(tmp,2)) = tmp + endif + array(:,ii) = val +end + +! //////////////////////////////////////////////// +! Utilitity routines + +subroutine min_img(XO,NO,i1,i2,box,lsq,x12,s12) + real(dp), intent(in) :: XO(3,NO), box(3) + integer, intent(in) :: NO, i1, i2 + real(dp), intent(out) :: lsq + real(dp), intent(out) :: x12(3) + integer, intent(out) :: s12(3) + x12 = XO(:,i1)-XO(:,i2) + s12 = nint(x12/box) + x12 = x12 - s12*box + lsq = sum(x12**2) +end + +subroutine min_img_c(XO,XC,NO,i1,i2,box,lsq,x12,c12,s12) + real(dp), intent(in) :: XO(3,NO), XC(3,NO), box(3) + integer, intent(in) :: NO, i1, i2 + real(dp), intent(out) :: lsq + real(dp), intent(out) :: x12(3), c12(3) + integer, intent(out) :: s12(3) + c12 = XC(:,i2)-XC(:,i1) + s12 = -nint(c12/box) + x12 = XO(:,i2)-XO(:,i1) + x12 = x12 + s12*box + c12 = c12 + s12*box + lsq = sum(x12**2) +end + +subroutine average_position(NW,XW,XC,XO) + integer, intent(in) :: NW + real(dp), intent(in) :: XW(3,NW*3) + real(dp), intent(out) :: XC(3,NW),XO(3,NW) + integer ii,jj,kk + do ii = 1,NW + jj = 3*(ii-1) !+1,2,3 for O,H,H + XO(:,ii) = XW(:,jj+1) + XC(:,ii) = 0 + do kk = 1,3 + XC(:,ii) = XC(:,ii) + XW(:,jj+kk)/3 + enddo + enddo +end + +function wall_time() result(tt) + integer count,count_rate + real(dp) tt + call system_clock(count,count_rate) + tt = dble(count)/count_rate +end +subroutine take(tt,text) + real(dp), intent(inout) :: tt + real(dp) :: old + character(*), intent(in) :: text + old = tt + tt = wall_time() + print'(f6.3,a)',tt-old,"s "//text +end + + +! //////////////////////////////////////////////// +! Finding triplets + +subroutine find_triplets_brute_force(XW,NW,box,rcut,n_trip) + ! find water triplets with brute force + integer, intent(in) :: NW + real(dp), intent(in) :: XW(3,NW*3), box(3), rcut + integer, intent(out) :: n_trip + real(dp) :: rcut2, d2ij, d2ik,d2jk, XC(3,NW),XO(3,NW) + integer ii,jj,kk, n_short !n_2, n_3, + real(dp),dimension(3) :: xij,xik,xjk ! Oxygen diff + real(dp),dimension(3) :: cij,cik,cjk ! Center diff + integer, dimension(3) :: sij,sik,sjk ! Shifts + rcut2 = rcut**2 + + call average_position(NW,XW,XC,XO) + + !!! $omp parallel do private(d2ij, d2ik,d2jk,n_short) reduction(+:n_2,n_3) + write(13,'(a)') ' ' + write(13,'(a)') ' TRIPLETS' + write(13,'(a)') ' ' + do ii = 1,NW + do jj = ii+1,NW + call min_img_c(XO,XC,NW,ii,jj,box,d2ij,xij,cij,sij) + do kk = jj+1,NW + call min_img_c(XO,XC,NW,ii,kk,box,d2ik,xik,cik,sik) + call min_img_c(XO,XC,NW,jj,kk,box,d2jk,xjk,cjk,sjk) + n_short = count([d2ij,d2ik,d2jk]1)then + n_trip = n_trip+1 + write(13,'(3i5,2(3i3,2x),2(3f10.5,2x))') ii,jj,kk, sij, sik, cij,cik + endif + enddo + enddo + enddo +end + +subroutine find_pairs_jona(XW,NO,box,rcut,n_pair,id2, sh2, dx2) + integer, intent(in) :: NO + real(dp), intent(in) :: XW(3,NO*3), box(3), rcut + integer, intent(out) :: n_pair + real(dp) :: rcut2, d2ij, xij(3), cij(3), XO(3,NO*3), XC(3,NO*3) + integer ii,jj, sij(3) + integer, allocatable, dimension(:,:), intent(out) :: id2, sh2 + real(dp), allocatable, dimension(:,:), intent(out) :: dx2 + allocate(id2(2,0), sh2(3,0), dx2(3,0)) + call average_position(NO,XW,XC,XO) + rcut2 = rcut**2 + n_pair = 0 + do ii = 1,NO + do jj = ii+1,NO + call min_img_c(XO,XC,NO,ii,jj,box,d2ij,xij,cij,sij) + if (d2ijii in G(ii) + do jl = 1,ncount(ii) + jj = nindex(i0+jl) + j0 = offset(jj) + sij = sh2(:,i0+jl) + cij = dx2(:,i0+jl) + if (iijj in G(ii) to get ii=a, jj=b, kk=c + do kl = jl+1,ncount(ii) + kk = nindex(i0+kl) + n_trip = n_trip + 1 + sik = sh2(:,i0+kl) + cik = dx2(:,i0+kl) + call insert(id3, n_trip, [ii,jj,kk]) + call insert(sh3, n_trip, [sij,sik]) + call insert(dx3, n_trip, [cij,cik]) + enddo + ! 2. a-b-c & 3. a-c-b: take kk>ii in G(jj)\G(ii) so that ii=a, jj=b/c, kk=c/b + do kl = 1,ncount(jj) + kk = nindex(j0+kl) + if (ii N(i) means j runs over the (N)eighbors of i + ! case 1. c-a-b-(c-) : let i N(i) and k -> N(i) + n_trip = 0 + do ii = 1, NO - 1 + i0 = ioff(ii) + i1 = ioff(ii+1) + do jl = 1, num(ii) - 1 + jj = neighbor(i0 + jl) + ! sij = sh2(:,i0 + jl) + cij = dx2(:,i0 + jl) + do kl = jl + 1, num(ii) + kk = neighbor(i0 + kl) + n_trip = n_trip + 1 + ! sik = sh2(:,i0 + kl) + cik = dx2(:,i0 + kl) + + call insert(id3, n_trip, [ii,jj,kk]) + ! call insert(sh3, n_trip, [sij,sik]) + call insert(dx3, n_trip, [cij,cik]) + + enddo + enddo + ! case 2. a-b-c : let iN(i) and k -> N(j)\N(i) + do jl = 1, num(ii) + jj = neighbor(i0 + jl) + j0 = ioff(jj) + ! sij = sh2(:,i0 + jl) + cij = dx2(:,i0 + jl) + do kl = 1, num(jj) !(1) + kk = neighbor(j0 + kl) !(2) + if (any(neighbor(i0+1:i1)==kk)) cycle + n_trip = n_trip + 1 + + ! sik = sh2(:,i0 + jl) + sh2(:,j0 + kl) + cik = dx2(:,i0 + jl) + dx2(:,j0 + kl) + + call insert(id3, n_trip, [ii,jj,kk]) + ! call insert(sh3, n_trip, [sij,sik]) + call insert(dx3, n_trip, [cij,cik]) + enddo + ! case 3. a-c-b : let i=a < k=b < j=c, so for j->N(i) find k->N(j)\N(i) + ! since k[i+1,j-1], exclude k->N(i) and include k when j->N(k) + do kk = ii + 1, jj - 1 + k0 = ioff(kk) + do jn = 1, num(kk) + if (jj /= neighbor(k0+jn)) cycle ! include j->N(k) + if (any(kk==neighbor(i0+1:i1))) cycle ! exclude k->N(i) + n_trip = n_trip + 1 + + ! sik = sh2(:,i0 + jl) - sh2(:,k0 + jn) + cik = dx2(:,i0 + jl) - dx2(:,k0 + jn) + + ! insert in i 1) call fit_n_from_xyz(main_gap_fit) + call gap_fit_set_mpi_blocksizes(main_gap_fit) + call gap_fit_estimate_memory(main_gap_fit) + + if (main_gap_fit%dryrun) then + call print('Exit before major allocations because dryrun is true.') + call system_finalise() + stop + end if + + call set_baselines(main_gap_fit) ! sets e0 etc. + + call fit_data_from_xyz(main_gap_fit) ! converts atomic neighbourhoods (bond neighbourhoods etc.) do descriptors, and feeds those to the GP + call print('Cartesian coordinates transformed to descriptors') + + if(main_gap_fit%sparsify_only_no_fit) then + if (gap_fit_is_root(main_gap_fit)) then + call initialise(main_gap_fit%gp_sp, main_gap_fit%my_gp) + call gap_fit_print_xml(main_gap_fit, main_gap_fit%gp_file, main_gap_fit%sparseX_separate_file) + end if + call system_finalise() + stop + end if + + call enable_timing() + call system_timer('GP sparsify') + + call gp_covariance_sparse(main_gap_fit%my_gp) + call gap_fit_print_linear_system_dump_file(main_gap_fit) + call gpSparse_fit(main_gap_fit%gp_sp, main_gap_fit%my_gp, main_gap_fit%task_manager, main_gap_fit%condition_number_norm) + + if (gap_fit_is_root(main_gap_fit)) call gap_fit_print_xml(main_gap_fit, main_gap_fit%gp_file, main_gap_fit%sparseX_separate_file) + + call system_timer('GP sparsify') + call system_finalise() + +end program gap_fit_program diff --git a/gap_fit_module.F90 b/gap_fit_module.F90 new file mode 100644 index 00000000..047333c6 --- /dev/null +++ b/gap_fit_module.F90 @@ -0,0 +1,2393 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X and Sascha Klawohn. Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module gap_fit_module + + use error_module + use libatoms_module + use descriptors_module + use gp_predict_module + use gp_fit_module + use fox_wxml + use potential_module + use ScaLAPACK_module + use task_manager_module + use MPI_context_module, only : is_root + + implicit none + + integer, parameter :: SPARSE_LENGTH = 10000 + integer, parameter :: THETA_LENGTH = 10000 + integer, parameter :: GAP_STRING_SIZE = 200 + + integer, parameter :: E0_ISOLATED = 1 + integer, parameter :: E0_AVERAGE = 2 + integer, parameter :: EXCLUDE_LOC = -1 + +#ifdef GAP_VERSION + integer, parameter, private :: gap_version = GAP_VERSION +#else + integer, parameter, private :: gap_version = huge(1) +#endif + + type gap_fit + !% everything from the command line + type(Atoms), dimension(:), allocatable :: at + + character(len=STRING_LENGTH) :: at_file='', core_ip_args = '', e0_str, local_property0_str, & + energy_parameter_name, local_property_parameter_name, force_parameter_name, virial_parameter_name, & + stress_parameter_name, hessian_parameter_name, config_type_parameter_name, sigma_parameter_name, & + config_type_sigma_string, core_param_file, gp_file, template_file, force_mask_parameter_name, & + local_property_mask_parameter_name, condition_number_norm, linear_system_dump_file, config_file + + character(len=10240) :: command_line = '' + real(dp), dimension(total_elements) :: e0, local_property0 + real(dp) :: max_cutoff + real(dp), dimension(4) :: default_sigma + real(dp) :: default_local_property_sigma + real(dp) :: sparse_jitter, e0_offset, hessian_delta + integer :: e0_method = E0_ISOLATED + logical :: do_core = .false., do_copy_at_file, has_config_type_sigma, sigma_per_atom = .true. + logical :: sparsify_only_no_fit = .false. + logical :: dryrun = .false. + integer :: n_frame = 0 + integer :: n_coordinate = 0 + integer :: n_ener = 0 + integer :: n_force = 0 + integer :: n_virial = 0 + integer :: n_hessian = 0 + integer :: n_local_property = 0 + integer :: n_species = 0 + integer :: min_save + integer :: mpi_blocksize_rows = 0 + integer :: mpi_blocksize_cols = 0 + type(extendable_str) :: quip_string, config_string + type(Potential) :: core_pot + + type(gpFull) :: my_gp + type(gpSparse) :: gp_sp + + type(MPI_Context) :: mpi_obj + type(ScaLAPACK) :: ScaLAPACK_obj + type(task_manager_type) :: task_manager + + type(descriptor), dimension(:), allocatable :: my_descriptor + character(len=STRING_LENGTH), dimension(:), allocatable :: gap_str + + real(dp), dimension(:), allocatable :: delta, f0, theta_uniform, zeta, unique_hash_tolerance, unique_descriptor_tolerance !, theta + real(dp), dimension(:,:), allocatable :: sigma + integer, dimension(:), allocatable :: n_sparseX, sparse_method, target_type, n_cross, n_descriptors, species_Z, covariance_type + integer, dimension(:,:), allocatable :: config_type_n_sparseX + character(len=STRING_LENGTH), dimension(:), allocatable :: theta_file, sparse_file, theta_fac_string, config_type, config_type_n_sparseX_string, print_sparse_index + logical, dimension(:), allocatable :: mark_sparse_atoms, add_species, has_theta_fac, has_theta_uniform, has_theta_file, has_zeta + + logical :: sparseX_separate_file + logical :: sparse_use_actual_gpcov + logical :: has_template_file, has_e0, has_local_property0, has_e0_offset, has_linear_system_dump_file, has_config_file + + endtype gap_fit + + private + + public :: fit_n_from_xyz + public :: fit_data_from_xyz + public :: e0_from_xyz + public :: w_Z_from_xyz + public :: gap_fit + public :: gap_fit_print_xml + public :: file_print_xml +! public :: print_sparse + public :: set_baselines + public :: get_n_sparseX_for_files + public :: parse_config_type_sigma + public :: parse_config_type_n_sparseX + public :: read_fit_xyz + public :: read_descriptors + public :: get_species_xyz + public :: add_multispecies_gaps + public :: add_template_string + public :: gap_fit_parse_command_line + public :: gap_fit_parse_gap_str + public :: gap_fit_read_core_param_file + + public :: gap_fit_init_mpi_scalapack + public :: gap_fit_init_task_manager + public :: gap_fit_distribute_tasks + public :: gap_fit_set_mpi_blocksizes + + public :: gap_fit_is_root + + public :: gap_fit_print_linear_system_dump_file + public :: gap_fit_estimate_memory + +contains + + subroutine gap_fit_parse_command_line(this) + !% This subroutine parses the main command line options. + type(gap_fit), intent(inout), target :: this + + type(Dictionary) :: params + + character(len=STRING_LENGTH), pointer :: at_file, e0_str, local_property0_str, & + core_param_file, core_ip_args, & + energy_parameter_name, local_property_parameter_name, force_parameter_name, & + virial_parameter_name, stress_parameter_name, hessian_parameter_name, & + config_type_parameter_name, sigma_parameter_name, config_type_sigma_string, & + gp_file, template_file, force_mask_parameter_name, condition_number_norm, & + linear_system_dump_file, config_file, local_property_mask_parameter_name + + character(len=STRING_LENGTH) :: gap_str, verbosity, sparse_method_str, covariance_type_str, e0_method, & + parameter_name_prefix + + logical, pointer :: sigma_per_atom, do_copy_at_file, sparseX_separate_file, sparse_use_actual_gpcov, sparsify_only_no_fit + logical, pointer :: dryrun, do_export_covariance + logical :: do_ip_timing, has_sparse_file, has_theta_uniform, has_at_file, has_gap, has_config_file, has_default_sigma + logical :: mpi_print_all, file_exists + + real(dp), pointer :: e0_offset, sparse_jitter, hessian_delta + real(dp), dimension(:), pointer :: default_sigma + real(dp), pointer :: default_local_property_sigma + + integer :: rnd_seed + integer, pointer :: mpi_blocksize_rows, mpi_blocksize_cols + + config_file => this%config_file + at_file => this%at_file + e0_str => this%e0_str + local_property0_str => this%local_property0_str + e0_offset => this%e0_offset + default_sigma => this%default_sigma + default_local_property_sigma => this%default_local_property_sigma + sparse_jitter => this%sparse_jitter + hessian_delta => this%hessian_delta + core_param_file => this%core_param_file + core_ip_args => this%core_ip_args + energy_parameter_name => this%energy_parameter_name + local_property_parameter_name => this%local_property_parameter_name + force_parameter_name => this%force_parameter_name + virial_parameter_name => this%virial_parameter_name + stress_parameter_name => this%stress_parameter_name + hessian_parameter_name => this%hessian_parameter_name + config_type_parameter_name => this%config_type_parameter_name + sigma_parameter_name => this%sigma_parameter_name + force_mask_parameter_name => this%force_mask_parameter_name + local_property_mask_parameter_name => this%local_property_mask_parameter_name + config_type_sigma_string => this%config_type_sigma_string + sigma_per_atom => this%sigma_per_atom + do_copy_at_file => this%do_copy_at_file + sparseX_separate_file => this%sparseX_separate_file + sparse_use_actual_gpcov => this%sparse_use_actual_gpcov + gp_file => this%gp_file + template_file => this%template_file + sparsify_only_no_fit => this%sparsify_only_no_fit + dryrun => this%dryrun + condition_number_norm => this%condition_number_norm + linear_system_dump_file => this%linear_system_dump_file + mpi_blocksize_rows => this%mpi_blocksize_rows + mpi_blocksize_cols => this%mpi_blocksize_cols + do_export_covariance => this%gp_sp%do_export_R + + call initialise(params) + + call param_register(params, 'config_file', '', config_file, has_value_target=has_config_file, & + help_string="File as alternative input (newlines converted to spaces)") + + ! check if config file is given, ignore everything else + ! prepare parsing of config file or command line string later + if (param_read_args(params, ignore_unknown=.true., command_line=this%command_line)) then + if (has_config_file) then + inquire(file=config_file, exist=file_exists) + if (.not. file_exists) call system_abort("Config file does not exist: "//config_file) + call read(this%config_string, config_file, keep_lf=.true., mpi_comm=this%mpi_obj%communicator, mpi_id=this%mpi_obj%my_proc) + end if + end if + if (.not. has_config_file) this%config_string = this%command_line + this%has_config_file = has_config_file + + call param_register(params, 'atoms_filename', '//MANDATORY//', at_file, has_value_target = has_at_file, help_string="XYZ file with fitting configurations", altkey="at_file") + call param_register(params, 'gap', '//MANDATORY//', gap_str, has_value_target = has_gap, help_string="Initialisation string for GAPs") + call param_register(params, 'e0', '0.0', e0_str, has_value_target = this%has_e0, & + help_string="Atomic energy value to be subtracted from energies before fitting (and added back on after prediction). & + & Specifiy a single number (used for all species) or by species: {Ti:-150.0:O:-320...}. energy = baseline + GAP + e0") + + call param_register(params, 'local_property0', '0.0', local_property0_str, has_value_target = this%has_local_property0, & + help_string="Local property value to be subtracted from the local property before fitting (and added back on after prediction). & + & Specifiy a single number (used for all species) or by species: {H:20.0:Cl:35.0...}.") + + call param_register(params, 'e0_offset', '0.0', e0_offset, has_value_target = this%has_e0_offset, & + help_string="Offset of baseline. If zero, the offset is the average atomic energy of the input data or the e0 specified manually.") + + call param_register(params, 'e0_method','isolated',e0_method, & + help_string="Method to determine e0, if not explicitly specified. Possible options: isolated (default, each atom & + present in the XYZ needs to have an isolated representative, with a valid energy), average (e0 is the average of & + all total energies across the XYZ)") + + call param_register(params, 'default_kernel_regularisation', '//MANDATORY//', default_sigma, has_value_target = has_default_sigma, & + help_string="error in [energies forces virials hessians]", altkey="default_sigma") + + call param_register(params, 'default_kernel_regularisation_local_property', '0.001', default_local_property_sigma, & + help_string="error in local_property", altkey="default_local_property_sigma") + + call param_register(params, 'sparse_jitter', "1.0e-10", sparse_jitter, & + help_string="Extra regulariser used to regularise the sparse covariance matrix before it is passed to the linear solver. Use something small, it really shouldn't affect your results, if it does, your sparse basis is still very ill-conditioned.") + + call param_register(params, 'hessian_displacement', "1.0e-2", hessian_delta, & + help_string="Finite displacement to use in numerical differentiation when obtaining second derivative for the Hessian covariance", altkey="hessian_delta") + + call param_register(params, 'baseline_param_filename', 'quip_params.xml', core_param_file, & + help_string="QUIP XML file which contains a potential to subtract from data (and added back after prediction)", altkey="core_param_file") + + call param_register(params, 'baseline_ip_args', '', core_ip_args, has_value_target = this%do_core, & + help_string=" QUIP init string for a potential to subtract from data (and added back after prediction)", altkey="core_ip_args") + + call param_register(params, 'energy_parameter_name', 'energy', energy_parameter_name, & + help_string="Name of energy property in the input XYZ file that describes the data") + + call param_register(params, 'local_property_parameter_name', 'local_property', local_property_parameter_name, & + help_string="Name of local_property (column) in the input XYZ file that describes the data") + + call param_register(params, 'force_parameter_name', 'force', force_parameter_name, & + help_string="Name of force property (columns) in the input XYZ file that describes the data") + + call param_register(params, 'virial_parameter_name', 'virial', virial_parameter_name, & + help_string="Name of virial property in the input XYZ file that describes the data") + + call param_register(params, 'stress_parameter_name', 'stress', stress_parameter_name, & + help_string="Name of stress property (6-vector or 9-vector) in the input XYZ file that describes the data - stress values only used if virials are not available (opposite sign, standard Voigt order)") + + call param_register(params, 'hessian_parameter_name', 'hessian', hessian_parameter_name, & + help_string="Name of hessian property (column) in the input XYZ file that describes the data") + + call param_register(params, 'config_type_parameter_name', 'config_type', config_type_parameter_name, & + help_string="Allows grouping on configurations into. This option is the name of the key that indicates the configuration type in the input XYZ file. With the default, the key-value pair config_type=blah would place that configuration into the group blah.") + + call param_register(params, 'kernel_regularisation_parameter_name', 'sigma', sigma_parameter_name, & + help_string="kernel regularisation parameters for a given configuration in the database. & + Overrides the command line values (both defaults and config-type-specific values). In the input XYZ file, it must be prepended by energy_, force_, virial_ or hessian_", altkey="sigma_parameter_name") + + call param_register(params, 'force_mask_parameter_name', 'force_mask', force_mask_parameter_name, & + help_string="To exclude forces on specific atoms from the fit. In the XYZ, it must be a logical column.") + + call param_register(params, 'local_property_mask_parameter_name', 'local_property_mask', local_property_mask_parameter_name, & + help_string="To exclude local_properties on specific atoms from the fit. In the XYZ, it must be a logical column.") + + call param_register(params, 'parameter_name_prefix', '', parameter_name_prefix, & + help_string="Prefix that gets uniformly appended in front of {energy,local_property,force,virial,...}_parameter_name") + + call param_register(params, 'config_type_kernel_regularisation', '', config_type_sigma_string, has_value_target = this%has_config_type_sigma, & + help_string="What kernel regularisation values to choose for each type of data, when the configurations are grouped into config_types. Format: {configtype1:energy:force:virial:hessian:config_type2:energy:force:virial:hessian...}", altkey="config_type_sigma") + + call param_register(params, 'kernel_regularisation_is_per_atom', 'T', sigma_per_atom, & + help_string="Interpretation of the energy and virial sigmas specified in >>default_kernel_regularisation<< and >>config_type_kernel_regularisation<<. & + If >>T<<, they are interpreted as per-atom errors, and the variance will be scaled according to the number of atoms in the configuration. & + If >>F<< they are treated as absolute errors and no scaling is performed. & + NOTE: values specified on a per-configuration basis (see >>kernel_regularisation_parameter_name<<) are always absolute, not per-atom.", altkey="sigma_per_atom") + + call param_register(params, 'do_copy_atoms_file', 'T', do_copy_at_file, & + help_string="Copy the input XYZ file into the GAP XML file (should be set to False for NetCDF input).", altkey="do_copy_at_file") + + call param_register(params, 'sparse_separate_file', 'T', sparseX_separate_file, & + help_string="Save sparse point data in separate file in binary (use it for large datasets)") + + call param_register(params, 'sparse_use_actual_gpcov', 'F', sparse_use_actual_gpcov, & + help_string="Use actual GP covariance for sparsification methods") + + call param_register(params, 'gap_file', 'gap_new.xml', gp_file, & + help_string="Name of output XML file that will contain the fitted potential", altkey="gp_file") + + call param_register(params, 'verbosity', 'NORMAL', verbosity, & + help_string="Verbosity control. Options: NORMAL, VERBOSE, NERD, ANALYSIS.") ! changed name to ANALYSIS now that we are grown up + + call param_register(params, "rnd_seed", "-1", rnd_seed, & + help_string="Random seed.") + + call param_register(params, "openmp_chunk_size", "0", openmp_chunk_size, & + help_string="Chunk size in OpenMP scheduling; 0: each thread gets a single block of similar size (default)") + + call param_register(params, 'do_ip_timing', 'F', do_ip_timing, & + help_string="To enable or not timing of the interatomic potential.") + + call param_register(params, 'template_file', 'template.xyz', template_file, has_value_target=this%has_template_file, & + help_string="Template XYZ file for initialising object") + + call param_register(params, 'sparsify_only_no_fit', 'F', sparsify_only_no_fit, & + help_string="If true, sparsification is done, but no fitting. print the sparse index by adding print_sparse_index=file.dat to the descriptor string.") + + call param_register(params, 'dryrun', 'F', dryrun, & + help_string="If true, exits after memory estimate, before major allocations.") + + call param_register(params, 'condition_number_norm', ' ', condition_number_norm, & + help_string="Norm for condition number of matrix A; O: 1-norm, I: inf-norm, : skip calculation (default)") + + call param_register(params, 'linear_system_dump_file', '', linear_system_dump_file, has_value_target=this%has_linear_system_dump_file, & + help_string="Basename prefix of linear system dump files. Skipped if empty (default).") + + call param_register(params, 'mpi_blocksize_rows', '0', mpi_blocksize_rows, & + help_string="Blocksize of MPI distributed matrix rows. Affects efficiency and memory usage slightly. Max if 0 (default).") + + call param_register(params, 'mpi_blocksize_cols', '100', mpi_blocksize_cols, & + help_string="Blocksize of MPI distributed matrix cols. Affects efficiency and memory usage considerably. Max if 0. Default: 100") + + call param_register(params, 'mpi_print_all', 'F', mpi_print_all, & + help_string="If true, each MPI processes will print its output. Otherwise, only the first process does (default).") + + call param_register(params, 'export_covariance', 'F', do_export_covariance, & + help_string="If true, posterior covariance of the GAP model is saved.") + + if (.not. param_read_line(params, replace(string(this%config_string), quip_new_line, ' '))) then + call system_abort('Exit: Mandatory argument(s) missing...') + endif + + call print_title("Input parameters") + call param_print(params) + call print_title("") + call finalise(params) + + if (mpi_print_all) then + call mpi_all_inoutput(mainlog, .true.) + call activate(mainlog) + call mpi_all_inoutput(errorlog, .true.) + call activate(errorlog) + end if + + if (len_trim(parameter_name_prefix) > 0) then + energy_parameter_name = trim(parameter_name_prefix) // trim(energy_parameter_name) + local_property_parameter_name = trim(parameter_name_prefix) // trim(local_property_parameter_name) + force_parameter_name = trim(parameter_name_prefix) // trim(force_parameter_name) + virial_parameter_name = trim(parameter_name_prefix) // trim(virial_parameter_name) + hessian_parameter_name = trim(parameter_name_prefix) // trim(hessian_parameter_name) + stress_parameter_name = trim(parameter_name_prefix) // trim(stress_parameter_name) + config_type_parameter_name = trim(parameter_name_prefix) // trim(config_type_parameter_name) + sigma_parameter_name = trim(parameter_name_prefix) // trim(sigma_parameter_name) + force_mask_parameter_name = trim(parameter_name_prefix) // trim(force_mask_parameter_name) + local_property_mask_parameter_name = trim(parameter_name_prefix) // trim(local_property_mask_parameter_name) + local_property_parameter_name = trim(parameter_name_prefix) // trim(local_property_parameter_name) + endif + + if (sparsify_only_no_fit) then + force_parameter_name = '//IGNORE//' + virial_parameter_name = '//IGNORE//' + hessian_parameter_name = '//IGNORE//' + stress_parameter_name = '//IGNORE//' + call print_warning("sparsify_only_no_fit == T: force, virial, hessian, stress parameters are ignored.") + end if + + if( len_trim(this%gp_file) > 216 ) then ! The filename's length is limited to 255 char.s in some filesystem. + ! Without this check, the fit would run but produce a core file and only a temporary xml file. + ! The limit is set to 216 as the sparse file can be 39 characters longer. + call system_abort("gap_file's name "//this%gp_file//" is too long. Please start the fit again with a shorter name.") + endif + + if(do_ip_timing) call enable_timing() + + select case(verbosity) + case ("NORMAL") + call verbosity_push(PRINT_NORMAL) + case ("VERBOSE") + call verbosity_push(PRINT_VERBOSE) + case ("NERD") + call verbosity_push(PRINT_NERD) + case ("ANALYSIS") ! changed name now that we are grown up + call verbosity_push(PRINT_ANALYSIS) ! changed name now that we are grown up + case default + call system_abort("confused by verbosity " // trim(verbosity)) + end select + + select case(lower_case(e0_method)) + case ("isolated") + this%e0_method = E0_ISOLATED + case ("average") + this%e0_method = E0_AVERAGE + case default + call system_abort("confused by e0_method " // trim(e0_method)) + end select + + if (rnd_seed >= 0) call system_set_random_seeds(rnd_seed) + + call print_title('Gaussian Approximation Potentials - Database fitting') + call print('') + call print('Initial parsing of command line arguments finished.') + + call reallocate(this%gap_str, GAP_STRING_SIZE, zero=.true.) + call split_string(gap_str,':;','{}',this%gap_str,this%n_coordinate,matching=.true.) + + call print('Found '//this%n_coordinate//' GAPs.') + + endsubroutine gap_fit_parse_command_line + + subroutine set_baselines(this) + type(gap_fit), intent(inout) :: this + + integer :: i + + this%e0 = 0.0_dp + + if( count( (/this%has_e0, this%has_e0_offset/) ) > 1 ) then + call print_warning('Both e0 and e0_offset has been specified. That means your atomic energy is e0 + e0_offset') + endif + + if( this%has_e0 ) then + call parse_atomtype_value_str(this%e0_str,this%e0) + else + call e0_from_xyz(this) ! calculates the average atomic energy so it can be subtracted later. + endif + + if( this%has_e0_offset ) this%e0 = this%e0 + this%e0_offset + + if( .not. this%has_e0 ) then + do i = 1, size(this%e0) + if( all(i/=this%species_Z) ) this%e0(i) = 0.0_dp + enddo + call print('E0/atom = '//this%e0) + endif + + if( this%has_local_property0 ) then + call parse_atomtype_value_str(this%local_property0_str,this%local_property0) + this%e0 = 0.0_dp + else + this%local_property0 = 0.0_dp + endif + + endsubroutine set_baselines + + subroutine parse_atomtype_value_str(this,values,error) + + character(len=STRING_LENGTH), intent(in) :: this + real(dp), dimension(total_elements), intent(out) :: values + integer, intent(out), optional :: error + + integer :: n_string_array, i, z + character(len=STRING_LENGTH), dimension(2*total_elements) :: string_array + + INIT_ERROR(error) + + call split_string(this,':','{}',string_array(:),n_string_array,matching=.true.) + if(n_string_array == 1) then + values = string_to_real(trim(string_array(1))) + elseif(mod(n_string_array,2) == 0) then + values = 0.0_dp + do i = 1, n_string_array / 2 + z = atomic_number(trim( string_array((i-1)*2+1) )) + if( z==0 ) then + RAISE_ERROR("parse_atomtype_value_str: invalid atomic symbol "//trim(string_array((i-1)*2+1)),error) + endif + values(z) = string_to_real(trim( string_array(2*i) )) + enddo + else + RAISE_ERROR("parse_atomtype_value_str: number of fields is an odd number. It must be a list of pairs of values, such as {Ti:-150.4:O:-345.1}",error) + endif + + endsubroutine parse_atomtype_value_str + + subroutine gap_fit_parse_gap_str(this) + !% This subroutine parses the options given in the gap string, for each GAP. + type(gap_fit), intent(inout), target :: this + type(Dictionary) :: params + + integer :: i_coordinate + + real(dp) :: delta, f0, theta_uniform, zeta, unique_hash_tolerance, unique_descriptor_tolerance + integer :: n_sparseX, sparse_method, covariance_type + character(len=STRING_LENGTH) :: config_type_n_sparseX_string, theta_fac_string, theta_file, sparse_file, print_sparse_index, & + covariance_type_str, sparse_method_str + logical :: mark_sparse_atoms, add_species, has_sparse_file + + if (.not. allocated(this%gap_str)) then + call system_abort("gap_fit_parse_gap_str: gap_str is not allocated.") + end if + + allocate(this%delta(this%n_coordinate)) + allocate(this%f0(this%n_coordinate)) + allocate(this%n_sparseX(this%n_coordinate)) + allocate(this%config_type_n_sparseX_string(this%n_coordinate)) + allocate(this%theta_fac_string(this%n_coordinate)) + allocate(this%theta_uniform(this%n_coordinate)) + allocate(this%theta_file(this%n_coordinate)) + allocate(this%has_theta_fac(this%n_coordinate)) + allocate(this%has_theta_uniform(this%n_coordinate)) + allocate(this%has_theta_file(this%n_coordinate)) + allocate(this%sparse_file(this%n_coordinate)) + allocate(this%mark_sparse_atoms(this%n_coordinate)) + allocate(this%sparse_method(this%n_coordinate)) + allocate(this%add_species(this%n_coordinate)) + allocate(this%covariance_type(this%n_coordinate)) + allocate(this%zeta(this%n_coordinate)) + allocate(this%has_zeta(this%n_coordinate)) + allocate(this%print_sparse_index(this%n_coordinate)) + allocate(this%unique_hash_tolerance(this%n_coordinate)) + allocate(this%unique_descriptor_tolerance(this%n_coordinate)) + + do i_coordinate = 1, this%n_coordinate + call initialise(params) + + call param_register(params, 'energy_scale', "//MANDATORY//", delta, & + help_string="Set the typical scale of the function you are fitting (or the specific term if you use multiple descriptors). It is equivalent to the standard deviation of the Gaussian process in the probabilistic view, and typically this would be & + set to the standard deviation (i.e. root mean square) of the function & + that is approximated with the Gaussian process. ", altkey="delta") + + call param_register(params, 'f0', '0.0', f0, & + help_string="Set the mean of the Gaussian process. Defaults to 0.") + + call param_register(params, 'n_sparse', "0", n_sparseX, & + help_string="Number of sparse points to use in the sparsification of the Gaussian process") + + call param_register(params, 'config_type_n_sparse', '', config_type_n_sparseX_string, & + help_string="Number of sparse points in each config type. Format: {type1:50:type2:100}") + + call param_register(params, 'sparse_method', 'RANDOM', sparse_method_str, & + help_string="Sparsification method. RANDOM(default), PIVOT, CLUSTER, UNIFORM, KMEANS, COVARIANCE, NONE, FUZZY, FILE, & + INDEX_FILE, CUR_COVARIANCE, CUR_POINTS") + + call param_register(params, 'lengthscale_factor', '1.0', theta_fac_string, has_value_target = this%has_theta_fac(i_coordinate), & + help_string="Set the width of Gaussians for the Gaussian and PP kernel by multiplying the range of each descriptor by lengthscale_factor. & + Can be a single number or different for each dimension. For multiple theta_fac separate each value by whitespaces.", altkey="theta_fac") + + call param_register(params, 'lengthscale_uniform', '0.0', theta_uniform, has_value_target = this%has_theta_uniform(i_coordinate), & + help_string="Set the width of Gaussians for the Gaussian and PP kernel, same in each dimension.", altkey="theta_uniform") + + call param_register(params, 'lengthscale_file', '', theta_file, has_value_target = this%has_theta_file(i_coordinate), & + help_string="Set the width of Gaussians for the Gaussian kernel from a file. & + There should be as many real numbers as the number of dimensions, in a single line", altkey="theta_file") + + call param_register(params, 'sparse_file', '', sparse_file, has_value_target = has_sparse_file, & + help_string="Sparse points from a file. If sparse_method=FILE, descriptor values (real) listed in a text file, one & + & >>element<< per line. If sparse_method=INDEX_FILE, 1-based index of sparse points, one per line.") + + call param_register(params, 'mark_sparse_atoms', 'F', mark_sparse_atoms, & + help_string="Reprints the original xyz file after sparsification process. & + sparse propery added, true for atoms associated with a sparse point.") + + call param_register(params, 'add_species', 'T', add_species, & + help_string="Create species-specific descriptor, using the descriptor string as a template.") + + call param_register(params, 'covariance_type', "//MANDATORY//", covariance_type_str, & + help_string="Type of covariance function to use. Available: Gaussian, DOT_PRODUCT, BOND_REAL_SPACE, PP (piecewise polynomial)") + + !call param_register(params, 'theta', '1.0', main_gap_fit%theta(i_coordinate), & + !help_string="Width of Gaussians for use with bond real space covariance.") + + call param_register(params, 'soap_exponent', '1.0', zeta, has_value_target = this%has_zeta(i_coordinate), & + help_string="Exponent of soap type dot product covariance kernel", altkey="zeta") + + call param_register(params, 'print_sparse_index', '', print_sparse_index, & + help_string="If given, after determinining the sparse points, their 1-based indices are appended to this file") + + call param_register(params, 'unique_hash_tolerance', '1.0e-10', unique_hash_tolerance, & + help_string="Hash tolerance when filtering out duplicate data points") + + call param_register(params, 'unique_descriptor_tolerance', '1.0e-10', unique_descriptor_tolerance, & + help_string="Descriptor tolerance when filtering out duplicate data points") + + if (.not. param_read_line(params, this%gap_str(i_coordinate), ignore_unknown=.true., task='main program gap_str('//i_coordinate//')')) then + call system_abort("main program failed to parse gap string ("//i_coordinate//")='"//trim(this%gap_str(i_coordinate))//"'") + endif + call finalise(params) + + this%delta(i_coordinate) = delta + this%f0(i_coordinate) = f0 + this%n_sparseX(i_coordinate) = n_sparseX + this%config_type_n_sparseX_string(i_coordinate) = config_type_n_sparseX_string + this%theta_fac_string(i_coordinate) = theta_fac_string + this%theta_uniform(i_coordinate) = theta_uniform + this%theta_file(i_coordinate) = theta_file + this%sparse_file(i_coordinate) = sparse_file + this%mark_sparse_atoms(i_coordinate) = mark_sparse_atoms + this%add_species(i_coordinate) = add_species + this%zeta(i_coordinate) = zeta + this%print_sparse_index(i_coordinate) = print_sparse_index + this%unique_hash_tolerance(i_coordinate) = unique_hash_tolerance + this%unique_descriptor_tolerance(i_coordinate) = unique_descriptor_tolerance + + select case(lower_case(trim(sparse_method_str))) + case('random') + this%sparse_method(i_coordinate) = GP_SPARSE_RANDOM + case('pivot') + this%sparse_method(i_coordinate) = GP_SPARSE_PIVOT + case('cluster') + this%sparse_method(i_coordinate) = GP_SPARSE_CLUSTER + case('uniform') + this%sparse_method(i_coordinate) = GP_SPARSE_UNIFORM + case('kmeans') + this%sparse_method(i_coordinate) = GP_SPARSE_KMEANS + case('covariance') + this%sparse_method(i_coordinate) = GP_SPARSE_COVARIANCE + case('uniq') + call system_abort("sparse method UNIQ is no longer in use. Use NONE instead." ) + case('fuzzy') + this%sparse_method(i_coordinate) = GP_SPARSE_FUZZY + case('file') + this%sparse_method(i_coordinate) = GP_SPARSE_FILE + case('index_file') + this%sparse_method(i_coordinate) = GP_SPARSE_INDEX_FILE + case('cur_covariance') + this%sparse_method(i_coordinate) = GP_SPARSE_CUR_COVARIANCE + case('cur_points') + this%sparse_method(i_coordinate) = GP_SPARSE_CUR_POINTS + case('none') + this%sparse_method(i_coordinate) = GP_SPARSE_NONE + case default + call system_abort("unknown sparse method "//trim(sparse_method_str)) + endselect + + if( has_sparse_file ) then + if( this%sparse_method(i_coordinate) /= GP_SPARSE_FILE .and. & + this%sparse_method(i_coordinate) /= GP_SPARSE_INDEX_FILE ) then + call system_abort('"sparse_file" specified in command line, but sparse method not "file" or "index_file"') + endif + endif + + select case(lower_case(trim(covariance_type_str))) + case('none') + call system_abort("covariance type cannot be"//trim(covariance_type_str)) + this%covariance_type(i_coordinate) = COVARIANCE_NONE + case('gaussian') + this%covariance_type(i_coordinate) = COVARIANCE_ARD_SE + case('ard_se') ! backwards compatibility + this%covariance_type(i_coordinate) = COVARIANCE_ARD_SE + case('dot_product') + this%covariance_type(i_coordinate) = COVARIANCE_DOT_PRODUCT + case('bond_real_space') + this%covariance_type(i_coordinate) = COVARIANCE_BOND_REAL_SPACE + case('pp') + this%covariance_type(i_coordinate) = COVARIANCE_PP + case default + call system_abort("unknown covariance type"//trim(covariance_type_str)//". Available: Gaussian, DOT_PRODUCT, BOND_REAL_SPACE, PP (piecewise polynomial)") + endselect + + enddo + + call print('Descriptors have been parsed') + + endsubroutine gap_fit_parse_gap_str + + subroutine read_fit_xyz(this) + + type(gap_fit), intent(inout) :: this + + type(cinoutput) :: xyzfile + integer :: n_con + logical :: file_exists + + if( allocated(this%at) ) then + do n_con = 1, this%n_frame + call finalise(this%at(n_con)) + enddo + deallocate(this%at) + this%n_frame = 0 + endif + + inquire(file=this%at_file, exist=file_exists) + if( .not. file_exists ) then + call system_abort("read_fit_xyz: at_file "//this%at_file//" could not be found") + endif + + call initialise(xyzfile,this%at_file,mpi=this%mpi_obj) + this%n_frame = xyzfile%n_frame + + allocate(this%at(this%n_frame)) + + do n_con = 1, this%n_frame + call read(xyzfile,this%at(n_con),frame=n_con-1) + call set_cutoff(this%at(n_con), this%max_cutoff) + call calc_connect(this%at(n_con)) + enddo + + call finalise(xyzfile) + + if(this%n_frame <= 0) then + call system_abort("read_fit_xyz: "//this%n_frame//" frames read from "//this%at_file//".") + endif + + endsubroutine read_fit_xyz + + subroutine read_descriptors(this) + + type(gap_fit), intent(inout) :: this + + integer :: i + + this%max_cutoff = 0.0_dp + if(allocated(this%my_descriptor)) then + do i = 1, size(this%my_descriptor) + call finalise(this%my_descriptor(i)) + enddo + deallocate(this%my_descriptor) + endif + + allocate(this%my_descriptor(this%n_coordinate)) + do i = 1, this%n_coordinate + call initialise(this%my_descriptor(i),this%gap_str(i)) + if( this%max_cutoff < cutoff(this%my_descriptor(i)) ) this%max_cutoff = cutoff(this%my_descriptor(i)) + enddo + + endsubroutine read_descriptors + + subroutine fit_n_from_xyz(this) + + type(gap_fit), intent(inout) :: this + + logical :: do_collect_tasks, do_filter_tasks + + type(Atoms) :: at + + integer :: n_con + logical :: has_ener, has_force, has_virial, has_stress_3_3, has_stress_voigt, has_hessian, has_local_property, has_force_mask, & + exclude_atom, has_local_property_mask + real(dp) :: ener, virial(3,3), stress_3_3(3,3) + real(dp) :: stress_voigt(6) + real(dp), pointer, dimension(:,:) :: f, hessian_eigenvector_j + real(dp), pointer, dimension(:) :: local_property + logical, pointer, dimension(:) :: force_mask, local_property_mask + integer :: i, j, k + integer :: n_descriptors, n_cross, n_hessian + integer :: n_current, n_last + + do_collect_tasks = (this%task_manager%active .and. .not. this%task_manager%distributed) + do_filter_tasks = (this%task_manager%active .and. this%task_manager%distributed) + + if (allocated(this%n_cross)) deallocate(this%n_cross) + if (allocated(this%n_descriptors)) deallocate(this%n_descriptors) + allocate(this%n_cross(this%n_coordinate)) + allocate(this%n_descriptors(this%n_coordinate)) + + this%n_cross = 0 + this%n_descriptors = 0 + this%n_ener = 0 + this%n_force = 0 + this%n_virial = 0 + this%n_hessian = 0 + this%n_local_property = 0 + n_last = 0 + + do n_con = 1, this%n_frame + if (do_filter_tasks) then + if (this%task_manager%tasks(n_con)%worker_id /= this%task_manager%my_worker_id) cycle + end if + + has_ener = get_value(this%at(n_con)%params,this%energy_parameter_name,ener) + has_force = assign_pointer(this%at(n_con),this%force_parameter_name, f) + has_virial = get_value(this%at(n_con)%params,this%virial_parameter_name,virial) + has_stress_voigt = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_voigt) + has_stress_3_3 = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_3_3) + has_hessian = get_value(this%at(n_con)%params,"n_"//this%hessian_parameter_name,n_hessian) + has_local_property = assign_pointer(this%at(n_con),this%local_property_parameter_name, local_property) + has_force_mask = assign_pointer(this%at(n_con),trim(this%force_mask_parameter_name),force_mask) + has_local_property_mask = assign_pointer(this%at(n_con),trim(this%local_property_mask_parameter_name),local_property_mask) + + if( has_ener ) then + this%n_ener = this%n_ener + 1 + endif + + if( has_force ) then + do i = 1, this%at(n_con)%N + exclude_atom = .false. + if(has_force_mask) exclude_atom = force_mask(i) + + if( .not. exclude_atom ) this%n_force = this%n_force + 3 + enddo + endif + + if( has_stress_voigt .or. has_stress_3_3 ) then + if( has_stress_voigt .and. has_stress_3_3 ) then + call system_abort("fit_n_from_xyz: conflict in stress between 6-vector and 9-vector (really 3x3 matrix)") + endif + ! if has_stress is true, virial is available whether or not virial + ! field has been detected + has_virial = .true. + endif + + if( has_virial ) then + this%n_virial = this%n_virial + 6 + endif + + if( has_hessian ) then + this%n_hessian = this%n_hessian + n_hessian + at = this%at(n_con) + endif + + if( has_local_property ) then + if( has_local_property_mask ) then + this%n_local_property = this%n_local_property + count(local_property_mask) + else + this%n_local_property = this%n_local_property + this%at(n_con)%N + endif + endif + +! if( has_local_property .and. ( has_ener .or. has_force .or. has_virial .or. has_hessian ) ) then +! call system_abort("fit_n_from_xyz: local_property and (energy or force or virial or hessian) present in configuration, currently not allowed.") +! endif + + do i = 1, this%n_coordinate + call descriptor_sizes(this%my_descriptor(i),this%at(n_con),n_descriptors,n_cross) + + if( has_force ) then + this%n_cross(i) = this%n_cross(i) + n_cross*3 + endif + + if( has_virial ) then + this%n_cross(i) = this%n_cross(i) + n_cross*6 + endif + + this%n_descriptors(i) = this%n_descriptors(i) + n_descriptors + + if( has_hessian ) then + do j = 1, n_hessian + if( .not. assign_pointer(this%at(n_con),trim(this%hessian_parameter_name)//j, hessian_eigenvector_j) ) & + call system_abort("fit_n_from_xyz: could not find the "//j//"th of "//n_hessian//" hessian eigenvector") + + hessian_eigenvector_j = hessian_eigenvector_j / sqrt( sum(hessian_eigenvector_j**2) ) + + do k = -1, 1, 2 + at%pos = this%at(n_con)%pos + k * this%hessian_delta * hessian_eigenvector_j + call set_cutoff(at,this%max_cutoff) + call calc_connect(at) + call descriptor_sizes(this%my_descriptor(i),at,n_descriptors,n_cross) + + this%n_descriptors(i) = this%n_descriptors(i) + n_descriptors + this%n_cross(i) = this%n_cross(i) + n_descriptors + enddo + + enddo + endif + enddo + + if (do_collect_tasks) then + n_current = this%n_ener + this%n_local_property + this%n_force + this%n_virial + this%n_hessian + call task_manager_add_task(this%task_manager, n_current - n_last) + n_last = n_current + end if + + call finalise(at) + enddo + + if (.not. do_filter_tasks) then + call print_title("Report on number of descriptors found") + do i = 1, this%n_coordinate + call print("---------------------------------------------------------------------") + call print("Descriptor "//i//": "//this%gap_str(i)) + call print("Number of descriptors: "//this%n_descriptors(i)) + call print("Number of partial derivatives of descriptors: "//this%n_cross(i)) + enddo + call print_title("") + end if + + end subroutine fit_n_from_xyz + + subroutine fit_data_from_xyz(this,error) + + type(gap_fit), intent(inout) :: this + integer, optional, intent(out) :: error + + type(inoutput) :: theta_inout + type(descriptor_data) :: my_descriptor_data + + type(Atoms) :: at + integer :: d, n_con + logical :: has_ener, has_force, has_virial, has_stress_voigt, has_stress_3_3, has_hessian, has_local_property, & + has_config_type, has_energy_sigma, has_force_sigma, has_virial_sigma, has_virial_component_sigma, has_hessian_sigma, & + has_force_atom_sigma, has_force_component_sigma, has_local_property_sigma, has_force_mask, has_local_property_mask, & + exclude_atom + real(dp) :: ener, ener_core, my_cutoff, energy_sigma, force_sigma, virial_sigma, hessian_sigma, local_property_sigma, & + grad_covariance_cutoff, use_force_sigma + real(dp), dimension(3) :: pos + real(dp), dimension(3,3) :: virial, virial_core, stress_3_3, virial_component_sigma + real(dp), dimension(6) :: stress_voigt + real(dp), dimension(:), allocatable :: theta, theta_fac, hessian, hessian_core, grad_data + real(dp), dimension(:), pointer :: force_atom_sigma + real(dp), dimension(:,:), pointer :: f, hessian_eigenvector_i, f_hessian, force_component_sigma + real(dp), dimension(:), pointer :: local_property + logical, dimension(:), pointer :: force_mask, local_property_mask + real(dp), dimension(:,:), allocatable :: f_core + integer, dimension(:,:), allocatable :: force_loc, permutations + integer :: ie, i, j, n, k, l, i_coordinate, n_hessian, n_energy_sigma, n_force_sigma, n_force_atom_sigma, & + n_force_component_sigma, n_hessian_sigma, n_virial_sigma, n_local_property_sigma, n_descriptors, n_virial_component_sigma + integer, dimension(:), allocatable :: xloc, hessian_loc, local_property_loc + integer, dimension(3,3) :: virial_loc + + integer :: i_config_type, n_config_type, n_theta_fac + character(len=STRING_LENGTH) :: config_type + character(len=THETA_LENGTH) :: theta_string + character(len=STRING_LENGTH), dimension(:), allocatable :: theta_string_array + + INIT_ERROR(error) + + if (this%task_manager%active) then + if (.not. this%task_manager%distributed) then + call system_abort("fit_data_from_xyz: Tasks are not distributed.") + end if + + do n_con = 1, this%n_frame + if (this%task_manager%tasks(n_con)%worker_id /= this%task_manager%my_worker_id) then + call finalise(this%at(n_con)) + end if + end do + end if + + this%my_gp%do_subY_subY = merge(gap_fit_is_root(this), .true., this%task_manager%active) + + my_cutoff = 0.0_dp + call gp_setParameters(this%my_gp,this%n_coordinate,this%n_ener+this%n_local_property,this%n_force+this%n_virial+this%n_hessian,this%sparse_jitter) + + do i_coordinate = 1, this%n_coordinate + d = descriptor_dimensions(this%my_descriptor(i_coordinate)) + + call gp_setParameters(this%my_gp,i_coordinate, d, this%n_descriptors(i_coordinate), this%n_cross(i_coordinate), this%delta(i_coordinate), this%f0(i_coordinate), & + covariance_type=this%covariance_type(i_coordinate) ) + call gp_addDescriptor(this%my_gp,i_coordinate,trim(this%gap_str(i_coordinate))) + + allocate(permutations(d,descriptor_n_permutations(this%my_descriptor(i_coordinate)))) + call descriptor_permutations(this%my_descriptor(i_coordinate),permutations) + call gp_setPermutations(this%my_gp,i_coordinate,permutations) + deallocate(permutations) + + my_cutoff = max(my_cutoff,cutoff(this%my_descriptor(i_coordinate))) + enddo + + call print_title("Report on number of target properties found in training XYZ:") + call print("Number of target energies (property name: "//trim(this%energy_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_ener)) + call print("Number of target local_properties (property name: "//trim(this%local_property_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_local_property)) + call print("Number of target forces (property name: "//trim(this%force_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_force)) + call print("Number of target virials (property name: "//trim(this%virial_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_virial)) + call print("Number of target Hessian eigenvalues (property name: "//trim(this%hessian_parameter_name)//") found: "//sum(this%task_manager%MPI_obj, this%n_hessian)) + call print_title("End of report") + + if( this%do_core ) call Initialise(this%core_pot, args_str=this%core_ip_args, param_str=string(this%quip_string)) + + n_energy_sigma = 0 + n_force_sigma = 0 + n_force_atom_sigma = 0 + n_force_component_sigma = 0 + n_virial_component_sigma=0 + n_hessian_sigma = 0 + n_virial_sigma = 0 + n_local_property_sigma = 0 + + do n_con = 1, this%n_frame + if (.not. is_initialised(this%at(n_con))) cycle + + has_ener = get_value(this%at(n_con)%params,this%energy_parameter_name,ener) + has_force = assign_pointer(this%at(n_con),this%force_parameter_name, f) + has_virial = get_value(this%at(n_con)%params,this%virial_parameter_name,virial) + has_virial_component_sigma = get_value(this%at(n_con)%params,'virial_component_'//trim(this%sigma_parameter_name),virial_component_sigma) + has_stress_voigt = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_voigt) + has_stress_3_3 = get_value(this%at(n_con)%params,this%stress_parameter_name,stress_3_3) + has_hessian = get_value(this%at(n_con)%params,"n_"//this%hessian_parameter_name,n_hessian) + has_config_type = get_value(this%at(n_con)%params,this%config_type_parameter_name,config_type) + has_local_property = assign_pointer(this%at(n_con),this%local_property_parameter_name,local_property) + + has_energy_sigma = get_value(this%at(n_con)%params,'energy_'//trim(this%sigma_parameter_name),energy_sigma) + has_force_sigma = get_value(this%at(n_con)%params,'force_'//trim(this%sigma_parameter_name),force_sigma) + has_virial_sigma = get_value(this%at(n_con)%params,'virial_'//trim(this%sigma_parameter_name),virial_sigma) + has_hessian_sigma = get_value(this%at(n_con)%params,'hessian_'//trim(this%sigma_parameter_name),hessian_sigma) + has_force_atom_sigma = assign_pointer(this%at(n_con),'force_atom_'//trim(this%sigma_parameter_name),force_atom_sigma) + has_force_component_sigma = assign_pointer(this%at(n_con),'force_component_'//trim(this%sigma_parameter_name),force_component_sigma) + has_local_property_sigma = get_value(this%at(n_con)%params,'local_property_'//trim(this%sigma_parameter_name),local_property_sigma) + has_force_mask = assign_pointer(this%at(n_con),trim(this%force_mask_parameter_name),force_mask) + has_local_property_mask = assign_pointer(this%at(n_con),trim(this%local_property_mask_parameter_name),local_property_mask) + + if ((.not. has_virial) .and. (has_stress_3_3 .or. has_stress_voigt)) then + if (has_stress_voigt) then + virial(1,1) = stress_voigt(1) + virial(2,2) = stress_voigt(2) + virial(3,3) = stress_voigt(3) + virial(2,3) = stress_voigt(4) + virial(3,1) = stress_voigt(5) + virial(1,2) = stress_voigt(6) + virial(3,2) = virial(2,3) + virial(1,3) = virial(3,1) + virial(2,1) = virial(1,2) + else if (has_stress_3_3) then + virial = stress_3_3 + else + call system_abort("Frame "//n_con//" has no virial and stress that is neither a 9-vector (3x3)"// & + " nor 6-vector (Voigt)") + endif + virial = -virial * cell_volume(this%at(n_con)) + has_virial = .true. + endif + + if( has_force_atom_sigma .and. has_force_component_sigma ) then + call print_warning("Frame "//n_con//" contains both force_atom_"//trim(this%sigma_parameter_name)// & + " and force_component_"//trim(this%sigma_parameter_name)//" parameters. Per-component values will be used.") + endif + + if( has_hessian ) then + allocate(hessian(n_hessian)) + do i = 1, n_hessian + if( .not. get_value(this%at(n_con)%params,trim(this%hessian_parameter_name)//i,hessian(i)) ) & + call system_abort("fit_data_from_xyz: did not find "//i//"th of "//n_hessian//" hessian element" ) + enddo + endif + + if( has_config_type ) then + config_type = trim(config_type) + else + config_type = "default" + endif + + if( .not. allocated(this%config_type) ) call system_abort('config_type not allocated') + n_config_type = 0 + do i_config_type = 1, size(this%config_type) + if( trim(this%config_type(i_config_type)) == trim(config_type) ) n_config_type = i_config_type + enddo + + if( n_config_type == 0 ) then ! get the number of the "default" type as default + do i_config_type = 1, size(this%config_type) + if( trim(this%config_type(i_config_type)) == "default" ) n_config_type = i_config_type + enddo + endif + + if( this%do_core ) then + allocate( f_core(3,this%at(n_con)%N) ) + ener_core = 0.0_dp + f_core = 0.0_dp + virial_core = 0.0_dp + + if( this%at(n_con)%cutoff < max(cutoff(this%core_pot),my_cutoff) ) then + call set_cutoff(this%at(n_con), max(cutoff(this%core_pot),my_cutoff)) + call calc_connect(this%at(n_con)) + endif + + if(has_virial .and. has_force) then + call calc(this%core_pot,this%at(n_con),energy=ener_core,force=f_core,virial=virial_core) + elseif(has_force) then + call calc(this%core_pot,this%at(n_con),energy=ener_core,force=f_core) + elseif(has_virial) then + call calc(this%core_pot,this%at(n_con),energy=ener_core,virial=virial_core) + else + call calc(this%core_pot,this%at(n_con),energy=ener_core) + end if + + if(has_hessian) then + allocate( hessian_core(n_hessian), f_hessian(3,this%at(n_con)%N) ) + hessian_core = 0.0_dp + at = this%at(n_con) + call set_cutoff(at, cutoff(this%core_pot)) + do i = 1, n_hessian + if( .not. assign_pointer(this%at(n_con),trim(this%hessian_parameter_name)//i, hessian_eigenvector_i) ) & + call system_abort("fit_data_from_xyz: could not find "//i//"th of "//n_hessian//" hessian eigenvector.") + + hessian_eigenvector_i = hessian_eigenvector_i / sqrt( sum(hessian_eigenvector_i**2) ) + + do j = -1, 1, 2 + at%pos = this%at(n_con)%pos + j * this%hessian_delta * hessian_eigenvector_i + call calc_connect(at) + call calc(this%core_pot,at,force = f_hessian) + hessian_core(i) = hessian_core(i) + j * sum(f_hessian*hessian_eigenvector_i) / 2.0_dp / this%hessian_delta + enddo + enddo + call finalise(at) + + hessian = hessian - hessian_core + deallocate(hessian_core, f_hessian) + endif + + if(has_ener) ener = ener - ener_core + if(has_force) f = f - f_core + if(has_virial) virial = virial - virial_core + + deallocate(f_core) + endif + + if(has_ener) then + do i = 1, this%at(n_con)%N + ener = ener - this%e0(this%at(n_con)%Z(i)) + enddo + endif + + if(has_local_property) then + do i = 1, this%at(n_con)%N + local_property(i) = local_property(i) - this%local_property0(this%at(n_con)%Z(i)) + enddo + endif + + if( has_ener .and. has_local_property ) then + RAISE_ERROR("fit_data_from_xyz: energy and local_property both present in configuration, currently not allowed.",error) + endif + + if( this%at(n_con)%cutoff < my_cutoff ) then + call set_cutoff(this%at(n_con),my_cutoff) + call calc_connect(this%at(n_con)) + endif + + if( .not. has_energy_sigma ) then + if( this%sigma_per_atom ) then + energy_sigma = this%sigma(1,n_config_type)*sqrt(1.0_dp * this%at(n_con)%N) + else + energy_sigma = this%sigma(1,n_config_type) + endif + else + n_energy_sigma = n_energy_sigma + 1 + endif + + if( .not. has_force_sigma ) then + force_sigma = this%sigma(2,n_config_type) + else + n_force_sigma = n_force_sigma + 1 + endif + + if( .not. has_virial_sigma ) then + if( this%sigma_per_atom ) then + virial_sigma = this%sigma(3,n_config_type)*sqrt(1.0_dp * this%at(n_con)%N) + else + virial_sigma = this%sigma(3,n_config_type) + endif + else + n_virial_sigma = n_virial_sigma + 1 + endif + if (has_virial_component_sigma) then + n_virial_component_sigma = n_virial_component_sigma + 9 + else + virial_component_sigma = virial_sigma + endif + + if( .not. has_hessian_sigma ) then + hessian_sigma = this%sigma(4,n_config_type) + else + n_hessian_sigma = n_hessian_sigma + 1 + endif + + if( .not. has_local_property_sigma ) then + local_property_sigma = this%default_local_property_sigma + else + n_local_property_sigma = n_local_property_sigma + 1 + endif + + if( has_ener ) then + if( energy_sigma .feq. 0.0_dp ) then + RAISE_ERROR("fit_data_from_xyz: too small energy_sigma ("//energy_sigma//"), should be greater than zero",error) + endif + ie = gp_addFunctionValue(this%my_gp,ener, energy_sigma) + elseif( has_local_property ) then + if( local_property_sigma .feq. 0.0_dp ) then + RAISE_ERROR("fit_data_from_xyz: too small local_property_sigma ("//local_property_sigma//"), should be greater than zero",error) + endif + allocate(local_property_loc(this%at(n_con)%N)) + do i = 1, this%at(n_con)%N + if(has_local_property_mask) then + if( local_property_mask(i) ) then + local_property_loc(i) = gp_addFunctionValue(this%my_gp,local_property(i),local_property_sigma) + else + local_property_loc(i) = EXCLUDE_LOC + endif + else + local_property_loc(i) = gp_addFunctionValue(this%my_gp,local_property(i),local_property_sigma) + endif + enddo + endif + + if(has_force) then + allocate(force_loc(3,this%at(n_con)%N)) + do i = 1, this%at(n_con)%N + if (has_force_component_sigma) then + n_force_component_sigma = n_force_component_sigma + 3 + use_force_sigma = huge(1.0_dp) ! Updated later, below + elseif (has_force_atom_sigma) then + use_force_sigma = force_atom_sigma(i) + n_force_atom_sigma = n_force_atom_sigma + 1 + else + use_force_sigma = force_sigma + endif + + if( use_force_sigma .feq. 0.0_dp ) then + RAISE_ERROR("fit_data_from_xyz: too small force_sigma ("//use_force_sigma//"), should be greater than zero",error) + endif + + exclude_atom = .false. + if(has_force_mask) exclude_atom = force_mask(i) + + if( exclude_atom ) then + force_loc(:,i) = EXCLUDE_LOC + else + do k = 1, 3 + if( has_force_component_sigma ) use_force_sigma = force_component_sigma(k,i) + force_loc(k,i) = gp_addFunctionDerivative(this%my_gp,-f(k,i),use_force_sigma) + enddo + endif + enddo + endif + if(has_virial) then + ! check if virial is symmetric + if( sum((virial - transpose(virial))**2) .fne. 0.0_dp ) & + call print_warning('virial not symmetric, now symmetrised') + + ! Now symmetrise matrix + virial = ( virial + transpose(virial) ) / 2.0_dp + virial_component_sigma = ( virial_component_sigma + transpose(virial_component_sigma) ) / 2.0_dp + if( virial_sigma .feq. 0.0_dp ) then + RAISE_ERROR("fit_data_from_xyz: too small virial_sigma ("//virial_sigma//"), should be greater than zero",error) + endif + + do k = 1, 3 + do l = k, 3 + if( virial_component_sigma(l,k) .feq. 0.0_dp ) then + RAISE_ERROR("fit_data_from_xyz: too small virial_sigma ("//virial_component_sigma(l,k)//"), should be greater than zero",error) + endif + virial_loc(l,k) = gp_addFunctionDerivative(this%my_gp,-virial(l,k),virial_component_sigma(l,k)) + enddo + enddo + endif + + if(has_hessian) then + if( hessian_sigma .feq. 0.0_dp ) then + RAISE_ERROR("fit_data_from_xyz: too small hessian_sigma ("//hessian_sigma//"), should be greater than zero",error) + endif + + allocate(hessian_loc(n_hessian)) + do i = 1, n_hessian + hessian_loc(i) = gp_addFunctionDerivative(this%my_gp,hessian(i),hessian_sigma) + enddo + endif + + n_descriptors = 0 + do i_coordinate = 1, this%n_coordinate + + call calc(this%my_descriptor(i_coordinate),this%at(n_con),my_descriptor_data, & + do_descriptor=.true.,do_grad_descriptor=has_force .or. has_virial) + + allocate(xloc(size(my_descriptor_data%x))) + n_descriptors = n_descriptors + size(my_descriptor_data%x) + + if( has_ener ) then + do i = 1, size(my_descriptor_data%x) + if( .not. my_descriptor_data%x(i)%has_data) cycle + xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & + cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, current_y=ie,config_type=n_config_type) + enddo + elseif( has_local_property ) then + do i = 1, size(my_descriptor_data%x) + if( .not. my_descriptor_data%x(i)%has_data) cycle + if( local_property_loc(my_descriptor_data%x(i)%ci(1)) == EXCLUDE_LOC ) then + xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & + cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, config_type=n_config_type) + else + xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & + cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, current_y=local_property_loc(my_descriptor_data%x(i)%ci(1)),config_type=n_config_type) + endif + enddo + else + do i = 1, size(my_descriptor_data%x) + if( .not. my_descriptor_data%x(i)%has_data) cycle + xloc(i) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(i)%data(:),i_coordinate, & + cutoff_in=my_descriptor_data%x(i)%covariance_cutoff, config_type=n_config_type) + enddo + endif + + + if(has_force) then + do i = 1, size(my_descriptor_data%x) + do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) + if( .not. my_descriptor_data%x(i)%has_grad_data(n)) cycle + j = my_descriptor_data%x(i)%ii(n) + + do k = 1, 3 + if( force_loc(k,j) > EXCLUDE_LOC ) then + call gp_addCoordinateDerivatives(this%my_gp,my_descriptor_data%x(i)%grad_data(:,k,n),i_coordinate, & + force_loc(k,j), xloc(i), dcutoff_in=my_descriptor_data%x(i)%grad_covariance_cutoff(k,n) ) + endif + enddo + enddo + enddo + + endif + + if(has_virial) then + do k = 1, 3 + do l = k, 3 + + do i = 1, size(my_descriptor_data%x) + do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) + if( .not. my_descriptor_data%x(i)%has_grad_data(n)) cycle + j = my_descriptor_data%x(i)%ii(n) + pos = my_descriptor_data%x(i)%pos(:,n) + call gp_addCoordinateDerivatives(this%my_gp,my_descriptor_data%x(i)%grad_data(:,k,n)*pos(l), i_coordinate, & + virial_loc(l,k), xloc(i), dcutoff_in=my_descriptor_data%x(i)%grad_covariance_cutoff(k,n)*pos(l)) + enddo + enddo + + enddo + enddo + endif + + if(allocated(xloc)) deallocate(xloc) + enddo + + if(allocated(force_loc)) deallocate(force_loc) + if(allocated(local_property_loc)) deallocate(local_property_loc) + + if( has_hessian ) then + at = this%at(n_con) + call set_cutoff( at, my_cutoff ) + do i_coordinate = 1, this%n_coordinate + allocate( grad_data(descriptor_dimensions(this%my_descriptor(i_coordinate))) ) + + do i = 1, n_hessian + if( .not. assign_pointer(this%at(n_con),trim(this%hessian_parameter_name)//i, hessian_eigenvector_i) ) & + call system_abort("fit_data_from_xyz: could not find "//i//"th of "//n_hessian//" hessian eigenvector.") + + do j = -1, 1, 2 + at%pos = this%at(n_con)%pos + j * this%hessian_delta * hessian_eigenvector_i + call calc_connect(at) + + call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, & + do_descriptor=.true.,do_grad_descriptor=.true.) + !hessian_core(i) = hessian_core(i) + j * sum(f_hessian*hessian_eigenvector_i) / 2.0_dp / this%hessian_delta + + allocate(xloc(size(my_descriptor_data%x))) + + do k = 1, size(my_descriptor_data%x) + if( .not. my_descriptor_data%x(k)%has_data) cycle + xloc(k) = gp_addCoordinates(this%my_gp,my_descriptor_data%x(k)%data(:),i_coordinate, & + cutoff_in=my_descriptor_data%x(k)%covariance_cutoff,config_type=EXCLUDE_CONFIG_TYPE) + !cutoff_in=my_descriptor_data%x(k)%covariance_cutoff,config_type=n_config_type) + + + grad_data = 0.0_dp + grad_covariance_cutoff = 0.0_dp + do n = lbound(my_descriptor_data%x(k)%ii,1), ubound(my_descriptor_data%x(k)%ii,1) + if( .not. my_descriptor_data%x(k)%has_grad_data(n)) cycle + l = my_descriptor_data%x(k)%ii(n) + grad_data = grad_data + j * matmul(my_descriptor_data%x(k)%grad_data(:,:,n), hessian_eigenvector_i(:,l)) / 2.0_dp / this%hessian_delta + grad_covariance_cutoff = grad_covariance_cutoff + & + dot_product(my_descriptor_data%x(k)%grad_covariance_cutoff(:,n), hessian_eigenvector_i(:,l)) / 2.0_dp / this%hessian_delta + enddo + call gp_addCoordinateDerivatives(this%my_gp, grad_data, i_coordinate, & + hessian_loc(i), xloc(k), dcutoff_in=grad_covariance_cutoff) + + enddo !k + + deallocate(xloc) + enddo !j = -1, 1, 2 + enddo ! i = 1, n_hessian + if(allocated(grad_data)) deallocate(grad_data) + enddo ! i_coordinate = 1, n_coordinate + endif !has_hessian + + if(allocated(hessian_loc)) deallocate(hessian_loc) + if(allocated(hessian)) deallocate(hessian) + call finalise(my_descriptor_data) + enddo !n_frame + + call print_title("Report on per-configuration/per-atom sigma (error parameter) settings") + call print("Number of per-configuration setting of energy_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_energy_sigma)) + call print("Number of per-configuration setting of force_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_force_sigma)) + call print("Number of per-configuration setting of virial_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_virial_sigma)) + call print("Number of per-configuration setting of hessian_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_hessian_sigma)) + call print("Number of per-configuration setting of local_propery_"//trim(this%sigma_parameter_name)//" found:"//sum(this%task_manager%MPI_obj, n_local_property_sigma)) + call print("Number of per-atom setting of force_atom_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_force_atom_sigma)) + call print("Number of per-component setting of force_component_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_force_component_sigma)) + call print("Number of per-component setting of virial_component_"//trim(this%sigma_parameter_name)//" found: "//sum(this%task_manager%MPI_obj, n_virial_component_sigma)) + call print_title("End of report") + + do i_coordinate = 1, this%n_coordinate + if( count( (/this%has_theta_file(i_coordinate), this%has_theta_uniform(i_coordinate), & + this%has_theta_fac(i_coordinate), this%has_zeta(i_coordinate) /) ) /= 1 ) then + call system_abort("fit_data_from_xyz: only one of theta_file, theta_uniform, theta_fac or zeta may be & + specified for each GAP.") + endif + if( this%covariance_type(i_coordinate) == COVARIANCE_DOT_PRODUCT ) then + if( .not. this%has_zeta(i_coordinate) ) call system_abort("fit_data_from_xyz: covariance type is DOT_PRODUCT but no zeta was specified.") + elseif( this%covariance_type(i_coordinate) == COVARIANCE_ARD_SE .or. this%covariance_type(i_coordinate) == COVARIANCE_PP ) then + if( count( (/this%has_theta_file(i_coordinate), this%has_theta_uniform(i_coordinate), this%has_theta_fac(i_coordinate) /) ) /= 1 ) then + call system_abort("fit_data_from_xyz: covariance type is Gaussian or PP, so one of theta_file, theta_uniform of theta_fac must be specified") + endif + endif + + if( this%has_theta_file(i_coordinate) ) then + allocate(theta_string_array(this%my_gp%coordinate(i_coordinate)%d)) + allocate(theta(this%my_gp%coordinate(i_coordinate)%d)) + + call initialise(theta_inout,trim(this%theta_file(i_coordinate))) + read(theta_inout%unit,'(a)') theta_string + call split_string(theta_string,' :;','{}',theta_string_array,d,matching=.true.) + if(this%my_gp%coordinate(i_coordinate)%d /= d) call system_abort('File '//trim(this%theta_file(i_coordinate))//' does not contain the right number of hyperparameters') + do i = 1, d + theta(i) = string_to_real(trim(theta_string_array(i))) + enddo + call gp_setTheta(this%my_gp,i_coordinate,theta=theta) + deallocate(theta_string_array) + deallocate(theta) + call finalise(theta_inout) + elseif(this%has_theta_uniform(i_coordinate)) then + allocate(theta(this%my_gp%coordinate(i_coordinate)%d)) + theta = this%theta_uniform(i_coordinate) + call gp_setTheta(this%my_gp,i_coordinate,theta=theta) + deallocate(theta) + elseif(this%has_theta_fac(i_coordinate)) then + allocate(theta_string_array(this%my_gp%coordinate(i_coordinate)%d)) + allocate(theta_fac(this%my_gp%coordinate(i_coordinate)%d)) + call split_string(trim(this%theta_fac_string(i_coordinate))," :;",'{}',theta_string_array,n_theta_fac,matching=.true.) + + if(n_theta_fac == 1) then + theta_fac = string_to_real(theta_string_array(1)) + elseif(n_theta_fac == this%my_gp%coordinate(i_coordinate)%d) then + do i = 1, this%my_gp%coordinate(i_coordinate)%d + theta_fac(i) = string_to_real(theta_string_array(i)) + enddo + else + call system_abort("theta_fac can only contain one value or as many as dimensions the descriptor is") + endif + call gp_setThetaFactor(this%my_gp,i_coordinate,theta_fac,useSparseX=.false.) + + deallocate(theta_fac) + deallocate(theta_string_array) + elseif( this%has_zeta(i_coordinate) ) then + call gp_setTheta(this%my_gp,i_coordinate,zeta=this%zeta(i_coordinate)) + endif + enddo + + if( this%do_core ) call Finalise(this%core_pot) + + call gp_sparsify(this%my_gp, n_sparseX=this%config_type_n_sparseX, default_all=(this%n_sparseX /= 0), & + task_manager=this%task_manager, sparse_method=this%sparse_method, sparse_file=this%sparse_file, & + use_actual_gpcov=this%sparse_use_actual_gpcov, print_sparse_index = this%print_sparse_index, & + unique_hash_tolerance=this%unique_hash_tolerance, unique_descriptor_tolerance=this%unique_descriptor_tolerance) + + end subroutine fit_data_from_xyz + + subroutine e0_from_xyz(this) + + type(gap_fit), intent(inout) :: this + + integer :: n_con, n_ener, i, my_n_neighbours + logical :: has_ener + real(dp) :: ener, ener_core + + logical, dimension(total_elements) :: found_Z, found_isolated + + if( this%do_core ) call Initialise(this%core_pot, this%core_ip_args, param_str=string(this%quip_string)) + + n_ener = 0 + + this%e0 = 0.0_dp + found_isolated = .false. + found_Z = .false. + + do n_con = 1, this%n_frame + + has_ener = get_value(this%at(n_con)%params,trim(this%energy_parameter_name),ener) + + found_Z(this%at(n_con)%Z) = .true. + + if( has_ener ) then + + ener_core = 0.0_dp + if( this%do_core ) then + if( this%at(n_con)%cutoff < cutoff(this%core_pot) ) then + call set_cutoff(this%at(n_con), cutoff(this%core_pot)) + call calc_connect(this%at(n_con)) + endif + call calc(this%core_pot,this%at(n_con),energy=ener_core) + endif + + select case(this%e0_method) + case(E0_ISOLATED) + if( this%at(n_con)%N == 1 ) then + if( this%at(n_con)%cutoff < this%max_cutoff ) then + call set_cutoff(this%at(n_con), this%max_cutoff) + endif + call calc_connect(this%at(n_con)) + if( n_neighbours(this%at(n_con),1,max_dist = this%max_cutoff) == 0 ) then + if( found_isolated(this%at(n_con)%Z(1)) ) then + call system_abort("Found more than one isolated atom configuration, which may be ambiguous.") + endif + this%e0(this%at(n_con)%Z(1)) = ener - ener_core + found_isolated(this%at(n_con)%Z(1)) = .true. + endif + endif + case(E0_AVERAGE) + this%e0 = this%e0 + (ener-ener_core) / this%at(n_con)%N + case default + call system_abort("Unknown e0_method") + endselect + + n_ener = n_ener + 1 + endif + enddo + + select case(this%e0_method) + case(E0_ISOLATED) + if( .not. all(found_isolated .eqv. found_Z) ) then + do i = 1, size(found_Z) + if( found_Z(i) .and. .not. found_isolated(i) ) then + call print("Atom species "//i//" present in teaching XYZ, but not found corresponding isolated & + representative") + endif + enddo + call system_abort("Determination of e0 was requested to be based on isolated atom energies, but not all & + & atom types present in the XYZ had an isolated representative.") + endif + case(E0_AVERAGE) + if( n_ener > 0 ) then + this%e0 = this%e0 / n_ener + else + this%e0 = 0.0_dp + endif + case default + call system_abort("Unknown e0_method") + endselect + + if( this%do_core ) call Finalise(this%core_pot) + + endsubroutine e0_from_xyz + + subroutine w_Z_from_xyz(this) + + type(gap_fit), intent(inout) :: this + + type(cinoutput) :: xyzfile + type(atoms) :: at + + call initialise(xyzfile,this%at_file,mpi=this%mpi_obj) + + call read(xyzfile,at,frame=0) + !call get_weights(at,this%w_Z) + call finalise(at) + + call finalise(xyzfile) + + end subroutine w_Z_from_xyz + + subroutine gap_fit_print_xml(this,filename,sparseX_separate_file) + + use iso_c_binding, only : C_NULL_CHAR + + type(gap_fit), intent(in) :: this + character(len=*), intent(in) :: filename + logical, intent(in), optional :: sparseX_separate_file + + type(xmlf_t) :: xf + !type(extendable_str) :: gap_string + !type(inoutput) :: gp_inout + character(len=STRING_LENGTH) :: gp_tmp_file, gp_label + integer :: i + integer, dimension(8) :: values + logical :: my_sparseX_separate_file + + call date_and_time(values=values) + ! Get totally unique label for GAP. This will be used at various places. + write(gp_label,'("GAP_"7(i0,"_")i0)') values + + ! Unique temporary file + gp_tmp_file = 'tmp_'//trim(gp_label)//'.xml' + + ! Print GAP part of the potential into the temporary file. + call xml_OpenFile(gp_tmp_file,xf,addDecl=.false.) + + call xml_NewElement(xf,"GAP_params") + call xml_AddAttribute(xf,"label",trim(gp_label)) + call xml_AddAttribute(xf,"gap_version",""//gap_version) + + call xml_NewElement(xf,"GAP_data") + call xml_AddAttribute(xf,"do_core",""//this%do_core) + + do i = 1, size(this%e0) + call xml_NewElement(xf,"e0") + call xml_AddAttribute(xf,"Z",""//i) + call xml_AddAttribute(xf,"value",""// (this%e0(i)+this%local_property0(i) )) + call xml_EndElement(xf,"e0") + enddo + + call xml_EndElement(xf,"GAP_data") + + my_sparseX_separate_file = optional_default(.false., sparseX_separate_file) + + ! Print GP bit of the potential + if (my_sparseX_separate_file) then + call gp_printXML(this%gp_sp,xf,label=gp_label,sparseX_base_filename=trim(filename)//".sparseX") + + call gp_write_covariance(this%gp_sp, trim(filename)//".R", gp_label) + else + call gp_printXML(this%gp_sp,xf,label=gp_label) + endif + + ! Print the config string (from command line or config file) used for the fitting + ! Keep for backwards compatibility + if(this%config_string%len > 0) then + call xml_NewElement(xf,"command_line") + call xml_AddCharacters(xf,trim(string(this%config_string)),parsed=.false.) + call xml_EndElement(xf,"command_line") + endif + + if(this%do_copy_at_file) then + ! Print the fitting configurations used for this potential. + if(len(trim(this%at_file)) > 0 ) call file_print_xml(this%at_file,xf,ws_significant=.false.) + endif + + call xml_EndElement(xf,"GAP_params") + call xml_Close(xf) + + !! Now read back into an extendable string what we have just printed out. + !call read(gap_string, trim(gp_tmp_file), keep_lf=.true.) + + !! Initialise the final file + !call initialise(gp_inout,trim(filename),action=OUTPUT) + + ! Open a unique root element for the xml + !call print('<'//trim(gp_label)//'>',file=gp_inout) + !!call system_command('echo "<'//trim(gp_label)//'>" >>'//trim(filename)) + call fwrite_line_to_file(trim(filename)//C_NULL_CHAR,'<'//trim(gp_label)//'>'//C_NULL_CHAR,'w'//C_NULL_CHAR) + + if(this%do_core) then + ! Create the sum potential xml entry (by hand) + !call print('',file=gp_inout) + !call system_command('echo "" >>'//trim(filename)) + call fwrite_line_to_file(trim(filename)//C_NULL_CHAR, & + ''//C_NULL_CHAR, & + 'a'//C_NULL_CHAR) + + ! Now add the core potential that was used. + !call print(string(this%quip_string),file=gp_inout) + !call system_command('echo "'//string(this%quip_string)//' >>'//trim(filename)) + call fappend_file_to_file(trim(filename)//C_NULL_CHAR,trim(this%core_param_file)//C_NULL_CHAR) + else + call fwrite_line_to_file(trim(filename)//C_NULL_CHAR, & + ''//C_NULL_CHAR,'a'//C_NULL_CHAR) + endif + + ! Add the GAP potential + !call print(string(gap_string),file=gp_inout) + !call system_command('cat '//trim(gp_tmp_file)//' >>'//trim(filename)) + call fappend_file_to_file(trim(filename)//C_NULL_CHAR,trim(gp_tmp_file)//C_NULL_CHAR) + + ! Close the root element + !call print('',file=gp_inout) + !call system_command('echo "" >>'//trim(filename)) + call fwrite_line_to_file(trim(filename)//C_NULL_CHAR,''//C_NULL_CHAR,'a'//C_NULL_CHAR) + + !call finalise(gp_inout) + !call finalise(gap_string) + + ! Delete the temporary file + !call system_command('rm -f '//trim(gp_tmp_file)) + call frm_file(trim(gp_tmp_file)//C_NULL_CHAR) + + + endsubroutine gap_fit_print_xml + + subroutine file_print_xml(this,xf,ws_significant) + character(len=*), intent(in) :: this + type(xmlf_t), intent(inout) :: xf + logical, intent(in), optional :: ws_significant + + type(inoutput) :: atfile + character(len=10240) :: line + integer :: iostat + + call initialise(atfile,trim(this)) + call xml_NewElement(xf,"XYZ_data") + call xml_AddNewLine(xf) + + do + read(atfile%unit,'(a)',iostat=iostat) line + if(iostat < 0) then + exit + elseif(iostat > 0) then + call system_abort('file_print_xml: unkown error ('//iostat//') while reading '//trim(this)) + endif + call xml_AddCharacters(xf,trim(line),parsed=.false.,ws_significant=ws_significant) + call xml_AddNewLine(xf) + enddo + call xml_EndElement(xf,"XYZ_data") + call finalise(atfile) + + endsubroutine file_print_xml + +! subroutine print_sparse(this) +! type(gap_fit), intent(in) :: this +! type(cinoutput) :: xyzfile, xyzfile_out +! type(atoms) :: at, at_out +! +! integer :: li, ui, n_con +! logical, dimension(:), allocatable :: x +! logical, dimension(:), pointer :: sparse +! +! if(this%do_mark_sparse_atoms) then +! +! allocate(x(this%n_descriptors)) +! x = .false. +! x(this%r) = .true. +! +! call initialise(xyzfile,this%at_file) +! call initialise(xyzfile_out,this%mark_sparse_atoms,action=OUTPUT) +! +! li = 0 +! ui = 0 +! do n_con = 1, xyzfile%n_frame +! call read(xyzfile,at,frame=n_con-1) +! at_out = at +! +! call add_property(at_out,'sparse',.false.,ptr=sparse) +! +! li = ui + 1 +! ui = ui + at%N +! if(any( x(li:ui) )) sparse(find_indices(x(li:ui))) = .true. +! +! call write(at_out,xyzfile_out,properties="species:pos:sparse") +! enddo +! call finalise(xyzfile) +! call finalise(xyzfile_out) +! deallocate(x) +! +! endif +! +! endsubroutine print_sparse + + subroutine get_n_sparseX_for_files(this) + type(gap_fit), intent(inout) :: this + + integer :: i, n_sparseX, d + + do i = 1, this%n_coordinate + if (all(this%sparse_method(i) /= [GP_SPARSE_FILE, GP_SPARSE_INDEX_FILE])) cycle + + d = descriptor_dimensions(this%my_descriptor(i)) + n_sparseX = count_entries_in_sparse_file(this%sparse_file(i), this%sparse_method(i), d) + + if (this%n_sparseX(i) /= 0 .and. this%n_sparseX(i) /= n_sparseX) then + call system_abort("get_n_sparseX_for_files: Given n_sparse ("//this%n_sparseX(i)//") " & + // "does not match with file ("//n_sparseX//"). ") + end if + + this%n_sparseX(i) = n_sparseX + end do + end subroutine get_n_sparseX_for_files + + subroutine parse_config_type_sigma(this) + type(gap_fit), intent(inout) :: this + character(len=STRING_LENGTH), dimension(200) :: config_type_sigma_fields + integer :: config_type_sigma_num_fields, i_default, i, n_config_type + + if( this%has_config_type_sigma ) then + call split_string(this%config_type_sigma_string,' :;','{}',config_type_sigma_fields,config_type_sigma_num_fields,matching=.true.) + + n_config_type = config_type_sigma_num_fields / 5 + + ! find "default" if present + i_default = 0 + do i = 1, config_type_sigma_num_fields, 5 + if( trim(config_type_sigma_fields(i)) == "default" ) i_default = i + enddo + + if( i_default == 0 ) then + ! no default present in the string, we add it, and it'll be the last one + n_config_type = n_config_type + 1 + i_default = n_config_type + config_type_sigma_fields(config_type_sigma_num_fields+1) = "default" + config_type_sigma_fields(config_type_sigma_num_fields+2) = ""//this%default_sigma(1) + config_type_sigma_fields(config_type_sigma_num_fields+3) = ""//this%default_sigma(2) + config_type_sigma_fields(config_type_sigma_num_fields+4) = ""//this%default_sigma(3) + config_type_sigma_fields(config_type_sigma_num_fields+5) = ""//this%default_sigma(4) + config_type_sigma_num_fields = config_type_sigma_num_fields + 5 + endif + + allocate(this%config_type(n_config_type)) + allocate(this%sigma(4,n_config_type)) + + do i = 1, n_config_type + this%config_type(i) = trim(config_type_sigma_fields(5*(i-1)+1)) + this%sigma(1,i) = string_to_real(config_type_sigma_fields(5*(i-1)+2)) + this%sigma(2,i) = string_to_real(config_type_sigma_fields(5*(i-1)+3)) + this%sigma(3,i) = string_to_real(config_type_sigma_fields(5*(i-1)+4)) + this%sigma(4,i) = string_to_real(config_type_sigma_fields(5*(i-1)+5)) + enddo + + call print('Sparse points and target errors per pre-defined types of configurations') + do i = 1, n_config_type + call print(""//trim(this%config_type(i))//" "//this%sigma(:,i)) + enddo + else + allocate(this%config_type(1)) + allocate(this%sigma(4,1)) + this%config_type(1)= "default" + this%sigma(:,1) = this%default_sigma + endif + + endsubroutine parse_config_type_sigma + + subroutine parse_config_type_n_sparseX(this) + type(gap_fit), intent(inout) :: this + + integer :: i, j, i_default, i_coordinate, i_config_type, config_type_n_sparseX_num_fields, n_config_type, new_config_types + character(len=STRING_LENGTH), dimension(200) :: config_type_n_sparseX_fields + logical :: config_type_present + + if( .not. allocated(this%config_type) ) call system_abort('config_type not allocated, call parse_config_type_sigma first') + + do i = 1, size(this%config_type) + if( trim(this%config_type(i)) == "default" ) i_default = i + enddo + + ! Check first if we have more new config types than we had from config_type_sigma + do i_coordinate = 1, this%n_coordinate + if( this%n_sparseX(i_coordinate) == 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) > 0) then + call split_string(this%config_type_n_sparseX_string(i_coordinate),' :;','{}',config_type_n_sparseX_fields,config_type_n_sparseX_num_fields,matching=.true.) + + if( mod(config_type_n_sparseX_num_fields,2) /= 0 ) then + call system_abort("parse_config_type_n_sparseX: config_type_n_sparseX could not be parsed correctly, key/value pairs must always be present") + endif + + n_config_type = size(this%config_type) + new_config_types = 0 ! Assume there are no new config_types + do j = 1, config_type_n_sparseX_num_fields, 2 ! loop over config_types in the descriptor string + config_type_present = .false. + do i = 1, n_config_type ! loop over config_types previously set + if( trim(this%config_type(i)) == trim(config_type_n_sparseX_fields(j)) ) config_type_present = .true. ! Found config_type among old ones + enddo + if(.not.config_type_present) new_config_types = new_config_types + 1 ! Increment as it's a genuine new config_type + enddo + if( new_config_types > 0 ) then + call reallocate(this%config_type, n_config_type + new_config_types, copy=.true.) + call reallocate(this%sigma,4,n_config_type + new_config_types, copy=.true.) + + i_config_type = n_config_type + do j = 1, config_type_n_sparseX_num_fields, 2 ! loop over config_types in the descriptor string + config_type_present = .false. + do i = 1, n_config_type ! loop over config_types previously set + if( trim(this%config_type(i)) == trim(config_type_n_sparseX_fields(j)) ) config_type_present = .true. ! Found config_type among old ones + enddo + if(.not.config_type_present) then ! it's a genuine new config_type + i_config_type = i_config_type + 1 + this%config_type(i_config_type) = trim(config_type_n_sparseX_fields(j)) + this%sigma(:,i_config_type) = this%sigma(:,i_default) + endif + enddo + endif + + elseif(this%n_sparseX(i_coordinate) > 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) > 0 .and. len_trim(this%sparse_file(i_coordinate)) ==0 ) then + call system_abort('Confused: cannot specify both n_sparse and config_type_n_sparse') + + + elseif(this%n_sparseX(i_coordinate) == 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) == 0 .and. len_trim(this%sparse_file(i_coordinate)) == 0) then + call system_abort('Confused: either n_sparse or config_type_n_sparse has to be specified') + endif + + enddo + + n_config_type = size(this%config_type) + allocate(this%config_type_n_sparseX(n_config_type,this%n_coordinate)) + this%config_type_n_sparseX = 0 + + do i_coordinate = 1, this%n_coordinate + if( this%n_sparseX(i_coordinate) == 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) > 0) then + call split_string(this%config_type_n_sparseX_string(i_coordinate),' :;','{}',config_type_n_sparseX_fields,config_type_n_sparseX_num_fields,matching=.true.) + + do j = 1, config_type_n_sparseX_num_fields, 2 ! loop over config_types in the descriptor string + do i = 1, n_config_type ! loop over config_types previously set + if( trim(this%config_type(i)) == trim(config_type_n_sparseX_fields(j)) ) & + this%config_type_n_sparseX(i,i_coordinate) = string_to_int( config_type_n_sparseX_fields(j+1) ) + enddo + enddo + !this%n_sparseX(i_coordinate) = sum( this%config_type_n_sparseX(:,i_coordinate) ) + + elseif( this%n_sparseX(i_coordinate) > 0 .and. len_trim(this%config_type_n_sparseX_string(i_coordinate)) == 0) then + this%config_type_n_sparseX(i_default,i_coordinate) = this%n_sparseX(i_coordinate) + endif + enddo + + endsubroutine parse_config_type_n_sparseX + + subroutine get_species_xyz(this) + type(gap_fit), intent(inout) :: this + + integer :: n_con, i + integer, dimension(total_elements) :: species_present + + this%n_species = 0 + species_present = 0 + + do n_con = 1, this%n_frame + do i = 1, this%at(n_con)%N + if( all(this%at(n_con)%Z(i) /= species_present) ) then + this%n_species = this%n_species + 1 + species_present(this%n_species) = this%at(n_con)%Z(i) + endif + enddo + enddo + + allocate(this%species_Z(this%n_species)) + this%species_Z = species_present(1:this%n_species) + + endsubroutine get_species_xyz + + subroutine add_multispecies_gaps(this) + type(gap_fit), intent(inout) :: this + + integer :: i_coordinate, i, j, n_gap_str, i_add_species + character(STRING_LENGTH), dimension(:), allocatable :: gap_str_i, new_gap_str + + ! temporary arrays + real(dp), dimension(:), allocatable :: delta, f0, theta_uniform, zeta, unique_hash_tolerance, unique_descriptor_tolerance + integer, dimension(:), allocatable :: n_sparseX, sparse_method, covariance_type + character(len=STRING_LENGTH), dimension(:), allocatable :: theta_file, sparse_file, theta_fac_string, config_type_n_sparseX_string, print_sparse_index + logical, dimension(:), allocatable :: mark_sparse_atoms, has_theta_fac, has_theta_uniform, has_theta_file, has_zeta + + n_gap_str = 0 + do i_coordinate = 1, this%n_coordinate + if( this%add_species(i_coordinate) ) then + + call print('Old GAP: {'//trim(this%gap_str(i_coordinate))//'}') + call descriptor_str_add_species(this%gap_str(i_coordinate),this%species_Z,gap_str_i) + call reallocate(new_gap_str, n_gap_str+size(gap_str_i),copy=.true.) + + call reallocate(delta, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(f0, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(n_sparseX, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(config_type_n_sparseX_string, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(theta_fac_string, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(theta_uniform, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(theta_file, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(has_theta_fac, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(has_theta_uniform, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(has_theta_file, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(sparse_file, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(mark_sparse_atoms, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(sparse_method, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(covariance_type, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(zeta, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(has_zeta, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(print_sparse_index, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(unique_hash_tolerance, n_gap_str+size(gap_str_i),copy=.true.) + call reallocate(unique_descriptor_tolerance, n_gap_str+size(gap_str_i),copy=.true.) + + do i = 1, size(gap_str_i) + i_add_species = index(gap_str_i(i),'add_species') + if(i_add_species /= 0) then + do j = i_add_species, len_trim(gap_str_i(i)) + if( gap_str_i(i)(j:j) == " " ) exit + gap_str_i(i)(j:j) = " " + !gap_str_i(i)(i_add_species:i_add_species+len('add_species')-1) = ' ' + enddo + endif + + new_gap_str(i+n_gap_str) = trim(gap_str_i(i)) + call print('New GAP: {'//trim(gap_str_i(i))//'}') + + delta(i+n_gap_str) = this%delta(i_coordinate) + f0(i+n_gap_str) = this%f0(i_coordinate) + n_sparseX(i+n_gap_str) = this%n_sparseX(i_coordinate) + config_type_n_sparseX_string(i+n_gap_str) = this%config_type_n_sparseX_string(i_coordinate) + theta_fac_string(i+n_gap_str) = this%theta_fac_string(i_coordinate) + theta_uniform(i+n_gap_str) = this%theta_uniform(i_coordinate) + theta_file(i+n_gap_str) = this%theta_file(i_coordinate) + + has_theta_fac(i+n_gap_str) = this%has_theta_fac(i_coordinate) + has_theta_uniform(i+n_gap_str) = this%has_theta_uniform(i_coordinate) + has_theta_file(i+n_gap_str) = this%has_theta_file(i_coordinate) + + sparse_file(i+n_gap_str) = this%sparse_file(i_coordinate) + mark_sparse_atoms(i+n_gap_str) = this%mark_sparse_atoms(i_coordinate) + sparse_method(i+n_gap_str) = this%sparse_method(i_coordinate) + covariance_type(i+n_gap_str) = this%covariance_type(i_coordinate) + zeta(i+n_gap_str) = this%zeta(i_coordinate) + has_zeta(i+n_gap_str) = this%has_zeta(i_coordinate) + print_sparse_index(i+n_gap_str) = this%print_sparse_index(i_coordinate) + unique_hash_tolerance(i+n_gap_str) = this%unique_hash_tolerance(i_coordinate) + unique_descriptor_tolerance(i+n_gap_str) = this%unique_descriptor_tolerance(i_coordinate) + + enddo + n_gap_str = n_gap_str + size(gap_str_i) + deallocate(gap_str_i) + + else + n_gap_str = n_gap_str + 1 + + call reallocate(new_gap_str, n_gap_str,copy=.true.) + call reallocate(delta, n_gap_str,copy=.true.) + call reallocate(f0, n_gap_str,copy=.true.) + call reallocate(n_sparseX, n_gap_str,copy=.true.) + call reallocate(config_type_n_sparseX_string, n_gap_str,copy=.true.) + call reallocate(theta_fac_string, n_gap_str,copy=.true.) + call reallocate(theta_uniform, n_gap_str,copy=.true.) + call reallocate(theta_file, n_gap_str,copy=.true.) + + call reallocate(has_theta_fac, n_gap_str,copy=.true.) + call reallocate(has_theta_uniform, n_gap_str,copy=.true.) + call reallocate(has_theta_file, n_gap_str,copy=.true.) + + call reallocate(sparse_file, n_gap_str,copy=.true.) + call reallocate(mark_sparse_atoms, n_gap_str,copy=.true.) + call reallocate(sparse_method, n_gap_str,copy=.true.) + call reallocate(covariance_type, n_gap_str,copy=.true.) + call reallocate(zeta, n_gap_str,copy=.true.) + call reallocate(has_zeta, n_gap_str,copy=.true.) + call reallocate(print_sparse_index, n_gap_str,copy=.true.) + + call reallocate(unique_hash_tolerance, n_gap_str,copy=.true.) + call reallocate(unique_descriptor_tolerance, n_gap_str,copy=.true.) + + new_gap_str(n_gap_str) = trim(this%gap_str(i_coordinate)) + delta(n_gap_str) = this%delta(i_coordinate) + f0(n_gap_str) = this%f0(i_coordinate) + n_sparseX(n_gap_str) = this%n_sparseX(i_coordinate) + config_type_n_sparseX_string(n_gap_str) = this%config_type_n_sparseX_string(i_coordinate) + theta_fac_string(n_gap_str) = this%theta_fac_string(i_coordinate) + theta_uniform(n_gap_str) = this%theta_uniform(i_coordinate) + theta_file(n_gap_str) = this%theta_file(i_coordinate) + + has_theta_fac(n_gap_str) = this%has_theta_fac(i_coordinate) + has_theta_uniform(n_gap_str) = this%has_theta_uniform(i_coordinate) + has_theta_file(n_gap_str) = this%has_theta_file(i_coordinate) + + sparse_file(n_gap_str) = this%sparse_file(i_coordinate) + mark_sparse_atoms(n_gap_str) = this%mark_sparse_atoms(i_coordinate) + sparse_method(n_gap_str) = this%sparse_method(i_coordinate) + covariance_type(n_gap_str) = this%covariance_type(i_coordinate) + zeta(n_gap_str) = this%zeta(i_coordinate) + has_zeta(n_gap_str) = this%has_zeta(i_coordinate) + print_sparse_index(n_gap_str) = this%print_sparse_index(i_coordinate) + + unique_hash_tolerance(n_gap_str) = this%unique_hash_tolerance(i_coordinate) + unique_descriptor_tolerance(n_gap_str) = this%unique_descriptor_tolerance(i_coordinate) + + call print('Unchanged GAP: {'//trim(this%gap_str(i_coordinate))//'}') + endif + + enddo + call reallocate(this%delta, n_gap_str) + call reallocate(this%f0, n_gap_str) + call reallocate(this%n_sparseX, n_gap_str) + call reallocate(this%config_type_n_sparseX_string, n_gap_str) + call reallocate(this%theta_fac_string, n_gap_str) + call reallocate(this%theta_uniform, n_gap_str) + call reallocate(this%theta_file, n_gap_str) + + call reallocate(this%has_theta_fac, n_gap_str) + call reallocate(this%has_theta_uniform, n_gap_str) + call reallocate(this%has_theta_file, n_gap_str) + + call reallocate(this%sparse_file, n_gap_str) + call reallocate(this%mark_sparse_atoms, n_gap_str) + call reallocate(this%sparse_method, n_gap_str) + call reallocate(this%covariance_type, n_gap_str) + call reallocate(this%zeta, n_gap_str) + call reallocate(this%has_zeta, n_gap_str) + call reallocate(this%print_sparse_index, n_gap_str) + + call reallocate(this%unique_hash_tolerance, n_gap_str) + call reallocate(this%unique_descriptor_tolerance, n_gap_str) + + this%gap_str(1:n_gap_str) = new_gap_str + this%delta = delta + this%f0 = f0 + this%n_sparseX = n_sparseX + this%config_type_n_sparseX_string = config_type_n_sparseX_string + this%theta_fac_string = theta_fac_string + this%theta_uniform = theta_uniform + this%theta_file = theta_file + + this%has_theta_fac = has_theta_fac + this%has_theta_uniform = has_theta_uniform + this%has_theta_file = has_theta_file + + this%sparse_file = sparse_file + this%mark_sparse_atoms = mark_sparse_atoms + this%sparse_method = sparse_method + this%covariance_type = covariance_type + this%zeta = zeta + this%has_zeta = has_zeta + this%print_sparse_index = print_sparse_index + + this%unique_hash_tolerance = unique_hash_tolerance + this%unique_descriptor_tolerance = unique_descriptor_tolerance + + this%n_coordinate = n_gap_str + + if(allocated(delta)) deallocate(delta) + if(allocated(f0)) deallocate(f0) + if(allocated(n_sparseX)) deallocate(n_sparseX) + if(allocated(config_type_n_sparseX_string)) deallocate(config_type_n_sparseX_string) + if(allocated(theta_fac_string)) deallocate(theta_fac_string) + if(allocated(theta_uniform)) deallocate(theta_uniform) + if(allocated(theta_file)) deallocate(theta_file) + + if(allocated(has_theta_fac)) deallocate(has_theta_fac) + if(allocated(has_theta_uniform)) deallocate(has_theta_uniform) + if(allocated(has_theta_file)) deallocate(has_theta_file) + + if(allocated(sparse_file)) deallocate(sparse_file) + if(allocated(mark_sparse_atoms)) deallocate(mark_sparse_atoms) + if(allocated(sparse_method)) deallocate(sparse_method) + if(allocated(covariance_type)) deallocate(covariance_type) + if(allocated(zeta)) deallocate(zeta) + if(allocated(has_zeta)) deallocate(has_zeta) + if(allocated(print_sparse_index)) deallocate(print_sparse_index) + + if(allocated(unique_hash_tolerance)) deallocate(unique_hash_tolerance) + if(allocated(unique_descriptor_tolerance)) deallocate(unique_descriptor_tolerance) + + endsubroutine add_multispecies_gaps + + subroutine add_template_string(this) + type(gap_fit), intent(inout) :: this + character(len=STRING_LENGTH) :: template_string=' ' + character(len=STRING_LENGTH),dimension(:), allocatable :: lines_array + type(inoutput) :: tempfile + integer :: i,n_lines,total_length=0 + + if( this%has_template_file ) then + call print("adding template string, reading from file "//trim(this%template_file)) + call initialise(tempfile,trim(this%template_file)) + call read_file(tempfile,lines_array,n_lines) + + do i=1,n_lines-1 + template_string=trim(template_string)//"{"//trim(lines_array(i))//"};" + total_length = total_length + len_trim(lines_array(i)) + end do + template_string=trim(template_string)//"{"//trim(lines_array(n_lines))//"}" + total_length = total_length + len_trim(lines_array(n_lines)) + + if (total_length .ge. STRING_LENGTH) call system_abort("Template atoms object exceeds maximum string size") + + do i=1,len_trim(template_string) + if(template_string(i:i)==' ') then + template_string(i:i)='%' + end if + end do + !call print(template_string) + + do i=1,this%n_coordinate + this%gap_str(i) = trim(this%gap_str(i))//" atoms_template_string={"//trim(template_string)//"}" + end do + endif + + end subroutine add_template_string + + subroutine gap_fit_read_core_param_file(this) + type(gap_fit), intent(inout) :: this + if (this%do_core) then + call read(this%quip_string, file=trim(this%core_param_file), mpi_comm=this%mpi_obj%communicator, mpi_id=this%mpi_obj%my_proc, keep_lf=.true.) + end if + end subroutine gap_fit_read_core_param_file + + subroutine gap_fit_init_mpi_scalapack(this) + type(gap_fit), intent(inout) :: this + + call initialise(this%mpi_obj) + call initialise(this%ScaLAPACK_obj, this%mpi_obj, np_r=this%mpi_obj%n_procs, np_c=1) + if (this%mpi_obj%n_procs > 1 .and. .not. this%ScaLAPACK_obj%active) then + call system_abort('Init MPI+Scalapack: n_procs > 1 but ScaLAPACK is inactive.') + end if + end subroutine gap_fit_init_mpi_scalapack + + subroutine gap_fit_init_task_manager(this) + type(gap_fit), intent(inout) :: this + + this%task_manager%active = this%ScaLAPACK_obj%active + this%task_manager%MPI_obj = this%MPI_obj + this%task_manager%ScaLAPACK_obj = this%ScaLAPACK_obj + + call task_manager_init_workers(this%task_manager, this%ScaLAPACK_obj%n_proc_rows) + call task_manager_init_tasks(this%task_manager, this%n_frame+1) ! mind special task + this%task_manager%my_worker_id = this%ScaLAPACK_obj%my_proc_row + 1 ! mpi 0-index to tm 1-index + + if (.not. this%task_manager%active) return + + call task_manager_init_idata(this%task_manager, 3) ! space for nrows, blocksizes + end subroutine gap_fit_init_task_manager + + subroutine gap_fit_distribute_tasks(this) + type(gap_fit), intent(inout) :: this + + integer :: n_sparseX + + if (.not. this%task_manager%active) return + + n_sparseX = sum(this%config_type_n_sparseX) + + ! add special task (size, offset) for Cholesky matrix addon shared by all workers + call task_manager_add_task(this%task_manager, n_sparseX, n_idata=2, worker_id=SHARED) + call task_manager_distribute_tasks(this%task_manager) + call task_manager_check_distribution(this%task_manager) + end subroutine gap_fit_distribute_tasks + + function gap_fit_is_root(this, root) result(res) + type(gap_fit), intent(in) :: this + integer, intent(in), optional :: root + logical :: res + res = is_root(this%MPI_obj, root) + end function gap_fit_is_root + + subroutine gap_fit_print_linear_system_dump_file(this) + type(gap_fit), intent(in) :: this + if (this%has_linear_system_dump_file) then + call gpFull_print_covariances_lambda_globalY(this%my_gp, this%linear_system_dump_file, & + this%mpi_obj%my_proc, do_Kmm=is_root(this%mpi_obj)) + end if + end subroutine gap_fit_print_linear_system_dump_file + + ! set blocksize, abort if ScaLAPACK would overflow 32bit integer + subroutine gap_fit_set_mpi_blocksizes(this) + type(gap_fit), intent(inout) :: this + + integer(idp), parameter :: bit_limit = 2_idp**31 + + integer :: nrows, nrows0, trows, ncols, mb_A, nb_A, i + integer(idp) :: lwork1, lwork2, trows64, size_A_local + + if (.not. this%task_manager%active) return + + nrows0 = this%task_manager%unified_workload + ncols = sum(this%config_type_n_sparseX) + + mb_A = this%mpi_blocksize_rows + if (mb_A == 0) then + call print("Defaulting mpi_blocksize_rows (arg = 0) ...", PRINT_VERBOSE) + mb_A = nrows0 + end if + call print("mpi_blocksize_rows = "//mb_A, PRINT_VERBOSE) + + nb_A = this%mpi_blocksize_cols + if (nb_A == 0) then + call print("Defaulting mpi_blocksize_cols (arg = 0) ...", PRINT_VERBOSE) + nb_A = ncols + end if + call print("mpi_blocksize_cols = "//nb_A, PRINT_VERBOSE) + + nrows = increase_to_multiple(nrows0, mb_A) + call print("nrows = "//nrows, PRINT_VERBOSE) + i = nrows - nrows0 + call print("distA extension: "//i//" "//ncols//" memory "//i2si(8_idp * i * ncols)//"B", PRINT_VERBOSE) + + ! transfer nrows and blocksizes to gp_predict + this%task_manager%idata(1) = nrows + this%task_manager%idata(2) = mb_A + this%task_manager%idata(3) = nb_A + + if (iwp == idp) return ! ignore 32bit checks for 64bit compilation + + + trows64 = int(nrows, idp) * this%task_manager%n_workers + trows = int(trows64, isp) + if (trows > bit_limit) then + call print_warning("Total rows of distributed matrix A is too large for 32bit integer: "//trows64//" = "//trows) + end if + + lwork1 = get_lwork_pdgeqrf(this%ScaLAPACK_obj, trows, ncols, mb_A, nb_A) + call print("lwork_pdgeqrf = "//lwork1//" = "//int(lwork1, isp), PRINT_VERBOSE) + lwork2 = get_lwork_pdormqr(this%ScaLAPACK_obj, 'L', trows, 1, mb_A, nb_A, mb_A, 1) + call print("lwork_pdormqr = "//lwork2//" = "//int(lwork2, isp), PRINT_VERBOSE) + if (max(lwork1, lwork2) > bit_limit) then + call system_abort("mpi_blocksize_cols = "//nb_A//" is too large for 32bit work array in ScaLAPACK!" & + //"Set mpi_blocksize_cols to something smaller, see --help.") + end if + + size_A_local = int(nrows, idp) * ncols + if (size_A_local > bit_limit) then + i = (trows64 * ncols + bit_limit - 1) / bit_limit + call system_abort("The local part of matrix A will have "//size_A_local//" entries. " & + // "This is too large for a 32bit integer calculation. " & + // "Use at least "//i//" MPI processes instead.") + end if + + end subroutine gap_fit_set_mpi_blocksizes + + subroutine gap_fit_estimate_memory(this) + type(gap_fit), intent(in) :: this + + integer(idp), parameter :: rmem = storage_size(1.0_dp, idp) / 8_idp + + integer :: i + integer(idp) :: s1, s2, entries + integer(idp) :: mem, memt, memp1 ! scratch, total, peak + integer(idp) :: sys_total_mem, sys_free_mem + + call print_title("Memory Estimate (per process)") + + call print("Descriptors") + memt = 0 + do i = 1, this%n_coordinate + s1 = descriptor_dimensions(this%my_descriptor(i)) + + entries = s1 * this%n_descriptors(i) + mem = entries * rmem + memt = memt + mem + call print("Descriptor "//i//" :: x "//s1//" "//this%n_descriptors(i)//" memory "//i2si(mem)//"B") + + entries = s1 * this%n_cross(i) + mem = entries * rmem + memt = memt + mem + call print("Descriptor "//i//" :: xPrime "//s1//" "//this%n_cross(i)//" memory "//i2si(mem)//"B") + end do + call print("Subtotal "//i2si(memt)//"B") + call print("") + memp1 = memt + + + call print("Covariances") + memt = 0 + s1 = sum(this%config_type_n_sparseX) + s2 = (this%n_ener + this%n_local_property) + (this%n_force + this%n_virial + this%n_hessian) + + entries = s1 * s2 + mem = entries * rmem + memt = memt + mem * 2 + call print("yY "//s1//" "//s2//" memory "//i2si(mem)//"B * 2") + memp1 = memp1 + mem + + entries = s1 * s1 + mem = entries * rmem + memt = memt + mem + call print("yy "//s1//" "//s1//" memory "//i2si(mem)//"B") + + entries = s1 * (s1 + s2) + mem = entries * rmem + memt = memt + mem * 2 + call print("A "//s1//" "//(s1+s2)//" memory "//i2si(mem)//"B * 2") + call print("Subtotal "//i2si(memt)//"B") + call print("") + + + mem = max(memp1, memt) + call print("Peak1 "//i2si(memp1)//"B") + call print("Peak2 "//i2si(memt)//"B") + call print("PEAK "//i2si(mem)//"B") + call print("") + + call mem_info(sys_total_mem, sys_free_mem) + call print("Free system memory "//i2si(sys_free_mem)//"B") + call print("Total system memory "//i2si(sys_total_mem)//"B") + + mem = sys_free_mem - mem + if (mem < 0) then + call print_warning("Memory estimate exceeds free system memory by "//i2si(-mem)//"B.") + end if + + call print_title("") + end subroutine gap_fit_estimate_memory + +end module gap_fit_module diff --git a/gp_fit.F90 b/gp_fit.F90 new file mode 100644 index 00000000..15de0009 --- /dev/null +++ b/gp_fit.F90 @@ -0,0 +1,750 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Gaussian Process module +!X +!% Module for general GP function interpolations. +!% A gp object contains the training set (fitting points and function values), +!% important temporary matrices, vectors and parameters. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module gp_fit_module + + use iso_c_binding, only : C_NULL_CHAR + use error_module + use system_module + use extendable_str_module + use linearalgebra_module + use dictionary_module, only : STRING_LENGTH + use gp_predict_module + use clustering_module + use task_manager_module, only : task_manager_type + use MPI_context_module, only: bcast, gatherv, is_root, scatterv, sum + implicit none + private + + integer, parameter, public :: EXCLUDE_CONFIG_TYPE = -10 + + interface gp_sparsify + module procedure gpFull_sparsify_array_config_type + endinterface gp_sparsify + public :: gp_sparsify + + public :: count_entries_in_sparse_file + + contains + + subroutine gpCoordinates_sparsify_config_type(this, n_sparseX, default_all, task_manager, sparse_method, sparse_file, & + use_actual_gpcov, print_sparse_index, unique_hash_tolerance, unique_descriptor_tolerance, error) + type(gpCoordinates), intent(inout), target :: this + integer, dimension(:), intent(in) :: n_sparseX + logical, intent(in) :: default_all + type(task_manager_type), intent(in) :: task_manager + integer, intent(in), optional :: sparse_method + character(len=STRING_LENGTH), intent(in), optional :: sparse_file, print_sparse_index + logical, intent(in), optional :: use_actual_gpcov + real(dp), intent(in), optional :: unique_descriptor_tolerance, unique_hash_tolerance + integer, intent(out), optional :: error + + integer :: my_sparse_method, i, j, li, ui, i_config_type, n_config_type, d, n_x + integer, dimension(:), allocatable :: config_type_index, sparseX_index, my_n_sparseX, x_index + real(dp), dimension(:,:), allocatable :: sparseX_array + + integer, dimension(:), pointer :: config_type_ptr, x_size_ptr + real(dp), dimension(:), pointer :: covdiag_x_x_ptr, cutoff_ptr + real(dp), dimension(:,:), pointer :: dm, x_ptr + + character(len=STRING_LENGTH) :: my_sparse_file + type(Inoutput) :: inout_sparse_index + + nullify(config_type_ptr, x_size_ptr) + nullify(covdiag_x_x_ptr, cutoff_ptr) + nullify(dm, x_ptr) + + INIT_ERROR(error) + + my_sparse_method = optional_default(GP_SPARSE_RANDOM,sparse_method) + my_sparse_file = optional_default("",sparse_file) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_sparsify: : object not initialised',error) + endif + + d = size(this%x, 1) + + if (task_manager%active) then + select case(my_sparse_method) + case (GP_SPARSE_NONE) ! shared task for Kmm breaks if n_sparseX increases + call system_abort("sparse_method NONE is not implemented for MPI.") + case (GP_SPARSE_INDEX_FILE) ! keeping original ordering of xyz frames would be too much effort + call system_abort("sparse_method INDEX_FILE is not implemented for MPI.") + case (GP_SPARSE_CLUSTER) ! routines depend directly on gpCoordinates + call system_abort("sparse_method CLUSTER is not implemented for MPI.") + case (GP_SPARSE_COVARIANCE) ! routines depend directly on gpCoordinates + call system_abort("sparse_method COVARIANCE is not implemented for MPI.") + case (GP_SPARSE_CUR_COVARIANCE) ! routines depend directly on gpCoordinates + call system_abort("sparse_method CUR_COVARIANCE is not implemented for MPI.") + case (GP_SPARSE_FILE) + ! use serial pointers + case default + call print("Collecting x on a single process for sparsification with MPI.") + n_x = sum(task_manager%mpi_obj, size(this%config_type), error) + + if (.not. is_root(task_manager%mpi_obj)) then + my_sparse_method = GP_SPARSE_SKIP + d = 1 + n_x = 1 + end if + + allocate(config_type_ptr(n_x)) + allocate(x_size_ptr(n_x)) + allocate(covdiag_x_x_ptr(n_x)) + allocate(cutoff_ptr(n_x)) + allocate(x_ptr(d, n_x)) + + call gatherv(task_manager%mpi_obj, this%config_type, config_type_ptr, error=error) + call gatherv(task_manager%mpi_obj, this%x, x_ptr, error=error) + call gatherv(task_manager%mpi_obj, this%cutoff, cutoff_ptr, error=error) + + if (this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + call gatherv(task_manager%mpi_obj, this%x_size, x_size_ptr, error=error) + end if + end select + end if + + if (.not. associated(config_type_ptr)) config_type_ptr => this%config_type + if (.not. associated(x_size_ptr)) x_size_ptr => this%x_size + if (.not. associated(covdiag_x_x_ptr)) covdiag_x_x_ptr => this%covarianceDiag_x_x + if (.not. associated(cutoff_ptr)) cutoff_ptr => this%cutoff + if (.not. associated(x_ptr)) x_ptr => this%x + + if (my_sparse_method /= GP_SPARSE_SKIP) then + allocate(my_n_sparseX(size(n_sparseX)), source=0) + + call exclude_duplicates(x_ptr, config_type_ptr, unique_descriptor_tolerance, unique_hash_tolerance, error) + n_x = count(EXCLUDE_CONFIG_TYPE /= config_type_ptr) + end if + + if (my_sparse_method == GP_SPARSE_SKIP) then + ! pass + elseif(my_sparse_method == GP_SPARSE_UNIQ) then + RAISE_ERROR('gpCoordinates_sparsify: UNIQ is no longer in use, please use NONE instead.',error) + + elseif(my_sparse_method == GP_SPARSE_NONE) then + + allocate(x_index(n_x)) + + j = 0 + do i = 1, size(x_ptr,2) + if( config_type_ptr(i) /= EXCLUDE_CONFIG_TYPE ) then + j = j + 1 + x_index(j) = i + endif + enddo + + this%n_sparseX = n_x + + call print('NONE type sparsification specified. The number of sparse points was changed from '//n_sparseX//' to '//this%n_sparseX//'.') + + elseif(my_sparse_method == GP_SPARSE_FILE .or. my_sparse_method == GP_SPARSE_INDEX_FILE) then + this%n_sparseX = count_entries_in_sparse_file(my_sparse_file, my_sparse_method, d, error) + else + do i_config_type = 1, size(n_sparseX) + if(default_all) then + + if( n_x < sum(n_sparseX) ) then + call print_warning('gpCoordinates_sparsify: number of data points ('//n_x//') less than the number of sparse points ('//sum(n_sparseX)//'), & + number of sparse points changed to '//n_x) + call print_warning('gpCoordinates_sparsify: affected descriptor : '//this%descriptor_str) + my_n_sparseX(1) = n_x + else + my_n_sparseX(1) = sum(n_sparseX) + endif + + else + if( n_sparseX(i_config_type) == 0 ) cycle + + n_config_type = count(i_config_type == config_type_ptr) + + if( n_config_type < n_sparseX(i_config_type) ) then + call print_warning('gpCoordinates_sparsify: number of data points ('//n_config_type//') less than the number of sparse points ('//n_sparseX(i_config_type)//'), & + number of sparse points changed to '//n_config_type) + call print_warning('gpCoordinates_sparsify: affected descriptor : '//this%descriptor_str) + my_n_sparseX(i_config_type) = n_config_type + else + my_n_sparseX(i_config_type) = n_sparseX(i_config_type) + endif + endif + + if(default_all) exit + enddo + this%n_sparseX = sum(my_n_sparseX) + endif + + if (task_manager%active .and. my_sparse_method /= GP_SPARSE_FILE) then + call bcast(task_manager%mpi_obj, this%n_sparseX, error) + end if + + call reallocate(this%sparseX, this%d, this%n_sparseX, zero = .true.) + + call reallocate(this%sparseX_index, this%n_sparseX, zero = .true.) + call reallocate(this%map_sparseX_globalSparseX, this%n_sparseX, zero = .true.) + call reallocate(this%alpha, this%n_sparseX, zero = .true.) + call reallocate(this%sparseCutoff, this%n_sparseX, zero = .true.) + this%sparseCutoff = 1.0_dp + + if (my_sparse_method == GP_SPARSE_SKIP) then + ! pass + elseif( my_sparse_method /= GP_SPARSE_FILE .and. my_sparse_method /= GP_SPARSE_INDEX_FILE) then + ui = 0 + do i_config_type = 1, size(my_n_sparseX) + + if( my_sparse_method == GP_SPARSE_NONE) exit + + if(default_all) then + + allocate(config_type_index(n_x), sparseX_index(this%n_sparseX)) + j = 0 + do i = 1, size(x_ptr,2) + if( config_type_ptr(i) /= EXCLUDE_CONFIG_TYPE ) then + j = j + 1 + config_type_index(j) = i + endif + enddo + + li = 1 + ui = this%n_sparseX + n_config_type = n_x + else + if( my_n_sparseX(i_config_type) == 0 ) cycle + + n_config_type = count(i_config_type == config_type_ptr) + + allocate(config_type_index(n_config_type),sparseX_index(my_n_sparseX(i_config_type))) + config_type_index = find(i_config_type == config_type_ptr) + + li = ui + 1 + ui = ui + my_n_sparseX(i_config_type) + endif + + select case(my_sparse_method) + case(GP_SPARSE_RANDOM) + call fill_random_integer(sparseX_index, n_config_type) + case(GP_SPARSE_PIVOT) + if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + call pivot(x_ptr(:,config_type_index), sparseX_index) + else + call pivot(x_ptr(:,config_type_index), sparseX_index, theta = this%theta) + endif + case(GP_SPARSE_CLUSTER) + if(use_actual_gpcov) then + call print('Started kernel distance matrix calculation') + dm => kernel_distance_matrix(this, config_type_index = config_type_index) + call print('Finished kernel distance matrix calculation') + endif + call print('Started kmedoids clustering') + if(use_actual_gpcov) then + call bisect_kmedoids(dm, my_n_sparseX(i_config_type), med = sparseX_index) + else + if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + call bisect_kmedoids(x_ptr(:,config_type_index), my_n_sparseX(i_config_type), med = sparseX_index, is_distance_matrix = .false.) + else + call bisect_kmedoids(x_ptr(:,config_type_index), my_n_sparseX(i_config_type), med = sparseX_index, theta = this%theta, is_distance_matrix = .false.) + endif + endif + call print('Finished kmedoids clustering') + if(use_actual_gpcov) deallocate(dm) + case(GP_SPARSE_UNIFORM) + call select_uniform(x_ptr(:,config_type_index), sparseX_index) + case(GP_SPARSE_KMEANS) + call print('Started kmeans clustering') + if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + call cluster_kmeans(x_ptr(:,config_type_index), sparseX_index) + else + call cluster_kmeans(x_ptr(:,config_type_index), sparseX_index, theta = this%theta) + endif + call print('Finished kmeans clustering') + case(GP_SPARSE_COVARIANCE) + call sparse_covariance(this,sparseX_index,config_type_index,use_actual_gpcov) + case(GP_SPARSE_FUZZY) + call print('Started fuzzy cmeans clustering') + if(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + call cluster_fuzzy_cmeans(x_ptr(:,config_type_index), sparseX_index, fuzziness=2.0_dp) + else + call cluster_fuzzy_cmeans(x_ptr(:,config_type_index), sparseX_index, theta=this%theta,fuzziness=2.0_dp) + endif + call print('Finished fuzzy cmeans clustering') + case(GP_SPARSE_CUR_COVARIANCE) + call print("Started covariance matrix calculation") + dm => kernel_distance_matrix(this, config_type_index=config_type_index, covariance_only = .true.) + call print("Finished covariance matrix calculation") + call print("Started CUR decomposition") + call cur_decomposition(dm, sparseX_index) + call print("Finished CUR decomposition") + deallocate(dm) + case(GP_SPARSE_CUR_POINTS) + call print("Started CUR decomposition") + call cur_decomposition(x_ptr(:,config_type_index), sparseX_index) + call print("Finished CUR decomposition") + case default + RAISE_ERROR('gpCoordinates_sparsify: '//my_sparse_method//' method is unknown', error) + endselect + this%sparseX_index(li:ui) = config_type_index(sparseX_index) + deallocate(config_type_index,sparseX_index) + + if(default_all) exit + enddo + + elseif(my_sparse_method == GP_SPARSE_INDEX_FILE) then + call print('Started reading sparse indices from file '//trim(my_sparse_file)) + call fread_array_i(size(this%sparseX_index),this%sparseX_index(1),trim(my_sparse_file)//C_NULL_CHAR) + call print('Finished reading sparse indices from file, '//size(this%sparseX_index)//' of them.') + endif + + call reallocate(this%covarianceDiag_sparseX_sparseX, this%n_sparseX) + + if (my_sparse_method == GP_SPARSE_SKIP) then + ! pass + elseif(my_sparse_method == GP_SPARSE_FILE) then + call print('Started reading sparse descriptors from file '//trim(my_sparse_file)) + allocate(sparseX_array(d+1,this%n_sparseX)) + call fread_array_d(size(sparseX_array),sparseX_array(1,1),trim(my_sparse_file)//C_NULL_CHAR) + this%sparseCutoff = sparseX_array(1,:) + this%sparseX = sparseX_array(2:,:) + this%covarianceDiag_sparseX_sparseX = 1.0_dp ! only used for COVARIANCE_BOND_REAL_SPACE + deallocate(sparseX_array) + call print('Finished reading sparse descriptors from file, '//size(this%sparseCutoff)//' of them.') + else + if(my_sparse_method == GP_SPARSE_NONE) this%sparseX_index = x_index + + call sort_array(this%sparseX_index) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + call reallocate(this%sparseX, maxval(x_size_ptr(this%sparseX_index)), this%n_sparseX) + call reallocate(this%sparseX_size, this%n_sparseX) + this%sparseX(:,:) = x_ptr(1:maxval(x_size_ptr(this%sparseX_index)),this%sparseX_index) + this%sparseX_size = x_size_ptr(this%sparseX_index) + else + this%sparseX(:,:) = x_ptr(:,this%sparseX_index) + endif + + this%covarianceDiag_sparseX_sparseX = covdiag_x_x_ptr(this%sparseX_index) + + this%sparseCutoff = cutoff_ptr(this%sparseX_index) + + if(present(print_sparse_index)) then + if(len_trim(print_sparse_index) > 0) then + call initialise(inout_sparse_index, trim(print_sparse_index), action=OUTPUT, append=.true.) + call print(""//this%sparseX_index,file=inout_sparse_index) + call finalise(inout_sparse_index) + endif + endif + endif + + if (task_manager%active .and. my_sparse_method /= GP_SPARSE_FILE) then + call print("Distributing sparseX after sparsification with MPI.") + call bcast(task_manager%mpi_obj, this%covarianceDiag_sparseX_sparseX, error=error) + call bcast(task_manager%mpi_obj, this%sparseCutoff, error=error) + call bcast(task_manager%mpi_obj, this%sparseX, error=error) + if (allocated(this%sparseX_size)) call bcast(task_manager%mpi_obj, this%sparseX_size, error=error) + + deallocate(config_type_ptr) + deallocate(x_size_ptr) + deallocate(covdiag_x_x_ptr) + deallocate(cutoff_ptr) + deallocate(x_ptr) + end if + + if (allocated(this%config_type)) deallocate(this%config_type) + if (allocated(this%sparseX_index)) deallocate(this%sparseX_index) + this%sparsified = .true. + endsubroutine gpCoordinates_sparsify_config_type + + subroutine exclude_duplicates(x, config_type, unique_descriptor_tolerance, unique_hash_tolerance, error) + real(dp), dimension(:,:), intent(in) :: x + integer, dimension(:), intent(inout) :: config_type + real(dp), intent(in), optional :: unique_descriptor_tolerance, unique_hash_tolerance + integer, intent(out), optional :: error + + integer :: i, j, n_x + real(dp) :: my_unique_hash_tolerance, my_unique_descriptor_tolerance + real(dp) :: max_diff + + integer, dimension(:), allocatable :: x_index + real(dp), dimension(:), allocatable :: x_hash + + INIT_ERROR(error) + + my_unique_hash_tolerance = optional_default(1.0e-10_dp, unique_hash_tolerance) + my_unique_descriptor_tolerance = optional_default(1.0e-10_dp, unique_descriptor_tolerance) + + n_x = count(config_type /= EXCLUDE_CONFIG_TYPE) + allocate(x_hash(n_x)) + allocate(x_index(n_x)) + + ! Compute 1-norm hash on all descriptors that we want to include, and the mapping to the full vector + j = 0 + do i = 1, size(x,2) + if (config_type(i) /= EXCLUDE_CONFIG_TYPE) then + j = j + 1 + x_hash(j) = sum(abs(x(:,i))) + x_index(j) = i + end if + end do + + call heap_sort(x_hash, i_data=x_index) + + ! Compare neighbouring hashes. If they're within tolerance, compare the corresponding descriptors using the eucledian norm. + ! Update the config type if they're equivalent. + do j = 2, n_x + if (abs(x_hash(j-1) - x_hash(j)) < my_unique_hash_tolerance) then + max_diff = maxval(abs(x(:,x_index(j)) - x(:,x_index(j-1)))) + if (max_diff < my_unique_descriptor_tolerance) then + config_type(x_index(j-1)) = EXCLUDE_CONFIG_TYPE + end if + end if + end do + end subroutine exclude_duplicates + + function count_entries_in_sparse_file(sparse_file, sparse_method, d, error) result(res) + character(len=*), intent(in) :: sparse_file + integer, intent(in) :: sparse_method + integer, intent(in) :: d ! coordinate_length + integer, intent(out), optional :: error + integer :: res + + logical :: exist_sparse_file + integer :: n_sparse_file + + INIT_ERROR(error) + + inquire(file=trim(sparse_file), exist=exist_sparse_file) + if (.not. exist_sparse_file) then + RAISE_ERROR('count_entries_in_sparse_file: "'//trim(sparse_file)//'" does not exist', error) + end if + + call fwc_l(trim(sparse_file)//C_NULL_CHAR, n_sparse_file) + + select case (sparse_method) + case (GP_SPARSE_INDEX_FILE) + res = n_sparse_file + case (GP_SPARSE_FILE) + if (mod(n_sparse_file, d+1) /= 0) then + RAISE_ERROR('count_entries_in_sparse_file: file '//trim(sparse_file)//' contains '//n_sparse_file//" lines, not conforming with descriptor size "//d, error) + end if + res = n_sparse_file / (d + 1) + case default + RAISE_ERROR('count_entries_in_sparse_file: given sparse_method is not implemented: '//sparse_method, error) + end select + end function count_entries_in_sparse_file + + subroutine gpFull_sparsify_array_config_type(this, n_sparseX, default_all, task_manager, sparse_method, sparse_file, & + use_actual_gpcov, print_sparse_index, unique_hash_tolerance, unique_descriptor_tolerance, error) + type(gpFull), intent(inout) :: this + integer, dimension(:,:), intent(in) :: n_sparseX + logical, dimension(:), intent(in) :: default_all + type(task_manager_type), intent(in) :: task_manager + integer, dimension(:), intent(in), optional :: sparse_method + character(len=STRING_LENGTH), dimension(:), intent(in), optional :: sparse_file, print_sparse_index + logical, intent(in), optional :: use_actual_gpcov + real(dp), dimension(:), intent(in), optional :: unique_hash_tolerance, unique_descriptor_tolerance + integer, intent(out), optional :: error + + integer :: i + integer, dimension(:), allocatable :: my_sparse_method + character(len=STRING_LENGTH), dimension(:), allocatable :: my_sparse_file + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_sparsify_array: object not initialised',error) + endif + + allocate(my_sparse_method(this%n_coordinate)) + allocate(my_sparse_file(this%n_coordinate)) + my_sparse_method = optional_default((/ (GP_SPARSE_RANDOM, i=1,this%n_coordinate) /),sparse_method) + my_sparse_file = optional_default((/ ("", i=1,this%n_coordinate) /),sparse_file) + + do i = 1, this%n_coordinate + call gpCoordinates_sparsify_config_type(this%coordinate(i), n_sparseX(:,i), default_all(i), task_manager, & + sparse_method=my_sparse_method(i), sparse_file=my_sparse_file(i), use_actual_gpcov=use_actual_gpcov, & + print_sparse_index=print_sparse_index(i), unique_hash_tolerance=unique_hash_tolerance(i), & + unique_descriptor_tolerance=unique_descriptor_tolerance(i), error=error) + enddo + endsubroutine gpFull_sparsify_array_config_type + + function kernel_distance_matrix(this, config_type_index, covariance_only) result(k_nn) + type(gpCoordinates), intent(in) :: this + integer, dimension(:), intent(in), optional :: config_type_index + logical, intent(in), optional :: covariance_only + + real(dp), pointer, dimension(:,:) :: k_nn ! actually the kernel distance matrix + + !real(dp), dimension(:,:), allocatable :: k_nn + real(dp), dimension(:), allocatable :: k_self + logical :: do_kernel_distance + integer :: i, j, n, ii, jj + integer :: stat + + call system_timer('kernel_distance_matrix') + + do_kernel_distance = .not. optional_default(.false., covariance_only) + + if(present(config_type_index)) then + n = size(config_type_index) + else + n = size(this%x,2) + endif + + allocate(k_self(n)) + + allocate(k_nn(n,n), stat=stat) + if(stat /= 0) call system_abort('kernel_distance_matrix: could not allocate matrix.') + +!$omp parallel do default(none) shared(this,n,config_type_index,k_self) private(i,ii) + do i = 1, n + if(present(config_type_index)) then + ii = config_type_index(i) + else + ii = i + endif + + k_self(i) = gpCoordinates_Covariance(this, i_x = ii, j_x = ii, normalise = .false.) + enddo + + do j = 1, n + if(present(config_type_index)) then + jj = config_type_index(j) + else + jj = j + endif + + !k_nn(j,j) = 1.0_dp ! normalised kernel self-covariance + k_nn(j,j) = 0.0_dp ! distance to itself = 0 + +!$omp parallel do default(none) shared(n,this,k_nn,jj,j,k_self,config_type_index,do_kernel_distance) private(i,ii) + do i = j+1, n + if(present(config_type_index)) then + ii = config_type_index(i) + else + ii = i + endif + + ! kernel covariance + k_nn(j,i) = gpCoordinates_Covariance(this, i_x = ii, j_x = jj, normalise = .false.) + ! then normalise + k_nn(j,i) = k_nn(j,i) / sqrt(k_self(i)*k_self(j)) + + if (do_kernel_distance) then + ! now convert to distance + k_nn(j,i) = sqrt(2.0_dp * (1.0_dp - k_nn(j,i))) + endif + + ! finally, symmetrise + k_nn(i,j) = k_nn(j,i) + enddo ! i + enddo ! j + + !dm = sqrt(2.0_dp * (1.0_dp - k_nn)) + !do i = 1, n + ! do j = i+1, n + ! dm(i,j) = sqrt(2.0_dp*(1.0_dp - kij)) + ! dm(j,i) = dm(i,j) + ! end do + !end do + + !deallocate(k_nn, k_self) + deallocate(k_self) + call system_timer('kernel_distance_matrix') + end function kernel_distance_matrix + + subroutine sparse_covariance(this, index_out, config_type_index, use_actual_gpcov) + type(gpCoordinates), intent(in) :: this + integer, dimension(:), intent(out) :: index_out + integer, dimension(:), intent(in), optional :: config_type_index + logical, intent(in), optional :: use_actual_gpcov + + real(dp), dimension(:), allocatable :: score, k_self !, xI_xJ + real(dp), dimension(:,:), allocatable :: k_mn, k_mm_k_m + real(dp), dimension(1,1) :: k_mm + integer :: m, n, i, ii, j, jj, i_p, zeta_int + integer, dimension(1) :: j_loc + logical, dimension(:), allocatable :: not_yet_added + logical :: do_use_actual_gpcov + + type(LA_Matrix) :: LA_k_mm + + call system_timer('sparse_covariance') + if(present(config_type_index)) then + n = size(config_type_index) + else + n = size(this%x,2) + endif + m = size(index_out) + + do_use_actual_gpcov = optional_default(.false., use_actual_gpcov) + if(do_use_actual_gpcov) then + call print("sparse_covariance using actual gpCoordinates_Covariance") + else + call print("sparse_covariance using manual 'covariance'") + endif + + allocate(k_mn(m,n), score(n), k_mm_k_m(m,n), k_self(n), not_yet_added(n)) + k_mn = 0.0_dp + not_yet_added = .true. + + !allocate(xI_xJ(this%d)) + + j = 1 + index_out(j) = 1 !ceiling(ran_uniform() * n) + not_yet_added(index_out(j)) = .false. + + k_mm = 1.0_dp+1.0e-6_dp + zeta_int = nint(this%zeta) + call initialise(LA_k_mm,k_mm) + +!$omp parallel do default(none) shared(this,n,config_type_index,k_self,do_use_actual_gpcov,zeta_int) private(i,ii,i_p) + do i = 1, n + if(present(config_type_index)) then + ii = config_type_index(i) + else + ii = i + endif + + if(do_use_actual_gpcov) then + k_self(i) = gpCoordinates_Covariance(this, i_x = ii, j_x = ii, normalise = .false.) + else + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + if( zeta_int .feq. this%zeta ) then + k_self(i) = dot_product( this%x(:,ii), this%x(:,ii) )**zeta_int + else + k_self(i) = dot_product( this%x(:,ii), this%x(:,ii) )**this%zeta + endif + elseif( this%covariance_type == COVARIANCE_ARD_SE ) then + k_self(i) = 0.0_dp + do i_p = 1, this%n_permutations + !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp + k_self(i) = k_self(i) + exp( -0.5_dp * sum((this%x(this%permutations(:,i_p),ii) - this%x(:,ii))**2) / 16.0_dp ) + enddo + elseif( this%covariance_type == COVARIANCE_PP ) then + k_self(i) = 0.0_dp + do i_p = 1, this%n_permutations + !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp + k_self(i) = k_self(i) + covariancePP( sqrt( sum((this%x(this%permutations(:,i_p),ii) - this%x(:,ii))**2) ) / 4.0_dp, PP_Q, this%d) + enddo + endif + endif + enddo + + do j = 1, m-1 + + if(present(config_type_index)) then + jj = config_type_index(index_out(j)) + else + jj = index_out(j) + endif + +!$omp parallel do default(none) shared(n,this,k_mn,jj,j,LA_k_mm,k_mm_k_m,score,k_self,config_type_index,index_out,do_use_actual_gpcov,zeta_int) private(i,i_p,ii) + do i = 1, n + + if(present(config_type_index)) then + ii = config_type_index(i) + else + ii = i + endif + if(do_use_actual_gpcov) then + k_mn(j,i) = gpCoordinates_Covariance(this, i_x = ii, j_x = jj, normalise = .false.) + else + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + if( zeta_int .feq. this%zeta ) then + k_mn(j,i) = dot_product( this%x(:,ii), this%x(:,jj) )**zeta_int + else + k_mn(j,i) = dot_product( this%x(:,ii), this%x(:,jj) )**this%zeta + endif + elseif( this%covariance_type == COVARIANCE_ARD_SE ) then + k_mn(j,i) = 0.0_dp + do i_p = 1, this%n_permutations + !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp + k_mn(j,i) = k_mn(j,i) + exp( -0.5_dp * sum((this%x(this%permutations(:,i_p),ii) - this%x(:,jj))**2) / 16.0_dp ) + enddo + elseif( this%covariance_type == COVARIANCE_PP ) then + k_mn(j,i) = 0.0_dp + do i_p = 1, this%n_permutations + !xI_xJ = (this%x(this%permutations(:,i_p),i) - this%x(:,j)) / 4.0_dp + k_mn(j,i) = k_mn(j,i) + covariancePP( sqrt( sum((this%x(this%permutations(:,i_p),ii) - this%x(:,jj))**2) ) / 4.0_dp, PP_Q, this%d) + enddo + endif + endif + k_mn(j,i) = k_mn(j,i) / sqrt(k_self(i)*k_self(index_out(j))) + + call Matrix_Solve(LA_k_mm,k_mn(1:j,i),k_mm_k_m(1:j,i)) + score(i) = sum( k_mn(1:j,i) * k_mm_k_m(1:j,i) ) + enddo + + j_loc = minloc(score, mask=not_yet_added) + jj = j_loc(1) + index_out(j+1) = jj + not_yet_added(jj) = .false. + + if(j == 1) then + call print('Initial score: '//score) + endif + call print('Min score: '//minval(score)) + + !k_mm(1:j_i,j_i+1) = k_mn(1:j_i,j) + !k_mm(j_i+1,1:j_i) = k_mn(1:j_i,j) + !k_mm(j_i+1,j_i+1) = 1.0_dp + call LA_Matrix_Expand_Symmetrically(LA_k_mm,(/k_mn(1:j,jj),1.0_dp+1.0e-6_dp/)) + !call initialise(LA_k_mm,k_mm(1:j_i+1,1:j_i+1)) + + enddo + call print('Final score: '//score) + call print('Min score: '//minval(score)) + + deallocate(k_mn, score, k_mm_k_m, k_self, not_yet_added) + !if(allocated(xI_xJ)) deallocate(xI_xJ) + call finalise(LA_k_mm) + call system_timer('sparse_covariance') + + endsubroutine sparse_covariance + +end module gp_fit_module diff --git a/gp_predict.F90 b/gp_predict.F90 new file mode 100644 index 00000000..37b826f1 --- /dev/null +++ b/gp_predict.F90 @@ -0,0 +1,5290 @@ +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! HND X +! HND X GAP (Gaussian Approximation Potental) +! HND X +! HND X +! HND X Portions of GAP were written by Albert Bartok-Partay, Gabor Csanyi, +! HND X and Sascha Klawohn. Copyright 2006-2021. +! HND X +! HND X Portions of GAP were written by Noam Bernstein as part of +! HND X his employment for the U.S. Government, and are not subject +! HND X to copyright in the USA. +! HND X +! HND X GAP is published and distributed under the +! HND X Academic Software License v1.0 (ASL) +! HND X +! HND X GAP is distributed in the hope that it will be useful for non-commercial +! HND X academic research, but WITHOUT ANY WARRANTY; without even the implied +! HND X warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! HND X ASL for more details. +! HND X +! HND X You should have received a copy of the ASL along with this program +! HND X (e.g. in a LICENSE.md file); if not, you can write to the original licensors, +! HND X Gabor Csanyi or Albert Bartok-Partay. The ASL is also published at +! HND X http://github.com/gabor1/ASL +! HND X +! HND X When using this software, please cite the following reference: +! HND X +! HND X A. P. Bartok et al Physical Review Letters vol 104 p136403 (2010) +! HND X +! HND X When using the SOAP kernel or its variants, please additionally cite: +! HND X +! HND X A. P. Bartok et al Physical Review B vol 87 p184115 (2013) +! HND X +! HND XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Gaussian Process module +!X +!% Module for general GP function interpolations. +!% A gp object contains the training set (fitting points and function values), +!% important temporary matrices, vectors and parameters. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module gp_predict_module + + use iso_c_binding, only : C_NULL_CHAR + ! use libatoms_module + use error_module +#ifdef _OPENMP + use omp_lib +#endif + use system_module, only : idp, dp, qp, optional_default, reallocate, NUMERICAL_ZERO, & + system_timer, string_to_numerical, print_warning, progress, progress_timer, & + current_times, InOutput, OUTPUT, increase_to_multiple, i2si, PRINT_VERBOSE + use units_module + use linearalgebra_module + use extendable_str_module + use dictionary_module + use paramreader_module + use descriptors_module + use fox_wxml + use FoX_sax, only: xml_t, dictionary_t, haskey, getvalue, parse, & + open_xml_string, close_xml_t + use CInOutput_module, only : quip_md5sum + use task_manager_module + use matrix_module + use MPI_context_module, only : scatterv + + implicit none + + private + + integer, parameter :: besseli_max_n = 20 + + real(dp), dimension(besseli_max_n), parameter :: besseli0_c = (/ & + 0.125_dp, & + 7.03125E-002_dp, & + 7.32421875E-002_dp, & + 0.112152099609375_dp, & + 0.22710800170898438_dp, & + 0.57250142097473145_dp, & + 1.7277275025844574_dp, & + 6.0740420012734830_dp, & + 24.380529699556064_dp, & + 110.01714026924674_dp, & + 551.33589612202059_dp, & + 3038.0905109223841_dp, & + 18257.755474293175_dp, & + 118838.42625678326_dp, & + 832859.30401628942_dp, & + 6252951.4934347980_dp, & + 50069589.531988934_dp, & + 425939216.50476694_dp, & + 3836255180.2304339_dp, & + 36468400807.065559_dp /) + + real(dp), dimension(besseli_max_n), parameter :: besseli1_c = (/ & + -0.375_dp, & + -0.1171875_dp, & + -0.1025390625_dp, & + -0.144195556640625_dp, & + -0.27757644653320313_dp, & + -0.67659258842468262_dp, & + -1.9935317337512970_dp, & + -6.8839142681099474_dp, & + -27.248827311268542_dp, & + -121.59789187653587_dp, & + -603.84407670507017_dp, & + -3302.2722944808525_dp, & + -19718.375912236628_dp, & + -127641.27264617461_dp, & + -890297.87670706783_dp, & + -6656367.7188176867_dp, & + -53104110.109685220_dp, & + -450278600.30503929_dp, & + -4043620325.1077542_dp, & + -38338575207.427895_dp /) + + real(dp), parameter :: besseli_max_x = 18.0_dp + + real(dp), parameter :: THETA_MIN = 1.0e-8_dp + integer, parameter, public :: GP_SPARSE_RANDOM = 1 + integer, parameter, public :: GP_SPARSE_PIVOT = 2 + integer, parameter, public :: GP_SPARSE_CLUSTER = 3 + integer, parameter, public :: GP_SPARSE_UNIFORM = 4 + integer, parameter, public :: GP_SPARSE_KMEANS = 5 + integer, parameter, public :: GP_SPARSE_COVARIANCE = 6 + integer, parameter, public :: GP_SPARSE_UNIQ = 7 + integer, parameter, public :: GP_SPARSE_FUZZY = 8 + integer, parameter, public :: GP_SPARSE_FILE = 9 + integer, parameter, public :: GP_SPARSE_INDEX_FILE = 10 + integer, parameter, public :: GP_SPARSE_CUR_COVARIANCE = 11 + integer, parameter, public :: GP_SPARSE_CUR_POINTS = 12 + integer, parameter, public :: GP_SPARSE_NONE = 13 + integer, parameter, public :: GP_SPARSE_SKIP = 99 ! internal use for MPI + + integer, parameter, public :: COVARIANCE_NONE = 0 + integer, parameter, public :: COVARIANCE_ARD_SE = 1 + integer, parameter, public :: COVARIANCE_DOT_PRODUCT = 2 + integer, parameter, public :: COVARIANCE_BOND_REAL_SPACE = 3 + integer, parameter, public :: COVARIANCE_PP = 4 + + integer, parameter, public :: PP_Q = 1 + + ! loop iterations per OpenMP thread, 0: each thread gets a single block of similar size + integer, public, save :: openmp_chunk_size = 0 + + type gpCovariance_bond_real_space + + integer :: n + real(dp) :: delta + real(dp) :: atom_sigma + + logical :: initialised = .false. + + endtype gpCovariance_bond_real_space + + type gpCovariance_atom_real_space + + integer :: l_max = 0 + real(dp) :: atom_sigma, delta, zeta + real(dp) :: cutoff, cutoff_transition_width + + logical :: initialised = .false. + + endtype gpCovariance_atom_real_space + + public :: gpCovariance_bond_real_space + public :: gpCovariance_bond_real_space_Calc + public :: gpCoordinates_gpCovariance_bond_real_space_Initialise + + public :: gpCovariance_atom_real_space + public :: gpCovariance_atom_real_space_Calc + + type gpCoordinates + + integer :: d = 0, n_x, n_xPrime, n_sparseX, n_permutations + ! dimension of descriptors, number of descriptors, number of derivatives of descriptors + + integer :: current_x, current_xPrime + ! pointers to the last added values + + real(dp), dimension(:,:), allocatable :: x, xPrime + ! descriptors (d,n_x), derivatives of descriptors (d, n_xPrime) + ! for real space covariance descriptors (max(x_size),n_x), derivatives of descriptors (max(x_size),n_xPrime) + real(dp), dimension(:), allocatable :: cutoff, cutoffPrime + integer, dimension(:), allocatable :: x_size, xPrime_size + real(dp), dimension(:), allocatable :: covarianceDiag_x_x, covarianceDiag_xPrime_xPrime + + real(dp), dimension(:,:), allocatable :: sparseX, covarianceDiag_x_xPrime + real(dp), dimension(:), allocatable :: sparseCutoff + ! sparse points stored as real array + ! for real space covariance descriptors + integer, dimension(:), allocatable :: sparseX_size + real(dp), dimension(:), allocatable :: covarianceDiag_sparseX_sparseX + + real(dp), dimension(:,:,:), allocatable :: sparseX_permuted + real(dp), dimension(:), allocatable :: sparseCovariance + + real(dp), dimension(:), allocatable :: theta + ! range parameters (d) for descriptors in each directions + real(dp) :: zeta = 0.0_dp + + real(dp), dimension(:), allocatable :: alpha + ! + + real(dp) :: delta, f0 = 0.0_dp, variance_estimate_regularisation = 0.0_dp + ! range of GP (function value) and baseline of function + + integer, dimension(:), allocatable :: map_x_y, map_xPrime_yPrime, map_xPrime_x, config_type + ! which descriptor is used for a given function value, which derivative descriptor is used for a given derivative function, which descriptor is differentiated + + integer, dimension(:), allocatable :: map_sparseX_globalSparseX + ! sparse point in this descriptor type -> all sparse points in gpFull + + integer, dimension(:), allocatable :: sparseX_index + ! sparse points stored as indices of the x array + + integer, dimension(:,:), allocatable :: permutations + ! Lists the permutations symmetries of the coordinates + logical, dimension(:,:), allocatable :: permutation_distance_mask + ! pairwise distances that may occur given all permutations + + type(gpCovariance_bond_real_space) :: bond_real_space_cov + integer :: covariance_type = COVARIANCE_NONE + + type(extendable_str) :: descriptor_str + + type(LA_Matrix) :: LA_k_mm + + logical :: initialised = .false. + logical :: sparsified = .false. + logical :: variance_estimate_initialised = .false. + logical :: sparse_covariance_initialised = .false. + + endtype gpCoordinates + + public :: gpCoordinates + + type gpFull + + integer :: n_y, n_yPrime + ! number of function values, number of derivative function values + + integer :: n_globalSparseX + ! number of all sparse points in every descriptor type + + integer :: n_coordinate + ! number of different descriptors + + integer :: current_y, current_yPrime + + real(dp) :: sparse_jitter = 1.0e-5_dp + + real(dp), dimension(:), allocatable :: y, yPrime + ! function values, derivative function values + + real(dp), dimension(:), allocatable :: sigma_y, sigma_yPrime + ! estimated error of function values, derivatives + + real(dp), dimension(:,:), allocatable :: covariance_subY_y, covariance_subY_subY, covariance_y_y + ! covariance matrix + + real(dp), dimension(:), allocatable :: covarianceDiag_y_y, lambda, alpha + ! covariance matrix + + integer, dimension(:), allocatable :: map_y_globalY, map_yPrime_globalY + + type(gpCoordinates), dimension(:), allocatable :: coordinate + + logical :: do_subY_subY = .true. + + logical :: initialised = .false. + + endtype gpFull + + type gpSparse + integer :: n_coordinate ! number of different descriptors + type(gpCoordinates), dimension(:), allocatable :: coordinate + logical :: initialised = .false. + logical :: fitted = .false. + logical :: do_export_R = .false. + real(dp), dimension(:, :), allocatable :: R + endtype gpSparse + + type cplx_1d_array + complex(dp), dimension(:), allocatable :: value + endtype cplx_1d_array + + type cplx_2d_array + complex(dp), dimension(:,:), allocatable :: value + endtype cplx_2d_array + + type neighbour_descriptor + type(cplx_1d_array), dimension(:), allocatable :: spherical_harmonics + real(dp) :: r + integer :: n + endtype neighbour_descriptor + + logical, save :: parse_matched_label, parse_in_gpCoordinates, parse_in_gpFull, parse_in_gpSparse, parse_in_sparseX, parse_sliced, parse_sparseX_separate_file + integer, save :: parse_i_sparseX, parse_i_x, parse_i_xPrime, parse_i_permutation, parse_slice_start, parse_slice_end + type(gpCoordinates), pointer :: parse_gpCoordinates + type(gpFull), pointer :: parse_gpFull + type(gpSparse), pointer :: parse_gpSparse + type(extendable_str), save :: parse_cur_data + integer, dimension(:,:), allocatable :: parse_in_permutations + character(len=1024), save :: parse_gpCoordinates_label, parse_gpFull_label, parse_gpSparse_label + + public :: gpFull, gpSparse + public :: gpFull_print_covariances_lambda_globalY + public :: gpSparse_fit + + interface initialise + module procedure gpSparse_initialise + endinterface initialise + public :: initialise + + interface finalise + module procedure gpFull_Finalise, gpCoordinates_Finalise, gpSparse_finalise, gpNeighbourDescriptor_Finalise + endinterface finalise + public :: finalise + + interface gp_setTheta + module procedure gpCoordinates_setTheta, gpFull_setTheta + endinterface gp_setTheta + public :: gp_setTheta + + interface gp_setThetaFactor + module procedure gpFull_setTheta_thetaFactor !, gpFull_setTheta_thetaFactorArray, gpFull_setTheta_thetaFactorUniform + endinterface gp_setThetaFactor + public :: gp_setThetaFactor + + interface gp_setParameters + module procedure gpFull_setParameters, gpFull_gpCoordinates_setParameters, gpCoordinates_setParameters, & + gpCoordinates_setParameters_sparse, gpSparse_setParameters + endinterface gp_setParameters + public :: gp_setParameters + + interface gp_setPermutations + module procedure gpCoordinates_setPermutations, gpFull_setPermutations, gpSparse_setPermutations + endinterface gp_setPermutations + public :: gp_setPermutations + + interface gp_addFunctionValue + module procedure gpFull_addFunctionValue + endinterface gp_addFunctionValue + public :: gp_addFunctionValue + + interface gp_addFunctionDerivative + module procedure gpFull_addFunctionDerivative + endinterface gp_addFunctionDerivative + public :: gp_addFunctionDerivative + + interface gp_addCoordinates + module procedure gpFull_addCoordinates_1Darray, gpFull_addCoordinates_2Darray + endinterface gp_addCoordinates + public :: gp_addCoordinates + + interface gp_addCoordinateDerivatives + module procedure gpFull_addCoordinateDerivatives_1Darray, gpFull_addCoordinateDerivatives_2Darray + endinterface gp_addCoordinateDerivatives + public :: gp_addCoordinateDerivatives + + interface gp_addDescriptor + module procedure gpFull_addDescriptor + endinterface gp_addDescriptor + public :: gp_addDescriptor + + interface gp_printXML + module procedure gpCoordinates_printXML, gpFull_printXML, gpSparse_printXML + endinterface gp_PrintXML + public :: gp_printXML + + interface gp_readXML + module procedure gpCoordinates_readXML, gpFull_readXML, gpSparse_readXML, & + gpCoordinates_readXML_string, gpFull_readXML_string, gpSparse_readXML_string + endinterface gp_readXML + public :: gp_readXML + + interface gp_covariance_sparse + module procedure gpFull_covarianceMatrix_sparse + endinterface gp_covariance_sparse + public :: gp_covariance_sparse + + interface gp_covariance_full + module procedure gpFull_covarianceMatrix + endinterface gp_covariance_full + public :: gp_covariance_full + + interface gp_Predict + module procedure gpCoordinates_Predict + endinterface gp_Predict + public :: gp_Predict + + interface gp_log_likelihood + module procedure gpCoordinates_log_likelihood + endinterface gp_log_likelihood + public :: gp_log_likelihood + + public :: gpCoordinates_Covariance + public :: gpCoordinates_initialise_variance_estimate + public :: covariancePP + + public :: gp_write_covariance + + contains + +#ifdef _OPENMP + function get_chunk_size(n) result(res) + integer, intent(in) :: n + integer :: res + integer :: t + + if (openmp_chunk_size == 0) then + ! We can't emulate OpenMP default exactly, so we use ceil(n / t) + t = omp_get_num_threads() + res = (n + t - 1) / t + else + res = openmp_chunk_size + end if + end function get_chunk_size +#endif + + subroutine gpFull_setParameters(this, n_coordinate, n_y, n_yPrime, sparse_jitter, error) + + type(gpFull), intent(inout) :: this + integer, intent(in) :: n_coordinate, n_y, n_yPrime + real(dp), intent(in) :: sparse_jitter + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(this%initialised) call finalise(this,error) + + this%n_coordinate = n_coordinate + this%n_y = n_y + this%n_yPrime = n_yPrime + this%current_y = 0 + this%current_yPrime = 0 + this%sparse_jitter = sparse_jitter + + allocate( this%coordinate(n_coordinate) ) + allocate( this%y(n_y), this%yPrime(n_yPrime) ) + allocate( this%map_y_globalY(n_y), this%map_yPrime_globalY(n_yPrime) ) + allocate( this%sigma_y(n_y), this%sigma_yPrime(n_yPrime) ) + + this%initialised = .true. + + endsubroutine gpFull_setParameters + + subroutine gpFull_gpCoordinates_setParameters(this, i, d, n_x, n_xPrime, delta, f0, covariance_type, x_size_max, xPrime_size_max, error) + + type(gpFull), intent(inout) :: this + integer, intent(in) :: i, d, n_x, n_xPrime + real(dp), intent(in) :: delta, f0 + integer, optional, intent(in) :: covariance_type + integer, optional, intent(in) :: x_size_max, xPrime_size_max + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_set_gpCoordinates_parameters: object not initialised',error) + endif + + if( i > this%n_coordinate ) then + RAISE_ERROR( 'gpFull_set_gpCoordinates_parameters: access to descriptor '//i//' is not possible as number of descriptors is '//this%n_coordinate,error ) + endif + + call gpCoordinates_setParameters(this%coordinate(i), d, n_x, n_xPrime, delta, f0, covariance_type = covariance_type, x_size_max=x_size_max, xPrime_size_max=xPrime_size_max, error=error) + + endsubroutine gpFull_gpCoordinates_setParameters + + subroutine gpCoordinates_setParameters(this, d, n_x, n_xPrime, delta, f0, covariance_type, x_size_max, xPrime_size_max, error) + + type(gpCoordinates), intent(inout) :: this + integer, intent(in) :: d, n_x, n_xPrime + real(dp), intent(in) :: delta, f0 + integer, optional, intent(in) :: covariance_type + integer, optional, intent(in) :: x_size_max, xPrime_size_max + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(this%initialised) call finalise(this,error) + + if( d < 0 ) then + RAISE_ERROR("gpCoordinates_setParameters: negative value of d = "//d,error) + else + this%d = d + endif + + if( n_x < 0 ) then + RAISE_ERROR("gpCoordinates_setParameters: negative value of n_x = "//n_x,error) + else + this%n_x = n_x + endif + + if( n_xPrime < 0 ) then + RAISE_ERROR("gpCoordinates_setParameters: negative value of n_xPrime = "//n_xPrime,error) + else + this%n_xPrime = n_xPrime + endif + + this%delta = delta + this%f0 = f0 + + this%current_x = 0 + this%current_xPrime = 0 + this%n_sparseX = 0 + this%n_permutations = 1 + + this%covariance_type = optional_default(COVARIANCE_ARD_SE, covariance_type) + + if(present(x_size_max)) then + allocate( this%x(x_size_max,n_x) ) + else + allocate( this%x(d,n_x) ) + endif + this%x = 0.0_dp + + if(present(xPrime_size_max)) then + allocate( this%xPrime(xPrime_size_max,n_xPrime) ) + else + allocate( this%xPrime(d,n_xPrime) ) + endif + this%xPrime = 0.0_dp + + allocate(this%cutoff(n_x)) + this%cutoff = 1.0_dp + allocate(this%cutoffPrime(n_xPrime)) + this%cutoffPrime = 0.0_dp + + allocate( this%config_type(n_x) ) + this%config_type = 0 + + allocate( this%map_x_y(n_x), this%map_xPrime_yPrime(n_xPrime), this%map_xPrime_x(n_xPrime) ) + this%map_x_y = 0 + this%map_xPrime_yPrime = 0 + this%map_xPrime_x = 0 + + allocate(this%covarianceDiag_x_x(n_x), this%covarianceDiag_xPrime_xPrime(n_xPrime)) + this%covarianceDiag_x_x = 1.0_dp + this%covarianceDiag_xPrime_xPrime = 1.0_dp + + select case(this%covariance_type) + case(COVARIANCE_BOND_REAL_SPACE) + allocate( this%x_size(n_x), this%xPrime_size(n_xPrime) ) + this%x_size = d + this%xPrime_size = 0 + allocate( this%theta(1), this%permutations(1,1) ) + this%theta = 0.0_dp + this%permutations = 1 + case(COVARIANCE_DOT_PRODUCT) + allocate( this%theta(1), this%permutations(1,1) ) + this%theta = 0.0_dp + this%permutations = 1 + case(COVARIANCE_ARD_SE,COVARIANCE_PP) + allocate( this%theta(d), this%permutations(d,1) ) + this%theta = 0.0_dp + this%permutations(:,1) = (/ (i, i=1, d) /) + + allocate(this%permutation_distance_mask(this%d,this%d)) + this%permutation_distance_mask = .false. + forall(i=1:this%d) this%permutation_distance_mask(i,i) = .true. + endselect + + this%sparsified = .false. + this%initialised = .true. + endsubroutine gpCoordinates_setParameters + + subroutine gpCoordinates_setParameters_sparse(this, d, n_sparseX, delta, f0, covariance_type, sparseX_size_max, error) + + type(gpCoordinates), intent(inout) :: this + integer, intent(in) :: d, n_sparseX + real(dp), intent(in) :: delta, f0 + integer, optional, intent(in) :: covariance_type + integer, optional, intent(in) :: sparseX_size_max + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(this%initialised) call finalise(this,error) + + this%d = d + this%n_x = 0 + this%n_xPrime = 0 + this%delta = delta + this%f0 = f0 + + this%current_x = 0 + this%current_xPrime = 0 + this%n_sparseX = n_sparseX + this%n_permutations = 1 + + this%covariance_type = optional_default(COVARIANCE_ARD_SE, covariance_type) + + if(present(sparseX_size_max)) then + allocate( this%sparseX(sparseX_size_max,n_sparseX) ) + else + allocate( this%sparseX(d,n_sparseX) ) + endif + + allocate( this%alpha(n_sparseX) ) + allocate( this%sparseCutoff(n_sparseX) ) + + allocate( this%covarianceDiag_sparseX_sparseX(n_sparseX) ) + this%covarianceDiag_sparseX_sparseX = 1.0_dp + + select case(this%covariance_type) + case(COVARIANCE_BOND_REAL_SPACE) + allocate( this%sparseX_size(n_sparseX) ) + this%sparseX_size = d + allocate( this%theta(1), this%permutations(1,1) ) + this%theta = 0.0_dp + this%permutations = 1 + case(COVARIANCE_DOT_PRODUCT) + allocate( this%theta(1), this%permutations(1,1) ) + this%theta = 0.0_dp + this%permutations = 1 + case(COVARIANCE_ARD_SE,COVARIANCE_PP) + allocate( this%theta(d), this%permutations(d,1) ) + this%theta = 0.0_dp + this%permutations(:,1) = (/ (i, i=1, d) /) + allocate(this%permutation_distance_mask(this%d,this%d)) + this%permutation_distance_mask = .false. + forall(i=1:this%d) this%permutation_distance_mask(i,i) = .true. + endselect + + this%sparsified = .true. + this%initialised = .true. + + endsubroutine gpCoordinates_setParameters_sparse + + subroutine gpSparse_setParameters(this,n_coordinate,error) + type(gpSparse), intent(inout) :: this + integer, intent(in) :: n_coordinate + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(this%initialised) call finalise(this,error) + this%n_coordinate = n_coordinate + allocate( this%coordinate(this%n_coordinate) ) + + endsubroutine gpSparse_setParameters + + subroutine gpCoordinates_setPermutations(this,permutations,error) + type(gpCoordinates), intent(inout) :: this + integer, dimension(:,:), intent(in) :: permutations + integer, optional, intent(out) :: error + + real(dp), dimension(this%d) :: theta + integer :: i, d + + INIT_ERROR(error) + + this%n_permutations = size(permutations,2) + + select case(this%covariance_type) + case(COVARIANCE_ARD_SE,COVARIANCE_PP) + call reallocate(this%permutations,this%d,this%n_permutations,zero=.true.) + this%permutations = permutations + ! Symmetrise theta wrt permutations + theta = this%theta + this%theta = 0.0_dp + do i = 1, this%n_permutations + this%theta = this%theta + theta(this%permutations(:,i)) + enddo + this%theta = this%theta / real(this%n_permutations,kind=dp) + + this%permutation_distance_mask = .false. + do i = 1, this%n_permutations + do d = 1, this%d + this%permutation_distance_mask(d,this%permutations(d,i)) = .true. + enddo + enddo + case default + + endselect + + + endsubroutine gpCoordinates_setPermutations + + subroutine gpFull_setPermutations(this,i_coordinate,permutations,error) + type(gpFull), intent(inout) :: this + integer :: i_coordinate + integer, dimension(:,:), intent(in) :: permutations + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( i_coordinate > this%n_coordinate ) then + RAISE_ERROR( 'gpFull_setPermutations: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate,error ) + endif + + call gpCoordinates_setPermutations(this%coordinate(i_coordinate),permutations,error) + + endsubroutine gpFull_setPermutations + + subroutine gpSparse_setPermutations(this,i_coordinate,permutations,error) + type(gpSparse), intent(inout) :: this + integer :: i_coordinate + integer, dimension(:,:), intent(in) :: permutations + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( i_coordinate > this%n_coordinate ) then + RAISE_ERROR( 'gpSparse_setPermutations: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate,error ) + endif + + call gpCoordinates_setPermutations(this%coordinate(i_coordinate),permutations,error) + + endsubroutine gpSparse_setPermutations + + subroutine gpSparse_initialise(this, from, error) + type(gpSparse), intent(inout) :: this + type(gpFull), intent(in) :: from + integer, optional, intent(out) :: error + + integer :: i + + if( .not. from%initialised ) then + RAISE_ERROR('gpSparse_initialise: gpFull object not initialised',error) + endif + + if(this%initialised) call finalise(this,error) + + call gpSparse_setParameters(this, from%n_coordinate) + + do i = 1, this%n_coordinate + if( from%coordinate(i)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call gpCoordinates_setParameters_sparse(this%coordinate(i), & + from%coordinate(i)%d, from%coordinate(i)%n_sparseX, from%coordinate(i)%delta, from%coordinate(i)%f0, covariance_type = from%coordinate(i)%covariance_type, & + sparseX_size_max=maxval(from%coordinate(i)%sparseX_size), error=error) + else + call gpCoordinates_setParameters_sparse(this%coordinate(i), & + from%coordinate(i)%d, from%coordinate(i)%n_sparseX, from%coordinate(i)%delta, from%coordinate(i)%f0, covariance_type = from%coordinate(i)%covariance_type, & + error=error) + endif + + this%coordinate(i)%alpha = 0.0 + this%coordinate(i)%sparseX = from%coordinate(i)%sparseX + this%coordinate(i)%covarianceDiag_sparseX_sparseX = from%coordinate(i)%covarianceDiag_sparseX_sparseX + + if(from%coordinate(i)%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + this%coordinate(i)%sparseX_size = from%coordinate(i)%sparseX_size + endif + + this%coordinate(i)%theta = from%coordinate(i)%theta + this%coordinate(i)%zeta = from%coordinate(i)%zeta + this%coordinate(i)%descriptor_str = from%coordinate(i)%descriptor_str + this%coordinate(i)%sparseCutoff = from%coordinate(i)%sparseCutoff + + call gpSparse_setPermutations(this,i,from%coordinate(i)%permutations,error) + enddo + + this%initialised = .true. + end subroutine gpSparse_initialise + + subroutine gpSparse_fit(this, from, task_manager, condition_number_norm, error) + type(gpSparse), intent(inout) :: this + type(gpFull), intent(inout) :: from ! actually input; intent(inout) to free memory early + type(task_manager_type), intent(in) :: task_manager + character(len=*), optional, intent(in) :: condition_number_norm + integer, optional, intent(out) :: error + + character(len=STRING_LENGTH) :: my_condition_number_norm + + integer :: i, j, mb_A, nb_A + integer :: i_coordinate, i_sparseX, i_global_sparseX, n_globalSparseX, n_globalY, i_y, i_yPrime, & + i_globalY, i_global_yPrime, nrows +#ifdef HAVE_QR + real(qp) :: rcond + real(qp), dimension(:,:), allocatable :: c_subYY_sqrtInverseLambda, factor_c_subYsubY, a + real(qp), dimension(:), allocatable :: globalY, alpha + type(LA_Matrix) :: LA_c_subYsubY, LA_q_subYsubY +#else + real(qp), dimension(:,:), allocatable :: c_subYY_inverseLambda, c_subYY_inverseLambda_c_YsubY!, & +! inverse_q_subYsubY, inverse_c_subYsubY + real(qp), dimension(:), allocatable :: globalY, alpha + type(LA_Matrix) :: LA_q_subYsubY +#endif + + INIT_ERROR(error) + + my_condition_number_norm = optional_default(' ', condition_number_norm) + + call gpSparse_initialise(this, from, error) + + n_globalSparseX = from%n_globalSparseX + n_globalY = from%n_y + from%n_yPrime + +#ifdef HAVE_QR + call system_timer('Build linear system') + + allocate(c_subYY_sqrtInverseLambda(n_globalSparseX,n_globalY)) + call matrix_product_vect_asdiagonal_sub(c_subYY_sqrtInverseLambda,from%covariance_subY_y,sqrt(1.0_qp/from%lambda)) ! O(NM) + if (allocated(from%covariance_subY_y)) deallocate(from%covariance_subY_y) ! free input component to save memory + + if (from%do_subY_subY) then + allocate(factor_c_subYsubY(n_globalSparseX,n_globalSparseX)) + call initialise(LA_c_subYsubY,from%covariance_subY_subY,use_allocate=.false.) + call LA_Matrix_Factorise(LA_c_subYsubY,factor_c_subYsubY,error=error) + call finalise(LA_c_subYsubY) + if (allocated(from%covariance_subY_subY)) deallocate(from%covariance_subY_subY) ! free input component to save memory + + do i = 1, n_globalSparseX-1 + do j = i+1, n_globalSparseX + factor_c_subYsubY(j,i) = 0.0_qp + end do + end do + end if + + allocate(alpha(n_globalSparseX)) + if (task_manager%active) then + nrows = task_manager%idata(1) + mb_A = task_manager%idata(2) + nb_A = task_manager%idata(3) + allocate(globalY(nrows)) + allocate(a(nrows,n_globalSparseX)) + alpha = 0.0_qp + globalY = 0.0_qp + a = 0.0_qp + else + allocate(globalY(n_globalY+n_globalSparseX)) + allocate(a(n_globalY+n_globalSparseX,n_globalSparseX)) + end if + + a(1:n_globalY,:) = transpose(c_subYY_sqrtInverseLambda) + if (allocated(c_subYY_sqrtInverseLambda)) deallocate(c_subYY_sqrtInverseLambda) + + if (task_manager%active) then + if (.not. allocated(factor_c_subYsubY)) then + ! tks: make sure we are not passing in an unallocated array as the input to + ! mpi_scatterv on the processes which are receiving data. This was found to + ! be an issue on GCC 11 with -O2 and above. + allocate(factor_c_subYsubY(0, 0)) + end if + call scatter_shared_task(task_manager, factor_c_subYsubY, a, n_globalY, n_globalSparseX, from%do_subY_subY) + else + a(n_globalY+1:,:) = factor_c_subYsubY + end if + if (allocated(factor_c_subYsubY)) deallocate(factor_c_subYsubY) + + if (my_condition_number_norm(1:1) /= ' ') then + if (task_manager%active) then + call print_warning("Condition number of distributed matrix is not implemented.") + else + rcond = matrix_condition_number(a, my_condition_number_norm(1:1)) + call print("Condition number (log10) of matrix A (norm "//my_condition_number_norm(1:1)//"): "//-log10(rcond)) + end if + end if + + globalY = 0.0_qp + do i_y = 1, from%n_y + ! loop over all function values + + i_globalY = from%map_y_globalY(i_y) + ! find unique function value/derivative identifier + + globalY(i_globalY) = from%y(i_y)*sqrt(1.0_qp/from%lambda(i_globalY)) + enddo + + do i_yPrime = 1, from%n_yPrime + ! loop over all function values + + i_global_yPrime = from%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + globalY(i_global_yPrime) = from%yPrime(i_yPrime)*sqrt(1.0_qp/from%lambda(i_global_yPrime)) + enddo + call system_timer('Build linear system') + + call system_timer('Solve linear system') + if (task_manager%active) then + call print("Using ScaLAPACK to solve QR") + call SP_Matrix_QR_Solve(a, globalY, alpha, task_manager%ScaLAPACK_obj, mb_A, nb_A, this%R, this%do_export_R) + else + call print("Using LAPACK to solve QR") + call initialise(LA_q_subYsubY, a, use_allocate=.false.) + call LA_Matrix_QR_Solve_Vector(LA_q_subYsubY, globalY, alpha) + call finalise(LA_q_subYsubY) + end if + call system_timer('Solve linear system') + + do i_coordinate = 1, from%n_coordinate + do i_sparseX = 1, from%coordinate(i_coordinate)%n_sparseX + i_global_sparseX = from%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) + this%coordinate(i_coordinate)%alpha(i_sparseX) = real(alpha(i_global_sparseX),kind=dp) + enddo + enddo + + if(allocated(a)) deallocate(a) + if(allocated(globalY)) deallocate(globalY) + if(allocated(alpha)) deallocate(alpha) +#else + allocate( c_subYY_inverseLambda(n_globalSparseX,n_globalY), c_subYY_inverseLambda_c_YsubY(n_globalSparseX,n_globalSparseX), & +! inverse_q_subYsubY(n_globalSparseX,n_globalSparseX), inverse_c_subYsubY(n_globalSparseX,n_globalSparseX), & + alpha(n_globalSparseX), globalY(n_globalY)) + + call matrix_product_vect_asdiagonal_sub(c_subYY_inverseLambda,from%covariance_subY_Y,1.0_qp/from%lambda) ! O(NM) + + c_subYY_inverseLambda_c_YsubY = matmul(c_subYY_inverseLambda,transpose(from%covariance_subY_Y)) + call initialise(LA_q_subYsubY,from%covariance_subY_subY + c_subYY_inverseLambda_c_YsubY) + + globalY = 0.0_qp + do i_y = 1, from%n_y + ! loop over all function values + + i_globalY = from%map_y_globalY(i_y) + ! find unique function value/derivative identifier + + globalY(i_globalY) = from%y(i_y) !*sqrt(1.0_qp/from%lambda(i_globalY)) + enddo + + do i_yPrime = 1, from%n_yPrime + ! loop over all function values + + i_global_yPrime = from%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + globalY(i_global_yPrime) = from%yPrime(i_yPrime) !*sqrt(1.0_qp/from%lambda(i_global_yPrime)) + enddo + + call Matrix_Solve(LA_q_subYsubY,matmul(c_subYY_inverseLambda, globalY),alpha) + call finalise(LA_q_subYsubY) + + do i_coordinate = 1, from%n_coordinate + do i_sparseX = 1, from%coordinate(i_coordinate)%n_sparseX + i_global_sparseX = from%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) + this%coordinate(i_coordinate)%alpha(i_sparseX) = real(alpha(i_global_sparseX),kind=dp) + enddo + enddo + + if(allocated(c_subYY_inverseLambda)) deallocate(c_subYY_inverseLambda) + if(allocated(c_subYY_inverseLambda_c_YsubY)) deallocate(c_subYY_inverseLambda_c_YsubY) +! if(allocated(inverse_q_subYsubY)) deallocate(inverse_q_subYsubY) +! if(allocated(inverse_c_subYsubY)) deallocate(inverse_c_subYsubY) + if(allocated(alpha)) deallocate(alpha) + if(allocated(globalY)) deallocate(globalY) +#endif + this%fitted = .true. + + endsubroutine gpSparse_fit + + ! put L part at the end of local A (take info from last task of each worker) + subroutine scatter_shared_task(task_manager, factor_c_subYsubY, a, n_globalY, n_globalSparseX, do_subY_subY) + type(task_manager_type), intent(in) :: task_manager + real(qp), intent(inout) :: factor_c_subYsubY(:,:) + real(qp), intent(inout) :: a(:,:) + integer, intent(in) :: n_globalY + integer, intent(in) :: n_globalSparseX + logical, intent(in) :: do_subY_subY + + integer :: n, t, w + integer, allocatable :: counts(:) + real(dp), allocatable :: tmp(:,:) + + ! scattering works with cols, so transposing input and output + if (do_subY_subY) then + factor_c_subYsubY = transpose(factor_c_subYsubY) + call get_shared_task_counts(task_manager, n_globalSparseX, counts) + else + allocate(counts(1), source=0) + end if + + w = task_manager%my_worker_id + t = task_manager%workers(w)%n_tasks + n = task_manager%workers(w)%tasks(t)%idata(1) + allocate(tmp(n_globalSparseX,n)) + tmp = 0.0_dp + + call scatterv(task_manager%MPI_obj, factor_c_subYsubY, tmp, counts) + a(n_globalY+1:n_globalY+n,:) = transpose(tmp) + end subroutine scatter_shared_task + + subroutine get_shared_task_counts(task_manager, ncols, counts) + type(task_manager_type), intent(in) :: task_manager + integer, intent(in) :: ncols + integer, intent(out), allocatable :: counts(:) + + integer :: n, o, t, w + + allocate(counts(task_manager%n_workers)) + counts = 0 + o = 0 + do w = 1, task_manager%n_workers + t = task_manager%workers(w)%n_tasks + n = task_manager%workers(w)%tasks(t)%idata(1) + counts(w) = n * ncols + o = o + n + if (o > ncols) then + counts(w) = (n - (o - ncols)) * ncols + call print_warning("get_shared_task_counts: Not enough data. & + &Were sparse points reduced since task distribution?") + exit + end if + end do + end subroutine get_shared_task_counts + + subroutine gpSparse_finalise(this,error) + type(gpSparse), intent(inout) :: this + integer, optional, intent(out) :: error + + integer :: i_coordinate + + INIT_ERROR(error) + + if (allocated(this%coordinate)) then + do i_coordinate = 1, this%n_coordinate + call finalise(this%coordinate(i_coordinate), error) + enddo + deallocate(this%coordinate) + end if + + this%n_coordinate = 0 + this%initialised = .false. + this%fitted = .false. + + endsubroutine gpSparse_finalise + + subroutine gpFull_Finalise(this, error) + type(gpFull), intent(inout) :: this + integer, optional, intent(out) :: error + + integer :: i + + INIT_ERROR(error) + + if(.not. this%initialised) return + + if(allocated(this%coordinate)) then + do i = 1, this%n_coordinate + call finalise(this%coordinate(i)) + enddo + deallocate( this%coordinate ) + endif + + if(allocated(this%y)) deallocate( this%y ) + if(allocated(this%yPrime)) deallocate( this%yPrime ) + if(allocated(this%sigma_y)) deallocate( this%sigma_y ) + if(allocated(this%sigma_yPrime)) deallocate( this%sigma_yPrime ) + if(allocated(this%map_y_globalY)) deallocate( this%map_y_globalY ) + if(allocated(this%map_yPrime_globalY)) deallocate( this%map_yPrime_globalY ) + if(allocated(this%covariance_subY_y)) deallocate( this%covariance_subY_y ) + if(allocated(this%covariance_subY_subY)) deallocate( this%covariance_subY_subY ) + if(allocated(this%covarianceDiag_y_y)) deallocate( this%covarianceDiag_y_y ) + if(allocated(this%lambda)) deallocate( this%lambda ) + if(allocated(this%alpha)) deallocate( this%alpha ) + + this%n_coordinate = 0 + this%n_y = 0 + this%n_yPrime = 0 + this%current_y = 0 + this%current_yPrime = 0 + + this%initialised = .false. + + endsubroutine gpFull_Finalise + + subroutine gpCoordinates_Finalise(this, error) + type(gpCoordinates), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not. this%initialised) return + + if(allocated(this%x)) deallocate( this%x ) + if(allocated(this%xPrime)) deallocate( this%xPrime ) + if(allocated(this%cutoff)) deallocate( this%cutoff ) + if(allocated(this%cutoffPrime)) deallocate( this%cutoffPrime ) + if(allocated(this%theta)) deallocate( this%theta ) + + if(allocated(this%permutations)) deallocate(this%permutations) + if(allocated(this%permutation_distance_mask)) deallocate( this%permutation_distance_mask ) + + if(allocated(this%map_x_y)) deallocate( this%map_x_y ) + if(allocated(this%map_xPrime_yPrime)) deallocate( this%map_xPrime_yPrime ) + if(allocated(this%map_xPrime_x)) deallocate( this%map_xPrime_x ) + if(allocated(this%map_sparseX_globalSparseX)) deallocate( this%map_sparseX_globalSparseX ) + if(allocated(this%config_type)) deallocate( this%config_type ) + + if(allocated(this%sparseX_index)) deallocate(this%sparseX_index) + if(allocated(this%sparseX)) deallocate(this%sparseX) + if(allocated(this%alpha)) deallocate(this%alpha) + if(allocated(this%sparseCutoff)) deallocate(this%sparseCutoff) + + if(allocated(this%x_size)) deallocate( this%x_size ) + if(allocated(this%xPrime_size)) deallocate( this%xPrime_size ) + if(allocated(this%covarianceDiag_x_x)) deallocate( this%covarianceDiag_x_x ) + if(allocated(this%covarianceDiag_x_xPrime)) deallocate( this%covarianceDiag_x_xPrime ) + if(allocated(this%covarianceDiag_xPrime_xPrime)) deallocate( this%covarianceDiag_xPrime_xPrime ) + + if(allocated(this%sparseX_size)) deallocate( this%sparseX_size ) + if(allocated(this%covarianceDiag_sparseX_sparseX)) deallocate( this%covarianceDiag_sparseX_sparseX ) + + + call finalise(this%descriptor_str) + call gpCoordinates_finalise_variance_estimate(this) + + if(allocated(this%sparseX_permuted)) deallocate( this%sparseX_permuted ) + if(allocated(this%sparseCovariance)) deallocate( this%sparseCovariance ) + + + this%sparse_covariance_initialised = .false. + + this%d = 0 + this%n_x = 0 + this%n_xPrime = 0 + this%delta = 0.0_dp + this%f0 = 0.0_dp + + this%current_x = 0 + this%current_xPrime = 0 + + this%n_sparseX = 0 + this%n_permutations = 0 + + this%sparsified = .false. + this%initialised = .false. + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call gpCovariance_bond_real_space_Finalise(this%bond_real_space_cov) + + this%covariance_type = COVARIANCE_NONE + + endsubroutine gpCoordinates_Finalise + + subroutine gpCovariance_bond_real_space_Finalise(this, error) + type(gpCovariance_bond_real_space), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + this%n = 0 + this%delta = 0.0_dp + this%atom_sigma = 0.0_dp + + this%initialised = .false. + + endsubroutine gpCovariance_bond_real_space_Finalise + + subroutine gpCovariance_atom_real_space_Finalise(this, error) + type(gpCovariance_atom_real_space), intent(inout) :: this + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + this%l_max = 0 + this%delta = 0.0_dp + + this%initialised = .false. + + endsubroutine gpCovariance_atom_real_space_Finalise + + function gpFull_addFunctionValue(this,y,sigma_y, error) + + type(gpFull), intent(inout) :: this + real(dp), intent(in) :: y, sigma_y ! Function value + integer :: gpFull_addFunctionValue ! Which function value we added + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_addFunctionValue: object not initialised',error) + endif + + if( this%current_y == this%n_y ) then + RAISE_ERROR( 'gpFull_addFunctionValue: object full, no more function values can be added',error) + endif + + this%current_y = this%current_y + 1 + this%y(this%current_y) = y + this%sigma_y(this%current_y) = sigma_y + + gpFull_addFunctionValue = this%current_y + + endfunction gpFull_addFunctionValue + + function gpFull_addFunctionDerivative(this, yPrime, sigma_yPrime, error) + type(gpFull), intent(inout) :: this + real(dp), intent(in) :: yPrime, sigma_yPrime ! Function value + integer :: gpFull_addFunctionDerivative ! Which function value we added + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_addFunctionDerivative: object not initialised',error) + endif + + if( this%current_yPrime == this%n_yPrime ) then + RAISE_ERROR( 'gpFull_addFunctionDerivative: object full, no more function values can be added',error) + endif + + this%current_yPrime = this%current_yPrime + 1 + this%yPrime(this%current_yPrime) = yPrime + this%sigma_yPrime(this%current_yPrime) = sigma_yPrime + + gpFull_addFunctionDerivative = this%current_yPrime + + endfunction gpFull_addFunctionDerivative + + function gpFull_addCoordinates_2Darray(this,x,i_coordinate,cutoff_in, current_y, config_type, error) result(xLocation) + type(gpFull), intent(inout) :: this + real(dp), dimension(:,:), intent(in) :: x + integer, intent(in) :: i_coordinate + integer, optional, intent(in) :: current_y, config_type + real(dp), dimension(:), intent(in), optional :: cutoff_in + integer, optional, intent(out) :: error + + integer, dimension(:), pointer :: xLocation + + integer :: previous_x, i + real(dp), dimension(:,:), allocatable :: new_x + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_addCoordinates: object not initialised',error) + endif + + if( i_coordinate > this%n_coordinate ) then + RAISE_ERROR( 'gpFull_addCoordinates: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate ,error) + endif + + if( .not. this%coordinate(i_coordinate)%initialised ) then + RAISE_ERROR('gpFull_addCoordinates: '//i_coordinate//'th coordinate object is not initialised',error) + endif + + if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + if( size(x,1) > size(this%coordinate(i_coordinate)%x,1) ) then + allocate( new_x(size(x,1),this%coordinate(i_coordinate)%n_x) ) + new_x = 0.0_dp + new_x(1:size(this%coordinate(i_coordinate)%x,1),:) = this%coordinate(i_coordinate)%x + deallocate( this%coordinate(i_coordinate)%x ) + allocate( this%coordinate(i_coordinate)%x(size(x,1),this%coordinate(i_coordinate)%n_x) ) + this%coordinate(i_coordinate)%x = new_x + deallocate( new_x ) + this%coordinate(i_coordinate)%d = size(x,1) + end if + else +! if( size(x,1) /= this%coordinate(i_coordinate)%d ) then +! RAISE_ERROR('gpFull_addCoordinates: dimensionality of descriptors '//size(x,1)//' does not match what is given in the object '//this%coordinate(i_coordinate)%d,error) +! endif + endif + + previous_x = this%coordinate(i_coordinate)%current_x + this%coordinate(i_coordinate)%current_x = previous_x + size(x,2) + + if( this%coordinate(i_coordinate)%current_x > this%coordinate(i_coordinate)%n_x ) then + RAISE_ERROR('gpFull_addCoordinates: object full, no more descriptors can be added',error) + endif + + if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + this%coordinate(i_coordinate)%x(1:size(x,1),previous_x+1:this%coordinate(i_coordinate)%current_x) = x + this%coordinate(i_coordinate)%x_size(previous_x+1:this%coordinate(i_coordinate)%current_x) = size(x,1) + else + this%coordinate(i_coordinate)%x(:,previous_x+1:this%coordinate(i_coordinate)%current_x) = x + endif + + if(present(cutoff_in)) then + this%coordinate(i_coordinate)%cutoff(previous_x+1:this%coordinate(i_coordinate)%current_x) = cutoff_in + endif + + if(present(current_y)) & + this%coordinate(i_coordinate)%map_x_y(previous_x+1:this%coordinate(i_coordinate)%current_x) = current_y + + if(present(config_type)) & + this%coordinate(i_coordinate)%config_type(previous_x+1:this%coordinate(i_coordinate)%current_x) = config_type + + allocate(xLocation(size(x,2))) + xLocation = (/ ( i, i = previous_x+1, this%coordinate(i_coordinate)%current_x ) /) + + endfunction gpFull_addCoordinates_2Darray + + function gpFull_addCoordinates_1Darray(this,x,i_coordinate,cutoff_in,current_y,config_type, error) result(xLocation) + type(gpFull), intent(inout) :: this + real(dp), dimension(:), intent(in) :: x + integer, intent(in) :: i_coordinate + real(dp), optional, intent(in) :: cutoff_in + integer, optional, intent(in) :: current_y, config_type + integer, optional, intent(out) :: error + + integer :: xLocation + + integer, dimension(:), pointer :: xLocation_in + + INIT_ERROR(error) + + xLocation_in => gpFull_addCoordinates_2Darray(this,reshape(x,(/size(x),1/)),i_coordinate,(/cutoff_in/),current_y,config_type,error) + + xLocation = xLocation_in(1) + deallocate(xLocation_in) + + endfunction gpFull_addCoordinates_1Darray + + subroutine gpFull_addCoordinateDerivatives_2Darray(this,xPrime,i_coordinate,current_yPrime, xLocation, dcutoff_in, error) + type(gpFull), intent(inout) :: this + real(dp), dimension(:,:), intent(in) :: xPrime + integer, intent(in) :: i_coordinate, current_yPrime + integer, dimension(:), intent(in) :: xLocation + real(dp), dimension(:), optional, intent(in) :: dcutoff_in + integer, optional, intent(out) :: error + + integer :: previous_xPrime + real(dp), dimension(:,:), allocatable :: new_xPrime + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_addCoordinateDerivatives: object not initialised',error) + endif + + if( i_coordinate > this%n_coordinate ) then + RAISE_ERROR( 'gpFull_addCoordinateDerivatives: access to descriptor '//i_coordinate//' is not possible as number of descriptors is set '//this%n_coordinate,error ) + endif + + if( .not. this%coordinate(i_coordinate)%initialised ) then + RAISE_ERROR('gpFull_addCoordinateDerivatives: '//i_coordinate//'th coordinate object is not initialised',error) + endif + + if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + if( size(xPrime,1) > size(this%coordinate(i_coordinate)%xPrime,1) ) then + allocate( new_xPrime(size(xPrime,1),this%coordinate(i_coordinate)%n_xPrime) ) + new_xPrime = 0.0_dp + new_xPrime(1:size(this%coordinate(i_coordinate)%xPrime,1),:) = this%coordinate(i_coordinate)%xPrime + deallocate( this%coordinate(i_coordinate)%xPrime ) + allocate( this%coordinate(i_coordinate)%xPrime(size(xPrime,1),this%coordinate(i_coordinate)%n_xPrime) ) + this%coordinate(i_coordinate)%xPrime = new_xPrime + deallocate( new_xPrime ) + end if + else + if( size(xPrime,1) /= this%coordinate(i_coordinate)%d ) then + RAISE_ERROR('gpFull_addCoordinateDerivatives: dimensionality of descriptors '//size(xPrime,1)//' does not match what is given in the object '//this%coordinate(i_coordinate)%d,error) + endif + endif + + if( size(xPrime,2) /= size(xLocation) ) then + RAISE_ERROR('gpFull_addCoordinateDerivatives: number of descriptors '//size(xPrime,2)//' has to match the dimensionality of the mapping array '//size(xLocation),error) + endif + + previous_xPrime = this%coordinate(i_coordinate)%current_xPrime + this%coordinate(i_coordinate)%current_xPrime = previous_xPrime + size(xPrime,2) + + if( this%coordinate(i_coordinate)%current_xPrime > this%coordinate(i_coordinate)%n_xPrime ) then + RAISE_ERROR('gpFull_addCoordinateDerivatives: object full, no more descriptors can be added',error) + endif + + if( this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + this%coordinate(i_coordinate)%xPrime(1:size(xPrime,1),previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = xPrime + this%coordinate(i_coordinate)%xPrime_size(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = size(xPrime,1) + else + this%coordinate(i_coordinate)%xPrime(:,previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = xPrime + endif + + if(present(dcutoff_in)) then + this%coordinate(i_coordinate)%cutoffPrime(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = dcutoff_in + endif + + this%coordinate(i_coordinate)%map_xPrime_yPrime(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = current_yPrime + this%coordinate(i_coordinate)%map_xPrime_x(previous_xPrime+1:this%coordinate(i_coordinate)%current_xPrime) = xLocation + + endsubroutine gpFull_addCoordinateDerivatives_2Darray + + subroutine gpFull_addCoordinateDerivatives_1Darray(this,xPrime,i_coordinate,current_yPrime, xLocation, dcutoff_in, error) + type(gpFull), intent(inout) :: this + real(dp), dimension(:), intent(in) :: xPrime + integer, intent(in) :: i_coordinate, current_yPrime + integer, intent(in) :: xLocation + real(dp), optional, intent(in) :: dcutoff_in + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + call gpFull_addCoordinateDerivatives_2Darray(this, reshape(xPrime,(/size(xPrime),1/)),i_coordinate,current_yPrime,(/xLocation/),(/dcutoff_in/),error) + + endsubroutine gpFull_addCoordinateDerivatives_1Darray + + subroutine gpFull_addDescriptor(this,i_coordinate,descriptor_str,error) + + type(gpFull), intent(inout) :: this + integer, intent(in) :: i_coordinate + character(len=*), intent(in) :: descriptor_str + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_addDescriptor: object not initialised',error) + endif + + call gpCoordinates_addDescriptor(this%coordinate(i_coordinate),descriptor_str,error) + + endsubroutine gpFull_addDescriptor + + subroutine gpCoordinates_addDescriptor(this,descriptor_str,error) + + type(gpCoordinates), intent(inout) :: this + character(len=*), intent(in) :: descriptor_str + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_addDescriptor: object not initialised',error) + endif + + call initialise(this%descriptor_str) + call zero(this%descriptor_str) + + call concat(this%descriptor_str,descriptor_str,keep_lf=.false.,lf_to_whitespace=.true.) + + endsubroutine gpCoordinates_addDescriptor + + subroutine gpCoordinates_setTheta(this, theta, zeta, error) + type(gpCoordinates), intent(inout), target :: this + real(dp), dimension(:), intent(in), optional :: theta + real(dp), intent(in), optional :: zeta + integer, optional, intent(out) :: error + + integer :: i + real(dp) :: delta + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_setTheta: object not initialised',error) + endif + + allocate(this%covarianceDiag_x_xPrime(size(this%x,1),this%n_x)) + this%covarianceDiag_x_xPrime = 0.0_dp + + select case(this%covariance_type) + case(COVARIANCE_BOND_REAL_SPACE) + RAISE_ERROR('gpCoordinates_setTheta: this call is not appropriate. Needs to be fixed!!!', error) + !if(.not. this%bond_real_space_cov%initialised) then + ! call gpCoordinates_gpCovariance_bond_real_space_Initialise(this) + !endif + + !delta = this%bond_real_space_cov%delta + !this%bond_real_space_cov%delta = 1.0_dp + + !do i = 1, this%n_x + ! this%covarianceDiag_x_x(i) = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i = this%x(:,i), x_i_size = this%x_size(i), x_j = this%x(:,i), x_j_size = this%x_size(i)) + !enddo + +! ! do i = 1, this%n_xPrime +! ! enddo + + !this%bond_real_space_cov%delta = delta + + case(COVARIANCE_ARD_SE,COVARIANCE_PP) + call check_size('theta',theta,shape(this%theta),'gpCoordinates_setTheta',error) + if( .not. present(theta) ) then + RAISE_ERROR('gpCoordinates_setTheta: no theta present when using ARD_SE or PP for covariance', error) + endif + this%theta = theta + case(COVARIANCE_DOT_PRODUCT) + if( .not. present(zeta) ) then + RAISE_ERROR('gpCoordinates_setTheta: no zeta present when using DOT_PRODUCT for covariance', error) + endif + this%zeta = zeta + endselect + + endsubroutine gpCoordinates_setTheta + + subroutine gpCoordinates_setThetaFactor(this, thetaFactor,useSparseX,error) + type(gpCoordinates), intent(inout) :: this + real(dp), dimension(:), intent(in) :: thetaFactor + logical, optional, intent(in) :: useSparseX + integer, optional, intent(out) :: error + + integer :: i,p + logical :: my_useSparseX + real(dp), dimension(this%d) :: theta, max_vals, min_vals + + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_calculateThetaFactor: object not initialised',error) + endif + + if( .not. ( (this%covariance_type == COVARIANCE_ARD_SE) .or. (this%covariance_type == COVARIANCE_PP) ) ) then + RAISE_ERROR('gpCoordinates_calculateThetaFactor: only ARD_SE or PP type covariance may use theta_fac',error) + endif + + my_useSparseX = .false. + if( allocated(this%sparseX_index) ) then + if( sum( this%sparseX_index ) > 0 ) my_useSparseX = optional_default(.true.,useSparseX) + endif + + if( my_useSparseX ) then + do i = 1, this%d + max_vals(i) = maxval(this%x(i,this%sparseX_index)) + min_vals(i) = minval(this%x(i,this%sparseX_index)) + enddo + do p=1, this%n_permutations !get max and min value of each dimension including all permutations + do i=1, this%d + max_vals(i) = max(max_vals(i),max_vals(this%permutations(i,p))) + min_vals(i) = min(min_vals(i),min_vals(this%permutations(i,p))) + enddo + enddo + do i = 1, this%d + theta(i) = ( max_vals(i)- min_vals(i) ) * thetaFactor(i) + if( theta(i) < THETA_MIN ) theta(i) = 1.0_dp + enddo + else + do i = 1, this%d + max_vals(i) = maxval(this%x(i,:)) + min_vals(i) = minval(this%x(i,:)) + enddo + do p=1, this%n_permutations !get max and min value of each dimension including all permutations + do i=1, this%d + max_vals(i) = max(max_vals(i),max_vals(this%permutations(i,p))) + min_vals(i) = min(min_vals(i),min_vals(this%permutations(i,p))) + enddo + enddo + do i = 1, this%d + theta(i) = ( max_vals(i)- min_vals(i) ) * thetaFactor(i) + if( theta(i) < THETA_MIN ) theta(i) = 1.0_dp + enddo + endif + + call gpCoordinates_setTheta(this,theta=theta,error=error) + + endsubroutine gpCoordinates_setThetaFactor + + subroutine gpFull_setTheta(this, i_coordinate, theta, zeta, error) + type(gpFull), intent(inout) :: this + integer, intent(in) :: i_coordinate + real(dp), dimension(:), intent(in), optional :: theta + real(dp), intent(in), optional :: zeta + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_setTheta: object not initialised',error) + endif + + call gpCoordinates_setTheta(this%coordinate(i_coordinate), theta=theta, zeta=zeta, error=error) + + endsubroutine gpFull_setTheta + + subroutine gpFull_setTheta_thetaFactor(this, i_coordinate, thetaFactor, useSparseX, error) + type(gpFull), intent(inout) :: this + integer, intent(in) :: i_coordinate + real(dp), dimension(:), intent(in) :: thetaFactor + logical, optional, intent(in) :: useSparseX + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_setTheta_thetaFactor: object not initialised',error) + endif + + call gpCoordinates_setThetaFactor(this%coordinate(i_coordinate), thetaFactor, useSparseX, error) + + endsubroutine gpFull_setTheta_thetaFactor + +! subroutine gpFull_setTheta_thetaFactorArray(this, thetaFactor, useSparseX, error) +! type(gpFull), intent(inout) :: this +! real(dp), dimension(:), intent(in) :: thetaFactor +! logical, optional, intent(out) :: useSparseX +! integer, optional, intent(out) :: error +! +! integer :: i +! +! INIT_ERROR(error) +! +! if( .not. this%initialised ) then +! RAISE_ERROR('gpFull_setTheta_thetaFactorArray: object not initialised',error) +! endif +! +! call check_size('thetaFactor',thetaFactor,(/this%n_coordinate/),'gpFull_setTheta_thetaFactorArray',error) +! +! do i = 1, this%n_coordinate +! call gpCoordinates_setThetaFactor(this%coordinate(i), thetaFactor(i), useSparseX, error) +! enddo +! +! endsubroutine gpFull_setTheta_thetaFactorArray +! +! subroutine gpFull_setTheta_thetaFactorUniform(this, thetaFactor, useSparseX, error) +! type(gpFull), intent(inout) :: this +! real(dp), intent(in) :: thetaFactor +! logical, optional, intent(out) :: useSparseX +! integer, optional, intent(out) :: error +! +! integer :: i +! +! INIT_ERROR(error) +! +! if( .not. this%initialised ) then +! RAISE_ERROR('gpFull_setTheta_thetaFactorUniform: object not initialised',error) +! endif +! +! do i = 1, this%n_coordinate +! call gpCoordinates_setThetaFactor(this%coordinate(i), thetaFactor, useSparseX, error) +! enddo +! +! endsubroutine gpFull_setTheta_thetaFactorUniform + + subroutine gpFull_covarianceMatrix_sparse(this,error) + type(gpFull), intent(inout), target :: this + integer, optional, intent(out) :: error + + integer :: i_coordinate, i_global_sparseX, j_global_sparseX, i_sparseX, j_sparseX, & + n_globalY, i_globalY, i_global_yPrime, i_y, i_yPrime, i_x, j_x, n_x, i_xPrime, j_xPrime, n_xPrime + real(dp) :: covariance_xPrime_sparseX + real(dp), dimension(:,:), allocatable :: grad_Covariance_i + real(dp), dimension(:), allocatable :: covariance_x_sparseX, covariance_subY_currentX_y, covariance_subY_currentX_suby + real(dp) :: start_time, cpu_time, wall_time + + + INIT_ERROR(error) + + call system_timer('gpFull_covarianceMatrix_sparse') + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_covarianceMatrix: object not initialised',error) + endif + + this%n_globalSparseX = 0 + i_global_sparseX = 0 + + do i_coordinate = 1, this%n_coordinate + if( .not. this%coordinate(i_coordinate)%initialised ) then + RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//'th coordinate object not initialised',error) + endif + + if( .not. this%coordinate(i_coordinate)%sparsified ) then + RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//'th coordinate object not sparsified',error) + endif + + if( .not. allocated(this%coordinate(i_coordinate)%x) ) then + RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//"th coordinate's x not allocated",error) + endif + + if( .not. allocated(this%coordinate(i_coordinate)%xPrime) ) then + RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//"th coordinate's xPrime not allocated",error) + endif + + if(this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + if(.not. this%coordinate(i_coordinate)%bond_real_space_cov%initialised) then + call gpCoordinates_gpCovariance_bond_real_space_Initialise(this%coordinate(i_coordinate)) + endif + endif + + this%n_globalSparseX = this%n_globalSparseX + this%coordinate(i_coordinate)%n_sparseX + + do i_sparseX = 1, this%coordinate(i_coordinate)%n_sparseX + i_global_sparseX = i_global_sparseX + 1 + this%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) = i_global_sparseX + enddo + enddo + + n_globalY = this%n_y + this%n_yPrime + + i_globalY = 0 + do i_y = 1, this%n_y + ! loop over all function values + + i_globalY = i_globalY + 1 + this%map_y_globalY(i_y) = i_globalY + enddo + do i_yPrime = 1, this%n_yPrime + ! loop over all derivative values + + i_globalY = i_globalY + 1 + this%map_yPrime_globalY(i_yPrime) = i_globalY + enddo + + if (this%do_subY_subY) then + call reallocate(this%covariance_subY_subY, this%n_globalSparseX, this%n_globalSparseX, zero = .true.) + else + call reallocate(this%covariance_subY_subY, 1, 1, zero = .true.) + end if + + call reallocate(this%covariance_subY_y, this%n_globalSparseX, n_globalY, zero = .true.) + call reallocate(this%covarianceDiag_y_y, n_globalY, zero = .true.) + call reallocate(this%lambda, n_globalY, zero = .true.) + + allocate( covariance_subY_currentX_y(n_globalY),covariance_subY_currentX_suby(this%n_globalSparseX) ) + covariance_subY_currentX_y = 0.0_dp + covariance_subY_currentX_suby = 0.0_dp + + do i_coordinate = 1, this%n_coordinate + ! loop over different descriptor types + call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate) + call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate//'_sparse') + call print('Started sparse covariance matrix calculation of coordinate '//i_coordinate) + call current_times(cpu_time, start_time) + ! + do i_sparseX = 1, this%coordinate(i_coordinate)%n_sparseX + ! loop over sparse points of each descriptor + + i_global_sparseX = this%coordinate(i_coordinate)%map_sparseX_globalSparseX(i_sparseX) + ! find the unique number of the sparse point (to refer to it outside of the context of descriptor) + + allocate( grad_Covariance_i(this%coordinate(i_coordinate)%d,this%coordinate(i_coordinate)%n_x), & + covariance_x_sparseX(this%coordinate(i_coordinate)%n_x) ) + + covariance_subY_currentX_y = 0.0_dp + covariance_subY_currentX_suby = 0.0_dp + +!$omp parallel do schedule(static,get_chunk_size(this%coordinate(i_coordinate)%n_x)) default(none) & +!$omp shared(this,i_coordinate,covariance_x_sparseX,grad_Covariance_i,i_sparseX) & +!$omp private(i_x,i_y,i_globalY) reduction(+:covariance_subY_currentX_y) + do i_x = 1, this%coordinate(i_coordinate)%n_x + ! loop over all data + + covariance_x_sparseX(i_x) = gpCoordinates_Covariance(this%coordinate(i_coordinate), & + i_x = i_x, j_sparseX = i_sparseX, grad_Covariance_i = grad_Covariance_i(:,i_x)) + + i_y = this%coordinate(i_coordinate)%map_x_y(i_x) + ! find which function value depends on the given descriptor + + if( i_y /= 0 ) then + i_globalY = this%map_y_globalY(i_y) + ! find unique function value/derivative identifier + + !this%covariance_subY_y(i_global_sparseX, i_globalY) = this%covariance_subY_y(i_global_sparseX, i_globalY) + & + covariance_subY_currentX_y(i_globalY) = covariance_subY_currentX_y(i_globalY) + & + covariance_x_sparseX(i_x)*this%coordinate(i_coordinate)%cutoff(i_x)*this%coordinate(i_coordinate)%sparseCutoff(i_sparseX) + endif + enddo + +!$omp parallel do schedule(static,get_chunk_size(this%coordinate(i_coordinate)%n_xPrime)) default(none) & +!$omp shared(this,i_coordinate,i_sparseX,grad_Covariance_i,covariance_x_sparseX) & +!$omp private(i_xPrime,i_yPrime,i_x,i_global_yPrime,covariance_xPrime_sparseX) reduction(+:covariance_subY_currentX_y) + + do i_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime + ! loop over all derivative data + + i_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(i_xPrime) + ! find which derivative depends on the given descriptor + + i_x = this%coordinate(i_coordinate)%map_xPrime_x(i_xPrime) + if( i_yPrime /= 0 ) then + i_global_yPrime = this%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + ! on Xeon w/ ifort 12, sum is fastest . ddot is close. dot_product is terrible + ! on Opteron w/ ifort 12 acml 5.2, ddot is 14.95 s, dot_product is 22.5 s, and sum is 13.9 s + ! dgemv doesn't seem noticeably faster at Opterons (may be faster on Xeon for 'N' transpose setting) + ! covariance_xPrime_sparseX = ddot(size(this%coordinate(i_coordinate)%xPrime,1),grad_Covariance_i(first_nonzero,i_x),1,this%coordinate(i_coordinate)%xPrime(1,i_xPrime),1)*& + ! covariance_xPrime_sparseX = dot_product(grad_Covariance_i(first_nonzero:last_nonzero,i_x),this%coordinate(i_coordinate)%xPrime(:,i_xPrime))* & + covariance_xPrime_sparseX = sum(grad_Covariance_i(:,i_x)*this%coordinate(i_coordinate)%xPrime(:,i_xPrime))* & + this%coordinate(i_coordinate)%cutoff(i_x)*this%coordinate(i_coordinate)%sparseCutoff(i_sparseX) + & + covariance_x_sparseX(i_x)*this%coordinate(i_coordinate)%cutoffPrime(i_xPrime)*this%coordinate(i_coordinate)%sparseCutoff(i_sparseX) + + !this%covariance_subY_y(i_global_sparseX, i_global_yPrime) = this%covariance_subY_y(i_global_sparseX, i_global_yPrime) + covariance_xPrime_sparseX + covariance_subY_currentX_y(i_global_yPrime) = covariance_subY_currentX_y(i_global_yPrime) + covariance_xPrime_sparseX + endif + enddo + + + if(allocated(grad_Covariance_i)) deallocate(grad_Covariance_i) + if(allocated(covariance_x_sparseX)) deallocate(covariance_x_sparseX) + +!$omp parallel do schedule(static,get_chunk_size(this%coordinate(i_coordinate)%n_sparseX)) default(none) & +!$omp shared(this,i_coordinate,covariance_x_sparseX,grad_Covariance_i,i_sparseX,i_global_sparseX) & +!$omp private(j_sparseX,j_global_sparseX) reduction(+:covariance_subY_currentX_suby) + do j_sparseX = 1, this%coordinate(i_coordinate)%n_sparseX + ! loop over sparse points of each descriptor + + j_global_sparseX = this%coordinate(i_coordinate)%map_sparseX_globalSparseX(j_sparseX) + ! find the unique number of the sparse point (to refer to it outside of the context of descriptor) + covariance_subY_currentX_suby(j_global_sparseX) = covariance_subY_currentX_suby(j_global_sparseX) + & + gpCoordinates_Covariance(this%coordinate(i_coordinate), j_sparseX = j_sparseX, i_sparseX = i_sparseX) * this%coordinate(i_coordinate)%sparseCutoff(i_sparseX)*this%coordinate(i_coordinate)%sparseCutoff(j_sparseX) + enddo + + if (this%do_subY_subY) then + this%covariance_subY_subY(i_global_sparseX,i_global_sparseX) = this%covariance_subY_subY(i_global_sparseX,i_global_sparseX) + this%sparse_jitter + this%covariance_subY_subY(:,i_global_sparseX) = this%covariance_subY_subY(:,i_global_sparseX) + covariance_subY_currentX_suby + end if + + this%covariance_subY_y(i_global_sparseX,:) = this%covariance_subY_y(i_global_sparseX,:) + covariance_subY_currentX_y + + call current_times(cpu_time, wall_time) + if(mod(i_sparseX,100) == 0) call progress_timer(this%coordinate(i_coordinate)%n_sparseX, i_sparseX, "Covariance matrix", wall_time-start_time) + enddo + call current_times(cpu_time, wall_time) + call progress_timer(this%coordinate(i_coordinate)%n_sparseX, i_sparseX, "Covariance matrix", wall_time-start_time) + call print('Finished sparse covariance matrix calculation of coordinate '//i_coordinate) + call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate//'_sparse') + + this%covarianceDiag_y_y = 0.0_dp + + if (allocated(this%coordinate(i_coordinate)%x)) deallocate(this%coordinate(i_coordinate)%x) + if (allocated(this%coordinate(i_coordinate)%xPrime)) deallocate(this%coordinate(i_coordinate)%xPrime) + call system_timer('gpFull_covarianceMatrix_sparse_Coordinate'//i_coordinate) + enddo + + call system_timer('gpFull_covarianceMatrix_sparse_FunctionValues') + this%lambda = 0.0_dp + + do i_y = 1, this%n_y + ! loop over all function values + + i_globalY = this%map_y_globalY(i_y) + ! find unique function value/derivative identifier + + this%lambda(i_globalY) = this%lambda(i_globalY) + & + this%sigma_y(i_y)**2 + enddo + + do i_yPrime = 1, this%n_yPrime + ! loop over all function values + + i_global_yPrime = this%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + this%lambda(i_global_yPrime) = this%lambda(i_global_yPrime) + & + this%sigma_yPrime(i_yPrime)**2 + enddo + call system_timer('gpFull_covarianceMatrix_sparse_FunctionValues') + + call system_timer('gpFull_covarianceMatrix_sparse') + + endsubroutine gpFull_covarianceMatrix_sparse + + subroutine gpFull_covarianceMatrix(this,error) + type(gpFull), intent(inout) :: this + integer, optional, intent(out) :: error + + integer :: i_coordinate, n_globalY, i_globalY, j_globalY, i_global_yPrime, j_global_yPrime, i_y, j_y, i_yPrime, j_yPrime, i_x, j_x, i_xPrime, j_xPrime + real(dp) :: covariance_x_x + real(dp), dimension(:), allocatable :: globalY + real(dp), dimension(:,:), allocatable :: grad_Covariance_i + logical :: is_i_xPrime + + type(LA_matrix) :: LA_covariance_y_y + + INIT_ERROR(error) + + call system_timer('gpFull_covarianceMatrix') + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_covarianceMatrix: object not initialised',error) + endif + + do i_coordinate = 1, this%n_coordinate + if( .not. this%coordinate(i_coordinate)%initialised ) then + RAISE_ERROR('gpFull_covarianceMatrix: '//i_coordinate//'th coordinate object not initialised',error) + endif + + if(this%coordinate(i_coordinate)%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + if(.not. this%coordinate(i_coordinate)%bond_real_space_cov%initialised) then + call gpCoordinates_gpCovariance_bond_real_space_Initialise(this%coordinate(i_coordinate)) + endif + endif + enddo + + n_globalY = this%n_y + this%n_yPrime + + i_globalY = 0 + do i_y = 1, this%n_y + ! loop over all function values + + i_globalY = i_globalY + 1 + this%map_y_globalY(i_y) = i_globalY + enddo + do i_yPrime = 1, this%n_yPrime + ! loop over all derivative values + + i_globalY = i_globalY + 1 + this%map_yPrime_globalY(i_yPrime) = i_globalY + enddo + + call reallocate(this%covariance_y_y, n_globalY, n_globalY, zero = .true.) + + do i_coordinate = 1, this%n_coordinate + ! loop over different descriptor types + +!!$omp parallel schedule(dynamic) default(none) private(j_x, j_y, j_globalY, i_x, i_y, i_globalY, covariance_x_x, i_xPrime, i_yPrime, i_global_yPrime, j_global_yPrime, j_xPrime, j_yPrime) shared(this,i_coordinate) +!!$omp do + do j_x = 1, this%coordinate(i_coordinate)%n_x + ! loop over all data + + j_y = this%coordinate(i_coordinate)%map_x_y(j_x) + ! find which function value depends on the given descriptor + if( j_y /= 0 ) then + j_globalY = this%map_y_globalY(j_y) + ! find unique function value/derivative identifier + + allocate( grad_Covariance_i(this%coordinate(i_coordinate)%d,this%coordinate(i_coordinate)%n_x) ) + do i_x = 1, this%coordinate(i_coordinate)%n_x + ! loop over all data + + i_y = this%coordinate(i_coordinate)%map_x_y(i_x) + ! find which function value depends on the given descriptor + + is_i_xPrime = any(this%coordinate(i_coordinate)%map_xPrime_x == i_x) + + if( (i_y /= 0 .and. i_y <= j_y) .or. is_i_xPrime) then + + if(is_i_xPrime) then + covariance_x_x = gpCoordinates_Covariance(this%coordinate(i_coordinate), i_x = i_x, j_x = j_x, grad_Covariance_i=grad_Covariance_i(:,i_x)) + else + covariance_x_x = gpCoordinates_Covariance(this%coordinate(i_coordinate), i_x = i_x, j_x = j_x) + endif + + if( i_y /= 0 ) then + i_globalY = this%map_y_globalY(i_y) + ! find unique function value/derivative identifier + this%covariance_y_y(i_globalY, j_globalY) = this%covariance_y_y(i_globalY, j_globalY) + covariance_x_x + endif + endif + + enddo + + do i_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime + ! loop over all derivative data + + i_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(i_xPrime) + ! find which derivative depends on the given descriptor + + i_x = this%coordinate(i_coordinate)%map_xPrime_x(i_xPrime) + + if( i_yPrime /= 0 ) then + i_global_yPrime = this%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + covariance_x_x = dot_product(grad_Covariance_i(:,i_x),this%coordinate(i_coordinate)%xPrime(:,i_xPrime)) + !gpCoordinates_Covariance(this%coordinate(i_coordinate), i_xPrime = i_xPrime, j_x = j_x) + this%covariance_y_y(i_global_yPrime, j_globalY) = this%covariance_y_y(i_global_yPrime, j_globalY) + covariance_x_x + endif + enddo + endif + if(allocated(grad_Covariance_i)) deallocate(grad_Covariance_i) + + enddo +!!$omp end do + +!!$omp do + do j_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime + ! loop over all derivative data + + j_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(j_xPrime) + ! find which derivative depends on the given descriptor + + if( j_yPrime /= 0 ) then + j_global_yPrime = this%map_yPrime_globalY(j_yPrime) + ! find unique function value/derivative identifier + + do i_xPrime = 1, this%coordinate(i_coordinate)%n_xPrime + ! loop over all derivative data + + i_yPrime = this%coordinate(i_coordinate)%map_xPrime_yPrime(i_xPrime) + ! find which derivative depends on the given descriptor + + if( i_yPrime /= 0 .and. i_yPrime <= j_yPrime) then + i_global_yPrime = this%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + call system_abort('not implemented yet') + !covariance_x_x = gpCoordinates_Covariance(this%coordinate(i_coordinate), i_xPrime = i_xPrime, j_xPrime = j_xPrime) + this%covariance_y_y(i_global_yPrime, j_global_yPrime) = this%covariance_y_y(i_global_yPrime, j_global_yPrime) + covariance_x_x + endif + enddo + endif + enddo +!!$omp end parallel + enddo + + do j_y = 1, size(this%covariance_y_y,2) + do i_y = j_y + 1, size(this%covariance_y_y,1) + this%covariance_y_y(i_y,j_y) = this%covariance_y_y(j_y,i_y) + enddo + enddo + + allocate( globalY(n_globalY) ) + + do i_y = 1, this%n_y + ! loop over all function values + + i_globalY = this%map_y_globalY(i_y) + ! find unique function value/derivative identifier + + this%covariance_y_y(i_globalY,i_globalY) = this%covariance_y_y(i_globalY,i_globalY) + & + this%sigma_y(i_y)**2 + + globalY(i_globalY) = this%y(i_y) + enddo + + do i_yPrime = 1, this%n_yPrime + ! loop over all function values + + i_global_yPrime = this%map_yPrime_globalY(i_yPrime) + ! find unique function value/derivative identifier + + this%covariance_y_y(i_global_yPrime,i_global_yPrime) = this%covariance_y_y(i_global_yPrime,i_global_yPrime) + & + this%sigma_yPrime(i_yPrime)**2 + + globalY(i_global_yPrime) = this%y(i_yPrime) + enddo + + call reallocate(this%alpha, n_globalY, zero = .true.) + + call initialise(LA_covariance_y_y,this%covariance_y_y) + call Matrix_Solve(LA_covariance_y_y, globalY, this%alpha ,error=error) + call finalise(LA_covariance_y_y) + + if(allocated(globalY)) deallocate(globalY) + + call system_timer('gpFull_covarianceMatrix') + + endsubroutine gpFull_covarianceMatrix + + function gpCoordinates_Covariance( this, i_x, j_x, i_sparseX, j_sparseX, grad_Covariance_i, grad_Covariance_j, grad2_Covariance, normalise, error ) + type(gpCoordinates), intent(in), target :: this + integer, intent(in), optional :: i_x, j_x, i_sparseX, j_sparseX + real(dp), dimension(:), optional, intent(out) :: grad_Covariance_i, grad_Covariance_j + real(dp), dimension(:,:), optional, intent(out) :: grad2_Covariance + logical, intent(in), optional :: normalise + integer, optional, intent(out) :: error + + real(dp) :: gpCoordinates_Covariance + + integer :: i_p, x_i_size, x_j_size, i + integer :: ii, jj, zeta_int + real(dp) :: covarianceExp, covarianceDiag_x_x_i, covarianceDiag_x_x_j, covarianceExp_ii, covarianceExp_jj, & + gpCoordinates_Covariance_ii, gpCoordinates_Covariance_jj, normalisation, & + covariancePP_ij, covariancePP_ii, covariancePP_jj, grad_covariancePP_ij, r_ij, r_ii, r_jj, grad_covariancePP_ii, grad_covariancePP_jj + real(dp), dimension(:), pointer :: x_i, x_j, grad_Covariance_Diag_i, grad_Covariance_Diag_j + !real(dp), dimension(this%d) :: inv_theta2, xI_xJ_theta2, xI_xJ, xI_xI, xI_xI_theta2, xJ_xJ, xJ_xJ_theta2, grad_Covariance_ii, grad_Covariance_jj + real(dp), dimension(:),allocatable :: inv_theta2, xI_xJ_theta2, xI_xJ, xI_xI, xI_xI_theta2, xJ_xJ, xJ_xJ_theta2, grad_Covariance_ii, grad_Covariance_jj + real(dp), dimension(:,:), allocatable :: distance_matrix + logical :: do_normalise + + INIT_ERROR(error) + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_Covariance: object not initialised', error) + endif + + do_normalise = optional_default(.true., normalise) + if( count( (/ present(i_x), present(i_sparseX) /) ) /= 1 ) then + RAISE_ERROR('gpCoordinates_Covariance: exactly one of i_x or i_sparseX can be present', error) + endif + + if( count( (/ present(j_x), present(j_sparseX) /) ) /= 1 ) then + RAISE_ERROR('gpCoordinates_Covariance: exactly one of j_x or j_sparseX can be present', error) + endif + + x_i => null() + x_j => null() + grad_Covariance_Diag_i => null() + grad_Covariance_Diag_j => null() + + x_i_size = 0 + x_j_size = 0 + + if(present(i_x)) then + x_i => this%x(:,i_x) + covarianceDiag_x_x_i = this%covarianceDiag_x_x(i_x) + grad_Covariance_Diag_i => this%covarianceDiag_x_xPrime(:,i_x) + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + x_i_size = this%x_size(i_x) + endif + endif + + if(present(j_x)) then + x_j => this%x(:,j_x) + covarianceDiag_x_x_j = this%covarianceDiag_x_x(j_x) + grad_Covariance_Diag_j => this%covarianceDiag_x_xPrime(:,j_x) + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + x_j_size = this%x_size(j_x) + endif + endif + + if(present(i_sparseX)) then + x_i => this%sparseX(:,i_sparseX) + covarianceDiag_x_x_i = this%covarianceDiag_sparseX_sparseX(i_sparseX) + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + x_i_size = this%sparseX_size(i_sparseX) + endif + endif + + if(present(j_sparseX)) then + x_j => this%sparseX(:,j_sparseX) + covarianceDiag_x_x_j = this%covarianceDiag_sparseX_sparseX(j_sparseX) + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + x_j_size = this%sparseX_size(j_sparseX) + endif + endif + + if( .not. associated(x_i) .or. .not. associated(x_j) ) then + RAISE_ERROR('gpCoordinates_Covariance: both i and j indices have to be present', error) + endif + + gpCoordinates_Covariance = 0.0_dp + if(present(grad_Covariance_i)) then + grad_Covariance_i = 0.0_dp + endif + if(present(grad_Covariance_j)) then + grad_Covariance_j = 0.0_dp + endif + if(present(grad2_Covariance)) then + grad2_Covariance = 0.0_dp + endif + + if(this%covariance_type == COVARIANCE_ARD_SE .or. this%covariance_type == COVARIANCE_PP) then + allocate(inv_theta2(this%d), & + xI_xJ(this%d), & + xI_xI(this%d), & + xJ_xJ(this%d), & + xI_xJ_theta2(this%d), & + xI_xI_theta2(this%d), & + xJ_xJ_theta2(this%d), & + grad_Covariance_ii(this%d), & + grad_Covariance_jj(this%d)) + endif + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + if(present(i_x)) then + if(present(j_x)) then + gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & + / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) + elseif(present(j_sparseX)) then + gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & + / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) + elseif(present(grad_Covariance_j)) then + RAISE_ERROR('gpCoordinates_Covariance: bond real space derivatives not implemented', error) + endif + elseif(present(i_sparseX)) then + if(present(j_x)) then + gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & + / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) + elseif(present(j_sparseX)) then + gpCoordinates_Covariance = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=x_i, x_i_size=x_i_size, x_j=x_j, x_j_size=x_j_size) & + / sqrt(covarianceDiag_x_x_i * covarianceDiag_x_x_j) + elseif(present(grad_Covariance_j)) then + RAISE_ERROR('gpCoordinates_Covariance: bond real space derivatives not implemented', error) + endif + elseif(present(grad_Covariance_i)) then + RAISE_ERROR('gpCoordinates_Covariance: bond real space derivatives not implemented', error) + endif + elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + gpCoordinates_Covariance = sum(x_i*x_j) + + zeta_int = nint(this%zeta) + if( zeta_int .feq. this%zeta ) then + if(present(grad_Covariance_i)) grad_Covariance_i = this%delta**2 * zeta_int * gpCoordinates_Covariance**(zeta_int-1) * x_j + if(present(grad_Covariance_j)) grad_Covariance_j = this%delta**2 * zeta_int * gpCoordinates_Covariance**(zeta_int-1) * x_i + gpCoordinates_Covariance = this%delta**2 * gpCoordinates_Covariance**zeta_int + else + if(present(grad_Covariance_i)) grad_Covariance_i = this%delta**2 * this%zeta * gpCoordinates_Covariance**(this%zeta-1.0_dp) * x_j + if(present(grad_Covariance_j)) grad_Covariance_j = this%delta**2 * this%zeta * gpCoordinates_Covariance**(this%zeta-1.0_dp) * x_i + gpCoordinates_Covariance = this%delta**2 * gpCoordinates_Covariance**this%zeta + endif + elseif(this%covariance_type == COVARIANCE_ARD_SE ) then + inv_theta2 = 1.0_dp / this%theta**2 + do i_p = 1, this%n_permutations + ! permute only i. theta should be symmetrised by now. + + do ii = 1, this%d + xI_xJ(ii) = x_i(this%permutations(ii,i_p)) - x_j(ii) + end do + xI_xJ_theta2 = xI_xJ * inv_theta2 + + covarianceExp = this%delta**2 * exp( -0.5_dp * dot_product(xI_xJ_theta2,xI_xJ) ) + gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp + + if(present(grad_Covariance_i)) then + do ii = 1, this%d + grad_Covariance_i(this%permutations(ii,i_p)) = grad_Covariance_i(this%permutations(ii,i_p)) - covarianceExp * xI_xJ_theta2(ii) + end do + endif + + if(present(grad_Covariance_j)) then + grad_Covariance_j = grad_Covariance_j + covarianceExp * xI_xJ_theta2 + endif + + if(present(grad2_Covariance)) then + do i = 1, this%d + grad2_Covariance(:,this%permutations(i,i_p)) = grad2_Covariance(:,this%permutations(i,i_p)) - covarianceExp * & + xI_xJ_theta2*xI_xJ_theta2(i) + grad2_Covariance(this%permutations(i,i_p),i) = grad2_Covariance(this%permutations(i,i_p),i) + covarianceExp * inv_theta2(i) + enddo + endif + + !if(present(i_xPrime) .and. .not. present(j_xPrime)) then + + ! gpCoordinates_Covariance = gpCoordinates_Covariance - covarianceExp * (dot_product(xI_xJ_theta,xPrime_i_theta(this%permutations(:,i_p)))*fc_i - dfc_i)*fc_j + + !elseif(.not. present(i_xPrime) .and. present(j_xPrime)) then + + ! gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp * (dot_product(xI_xJ_theta,xPrime_j_theta)*fc_j + dfc_j)*fc_i + + !elseif(present(i_xPrime) .and. present(j_xPrime)) then + + ! gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp * ( dot_product( xPrime_i_theta(this%permutations(:,i_p)), xPrime_j_theta )*fc_i*fc_j + & + ! ( - dot_product( xI_xJ_theta, xPrime_i_theta(this%permutations(:,i_p)) )*fc_i + dfc_i ) * & + ! ( dot_product( xI_xJ_theta, xPrime_j_theta )*fc_j + dfc_j ) ) + + !else + ! gpCoordinates_Covariance = gpCoordinates_Covariance + covarianceExp*fc_i*fc_j + !endif + enddo + + if( this%n_permutations > 1 .and. do_normalise ) then + gpCoordinates_Covariance_ii = 0.0_dp + gpCoordinates_Covariance_jj = 0.0_dp + + if(present(grad_Covariance_i)) then + grad_Covariance_ii = 0.0_dp + endif + + if(present(grad_Covariance_j)) then + grad_Covariance_jj = 0.0_dp + endif + + do i_p = 1, this%n_permutations + + do ii = 1, this%d + xI_xI(ii) = x_i(this%permutations(ii,i_p)) - x_i(ii) + enddo + xI_xI_theta2 = xI_xI * inv_theta2 + + do ii = 1, this%d + xJ_xJ(ii) = x_j(this%permutations(ii,i_p)) - x_j(ii) + enddo + xJ_xJ_theta2 = xJ_xJ * inv_theta2 + + covarianceExp_ii = exp( -0.5_dp * dot_product(xI_xI_theta2,xI_xI) ) + covarianceExp_jj = exp( -0.5_dp * dot_product(xJ_xJ_theta2,xJ_xJ) ) + + gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covarianceExp_ii + gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covarianceExp_jj + + if(present(grad_Covariance_i)) then + grad_Covariance_ii = grad_Covariance_ii + covarianceExp_ii * xI_xI_theta2 + grad_Covariance_ii(this%permutations(:,i_p)) = grad_Covariance_ii(this%permutations(:,i_p)) & + - covarianceExp_ii * xI_xI_theta2 + endif + + if(present(grad_Covariance_j)) then + grad_Covariance_jj = grad_Covariance_jj + covarianceExp_jj * xJ_xJ_theta2 + grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) & + - covarianceExp_jj * xJ_xJ_theta2 + endif + + if(present(grad2_Covariance)) then + RAISE_ERROR('grad2_Covariance for n_permutations > 1 not implemented yet',error) + endif + enddo + + normalisation = sqrt(gpCoordinates_Covariance_ii * gpCoordinates_Covariance_jj) + + if(present(grad_Covariance_i)) then + grad_Covariance_i = grad_Covariance_i / normalisation - 0.5_dp * grad_Covariance_ii * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_ii + endif + + if(present(grad_Covariance_j)) then + grad_Covariance_j = grad_Covariance_j / normalisation - 0.5_dp * grad_Covariance_jj * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_jj + endif + + gpCoordinates_Covariance = gpCoordinates_Covariance / normalisation + else + normalisation = 1.0_dp + endif + + gpCoordinates_Covariance = gpCoordinates_Covariance + this%f0**2 + elseif(this%covariance_type == COVARIANCE_PP ) then + allocate(distance_matrix(this%d, this%d)) + + inv_theta2 = 1.0_dp / this%theta**2 + + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - x_j(jj) )**2 / this%theta(ii)**2 + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle + + r_ij = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) + if( r_ij >= 1.0_dp ) cycle + + covariancePP_ij = this%delta**2 * covariancePP(r_ij,PP_Q, this%d) + gpCoordinates_Covariance = gpCoordinates_Covariance + covariancePP_ij + + if( ( present(grad_Covariance_i) .or. present(grad_Covariance_j) ) .and. (r_ij > 0.0_dp) ) then + grad_covariancePP_ij = this%delta**2 * grad_covariancePP(r_ij,PP_Q, this%d) / r_ij + xI_xJ(:) = x_i(this%permutations(:,i_p)) - x_j(:) + + if(present(grad_Covariance_i)) & + grad_Covariance_i(this%permutations(:,i_p)) = grad_Covariance_i(this%permutations(:,i_p)) + grad_covariancePP_ij * xI_xJ(:) + + if(present(grad_Covariance_j)) & + grad_Covariance_j(:) = grad_Covariance_j(:) - grad_covariancePP_ij * xI_xJ(:) + endif + enddo ! i_p + + if(present(grad_Covariance_i)) grad_Covariance_i = grad_Covariance_i * inv_theta2 + if(present(grad_Covariance_j)) grad_Covariance_j = grad_Covariance_j * inv_theta2 + + do_normalise = do_normalise .and. ( gpCoordinates_Covariance .fne. 0.0_dp ) + if( this%n_permutations > 1 .and. do_normalise ) then + gpCoordinates_Covariance_ii = 0.0_dp + gpCoordinates_Covariance_jj = 0.0_dp + + if(present(grad_Covariance_i)) then + grad_Covariance_ii = 0.0_dp + endif + + if(present(grad_Covariance_j)) then + grad_Covariance_jj = 0.0_dp + endif + + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - x_i(jj) )**2 * inv_theta2(ii) + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle + + r_ii = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) + if( r_ii >= 1.0_dp ) cycle + + covariancePP_ii = covariancePP(r_ii,PP_Q, this%d) + gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covariancePP_ii + + if(present(grad_Covariance_i) .and. (r_ii > 0.0_dp)) then + xI_xI(:) = x_i(this%permutations(:,i_p)) - x_i(:) + + grad_covariancePP_ii = grad_covariancePP(r_ii,PP_Q, this%d) / r_ii + grad_Covariance_ii = grad_Covariance_ii + grad_covariancePP_ii * xI_xI(:) + grad_Covariance_ii(this%permutations(:,i_p)) = grad_Covariance_ii(this%permutations(:,i_p)) - grad_covariancePP_ii * xI_xI + endif + enddo + if(present(grad_Covariance_i)) grad_Covariance_ii = grad_Covariance_ii * inv_theta2 + + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_j(ii) - x_j(jj) )**2 * inv_theta2(ii) + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle + + r_jj = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) + if( r_jj >= 1.0_dp ) cycle + + covariancePP_jj = covariancePP(r_jj,PP_Q, this%d) + gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covariancePP_jj + + if(present(grad_Covariance_j) .and. (r_jj > 0.0_dp)) then + xJ_xJ(:) = x_j(this%permutations(:,i_p)) - x_j(:) + + grad_covariancePP_jj = grad_covariancePP(r_jj,PP_Q, this%d) / r_jj + grad_Covariance_jj = grad_Covariance_jj + grad_covariancePP_jj * xJ_xJ(:) + grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) - grad_covariancePP_jj * xJ_xJ(:) + endif + enddo + if(present(grad_Covariance_j)) grad_Covariance_jj = grad_Covariance_jj * inv_theta2 + + normalisation = sqrt(gpCoordinates_Covariance_ii * gpCoordinates_Covariance_jj) + + if(present(grad_Covariance_i)) then + grad_Covariance_i = grad_Covariance_i / normalisation - 0.5_dp * grad_Covariance_ii * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_ii + endif + + if(present(grad_Covariance_j)) then + grad_Covariance_j = grad_Covariance_j / normalisation - 0.5_dp * grad_Covariance_jj * gpCoordinates_Covariance / normalisation / gpCoordinates_Covariance_jj + endif + + gpCoordinates_Covariance = gpCoordinates_Covariance / normalisation + else + normalisation = 1.0_dp + endif + + gpCoordinates_Covariance = gpCoordinates_Covariance + this%f0**2 + endif ! this%covariance_type + + if(allocated(inv_theta2)) deallocate(inv_theta2) + if(allocated(xI_xJ)) deallocate(xI_xJ) + if(allocated(xI_xI)) deallocate(xI_xI) + if(allocated(xJ_xJ)) deallocate(xJ_xJ) + if(allocated(xI_xJ_theta2)) deallocate(xI_xJ_theta2) + if(allocated(xI_xI_theta2)) deallocate(xI_xI_theta2) + if(allocated(xJ_xJ_theta2)) deallocate(xJ_xJ_theta2) + if(allocated(grad_Covariance_ii)) deallocate(grad_Covariance_ii) + if(allocated(grad_Covariance_jj)) deallocate(grad_Covariance_jj) + if( allocated( distance_matrix ) ) deallocate(distance_matrix) + + endfunction gpCoordinates_Covariance + + subroutine gpCoordinates_gpCovariance_bond_real_space_Initialise( this, error ) + type(gpCoordinates), intent(inout) :: this + integer, optional, intent(out) :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + if (.not. this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + RAISE_ERROR('gpCoordinates_gpCovariance_bond_real_space_Initialise: covariance is not bond_real_space', error) + endif + + call gpCovariance_bond_real_space_Finalise(this%bond_real_space_cov, error) + + call initialise(params) + call param_register(params, 'n', '2', this%bond_real_space_cov%n, & + help_string="Covariance degree for bond_real_space-type descriptors") + call param_register(params, 'atom_sigma', '0.0', this%bond_real_space_cov%atom_sigma, & + help_string="Atoms sigma for bond_real_space-type descriptors") + + if (.not. param_read_line(params, string(this%descriptor_str), ignore_unknown=.true., task='gpCoordinates_gpCovariance_bond_real_space_Initialise descriptor_str')) then + RAISE_ERROR("gpCoordinates_gpCovariance_bond_real_space_Initialise failed to parse descriptor_str='"//trim(string(this%descriptor_str))//"'", error) + endif + call finalise(params) + + this%bond_real_space_cov%delta = this%delta + + this%bond_real_space_cov%initialised = .true. + + endsubroutine gpCoordinates_gpCovariance_bond_real_space_Initialise + + function gpCovariance_bond_real_space_Calc( this, x_i, x_i_size, x_j, x_j_size, xPrime_i, xPrime_j, xPrime_ij, error ) + type(gpCovariance_bond_real_space), intent(in) :: this + real(dp), intent(in) :: x_i(0:), x_j(0:) + integer, intent(in) :: x_i_size, x_j_size + real(dp), dimension(:), intent(out), optional, pointer :: xPrime_i, xPrime_j + real(dp), dimension(:,:), intent(out), optional, pointer :: xPrime_ij + integer, intent(out), optional :: error + + real(dp) :: gpCovariance_bond_real_space_Calc + real(dp) :: gpCovariance_bond_real_space_Calc_compensation ! Running compensation for Kahan summation algorithm + + integer :: i, j, k, m, n + integer :: x_i_N, x_j_N + complex(dp), allocatable :: gamma_i(:,:), gamma_j(:,:) + real(dp), allocatable :: z_i(:), z_j(:), c_i(:), c_j(:) + real(dp) :: x_i_self_overlap, x_j_self_overlap + integer, allocatable :: iter_index(:) + + logical :: do_derivative, do_xPrime_i, do_xPrime_j, do_xPrime_ij + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCovariance_bond_real_space_Calc: object not initialised', error) + endif + + do_xPrime_i = .false. + do_xPrime_j = .false. + do_xPrime_ij = .false. + if(present(xPrime_i)) do_xPrime_i = associated(xPrime_i) + if(present(xPrime_j)) do_xPrime_j = associated(xPrime_j) + if(present(xPrime_ij)) do_xPrime_ij = associated(xPrime_ij) + + do_derivative = (do_xPrime_i .or. do_xPrime_j .or. do_xPrime_ij) + + if( do_derivative ) then + RAISE_ERROR('gpCovariance_bond_real_space_Calc: derivatives not implemented', error) + endif + + ! + ! x_i: get x_i_N, gamma_i, z_i, c_i, x_i_self_overlap + ! + x_i_N = nint(x_i(0)) + + allocate( gamma_i(x_i_N,x_i_N), z_i(x_i_N), c_i(x_i_N) ) + + gamma_i = cmplx(0.0_dp, 0.0_dp, dp) + z_i = 0.0_dp + c_i = 0.0_dp + + do i = 1, x_i_N + do j = 1, x_i_N + gamma_i(i,j) = cmplx(x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j) - 1), x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j)), dp) + + if (i == j) then + gamma_i(i,j) = cmplx(x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j) - 1), 0.0_dp, dp) + + z_i(i) = x_i(1 + x_i_N + (2 * (i - 1) * x_i_N) + (2 * j)) + endif + enddo + enddo + + x_i_self_overlap = x_i(1) + + c_i = x_i(2:x_i_N + 1) + + ! + ! x_j: get x_j_N, gamma_j, z_j, c_j, x_j_self_overlap + ! + x_j_N = nint(x_j(0)) + + allocate( gamma_j(x_j_N,x_j_N), z_j(x_j_N), c_j(x_j_N) ) + + gamma_j = cmplx(0.0_dp, 0.0_dp, dp) + z_j = 0.0_dp + c_j = 0.0_dp + + do i = 1, x_j_N + do j = 1, x_j_N + gamma_j(i,j) = cmplx(x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j) - 1), x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j)), dp) + + if (i == j) then + gamma_j(i,j) = cmplx(x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j) - 1), 0.0_dp, dp) + + z_j(i) = x_j(1 + x_j_N + (2 * (i - 1) * x_j_N) + (2 * j)) + endif + enddo + enddo + + x_j_self_overlap = x_j(1) + + c_j = x_j(2:x_j_N + 1) + + ! + ! Start with gpCovariance_bond_real_space_Calc = 0 + ! + gpCovariance_bond_real_space_Calc = 0.0_dp + gpCovariance_bond_real_space_Calc_compensation = 0.0_dp ! Running compensation for Kahan summation algorithm + + allocate( iter_index(this%n) ) + + call gpCovariance_bond_real_space_sum(1, 1) + + gpCovariance_bond_real_space_Calc = gpCovariance_bond_real_space_Calc * (2.0_dp / (x_i_self_overlap + x_j_self_overlap))**this%n + + contains + + recursive subroutine gpCovariance_bond_real_space_sum(n, iter) + integer :: n, iter + integer :: i(n), j(n), k, m, l + integer :: iter_index_sorted(n), powers(n) + real(dp) :: coefficient, arg_z, arg_r2, arg_gamma + complex(dp) :: arg_gamma_complex + real(dp) :: x, x_mirror + real(dp) :: y, t ! Intermediate variables for Kahan summation algorithm + + do k = iter, x_i_N*x_j_N + iter_index(n) = k + + if (n < this%n) then + call gpCovariance_bond_real_space_sum(n + 1, k) + else + iter_index_sorted = iter_index + powers = 1 + if (n > 1) then + ! + ! For large n could replace with heapsort? + ! + call sort_array(iter_index_sorted) + + do m = 1, (n - 1) + if (iter_index_sorted(m) == iter_index_sorted(m + 1)) then + powers(m + 1) = powers(m + 1) + powers(m) + powers(m) = 0 + endif + enddo + endif + + do m = 1, n + i(m) = 1 + ((iter_index(m) - 1) / x_i_N) + j(m) = 1 + mod(iter_index(m) - 1, x_j_N) + enddo + + coefficient = factorial(n) + arg_z = 0.0_dp + arg_r2 = 0.0_dp + arg_gamma_complex = cmplx(0.0_dp, 0.0_dp, dp) + do m = 1, n + if (powers(m) /= 0) then + coefficient = coefficient / factorial(powers(m)) + coefficient = coefficient * (c_i(i(m)) * c_j(j(m)))**powers(m) + endif + + arg_z = arg_z + z_i(i(m)) * z_j(j(m)) + arg_r2 = arg_r2 + real(gamma_i(i(m),i(m)), dp) + real(gamma_j(j(m),j(m)), dp) + arg_gamma_complex = arg_gamma_complex + gamma_i(i(m),i(m)) * conjg(gamma_j(j(m),j(m))) + if (m < n) then + do l = (m + 1), n + arg_gamma_complex = arg_gamma_complex + 2.0_dp * gamma_i(i(m),i(l)) * conjg(gamma_j(j(m),j(l))) + enddo + endif + enddo + arg_z = arg_z / (2.0_dp * this%atom_sigma**2) + arg_r2 = - arg_r2 / (4.0_dp * this%atom_sigma**2) + arg_gamma = sqrt(real(arg_gamma_complex, dp)) / (2.0_dp * this%atom_sigma**2) + + ! + ! Use asymptotic expansion of Bessel function + ! + if (arg_gamma < besseli_max_x) then + x = besseli0(arg_gamma) + + x_mirror = exp(- arg_z + arg_r2) * x + x = exp(arg_z + arg_r2) * x + else + x = 1.0_dp + do m = 1, besseli_max_n + x = x + besseli0_c(m) / arg_gamma**m + enddo + x = x / sqrt(2.0_dp * pi * arg_gamma) + + x_mirror = exp(- arg_z + arg_r2 + arg_gamma) * x + x = exp(arg_z + arg_r2 + arg_gamma) * x + endif + + x_mirror = coefficient * x_mirror + x = coefficient * x + + ! + ! Kahan summation algorithm for x_mirror + ! + y = x_mirror - gpCovariance_bond_real_space_Calc_compensation + t = gpCovariance_bond_real_space_Calc + y + gpCovariance_bond_real_space_Calc_compensation = (t - gpCovariance_bond_real_space_Calc) - y + gpCovariance_bond_real_space_Calc = t + ! + ! Kahan summation algorithm for x + ! + y = x - gpCovariance_bond_real_space_Calc_compensation + t = gpCovariance_bond_real_space_Calc + y + gpCovariance_bond_real_space_Calc_compensation = (t - gpCovariance_bond_real_space_Calc) - y + gpCovariance_bond_real_space_Calc = t + endif + enddo + + endsubroutine gpCovariance_bond_real_space_sum + + endfunction gpCovariance_bond_real_space_Calc + + function besseli0(x) + + real(dp), intent(in) :: x + real(dp) :: besseli0 + + real(dp) :: x2, r, k + integer :: i + + x2 = x**2 + + if(x == 0.0_dp) then + besseli0 = 1.0_dp + elseif( x < besseli_max_x ) then + besseli0 = 1.0_dp + r = 1.0_dp + k = 1.0_dp + do while ( abs(r/besseli0) > NUMERICAL_ZERO ) + r = 0.25_dp * r * x2 / k**2 + besseli0 = besseli0 + r + k = k + 1.0_dp + enddo + else + besseli0 = 1.0_dp + do i = 1, besseli_max_n + besseli0 = besseli0 + besseli0_c(i)/x**i + enddo + besseli0 = besseli0 * exp(x) / sqrt(2.0_dp*pi*x) + endif + + endfunction besseli0 + + function besseli1(x) + + real(dp), intent(in) :: x + real(dp) :: besseli1 + + real(dp) :: x2, r, k + integer :: i + + x2 = x**2 + + if(x == 0.0_dp) then + besseli1 = 0.0_dp + elseif( x < besseli_max_x ) then + besseli1 = 1.0_dp + r = 1.0_dp + k = 1.0_dp + do while ( abs(r/besseli1) > NUMERICAL_ZERO ) + r = 0.25_dp * r * x2 / (k*(k+1.0_dp)) + besseli1 = besseli1 + r + k = k + 1.0_dp + enddo + besseli1 = besseli1 * 0.5_dp * x + else + besseli1 = 1.0_dp + do i = 1, besseli_max_n + besseli1 = besseli1 + besseli1_c(i)/x**i + enddo + besseli1 = besseli1 * exp(x) / sqrt(2.0_dp*pi*x) + endif + + endfunction besseli1 + + pure function covariancePP(r,q,d) + real(dp), intent(in) :: r + integer, intent(in) :: q, d + real(dp) :: covariancePP + + real(dp) :: j + integer :: j_int + + j_int = d/2 + q + 1 + j = float(j_int) + + if( r > 1.0_dp ) then + covariancePP = 0.0_dp + elseif( r < 0.0_dp ) then + covariancePP = 1.0_dp + else + if( q == 0 ) then + covariancePP = (1.0_dp - r)**j_int + elseif( q == 1 ) then + covariancePP = (1.0_dp - r)**(j_int+1) * ( (j+1.0_dp)*r + 1.0_dp ) + elseif( q == 2) then + covariancePP = (1.0_dp - r)**(j_int+2) * ( (j**2 + 4.0_dp*j + 3.0_dp) * r**2 + (3.0_dp*j+6.0_dp)*r + 3.0_dp ) / 3.0_dp + elseif( q == 3) then + covariancePP = (1.0_dp - r)**(j_int+3) * & + ( (j**3 + 9.0_dp*j**2 + 23.0_dp*j + 15.0_dp)*r**3 + & + (6.0_dp * j**2 + 36.0_dp*j + 45.0_dp) * r**2 + & + (15.0_dp*j+45.0_dp)*r + 15.0_dp ) / 15.0_dp + endif + endif + + endfunction covariancePP + + pure function grad_covariancePP(r,q,d) + real(dp), intent(in) :: r + integer, intent(in) :: q, d + real(dp) :: grad_covariancePP + + real(dp) :: j + integer :: j_int + + j_int = d/2 + q + 1 + j = float(j_int) + + if( r > 1.0_dp ) then + grad_covariancePP = 0.0_dp + elseif( r < 0.0_dp ) then + grad_covariancePP = 0.0_dp + else + if( q == 0 ) then + grad_covariancePP = - j * (1.0_dp - r)**(j_int-1) + elseif( q == 1 ) then + grad_covariancePP = - (j+1.0_dp) * (1.0_dp - r)**j_int * ( (j+1.0_dp)*r + 1.0_dp ) + & + (1.0_dp - r)**(j_int+1) * (j+1.0_dp) + elseif( q == 2) then + grad_covariancePP = - (j+2.0_dp) * (1.0_dp - r)**(j_int+1) * ( (j**2 + 4.0_dp*j + 3.0_dp) * r**2 + (3.0_dp*j+6.0_dp)*r + 3.0_dp ) / 3.0_dp + & + (1.0_dp - r)**(j_int+2) * ( 2.0_dp * (j**2 + 4.0_dp*j + 3.0_dp) * r + (3.0_dp*j+6.0_dp) ) / 3.0_dp + elseif( q == 3) then + grad_covariancePP = -(j+3.0_dp) * (1.0_dp - r)**(j_int+2) * & + ( (j**3 + 9.0_dp*j**2 + 23.0_dp*j + 15.0_dp)*r**3 + & + (6.0_dp * j**2 + 36.0_dp*j + 45.0_dp) * r**2 + & + (15.0_dp*j+45.0_dp)*r + 15.0_dp ) / 15.0_dp + & + (1.0_dp - r)**(j_int+3) * & + ( 3.0_dp * (j**3 + 9.0_dp*j**2 + 23.0_dp*j + 15.0_dp)*r**2 + & + 2.0_dp * (6.0_dp * j**2 + 36.0_dp*j + 45.0_dp) * r + & + (15.0_dp*j+45.0_dp) ) / 15.0_dp + endif + endif + + endfunction grad_covariancePP + + function gpCovariance_atom_real_space_Calc( this, x_i, x_i_size, x_j, x_j_size, xPrime_i, xPrime_j, xPrime_ij, error ) + type(gpCovariance_atom_real_space), intent(in) :: this + real(dp), dimension(:), intent(in) :: x_i, x_j + integer, intent(in) :: x_i_size, x_j_size + real(dp), dimension(:), intent(out), optional, pointer :: xPrime_i, xPrime_j + real(dp), dimension(:,:), intent(out), optional, pointer :: xPrime_ij + integer, intent(out), optional :: error + + real(dp) :: gpCovariance_atom_real_space_Calc + + type(neighbour_descriptor), dimension(:), allocatable :: neighbour_i, neighbour_j, grad_spherical_i, grad_spherical_j + type(neighbour_descriptor), dimension(:,:), allocatable :: grad_spherical_i_radial_j, grad_spherical_j_radial_i + + real(dp) :: r1, r2, arg_bess, fac_exp, mo_spher_bess_fi_ki_lmm, mo_spher_bess_fi_ki_lm, & + mo_spher_bess_fi_ki_l, mo_spher_bess_fi_ki_lp, mo_spher_bess_fi_ki_lpp, & + grad_mo_spher_bess_fi_ki_l, grad2_mo_spher_bess_fi_ki_l, & + grad_arg_bess1, grad_arg_bess2, grad_fac_exp1, grad_fac_exp2, radial, grad_radial_i, grad_radial_j, grad2_radial_ij, & + fcut1, fcut2, dfcut1, dfcut2, fac_r1r2, grad_fac_r1r2_1, grad_fac_r1r2_2, grad2_fac_exp, grad2_fac_r1r2 + + real(dp), dimension(1) :: real_mould + + integer :: i, j, i_data, j_data, n1, n2, l, l1, l2, m1, m2, n_neighbour_i, n_neighbour_j, real_mould_size + + logical :: do_derivative, do_xPrime_i, do_xPrime_j, do_xPrime_ij + + complex(dp) :: I_lm1m2, tmp_complex + type(cplx_2d_array), dimension(:), allocatable :: integral_r + + type grad_r_type + type(cplx_2d_array), dimension(:), allocatable :: integral_r + endtype grad_r_type + + type real_1d_array + real(dp), dimension(:), allocatable :: value + endtype real_1d_array + + type(grad_r_type), dimension(:), allocatable :: grad_ri, grad_rj + type(grad_r_type), dimension(:,:), allocatable :: grad_rij + + type(real_1d_array), dimension(:,:), allocatable :: grad_spherical_ij + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCovariance_atom_real_space_Calc: object not initialised', error) + endif + + do_xPrime_i = .false. + do_xPrime_j = .false. + do_xPrime_ij = .false. + if(present(xPrime_i)) do_xPrime_i = associated(xPrime_i) + if(present(xPrime_j)) do_xPrime_j = associated(xPrime_j) + if(present(xPrime_ij)) do_xPrime_ij = associated(xPrime_ij) + + do_derivative = (do_xPrime_i .or. do_xPrime_j .or. do_xPrime_ij) + + call gpRealArray_NeighbourDescriptor(this,x_i,x_i_size,neighbour_i,n_neighbour_i) + call gpRealArray_NeighbourDescriptor(this,x_j,x_j_size,neighbour_j,n_neighbour_j) + + if(do_xPrime_i .or. do_xPrime_ij) then + allocate(grad_spherical_i(n_neighbour_i)) + allocate(grad_ri(n_neighbour_i)) + + do i = 1, n_neighbour_i + + + allocate(grad_ri(i)%integral_r(0:this%l_max)) + allocate(grad_spherical_i(i)%spherical_harmonics(0:this%l_max)) + + do l = 0, this%l_max + allocate(grad_spherical_i(i)%spherical_harmonics(l)%value(-l:l)) + grad_spherical_i(i)%spherical_harmonics(l)%value = CPLX_ZERO + + allocate(grad_ri(i)%integral_r(l)%value(-l:l,-l:l)) + grad_ri(i)%integral_r(l)%value = CPLX_ZERO + enddo + enddo + endif + + if(do_xPrime_j .or. do_xPrime_ij) then + allocate(grad_spherical_j(n_neighbour_j)) + allocate(grad_rj(n_neighbour_j)) + + do i = 1, n_neighbour_j + + allocate(grad_rj(i)%integral_r(0:this%l_max)) + allocate(grad_spherical_j(i)%spherical_harmonics(0:this%l_max)) + + do l = 0, this%l_max + allocate(grad_spherical_j(i)%spherical_harmonics(l)%value(-l:l)) + grad_spherical_j(i)%spherical_harmonics(l)%value = CPLX_ZERO + + allocate(grad_rj(i)%integral_r(l)%value(-l:l,-l:l)) + grad_rj(i)%integral_r(l)%value = CPLX_ZERO + enddo + enddo + endif + + if(do_xPrime_ij) then + allocate(grad_rij(n_neighbour_j,n_neighbour_i)) + allocate(grad_spherical_ij(n_neighbour_j,n_neighbour_i)) + allocate(grad_spherical_i_radial_j(n_neighbour_j,n_neighbour_i)) + allocate(grad_spherical_j_radial_i(n_neighbour_j,n_neighbour_i)) + + do i = 1, n_neighbour_i + do j = 1, n_neighbour_j + + allocate(grad_spherical_ij(j,i)%value(0:this%l_max)) + grad_spherical_ij(j,i)%value = 0.0_dp + + allocate(grad_rij(j,i)%integral_r(0:this%l_max)) + + allocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics(0:this%l_max)) + allocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics(0:this%l_max)) + + do l = 0, this%l_max + allocate(grad_rij(j,i)%integral_r(l)%value(-l:l,-l:l)) + grad_rij(j,i)%integral_r(l)%value = CPLX_ZERO + + allocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics(l)%value(-l:l)) + grad_spherical_i_radial_j(j,i)%spherical_harmonics(l)%value = CPLX_ZERO + + allocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value(-l:l)) + grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value = CPLX_ZERO + enddo + enddo + enddo + + endif + + allocate(integral_r(0:this%l_max)) + + do l = 0, this%l_max + allocate(integral_r(l)%value(-l:l,-l:l)) + integral_r(l)%value = CPLX_ZERO + enddo + + if(do_xPrime_i) xPrime_i = 0.0_dp + if(do_xPrime_j) xPrime_j = 0.0_dp + if(do_xPrime_ij) xPrime_ij = 0.0_dp + + ! Overlap of central atoms + integral_r(0)%value(0,0) = 0.25_dp/PI !/ this%atom_sigma**1.5_dp + + ! Overlaps of central atom of first environment with the other atoms in the second. + do n1 = 1, n_neighbour_i + r1 = neighbour_i(n1)%r + if(r1 > this%cutoff) cycle + fcut1 = coordination_function(r1,this%cutoff,this%cutoff_transition_width) + fac_exp = exp(-0.5_dp*this%atom_sigma*r1**2) * 0.25_dp/PI + fac_r1r2 = fac_exp * fcut1 + + integral_r(0)%value(0,0) = integral_r(0)%value(0,0) + fac_r1r2 + + if(do_xPrime_i) then + dfcut1 = dcoordination_function(r1,this%cutoff,this%cutoff_transition_width) + grad_fac_exp1 = -fac_exp*this%atom_sigma*r1 + grad_fac_r1r2_1 = fac_exp * dfcut1 + grad_fac_exp1 * fcut1 + grad_ri(n1)%integral_r(0)%value(0,0) = grad_ri(n1)%integral_r(0)%value(0,0) + grad_fac_r1r2_1 + endif + enddo + + ! Overlaps of central atom of second environment with the other atoms in the first. + do n2 = 1, n_neighbour_j + r2 = neighbour_j(n2)%r + if(r2 > this%cutoff) cycle + fcut2 = coordination_function(r2,this%cutoff,this%cutoff_transition_width) + fac_exp = exp(-0.5_dp*this%atom_sigma*r2**2) * 0.25_dp/PI + fac_r1r2 = fac_exp * fcut2 + + integral_r(0)%value(0,0) = integral_r(0)%value(0,0) + fac_r1r2 + + if(do_xPrime_j) then + dfcut2 = dcoordination_function(r2,this%cutoff,this%cutoff_transition_width) + grad_fac_exp2 = -fac_exp*this%atom_sigma*r2 + grad_fac_r1r2_2 = fac_exp * dfcut2 + grad_fac_exp2 * fcut2 + grad_rj(n2)%integral_r(0)%value(0,0) = grad_rj(n2)%integral_r(0)%value(0,0) + grad_fac_r1r2_2 + endif + enddo + + ! Overlaps of non-central atoms. + do n1 = 1, n_neighbour_i + r1 = neighbour_i(n1)%r + + if(r1 > this%cutoff) cycle + fcut1 = coordination_function(r1,this%cutoff,this%cutoff_transition_width) + dfcut1 = dcoordination_function(r1,this%cutoff,this%cutoff_transition_width) + do n2 = 1, n_neighbour_j + r2 = neighbour_j(n2)%r + + if(r2 > this%cutoff) cycle + fcut2 = coordination_function(r2,this%cutoff,this%cutoff_transition_width) + dfcut2 = dcoordination_function(r2,this%cutoff,this%cutoff_transition_width) + + arg_bess = this%atom_sigma*r1*r2 + fac_exp = exp(-0.5_dp*this%atom_sigma*(r1**2+r2**2)) + fac_r1r2 = fac_exp * fcut1 * fcut2 + + if(do_xPrime_i .or. do_xPrime_ij) then + grad_arg_bess1 = this%atom_sigma*r2 + grad_fac_exp1 = -fac_exp*this%atom_sigma*r1 + grad_fac_r1r2_1 = (fac_exp * dfcut1 + grad_fac_exp1 * fcut1) * fcut2 + endif + + if(do_xPrime_j .or. do_xPrime_ij) then + grad_arg_bess2 = this%atom_sigma*r1 + grad_fac_exp2 = -fac_exp*this%atom_sigma*r2 + grad_fac_r1r2_2 = (fac_exp * dfcut2 + grad_fac_exp2 * fcut2) * fcut1 + endif + + if(do_xPrime_ij) then + grad2_fac_exp = fac_exp * this%atom_sigma**2 * r1*r2 + grad2_fac_r1r2 = grad2_fac_exp*fcut1*fcut2 + grad_fac_exp1*fcut1*dfcut2 + grad_fac_exp2*dfcut1*fcut2 + fac_exp*dfcut1*dfcut2 + endif + + do l = 0, this%l_max + if( l == 0 ) then + mo_spher_bess_fi_ki_lm = cosh(arg_bess)/arg_bess + mo_spher_bess_fi_ki_l = sinh(arg_bess)/arg_bess + if(do_derivative) mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess + if(do_xPrime_ij) mo_spher_bess_fi_ki_lpp = mo_spher_bess_fi_ki_l - (2*l+3)*mo_spher_bess_fi_ki_lp / arg_bess + else + mo_spher_bess_fi_ki_lmm = mo_spher_bess_fi_ki_lm + mo_spher_bess_fi_ki_lm = mo_spher_bess_fi_ki_l + if(do_derivative) then + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lp + mo_spher_bess_fi_ki_lp = mo_spher_bess_fi_ki_lm - (2*l+1)*mo_spher_bess_fi_ki_l / arg_bess + if(do_xPrime_ij) mo_spher_bess_fi_ki_lpp = mo_spher_bess_fi_ki_l - (2*l+3)*mo_spher_bess_fi_ki_lp / arg_bess + else + mo_spher_bess_fi_ki_l = mo_spher_bess_fi_ki_lmm - (2*l-1)*mo_spher_bess_fi_ki_lm / arg_bess + endif + endif + + if(do_derivative) grad_mo_spher_bess_fi_ki_l = l * mo_spher_bess_fi_ki_l / arg_bess + mo_spher_bess_fi_ki_lp + if(do_xPrime_ij) grad2_mo_spher_bess_fi_ki_l = ( l*(2*l+3)*(l-1) + (1.0_dp+2*l)*arg_bess**2 ) * & + mo_spher_bess_fi_ki_lp / arg_bess**3 + & + ( 1.0_dp + l*(l-1)/arg_bess**2 ) * mo_spher_bess_fi_ki_lpp + + !radial = mo_spher_bess_fi_ki_l*fac_exp + radial = mo_spher_bess_fi_ki_l*fac_r1r2 + + !if(do_xPrime_i .or. do_xPrime_ij) grad_radial_i = grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp1 + if(do_xPrime_i .or. do_xPrime_ij) grad_radial_i = grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * fac_r1r2 + mo_spher_bess_fi_ki_l * grad_fac_r1r2_1 + + !if(do_xPrime_j .or. do_xPrime_ij) grad_radial_j = grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * fac_exp + mo_spher_bess_fi_ki_l * grad_fac_exp2 + if(do_xPrime_j .or. do_xPrime_ij) grad_radial_j = grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * fac_r1r2 + mo_spher_bess_fi_ki_l * grad_fac_r1r2_2 + + if(do_xPrime_ij) then + !grad2_radial_ij = fac_exp * this%atom_sigma**2 * r1 * r2 * mo_spher_bess_fi_ki_l + & + !grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * grad_fac_exp2 + & + !grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * grad_fac_exp1 + & + !fac_exp * ( this%atom_sigma * grad_mo_spher_bess_fi_ki_l + grad_arg_bess1*grad_arg_bess2*grad2_mo_spher_bess_fi_ki_l ) + grad2_radial_ij = grad2_fac_r1r2 * mo_spher_bess_fi_ki_l + & + grad_mo_spher_bess_fi_ki_l * grad_arg_bess1 * grad_fac_r1r2_2 + & + grad_mo_spher_bess_fi_ki_l * grad_arg_bess2 * grad_fac_r1r2_1 + & + fac_r1r2 * ( this%atom_sigma * grad_mo_spher_bess_fi_ki_l + grad_arg_bess1*grad_arg_bess2*grad2_mo_spher_bess_fi_ki_l ) + + grad_spherical_ij(n2,n1)%value(l) = grad_spherical_ij(n2,n1)%value(l) + & + radial + endif + + do m1 = -l, l + if(do_xPrime_i .or. do_xPrime_ij) then + grad_spherical_i(n1)%spherical_harmonics(l)%value(m1) = & + grad_spherical_i(n1)%spherical_harmonics(l)%value(m1) + & + radial * neighbour_j(n2)%spherical_harmonics(l)%value(m1) + endif + + if(do_xPrime_j .or. do_xPrime_ij) then + grad_spherical_j(n2)%spherical_harmonics(l)%value(m1) = & + grad_spherical_j(n2)%spherical_harmonics(l)%value(m1) + & + radial * conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) + endif + + if(do_xPrime_ij) then + grad_spherical_i_radial_j(n2,n1)%spherical_harmonics(l)%value(m1) = & + grad_spherical_i_radial_j(n2,n1)%spherical_harmonics(l)%value(m1) + & + grad_radial_j * neighbour_j(n2)%spherical_harmonics(l)%value(m1) + + grad_spherical_j_radial_i(n2,n1)%spherical_harmonics(l)%value(m1) = & + grad_spherical_j_radial_i(n2,n1)%spherical_harmonics(l)%value(m1) + & + grad_radial_i * conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) + endif + + do m2 = -l, l + I_lm1m2 = radial * & + conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & + neighbour_j(n2)%spherical_harmonics(l)%value(m2) + + integral_r(l)%value(m2,m1) = integral_r(l)%value(m2,m1) + I_lm1m2 + + if(do_xPrime_i .or. do_xPrime_ij) then + grad_ri(n1)%integral_r(l)%value(m2,m1) = grad_ri(n1)%integral_r(l)%value(m2,m1) + & + grad_radial_i * & + conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & + neighbour_j(n2)%spherical_harmonics(l)%value(m2) + endif + + if(do_xPrime_j .or. do_xPrime_ij) then + grad_rj(n2)%integral_r(l)%value(m2,m1) = grad_rj(n2)%integral_r(l)%value(m2,m1) + & + grad_radial_j * & + conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & + neighbour_j(n2)%spherical_harmonics(l)%value(m2) + endif + + if(do_xPrime_ij) then + grad_rij(n2,n1)%integral_r(l)%value(m2,m1) = grad_rij(n2,n1)%integral_r(l)%value(m2,m1) + & + grad2_radial_ij * & + conjg(neighbour_i(n1)%spherical_harmonics(l)%value(m1)) * & + neighbour_j(n2)%spherical_harmonics(l)%value(m2) + endif + + enddo + enddo + enddo + enddo + enddo + + gpCovariance_atom_real_space_Calc = 0.0_dp + + do l = 0, this%l_max + gpCovariance_atom_real_space_Calc = gpCovariance_atom_real_space_Calc + sum(real(integral_r(l)%value)**2) + sum(aimag(integral_r(l)%value)**2) + enddo + + if(do_xPrime_i) then + i_data = 0 + do i = 1, n_neighbour_i + + i_data = i_data + 1 + do l = 0, this%l_max + xPrime_i(i_data) = xPrime_i(i_data) + & + sum(real(integral_r(l)%value)*real(grad_ri(i)%integral_r(l)%value)) + & + sum(aimag(integral_r(l)%value)*aimag(grad_ri(i)%integral_r(l)%value)) + enddo + i_data = i_data + 1 + xPrime_i(i_data) = 0.0_dp + + do l = 0, this%l_max + real_mould_size = size(transfer(grad_spherical_i(i)%spherical_harmonics(l)%value(-l:l),real_mould)) + xPrime_i(i_data+1:i_data+real_mould_size) = transfer(matmul(grad_spherical_i(i)%spherical_harmonics(l)%value,conjg(integral_r(l)%value)),real_mould) + i_data = i_data + real_mould_size + enddo + enddo + + xPrime_i = xPrime_i * 2.0_dp + endif + + if(do_xPrime_j) then + i_data = 0 + do i = 1, n_neighbour_j + + i_data = i_data + 1 + do l = 0, this%l_max + xPrime_j(i_data) = xPrime_j(i_data) + & + sum(real(integral_r(l)%value)*real(grad_rj(i)%integral_r(l)%value)) + & + sum(aimag(integral_r(l)%value)*aimag(grad_rj(i)%integral_r(l)%value)) + enddo + i_data = i_data + 1 + xPrime_j(i_data) = 0.0_dp + + do l = 0, this%l_max + real_mould_size = size(transfer(grad_spherical_j(i)%spherical_harmonics(l)%value(-l:l),real_mould)) + xPrime_j(i_data+1:i_data+real_mould_size) = transfer(matmul(integral_r(l)%value,conjg(grad_spherical_j(i)%spherical_harmonics(l)%value)),real_mould) + i_data = i_data + real_mould_size + enddo + enddo + + xPrime_j = xPrime_j * 2.0_dp + endif + + if(do_xPrime_ij) then + i_data = 0 + do i = 1, n_neighbour_i + i_data = i_data + 1 + + ! i-th neighbour, wrt r + j_data = 0 + do j = 1, n_neighbour_j + j_data = j_data + 1 + + ! d r_i d r_j + do l = 0, this%l_max + xPrime_ij(i_data,j_data) = xPrime_ij(i_data,j_data) + & + sum(real(grad_rj(j)%integral_r(l)%value)*real(grad_ri(i)%integral_r(l)%value)) + & + sum(aimag(grad_rj(j)%integral_r(l)%value)*aimag(grad_ri(i)%integral_r(l)%value)) + & + sum(real(integral_r(l)%value)*real(grad_rij(j,i)%integral_r(l)%value)) + & + sum(aimag(integral_r(l)%value)*aimag(grad_rij(j,i)%integral_r(l)%value)) + enddo + j_data = j_data + 1 + xPrime_ij(i_data,j_data) = 0.0_dp + + ! d r_i d Y^{lm}_j + do l = 0, this%l_max + real_mould_size = size(transfer(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value(-l:l),real_mould)) + xPrime_ij(i_data,j_data+1:j_data+real_mould_size) = transfer( & + matmul(integral_r(l)%value, conjg(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value)) + & + matmul(grad_ri(i)%integral_r(l)%value, conjg(grad_spherical_j(j)%spherical_harmonics(l)%value)), real_mould) + + j_data = j_data + real_mould_size + enddo + enddo + + i_data = i_data + 1 + xPrime_ij(i_data,:) = 0.0_dp + + do l1 = 0, this%l_max + do m1 = -l1, l1 + j_data = 0 + i_data = i_data + 1 + + ! d Y^{lm}_i d r_j + do j = 1, n_neighbour_j + j_data = j_data + 1 + + tmp_complex = dot_product(grad_rj(j)%integral_r(l1)%value(-l1:l1,m1), grad_spherical_i(i)%spherical_harmonics(l1)%value(-l1:l1)) + & + dot_product(integral_r(l1)%value(-l1:l1,m1),grad_spherical_i_radial_j(j,i)%spherical_harmonics(l1)%value(-l1:l1)) + xPrime_ij(i_data:i_data+1,j_data) = (/real(tmp_complex),aimag(tmp_complex)/) + + j_data = j_data + 1 + xPrime_ij(i_data:i_data+1,j_data) = 0.0_dp + + do l2 = 0, this%l_max + real_mould_size = size(transfer(grad_spherical_j(j)%spherical_harmonics(l2)%value(-l2:l2),real_mould)) + if(l1 == l2) then + xPrime_ij(i_data,j_data+1:j_data+real_mould_size) = transfer( & + grad_spherical_i(i)%spherical_harmonics(l1)%value*conjg(grad_spherical_j(j)%spherical_harmonics(l2)%value(m1)) + & + grad_spherical_ij(j,i)%value(l1)*integral_r(l1)%value(-l1:l1,m1), real_mould) + + xPrime_ij(i_data+1,j_data+1:j_data+real_mould_size) = transfer( & + -CPLX_IMAG*grad_spherical_i(i)%spherical_harmonics(l1)%value*conjg(grad_spherical_j(j)%spherical_harmonics(l2)%value(m1)) + & + CPLX_IMAG*grad_spherical_ij(j,i)%value(l1)*integral_r(l1)%value(-l1:l1,m1), real_mould) + endif + j_data = j_data + real_mould_size + enddo + + enddo + i_data = i_data + 1 + enddo + enddo + enddo + xPrime_ij = xPrime_ij * 2.0_dp + endif + + + if(allocated(integral_r)) then + do l = 0, this%l_max + if(allocated(integral_r(l)%value)) deallocate(integral_r(l)%value) + enddo + deallocate(integral_r) + endif + if(allocated(grad_ri)) then + do i = 1, size(grad_ri) + if(allocated(grad_ri(i)%integral_r)) then + do l = 0, this%l_max + if(allocated(grad_ri(i)%integral_r(l)%value)) deallocate(grad_ri(i)%integral_r(l)%value) + enddo + deallocate(grad_ri(i)%integral_r) + endif + enddo + deallocate(grad_ri) + endif + + if(allocated(grad_rj)) then + do i = 1, size(grad_rj) + if(allocated(grad_rj(i)%integral_r)) then + do l = 0, this%l_max + if(allocated(grad_rj(i)%integral_r(l)%value)) deallocate(grad_rj(i)%integral_r(l)%value) + enddo + deallocate(grad_rj(i)%integral_r) + endif + enddo + deallocate(grad_rj) + endif + + if(do_xPrime_ij) then + + do i = 1, n_neighbour_i + do j = 1, n_neighbour_j + + + do l = 0, this%l_max + deallocate(grad_rij(j,i)%integral_r(l)%value) + deallocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics(l)%value) + deallocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics(l)%value) + enddo + + deallocate(grad_spherical_ij(j,i)%value) + deallocate(grad_rij(j,i)%integral_r) + deallocate(grad_spherical_i_radial_j(j,i)%spherical_harmonics) + deallocate(grad_spherical_j_radial_i(j,i)%spherical_harmonics) + enddo + enddo + + deallocate(grad_rij) + deallocate(grad_spherical_ij) + deallocate(grad_spherical_i_radial_j) + deallocate(grad_spherical_j_radial_i) + + endif + + call finalise(neighbour_i) + call finalise(neighbour_j) + call finalise(grad_spherical_i) + call finalise(grad_spherical_j) + + endfunction gpCovariance_atom_real_space_Calc + +! function gpCovariance_soap_Calc( this, x_i, x_j, xPrime_i, xPrime_j, xPrime_ij, error ) +! type(gpCovariance_soap), intent(in) :: this +! real(dp), dimension(:), intent(in) :: x_i, x_j +! real(dp), dimension(:), intent(out), optional, pointer :: xPrime_i, xPrime_j +! real(dp), dimension(:,:), intent(out), optional, pointer :: xPrime_ij +! integer, intent(out), optional :: error +! +! real(dp) :: gpCovariance_soap_Calc +! +! integer :: l, m, m1, m2, a, i +! logical :: do_xPrime_i, do_xPrime_j, do_xPrime_ij, do_derivative +! +! type(cplx_1d_array), dimension(:,:), allocatable :: fourier1_so3, fourier2_so3, dcov_dfourier1, dcov_dfourier2 +! type(cplx_2d_array), dimension(:), allocatable :: int_soap +! +! INIT_ERROR(error) +! +! if( .not. this%initialised ) then +! RAISE_ERROR('gpCovariance_soap_Calc: object not initialised', error) +! endif +! +! do_xPrime_i = .false. +! do_xPrime_j = .false. +! do_xPrime_ij = .false. +! if(present(xPrime_i)) do_xPrime_i = associated(xPrime_i) +! if(present(xPrime_j)) do_xPrime_j = associated(xPrime_j) +! if(present(xPrime_ij)) do_xPrime_ij = associated(xPrime_ij) +! +! do_derivative = (do_xPrime_i .or. do_xPrime_j .or. do_xPrime_ij) +! +! allocate( fourier1_so3(0:this%l_max,this%n_max), fourier2_so3(0:this%l_max,this%n_max), int_soap(0:this%l_max) ) +! +! if(do_xPrime_i) allocate( dcov_dfourier1(0:this%l_max,this%n_max) ) +! if(do_xPrime_j) allocate( dcov_dfourier2(0:this%l_max,this%n_max) ) +! +! do a = 1, this%n_max +! do l = 0, this%l_max +! allocate(fourier1_so3(l,a)%value(-l:l)) +! allocate(fourier2_so3(l,a)%value(-l:l)) +! if(do_xPrime_i) allocate(dcov_dfourier1(l,a)%value(-l:l)) +! if(do_xPrime_j) allocate(dcov_dfourier2(l,a)%value(-l:l)) +! enddo +! enddo +! +! do l = 0, this%l_max +! allocate(int_soap(l)%value(-l:l,-l:l)) +! int_soap(l)%value = CPLX_ZERO +! enddo +! +! +! i = 0 +! do a = 1, this%n_max +! do l = 0, this%l_max +! do m = -l, l +! fourier1_so3(l,a)%value(m) = cmplx(x_i(i+1), x_i(i+2)) +! fourier2_so3(l,a)%value(m) = cmplx(x_j(i+1), x_j(i+2)) +! i = i + 2 +! enddo +! enddo +! enddo +! +! do a = 1, this%n_max +! do l = 0, this%l_max +! do m1 = -l, l +! do m2 = -l, l +! int_soap(l)%value(m2,m1) = int_soap(l)%value(m2,m1) + & +! fourier1_so3(l,a)%value(m1) * conjg(fourier2_so3(l,a)%value(m2)) +! enddo +! enddo +! enddo +! enddo +! +! do a = 1, this%n_max +! do l = 0, this%l_max +! if(do_xPrime_i) dcov_dfourier1(l,a)%value = matmul(fourier2_so3(l,a)%value,int_soap(l)%value) +! if(do_xPrime_j) dcov_dfourier2(l,a)%value = matmul(conjg(int_soap(l)%value),fourier1_so3(l,a)%value) +! enddo +! enddo +! +! gpCovariance_soap_Calc = 0.0_dp +! do l = 0, this%l_max +! gpCovariance_soap_Calc = gpCovariance_soap_Calc + sum(real(int_soap(l)%value)**2+aimag(int_soap(l)%value)**2) +! enddo +! +! if(do_derivative) then +! i = 0 +! do a = 1, this%n_max +! do l = 0, this%l_max +! do m = -l, l +! if(do_xPrime_i) then +! xPrime_i(i+1) = real(dcov_dfourier1(l,a)%value(m)) +! xPrime_i(i+2) = aimag(dcov_dfourier1(l,a)%value(m)) +! endif +! if(do_xPrime_j) then +! xPrime_j(i+1) = real(dcov_dfourier2(l,a)%value(m)) +! xPrime_j(i+2) = aimag(dcov_dfourier2(l,a)%value(m)) +! endif +! i = i + 2 +! enddo +! enddo +! enddo +! if(do_xPrime_i) xPrime_i = xPrime_i*2.0_dp +! if(do_xPrime_j) xPrime_j = xPrime_j*2.0_dp +! endif +! +! if(allocated(fourier1_so3)) then +! do a = 1, this%n_max +! do l = 0, this%l_max +! deallocate(fourier1_so3(l,a)%value) +! enddo +! enddo +! deallocate(fourier1_so3) +! endif +! +! if(allocated(fourier2_so3)) then +! do a = 1, this%n_max +! do l = 0, this%l_max +! deallocate(fourier2_so3(l,a)%value) +! enddo +! enddo +! deallocate(fourier2_so3) +! endif +! +! if(allocated(int_soap)) then +! do l = 0, this%l_max +! deallocate(int_soap(l)%value) +! enddo +! deallocate(int_soap) +! endif +! +! if(allocated(dcov_dfourier1)) then +! do a = 1, this%n_max +! do l = 0, this%l_max +! deallocate(dcov_dfourier1(l,a)%value) +! enddo +! enddo +! deallocate(dcov_dfourier1) +! endif +! +! if(allocated(dcov_dfourier2)) then +! do a = 1, this%n_max +! do l = 0, this%l_max +! deallocate(dcov_dfourier2(l,a)%value) +! enddo +! enddo +! deallocate(dcov_dfourier2) +! endif +! +! endfunction gpCovariance_soap_Calc + + subroutine gpRealArray_NeighbourDescriptor(this,x,x_size,neighbour,n_neighbour) + type(gpCovariance_atom_real_space), intent(in) :: this + real(dp), dimension(:), intent(in) :: x + integer, intent(in) :: x_size + type(neighbour_descriptor), dimension(:), allocatable, intent(out) :: neighbour + integer, intent(out) :: n_neighbour + + integer :: l, i_data, i, real_mould_size + real(dp), dimension(1) :: real_mould + complex(dp), dimension(1) :: complex_mould + + n_neighbour = x_size / ( 2 * (this%l_max+1)**2 + 2 ) + + call finalise(neighbour) + + allocate(neighbour(n_neighbour)) + + i_data = 0 + do i = 1, n_neighbour + + i_data = i_data + 1 + neighbour(i)%r = x(i_data) + i_data = i_data + 1 + neighbour(i)%n = abs(nint(x(i_data))) + + allocate(neighbour(i)%spherical_harmonics(0:this%l_max)) + do l = 0, this%l_max + + allocate(neighbour(i)%spherical_harmonics(l)%value(-l:l)) + + real_mould_size = size(transfer(neighbour(i)%spherical_harmonics(l)%value(-l:l),real_mould)) + neighbour(i)%spherical_harmonics(l)%value = transfer(x(i_data+1:i_data+real_mould_size),complex_mould) + i_data = i_data + real_mould_size + enddo + enddo + + endsubroutine gpRealArray_NeighbourDescriptor + + subroutine gpNeighbourDescriptor_Finalise(this) + type(neighbour_descriptor), dimension(:), allocatable, intent(inout) :: this + + integer :: i, l + + if(allocated(this)) then + do i = 1, size(this) + do l = lbound(this(i)%spherical_harmonics,dim=1), ubound(this(i)%spherical_harmonics,dim=1) + if(allocated(this(i)%spherical_harmonics(l)%value)) deallocate(this(i)%spherical_harmonics(l)%value) + enddo + if(allocated(this(i)%spherical_harmonics)) deallocate(this(i)%spherical_harmonics) + enddo + deallocate(this) + endif + + endsubroutine gpNeighbourDescriptor_Finalise + + subroutine gp_atom_real_space_RealArray_XYZ(this,x_array,x_array_size,xyz_array,xyz_array_size) + type(gpCovariance_atom_real_space), intent(in) :: this + real(dp), dimension(:), intent(in), target :: x_array + integer, intent(in) :: x_array_size + real(dp), dimension(:), allocatable, intent(out) :: xyz_array + integer, intent(out) :: xyz_array_size + + integer :: l, i_data, i, n_neighbour, n, n_data, xyz_start, xyz_end + real(dp), dimension(:), pointer :: Y1_array + real(dp), pointer :: Re_Y1m1, Im_Y1m1, Re_Y10 + real(dp) :: r, x, y, z + + real(dp), parameter :: xy_factor = 0.5_dp * sqrt(1.5_dp / PI) + real(dp), parameter :: z_factor = 0.5_dp * sqrt(3.0_dp / PI) + + n_neighbour = x_array_size / ( 2 * (this%l_max+1)**2 + 2 ) + xyz_array_size = n_neighbour*3 + + if(allocated(xyz_array)) deallocate(xyz_array) + + allocate(xyz_array(xyz_array_size)) + + i_data = 0 + do i = 1, n_neighbour + + i_data = i_data + 1 + r = x_array(i_data) + i_data = i_data + 1 + n = abs(nint(x_array(i_data))) + + do l = 0, this%l_max + n_data = 2*(2*l + 1) + + if(l == 1) then + Y1_array => x_array(i_data+1:i_data+n_data) + Re_Y1m1 => Y1_array(1) + Im_Y1m1 => Y1_array(2) + Re_Y10 => Y1_array(3) + !Im_Y10 => Y1_value(4) + !Re_Y1p1 => Y1_value(5) + !Im_Y1p1 => Y1_value(6) + + z = Re_Y10 * r / z_factor + x = Re_Y1m1 * r / xy_factor + y = -Im_Y1m1 * r / xy_factor + endif + + i_data = i_data + n_data + enddo + + xyz_start = (i-1)*3+1 + xyz_end = 3*i + xyz_array(xyz_start:xyz_end) = (/x,y,z/) + enddo + + endsubroutine gp_atom_real_space_RealArray_XYZ + + subroutine gp_atom_real_space_XYZ_RealArray(this,xyz_array,xyz_array_size,x_array,x_array_size) + type(gpCovariance_atom_real_space), intent(in) :: this + real(dp), dimension(:), intent(in), target :: xyz_array + integer, intent(in) :: xyz_array_size + real(dp), dimension(:), allocatable, intent(out) :: x_array + integer, intent(out) :: x_array_size + + integer :: l, m, i_data, i, n_neighbour, xyz_start, xyz_end + real(dp), dimension(:), pointer :: xyz + complex(dp) :: Y_lm + + n_neighbour = xyz_array_size / 3 + x_array_size = n_neighbour * ( 2 * (this%l_max+1)**2 + 2 ) + + if(allocated(x_array)) deallocate(x_array) + + allocate(x_array(x_array_size)) + + i_data = 0 + do i = 1, n_neighbour + + xyz_start = (i-1)*3+1 + xyz_end = 3*i + xyz => xyz_array(xyz_start:xyz_end) + + i_data = i_data + 1 + x_array(i_data) = norm(xyz) + i_data = i_data + 1 + x_array(i_data) = real(i,dp) + + do l = 0, this%l_max + do m = -l, l + Y_lm = SphericalYCartesian(l,m,xyz) + x_array(i_data+1:i_data+2) = (/real(Y_lm),aimag(Y_lm)/) + i_data = i_data + 2 + enddo + enddo + + enddo + + endsubroutine gp_atom_real_space_XYZ_RealArray + + function fast_pow_1d(v, e) + real(dp), intent(in) :: v(:), e + real(dp) :: fast_pow_1d(size(v)) + integer :: e_int + + if (e .feq. 0) then + fast_pow_1d = 1.0_dp + elseif (e .feq. 1) then + fast_pow_1d = v + elseif (e .feq. 2) then + fast_pow_1d = v*v + elseif (e .feq. 3) then + fast_pow_1d = v*v*v + elseif (e .feq. 4) then + fast_pow_1d = v*v + fast_pow_1d = fast_pow_1d*fast_pow_1d + else + e_int = nint(e) + if (e .feq. e_int) then + fast_pow_1d = v**e_int + else + fast_pow_1d = v**e + endif + endif + end function fast_pow_1d + + function fast_pow_2d(v, e) + real(dp), intent(in) :: v(:,:), e + real(dp) :: fast_pow_2d(size(v,1),size(v,2)) + + if (e == 0.0) then + fast_pow_2d = 1.0_dp + elseif (e == 1.0) then + fast_pow_2d = v + elseif (e == 2.0) then + fast_pow_2d = v*v + elseif (e == 3.0) then + fast_pow_2d = v*v*v + elseif (e == 4.0) then + fast_pow_2d = v*v + fast_pow_2d = fast_pow_2d*fast_pow_2d + else + fast_pow_2d = v**e + endif + end function fast_pow_2d + + function gpCoordinates_Predict( this, xStar, gradPredict, variance_estimate, do_variance_estimate, grad_variance_estimate, error ) + type(gpCoordinates), intent(inout), target :: this + real(dp), dimension(:), intent(in) :: xStar + real(dp), dimension(:), intent(out), optional :: gradPredict + real(dp), intent(out), optional :: variance_estimate + logical, intent(in), optional :: do_variance_estimate + real(dp), dimension(:), intent(out), optional :: grad_variance_estimate + integer, optional, intent(out) :: error + + real(dp) :: gpCoordinates_Predict + + real(dp) :: covarianceExp, gpCoordinates_Covariance_ii, gpCoordinates_Covariance_jj, covarianceExp_ii, covarianceExp_jj, normalisation, r_ij, r_jj, covariancePP_ij, covariancePP_jj + real(dp), pointer :: fc_i + real(dp), dimension(:), pointer :: x_i + real(dp), dimension(:,:), pointer :: x_i_permuted_theta + real(dp), dimension(this%d) :: xI_xJ_theta, xStar_theta + !real(dp), dimension(this%d,this%n_permutations) :: xStar_permuted + real(dp), dimension(this%n_sparseX) :: k + integer :: i_sparseX, i_p, ii, jj + real(dp) :: delta, covariance_x_x, diag_covariance + real(dp), dimension(:), allocatable :: covariance_x_xStars, alpha_scaled, grad_Covariance_jj + real(dp), dimension(:), pointer :: xPrime_i + real(dp), dimension(:), allocatable, target :: grad_kStar, k_mm_k + real(dp), dimension(:,:), allocatable, target :: grad_k + real(dp), dimension(:,:), allocatable :: distance_matrix + logical :: my_do_variance_estimate + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_Predict: object not initialised', error) + endif + + my_do_variance_estimate = present(variance_estimate) .and. optional_default(.false.,do_variance_estimate) + + if( this%n_sparseX == 0 ) then + gpCoordinates_Predict = 0.0_dp + if( present(gradPredict) ) gradPredict = 0.0_dp + if( my_do_variance_estimate ) then + variance_estimate = 0.0_dp + if( present( grad_variance_estimate ) ) grad_variance_estimate = 0.0_dp + endif + return + endif + + + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then +#ifdef _OPENMP + if (OMP_IN_PARALLEL()) then + RAISE_ERROR('gpCoordinates_Predict: bond_real_space covariance not OpenMP/thread-safe', error) + end if +#endif + if(.not. this%bond_real_space_cov%initialised) then + call gpCoordinates_gpCovariance_bond_real_space_Initialise(this) + endif + endif + + k = 0.0_dp + xPrime_i => null() + if(present(gradPredict) .and. this%covariance_type /= COVARIANCE_DOT_PRODUCT) then + allocate(grad_k(size(xStar),this%n_sparseX)) + grad_k = 0.0_dp + if( this%n_permutations > 1 ) allocate(grad_Covariance_jj(this%d)) + endif + + covariance_ard_se_calc_cov_jj: if (this%covariance_type == COVARIANCE_ARD_SE) then + if (.not. this%sparse_covariance_initialised) then + RAISE_ERROR('gpCoordinates_Predict: gpCoordinates_precalculate_sparse needs to be called first', error) + end if + + xStar_theta = xStar / this%theta + + !do i_p = 1, this%n_permutations + ! xStar_permuted(:,i_p) = xStar(this%permutations(:,i_p)) + !end do + if( this%n_permutations > 1 ) then + gpCoordinates_Covariance_jj = 0.0_dp + if(present(gradPredict)) grad_Covariance_jj = 0.0_dp + + do i_p = 1, this%n_permutations + xI_xJ_theta = ( xStar_theta(this%permutations(:,i_p)) - xStar_theta(:) ) + covarianceExp_jj = exp( -0.5_dp * dot_product(xI_xJ_theta,xI_xJ_theta) ) + gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covarianceExp_jj + + if(present(gradPredict)) then + !grad_Covariance_jj = grad_Covariance_jj + covarianceExp_jj * xI_xJ_theta / this%theta + grad_Covariance_jj = grad_Covariance_jj + covarianceExp_jj * xI_xJ_theta / this%theta + grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) - covarianceExp_jj * xI_xJ_theta / this%theta + endif + enddo + endif + end if covariance_ard_se_calc_cov_jj + + covariance_pp_calc_cov_jj: if (this%covariance_type == COVARIANCE_PP) then + if (.not. this%sparse_covariance_initialised) then + RAISE_ERROR('gpCoordinates_Predict: gpCoordinates_precalculate_sparse needs to be called first', error) + end if + + xStar_theta = xStar / this%theta + allocate(distance_matrix(this%d, this%d)) + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) & + distance_matrix(ii,jj) = ( xStar_theta(ii) - xStar_theta(jj) )**2 + + if( this%n_permutations > 1 ) then + gpCoordinates_Covariance_jj = 0.0_dp + if(present(gradPredict)) grad_Covariance_jj = 0.0_dp + + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle + + r_jj = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) + if( r_jj >= 1.0_dp ) cycle + + covariancePP_jj = covariancePP(r_jj,PP_Q, this%d) + gpCoordinates_Covariance_jj = gpCoordinates_Covariance_jj + covariancePP_jj + + if(present(gradPredict) .and. ( r_jj .fne. 0.0_dp ) ) then + xI_xJ_theta = ( xStar_theta(:) - xStar_theta(this%permutations(:,i_p)) ) + + grad_Covariance_jj = grad_Covariance_jj + grad_covariancePP(r_jj,PP_Q, this%d) * xI_xJ_theta / this%theta / r_jj + grad_Covariance_jj(this%permutations(:,i_p)) = grad_Covariance_jj(this%permutations(:,i_p)) - grad_covariancePP(r_jj,PP_Q, this%d) * xI_xJ_theta / this%theta / r_jj + endif + enddo + endif + end if covariance_pp_calc_cov_jj + + covariance_type_calc_k: if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then + allocate(covariance_x_xStars(this%n_sparseX)) + call dgemv('T', size(this%sparseX,1), size(this%sparseX,2), 1.0_dp, this%sparseX(1,1), size(this%sparseX, 1), & + xStar(1), 1, 0.0_dp, covariance_x_xStars(1), 1) +! now a single dgemv call outside the loop +! do i_sparseX = 1, this%n_sparseX +! covariance_x_xStar = dot_product(xStar,this%sparseX(:,i_sparseX)) +! +! k(i_sparseX) = this%delta**2 * covariance_x_xStar**this%theta(1) +! +! if(present(gradPredict)) grad_k(:,i_sparseX) = this%delta**2 * this%theta(1) * covariance_x_xStar**(this%theta(1)-1.0_dp) * this%sparseX(:,i_sparseX) +! end do + + k(:) = this%delta**2 * fast_pow_1d(covariance_x_xStars(:), this%zeta) + + k = k * this%sparseCutoff + if(present(gradPredict)) then + allocate(alpha_scaled(size(this%alpha))) + alpha_scaled(:) = this%alpha(:) * this%delta**2 * this%zeta * fast_pow_1d(covariance_x_xStars, this%zeta-1.0_dp) + alpha_scaled = alpha_scaled * this%sparseCutoff + endif + deallocate(covariance_x_xStars) + + else if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then covariance_type_calc_k + xPrime_i => null() + do i_sparseX = 1, this%n_sparseX + delta = this%bond_real_space_cov%delta + this%bond_real_space_cov%delta = 1.0_dp + covariance_x_x = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=xStar, x_i_size=(size(xStar) - 1), x_j=xStar, x_j_size=(size(xStar) - 1)) + this%bond_real_space_cov%delta = delta + k(i_sparseX) = gpCovariance_bond_real_space_Calc(this%bond_real_space_cov, x_i=xStar, x_i_size=(size(xStar) - 1), x_j=this%sparseX(:,i_sparseX), x_j_size=this%sparseX_size(i_sparseX)) & + / sqrt(covariance_x_x * this%covarianceDiag_sparseX_sparseX(i_sparseX)) + enddo + + else if(this%covariance_type == COVARIANCE_ARD_SE) then covariance_type_calc_k + xPrime_i => null() + do i_sparseX = 1, this%n_sparseX + !x_i => this%sparseX(:,i_sparseX) + x_i_permuted_theta => this%sparseX_permuted(:,:,i_sparseX) + fc_i => this%sparseCutoff(i_sparseX) + do i_p = 1, this%n_permutations + + xI_xJ_theta = (x_i_permuted_theta(:,i_p) - xStar_theta(:)) + !xI_xJ_theta = (x_i(:) - xStar_permuted(:,i_p)) / this%theta + !xI_xJ_theta = (this%sparseX_permuted(:,i_p,i_sparseX) - xStar(:)) / this%theta + + covarianceExp = this%delta**2 * exp( -0.5_dp * dot_product(xI_xJ_theta,xI_xJ_theta) ) + + if(present(gradPredict)) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) + covarianceExp*xI_xJ_theta / this%theta + k(i_sparseX) = k(i_sparseX) + covarianceExp + enddo + + if( this%n_permutations > 1 ) then + + normalisation = sqrt(this%sparseCovariance(i_sparseX) * gpCoordinates_Covariance_jj) + if(present(gradPredict)) then + grad_k(:,i_sparseX) = grad_k(:,i_sparseX) / normalisation - 0.5_dp * grad_Covariance_jj * k(i_sparseX) / normalisation / gpCoordinates_Covariance_jj + endif + + k(i_sparseX) = k(i_sparseX) / normalisation + + endif + k(i_sparseX) = ( k(i_sparseX) + this%f0**2 ) * fc_i + if(present(gradPredict)) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) * fc_i + enddo + else if(this%covariance_type == COVARIANCE_PP) then covariance_type_calc_k + xPrime_i => null() + do i_sparseX = 1, this%n_sparseX + x_i => this%sparseX(:,i_sparseX) + fc_i => this%sparseCutoff(i_sparseX) + + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - xStar(jj) )**2 / this%theta(ii)**2 + + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(this%permutations(ii,i_p),ii) > 1.0_dp, ii=1, this%d) /) ) ) cycle + + r_ij = sqrt( sum( (/ (distance_matrix(this%permutations(ii,i_p),ii), ii=1, this%d) /) ) ) + if( r_ij >= 1.0_dp ) cycle + + covariancePP_ij = this%delta**2 * covariancePP(r_ij,PP_Q, this%d) + if(present(gradPredict) .and. ( r_ij /= 0.0_dp ) ) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) + & + this%delta**2 * grad_covariancePP(r_ij,PP_Q, this%d) * ( xStar(:) - x_i(this%permutations(:,i_p)) ) / r_ij / this%theta(:)**2 + + k(i_sparseX) = k(i_sparseX) + covariancePP_ij + enddo + + if( this%n_permutations > 1 ) then + + normalisation = sqrt(this%sparseCovariance(i_sparseX) * gpCoordinates_Covariance_jj) + + if(present(gradPredict)) then + grad_k(:,i_sparseX) = grad_k(:,i_sparseX) / normalisation - 0.5_dp * grad_Covariance_jj * k(i_sparseX) / normalisation / gpCoordinates_Covariance_jj + endif + + k(i_sparseX) = k(i_sparseX) / normalisation + + endif + k(i_sparseX) = ( k(i_sparseX) + this%f0**2 ) * fc_i + if(present(gradPredict)) grad_k(:,i_sparseX) = grad_k(:,i_sparseX) * fc_i + enddo + end if covariance_type_calc_k + gpCoordinates_Predict = dot_product( k, this%alpha ) + + if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then + if(present(gradPredict)) & + call dgemv('N', size(this%sparseX,1), size(this%sparseX,2), 1.0_dp, this%sparseX(1,1), size(this%sparseX,1), & + alpha_scaled(1), 1, 0.0_dp, gradPredict(1), 1) + else + if(present(gradPredict)) & + call dgemv('N', size(grad_k,1), size(grad_k,2), 1.0_dp, grad_k(1,1), size(grad_k,1), & + this%alpha(1), 1, 0.0_dp, gradPredict(1), 1) + endif + + if(my_do_variance_estimate) then + allocate(k_mm_k(this%n_sparseX)) + + if(.not.this%variance_estimate_initialised) then + RAISE_ERROR('gpCoordinates_Predict: variance_estimate not initialised',error) + endif + + call Matrix_Solve(this%LA_k_mm, k, k_mm_k) + diag_covariance = this%delta**2 + this%f0**2 + this%variance_estimate_regularisation**2 + + variance_estimate = diag_covariance - dot_product(k,k_mm_k) + if( variance_estimate < 0.0_dp ) then + RAISE_ERROR('gpCoordinates_Predict: variance_estimate: negative variance predicted: '//variance_estimate ,error) + endif + + if( present(gradPredict) .and. present(grad_variance_estimate) ) then + if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then + grad_variance_estimate = - 2.0_dp * matmul(this%sparseX, alpha_scaled / this%alpha * k_mm_k) + else + call dgemv('N', size(grad_k,1), size(grad_k,2), 1.0_dp, grad_k(1,1), size(grad_k,1), & + k_mm_k(1), 1, 0.0_dp, grad_variance_estimate(1), 1) + grad_variance_estimate = - 2.0_dp * grad_variance_estimate + endif + endif + if(allocated(k_mm_k)) deallocate(k_mm_k) + endif + + if(allocated(alpha_scaled)) deallocate(alpha_scaled) + if(allocated(grad_k)) deallocate(grad_k) + if(allocated(grad_kStar)) deallocate(grad_kStar) + if(allocated(grad_Covariance_jj)) deallocate(grad_Covariance_jj) + if( allocated( distance_matrix ) ) deallocate(distance_matrix) + + endfunction gpCoordinates_Predict + + subroutine gpCoordinates_precalculate_sparse(this) + type(gpCoordinates), intent(inout), target :: this + + integer :: i_sparseX, i_p, ii, jj + real(dp), dimension(:), pointer :: x_i + real(dp), dimension(:,:), pointer :: x_i_permuted_theta + real(dp) :: gpCoordinates_Covariance_ii, covarianceExp_ii, r_ii + real(dp), dimension(this%d) :: xI_xI_theta + real(dp), dimension(:,:), allocatable :: distance_matrix + + initialise_sparse_covariance: if( .not. this%sparse_covariance_initialised ) then + select case(this%covariance_type) + case(COVARIANCE_ARD_SE) + if (allocated(this%sparseX_permuted)) deallocate( this%sparseX_permuted ) + allocate(this%sparseX_permuted(this%d, this%n_permutations, this%n_sparseX)) + + do i_sparseX = 1, this%n_sparseX + x_i => this%sparseX(:,i_sparseX) + x_i_permuted_theta => this%sparseX_permuted(:,:,i_sparseX) + do i_p = 1, this%n_permutations + x_i_permuted_theta(:,i_p) = x_i(this%permutations(:,i_p)) / this%theta + end do + end do + + if( this%n_permutations > 1 ) then + call reallocate(this%sparseCovariance,this%n_sparseX) + + do i_sparseX = 1, this%n_sparseX + x_i => this%sparseX(:,i_sparseX) + x_i_permuted_theta => this%sparseX_permuted(:,:,i_sparseX) + gpCoordinates_Covariance_ii = 0.0_dp + do i_p = 1, this%n_permutations + xI_xI_theta = x_i_permuted_theta(:,i_p) - (x_i / this%theta) + covarianceExp_ii = exp( -0.5_dp * dot_product(xI_xI_theta,xI_xI_theta) ) + gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covarianceExp_ii + enddo + this%sparseCovariance(i_sparseX) = gpCoordinates_Covariance_ii + end do + end if + case(COVARIANCE_PP) + if( this%n_permutations > 1 ) then + call reallocate(this%sparseCovariance,this%n_sparseX) + allocate(distance_matrix(this%d,this%d)) + + do i_sparseX = 1, this%n_sparseX + x_i => this%sparseX(:,i_sparseX) + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) & + distance_matrix(ii,jj) = ( x_i(ii) - x_i(jj) )**2 / this%theta(ii)**2 + gpCoordinates_Covariance_ii = 0.0_dp + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(ii,this%permutations(ii,i_p)) > 1.0_dp, ii=1, this%d) /) ) ) cycle + r_ii = sqrt( sum( (/ (distance_matrix(ii,this%permutations(ii,i_p)), ii=1, this%d) /) ) ) + if( r_ii >= 1.0_dp ) cycle + + gpCoordinates_Covariance_ii = gpCoordinates_Covariance_ii + covariancePP(r_ii,PP_Q, this%d) + enddo + this%sparseCovariance(i_sparseX) = gpCoordinates_Covariance_ii + end do + + deallocate(distance_matrix) + end if + + endselect + + this%sparse_covariance_initialised = .true. + end if initialise_sparse_covariance + + end subroutine gpCoordinates_precalculate_sparse + + subroutine gpCoordinates_initialise_variance_estimate(this, regularisation, error) + type(gpCoordinates), intent(inout), target :: this + real(dp), intent(in) :: regularisation + integer, intent(out), optional :: error + + real(dp) :: r_ij + real(dp), dimension(:,:), allocatable :: k_mm, distance_matrix + real(dp), dimension(:), pointer :: x_i, x_j + real(dp), pointer :: fc_i, fc_j + real(dp), dimension(this%d) :: xI_xJ_theta + + integer :: i, j, i_p, ii, jj, zeta_int + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_initialise_variance_estimate: object not initialised', error) + endif + + if( this%variance_estimate_initialised ) then + if( regularisation .feq. this%variance_estimate_regularisation) then + return + else + call gpCoordinates_finalise_variance_estimate(this,error) + endif + endif + + if( this%n_sparseX == 0 ) return + + if( regularisation < 0.0_dp ) then + RAISE_ERROR("gpCoordinates_initialise_variance_estimate: regularisation ("//regularisation//") is negative.",error) + elseif( regularisation == 0.0_dp ) then + call print_warning("gpCoordinates_initialise_variance_estimate: regularisation = 0.0, proceed with caution") + endif + + this%variance_estimate_regularisation = regularisation + + allocate(k_mm(this%n_sparseX,this%n_sparseX)) + zeta_int = int(this%zeta) + + if( this%covariance_type == COVARIANCE_PP ) allocate(distance_matrix(this%d,this%d)) + + if (this%covariance_type == COVARIANCE_DOT_PRODUCT) then + call dgemm('T', 'N', size(this%sparseX,2), size(this%sparseX,2), size(this%sparseX,1), & + 1.0_dp, this%sparseX(1,1), size(this%sparseX,1), this%sparseX(1,1), size(this%sparseX, 1), & + 0.0_dp, k_mm(1,1), size(k_mm,1)) + k_mm = fast_pow_2d(k_mm, this%zeta) + else + k_mm = 0.0_dp + do i = 1, this%n_sparseX + x_i => this%sparseX(:,i) + fc_i => this%sparseCutoff(i) + do j = i, this%n_sparseX + x_j => this%sparseX(:,j) + fc_j => this%sparseCutoff(j) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_initialise_variance_estimate: bond real space sparse score not implemented', error) + endif + elseif(this%covariance_type == COVARIANCE_DOT_PRODUCT) then + if( zeta_int .feq. this%zeta ) then + k_mm(j,i) = fc_i*fc_i * sum( x_i * x_j )**zeta_int + else + k_mm(j,i) = fc_i*fc_i * sum( x_i * x_j )**this%zeta + endif + elseif( this%covariance_type == COVARIANCE_ARD_SE ) then + do i_p = 1, this%n_permutations + xI_xJ_theta = (x_i(this%permutations(:,i_p)) - x_j) / this%theta + !xI_xJ_theta = (x_i - x_j(this%permutations(:,i_p))) / this%theta + k_mm(j,i) = k_mm(j,i) + exp( -0.5_dp * dot_product(xI_xJ_theta,xI_xJ_theta) ) + enddo + elseif( this%covariance_type == COVARIANCE_PP ) then + forall( ii = 1:this%d, jj = 1:this%d, this%permutation_distance_mask(ii,jj) ) distance_matrix(ii,jj) = ( x_i(ii) - x_j(jj) )**2 / this%theta(ii)**2 + do i_p = 1, this%n_permutations + if( any( (/ (distance_matrix(ii,this%permutations(ii,i_p)) > 1.0_dp, ii=1, this%d) /) ) ) cycle + r_ij = sqrt( sum( (/ (distance_matrix(ii,this%permutations(ii,i_p)), ii=1, this%d) /) ) ) + if( r_ij >= 1.0_dp ) cycle + + k_mm(j,i) = k_mm(j,i) + covariancePP(r_ij,PP_Q, this%d) + enddo + endif + if( i /= j ) k_mm(i,j) = k_mm(j,i) + enddo + enddo + endif + + if( this%covariance_type == COVARIANCE_ARD_SE .or. this%covariance_type == COVARIANCE_PP ) then + do i = 1, this%n_sparseX + fc_i => this%sparseCutoff(i) + do j = i+1, this%n_sparseX + fc_j => this%sparseCutoff(j) + k_mm(j,i) = k_mm(j,i) * fc_i * fc_j / sqrt(k_mm(j,j)*k_mm(i,i)) + k_mm(i,j) = k_mm(j,i) + enddo + enddo + do i = 1, this%n_sparseX + fc_i => this%sparseCutoff(i) + k_mm(i,i) = fc_i**2 + enddo + endif + + k_mm = k_mm * this%delta**2 + k_mm = k_mm + this%f0**2 + + do i = 1, this%n_sparseX + k_mm(i,i) = k_mm(i,i) + regularisation**2 + enddo + + call initialise(this%LA_k_mm, k_mm) + call LA_Matrix_Factorise(this%LA_k_mm,error=error) + if(allocated(k_mm)) deallocate(k_mm) + if(allocated(distance_matrix)) deallocate(distance_matrix) + + this%variance_estimate_initialised = .true. + + endsubroutine gpCoordinates_initialise_variance_estimate + + function gpCoordinates_log_likelihood(this,regularisation,error) result(log_likelihood) + type(gpCoordinates), intent(inout) :: this + real(dp), intent(in), optional :: regularisation + integer, intent(out), optional :: error + real(dp) :: log_likelihood + + real(dp) :: my_regularisation + logical :: was_initialised + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_log_likelihood: object not initialised', error) + endif + + if( this%n_sparseX == 0 ) then + log_likelihood = 0.0_dp + return + endif + + was_initialised = this%variance_estimate_initialised + if( this%variance_estimate_initialised ) then + my_regularisation = optional_default(this%variance_estimate_regularisation,regularisation) + else + my_regularisation = optional_default(0.001_dp,regularisation) + endif + + call gpCoordinates_initialise_variance_estimate(this,my_regularisation,error) + + log_likelihood = -0.5_dp * sum(matmul(this%LA_k_mm%matrix,this%alpha)*this%alpha) & + - 0.5_dp*LA_Matrix_LogDet(this%LA_k_mm) - this%n_sparseX * log(2.0_dp*pi) + + if( .not. was_initialised ) call gpCoordinates_finalise_variance_estimate(this,error) + + endfunction gpCoordinates_log_likelihood + + subroutine gpCoordinates_finalise_variance_estimate(this,error) + type(gpCoordinates), intent(inout) :: this + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if( .not. this%variance_estimate_initialised) return + + call finalise(this%LA_k_mm) + + this%variance_estimate_regularisation = 0.0_dp + this%variance_estimate_initialised = .false. + + endsubroutine gpCoordinates_finalise_variance_estimate + + subroutine gpCoordinates_print_sparseX_file(this,sparseX_filename,error) + type(gpCoordinates), intent(in) :: this + character(len=*), intent(in) :: sparseX_filename + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call fwrite_array_d(size(this%sparseX), this%sparseX(1,1), trim(sparseX_filename)//C_NULL_CHAR) + + end subroutine gpCoordinates_print_sparseX_file + + subroutine gpFull_get_globalY(this, globalY) + type(gpFull), intent(in) :: this + real(dp), intent(inout), allocatable :: globalY(:) + + integer :: i_y, i_yPrime, i_map + + call reallocate(globalY, (this%n_y + this%n_yPrime)) + + do i_y = 1, this%n_y + i_map = this%map_y_globalY(i_y) + globalY(i_map) = this%y(i_y) + enddo + + do i_yPrime = 1, this%n_yPrime + i_map = this%map_yPrime_globalY(i_yPrime) + globalY(i_map) = this%yPrime(i_yPrime) + end do + end subroutine gpFull_get_globalY + + ! print covariances and lambda to process-dependent files, one value per line + subroutine gpFull_print_covariances_lambda_globalY(this, file_prefix, my_proc, do_Kmm) + type(gpFull), intent(in) :: this + character(*), intent(in) :: file_prefix + integer, intent(in) :: my_proc + logical, intent(in) :: do_Kmm + + real(dp), allocatable :: globalY(:) + + call fwrite_array_d(size(this%covariance_subY_y), this%covariance_subY_y, trim(file_prefix)//'_Kmn.'//my_proc//C_NULL_CHAR) + call fwrite_array_d(size(this%lambda), this%lambda, trim(file_prefix)//'_lambda.'//my_proc//C_NULL_CHAR) + + call gpFull_get_globalY(this, globalY) + call fwrite_array_d(size(globalY), globalY, trim(file_prefix)//'_globalY.'//my_proc//C_NULL_CHAR) + + if (.not. do_Kmm) return + if (.not. this%do_subY_subY) then + call print_warning("gpFull_print_covariances_lambda: Called to print Kmm but do_subY_subY is false.") + return + end if + if (.not. allocated(this%covariance_subY_subY)) then + call print_warning("gpFull_print_covariances_lambda: Called to print Kmm but not allocated.") + return + end if + + call fwrite_array_d(size(this%covariance_subY_subY), this%covariance_subY_subY, trim(file_prefix)//'_Kmm'//C_NULL_CHAR) + end subroutine gpFull_print_covariances_lambda_globalY + + subroutine gpCoordinates_printXML(this,xf,label,sparseX_base_filename,error) + type(gpCoordinates), intent(in) :: this + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: label + character(len=*), intent(in), optional :: sparseX_base_filename + integer, intent(out), optional :: error + + integer :: i, j, j_end, slash_ind + type(extendable_str) :: sparseX_filename + character(len=32) :: sparseX_md5sum + logical :: have_sparseX_base_filename + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpCoordinates_printXML: object not initialised', error) + endif + + have_sparseX_base_filename = .false. + if (present(sparseX_base_filename)) then + if (len_trim(sparseX_base_filename) > 0) have_sparseX_base_filename = .true. + endif + + call xml_NewElement(xf,"gpCoordinates") + + if(present(label)) call xml_AddAttribute(xf,"label", trim(label)) + + call xml_AddAttribute(xf,"dimensions", ""//this%d) + call xml_AddAttribute(xf,"signal_variance", ""//this%delta) + call xml_AddAttribute(xf,"signal_mean", ""//this%f0) + call xml_AddAttribute(xf,"sparsified", ""//this%sparsified) + call xml_AddAttribute(xf,"n_permutations", ""//this%n_permutations) + call xml_AddAttribute(xf,"covariance_type", ""//this%covariance_type) + + if( this%covariance_type == COVARIANCE_DOT_PRODUCT ) & + call xml_AddAttribute(xf,"zeta", ""//this%zeta) + + if(this%sparsified) then + call xml_AddAttribute(xf,"n_sparseX",""//this%n_sparseX) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"sparseX_size_max", ""//maxval(this%sparseX_size)) + if (have_sparseX_base_filename) then + sparseX_filename = trim(sparseX_base_filename) + if (present(label)) then + call concat(sparseX_filename,"."//trim(label)) + endif + call gpCoordinates_print_sparseX_file(this,trim(string(sparseX_filename)),error=error) + call quip_md5sum(trim(string(sparseX_filename)),sparseX_md5sum) + ! remove leading path, since file will be read in from path of + ! xml file + slash_ind = index(sparseX_filename, "/") + do while (slash_ind > 0) + call substr_replace(sparseX_filename, 1, slash_ind, "") + slash_ind = index(sparseX_filename, "/") + end do + call xml_AddAttribute(xf,"sparseX_filename",trim(string(sparseX_filename))) + call xml_AddAttribute(xf,"sparseX_md5sum",trim(sparseX_md5sum)) + endif + else + call xml_AddAttribute(xf,"n_x",""//this%n_x) + call xml_AddAttribute(xf,"n_xPrime",""//this%n_xPrime) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"x_size_max", ""//maxval(this%x_size)) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"xPrime_size_max", ""//maxval(this%xPrime_size)) + endif + + if( this%covariance_type == COVARIANCE_ARD_SE .or. this%covariance_type == COVARIANCE_PP ) then + call xml_NewElement(xf,"theta") + call xml_AddCharacters(xf, ""//this%theta//" ") + call xml_EndElement(xf,"theta") + endif + + call xml_NewElement(xf,"descriptor") + call xml_AddCharacters(xf, string(this%descriptor_str)) + call xml_EndElement(xf,"descriptor") + + do i = 1, this%n_permutations + call xml_NewElement(xf,"permutation") + call xml_AddAttribute(xf,"i",""//i) + call xml_AddCharacters(xf,""//this%permutations(:,i)//" ") + call xml_EndElement(xf,"permutation") + enddo + + if(this%sparsified) then + do i = 1, this%n_sparseX + call xml_NewElement(xf,"sparseX") + call xml_AddAttribute(xf,"i", ""//i) + call xml_AddAttribute(xf,"alpha", ""//this%alpha(i)) + call xml_AddAttribute(xf,"sparseCutoff", ""//this%sparseCutoff(i)) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + call xml_AddAttribute(xf,"covariance_sparseX_sparseX", ""//this%covarianceDiag_sparseX_sparseX(i)) + endif + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) then + call xml_AddAttribute(xf,"sparseX_size", ""//this%sparseX_size(i)) + call xml_AddCharacters(xf, ""//this%sparseX(:this%sparseX_size(i),i)//" ") + elseif (.not. have_sparseX_base_filename) then + if(this%d <= 50) then + call xml_AddCharacters(xf, ""//this%sparseX(:,i)//" ") + else + call xml_AddAttribute(xf,"sliced", "T") + do j = 1, this%d, 50 + j_end = min(j-1+50,this%d) + call xml_NewElement(xf,"sparseX_slice") + call xml_AddAttribute(xf,"start", ""//j) + call xml_AddAttribute(xf,"end", ""//j_end) + call xml_AddCharacters(xf, ""//this%sparseX(j:j_end,i)//" ") + call xml_EndElement(xf,"sparseX_slice") + enddo + endif + endif + call xml_EndElement(xf,"sparseX") + enddo + else + do i = 1, this%n_x + call xml_NewElement(xf,"x") + call xml_AddAttribute(xf,"i", ""//i) + call xml_AddAttribute(xf,"map_x_y", ""//this%map_x_y(i)) + call xml_AddAttribute(xf,"cutoff", ""//this%cutoff(i)) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"x_size", ""//this%x_size(i)) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"covariance_x_x", ""//this%covarianceDiag_x_x(i)) + call xml_AddCharacters(xf, ""//this%x(:,i)//" ") + call xml_EndElement(xf,"x") + enddo + do i = 1, this%n_xPrime + call xml_NewElement(xf,"xPrime") + call xml_AddAttribute(xf,"i", ""//i) + call xml_AddAttribute(xf,"map_xPrime_yPrime", ""//this%map_xPrime_yPrime(i)) + call xml_AddAttribute(xf,"map_xPrime_x", ""//this%map_xPrime_x(i)) + call xml_AddAttribute(xf,"cutoffPrime", ""//this%cutoffPrime(i)) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"xPrime_size", ""//this%xPrime_size(i)) + if(this%covariance_type == COVARIANCE_BOND_REAL_SPACE) call xml_AddAttribute(xf,"covariance_xPrime_xPrime", ""//this%covarianceDiag_xPrime_xPrime(i)) + call xml_AddCharacters(xf, ""//this%xPrime(:,i)//" ") + call xml_EndElement(xf,"xPrime") + enddo + endif + + call xml_EndElement(xf,"gpCoordinates") + + endsubroutine gpCoordinates_printXML + + subroutine gpFull_printXML(this,xf,label,error) + type(gpFull), intent(in) :: this + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + + integer :: i + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpFull_printXML: object not initialised', error) + endif + + call xml_NewElement(xf,"gpFull") + + if(present(label)) call xml_AddAttribute(xf,"label", trim(label)) + + call xml_AddAttribute(xf,"n_y", ""//this%n_y) + call xml_AddAttribute(xf,"n_yPrime", ""//this%n_yPrime) + call xml_AddAttribute(xf,"n_globalSparseX", ""//this%n_globalSparseX) + call xml_AddAttribute(xf,"n_coordinate", ""//this%n_coordinate) + call xml_AddAttribute(xf,"sparse_jitter", ""//this%sparse_jitter) + + do i = 1, this%n_y + call xml_NewElement(xf,"y") + call xml_AddAttribute(xf,"i", ""//i) + call xml_AddAttribute(xf,"map_y_globalY", ""//this%map_y_globalY(i)) + call xml_AddAttribute(xf,"alpha", ""//this%alpha(this%map_y_globalY(i)) ) + call xml_EndElement(xf,"y") + enddo + + do i = 1, this%n_yPrime + call xml_NewElement(xf,"yPrime") + call xml_AddAttribute(xf,"i", ""//i) + call xml_AddAttribute(xf,"map_yPrime_globalY", ""//this%map_yPrime_globalY(i)) + call xml_AddAttribute(xf,"alpha", ""//this%alpha(this%map_yPrime_globalY(i)) ) + call xml_EndElement(xf,"yPrime") + enddo + + do i = 1, this%n_coordinate + call gpCoordinates_printXML(this%coordinate(i),xf,label=trim(optional_default("",label))//i,error=error) + enddo + + call xml_EndElement(xf,"gpFull") + + endsubroutine gpFull_printXML + + subroutine gpSparse_printXML(this,xf,label,sparseX_base_filename,error) + type(gpSparse), intent(in) :: this + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: label + character(len=*), intent(in), optional :: sparseX_base_filename + integer, intent(out), optional :: error + + integer :: i + + INIT_ERROR(error) + + if( .not. this%initialised ) then + RAISE_ERROR('gpSparse_printXML: object not initialised', error) + endif + + call xml_NewElement(xf,"gpSparse") + + if(present(label)) call xml_AddAttribute(xf,"label", trim(label)) + + call xml_AddAttribute(xf,"n_coordinate", ""//this%n_coordinate) + call xml_AddAttribute(xf,"fitted", ""//this%fitted) + + do i = 1, this%n_coordinate + call gpCoordinates_printXML(this%coordinate(i),xf,label=trim(optional_default("",label))//i,& + sparseX_base_filename=sparseX_base_filename, error=error) + enddo + + call xml_EndElement(xf,"gpSparse") + + endsubroutine gpSparse_printXML + + subroutine gp_write_covariance(this, basename, label) + type(gpSparse), intent(in) :: this + character(*), intent(in) :: basename + character(*),intent(in), optional :: label + + + character(STRING_LENGTH) :: my_label, R_fname + integer :: M + + my_label = optional_default("", "." // trim(label)) + + R_fname = trim(basename) // trim(my_label) + + + + if (this%do_export_R .and. allocated(this%R)) then + M = size(this%R, 1) + call fwrite_array_d(M * M, this%R, trim(R_fname)//C_NULL_CHAR) + end if + end subroutine gp_write_covariance + + + subroutine gpCoordinates_readXML(this,xp,label,error) + type(gpCoordinates), intent(inout), target :: this + type(xml_t), intent(inout) :: xp + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if( this%initialised ) call finalise(this,error) + + parse_in_gpCoordinates = .false. + parse_matched_label = .false. + parse_gpCoordinates => this + parse_gpCoordinates_label = optional_default("",label) + + call initialise(parse_cur_data) + call parse(xp, & + characters_handler = gpCoordinates_characters_handler, & + startElement_handler = gpCoordinates_startElement_handler, & + endElement_handler = gpCoordinates_endElement_handler) + + call finalise(parse_cur_data) + + this%initialised = .true. + + endsubroutine gpCoordinates_readXML + + subroutine gpFull_readXML(this,xp,label,error) + type(gpFull), intent(inout), target :: this + type(xml_t), intent(inout) :: xp + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + + integer :: i + + INIT_ERROR(error) + + if( this%initialised ) call finalise(this,error) + + parse_in_gpFull = .false. + parse_matched_label = .false. + parse_gpFull => this + parse_gpFull_label = optional_default("",label) + + call initialise(parse_cur_data) + + call parse(xp, & + characters_handler = gpFull_characters_handler, & + startElement_handler = gpFull_startElement_handler, & + endElement_handler = gpFull_endElement_handler) + + call finalise(parse_cur_data) + + do i = 1, this%n_coordinate + call gpCoordinates_readXML(this%coordinate(i),xp,label=trim(parse_gpFull_label)//i,error=error) + enddo + + this%initialised = .true. + + endsubroutine gpFull_readXML + + subroutine gpSparse_readXML(this,xp,label,error) + type(gpSparse), intent(inout), target :: this + type(xml_t), intent(inout) :: xp + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + +! integer :: i + + INIT_ERROR(error) + + if( this%initialised ) call finalise(this,error) + + parse_in_gpSparse = .false. + parse_gpSparse => this + parse_matched_label = .false. + parse_gpSparse_label = optional_default("",label) + + call initialise(parse_cur_data) + + call parse(xp, & + characters_handler = gpSparse_characters_handler, & + startElement_handler = gpSparse_startElement_handler, & + endElement_handler = gpSparse_endElement_handler) + + call finalise(parse_cur_data) + +! do i = 1, this%n_coordinate +! call gpCoordinates_readXML(this%coordinate(i),xp,label=trim(parse_gpSparse_label)//i,error=error) +! enddo + + this%initialised = .true. + + endsubroutine gpSparse_readXML + + subroutine gpFull_readXML_string(this,params_str,label,error) + type(gpFull), intent(inout), target :: this + character(len=*), intent(in) :: params_str + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + + type(xml_t) :: xp + + INIT_ERROR(error) + + call open_xml_string(xp, params_str) + call gp_readXML(this,xp,label,error) + call close_xml_t(xp) + + endsubroutine gpFull_readXML_string + + subroutine gpCoordinates_readXML_string(this,params_str,label,error) + type(gpCoordinates), intent(inout), target :: this + character(len=*), intent(in) :: params_str + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + + type(xml_t) :: xp + + INIT_ERROR(error) + + call open_xml_string(xp, params_str) + call gp_readXML(this,xp,label,error) + call close_xml_t(xp) + + endsubroutine gpCoordinates_readXML_string + + subroutine gpSparse_readXML_string(this,params_str,label,error) + type(gpSparse), intent(inout), target :: this + character(len=*), intent(in) :: params_str + character(len=*), intent(in), optional :: label + integer, intent(out), optional :: error + + type(xml_t) :: xp + integer :: i + + INIT_ERROR(error) + + call open_xml_string(xp, params_str) + call gp_readXML(this,xp,label,error) + call close_xml_t(xp) + + do i = 1, this%n_coordinate + call gp_readXML(this%coordinate(i),params_str,label=trim(parse_gpSparse_label)//i,error=error) + call gpCoordinates_precalculate_sparse(this%coordinate(i)) + enddo + + endsubroutine gpSparse_readXML_string + + subroutine gpCoordinates_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + real(dp) :: delta, f0 + integer :: status, d, n_sparseX, n_x, n_xPrime, n_permutations, i, x_size_max, xPrime_size_max, sparseX_size_max, covariance_type + logical :: sparsified, exist_sparseX_filename + character(len=32) :: sparseX_md5sum + character(len=1024) :: value + + if(name == 'gpCoordinates') then ! new GP_data + if(parse_in_gpCoordinates) then + call system_abort("gpCoordinates_startElement_handler entered gpCoordinates with parse_in_gpCoordinates true. Probably a bug in FoX (4.0.1, e.g.)") + endif + + if(parse_matched_label) return ! we already found an exact match for this label + + call GP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if(len(trim(parse_gpCoordinates_label)) > 0) then ! we were passed in a label + if(trim(value) == trim(parse_gpCoordinates_label)) then + parse_matched_label = .true. + parse_in_gpCoordinates = .true. + else ! no match + parse_in_gpCoordinates = .false. + endif + else ! no label passed in + parse_in_gpCoordinates = .true. + endif + + if(parse_in_gpCoordinates) then + if(parse_gpCoordinates%initialised) call finalise(parse_gpCoordinates) + + call GP_FoX_get_value(attributes, 'dimensions', value, status) + if (status == 0) then + read (value,*) d + else + call system_abort("gpCoordinates_startElement_handler did not find the dimensions attribute.") + endif + + call GP_FoX_get_value(attributes, 'signal_variance', value, status) + if (status == 0) then + read (value,*) delta + else + call system_abort("gpCoordinates_startElement_handler did not find the signal_variance attribute.") + endif + + call GP_FoX_get_value(attributes, 'signal_mean', value, status) + if (status == 0) then + read (value,*) f0 + else + call system_abort("gpCoordinates_startElement_handler did not find the signal_variance attribute.") + endif + + + call GP_FoX_get_value(attributes, 'sparsified', value, status) + if (status == 0) then + read (value,*) sparsified + else + call system_abort("gpCoordinates_startElement_handler did not find the sparsified attribute.") + endif + + call GP_FoX_get_value(attributes, 'n_permutations', value, status) + if (status == 0) then + read (value,*) n_permutations + else + call system_abort("gpCoordinates_startElement_handler did not find the n_permutations attribute.") + endif + + call GP_FoX_get_value(attributes, 'covariance_type', value, status) + if (status == 0) then + read (value,*) covariance_type + else + call system_abort("gpCoordinates_startElement_handler did not find the covariance_type attribute.") + covariance_type = COVARIANCE_NONE + endif + + call GP_FoX_get_value(attributes, 'zeta', value, status) + if (status == 0) then + if (covariance_type == COVARIANCE_DOT_PRODUCT) then + read (value,*) parse_gpCoordinates%zeta + else + call system_abort("gpCoordinates_startElement_handler found zeta attribute but the covariance is not & + dot product.") + endif + else + if (covariance_type == COVARIANCE_DOT_PRODUCT) then + call print_warning("gpCoordinates_startElement_handler: covariance type is dot product, but no & + zeta attribute is present. This may mean an XML generated by an older version. If found, the single & + value from the theta element will be used, to ensure backwards compatibility") + endif + endif + + call GP_FoX_get_value(attributes, 'x_size_max', value, status) + if (status == 0) then + read (value,*) x_size_max + else + if ((covariance_type == COVARIANCE_BOND_REAL_SPACE) .and. (.not. sparsified)) call system_abort("gpCoordinates_startElement_handler did not find the x_size_max attribute.") + x_size_max = 0 + endif + + call GP_FoX_get_value(attributes, 'xPrime_size_max', value, status) + if (status == 0) then + read (value,*) xPrime_size_max + else + if ((covariance_type == COVARIANCE_BOND_REAL_SPACE) .and. (.not. sparsified)) call system_abort("gpCoordinates_startElement_handler did not find the xPrime_size_max attribute.") + xPrime_size_max = 0 + endif + + call GP_FoX_get_value(attributes, 'sparseX_size_max', value, status) + if (status == 0) then + read (value,*) sparseX_size_max + else + if ((covariance_type == COVARIANCE_BOND_REAL_SPACE) .and. sparsified) call system_abort("gpCoordinates_startElement_handler did not find the sparseX_size_max attribute.") + sparseX_size_max = 0 + endif + + if(sparsified) then + call GP_FoX_get_value(attributes, 'n_sparseX', value, status) + if (status == 0) then + read (value,*) n_sparseX + else + call system_abort("gpCoordinates_startElement_handler did not find the n_sparseX attribute.") + endif + + if (covariance_type == COVARIANCE_BOND_REAL_SPACE) then + call gpCoordinates_setParameters_sparse(parse_gpCoordinates,d,n_sparseX,delta,f0,covariance_type=covariance_type,sparseX_size_max=sparseX_size_max) + else + call gpCoordinates_setParameters_sparse(parse_gpCoordinates,d,n_sparseX,delta,f0, covariance_type=covariance_type) + call GP_FoX_get_value(attributes, 'sparseX_filename', value, status) + if (status == 0) then + inquire(file=trim(value),exist=exist_sparseX_filename) + if(.not.exist_sparseX_filename) call system_abort("gpCoordinates_startElement_handler: sparseX file "//trim(value)//" does not exist.") + + call quip_md5sum(trim(value),sparseX_md5sum) + if( len_trim(sparseX_md5sum) == 0 ) call print_warning("gpCoordinates_startElement_handler: could not obtain md5 sum of sparse file, will not be able & + & to verify consistency with the XML") + + call fread_array_d(size(parse_gpCoordinates%sparseX), parse_gpCoordinates%sparseX(1,1), trim(value)//C_NULL_CHAR) + parse_sparseX_separate_file = .true. + else + parse_sparseX_separate_file = .false. + endif + + if(parse_sparseX_separate_file) then + call GP_FoX_get_value(attributes, 'sparseX_md5sum', value, status) + if (status == 0) then + if( len_trim(value) /= 32 ) call print_warning("gpCoordinates_startElement_handler: recorded md5 sum in the XML is not 32 characters. & + & This could have happened because the md5 tool was not available when the XML was written.") + if( len_trim(value) > 0 .and. len_trim(sparseX_md5sum) > 0 .and. trim(sparseX_md5sum) /= trim(value) ) then + call system_abort("gpCoordinates_startElement_handler: md5 check sum failed. Sparse file ("//sparseX_md5sum// & + ") does not match record in XML ("//trim(value)//")") + endif + endif + endif + endif + else + call GP_FoX_get_value(attributes, 'n_x', value, status) + if (status == 0) then + read (value,*) n_x + else + call system_abort("gpCoordinates_startElement_handler did not find the n_x attribute.") + endif + + call GP_FoX_get_value(attributes, 'n_xPrime', value, status) + if (status == 0) then + read (value,*) n_xPrime + else + call system_abort("gpCoordinates_startElement_handler did not find the n_xPrime attribute.") + endif + + if (covariance_type == COVARIANCE_BOND_REAL_SPACE) then + call gpCoordinates_setParameters(parse_gpCoordinates,d,n_x,n_xPrime,delta,f0,covariance_type=covariance_type,x_size_max=x_size_max,xPrime_size_max=xPrime_size_max) + else + call gpCoordinates_setParameters(parse_gpCoordinates,d,n_x,n_xPrime,delta,f0,covariance_type=covariance_type) + endif + endif + + if (covariance_type == COVARIANCE_BOND_REAL_SPACE .or. covariance_type == COVARIANCE_DOT_PRODUCT) then + allocate(parse_in_permutations(1,n_permutations)) + else + allocate(parse_in_permutations(d,n_permutations)) + endif + + endif + + elseif(parse_in_gpCoordinates .and. name == 'theta') then + call zero(parse_cur_data) + elseif(parse_in_gpCoordinates .and. name == 'descriptor') then + call zero(parse_cur_data) + elseif(parse_in_gpCoordinates .and. name == 'permutation') then + + call GP_FoX_get_value(attributes, 'i', value, status) + if (status == 0) then + read (value,*) i + else + call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") + endif + + parse_i_permutation = i + + call zero(parse_cur_data) + + elseif(parse_in_gpCoordinates .and. name == 'sparseX') then + + parse_in_sparseX = .true. + + if( .not. parse_gpCoordinates%sparsified ) then + call system_abort("gpCoordinates_startElement_handler: not sparsified data and sparseX element found.") + endif + + call GP_FoX_get_value(attributes, 'i', value, status) + if (status == 0) then + read (value,*) i + else + call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") + endif + + call GP_FoX_get_value(attributes, 'alpha', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%alpha(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the alpha attribute.") + endif + + call GP_FoX_get_value(attributes, 'sparseCutoff', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%sparseCutoff(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the cutoff attribute.") + endif + + call GP_FoX_get_value(attributes, 'sliced', value, status) + if (status == 0) then + read (value,*) parse_sliced + else + parse_sliced = .false. + endif + + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call GP_FoX_get_value(attributes, 'sparseX_size', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%sparseX_size(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the sparseX_size attribute.") + endif + endif + + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call GP_FoX_get_value(attributes, 'covariance_sparseX_sparseX', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%covarianceDiag_sparseX_sparseX(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the covariance_sparseX_sparseX attribute.") + endif + endif + + parse_i_sparseX = i + + call zero(parse_cur_data) + + elseif(parse_in_gpCoordinates .and. parse_in_sparseX .and. name == 'sparseX_slice') then + + call GP_FoX_get_value(attributes, 'start', value, status) + if (status == 0) then + read (value,*) parse_slice_start + else + call system_abort("gpCoordinates_startElement_handler did not find the start attribute.") + endif + + call GP_FoX_get_value(attributes, 'end', value, status) + if (status == 0) then + read (value,*) parse_slice_end + else + call system_abort("gpCoordinates_startElement_handler did not find the end attribute.") + endif + + call zero(parse_cur_data) + elseif(parse_in_gpCoordinates .and. name == 'x') then + if( parse_gpCoordinates%sparsified ) then + call system_abort("gpCoordinates_startElement_handler: sparsified=T but x element found.") + endif + + call GP_FoX_get_value(attributes, 'i', value, status) + if (status == 0) then + read (value,*) i + else + call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") + endif + + call GP_FoX_get_value(attributes, 'map_x_y', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%map_x_y(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the map_x_y attribute.") + endif + + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call GP_FoX_get_value(attributes, 'x_size', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%x_size(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the x_size attribute.") + endif + endif + + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call GP_FoX_get_value(attributes, 'covariance_x_x', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%covarianceDiag_x_x(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the covariance_x_x attribute.") + endif + endif + + parse_i_x = i + + call zero(parse_cur_data) + + elseif(parse_in_gpCoordinates .and. name == 'xPrime') then + if( parse_gpCoordinates%sparsified ) then + call system_abort("gpCoordinates_startElement_handler: sparsified=T but xPrime element found.") + endif + + call GP_FoX_get_value(attributes, 'i', value, status) + if (status == 0) then + read (value,*) i + else + call system_abort("gpCoordinates_startElement_handler did not find the i attribute.") + endif + + call GP_FoX_get_value(attributes, 'map_xPrime_yPrime', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%map_xPrime_yPrime(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the map_xPrime_yPrime attribute.") + endif + + call GP_FoX_get_value(attributes, 'map_xPrime_x', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%map_xPrime_x(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the map_xPrime_x attribute.") + endif + + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call GP_FoX_get_value(attributes, 'xPrime_size', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%xPrime_size(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the xPrime_size attribute.") + endif + endif + + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + call GP_FoX_get_value(attributes, 'covariance_xPrime_xPrime', value, status) + if (status == 0) then + read (value,*) parse_gpCoordinates%covarianceDiag_xPrime_xPrime(i) + else + call system_abort("gpCoordinates_startElement_handler did not find the covariance_xPrime_xPrime attribute.") + endif + endif + + parse_i_xPrime = i + + call zero(parse_cur_data) + + endif + + endsubroutine gpCoordinates_startElement_handler + + subroutine gpCoordinates_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if(parse_in_gpCoordinates) then + if(name == 'gpCoordinates') then + call gpCoordinates_setPermutations(parse_gpCoordinates,parse_in_permutations) + deallocate(parse_in_permutations) + parse_in_gpCoordinates = .false. + elseif(name == 'theta') then + !val = string(parse_cur_data) + !read(val,*) parse_gpCoordinates%theta + call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%theta) + if( parse_gpCoordinates%covariance_type == COVARIANCE_DOT_PRODUCT ) then + parse_gpCoordinates%zeta = parse_gpCoordinates%theta(1) + parse_gpCoordinates%theta(1) = 0.0_dp + call print_warning("gpCoordinates_endElement_handler: dot product covariance is used, but found a theta element & + in the XML. This may be a sign of an XML generated by an older version. The first and only element of theta will & + be used as zeta.") + endif + elseif(name == 'descriptor') then + parse_gpCoordinates%descriptor_str = parse_cur_data + elseif(name == 'permutation') then + + if( parse_i_permutation > size(parse_in_permutations,2) ) then + call system_abort("gpCoordinates_endElement_handler: parse_i_permutation ("//parse_i_permutation//") greater than n_permutations ("//size(parse_in_permutations,2)//")") + endif + + !val = string(parse_cur_data) + !read(val,*) parse_in_permutations(:,parse_i_permutation) + call string_to_numerical(string(parse_cur_data),parse_in_permutations(:,parse_i_permutation)) + elseif(name == 'sparseX') then + + if( .not. allocated(parse_gpCoordinates%sparseX) ) then + call system_abort("gpCoordinates_endElement_handler: sparseX not allocated") + endif + + if( parse_i_sparseX > parse_gpCoordinates%n_sparseX ) then + call system_abort("gpCoordinates_endElement_handler: parse_i_sparseX ("//parse_i_sparseX//") greater than n_sparseX ("//parse_gpCoordinates%n_sparseX//")") + endif + + !val = string(parse_cur_data) + !read(val,*) parse_gpCoordinates%sparseX(:,parse_i_sparseX) + if( parse_gpCoordinates%covariance_type == COVARIANCE_BOND_REAL_SPACE ) then + parse_gpCoordinates%sparseX(:,parse_i_sparseX) = 0.0_dp + call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%sparseX(:parse_gpCoordinates%sparseX_size(parse_i_sparseX),parse_i_sparseX)) + else + if(.not. parse_sparseX_separate_file .and. .not. parse_sliced) call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%sparseX(:,parse_i_sparseX)) + endif + + parse_in_sparseX = .false. + elseif(name == 'sparseX_slice') then + if(parse_slice_start < 1) then + call system_abort("gpCoordinates_endElement_handler: slice start less than 1") + endif + + if(parse_slice_end > parse_gpCoordinates%d) then + call system_abort("gpCoordinates_endElement_handler: slice start greater than dimension") + endif + + if(.not. parse_sparseX_separate_file .and. parse_sliced) call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%sparseX(parse_slice_start:parse_slice_end,parse_i_sparseX)) + elseif(name == 'x') then + + if( .not. allocated(parse_gpCoordinates%x) ) then + call system_abort("gpCoordinates_endElement_handler: x not allocated") + endif + + if( parse_i_x > parse_gpCoordinates%n_x ) then + call system_abort("gpCoordinates_endElement_handler: parse_i_x ("//parse_i_x//") greater than n_x ("//parse_gpCoordinates%n_x//")") + endif + + !val = string(parse_cur_data) + !read(val,*) parse_gpCoordinates%x(:,parse_i_x) + call string_to_numerical(string(parse_cur_data),parse_gpCoordinates%x(:,parse_i_x)) + elseif(name == 'xPrime') then + + if( .not. allocated(parse_gpCoordinates%xPrime) ) then + call system_abort("gpCoordinates_endElement_handler: xPrime not allocated") + endif + + if( parse_i_xPrime > parse_gpCoordinates%n_xPrime ) then + call system_abort("gpCoordinates_endElement_handler: parse_i_xPrime ("//parse_i_xPrime//") greater than n_xPrime ("//parse_gpCoordinates%n_xPrime//")") + endif + + !val = string(parse_cur_data) + !read(val,*) parse_gpCoordinates%xPrime(:,parse_i_xPrime) + call string_to_numerical(string(parse_cur_data), parse_gpCoordinates%xPrime(:,parse_i_xPrime)) + endif + endif + + endsubroutine gpCoordinates_endElement_handler + + subroutine gpCoordinates_characters_handler(in) + character(len=*), intent(in) :: in + + if(parse_in_gpCoordinates) then + call concat(parse_cur_data, in, keep_lf=.false.,lf_to_whitespace=.true.) + endif + endsubroutine gpCoordinates_characters_handler + + subroutine gpFull_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status, n_y, n_yPrime, n_coordinate, i + real(dp) :: sparse_jitter + character(len=1024) :: value + + if(name == 'gpFull') then ! new GP_data + if(parse_in_gpFull) then + call system_abort("gpFull_startElement_handler entered gpFull with parse_in_gpFull true. Probably a bug in FoX (4.0.1, e.g.)") + endif + + if(parse_matched_label) return ! we already found an exact match for this label + + call GP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if(len(trim(parse_gpFull_label)) > 0) then ! we were passed in a label + if(trim(value) == trim(parse_gpFull_label)) then + parse_matched_label = .true. + parse_in_gpFull = .true. + else ! no match + parse_in_gpFull = .false. + endif + else ! no label passed in + parse_in_gpFull = .true. + endif + + if(parse_in_gpFull) then + if(parse_gpFull%initialised) call finalise(parse_gpFull) + + call GP_FoX_get_value(attributes, 'n_y', value, status) + if (status == 0) then + read (value,*) n_y + else + call system_abort("gpFull_startElement_handler did not find the n_y attribute.") + endif + + call GP_FoX_get_value(attributes, 'n_yPrime', value, status) + if (status == 0) then + read (value,*) n_yPrime + else + call system_abort("gpFull_startElement_handler did not find the n_yPrime attribute.") + endif + + call GP_FoX_get_value(attributes, 'n_coordinate', value, status) + if (status == 0) then + read (value,*) n_coordinate + else + call system_abort("gpFull_startElement_handler did not find the n_coordinate attribute.") + endif + + call GP_FoX_get_value(attributes, 'sparse_jitter', value, status) + if (status == 0) then + read (value,*) sparse_jitter + else + call print_warning("gpFull_startElement_handler did not find the sparse_jitter attribute, using default value 1.0e-5.") + sparse_jitter = 1.0e-5_dp + endif + call gpFull_setParameters(parse_gpFull,n_coordinate, n_y, n_yPrime, sparse_jitter) + + endif + + elseif(parse_in_gpFull .and. name == 'y') then + + call GP_FoX_get_value(attributes, 'i', value, status) + if (status == 0) then + read (value,*) i + else + call system_abort("gpFull_startElement_handler did not find the i attribute.") + endif + + call GP_FoX_get_value(attributes, 'map_y_globalY', value, status) + if (status == 0) then + read (value,*) parse_gpFull%map_y_globalY(i) + else + call system_abort("gpFull_startElement_handler did not find the map_y_globalY attribute.") + endif + + call GP_FoX_get_value(attributes, 'alpha', value, status) + if (status == 0) then + read (value,*) parse_gpFull%alpha(parse_gpFull%map_y_globalY(i)) + else + call system_abort("gpFull_startElement_handler did not find the alpha attribute.") + endif + + elseif(parse_in_gpFull .and. name == 'yPrime') then + + call GP_FoX_get_value(attributes, 'i', value, status) + if (status == 0) then + read (value,*) i + else + call system_abort("gpFull_startElement_handler did not find the i attribute.") + endif + + call GP_FoX_get_value(attributes, 'map_yPrime_globalY', value, status) + if (status == 0) then + read (value,*) parse_gpFull%map_yPrime_globalY(i) + else + call system_abort("gpFull_startElement_handler did not find the map_yPrime_globalY attribute.") + endif + + call GP_FoX_get_value(attributes, 'alpha', value, status) + if (status == 0) then + read (value,*) parse_gpFull%alpha(parse_gpFull%map_yPrime_globalY(i)) + else + call system_abort("gpFull_startElement_handler did not find the alpha attribute.") + endif + + endif + + endsubroutine gpFull_startElement_handler + + subroutine gpFull_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if(parse_in_gpFull) then + if(name == 'gpFull') then + parse_in_gpFull = .false. + endif + elseif(name == 'y') then + + elseif(name == 'yPrime') then + + endif + + endsubroutine gpFull_endElement_handler + + subroutine gpFull_characters_handler(in) + character(len=*), intent(in) :: in + + if(parse_in_gpFull) then + call concat(parse_cur_data, in, keep_lf=.false.,lf_to_whitespace=.true.) + endif + endsubroutine gpFull_characters_handler + + subroutine gpSparse_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status, n_coordinate + character(len=1024) :: value + + if(name == 'gpSparse') then ! new GP_data + if(parse_in_gpSparse) then + call system_abort("gpSparse_startElement_handler entered gpSparse with parse_in_gpSparse true. Probably a bug in FoX (4.0.1, e.g.)") + endif + + if(parse_matched_label) return ! we already found an exact match for this label + + call GP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if(len(trim(parse_gpSparse_label)) > 0) then ! we were passed in a label + if(trim(value) == trim(parse_gpSparse_label)) then + parse_matched_label = .true. + parse_in_gpSparse = .true. + else ! no match + parse_in_gpSparse = .false. + endif + else ! no label passed in + parse_in_gpSparse = .true. + endif + + if(parse_in_gpSparse) then + if(parse_gpSparse%initialised) call finalise(parse_gpSparse) + + call GP_FoX_get_value(attributes, 'n_coordinate', value, status) + if (status == 0) then + read (value,*) n_coordinate + else + call system_abort("gpSparse_startElement_handler did not find the n_coordinate attribute.") + endif + call gpSparse_setParameters(parse_gpSparse,n_coordinate) + + call GP_FoX_get_value(attributes, 'fitted', value, status) + if (status == 0) then + read (value,*) parse_gpSparse%fitted + else + parse_gpSparse%fitted = .true. ! for backward compatibility + endif + + endif + + endif + + endsubroutine gpSparse_startElement_handler + + subroutine gpSparse_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if(parse_in_gpSparse) then + if(name == 'gpSparse') then + parse_in_gpSparse = .false. + endif + endif + + endsubroutine gpSparse_endElement_handler + + subroutine gpSparse_characters_handler(in) + character(len=*), intent(in) :: in + + if(parse_in_gpSparse) then + call concat(parse_cur_data, in, keep_lf=.false.,lf_to_whitespace=.true.) + endif + endsubroutine gpSparse_characters_handler + + subroutine gp_FoX_get_value(attributes, key, val, status) + type(dictionary_t), intent(in) :: attributes + character(len=*), intent(in) :: key + character(len=*), intent(inout) :: val + integer, intent(out), optional :: status + + if (HasKey(attributes,key)) then + val = GetValue(attributes, trim(key)) + if (present(status)) status = 0 + else + val = "" + if (present(status)) status = 1 + endif + end subroutine gp_FoX_get_value + +end module gp_predict_module diff --git a/make_permutations_noncommercial_v2.F90 b/make_permutations_noncommercial_v2.F90 new file mode 100644 index 00000000..329b641c --- /dev/null +++ b/make_permutations_noncommercial_v2.F90 @@ -0,0 +1,733 @@ +!!$ +!!$------------Permutation Generator---Alan Nichol--------------------------------- + +!!$ Generate permutations of the interatomic distance vector of +!!$ a number of atoms. Information about the symmetries present in the cluster +!!$ is specified as an array called 'equivalents' - this is generated automatically +!!$ when a permutation_data_type is initialised with one or more 'signatures' which +!!$ are integer arrays of the atomic numbers. +!!$ +!!$ For systems where not all atoms of the same Z are equivalent, the symmetries can +!!$ be specified beforehand by passing an equivalents array to permutation_data_initialise +!!$ An example for toluene would be the following: +!!$ +!!$ Toluene : C_6 H_5 - CH_3 +!!$ +!!$ Atoms in order +!!$ C1 C2 H C3 H C4 H C5 H C6 H C7 H H H +!!$ +!!$ where C1 is the tertiary carbon and C2-C6 go in order about the benzene ring +!!$ C7 is the methyl carbon +!!$ +!!$ +!!$ 15 Atoms in total, and two permutational symmetries. So equivalents array is 2X15 +!!$ Symmetry of the 3 methyl hydrogens is specified by the first row: +!!$ ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 11, 111) +!!$ +!!$ And the symmetry of the benzene ring is specified by the second row: +!!$ ( 0, 1, 2, 3, 4, 0, 0, 33, 44, 11, 22, 0, 0 ,0 ,0) +!!$ +!!$-------------------------------------------------------------------------------- +!!$-------------------------------------------------------------------------------- + + +#include "error.inc" + +module permutation_maker_module + use error_module + use system_module, only : dp, print, optional_default, system_timer, operator(//) + + implicit none + +type permutation_data_type + integer :: perm_number, n_perms + integer, dimension(:), allocatable :: signature_one, signature_two, signature_three, counter, rank, dist_vec !dist_vec is internal name for descriptor + integer, dimension(:,:), allocatable :: dist_vec_permutations + integer, dimension(:,:,:), allocatable :: perm_array + logical :: internal_swaps_only, initialised +endtype permutation_data_type + +!% Overloaded assigment operators for permutation data objects. +private :: permutation_data_assignment +interface assignment(=) + module procedure permutation_data_assignment +end interface assignment(=) + +contains + +subroutine permutation_data_assignment(to,from) +!this is the slow way to copy this object, because it goes through the motions of initialisation again +! call permutation_data_copy for a much faster alternative + type(permutation_data_type), intent(inout) :: to + type(permutation_data_type), intent(in) :: from + + ! We do not fail if *from* is unitialised, since overloaded operator + ! routines are outside scope of error handling mechanism. + if(.not. from%initialised) then + call permutation_data_finalise(to) + return + end if + + call permutation_data_initialise(to,signature_one=from%signature_one,signature_two=from%signature_two,signature_three=from%signature_three,internal_swaps_only=from%internal_swaps_only) + +end subroutine permutation_data_assignment + +subroutine permutation_data_copy(to,from) + type(permutation_data_type), intent(inout) :: to + type(permutation_data_type), intent(in) :: from + + if(.not. from%initialised) then + call permutation_data_finalise(to) + return + end if + + + allocate(to%counter(size(from%counter))) + allocate(to%rank(size(from%rank))) + allocate(to%dist_vec(size(from%dist_vec))) + allocate(to%dist_vec_permutations(size(from%dist_vec_permutations,1),size(from%dist_vec_permutations,2))) + allocate(to%perm_array(size(from%perm_array,1),size(from%perm_array,2),size(from%perm_array,3))) + + if (allocated(from%signature_one)) then + allocate(to%signature_one(size(from%signature_one))) + to%signature_one = from%signature_one + if (allocated(from%signature_two)) then + allocate(to%signature_two(size(from%signature_two))) + to%signature_two = from%signature_two + if (allocated(from%signature_three)) then + allocate(to%signature_three(size(from%signature_three))) + to%signature_three = from%signature_three + end if + end if + end if + to%counter = from%counter + to%rank = from%rank + to%dist_vec = from%dist_vec + to%dist_vec_permutations = from%dist_vec_permutations + to%perm_array = from%perm_array + + to%n_perms = from%n_perms + to%internal_swaps_only = from%internal_swaps_only + + to%initialised = .true. + to%perm_number = 1 + +end subroutine permutation_data_copy + +subroutine equivalents_row_atoms(equivalents_row,signature,offset,N) + implicit none + integer, dimension(:), allocatable, intent(inout) :: equivalents_row + integer, dimension(:), intent(in) :: signature + integer, dimension(:), allocatable :: scratch_row, equivalents_temp + integer, intent(in) :: offset, N + integer :: z_index, i, j, repeats + + allocate(scratch_row(N)) + allocate(equivalents_temp(1)) + + do z_index=1,maxval(signature) + repeats=0 + scratch_row=0 + do i=1,size(signature) + if (signature(i) == z_index) then + do j=repeats,0,-1 + scratch_row(i+offset)=scratch_row(i+offset)+10**(j) + end do + repeats = repeats+1 + end if + end do + if (repeats .le. 1) cycle + + if (.not. allocated(equivalents_row)) then + allocate(equivalents_row(N)) + equivalents_row=scratch_row + else + deallocate(equivalents_temp) + allocate(equivalents_temp(size(equivalents_row))) + equivalents_temp=equivalents_row + deallocate(equivalents_row) + allocate(equivalents_row(size(equivalents_temp)+N)) + equivalents_row=(/equivalents_temp,scratch_row/) + end if + end do + +end subroutine equivalents_row_atoms + +subroutine equivalents_row_monomers(equivalents_row,N,signature,pos_a,pos_b,pos_c) + + integer,dimension(:), allocatable, intent(inout) :: equivalents_row + integer, intent(in) :: N, pos_a, pos_b + integer, intent(in), optional :: pos_c + integer :: i + integer, dimension(:), intent(in) :: signature + integer, dimension(:), allocatable :: scratch_row, equivalents_temp + + allocate(scratch_row(N)) + allocate(equivalents_temp(1)) + scratch_row=0 + + do i=1,size(signature) + scratch_row(i+pos_a) = i + scratch_row(i+pos_b) = i*11 + if (present(pos_c)) then + scratch_row(i+pos_c) = i*111 + end if + end do + + if (.not. allocated(equivalents_row)) then + allocate(equivalents_row(N)) + equivalents_row=scratch_row + else + deallocate(equivalents_temp) + allocate(equivalents_temp(size(equivalents_row))) + equivalents_temp=equivalents_row + deallocate(equivalents_row) + allocate(equivalents_row(size(equivalents_temp)+N)) + equivalents_row=(/equivalents_temp,scratch_row/) + end if + +end subroutine equivalents_row_monomers + +subroutine permutation_data_initialise(this,equivalents_input,signature_one,signature_two,signature_three,internal_swaps_only,error) + ! better make sure that all these optional things are fed in as key=value, because relying on ordering is asking for trouble + implicit none + type(permutation_data_type) :: this + integer, dimension(:), allocatable :: counter, rank, dist_vec, equivalents_row, scratch_row, & + equivalents_temp, atoms, group + integer, dimension(:), allocatable :: signature + integer, dimension(:), optional :: signature_one, signature_two, signature_three +! integer, dimension(:) :: signature_one + integer, dimension(:,:), optional :: equivalents_input + integer, dimension(:,:), allocatable :: group_array, dist_vec_permutations, equivalents + integer, dimension(:,:,:), allocatable :: perm_array + integer, optional, intent(out) :: error + integer :: repeats, num_groups, N, dist_vec_n_perms, i,j,z_index,max_rank,num_distances, & + num_perms, offset_one, offset_two, offset_three, n_atoms_one, n_atoms_two, n_atoms_three + logical, optional :: internal_swaps_only + logical :: two_monomers_given, three_monomers_given, my_internal_swaps_only + real(dp) :: cutoff + + INIT_ERROR(error) + + call permutation_data_finalise(this) + + + two_monomers_given=.false. + three_monomers_given=.false. + + ! automatic generation of equivalents array based on atomic numbers + if (present(equivalents_input)) then + if (present(signature_one)) then + RAISE_ERROR('permutation_data_initialise: mixing of automatically generated permutations and pre-specified symmetries not well defined', error) + end if + N= size(equivalents_input,2) + num_groups = size(equivalents_input,1) + allocate(equivalents(num_groups,N)) + equivalents = equivalents_input + else + if (.not. present(signature_one)) then + RAISE_ERROR('permutation_data_initialise doesnt know which permutations to do, provide a signature or equivalents array', error) + end if + + n_atoms_one=size(signature_one) + if(present(signature_two)) then + if ( size(signature_two) .ge. 1) then + two_monomers_given= .true. + n_atoms_two=size(signature_two) + if(present(signature_three)) then + if ( size(signature_three) .ge. 1) then + three_monomers_given= .true. + n_atoms_three=size(signature_three) + end if + end if + end if + end if + my_internal_swaps_only = optional_default(.true., internal_swaps_only) + + if (three_monomers_given) then + N = size(signature_one)+size(signature_two)+size(signature_three) + else if (two_monomers_given) then + N = size(signature_one)+size(signature_two) + else + N = size(signature_one) + end if + + + allocate(scratch_row(N)) + allocate(equivalents_temp(1)) + if (two_monomers_given .and. .not. three_monomers_given) then + if (n_atoms_one .eq. n_atoms_two) then + if (count(signature_one .ne. signature_two) .eq. 0) then + offset_one=0 + offset_two=size(signature_one) + call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two) + end if + end if + else if (three_monomers_given) then + if (n_atoms_one .eq. n_atoms_two) then + if (count(signature_one .ne. signature_two) .eq. 0) then + ! one and two are equivalent + if (n_atoms_one .eq. n_atoms_three) then + if (count(signature_one .ne. signature_three) .eq. 0) then + ! all three are equivalent + offset_one=0 + offset_two=size(signature_one) + offset_three =size(signature_one)+size(signature_two) + call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two,offset_three) + end if + else + ! only one and two are equivalent + offset_one=0 + offset_two=size(signature_one) + call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two) + end if + end if + else if (n_atoms_one .eq. n_atoms_three) then + if (count(signature_one .ne. signature_three) .eq. 0) then + ! only one and three are equivalent + offset_one=0 + offset_two=size(signature_one)+size(signature_two) + call equivalents_row_monomers(equivalents_row,N,signature_one,offset_one,offset_two) + end if + else if (n_atoms_two .eq. n_atoms_three) then + if (count(signature_two .ne. signature_three) .eq. 0) then + ! only two and three are equivalent + offset_one=size(signature_one) + offset_two=size(signature_one)+size(signature_two) + call equivalents_row_monomers(equivalents_row,N,signature_two,offset_one,offset_two) + end if + end if + end if + + ! if more than one signature is given, and swapping atoms between monomers is allowed + ! then the signatures get concatenated to 'signature'. Otherwise 'signature' is just set + ! to refer to signature_one + if(two_monomers_given) then + if (my_internal_swaps_only) then + allocate(signature(size(signature_one))) + signature = signature_one + else if (three_monomers_given) then + allocate(signature(size(signature_one)+size(signature_two)+size(signature_three))) + signature = (/signature_one,signature_two,signature_three/) + else + allocate(signature(size(signature_one)+size(signature_two))) + signature = (/signature_one,signature_two/) + end if + else + allocate(signature(size(signature_one))) + signature = signature_one + end if + + offset_one=0 + + call equivalents_row_atoms(equivalents_row,signature,offset_one,N) + if (two_monomers_given .and. my_internal_swaps_only) then + offset_one=size(signature) + call equivalents_row_atoms(equivalents_row,signature_two,offset_one,N) + if (three_monomers_given .and. my_internal_swaps_only) then + offset_one =size(signature)+size(signature_two) + call equivalents_row_atoms(equivalents_row,signature_three,offset_one,N) + end if + end if + + if (.not. allocated(equivalents_row)) then + num_groups=0 ! only identity permutation + else + num_groups=size(equivalents_row)/N + allocate(equivalents(num_groups,N)) + ! make the equivalents array + equivalents =transpose(reshape(equivalents_row,(/ size(equivalents, 2), size(equivalents, 1) /))) + endif + + end if + +!!$write(*,*) 'equivalents array' +!!$ do i=1,size(equivalents,1) +!!$ write(*,*) equivalents(i,:) +!!$ end do + + + + +!--------- Further Array allocations and Initialisation --------------------------! + allocate(atoms(N)) + allocate(group(N)) + do i=1,size(atoms) + atoms(i)=i + end do + + num_distances = N*(N-1)/2 + allocate(dist_vec(num_distances)) + + allocate(counter(num_groups)) + allocate(rank(num_groups)) + + !make rank vector + do i=1,num_groups + group(:) = equivalents(i,:) + num_perms = num_group_perms(group) + rank(i) = num_perms + end do + + + max_rank = maxval(rank) + + !get total number of permutations + dist_vec_n_perms = 1 + do i=1,size(rank) + dist_vec_n_perms = dist_vec_n_perms*rank(i) + end do + + !initialise counter + counter=1 + + allocate(dist_vec_permutations(num_distances,dist_vec_n_perms)) + allocate(group_array(max_rank,N)) + allocate(perm_array(num_groups,N,max_rank)) + + !initialise arrays permutations to zero + perm_array = 0 + dist_vec_permutations=0 + + +!-------------------------------------------------------------------------! +!make 2D array of permutations of each group and add to 3D array perm_array +!-------------------------------------------------------------------------! + do i = 1,num_groups + group(:) = equivalents(i,:) + group_array = permute_atoms(atoms,group,N,max_rank)!this padded with zeroes in case group is of less than max_rank + do j=1,size(group_array, 1) + perm_array(i,:,j) = group_array(j,:) + end do + end do + + +!-------------------------------------------------------------------------! +!Now assign relevant stuff to the permutation_data_type +!-------------------------------------------------------------------------! + + + if (present(signature_one)) then + allocate(this%signature_one(size(signature_one))) + this%signature_one=signature_one + end if + if (two_monomers_given) then + allocate(this%signature_two(size(signature_two))) + this%signature_two=signature_two + end if + if (three_monomers_given) then + allocate(this%signature_three(size(signature_three))) + this%signature_three=signature_three + end if + +!- If there's only one permutation then write it out explicitly here + if (num_groups == 0) then + do i=1,num_distances + dist_vec_permutations(i,1)=i + end do + end if + + allocate(this%counter(size(counter))) + allocate(this%rank(size(rank))) + allocate(this%perm_array(size(perm_array,1),size(perm_array,2),size(perm_array,3))) + allocate(this%dist_vec(num_distances)) + allocate(this%dist_vec_permutations(size(dist_vec_permutations,1),size(dist_vec_permutations,2))) + + + this%counter=counter + this%rank=rank + this%perm_array=perm_array + this%dist_vec_permutations=dist_vec_permutations + this%perm_number=1 + this%n_perms=dist_vec_n_perms + this%initialised=.true. + +end subroutine permutation_data_initialise + +subroutine permutation_data_finalise(this) + implicit none + type(permutation_data_type) :: this + + if (.not. this%initialised) return + + if(allocated(this%signature_one)) deallocate(this%signature_one) + if(allocated(this%signature_two)) deallocate(this%signature_two) + if(allocated(this%counter)) deallocate(this%counter) + if(allocated(this%rank)) deallocate(this%rank) + if(allocated(this%perm_array)) deallocate(this%perm_array) + if(allocated(this%dist_vec)) deallocate(this%dist_vec) + if(allocated(this%dist_vec_permutations)) deallocate(this%dist_vec_permutations) + this%initialised = .false. + +end subroutine permutation_data_finalise + + subroutine add_combined_permutation (counter, perm_array, dist_vec_permutations,perm_number) + implicit none + ! this gets called by the subroutine next, it should receive a vector 'counter' from which it + ! figures out which permutations to combine. It then asks combine_perms to do so and + ! gets the dist_vec vector from do_swaps + integer :: i, num_distances, N, perm_number + integer, dimension(:), intent(inout) :: counter + integer, dimension(:), allocatable :: combo, next_perm, dist_vec + integer, dimension(:,:,:), intent(in) :: perm_array + integer, dimension(:,:) :: dist_vec_permutations + + N=size(perm_array,2) + num_distances = N*(N-1)/2 + allocate(dist_vec(num_distances)) + allocate(combo(N)) + allocate(next_perm(N)) + + combo = perm_array(1,:,counter(1)) + do i=1, size(counter)-1 + next_perm = perm_array(i+1,:,counter(i+1)) + combo = combine_perms(combo,next_perm) + end do + call do_swaps(combo, dist_vec) + + dist_vec_permutations(:,perm_number)=dist_vec + + deallocate(dist_vec) + deallocate(combo) + deallocate(next_perm) + + end subroutine add_combined_permutation + + recursive subroutine next(this, m) + implicit none + type(permutation_data_type), intent(inout) :: this + integer :: m, num_groups + + num_groups = size(this%counter) + + if (m .gt. num_groups) then + + call add_combined_permutation(this%counter, this%perm_array, this%dist_vec_permutations, this%perm_number) + this%perm_number=this%perm_number+1 + + else + do while (this%counter(m) .lt. this%rank(m)) + call next(this, m+1) + this%counter(m+1:) = 1 + this%counter(m) = this%counter(m) + 1 + end do + this%counter(m+1:) = 1 + call next(this,m+1) + + end if + end subroutine next + + function num_group_perms(group) + implicit none + integer :: num_group_perms, n_members + integer, dimension(:) :: group + integer, dimension(8) :: factorial + + factorial = (/ 1,2,6,24,120,720,5040,40320 /) + n_members = ceiling(log10(real(maxval(group)))) + num_group_perms = factorial(n_members) + return + end function num_group_perms + + ! This modified from Rosetta Code + recursive subroutine update_matrix(std_perms,n_members,position,i_perm,perm_vec) + implicit none + integer :: n_members, value, position, i_perm + integer, dimension(:,:) :: std_perms + integer, dimension(:) :: perm_vec + + if (position > n_members) then + std_perms(i_perm,:) = perm_vec + i_perm=i_perm+1 + else + do value = 1, n_members + if (.not. any (perm_vec(:position - 1) == value)) then + perm_vec(position)= value + call update_matrix(std_perms,n_members,position+1,i_perm,perm_vec) + end if + end do + end if + end subroutine update_matrix + + function permute_atoms(atoms,group,N,max_rank) + implicit none + integer :: i, j, k, i_perm, n_members, num_perms, atoms_per_monomer + integer, intent(IN) :: N, max_rank + integer, dimension(N) :: atoms, group + integer, dimension(:,:), allocatable :: permute_atoms, std_perms + integer, dimension(:), allocatable :: group_vec, perm_vec, indices, offsets + integer, dimension(1) :: p, q, temp + + n_members = ceiling(log10(real(maxval(group)))) + num_perms = num_group_perms(group) + allocate(group_vec(n_members)) + allocate(perm_vec(n_members)) + !allocate(indices(n_members)) + allocate(std_perms(num_perms,n_members)) + allocate(permute_atoms(max_rank,N)) + permute_atoms = 0 + + if (num_perms .eq. 2) then + !just a pair of equivalent atoms or monomers + permute_atoms(1,:) = atoms + permute_atoms(2,:) = atoms + do i=1,count(group .lt. 10 .and. group .gt. 0) + p = minloc(group, mask=group .ge. i) + q = minloc(group, mask=group .gt. 10*i) + !write(*,*) "equivalent pair" + !write(*,'(2I3)') p,q + temp = permute_atoms(2,p(1)) + permute_atoms(2,p(1)) = permute_atoms(2,q(1)) + permute_atoms(2,q(1)) = temp(1) + end do + else + !Permutations of groups of >2 atoms, no support for >2 monomers yet + i_perm=1 + call update_matrix(std_perms,n_members,1,i_perm,perm_vec) + + + if (.not. any(group .eq. 2)) then ! permutations of identical atoms + allocate(indices(n_members)) + ! get indices of equivalent atoms + do i=1,n_members + temp =minloc(group, mask = group .ge. 10**(i-1)) + indices(i) = temp(1) + end do + + do i=1,size(std_perms,1) + perm_vec = std_perms(i,:) + group_vec = indices(perm_vec) + do j=1,n_members + permute_atoms(i,indices(j)) = group_vec(j) + end do + do j=1,N + if (permute_atoms(i,j) ==0) permute_atoms(i,j) = j + end do + end do + + else ! permutations of identical monomers + allocate(offsets(n_members)) + atoms_per_monomer = maxval(group, mask = group .lt. 10) +! allocate(indices(n_members*atoms_per_monomer)) + + do i=1,n_members + ! find the 1, 11, 111, etc. with which the monomer starts + temp =minloc(group, mask = group .ge. 10**(i-1)) + offsets(i) = temp(1)-1 +!!$ do j=1,atoms_per_monomer +!!$ indices(j+(i-1)*n_members) = j + offsets(i) +!!$ end do + end do + + do i=1,size(std_perms,1) + perm_vec = std_perms(i,:) + group_vec = offsets(perm_vec) + do j=1,n_members + do k=1,atoms_per_monomer + permute_atoms(i,k+offsets(j)) = k+group_vec(j) + end do + end do + do j=1,N + if (permute_atoms(i,j) ==0) permute_atoms(i,j) = j + end do + end do + + end if + end if + + return + + end function permute_atoms + + function combine_perms(vec1,vec2) + implicit none + integer, dimension(:), intent(in) :: vec1, vec2 + integer, dimension(:), allocatable :: combine_perms + integer :: j + allocate(combine_perms(size(vec1))) + + if (size(vec1) /= size(vec2)) then + write(*,*) "combine_perms received vectors of mismatched lengths" + call exit(1) + end if + + do j=1,size(vec1) + combine_perms(j) = vec1(vec2(j)) + end do + return + end function combine_perms + + subroutine do_swaps(atom_vec, dist_vec) + implicit none + integer :: N, start, finish, length, temp, j, i + integer, dimension(:), intent(in) :: atom_vec + integer, dimension(:) :: dist_vec + integer, dimension(1) :: i_vec + integer, dimension(:), allocatable :: temp_vec, scratch_vec!, do_swaps + integer, dimension(:,:), allocatable :: dist_mat, dist_mat_upper + + !initialise vector and matrix + N = size(atom_vec) + allocate(scratch_vec(N)) + allocate(temp_vec(N)) + do i=1,N + temp_vec(i)=i + end do + + do i=1,size(dist_vec) + dist_vec(i)=i + end do + + + allocate(dist_mat(N,N)) + allocate(dist_mat_upper(N,N)) + dist_mat=0 + dist_mat_upper = 0 + + start = 1 + do i=1,N + finish=start + N-i + dist_mat_upper(i,i+1:N) = dist_vec(start:finish-1) + start = finish + end do + + dist_mat = dist_mat_upper + transpose(dist_mat_upper) + + do while (any(temp_vec .ne. atom_vec)) + + i_vec = minloc(temp_vec, temp_vec .ne. atom_vec) + i=i_vec(1) + + ! keep track of swaps + temp = temp_vec(i) + temp_vec(i) = temp_vec(atom_vec(i)) + temp_vec(atom_vec(i)) = temp + ! now swap in array - rows then columns + scratch_vec = dist_mat(i,:) + dist_mat(i,:) = dist_mat(atom_vec(i),:) + dist_mat(atom_vec(i),:) = scratch_vec + + scratch_vec = dist_mat(:,i) + dist_mat(:,i) = dist_mat(:,atom_vec(i)) + dist_mat(:,atom_vec(i)) = scratch_vec + end do + + !convert back into vector + + start = 1 + finish=N-1 + do i=1,N-1 + dist_vec(start:finish) = dist_mat(i,i+1:N) + start = finish+1 + finish = finish+N-i-1 + end do + + + deallocate(temp_vec) + deallocate(scratch_vec) + deallocate(dist_mat) + deallocate(dist_mat_upper) + return + end subroutine do_swaps + +end module permutation_maker_module From 045127d30c7a06fad53b407e8e8a23f7e7bf50f0 Mon Sep 17 00:00:00 2001 From: James Kermode Date: Sat, 4 Oct 2025 23:40:48 +0100 Subject: [PATCH 6/7] Fix meson build configuration for GAP MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Update gapversion script to use .F90 file extensions instead of .f95 - Add -lgomp link argument to meson.build for OpenMP support These changes fix build issues when building GAP with the meson build system. 🤖 Generated with [Claude Code](https://claude.com/claude-code) Co-Authored-By: Claude --- gapversion | 8 ++++---- meson.build | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/gapversion b/gapversion index 4edc491c..502cef8a 100755 --- a/gapversion +++ b/gapversion @@ -4,10 +4,10 @@ # of file (or the file GAP_VERSION if it exists). The gapversion # is the UNIX timestap of the most recently changed file. -GAP_FILES="descriptors.f95 descriptors_wrapper.f95 \ - gp_predict.f95 \ - clustering.f95 gp_fit.f95 \ - gap_fit_module.f95 gap_fit.f95" +GAP_FILES="descriptors.F90 descriptors_wrapper.F90 \ + gp_predict.F90 \ + clustering.F90 gp_fit.F90 \ + gap_fit_module.F90 gap_fit.F90" GAP_ROOT=$(dirname "$0") diff --git a/meson.build b/meson.build index acd4f4bc..66e39f8a 100644 --- a/meson.build +++ b/meson.build @@ -20,4 +20,5 @@ GAP = library('GAP', mpi_dep, ], link_with : [libAtoms,fox], + link_args: ['-lgomp'], ) From cefcbc005e955ab4e6795f5cf349ee754e527f25 Mon Sep 17 00:00:00 2001 From: James Kermode Date: Sun, 5 Oct 2025 11:52:44 +0100 Subject: [PATCH 7/7] Fix Fortran format string for gfortran 15.1.0 compatibility MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixed format descriptor in gap_fit_module.F90 line 1603 to be compatible with gfortran 15.1.0. Changed from: write(gp_label,'("GAP_"7(i0,"_")i0)') to: write(gp_label,'("GAP_",7(i0,"_"),i0)') This adds the required comma separators between format descriptors, which gfortran 15.1.0 enforces more strictly. The generated unique IDs remain identical in format. Error fixed: Fortran runtime error: Missing comma between descriptors 🤖 Generated with [Claude Code](https://claude.com/claude-code) Co-Authored-By: Claude --- gap_fit_module.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gap_fit_module.F90 b/gap_fit_module.F90 index 3a6349b9..b4834e15 100644 --- a/gap_fit_module.F90 +++ b/gap_fit_module.F90 @@ -1600,7 +1600,7 @@ subroutine gap_fit_print_xml(this,filename,sparseX_separate_file) call date_and_time(values=values) ! Get totally unique label for GAP. This will be used at various places. - write(gp_label,'("GAP_"7(i0,"_")i0)') values + write(gp_label,'("GAP_",7(i0,"_"),i0)') values ! Unique temporary file gp_tmp_file = 'tmp_'//trim(gp_label)//'.xml'