Add lz to lz and ly and fix different things

src/model/adia.f90

@@ -26,7 +26,7 @@
       subroutine adia(n,p,npar,ymod,vx,u,skip)
       use dim_parameter,only: ndiab,nstat,ntot,nci,pst
       use data_module,only: q_m,x1_m,x2_m,y_m
-      use diabmodel, only:diab 
+      use diab_mod, only:diab 
       use data_matrix 
       !use dipole, only: diab
       implicit none
@@ -58,17 +58,17 @@
       integer TYPES, BLK ! TYPE OF THE CALCULATION
       ! variabke for dgemm
        
-      double precision,dimension(ndiab,ndiab):: ex,ey
+      double precision,dimension(ndiab,ndiab):: ex,ey,ez
       double precision:: alpha
       integer:: lda,ldb,beta,ldc
       double precision,dimension(ndiab,ndiab):: temp1,temp2
-      call diab(ex,ey,n,x1_m(:,n),x2_m(:,n),p)
+      call diab(ex,ey,ez,n,x1_m(:,n),x2_m(:,n),p)
       
       
 !     init eigenvector matrix
-      TYPES = int(p(pst(1,28)))
+      TYPES = int(p(pst(1,32)))
       
-      BLK = int(p(pst(1,28)+1)) ! BLOCK IF TYPE IS 3
+      BLK = int(p(pst(1,32)+1)) ! BLOCK IF TYPE IS 3
       u = 0.d0
       vx=0.0d0
       skip=.false.
@@ -87,6 +87,9 @@
        else if (TYPES .eq.5) then
         call Transformation_mat(ex,vx,ymod)
          ymod=0.0d0
+       else if (TYPES .eq.6) then
+         ! transform the lz 
+         call one_dia_upper(ez,ymod)
        else 
          write(*,*) "Error in TYPE of calculation here",TYPES
        

src/model/data_transform.f90

@@ -1,5 +1,6 @@
 !     <subroutine for manipulating the input Data before the Fit
       subroutine data_transform(q,x1,x2,y,wt,p,npar,p_act)
+      use accuracy_constants, only: dp,idp
       use dim_parameter,only : nstat,pst,ntot,qn,numdatpt,ndiab,ndata,sets
       use ctrans_mod, only: ctrans
      
@@ -8,27 +9,37 @@
 !      use david_ctrans_mod, only: ctrans_d
       implicit none
 !     IN: variables
-      integer npar
+      integer(idp),intent(in) :: npar 
-      double precision q(qn,numdatpt),x1(qn,numdatpt),x2(qn,numdatpt)
+      Real(dp),intent(in) :: q(qn,numdatpt)
-      double precision y(ntot,numdatpt),wt(ntot,numdatpt)
+      Real(dp),intent(in) :: p(npar)
-      double precision p(npar),mat_x(ndiab,ndiab),mat_y(ndiab,ndiab)
+      integer(idp),intent(in) :: p_act(npar)
-      double precision v(ndiab,ndiab),E(nstat), energies(nstat)
+
-      integer p_act(npar), pt
+      ! INOUT: variables 
-      logical dbg
+      Real(dp),intent(inout) :: y(ntot,numdatpt)
-      parameter (dbg=.false.)
+      Real(dp),intent(inout) :: wt(ntot,numdatpt)
-      integer TYPES,BLK ! TYPE OF THE CALCULATION AND THE BLOCK IF TYEPE IS 3
+
-      double precision U(ndiab,ndiab), U_ref(ndiab,ndiab) ! Transformation matrix 
+      ! OUT: vairables 
-      integer:: i,j,k,l
+      Real(dp), intent(out) :: x1(qn,numdatpt),x2(qn,numdatpt)
+      ! internal variables 
 
       
-      if (pst(2,28) .ne. 2) then  
+      Real(dp),dimension(ndiab,ndiab)::mat_x,mat_y,mat_z,U,V
   
-            write(*,*) "Error in Paramater Keys, TYPE_CAL should be 2 parameter", pst(2,28)
+      Real(dp),dimension(nstat) :: E
+      integer(idp) pt,i,j,k,l, TYPES, BLK  ! types is for the type of calculation 
+      ! blk is for which block to fit 
+      logical,parameter::  dbg = .false.
+    
+
+       
+      if (pst(2,32) .ne. 2) then  
+
+            write(*,*) "Error in Paramater Keys, TYPE_CAL should be 2 parameter", pst(2,32)
             stop
       end if 
 
-      TYPES = int(p(pst(1,28)))! TYPE OF THE CALCULATION
+      TYPES = int(p(pst(1,32)))! TYPE OF THE CALCULATION
-      BLK= int(p(pst(1,28)+1))! BLOCK IF TYPE IS 3
+      BLK= int(p(pst(1,32)+1))! BLOCK IF TYPE IS 3
       write(*,*) "TYPE of calculation:",TYPES
 
       pt=1
@@ -66,14 +77,9 @@
            write(50+i,*) ""
           endif
          !call overlap(U_ref,U)
-       call Y2mat(y(1:ntot,pt),mat_x,mat_y)
+       call Y2mat(y(1:ntot,pt),mat_x,mat_y,mat_z)
-       mat_y=-mat_y
-       if (ntot .ne. ndiab*(ndiab+1)) then
-         energies(1:nstat)= y(31:ntot,pt)
-       end if
 
        if (TYPES .eq.1 ) then 
-          !call adiabatic_transform(mat_x,mat_y,U)
           ! Trace of the potential
           call trace_mat(mat_x,mat_y,y(1:ntot,pt))
        else if (TYPES .eq.2) then 
@@ -81,28 +87,29 @@
          call Eigen(mat_x,mat_y,y(1:ntot,pt))
        else if (TYPES .eq.3) then 
          ! Adiabatic transformation of the potential
-         call adiabatic_transform(mat_x,mat_y,U)
+         call adiabatic_transform(mat_x,U)
+         call adiabatic_transform(mat_y,U)
          call block_diab(mat_x,mat_y,y(1:ntot,pt),BLK)
          
        else if (TYPES .eq.4) then
           ! Write the full upper diabatic matrix 
-          call adiabatic_transform(mat_x,mat_y,U)
+          call adiabatic_transform(mat_x,U)
+          call adiabatic_transform(mat_y,U)
           ! and write the full diabatic matrix to y
           ! This is the full diabatic matrix
           call Full_diab_upper(mat_x,mat_y,y(1:ntot,pt))
         else if (TYPES .eq.5) then
-          call adiabatic_transform(mat_x,mat_y,U)
+          !call adiabatic_transform(mat_x,U)
-          call Transformation_mat(mat_x,E,y(1:ntot,pt))
+          !call adiabatic_transform(mat_y,U)
-          if (dbg)  then 
+          call Transformation_mat(U,E,y(1:ntot,pt))
-            do k=1,ndiab 
+        else if (TYPES .eq.6) then
-              write(34,'(5f14.6)') (mat_x(k,l),l=1,ndiab)
+          ! Just do the adiabatic transformation and write the matrix
-            enddo
+          ! transform the lz 
-            write(34,*) ""
+          call adiabatic_transform(mat_z,U)
-          endif
+          call one_dia_upper(mat_z,y(1:ntot,pt))
-          !y(31:ntot,pt)=energies(1:nstat)
        else 
          write(*,*) "Error in TYPE of calculationss",TYPES
-         write(*,*) "the value:,", p(pst(1,28))
+         write(*,*) "the value:,", p(pst(1,32))
          stop
        end if
        pt=pt+1

src/model/matrix_form.f90

@@ -20,11 +20,11 @@
       END SUBROUTINE trace_mat
             !! subroutine Ydata to matrix
 
-      subroutine Y2mat(Y,Mx,My)
+      subroutine Y2mat(Y,Mx,My,mz)
             IMPLICIT NONE
             integer:: ii,i,j
             double precision, intent(in):: y(:)
-            double precision,intent(out):: Mx(ndiab,ndiab),My(ndiab,ndiab)
+            double precision,dimension(ndiab,ndiab),intent(out):: mx, my,mz 
 
             !if (ndiab .ne. 4 ) then
             !write(*,*) " NDIAB should be equal to 4",NDIAB
@@ -38,18 +38,16 @@
 
                   mx(i,j)=y(ii)
             !      ! My
-                  if (ntot .eq. ndiab*(ndiab+1)) then 
+                  my(i,j)=y( (ntot/3)+ii)
-                        my(i,j)=y( (ntot/2)+ii)
-                  else
-                        my(i,j)=y(15+ii)
-                  end if
                    ! remember to adjust here I added the energy
+                  mz(i,j)= y(2*(ntot/3)+ ii )
             !      
                   ii=ii+1
             enddo  
             enddo 
             call copy_2_upper(mx)
             call copy_2_upper(my)
+            call copy_2_upper(mz)
       end subroutine
 
       subroutine Full_diab_upper(mx,my,y)
@@ -72,10 +70,28 @@
             enddo
       end subroutine Full_diab_upper
 
-
+      subroutine one_dia_upper(m,y)
-      Subroutine adiabatic_transform(mx,my,U)
             implicit none
-            double precision, intent(inout) :: mx(ndiab,ndiab), my(ndiab,ndiab)
+            double precision,intent(inout) :: y(:)
+            double precision, intent(in) :: m(ndiab,ndiab)
+            integer i,j,ii
+            ii=1
+            y=0.0d0
+            
+            do i=1,ndiab
+                  do j=i,ndiab
+                        ! mx  
+                        y(ii) = m(i,j)
+                        ! increment the index
+                        ii=ii+1
+                  enddo
+            enddo
+      end subroutine one_dia_upper
+
+
+      Subroutine adiabatic_transform(mx,U)
+            implicit none
+            double precision, intent(inout) :: mx(ndiab,ndiab)
             double precision, dimension(:,:), intent(inout) :: U
             double precision, dimension(ndiab,ndiab) :: temp1, temp2
             integer i, j    
@@ -85,8 +101,8 @@
             ! Transform mx and my to adiabatic basis
             temp1 = matmul(mx, transpose(U))
             mx = matmul(U, temp1)         
-            temp2 = matmul(my, transpose(U))
+            !temp2 = matmul(my, transpose(U))
-            my = matmul(U, temp2)
+            !my = matmul(U, temp2)
 
       end subroutine adiabatic_transform
 
@@ -282,8 +298,8 @@
             double precision, intent(in) :: p(:)
             integer, intent(in) :: id_write
             integer :: type_calc, blk
-            type_calc = int(p(pst(1,28)))
+            type_calc = int(p(pst(1,32)))
-            blk = int(p(pst(1,28)+1))
+            blk = int(p(pst(1,32)+1))
 
             if (type_calc ==1) then 
                   write(id_write,*) "Type of calculation: TRACE"

src/model/model.f90

@@ -3,19 +3,33 @@
 ! Last modified: 2025-10-03 14:10:10 jnshuti
 ! model for L-matrix of NO3 radical 
 
-module diab_mod:
+module diab_mod
   use accuracy_constants, only: dp, idp
-  use dim_parameter, only: ndiab, nstat, ntot,npar,qn,pst
+  use dim_parameter, only: ndiab, nstat, ntot,qn,pst
-  private
-  public :: Lx_diab, Ly_diab, Lz_diab
   implicit none
+  private
+  public :: diab 
+  
   contains 
+    subroutine diab(lx,ly,lz,n,x1,x2,p)
+        implicit none 
+        real(dp), intent(out),dimension(ndiab,ndiab):: lx,ly,lz 
+        real(dp), intent(in), dimension(qn):: x1,x2 
+        real(dp), intent(in),dimension(:):: p 
+        integer(idp),intent(in):: n
+
+        call Lx_diab(lx,x1,x2,p)
+        call Ly_diab(ly,x1,x2,p)
+        call Lz_diab(lz,x1,x2,p)
+
+    end subroutine diab 
+
 
     subroutine Lx_diab(E,q,t,p)
         implicit none 
         real(dp),dimension(ndiab,ndiab), intent(out):: E 
         real(dp),dimension(:),intent(in):: q,t
-        real(dp),dimension(npar),intent(in):: p 
+        real(dp),dimension(:),intent(in):: p 
         real(dp):: xs,ys,xb,yb,a,b 
         real(dp):: v3_vec(8), v2(6)
         integer(idp):: i,j,id
@@ -37,15 +51,6 @@ module diab_mod:
         v2(5)=2*xb*yb 
         v2(6)=xs*yb+xb*ys
 
-        v3( 1) = xs*(xs**2-3*ys**2)
-        v3( 2) = xb*(xb**2-3*yb**2)
-        v3( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
-        v3( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
-        v3( 5) = ys*(3*xs**2-ys**2)
-        v3( 6) = yb*(3*xb**2-yb**2)
-        v3( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
-        v3( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
-
         e = 0.0_dp 
         id = 1
         e(1,1)=e(1,1)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 param
@@ -199,9 +204,9 @@ module diab_mod:
         implicit none 
         real(dp),dimension(ndiab,ndiab), intent(out):: e
         real(dp),dimension(:),intent(in):: q,t
-        real(dp),dimension(npar),intent(in):: p 
+        real(dp),dimension(:),intent(in):: p 
         real(dp):: xs,ys,xb,yb,a,b 
-        real(dp):: v3_vec(8)
+        real(dp):: v2(6)
         integer(idp):: i,j,id
 
         ! check the dimension of the matrix 
@@ -219,15 +224,6 @@ module diab_mod:
         v2(5)=2*xb*yb 
         v2(6)=xs*yb+xb*ys
 
-        v3( 1) = xs*(xs**2-3*ys**2)
-        v3( 2) = xb*(xb**2-3*yb**2)
-        v3( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
-        v3( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
-        v3( 5) = ys*(3*xs**2-ys**2)
-        v3( 6) = yb*(3*xb**2-yb**2)
-        v3( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
-        v3( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
-
         e = 0.0_dp 
         
         ! V-term 
@@ -369,17 +365,17 @@ module diab_mod:
         implicit none 
         real(dp),dimension(ndiab,ndiab), intent(out):: e 
         real(dp),dimension(:),intent(in):: q,t
-        real(dp),dimension(npar),intent(in):: p 
+        real(dp),dimension(:),intent(in):: p 
         real(dp):: xs,ys,xb,yb,a,b 
-        real(dp):: v3_vec(8)
+        real(dp):: v2(6)
-        integer(idp):: i,j
+        integer(idp):: i,j,id 
 
         ! check the dimension of the matrix 
         if (size(e,1) .ne. ndiab) then 
             write(*,*) " Error in Lz_diab: wrong dimension of e matrix ", size(e,1)
             stop
         endif
-        call rewrite_coord(q,a,xs,xb,yb,b,1)
+        call rewrite_coord(q,a,xs,ys,xb,yb,b,1)
 
 
         e = 0.0_dp
@@ -494,4 +490,16 @@ module diab_mod:
         b = q(start+5)
     end subroutine rewrite_coord
 
+    subroutine copy_2_lower_triangle(mat)
+        real(dp), intent(inout) :: mat(:, :)
+        integer :: m, n
+    !     write lower triangle of matrix symmetrical
+        do n=1,size(mat,1)
+            do m=n,size(mat,1)
+                mat(m,n)=mat(n,m)
+            enddo 
+        enddo
+   end subroutine copy_2_lower_triangle
+
+
 end module diab_mod