From af6b03e2639da885032eefe1c59e368ae11984d9 Mon Sep 17 00:00:00 2001
From: David Sagan <dcs16@cornell.edu>
Date: Mon, 16 Sep 2024 13:29:37 -0400
Subject: [PATCH] More from Etienne. (#1194)

* More from Etienne.
---
 forest/code/Ci_tpsa.f90                       | 51 +++++++++++++------
 regression_tests/write_foreign_test/run.py    |  4 +-
 .../write_foreign_test/write_foreign_test.f90 |  1 +
 3 files changed, 38 insertions(+), 18 deletions(-)

diff --git a/forest/code/Ci_tpsa.f90 b/forest/code/Ci_tpsa.f90
index b49493630..95f2918ad 100644
--- a/forest/code/Ci_tpsa.f90
+++ b/forest/code/Ci_tpsa.f90
@@ -17849,18 +17849,19 @@ subroutine ddt_vector_field_fourier(s1,ds1)
 
 end subroutine ddt_vector_field_fourier
 
-subroutine print_vector_field_fourier(s1,mf,collated)
+subroutine print_vector_field_fourier(s1,mf,collated,non_zero_only)
     implicit none
     TYPE (c_vector_field_fourier), INTENT (INout) :: S1 
-    logical, optional  :: collated
-    logical usual
+    logical, optional  :: collated,non_zero_only
+    logical usual,nonz
     INTEGER I,mf,j
     usual=.false.
      if(present(collated)) usual=.not.collated
 
      write(mf,*) 0,"th mode"
      call print(s1%f(0),mf)  !,dospin=.false.)
-
+     nonz=.false.
+     if(present(non_zero_only)) nonz=non_zero_only
     do i=1,n_fourier
 
     if(usual) then
@@ -17869,16 +17870,30 @@ subroutine print_vector_field_fourier(s1,mf,collated)
      call print(s1%f(-i),mf)  !,dospin=.false.)
    else
      do j=1,s1%f(i)%n
+      if(nonz) then
+       write(mf,*) i,"th mode orbital",j   
+       if(full_abs(s1%f(i)%v(j))/=0)  call print(s1%f(i)%v(j),mf)  !,dospin=.false.)
+       write(mf,*) -i,"th orbital",j
+       if(full_abs(s1%f(-i)%v(j))/=0) call print(s1%f(-i)%v(j),mf)  !,dospin=.false.)
+      else
        write(mf,*) i,"th mode orbital",j
        call print(s1%f(i)%v(j),mf)  !,dospin=.false.)
        write(mf,*) -i,"th orbital",j
        call print(s1%f(-i)%v(j),mf)  !,dospin=.false.)
+      endif
      enddo
      do j=0,3
-       write(mf,*) i,"th quaternion",j
-       call print(s1%f(i)%q%x(j),mf)  !,dospin=.false.)
-       write(mf,*) -i,"th mode quaternion",j
-       call print(s1%f(-i)%q%x(j),mf)   !,dospin=.false.)
+       if(nonz) then
+        write(mf,*) i,"th quaternion",j
+        if(full_abs(s1%f(i)%q%x(j))/=0) call print(s1%f(i)%q%x(j),mf)  !,dospin=.false.)
+        write(mf,*) -i,"th mode quaternion",j
+        if(full_abs(s1%f(-i)%q%x(j))/=0) call print(s1%f(-i)%q%x(j),mf)  !,dospin=.false.)
+       else
+        write(mf,*) i,"th quaternion",j
+        call print(s1%f(i)%q%x(j),mf)  !,dospin=.false.)
+        write(mf,*) -i,"th mode quaternion",j
+        call print(s1%f(-i)%q%x(j),mf)   !,dospin=.false.)
+       endif
      enddo
  
       endif
@@ -21938,24 +21953,28 @@ subroutine normalise_vector_field_fourier(H,Fc,K,F1,dospin,mres,h_comoving)
 jq=0
                call check_kernel_ham(ki,n,je,nu,da,removeit,m,nus,jq)
  
-
+!!! m.nu+k=0   =>  k=-p
  if(removeit.and.present(mres)) then
+ je(ki)=je(ki)-1
    ires=0
     do l=1,c_%nd
      ires=iabs(mres(L)-(je(2*L)-je(2*L-1)))+ires
     enddo
-   ires=iabs(mres(-1)-jq)+ires
-   ires=iabs(-mres(0)-m)+ires
+!   ires=iabs(mres(-1)-jq)+ires
+   ires=iabs(-mres(0)-m)+ires !k=-p
    if(ires==0) removeit=.false.
+je(ki)=je(ki)+1
   endif
  if(removeit.and.present(mres)) then
+je(ki)=je(ki)-1
    ires=0
     do l=1,c_%nd
      ires=iabs(-mres(L)-(je(2*L)-je(2*L-1)))+ires
     enddo
-    ires=iabs(-mres(-1)-jq)+ires
-    ires=iabs(mres(0)-m)+ires
+!    ires=iabs(-mres(-1)-jq)+ires
+    ires=iabs(mres(0)-m)+ires !k=-p
    if(ires==0) removeit=.false.
+je(ki)=je(ki)+1
   endif
 
             if(removeit) then
@@ -21993,14 +22012,14 @@ subroutine normalise_vector_field_fourier(H,Fc,K,F1,dospin,mres,h_comoving)
  
  
   call check_kernel_ham(0,n,je,nu,da,removeit,m,nus,jq)
-
+!!! m.nu+k=0   =>  k=-p
  if(removeit.and.present(mres)) then
    ires=0
     do l=1,c_%nd
      ires=iabs(mres(L)-(je(2*L)-je(2*L-1)))+ires
     enddo
    ires=iabs(mres(-1)-jq)+ires
-   ires=iabs(-mres(0)-m)+ires
+   ires=iabs(-mres(0)-m)+ires  !k=-p
    if(ires==0) removeit=.false.
   endif
  if(removeit.and.present(mres)) then
@@ -22009,7 +22028,7 @@ subroutine normalise_vector_field_fourier(H,Fc,K,F1,dospin,mres,h_comoving)
      ires=iabs(-mres(L)-(je(2*L)-je(2*L-1)))+ires
     enddo
     ires=iabs(-mres(-1)-jq)+ires
-    ires=iabs(mres(0)-m)+ires
+    ires=iabs(mres(0)-m)+ires !k=-p
    if(ires==0) removeit=.false.
   endif
 
diff --git a/regression_tests/write_foreign_test/run.py b/regression_tests/write_foreign_test/run.py
index a54a0c6c3..9b0920e67 100644
--- a/regression_tests/write_foreign_test/run.py
+++ b/regression_tests/write_foreign_test/run.py
@@ -11,8 +11,8 @@
 results = subprocess.run([exe], stdout=subprocess.PIPE).stdout.decode('utf-8')
 d = difflib.Differ()
 
-files = ['write_foreign_test.mad8', 'write_foreign_test.madx', 'write_foreign_test.sad', 
-             'write_foreign_test.lte', 'write_foreign_test.julia', 'write_foreign_test.opal']
+##files = ['write_foreign_test.mad8', 'write_foreign_test.madx', 'write_foreign_test.sad', 
+##             'write_foreign_test.lte', 'write_foreign_test.julia', 'write_foreign_test.opal']
 
 files = ['write_foreign_test.mad8', 'write_foreign_test.madx', 
              'write_foreign_test.lte', 'write_foreign_test.julia']
diff --git a/regression_tests/write_foreign_test/write_foreign_test.f90 b/regression_tests/write_foreign_test/write_foreign_test.f90
index 66567803a..c778139bd 100644
--- a/regression_tests/write_foreign_test/write_foreign_test.f90
+++ b/regression_tests/write_foreign_test/write_foreign_test.f90
@@ -43,6 +43,7 @@ program write_foreign_test
 call file_suffixer(lat_file, out_file, 'julia.now', .true.)
 call write_lattice_in_foreign_format ('JULIA', out_file, lat)
 
+! This needs some work. Specifically there should be a separate lattice for testing.
 !call file_suffixer(lat_file, out_file, 'opal.now', .true.)
 !call write_lattice_in_foreign_format ('OPAL-T', out_file, lat)