module constants

!     all in SI   
      real(8), parameter :: h = 6.62607004d-34
      real(8), parameter :: pi = 3.14159265359
      real(8), parameter :: hbar = h/2d0/pi
      real(8), parameter :: el = 1.60217662d-19
      real(8), parameter :: el_AU = 1d0
      real(8), parameter :: mne = 1.67492749804d-27
      real(8), parameter :: mpr = 1.67262192369d-27
      real(8), parameter :: mpr_AU = 1.83615D3
      real(8), parameter :: mpr_amu = 1.007276466621
      real(8), parameter :: mel = 9.1093837015d-31
      real(8), parameter :: cc = 299792458d0
      real(8), parameter :: cc_AU=137.036d0
      real(8), parameter :: NA = 6.02214076D23
      real(8), parameter :: BohrM = el*hbar/2.0d0/mel
      real(8), parameter :: BohrM_AU = 0.5d0
      real(8), parameter :: BohrM_CGSScaled = BohrM*1.0d24 !so Debye*Bohr Magneton add up to 10^-36 esu2cm2, not 100% percent sure about this
!      real(8), parameter :: Debye_CGSScaled = 2.541746913d0*1.0d18
      real(8), parameter :: NucM = el*hbar/2.0d0/mpr
      real(8), parameter :: NucM_AU=0.5d0/(mpr_AU)
      real(8), parameter :: NucM_CGS=0.5d0/(mpr_AU)/137.0359991 ! ¯\_(ツ)_/¯
      real(8), parameter :: BohrR = 0.52917721092d0 !in Angstrom
      real(8), parameter :: permi0 = 8.8541878128D-12
      real(8), parameter :: perme0 = 1.25663706212D-6
      real(8), parameter :: kb = 1.380649d-23
      real(8), parameter :: Rgas = 8.31446261815324
      real(8), parameter :: SI_2_Debye=1d0/3.33564D-30
      real(8), parameter :: DEBYE_2_SI=3.33564D-30
      
!     energy conversions in SI
      real(8), parameter :: Hz_2_cm = 3.33564d-11
      real(8), parameter :: cm_2_Hz = 1d0/hz_2_cm
      
!     conversions to AU
      real(8), parameter :: SI2AU_debye = 1.0d0/2.541746913d0
      real(8), parameter :: SI2AU_BohrMagneton = BohrM_AU/BohrM
      real(8), parameter :: SI2AU_Hz    = 1.51983D-16
      real(8), parameter :: SI2AU_Kg    = 1d0/9.10939D-31
      real(8), parameter :: SI2AU_m     = 1d0/5.29177d-11
      
!     conversions to "SI"
      real(8), parameter :: AU2SI_debye = 2.541746913d0
      real(8), parameter :: AU2SI_BohrMagneton = 2.0d0
     
end module constants

module rotor
   use constants
   implicit none
   
      
   contains

   !J. Quant. Spectrosc. Radiat. Transfer Vol. 21, pp. 309-313
   SUBROUTINE CPFI2(X,Y,WR,WI)
      ! ROUTINE COMPUTES THE REAL (WR) AND IMAGINARY (WI) PARTS OF THE COMPLEX
      ! PROBABILITY FUNCTION W(Z)=EXP(-Z**2)*ERFC(-I*Z) IN THE UPPER HALF-PLANE Z=X+i*Y (I.E. FOR Y>=O)
      ! MAXIXUM RELATIVE ERROR OF WR IS <2*10**(-6), THAT OF WI <5*10**(-6)
      REAL(8) :: T(6),C(6),S(6),X,Y,WR,WI,Y1,Y2,D1,D2,D3,D4,R1,R2,D,R,Y3
      INTEGER(4) :: I
      !DIMENSION T(6),C(6),S(6)
      DATA(T(I),I=1,6)/.314240376,.947788391,1.59768264,2.27950708,3.02063703, &
    & 3.8897249/,(C(I),I=1,6)/1.01172805,-.75197147,1.2557727E-2, &
    & 1.00220082E-2,-2.42068135E-4,5.00848061E-7/,(S(I),I=1,6)/1.393237, &
    & .231152406,-.155351466,6.21836524E-3,9.19082986E-5,-6.27525958E-7/
      WR=0.
      WI=9.
      Y1=Y+1.5
      Y2=Y1*Y1
      ! IF HIGH ~ELATIVE ACCURACY IN REGION II IS NOT REQUIRED° THE FOLLOWING
      ! 19 LI~ES ~AY BE DELETED
      IF((Y.GT.0.85).OR.(ABS(X).LT.18.1*y+1.65))GOTO 2
      ! ***REGION II
      IF(ABS(X).LT.12.)WR=EXP(-X*X)
      Y3=Y+3.
      DO 1 I=1,6
         R=X-T(I)
         R2=R*R
         D=1./(R2+Y2)
         D1=Y1*D
         D2=R*D
         WR=WR+Y*(C(I)*(R*D2-1.5*D1)+S(I)*Y3*D2)/(R2+2.25)
         R=X+T(I)
         R2=R*R
         D=1./(R2+Y2)
         D3=Y1*D
         D4=R*D
         WR=WR+Y*(C(I)*(R*D4-1.5*D3)-S(I)*Y3*D4)/(R2+2.25)
1        WI=WI+C(I)*(D2+D4)+S(I)*(D1-D3)
      RETURN
      ! ***REGION I
2     DO 3 I=1,6
         R=X-T(I)
         D=1./(R*R+Y2)
         D1=Y1*D
         D2=R*D
         R=X+T(I)
         D=1./(R*R+Y2)
         D3=Y1*D
         D4=R*D
         WR=WR+C(I)*(D1+D3)-S(I)*(D2-D4)
3        WI=WI+C(I)*(D2+D4)+S(I)*(D1-D3)
      RETURN
   END SUBROUTINE CPFI2
   
   
!====================================
!WAVE FUNCTIONS, OPERATORS AND DIAGONALIZATIONS
!====================================

   function Jplus_EVAL(J,K) result (res)
      integer(4) J,K
      real(8) res
      if(abs(k)>j)stop 'K greater than J'
      res=sqrt(dble(j*(j+1)-k*(k+1)))
   end function Jplus_EVAL
   
   function Jminus_EVAL(J,K) result (res)
      integer(4) J,K
      real(8) res
      if(abs(k)>j)stop 'K greater than J'
      res=sqrt(dble(j*(j+1)-k*(k-1)))
   end function Jminus_EVAL

   function Jplus_sph_eval(J,K) result (res)
      integer(4) J,K
      real(8) res
      res=-1.0d0/sqrt(2.0d0)*Jplus_EVAL(J,K)
   end function Jplus_sph_EVAL
   
   function Jminus_sph_eval(J,K) result (res)
      integer(4) J,K
      real(8) res
      res=1.0d0/sqrt(2.0d0)*Jminus_EVAL(J,K)
   end function Jminus_sph_EVAL
   
   subroutine DIAG_SYM(Eval,Evec,dime,info,ordered)
      INTEGER(4), INTENT(IN) :: dime
      REAL(8), INTENT(INOUT) :: Eval(dime)
      REAL(8), INTENT(OUT) :: Evec(dime,dime)
      INTEGER(4), INTENT(OUT) :: info
      logical, intent(in) :: ordered
      REAL(8) Work(7*dime,7*dime),evalc(dime),evecL(dime,dime),evecR(dime,dime)
      info=0
      !LAPACK function, WORK array is set as large as possible, these eigenvalues are in ascending order
      if(ordered)then
         call dsyev('V','L',dime,evec,dime,eval,work,7*dime*7*dime,info)
      else
      !Another LAPACK function, these eigenvalues are not ordered (or perhaps they are shuffled ¯\_(ツ)_/¯, who knows)
         call dgeev('V','N',dime,evec,dime,eval,evalc,evecL,dime,evecR,dime,work,10*dime,info)
         eval=eval
         evec=evecL
      end if
   end subroutine Diag_SYM
   
   subroutine EVAL_TO_ENERGY(eval,dime,A,B,C,J)
      integer(4) dime,i,J
      Real(8),intent(inout) :: eval(dime)
      real(8) A,B,C
      
      do i=1,dime
         eval(i)=0.5d0*(A+C)*dble(J*(J+1d0))+0.5d0*(A-C)*eval(i)
      end do
      
   end subroutine
      
      
   function Reverse_IArr(arr,n)result(res1)
      integer(4) n,i,siz,buf
      integer(4), INTENT(IN)::arr(n)
      integer(4) res1(n)
      siz = n/2
      
      do i = 1,n
         res1(i)=arr(i)
      end do
      do i = 1,siz
         buf=res1(i)
         res1(i)=res1(n-i+1)
         res1(n-i+1)=buf
      end do
      
      
   end function Reverse_IArr
      
   !sigh
   function OldToNewNotation(J,T) result(res)
      integer(4) J,T,rep,i,ii,K1,Km1,Km1Arr(2*J+1),K1Arr(2*J+1)
      logical left
      integer(4) res(3)
            
      res(1)=J
      Km1=J+1
      K1=0
      K1Arr(1)=0
      
      do i=1,2*J
         K1Arr(i+1)=i/2+modulo(i,2)
      end do
      Km1Arr=Reverse_IArr(K1Arr,2*J+1)
      
      do i=1,2*J+1
         if(Km1ARr(i)-K1Arr(i) == T)exit
      end do
      
      res(2)=Km1ARr(i)
      res(3)=K1Arr(i)
      
   end function OldToNewNotation
      
   
   subroutine HAM_DIM_SEQUENCE(Jmin,Jmax,arr)
      integer(4) Jmin,Jmax,j,arr(Jmax-Jmin+1),car
      
      car=1
      do J = Jmin,Jmax
         arr(car)=2*J+1
         car=car+1
      end do
   end subroutine HAM_DIM_SEQUENCE
   
   function RepAxesSwitch_get(rep,left) result(res)
      integer(4) rep,res(3)
      logical left
      
      if(.not.left)then!right handed representation
         select case(rep)
            case(1)
               res=[2,3,1]
            case(2)
               res=[3,1,2]
            case(3)
               res=[1,2,3]
            case default
               stop "RepAxesSwitch_get wrong rep"
         end select
      else
         select case(rep)
            case(1)
               res=[3,2,1]
            case(2)
               res=[1,3,2]
            case(3)
               res=[2,1,3]
            case default
               stop "RepAxesSwitch_get wrong rep"
         end select
      end if
   end function RepAxesSwitch_get
   
   function RepAxesSwitch_V(arr,rep,left) result(res)
      real(8) arr(3),res(3)
      logical left
      integer(4) i,rep,order(3)
      
      
      res=0d0
      order=RepAxesSwitch_get(rep,left)
      do i = 1,3
         res(i)=arr(order(i))
      end do   
   end function RepAxesSwitch_V
   
   function Permute_matrix(n,m,mat,perm,columns)result(res)
      integer(4) n,m,i,perm(:)
      real(8) mat(n,m),res(n,m)
      logical columns
   
      res=0d0
      
      if(columns)then
         do i = 1,m
            res(:,i)=mat(:,perm(i))
         end do
      else
         do i = 1,n
            res(i,:)=mat(perm(i),:)
         end do
      end if
   end function Permute_matrix
   
   function RepAxesSwitch_T(mat,rep,left) result(res)
      real(8) mat(3,3),res(3,3),matbuf(3,3)
      logical left
      integer(4) i,j,rep,order(3)
      
      res=0d0
      order=RepAxesSwitch_get(rep,left)
      res=Permute_matrix(3,3,mat,order,.true.)
      res=Permute_matrix(3,3,res,order,.false.)
   end function RepAxesSwitch_T
   
   function AxesSwitch_V(arr,order) result(res)
      real(8),intent(in) :: arr(3)
      real(8) :: res(3)
      integer(4) i
      integer(4),intent(in) :: order(3)
      
      
      res=0d0
      do i = 1,3
         res(i)=arr(order(i))
      end do   
   end function AxesSwitch_V

   function AxesSwitch_T(mat,order)result(res)
      real(8),intent(in) :: mat(3,3)
      integer(4),intent(in) :: order(3)
      real(8) :: res(3,3)
      
      res=0d0
      res=Permute_matrix(3,3,mat,order,.true.)
      res=Permute_matrix(3,3,res,order,.false.)
   end function AxesSwitch_T
   
   function REPRESENTATION(RAY) result (res)
      real(8) RAY,d,e,f
      integer(4) res
      
      if((RAY>1.0d0).OR.(RAY<-1.0d0)) STOP 1
      
      d = DABS(RAY-1.0)
      e = DABS(RAY-0.0)
      f = DABS(RAY+1.0)
      res=0
      if((d<e).AND.(d<f)) then
         res = 3
      else if((e<d).AND.(e<f)) then
         res = 2
      else if((f<e).AND.(f<d)) then
         res = 1
      end if
   end function REPRESENTATION
   
   !returns the dimensions of the full Hamiltonian for multiple Js in the range of [Jmin]-[Jmax]
   function DIM_HAMILTONIAN(Jmin,Jmax) result (res)
      implicit none
      integer(4) Jmin,Jmax,res,i
      
      res = 0
      do i=Jmin,Jmax
         res = res + (i*2+1)
      end do
   end function
   
   !imprints (copies) 1D array [arr2] with size [m] onto 1D array [arr1] with size [n], [arr1] has to be larger or the same size as [arr2],
   ![start] marks the starting index on the larger array [arr1]
   !eg. (0 0 0 0 0 0) <- (4 5 7), starting index 2 => (0 4 5 7 0 0) 
   subroutine COPY_ARRAY1D(arr1,n,arr2,m,start)
      implicit none
      integer(4),intent(in) :: n,m,start
      real(8),intent(inout) :: arr1(n)
      real(8),intent(in) :: arr2(m)
      
      if(n<m) stop "Copied-to array smaller than copied array"
      
      arr1(start:(start+m-1))=arr2
   end subroutine COPY_ARRAY1D
   
   !imprints (copies) 2D array [arr2] with sizes [m1,m2] onto 2D array [arr1] with sizes [n1,n2], [arr1] has to be larger or the same size as [arr2] in any dimension,
   ![start1,start2] mark the starting indices on the larger array [arr1] 
   subroutine COPY_ARRAY2D(arr1,n1,n2,arr2,m1,m2,start1,start2)
      implicit none
      integer(4),intent(in) :: n1,n2,m1,m2,start1,start2
      real(8), INTENT(INOUT) :: arr1(n1,n2)
      real(8), INTENT(in) :: arr2(m1,m2)
      arr1(start1:(start1+m1-1),start2:(start2+m2-1))=arr2
   end subroutine COPY_ARRAY2D
   
   !gets the full block-diagonal assymetric rotor Hamiltonian [HamFull] with sizes [N,N] for Js in range [Jmin]-[Jmax]
   subroutine FULL_HAMILTONIAN_ASS(A,B,C,Jmin,Jmax,rep,HamFull,N,left)
      implicit none
      real(8), intent(in) :: A,B,C
      integer(4), intent(in) :: Jmin,Jmax,N,rep
      real(8), intent(out) :: HamFull(N,N)
      real(8), allocatable :: Ham(:,:)
      integer(4) i,j,k,car,len1(2)
      integer(4) len2(2),curdim
      logical left
      
      len1 = shape(HamFull)
      car = 1
      do i=Jmin,Jmax,1
         allocate(Ham(i*2+1,i*2+1))
         curdim = 2*i+1
         
         len2=shape(Ham)
         do j = 1,len2(1),1
            do k = 1,len2(1),1
               Ham(j,k)=0.0d0
            end do
         end do
         call ASS_ROTOR(A,B,C,i,rep,Ham,curdim,left)
         !call W2dArr(Ham,curdim,curdim)
         call COPY_ARRAY2D(HamFull,len1(1),len1(2),Ham,len2(1),len2(2),car,car)
         car = car + curdim
         deallocate(Ham)
      end do
      
   end subroutine FULL_HAMILTONIAN_ASS
   
   !gets the assymetric rotor Hamiltonian [Ham] with sizes [N,N] for one specific [J], representation [rep] in range -1 to 1
   subroutine ASS_ROTOR(A,B,C,J,rep,Ham,N,left)
      implicit none      
      real(8), intent(in) :: A,B,C
      real(8) buf,kappa,Fv,Gv,Hv
      integer(4),intent(in) :: J,rep,N
      integer(4) k1,k2
      real(8),intent(out) :: Ham(N,N)
      logical left

      kappa = (2.0d0*B-A-C)/(A-C)
      
      !dependent on the choice of [rep]
      Fv = Fval(kappa,rep)
      Gv = Gval(kappa,rep) 
      Hv = Hval(kappa,rep) 
      
      if(left.eqv..true.)then
         Hv=-Hv
      end if
      
      Ham=0.0d0
      
      do k1=1,2*J+1
         do k2=1,2*J+1
            if(k1==k2) then
               Ham(k1,k2)=Fv*J*(J+1.0D0)+(Gv-Fv)*(k1-J-1.0D0)**2.0D0
            end if
            continue
            if((k1+2)==k2) then
               buf=Hv*sqrt(fun(J,k1-J-1))
               Ham(k1,k2)=buf
               Ham(k2,k1)=buf
            end if
            continue
         end do
      end do
   end subroutine ASS_ROTOR
   
   subroutine LIN_ROTOR()
      
   end subroutine LIN_ROTOR
   
   subroutine SYM_ROTOR()
   
   end subroutine SYM_ROTOR
   
   subroutine SPH_ROTOR()
      
   end subroutine SPH_ROTOR
   
   function Ray(A,B,C) result (res)
      implicit none
      real(8) A,B,C,res
      res = (2.0d0*B-A-C)/(A-C)
   end function Ray
   
   function Fun(J,K) result (res)
      implicit none
      integer(4) J,K
      real(8) res
      res = 0.25D0*(J*(J+1.0)-K*(K+1.0))*(J*(J+1.0)-(K+2.0)*(K+1.0))

   end function Fun
      
   function Fval(kappa,n) result (res)
      implicit none
      real(8) kappa,res
      integer(4) n
      if(n==1) then
         res = 0.5d0*(kappa-1.0d0)
         return
      else if(n==3) then
         res = 0.5d0*(kappa+1.0d0)
         return
      else if(n==2) then
         res = 0
         return
      else
         stop "Incorrect ass. top representation"
      end if
   end function Fval
   
   function Gval(kappa,n) result(res)
      implicit none
      real(8) kappa,res
      integer(4) n
      if(n==1) then
         res = 1d0
         return
      else if(n==3) then
         res = -1d0
         return
      else if(n==2) then
         res = kappa
         return
      else
         stop "Incorrect ass. top representation"
      end if
   end function Gval
   
   function Hval(kappa,n) result(res)
      implicit none
      real(8) kappa,res
      integer(4) n
      if(n==1) then
         res = -0.5d0*(kappa+1.0d0)
         return
      else if(n==3) then
         res = 0.5d0*(kappa-1.0d0)
         return
      else if(n==2) then
         res = 1
         return
      else
         stop "Incorrect ass. top representation"
      end if
   end function Hval
   
!  write a very fancy 2D array, [n,m] dimensions from SHAPE function
!  useful, if u dont know GDB
   subroutine W2dArr(arr,n,m)
      integer(4) n,m
      real(8), dimension(n,m) :: arr
      integer(4), dimension(2) :: leng
      integer(4) i,j
      leng = shape(arr)

      write(*,"(1A8)", advance = "no") "        "
      do i = 1,leng(2)
         write(6,"(1I4)", advance = "no") i
         write(6,"(1A4)", advance = "no") "     "
      end do

      write (*,"(1A1)") " "
      i = 1

      do i = 1,leng(1)
         write(6,"(1I4)", advance = "no") i
         do j = 1,leng(2)
            write (6,"(1F8.3)", advance = "no") arr(j,i)
         end do
         write(6,"(1A1)") " "
      end do
   end subroutine W2darr

   subroutine W2dArr_log(arr,n,m)
      integer(4) n,m
      logical, dimension(n,m) :: arr
      integer(4), dimension(2) :: leng
      integer(4) i,j
      leng = shape(arr)

      write(*,"(1A6)", advance = "no") "      "
      do i = 1,leng(2)
         write(6,"(1I2)", advance = "no") i
         !write(6,"(1A4)", advance = "no") "     "
      end do

      write (*,"(1A1)") " "
      i = 1

      do i = 1,leng(1)
         write(6,"(1I4)", advance = "no") i
         do j = 1,leng(2)
            write (6,"(1L2)", advance = "no") arr(j,i)
         end do
         write(6,"(1A1)") " "
      end do
   end subroutine W2darr_log

!  write a very fancy 2D array, [n,m] dimensions from SHAPE function, can set starting indices when printed
   subroutine W2dArr_index(arr,n,m,start1,start2)
      integer(4) n,m
      real(8), dimension(n,m) :: arr
      integer(4), dimension(2) :: leng
      integer(4) start1,start2
      integer(4) i,j
      leng = shape(arr)

      write(*,"(1A8)", advance = "no") "        "
      do i = 1,leng(2)
         write(6,"(1I4)", advance = "no") (start1 + i - 1)
         write(6,"(1A4)", advance = "no") "     "
      end do

      write (*,"(1A1)") " "
      i = 1

      do i = 1,leng(1)
         write(6,"(1I4)", advance = "no") (start2 + i - 1)
         do j = 1,leng(2)
            write (6,"(1F8.3)", advance = "no") arr(j,i)
         end do
         write(6,"(1A1)") " "
      end do
   end subroutine W2darr_index
   
   
end module rotor

module input
   use constants   
   use rotor
   
   implicit none
   integer(4) n0,MENDELEV
   parameter (n0=100,MENDELEV=89)
   
   real(8) quad(3,3),quadtr(3,3),qtot(3,3),g(3,3),gn(3,3),ge(3,3),gt(3,3),gnew(3,3)
   real(8) xp(3,3),ama(n0)
   real(8) r(3,n0)
   real(8) dip(3),abc(3),mass
   real(8),allocatable :: a_masses(:)
   logical dip_found, g_found, q_found, ABC_found
   public :: quad,quadtr,qtot,g,gn,ge,gt,gnew,xp,r,ama,dip,abc,mass,dip_found, g_found, q_found, ABC_found
   contains
   
   
   
   
   !What I've learned when writing fortran:
   !Any attempt at modularity will add double the time required on a functional solution
   
   !shamelessly borrowed from: http://rosettacode.org/wiki/String_case#Fortran
   subroutine To_upper(str)
     character(*), intent(inout) :: str
     integer :: i
 
     do i = 1, len(str)
       select case(str(i:i))
         case("a":"z")
           str(i:i) = achar(iachar(str(i:i))-32)
       end select
     end do 
   end subroutine To_upper
 
   subroutine To_lower(str)
     character(*), intent(inout) :: str
     integer :: i
 
     do i = 1, len(str)
       select case(str(i:i))
         case("A":"Z")
           str(i:i) = achar(iachar(str(i:i))+32)
       end select
     end do  
   end subroutine To_Lower   
   
      
   !write double 2D array to sequential file
   subroutine ARR2D_2_FILE(arr,dime,unitt,line)
      integer(4) dime,unitt,line,i,j
      REAL(8) arr(dime,dime)
      character(3)str
      character(15)str2
      
      rewind(unitt)
      write(str,*)dime
      !FORMAT
      str2 = (str//'(1F15.8,A1))')   
      do i = 1,line-1
         read(unitt,*)
      end do
      do i = 1,dime
         do j = 1,dime
            write(unitt,str2)arr(i,j)
         end do
      end do
   end subroutine ARR2D_2_FILE
 
   subroutine ARR2D_2_FILE_spec(arr,n,m,maxidx,unitt)
      integer(4) unitt,i,j,maxidx,n,m
      REAL(8) arr(n,m)
      character(3)str
      character(15)str2
      
      !rewind(unitt)
      str='   '
      write(str,'(I3)')m
      !FORMAT
      str2 = ("("//trim(adjustl(str))//"(E25.15E4,' '))")   
      !do i = 1,line-1
      !   read(unitt,*)
      !end do
      do i = 1,maxidx-1
         write(unitt,str2)(arr(i,j),j=1,m)
      end do
   end subroutine ARR2D_2_FILE_spec
 
   subroutine RotateVector(a,b,c,v)
      real(8),intent(in) :: a,b,c
      real(8),intent(inout) :: v(3)
      
      v = MATMUL(RotationMatrix(a,b,c),v)
   end subroutine RotateVector
   
   subroutine RotateMatrix(a,b,c,v)
      real(8),intent(in) :: a,b,c
      real(8),intent(inout) :: v(3,3)
      
      v = MATMUL(RotationMatrix(a,b,c),v)
   end subroutine RotateMatrix
   
   function RotationMatrix(a,b,c) result(mat)
      real(8),intent(in) :: a,b,c
      real(8) mat(3,3)
      
      mat(1,1)=cos(a)*cos(b)
      mat(2,1)=sin(a)*cos(b)
      mat(3,1)=-sin(b)
      mat(1,2)=cos(a)*sin(b)*sin(c)-sin(a)*cos(c)
      mat(2,2)=sin(a)*sin(b)*sin(c)+cos(a)*cos(c)
      mat(3,2)=cos(b)*sin(c)
      mat(1,3)=cos(a)*sin(b)*cos(c)+sin(a)*sin(c)
      mat(2,3)=sin(a)*sin(b)*cos(c)-cos(a)*sin(c)
      mat(3,3)=cos(b)*cos(c)
   end function RotationMatrix
   
   function Shift_Coordinate_dip(dip,transform)result(res)
      real(8) dip(3),transform(3),res(3)
      integer(4) i
      
      do i = 1,3
         res(i)=dip(i)*transform(i)
      end do
   end function Shift_Coordinate_dip
   
   function Shift_Coordinate_quad(quadr,dipo,transform) result(res)
      real(8) quadr(3,3),dipo(3),transform(3),res(3,3)
      integer(4) i,j
      
      do i = 1,3
         do j = 1,3
            res(i,j)=quadr(i,j)+0.5*(transform(i)*dipo(j)+dipo(i)*transform(j))
         end do
      end do
   end function Shift_Coordinate_quad
   
   function kdelta(a,b)result(res)
      integer(4) a,b,res
      
      
      if(a==b)then
         res=1
      else
         res=0
      end if
   end function kdelta
   
   function Str2Num(str) result(num)
      character(*) str
      real(8) num(3)
      integer(4) i
      
      if(index(str,'E')/=0)then
         read(str,2001)(num(i),i=1,3)
      else if(index(str,'e')/=0)then
         read(str,2001)(num(i),i=1,3)
      else
         read(str,2000)(num(i),i=1,3)
      end if
2000  format(3(F15.8,1X))
2001  format(3(E15.8E2,1X))
   end function Str2Num
   
   
   function ROTMAT_2_ANGLES(rot) result(arr)
      real(8), intent(in) :: rot(3,3)
      real(8) :: arr(3)
      
      arr(1)=atan2(rot(3,2),rot(3,3))
      arr(2)=atan2(-rot(3,1),sqrt(rot(3,2)**2+rot(3,3)**2))
      arr(3)=atan2(rot(2,1),rot(1,1))
      arr=arr/pi*180.0d0
   end function ROTMAT_2_ANGLES
   
   FUNCTION CALC_INERT(n,m,r) RESULT(t)
      integer(4) :: i,n
      real(8),intent(in) :: m(n),r(3,n)
      real(8) :: t(3,3)
      
      t=0d0
      do i = 1,n
         t(1,1)=t(1,1) + m(i)*(r(2,i)**2+r(3,i)**2)
         t(2,2)=t(2,2) + m(i)*(r(1,i)**2+r(3,i)**2)
         t(3,3)=t(3,3) + m(i)*(r(2,i)**2+r(1,i)**2)
         t(1,2)=t(1,2) - m(i)*r(1,i)*r(2,i)
         t(1,3)=t(1,3) - m(i)*r(1,i)*r(3,i)
         t(2,3)=t(2,3) - m(i)*r(2,i)*r(3,i)
      end do
      t(3,2)=t(2,3)
      t(3,1)=t(1,3)
      t(2,1)=t(1,2)
   END FUNCTION CALC_INERT
   
   FUNCTION CALC_COM(n,m,r) RESULT (COM)
      integer(4) :: i,n
      real(8),intent(in) :: m(n),r(3,n)
      real(8) :: COM(3)
      
      COM=0d0
      do i = 1,n
         COM=COM+m(i)*r(:,i)
      end do
      
      COM=COM/SUM(m)
   END FUNCTION CALC_COM

   SUBROUTINE SHIFT_COORD(n,r,c)
      integer(4) n,i
      real(8),intent(inout) :: r(3,n)
      real(8),intent(in) :: c(3)
      
      do i = 1,n
         r(:,i)=r(:,i)-c
      end do
   END SUBROUTINE SHIFT_COORD
   
   !gets a more accurate mass than the one from gaussian
   function getMass(n,m)result(mass)
      integer(4) :: n,atomic,nucleon,length,atomic2,i
      real(8) :: m,mass
      real(8),allocatable :: masses(:),masses_copy(:)
      character(4) :: symbol
      open(99,file='isotopes.par')
!19       continue
19       read(99,1996)atomic,symbol,nucleon,mass
         length=0
         if(atomic==n)then
            length=1
            read(99,1996)atomic2,symbol,nucleon,mass
            do while(atomic2==atomic)
               length=length+1
               read(99,1996)atomic2,symbol,nucleon,mass
            end do
            
            do i = 1,length+1
               backspace(99)
            end do
            
            allocate(masses(length),masses_copy(length))
            do i=1,length
               read(99,1996)atomic2,symbol,nucleon,masses(i)
            end do
            masses_copy=masses
            masses=abs(masses-m)
            mass = masses_copy(minloc(masses,1))
            goto 20
         else
            goto 19
         end if
         
!21       if(atomic==n .and.abs(mass/m-1d0)<1d-1)goto 20
      !goto 19
20    close(99)
      deallocate(masses,masses_copy)
1996  format(BN,I4,A4,I5,F15.11)
      !BN = left justified
      !/ = dont read the next record
   end function getMass
   
   subroutine Reorder_Tensor(arr,order)
      real(8),intent(inout) :: arr(3,3)
      real(8) bufarr(3),bufarr2(3,3)
      integer(4) first,second,third,i
      integer(4),intent(out) :: order(3)
      
      do i = 1,3
         bufarr(i)=dabs(arr(i,i))
      end do
      third = maxloc(bufarr,dim=1)
      first = minloc(bufarr,dim=1)
      
      do i = 1,3
         if(i/=first .and. i/=third)then
            second=i
            exit
         end if
      end do
      
      order=[first,second,third] !bruh
      bufarr2=arr
      arr = axesSwitch_T(arr,order)
   end subroutine Reorder_Tensor
   
   !iz a mess, dont judge
   subroutine readFile(filename,outputfilen,outlen,filenameDalton,flags,sta)
      
      
      !So many variables. This is totally good practice.
      integer(4) nat,ia,ierr,unitt,sta
      logical lex,outp,flags(10)
      CHARACTER(2) atsy(MENDELEV)
      integer(4) lines,i,j,k,m,ka,iz(n0),l,arr(2),ii,n_atoms,ng
      real(8) bohr,mp,c,u,amu,charge,curmass
      real(8) t(3,3),q(3,3),gq(3,3),tvec(3),dipbuf(3),quadbuf(3,3),qt(3,3),gdalton(3,3)
      real(8) mt,cm(3),a(3),z(3,3),e(3,3),arrbuf(3,3),bufr1(3),bufr2(3),t0(3,3),t1(3,3)
      character(80) filename,outputfilen,filenameDalton
      integer(4) outlen,idx,order(3)
      
!     Current Line String 
      character(150) FN
      
      
      data atsy/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', &
      &'Na','Mg','Al','Si',' P',' S','Cl','Ar', &
      &' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn',&
      &         'Ga','Ge','As','Se','Br','Kr',&
      &'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd',&
      &         'In','Sn','Sb','Te',' I','Xe',&
      &'Cs','Ba','La',&
      &              'Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho',&
      &              'Er','Tm','Yb','Lu',&
      &'Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg',&
      &          'Tl','Pb','Bi','Po','At','Rn',&
      &'Fr','Ra','Ac'/
     
      real(8)  amas(MENDELEV)
      data amas/1.008,4.003,&
      &6.941,9.012,10.810,12.011,14.007,15.999,18.998,20.179,&
      &22.990,24.305,26.981,28.086,30.974,32.060,35.453,39.948,&
      &39.098,40.080,44.956,47.900,50.941,51.996,54.938,55.847,&
      &58.933,58.700,63.546,65.380,&
      &69.720,72.590,74.922,78.960,79.904,83.800,&
      &85.468,87.620,88.906,91.220,92.906,95.940,98.906,101.070,&
      &102.906,106.400,107.868,112.410,&
      &114.82,118.69,121.75,127.600,126.905,131.300,&
      &132.905,137.330,138.906,&
      &140.120,140.908,144.240,145.000,150.400,&
      &151.960,157.250,158.925,162.500,164.930,167.260,168.934,&
      &173.040,174.970,&
      &178.490,180.948,183.850,186.207,190.200,192.220,195.090,&
      &196.967,207.590,204.370,207.200,208.980,210.000,210.001,&
      &222.02,&
      &223.000,226.025,227.028/  

!     conversions
      bohr=0.52917721092d0
      mp=1.00727646688d0
      c=2.99792458d10
      u=219474.63068d0
      amu=1822.88839d0
     
     
!     File Check

      inquire(file=filename,exist=lex)
      if(.not.lex)then
         sta=-1
         return
      end if
      sta=0
      OPEN(2,FILE=filename)
      
2000  format(A150)
      rewind(2)
      iz=0
      ama=0d0
      nat=0
      l=0
!     Reads every line of the gaussian output file and checks every line for wanted parameters
50    CONTINUE
         read(2,2000,end=1001)FN
!         write(6,2000)FN
         
         if(FN(1:12)==' Atom  1 has')then
            n_atoms=1
            do i = 1,1000
               read(2,2000,end=1001)FN
               if(FN(1:6)==' Atom ')then
                  n_atoms=n_atoms+1
               else
                  exit
               end if
            end do
            allocate(a_masses(n_atoms))
            do i = 1,n_atoms+1
               backspace(2)
            end do
            do i = 1,n_atoms
               read(2,2000,end=1001)FN
               read(FN(36:44),*)a_masses(i)
               !a_masses(i)=GetMass(iz(i),curmass)
            end do
         end if
         
         
         if(FN(27:44).EQ.'Input orientation:')THEN
         
         NG=NG+1
         DO 4 I=1,4
            READ(2,*)
4           CONTINUE
         l=0
            
5        READ(2,2000)FN
         IF(FN(2:4).NE.'---')THEN
            l=l+1
            if(l.gt.n0)call report('too many atoms')
            BACKSPACE 2
            READ(2,5001)IA,KA,IA,r(1,l),r(2,l),r(3,l)
            iz(l)=KA
!         IF(KA.EQ.-1)l=l-1
            GOTO 5
         ENDIF
         
         nat=l
!4000     format(I3,3F12.6,7(1x,i1),f4.1)
5001     format(1x,I6,6x,I6,6x,I6,3x,3(1x,F11.6))
         ENDIF        



         if(FN(1:49).eq.' Dipole moment (field-independent basis, Debye):' .and. .not.dip_found)then
            read(2,2000,end=1001)FN
            read(FN(1:79),207)(dip(i),i=1,3)
207         format(3(13x,f15.4))
            dip(1)=dip(1)
            dip(2)=dip(2)
            dip(3)=dip(3)
            dip=dip*SI2AU_debye
         endif
         
         IF(FN(2:40).eq.'Paramagnetic susceptibility tensor (au)')then
!            write(6,2000)FN
            do 10 i=1,3
            read(2,203)(xp(i,j),j=1,3)
10          continue
203         format(3(6x,f15.4))
         endif
                  
         IF(FN(2:43).eq.'Quadrupole moment (field-independent basis' .and. .not.q_found)then
!        Gaussian, Debye*Ang:
!            write(6,2000)FN
            read(2,204)quad(1,1),quad(2,2),quad(3,3)
            read(2,204)quad(1,2),quad(1,3),quad(2,3)
204         format(3(6x,f20.4))
            quad(2,1)=quad(1,2)
            quad(3,1)=quad(1,3)
            quad(3,2)=quad(2,3)
            do 122 i=1,3
               do 123 j=1,3
                  quad(i,j)=quad(i,j)/bohr*SI2AU_debye
123            continue
122         continue
   !       traceless:
           quadtr(1,1)=(2.0d0*quad(1,1)-quad(2,2)-quad(3,3))/3.0d0
           quadtr(2,2)=(2.0d0*quad(2,2)-quad(3,3)-quad(1,1))/3.0d0
           quadtr(3,3)=(2.0d0*quad(3,3)-quad(1,1)-quad(2,2))/3.0d0
           quadtr(1,2)=quad(2,1)
           quadtr(2,1)=quad(1,2)
           quadtr(1,3)=quad(3,1)
           quadtr(3,1)=quad(1,3)
           quadtr(2,3)=quad(3,2)
           quadtr(3,2)=quad(2,3)
          
         endif

         IF(FN(2:28).eq.'Rotational constants (GHZ):' .and. .not.abc_found)then
            !read(FN(29:88),2315)(ABC(I),I=1,3)
            read(FN(29:48),2316)abc(1)
            read(FN(49:68),2316)abc(2)
            read(FN(69:88),2316)abc(3)
         endif       
!2315     format(3(f20.7))  
2316     format(f19.7)  
         IF(FN(2:24).eq.'GIAO rotational tensor:' .and. .not.g_found)then
            read(2,2000)FN
            read(FN(7:17),*)g(1,1)
            read(FN(24:34),*)g(2,1)
            read(FN(41:51),*)g(3,1)
            read(2,2000)FN
            read(FN(7:17),*)g(1,2)
            read(FN(24:34),*)g(2,2)
            read(FN(41:51),*)g(3,2)
            read(2,2000)FN
            read(FN(7:17),*)g(1,3)
            read(FN(24:34),*)g(2,3)
            read(FN(41:51),*)g(3,3)
            
            ! do 8 i=1,3
               ! read(2,205)(g(i,j),j=1,3)
! 8           continue
205         format(3(6x,f11.4))
            g=transpose(g)
         endif

         IF(FN(10:26).eq.'has atomic number')then
            read(FN(6:8),*)I
            read(FN(35:44),*)ama(I)
         endif
         
         if(FN(2:8).eq.'Charge=')then
            read(FN(14:28),*)charge
         end if
         
         GOTO 50
1001     CLOSE(2)

      inquire(file=filenameDalton,exist=lex)
      !TODO, delete dis
      if(.false.)then
         OPEN(3,FILE=filenameDalton)
         
5124     continue
         read(3,2000,end=5125)FN
            if(FN(1:64)=='  Molecular rotational g-tensor in principal axis system (a.u.):')then
            read(3,2000)FN
            read(3,2000)FN
            read(3,2789)gdalton(1,1),gdalton(1,2),gdalton(1,3)
            read(3,2789)gdalton(2,1),gdalton(2,2),gdalton(2,3)
            read(3,2789)gdalton(3,1),gdalton(3,2),gdalton(3,3)
            
2789        format(11X,3(F15.8,1X))            
            end if
         goto 5124   
5125     close(3)
      end if

!     molecular mass
      mass=0d0
      do i = 1,nat
         idx = iz(i)
         mass=mass+a_masses(i)
      end do

!     coordinates to atomic units:
      do ia=1,nat
         do i=1,3
            r(i,ia)=r(i,ia)/bohr
         end do
      end do


      CM=CALC_COM(nat,a_masses,r)
      
      
! !     subtract mass center:
      ! DO I=1,3
         ! CM(I)=0.0d0
         ! mt=0.0d0
         ! DO J=1,nat
            ! mt=mt+ama(J)
            ! CM(I)=CM(I)+R(I,J)*ama(J)
         ! end do   
         ! CM(I)=CM(I)/mt
      ! end do

      unitt=2
      if(flags(1))then
         open(unitt,file=outputfilen(1:outlen)//'_MolParams')
      end if
      !dip=0d0
      if(.not.dip_found)then 
         do j = 1,3
            dip(j)=dip(j)+charge*CM(j)
         end do
      end if
      
      t0=CALC_INERT(nat,a_masses,r)
      
      do ia=1,nat
         do i=1,3
            r(i,ia)=r(i,ia)-CM(i)
         end do
      end do
      t1=CALC_INERT(nat,a_masses,r)
      
      !dip=dipbuf
      quadbuf=0d0
      
      if(.not.q_found)then 
         do j = 1,3
            do k = 1,3
               quadbuf(j,k)=quad(j,k)-CM(j)*dip(k)-CM(k)*dip(j)
            end do
         end do
         quad=quadbuf
      end if
      if(.not.g_found)then 
         do i=1,3
            do j=1,3
               g(i,j)=g(i,j)*t0(j,j)-mpr_amu*(2d0*kdelta(i,j)*DOT_PRODUCT(dip,CM)-dip(i)*CM(j)-CM(i)*dip(j))
               g(i,j)=g(i,j)/t1(j,j)
            end do
         end do
      end if  
      
!     make inertia-like:
      qt=0.5d0*quad
      qtot=0d0
      do i=1,3
         do j=1,3
            if(i.eq.j)then
               k=i+1
               if(k.gt.3)k=1
               l=k+1
               if(l.gt.3)l=1
               qtot(i,j)=qt(k,k)+qt(l,l)
            else
               qtot(i,j)=-qt(i,j)
            endif
         end do
      end do
      quadbuf=0d0
      outp=.true.
      if(flags(1))then
         write(unitt,*)'mass center (A):'
         write(unitt,6001)(cm(i)*bohr,i=1,3)
      end if
   !  inertia and quadrupole moment:
      do 6 i=1,3
         t(i,i)=0.0d0
         q(i,i)=0.0d0
         j=i+1
         if(j.gt.3)j=1
         k=j+1
         if(k.gt.3)k=1
         do 61 ia=1,nat
            q(i,i)=q(i,i)+dble(iz(ia))*(r(j,ia)*r(j,ia)+r(k,ia)*r(k,ia))
            t(i,i)=t(i,i)+a_masses(ia)*(r(j,ia)*r(j,ia)+r(k,ia)*r(k,ia))
61       continue
         do 9 j=1,i-1
            t(i,j)=0.0d0
            q(i,j)=0.0d0
            do 62 ia=1,nat
               q(i,j)=q(i,j)-dble(iz(ia))*r(i,ia)*r(j,ia)
               t(i,j)=t(i,j)-a_masses(ia)*r(i,ia)*r(j,ia)
62          continue
            q(j,i)=q(i,j)
            t(j,i)=t(i,j)
9        continue
6     continue
         
      t=0d0
      q=0d0
      do i = 1,nat
         do j=1,3
            do k=1,3
               q(j,k)=q(j,k)+dble(iz(i))*(dble(kdelta(j,k))*DOT_PRODUCT(r(:,i),r(:,i))-r(j,i)*r(k,i))
            end do
         end do
         ! q(1,1)=q(1,1) + dble(iz(i))*(r(2,i)**2+r(3,i)**2)
         ! q(2,2)=q(2,2) + dble(iz(i))*(r(1,i)**2+r(3,i)**2)
         ! q(3,3)=q(3,3) + dble(iz(i))*(r(2,i)**2+r(1,i)**2)
         ! q(1,2)=q(1,2) - dble(iz(i))*r(1,i)*r(2,i)
         ! q(1,3)=q(1,3) - dble(iz(i))*r(1,i)*r(3,i)
         ! q(2,3)=q(2,3) - dble(iz(i))*r(2,i)*r(3,i)
      
         t(1,1)=t(1,1) + a_masses(i)*(r(2,i)**2+r(3,i)**2)
         t(2,2)=t(2,2) + a_masses(i)*(r(1,i)**2+r(3,i)**2)
         t(3,3)=t(3,3) + a_masses(i)*(r(2,i)**2+r(1,i)**2)
         t(1,2)=t(1,2) - a_masses(i)*r(1,i)*r(2,i)
         t(1,3)=t(1,3) - a_masses(i)*r(1,i)*r(3,i)
         t(2,3)=t(2,3) - a_masses(i)*r(2,i)*r(3,i)
      end do
      t(3,2)=t(2,3)
      t(3,1)=t(1,3)
      t(2,1)=t(1,2)
      q(3,2)=q(2,3)
      q(3,1)=q(1,3)
      q(2,1)=q(1,2)
      
      ! t=AxesSwitch_T(t,[1,3,2])
      !if molecular axes are not ordered from lowest to highest moment of inertia
      !this should not matter all that much, but would f-up the correct representation
      if(.not.(t(1,1)<t(2,2).and.t(2,2)<t(3,3)))then
         call Reorder_Tensor(t,order)
         do i = 1,nat
            r(:,i)=AxesSwitch_V(r(:,i),order)
         end do
         if(.not.dip_found)then
            dip = AxesSwitch_V(dip,order)
         end if
         if(.not.g_found)then
            g = AxesSwitch_T(g,order)
         end if
         if(.not.q_found)then
            quad = AxesSwitch_T(quad,order)
         end if
      end if
         !write(6,*)'t matrix:'
         !call WriteMat(t,3,3)
         !write(6,*)'q matrix:'
         !call WriteMat(q,3,3)
         !write(6,*)'r matrix:'
         !call WriteMat(r,3,n0)
         
         e=t
         !CALL WriteMat(T,3,3)
         ierr=0_4
         !CALL TRED12(3,T,A,Z,1,IERR,E)
         call Diag_sym(a,t,3,ierr,.true.)
         !CALL WriteMat(T,3,3)
         !CALL WriteMat(T,arr(1),arr(2))
         !arr=shape(A)
         !write(6,*)(a(i),i=1,3)
         !write(6,*)ierr
!     check that we have a right-handed system
         if(t(3,3)*(t(1,1)*t(2,2)-t(1,2)*t(2,1)).lt.0.0d0)then
            t(1,3)=-t(1,3)
            t(2,3)=-t(2,3)
            t(3,3)=-t(3,3)
            if(flags(1)) write(unitt,*)'chirality fixed'           
         endif
         
         z=0d0
         do i=1,3
            z(i,i)=a(i)
         end do
         a=u*c/1.0d9/a/2.0d0
         !call writemat(MATMUL(e,t),3,3)
         !call writemat(MATMUL(t,z),3,3)
         !Write(6,*)'Eigenvalues:'
         !Write(6,*)(Z(i),i=1,3)
         !Write(6,*)'Eigenvector:'
         !Write(6,*)(E(i),i=1,3)
         
         arrbuf=0d0
         !t=transpose(t)
         do i = 1,3
            do j = 1,3
               do k = 1,3
                  do ii = 1,3
                     arrbuf(i,j)=arrbuf(i,j)+t(i,k)*t(j,ii)*e(k,ii)
                  end do
               end do
            end do
         end do
         
         !arrbuf=RotateT(e,t)

         if(flags(1))then
            write(unitt,*)'Gaussian (GHz):'
            write(unitt,6000)(abc(i),i=1,3)
            write(unitt,*)'Recalc:'
            write(unitt,6000)(a(i)/amu,i=1,3)
         end if
6000     format(3f18.6)

         if(.not.g_found)then
            do i=1,3
               do j=1,3
                  ge(i,j)=-4.0d0*xp(i,j)/e(i,i)*mp
                  gn(i,j)=q(i,j)/e(i,i)*mp
                  gt(i,j)=ge(i,j)+gn(i,j)
               end do
            end do

            do i=1,3
               do j=1,3
                  gq(i,j)=qtot(i,j)/e(i,i)*mp
               end do
            end do
         end if


         if(flags(1))then
         write(unitt,*)'Laboratory system:'
         ! write(6,*)'Positions:'
         ! do i = 1,nat
            ! write(6,6382)i,(r(j,i),j=1,3)
! 6382     format(I4,': ',3F18.6)       
         ! end do
         write(unitt,*)
         write(unitt,*)'Trafo:'
         write(unitt,6001)((t(i,j),i=1,3),j=1,3)
         write(unitt,*)'xp:'
         write(unitt,6001)((xp(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor,electronic:'
         write(unitt,6001)((ge(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor,nuclear:'
         write(unitt,6001)((gn(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor,electronic+nuclear:'
         write(unitt,6001)((gt(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor in output:'
         write(unitt,6001)((g(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment (1/2) qrr:'
         write(unitt,6001)((qt(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment nuclear:'
         write(unitt,6001)((q(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment total, inertia-like:'
         write(unitt,6001)((qtot(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment total, traceless:'
         write(unitt,6001)((quadtr(i,j),i=1,3),j=1,3)
         write(unitt,*)'Inertia moment:'
         write(unitt,6001)((e(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor from quadrupole:'
         write(unitt,6001)((gq(i,j),i=1,3),j=1,3)
         write(unitt,*)'dipole (au):'
         write(unitt,6001)(dip(i),i=1,3)
         end if
6001     format(/,3(3f18.6,/),/)

         !write(6,*)'dipole (au):'
         !write(6,6001)(dip(i),i=1,3)
         ! do i = 1,nat
            ! r(:,i)=MATMUL(t,r(:,i))
         ! end do
         
         ! arrbuf=0d0
         ! do i = 1,3
            ! do j = 1,3
               ! bufr=0d0
               ! do k = 1,3
                  ! do m = 1,3
                     ! bufr=bufr+t(i,k)*t(j,m)*xp(k,m)
                  ! end do 
               ! end do
               ! arrbuf(i,j)=bufr
            ! end do
         ! end do
         
         if(.not.dip_found)then
            dip=RotateV(dip,t)
         end if
         xp=RotateT(xp,t)
         e=RotateT(e,t)
         q=rotatet(q,t)
         qtot=Rotatet(qtot,t)
         quadtr=Rotatet(quadtr,t)
         g=rotatet(g,t)
         gq=Rotatet(gq,t)
         qt=rotatet(qt,t)
         
         !quad=rotatet(quad,t)
         !arrbuf=rotatet(t,t)
         if(.not.g_found)then
            do i=1,3
               do j=1,3
                  ge(i,j)=-4.0d0*xp(i,j)/e(i,i)*mp
                  gn(i,j)=q(i,j)/e(i,i)*mp
                  gt(i,j)=ge(i,j)+gn(i,j)
                  gq(i,j)=qtot(i,j)/e(i,i)*mp
               end do
            end do
         end if
         if(flags(1))then
         write(unitt,*)'Molecular system:'
         ! write(6,*)'Positions:'
         ! do i = 1,nat
            ! write(6,6382)i,(r(j,i),j=1,3)
         ! end do
         write(unitt,*)
         write(unitt,*)'xp:'
         write(unitt,6001)((xp(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor,electronic:'
         write(unitt,6001)((ge(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor,nuclear:'
         write(unitt,6001)((gn(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor,electronic+nuclear:'
         write(unitt,6001)((gt(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor in output:'
         write(unitt,6001)((g(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment (1/2) qrr:'
         write(unitt,6001)((qt(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment nuclear:'
         write(unitt,6001)((q(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment total, inertia-like:'
         write(unitt,6001)((qtot(i,j),i=1,3),j=1,3)
         write(unitt,*)'Quadrupole moment total, traceless:'
         write(unitt,6001)((quadtr(i,j),i=1,3),j=1,3)
         write(unitt,*)'Inertia moment:'
         write(unitt,6001)((e(i,j),i=1,3),j=1,3)
         write(unitt,*)'g-tensor from quadrupole:'
         write(unitt,6001)((gq(i,j),i=1,3),j=1,3)
         write(unitt,*)'dipole (au):'
         write(unitt,6001)(dip(i),i=1,3)
         close(unitt)
         write(6,*)'WRITTEN '//outputfilen(1:outLen)//'_MolParams'
         end if
      if(.not.q_found)then
0451     quad=qt
      end if
      if(.not.g_found)then
         gt=g
      end if
      end subroutine readFile
      
      function RotateV(v,T) result(res)
         real(8) v(3),T(3,3),res(3)
         integer(4) i,j
         
         res=0.0d0
         do i=1,3
            do j=1,3
               res(i)=res(i)+T(j,i)*v(j)
            end do
         end do
      end function RotateV
      
      function RotateT(v,t) result(res)
         real(8) v(3,3),T(3,3),res(3,3)
         integer(4) i,j,k,l
         
         res=0.0d0
         do i=1,3
            do j=1,3
               do k=1,3
                  do l=1,3
                     res(i,j)=res(i,j)+t(k,i)*t(l,j)*v(k,l)
                  end do
               end do
            end do
         end do
      end function RotateT
      
!     write 2d matrix to unit 6 (the console)
      subroutine WriteMat(mat,x,y)
         Integer(4) :: x,y,i,j
         Real(8), dimension(x,y) :: mat
         
         do i = 1,y
            write(6,2000)(mat(j,i),j=1,x)
         end do
2000     format(3(f16.5))
         write(6,*)''
      end subroutine WriteMat
      
      
!     generic error handling, writes argument
      subroutine report(s)
      character(*) s
      write(6,*)s
      stop 1
      end subroutine report

      
      
end module input

module wigner
   implicit none
   integer(4) factSize
   integer(4) W3Jsize
   parameter(factSize=170)   !MAXIMUM FACTORIAL REPRESENTABLE IN DOUBLE PRECISION IS APPROXIMATELY 170!
   parameter(W3Jsize=100000000)
   real(8) factorials(factSize)
   real(8),allocatable :: W3Js(:)
   integer(8) W3J_count
   complex(8),parameter :: iu=(0d0,1d0)
   logical factFlag,W3JFlag,W3JDiskFlag
   
   public factorials,W3Js,factFlag
   
   interface calc_c
      module procedure calc_c_a,calc_c_b
   end interface calc_c
   
   interface LXTBS
      module procedure LXTBS_a
      module procedure LXTBS_b
   end interface LXTBS
   
   interface CALC_R
      module procedure CALC_R_A,CALC_R_B
   end interface CALC_R
   
   contains
   
   subroutine COMPUTE_FACTORIALS()
      integer(4) i
      do i = 1,factSize
         factorials(i)=fact(i)
      end do
      factFlag=.true.
   end subroutine COMPUTE_FACTORIALS
!==============================================
!W3J STORAGE
!storing W3J coefficient in a 6 dim array would be memory-expensive
!On a further note, after thouroughly thinking about this it saves memory but barely saves time
!Feel free to rip it from here for your own use
!https://doi.org/10.1137/S1064827503422932
!==============================================
   function CALC_R_B(arr) result (r)
      integer(4) arr(2,3),r(3,3)
      r = calc_R(arr(1,1),arr(1,2),arr(1,3),arr(2,1),arr(2,2),arr(2,3))
   end function CALC_R_B
   
   function CALC_R_A(j1,j2,j3,m1,m2,m3) result (r)
      integer(4):: j1,j2,j3,m1,m2,m3
      integer(4), dimension(3,3) :: r
      
      R(1,1)=-j1+j2+j3
      R(1,2)=j1-j2+j3
      R(1,3)=j1+j2-j3
      R(2,1)=j1-m1
      R(2,2)=j2-m2
      R(2,3)=j3-m3
      R(3,1)=j1+m1
      R(3,2)=j2+m2
      R(3,3)=j3+m3         
   end function CALC_R_A
               
   subroutine PermR_row(R,a,b,c)
      integer(4),intent(inout), dimension(3,3) :: r
      integer(4),intent(in):: a,b,c
      integer(4) buf(3,3)
      
      buf(1,:)=r(a,:)
      buf(2,:)=r(b,:)
      buf(3,:)=r(c,:)
      r=buf
   end subroutine PermR_row
   
   subroutine PermR_column(R,a,b,c)
      integer(4),intent(inout), dimension(3,3) :: r
      integer(4),intent(in):: a,b,c
      integer(4) buf(3,3)
      
      buf(:,1)=r(:,a)
      buf(:,2)=r(:,b)
      buf(:,3)=r(:,c)
      r=buf
   end subroutine PermR_column
   
   subroutine Change_signs(arr)
      integer(4), intent(inout) :: arr(2,3)
      integer(4) :: minus
      
      minus=(-1)**((arr(1,1)+arr(1,2)+arr(1,3)))
      arr(2,1)=minus*arr(2,1)
      arr(2,2)=minus*arr(2,2)
      arr(2,3)=minus*arr(2,3)
   end subroutine Change_signs
   
   subroutine LXTBS_a(j1,j2,j3,m1,m2,m3,minusFlag,arr)
      integer(4) :: R(3,3)
      integer(4),intent(in) :: j1,j2,j3,m1,m2,m3
      integer(4),intent(out) :: arr(5)
      logical, intent(out) :: minusFlag
      
      R = CALC_R(j1,j2,j3,m1,m2,m3)
      call LXTBS_b(R,minusFlag,arr)
   end subroutine LXTBS_a
   
   subroutine LXTBS_b(R,minusFlag,arr)
      integer(4),intent(inout) :: R(3,3)
      integer(4) :: i,j,rangeArrRows(3),rangeArrColumns(3),maxi,arr2(3),maxind,minind
      integer(4),intent(out) ::arr(5)
      logical, intent(out) :: minusFlag
      
      minusFlag=.false.
      if(minusFlag.eqv..true.) then
      STOP 'Wrong minusFlag'
      end if
      
      j = SUM(R(1,:))
      do i = 1,3
         rangeArrRows(i)=MAXVAL(R(i,:))-MINVAL(R(i,:))
         rangeArrColumns(i)=MAXVAL(R(:,i))-MINVAL(R(:,i))
      end do
      
      !MAYBE?!
      if(MAXVAL(rangeArrRows)<MAXVAL(rangeArrColumns))then
         R = transpose(R)
         !minusFlag=XOR(.true.,minusFlag)
         maxi = MAXLOC(rangeArrColumns,dim=1)
      else
         maxi = MAXLOC(rangeArrRows,dim=1)
      end if
      arr2 = R(maxi,:)
      
      !if the maximum range is not in the first row => even permute
      if(maxi==2)then
         call PermR_row(R,maxi,3,1)
         
      else if(maxi==3)then
         call PermR_row(R,maxi,1,2)
         
      end if
      maxind = MAXLOC(arr2,dim=1)
      minind = MINLOC(arr2,dim=1)
      if(maxind==minind)then
         arr2(maxind)=HUGE(0)
         minind = MINLOC(arr2,dim=1)
      end if
      call PermR_column(R,minind,maxind,6-minind-maxind)
      if(((minind==1).AND.(maxind==3)).OR.((minind==2).AND.(maxind==1)).OR.((minind==3).AND.(maxind==2)))then
         minusFlag=XOR(.true.,minusFlag) !¯\_(ツ)_/¯
      end if
      
      if((R(1,2)>=R(2,1)).AND.(R(2,1)>=R(3,3)).AND.(R(3,3)>=R(2,2)).AND.(R(2,2)>=R(1,1))) then
         goto 220
      end if
      ! call PermR_row(R,1,3,2)
      ! minusFlag=.true.
      
      if(SUM(R(1,:))/=J.OR.SUM(R(2,:))/=J.OR.SUM(R(3,:))/=J.OR.SUM(R(:,1))/=J.OR.SUM(R(:,2))/=J.OR.SUM(R(:,3))/=J)then
      STOP 'BROKEN EQULALITY TO J'
      end if
      
220      continue         
      arr(1) = R(1,2)!L
      arr(2) = R(2,1)!X
      arr(3) = R(3,3)!T
      arr(4) = R(2,2)!B
      arr(5) = R(1,1)!S
      if((arr(1)>=arr(2)).AND.(arr(2)>=arr(3)).AND.(arr(3)>=arr(4)).AND.(arr(4)>=arr(5))) then
         return
      else
         continue
         STOP 'INEQUALITY WRONG L>=X>=T>=B>=S'
      end if
   end subroutine LXTBS_b
   
   ! function XOR(a,b) result (res)
      ! logical a,b,res
      ! res = (a.AND.(.NOT.b)).OR.((.NOT.A).AND.B)
   ! end function XOR
   
   function calc_c_a(arr) result (c)
      integer(4) c,L,X,T,B,S,arr(5)
      
      L=arr(1)
      X=arr(2)
      T=arr(3)
      B=arr(4)
      S=arr(5)
      c = NINT((1d0/120d0)*L*(24+L*(50+L*(35+L*(10+L))))+1d0/24d0*X*(6+X*(11+X*(6+X)))+1.0d0/6.0d0*T*(2+T*(3+T))+0.5d0*B*(B+1)+S+1)
   end function calc_c_a
   
   function calc_c_b(L,X,T,B,S) result (c)
      integer(4) c,L,X,T,B,S
      
      c = NINT((1d0/120d0)*L*(24+L*(50+L*(35+L*(10+L))))+1d0/24d0*X*(6+X*(11+X*(6+X)))+1.0d0/6.0d0*T*(2+T*(3+T))+0.5d0*B*(B+1)+S+1)
   end function calc_c_b
   
   subroutine REORDER_W3J_B(arr)
      integer(4), intent(inout) :: arr(2,3)
      
      ! if(MOD((arr(1,1)+arr(1,2)+arr(1,3)),2)/=0)then
         ! i=0
      ! end if
      call ASHIFT_W3J(arr,1,2)
      if(arr(1,1)>=arr(1,3).AND.arr(1,3)>=arr(1,2)) return
      call SHIFT_W3J(arr)
      if(arr(1,1)>=arr(1,3).AND.arr(1,3)>=arr(1,2)) return
      call SHIFT_W3J(arr)
      if(arr(1,1)>=arr(1,3).AND.arr(1,3)>=arr(1,2)) return
      stop 'BAD SHIFT'
   end subroutine REORDER_W3J_B
    
   !anticyclic permutation of W3J coeff
   subroutine ASHIFT_W3J(arr,i,j)
      integer(4), intent(inout) :: arr(2,3)
      integer(4) i,j,buf(2),minus
      
      buf=arr(:,j)
      arr(:,j)=arr(:,i)
      arr(:,i)=buf
      minus=(-1)**((arr(1,1)+arr(1,2)+arr(1,3)))
      arr(2,1)=minus*arr(2,1)
      arr(2,2)=minus*arr(2,2)
      arr(2,3)=minus*arr(2,3)
   end subroutine ASHIFT_W3J
    
   !Cyclic permutation of W3J coeff
   subroutine SHIFT_W3J(arr)
      integer(4), intent(inout) :: arr(2,3)
      integer(4) buf1(3),buf2(3)
      
      buf1=arr(1,:)
      buf2=arr(2,:)
      
      call SHIFT_ARR_1D(buf1)
      call SHIFT_ARR_1D(buf2)
      
      arr(1,:)=buf1
      arr(2,:)=buf2
   end subroutine SHIFT_W3J
   
   subroutine SHIFT_ARR_1D(arr)
      integer(4), intent(inOUT) :: arr(:)
      integer(4) leng,i,buf
      
      leng = size(arr,1)
      buf = arr(leng)
      do i = leng,2,-1
         arr(i)=arr(i-1)
      end do
      arr(1)=buf
      
   end subroutine
   
   subroutine REORDER_W3J(arr)
      integer(4), intent(inout) :: arr(2,3)
      integer(4) i
      
      do i=1,4
         if(i>=4) then
            call REORDER_W3J_B(arr)
            return
         end if
         if(arr(1,1)>=arr(1,3).AND.arr(1,3)>=arr(1,2))then
            exit
         end if
         call SHIFT_W3J(arr)
      end do
   end subroutine REORDER_W3J
   
   
   
   !Probably implemented wrong or I didn't understand the paper
   function APPROX_STORAGE_NEEDED(L) result(res)
      integer(4) L,res
      res = INT(1d0/120d0*L*(274+L*(225+L*(85+L*(15+L))))+1)
   end function APPROX_STORAGE_NEEDED
   
   subroutine COMPUTE_W3Js(fromJ,toJ)
      integer(4) a,b,c,d,e,f,arr(2,3),fromJ,toJ,ind,arrLXTBS(5),R(3,3),arrmaxbuf(2,3),indbuf,i,j
      real(8) buf
      logical minus
      
      if(fromJ<0.OR.toJ<0)STOP 'J cannot be negative'
      
      !write(6,*)
      indbuf=0
      allocate(W3Js(W3Jsize))
      W3Js=HUGE(1.0d0)!error catch
      !NOTE: the indices from the paper are ALL constant, if you put more constraints on any of the looping variables,
      !      it will just speed up the calculation, the maximum index COULD stay the same
      do a = fromJ,toJ
         do b = 0,a
            do c = abs(a-b),a+b
               do d = -a,a
                  do e = -b,b
                     do f = -c,c
                        minus=.false.
                        if((d+e+f/=0).OR.(TRIANGLE_RULE(a,b,c).eqv..false.)) then
                           cycle
                        end if
                        arr(1,1)=a
                        arr(1,2)=b
                        arr(1,3)=c
                        arr(2,1)=d
                        arr(2,2)=e
                        arr(2,3)=f
                        
                        call reorder_W3J(arr)                        
                        buf=W3J(arr(1,1),arr(1,2),arr(1,3),arr(2,1),arr(2,2),arr(2,3))
                        R=calc_R(arr(1,1),arr(1,2),arr(1,3),arr(2,1),arr(2,2),arr(2,3))
                        call LXTBS_b(R,minus,arrLXTBS)
                        ind = calc_c(arrLXTBS)
                        if((minus.eqv..true.).AND.(MODULO(arr(1,1)+arr(1,2)+arr(1,3),2)/=0)) then
                           buf=-buf
                        end if
                        if(ind>indbuf)then
                           indbuf=ind
                           arrmaxbuf=arr
                        end if
                        W3JS(ind)=buf
                     end do
                  end do
               end do
            end do
         end do
         !write(6,*)'Index: ',indbuf
         !write(6,2001)((arrmaxbuf(i,j),j=1,3),i=1,2)
      end do
2001     format(/,2(3I3,/),/)        
      W3JFlag=.true.
   end subroutine COMPUTE_W3Js      
   
   !pseudo triangle rule
   function TRIANGLE_RULE(a,b,c) result(res)
      integer(4), INTENT(IN) :: a,b,c
      logical res
      
      res = .false.
      if(a+b>=c.AND.a+c>=b.AND.b+c>=a)then
         res = .true.
         return
      end if
   end function TRIANGLE_RULE

   !store W3js on the hard drive, works but is super slow
   subroutine W3J_to_hdd(endJ)
      integer(4) a,b,c,d,e,f,endJ
      real(8) buf
      
      W3J_count=0
      OPEN(69,FILE='W3Js_sratch',ACCESS='direct',RECL=35,FORM='formatted')
      
      do a = 0,endJ+1
      do b = 0,endJ+1
      do c = 0,endJ+1
      do d = -a,a
      do e = -b,b
      do f = -c,c
         if((TRIANGLE_RULE(a,b,c).eqv..false.).or.((d+e+f)/=0))cycle
         buf=W3J(a,b,c,d,e,f)
         W3J_count=W3J_count+1
         write(69,2000,rec=W3J_count)a,b,c,d,e,f,buf
      end do
      end do
      end do
      end do
      end do
      end do
      
2000     format(3I2,3I3,1E20.13E2)       
   end subroutine W3J_to_hdd
   
   
   function BINARY_SEARCH_W3J(j1,j2,j3,m1,m2,m3) result(res)
      integer(4) j1,j2,j3,m1,m2,m3,arr(6)
      integer(4) j1_,j2_,j3_,m1_,m2_,m3_
      integer(8) i,mid,right,left
      real(8) res
      
      arr = (/j1,j2,j3,m1,m2,m3/)
      left=1
      right=W3J_count
      mid=(right-left)/2+left
      call BINARY_SEARCH(arr,1,left,right,mid)
      call BINARY_SEARCH(arr,2,left,right,mid)
      call BINARY_SEARCH(arr,3,left,right,mid)
      call BINARY_SEARCH(arr,4,left,right,mid)
      call BINARY_SEARCH(arr,5,left,right,mid)
      call BINARY_SEARCH(arr,6,left,right,mid)
      !res = Linear_search(j1,j2,j3,m1,m2,m3,left,right)
      
      read(69,2000,rec=mid)j1_,j2_,j3_,m1_,m2_,m3_,res
      
2000     format(3I2,3I3,1E20.13E2)       
   end function BINARY_SEARCH_W3J
   
   function Linear_search(j1,j2,j3,m1,m2,m3,left,right) result(res)
      integer(4),intent(in) :: j1,j2,j3,m1,m2,m3
      integer(8),intent(in) :: left,right
      integer(4) j1_,j2_,j3_,m1_,m2_,m3_,i
      integer(8) idx
      real(8) res
      
      do i = 0,right-left
         read(69,2000,rec=left+i)j1_,j2_,j3_,m1_,m2_,m3_,res
         if((j1_==j1).and.(j2_==j2).and.(j3_==j3).and.(m1_==m1).and.(m2_==m2).and.(m3_==m3))then
            return
         end if
      end do
2000     format(3I2,3I3,1E20.13E2)       
   end function Linear_search
   
   
   subroutine BINARY_search(wanted,idx,left,right,mid)
      integer(4),intent(in) :: wanted(6),idx
      integer(4) :: arr(6),j
      real(8) res
      integer(8),intent(inout) :: left,right,mid
      integer(8) i,mid2,left2,right2
      logical condition
      
2000     format(3I2,3I3,1E20.13E2)       
      if((idx>6).or.(idx<1))then
         STOP 'IZ WRONK BINARY_SEARCH'
      end if
      do i = 1,W3J_count
      read(69,2000,rec=mid)arr(1),arr(2),arr(3),arr(4),arr(5),arr(6),res
         
         do j = 1,idx
            condition=(arr(j)==wanted(j))
         end do
         if(condition.eqv..true.)then
            mid2=mid
            right2=right
            left2=left
            do j = mid2,right2,1
               read(69,2000,rec=j)arr(1),arr(2),arr(3),arr(4),arr(5),arr(6),res
               if(arr(idx)==wanted(idx))then
                  right=j
               else if(arr(idx)>wanted(idx))then
                  exit
               end if
            end do
            
            do j = mid2,left2,-1
               read(69,2000,rec=j)arr(1),arr(2),arr(3),arr(4),arr(5),arr(6),res
               if(arr(idx)==wanted(idx))then
                  left=j
               else if(arr(idx)<wanted(idx))then
                  exit
               end if
            end do
            return
         else if(arr(idx)<wanted(idx))then
            left=mid+1
            mid=(right-left)/2+left
         else if(arr(idx)>wanted(idx))then
            right=mid-1
            mid=(right-left)/2+left
         end if
      end do
   end subroutine BINARY_search
   
!==============================================
!SPHERICAL TENSORS AND CG/W3J COEFFS.
!==============================================
   !
   !ROWS THEN COLUMNS arr(rows,columns)
   !CARTESIAN VECTOR: X,Y,Z ==> 1,2,3
   !SPHERICAL TENSOR OF RANK 1 INDICES: -1,0,1 ==> 1,2,3
   !SPHERICAL TENSOR OF RANK 2 INDICES: -2,-1,0,1,2 ==> 1,2,3,4,5
   !returns spherical tensor (rank 1) of a cartesian vector u, returns double array[3] v
   
   subroutine CART2SPH_V(u,v)
      integer(4) n,m,len_u,len_v
      parameter(n=3,m=3)
      real(8), INTENT(IN) :: u(n)
      complex(8), INTENT(OUT) :: v(m)
      
      len_u = size(u,dim=1)
      len_v = size(v,dim=1)
      if(len_u/=n.or.len_v/=m)STOP 'ARRAY DIMENSIONS DO NOT MATCH CARTESIAN OR SPHERICAL DIMENSIONS'
      
      v(1)=(sqrt(2.0d0)/2.0d0)*CMPLX(u(1),u(2),kind=8)
      v(3)=-(sqrt(2.0d0)/2.0d0)*CMPLX(u(1),-u(2),kind=8)
      v(2)=-u(3)
      
   end subroutine CART2SPH_V
   
   !same as the subroutine below except you leave out the (Z,X) and (Z,Y) elements
   !not in use obv
   subroutine CART2SPH_T_V_MODIFIED(u,v)
      integer(4) n,m,len_u,len_v
      parameter(n=3,m=3)
      real(8), INTENT(IN) :: u(n,n)
      complex(8), INTENT(OUT) :: v(m)
      
      len_u = size(u,dim=1)
      len_v = size(v,dim=1)
      if(len_u/=n.or.len_v/=m)STOP 'ARRAY DIMENSIONS DO NOT MATCH CARTESIAN OR SPHERICAL DIMENSIONS'
      
      v(1)=(1.0d0/sqrt(2.0d0))*CMPLX(-u(1,3),u(2,3),kind=8)
      v(3)=(1.0d0/sqrt(2.0d0))*CMPLX(-u(1,3),-u(2,3),kind=8)
      v(2)=(1.0d0/sqrt(8.0d0))*CMPLX(0.0d0,2.0d0*u(1,2)-2.0d0*u(2,1),kind=8)
   end subroutine CART2SPH_T_V_MODIFIED
   
   subroutine CART2SPH_T_V(u,v)
      integer(4) n,m,len_u,len_v
      parameter(n=3,m=3)
      real(8), INTENT(IN) :: u(n,n)
      complex(8), INTENT(OUT) :: v(m)
      complex(8) a(m)
      
      len_u = size(u,dim=1)
      len_v = size(v,dim=1)
      if(len_u/=n.or.len_v/=m)STOP 'ARRAY DIMENSIONS DO NOT MATCH CARTESIAN OR SPHERICAL DIMENSIONS'
      
      ! call CART2SPH_V(u,a)
      ! v(3)=1.0d0/sqrt(2.0d0)*(a(3)*a(2)-a(2)*a(3))
      ! v(1)=1.0d0/sqrt(2.0d0)*(a(2)*a(1)-a(1)*a(2))
      ! v(2)=1.0d0/sqrt(2.0d0)*(a(3)*a(1)-a(1)*a(3))
      
      v(1)=(1.0d0/sqrt(4.0d0))*CMPLX(u(3,1)-u(1,3),-u(3,2)+u(2,3),kind=8)
      v(3)=(1.0d0/sqrt(4.0d0))*CMPLX(u(3,1)-u(1,3),-u(2,3)+u(3,2),kind=8)
      v(2)=(1.0d0/sqrt(8.0d0))*CMPLX(0.0d0,2.0d0*u(1,2)-2.0d0*u(2,1),kind=8)
   end subroutine CART2SPH_T_V
   
   !returns spherical tensor (rank 2) of a 2D cartesian tensor u[3,3], returns complex double array[5] v
   subroutine CART2SPH_T(u,v)
      integer(4) n,m,len_u,len_v
      parameter(n=3,m=5)
      real(8), INTENT(IN) :: u(n,n)
      complex(8), INTENT(OUT) :: v(m)
      complex(8) a(m)
      len_u = size(u,dim=1)
      len_v = size(v,dim=1)
      if(len_u/=n.or.len_v/=m)STOP 'ARRAY DIMENSIONS DO NOT MATCH CARTESIAN OR SPHERICAL DIMENSIONS'
      
      ! call CART2SPH_T_V(u,a)
      
      ! v(1)=a(1)*a(1)
      ! v(2)=1.0d0/sqrt(2.0d0)*(a(3)*a(2)+a(2)*a(3))
      ! v(3)=1.0d0/sqrt(6.0d0)*(a(3)*a(1)+a(1)*a(3)+2d0*a(2)*a(2))
      ! v(4)=1.0d0/sqrt(2.0d0)*(a(1)*a(2)+a(2)*a(1))
      ! v(5)=a(3)*a(3)
      
      ! return
      v(1)=0.5d0*CMPLX(u(1,1)-u(2,2),-(u(1,2)+u(2,1)),kind=8)
      v(2)=0.5d0*CMPLX(u(1,3)+u(3,1),-(u(2,3)+u(3,2)),kind=8)
      v(3)=1.0d0/sqrt(6.0d0)*CMPLX(3*u(3,3)-(u(1,1)+u(2,2)+u(3,3)),0.0d0,kind=8)
      v(4)=-0.5d0*CMPLX(u(1,3)+u(3,1),(u(2,3)+u(3,2)),kind=8)
      v(5)=0.5d0*CMPLX(u(1,1)-u(2,2),u(1,2)+u(2,1),kind=8)
      
   end subroutine CART2SPH_T
  
   !returns spherical tensor (rank 3) of a 3D cartesian tensor u[3,3,3], returns double array[7?] v
   subroutine CART2SPH_3T(u,v)
      integer(4) n,m,len_u,len_v
      parameter(n=3,m=5)
      real(8), INTENT(IN) :: u(n,n,n)
      complex(8), INTENT(OUT) :: v(m)

      len_u = size(u,dim=1)
      len_v = size(v,dim=1)
      if(len_u/=n.or.len_v/=m)STOP 'ARRAY DIMENSIONS DO NOT MATCH CARTESIAN OR SPHERICAL DIMENSIONS'

      !TODO implement?
      
   end subroutine CART2SPH_3T
  
   !spherical mixed form of a cartesian tensor u[3,3], returns double array[3,3] v
   subroutine CART2SPH_T_MIX(u,v)
      integer(4) n,m,len_u,len_v
      parameter(n=3,m=3)
      real(8), INTENT(IN) :: u(n,n)
      complex(8), INTENT(OUT) :: v(m,m)
      complex(8) iu
      
      iu=(0d0,1d0)
      len_u = size(u,dim=1)
      len_v = size(v,dim=1)
      if(len_u/=n.or.len_v/=m)STOP 'ARRAY DIMENSIONS DO NOT MATCH CARTESIAN OR SPHERICAL DIMENSIONS'
      goto 51
51       continue
      !-1,-1
      v(1,1)=0.5d0*(u(1,1)-iu*u(2,1)+iu*u(1,2)+u(2,2))
      v(1,2)=1d0/sqrt(2d0)*(u(1,3)-iu*u(2,3))
      v(1,3)=0.5d0*(-u(1,1)+u(2,2)+iu*u(2,1)+iu*u(1,2))
      
      v(2,1)=1d0/sqrt(2d0)*(u(3,1)+iu*u(3,2))
      v(2,2)=u(3,3)
      v(2,3)=1d0/sqrt(2d0)*(-u(3,1)+iu*u(3,2))
      
      
      v(3,3)=0.5d0*(u(1,1)+iu*u(2,1)-iu*u(1,2)+u(2,2))
      v(3,2)=-1d0/sqrt(2d0)*(u(1,3)+iu*u(2,3))
      v(3,1)=0.5d0*(u(2,2)-iu*u(2,1)-u(1,1)-iu*u(1,2))
      
      !v(1,2)=1d0/sqrt(2d0)*(u(1,3)-iu*u(2,3))
      
      
      return
      !-1,-1
      v(1,1)=0.5d0*CMPLX(u(1,1)-u(2,2),-(u(1,2)+u(2,1)),kind=8)
      !-1,0
      v(1,2)=sqrt(0.5d0)*CMPLX(u(1,3),-u(2,3),kind=8)
      !-1,1
      v(1,3)=0.5d0*CMPLX(-u(1,1)-u(2,2),-(u(1,2)-u(2,1)),kind=8)
      !0,-1
      v(2,1)=sqrt(0.5d0)*CMPLX(u(3,1),-u(3,2),kind=8)
      !0,0
      v(2,2)=u(3,3)
      !0,1
      v(2,3)=-sqrt(0.5d0)*CMPLX(u(3,1),u(3,2),kind=8)
      !1,-1
      v(3,1)=0.5d0*CMPLX(-u(1,1)-u(2,2),u(1,2)-u(2,1),kind=8)
      !1,0
      v(3,2)=-sqrt(0.5d0)*CMPLX(u(1,3),u(2,3),kind=8)
      !1,1
      v(3,3)=0.5d0*CMPLX(u(1,1)-u(2,2),u(1,2)+u(2,1),kind=8)
      
      return
      !-1,-1
      v(1,1)=0.5d0*((u(1,1)-iu*u(2,1))+iu*(u(1,2)-iu*u(2,2)))
      !-1,0
      v(1,2)=sqrt(0.5d0)*CMPLX(u(1,3),-u(2,3),kind=8)
      !-1,1
      v(1,3)=-0.5d0*((u(1,1)-iu*u(2,1))-iu*(u(1,2)-iu*u(2,2)))
      !0,-1
      v(2,1)=sqrt(0.5d0)*CMPLX(u(3,1),u(3,2),kind=8)
      !0,0
      v(2,2)=u(3,3)
      !0,1
      v(2,3)=-sqrt(0.5d0)*CMPLX(u(3,1),-u(3,2),kind=8)
      !1,-1
      v(3,1)=-0.5d0*((u(1,1)+iu*u(2,1))+iu*(u(1,2)+iu*u(2,2)))
      !1,0
      v(3,2)=-sqrt(0.5d0)*CMPLX(u(1,3),u(2,3),kind=8)
      !1,1
      v(3,3)=0.5d0*((u(1,1)+iu*u(2,1))-iu*(u(1,2)+iu*u(2,2)))
      
      return
      
      !-1,-1
      !v(1,1)=0.5d0*((u(1,1)-iu*u(2,1))+iu*(u(1,2)-iu*u(2,2)))
      !-1,0
      !v(1,2)=sqrt(0.5d0)*CMPLX(u(1,3),-u(2,3),kind=8)
      !-1,1
      !v(1,3)=-0.5d0*((u(1,1)-iu*u(2,1))-iu*(u(1,2)-iu*u(2,2)))
      !0,-1
      !v(2,1)=sqrt(0.5d0)*CMPLX(u(3,1),u(3,2),kind=8)
      !0,0
      v(2,2)=u(3,3)
      !0,1
      v(2,3)=-sqrt(0.5d0)*CMPLX(u(3,1),-u(3,2),kind=8)
      v(2,1)=-conjg(v(2,3))
      !1,-1
      v(3,1)=-0.5d0*((u(1,1)+iu*u(1,2))+iu*(u(2,1)+iu*u(2,2)))
      v(1,3)=conjg(v(3,1))
      !1,0
      v(3,2)=-sqrt(0.5d0)*CMPLX(u(1,3),u(2,3),kind=8)
      v(1,2)=-conjg(v(3,2))
      !1,1
      v(3,3)=0.5d0*((u(1,1)-iu*u(1,2))+iu*(u(2,1)-iu*u(2,2)))
      v(1,1)=conjg(v(3,3))
   
   end subroutine CART2SPH_T_MIX
   
   function KrDelta(a,b) result(res)
      integer(4) a,b
      integer(4) res
      
      if(a==b)then
         res=1
      else
         res=0
      end if
   end function KrDelta
   
   !Clebsch Gordan coefficient defined by 3 Js and 3Ms, returns double
   function CG(j1,j2,j3,m1,m2,m3) result(res)
      REAL(8) A,B,C,buf
      INTEGER(4) j1,j2,j3,m1,m2,m3,u
      REAL(8) res
      INTEGER(4) i
      
      if((m1+m2)/=m3) then
         res = 0d0
         return 
      end if
      
      
      
      select case(j2)
         case(1)
            if(j3==j1+1)then
            select case(m2)
               case(1)
                  res=sqrt((j1+m3)*(j1+m3+1d0)/((2d0*j1+1d0)*(2d0*j1+2d0)))
               case(0)
                  res=sqrt((j1-m3+1d0)*(j1+m3+1d0)/((2d0*j1+1d0)*(j1+1d0)))
               case(-1)
                  res=sqrt((j1-m3)*(j1-m3+1d0)/((2d0*j1+1d0)*(2d0*j1+2d0)))
               case default
                  STOP 'WRONG CG: J2=1 M=?'
            end select
            else if(j3==j1)then
            select case(m2)
               case(1)
                  res=-sqrt((j1+m3)*(j1-m3+1d0)/(2d0*j1*(j1+1d0)))
               case(0)
                  res=dble(m3)/sqrt(j1*(j1+1d0))
               case(-1)
                  res=sqrt((j1-m3)*(j1+m3+1d0)/(2d0*j1*(j1+1d0)))
               case default
                  STOP 'WRONG CG: J2=1 M=?'
            end select
            else if(j3==j1-1)then
            select case(m2)
               case(1)
                  res=sqrt((j1-m3)*(j1-m3+1d0)/(2d0*j1*(2d0*j1+1d0)))
               case(0)
                  res=-sqrt((j1-m3)*(j1+m3)/(j1*(2d0*j1+1d0)))
               case(-1)
                  res=sqrt((j1+m3)*(j1+m3+1d0)/(2d0*j1*(2d0*j1+1)))
               case default
                  STOP 'WRONG CG: J2=1 M=?'
            end select
            end if
            return
         case(0)
            res=dble(KrDelta(j3,j1)*KrDelta(m3,m1))
            return
      end select
      
      A = (FACTN(j1+j2-j3)*FACTN(j3+j1-j2)*FACTN(j2+j3-j1))/(FACTN(j1+j2+j3+1))
      B = FACTN(j1+m1)*FACTN(j1-m1)*FACTN(j2+m2)*FACTN(j2-m2)*FACTN(j3+m3)*FACTN(j3-m3)
      
      if((A==0d0).OR.(B==0d0))then
         res=0d0
         return
      end if
      
      C = 0
      u = 0
      buf = 0
      do i = 0,100,1
         u = DBLE(i)
         C = (FACTN(j1+j2-j3-u)*FACTN(j1-m1-u)*FACTN(j2+m2-u)*FACTN(j3-j2+m1+u)*FACTN(j3-j1-m2+u))**(1)
         if(C>0.0d0) then
            buf = buf + (-1)**i/FACT(u)*C**(-1)
         else
            cycle
         end if
         
      end do
      
      res = (dble(2*j3+1)*A*B)**(0.5)*buf
   end function CG
   
   !Wigner 3j coefficient, similar to CG coefficient, more symmetric, returns double
   function W3J(j1,j2,j3,m1,m2,m3) result (res)
      integer(4) j1,j2,j3,m1,m2,m3,ind,arr(2,3),R(3,3),arrLXTBS(5)
      REAL(8) res
      logical minus
      
      if(((m1+m2+m3)/=0).OR.(TRIANGLE_RULE(j1,j2,j3).eqv..false.).OR.(abs(m1)>j1.eqv..true.).OR.(abs(m2)>j2.eqv..true.).OR.(abs(m3)>j3.eqv..true.))then
         res = 0d0
         return
      end if
      
         if(j2==1)then
            res=CG(j1,j2,j3,m1,m2,-m3)/(SQRT(2d0*j3+1d0))*(-1)**(j1-j2-m3)
            return
         else if(j1==1)then
            arr(1,1)=j1
            arr(1,2)=j2
            arr(1,3)=j3
            arr(2,1)=m1
            arr(2,2)=m2
            arr(2,3)=m3
            call ashift_W3J(arr,1,2)
            res=CG(arr(1,1),arr(1,2),arr(1,3),arr(2,1),arr(2,2),-arr(2,3))/(SQRT(2d0*j3+1d0))*(-1)**(j1-j2-m3)
         else if(j3==1)then
            arr(1,1)=j1
            arr(1,2)=j2
            arr(1,3)=j3
            arr(2,1)=m1
            arr(2,2)=m2
            arr(2,3)=m3
            call ashift_W3J(arr,3,2)
            res=CG(arr(1,1),arr(1,2),arr(1,3),arr(2,1),arr(2,2),-arr(2,3))/(SQRT(2d0*j3+1d0))*(-1)**(j1-j2-m3)
         end if
         
      if(W3JFlag.eqv..true.) then
         minus=.false.
         arr(1,1)=j1
         arr(1,2)=j2
         arr(1,3)=j3
         arr(2,1)=m1
         arr(2,2)=m2
         arr(2,3)=m3
         call reorder_W3J(arr)
         R=calc_R(arr)
         call LXTBS_b(R,minus,arrLXTBS)
         ind = calc_c(arrLXTBS)
         res = W3Js(ind)
         if((minus.eqv..true.).AND.(MODULO(arr(1,1)+arr(1,2)+arr(1,3),2)/=0)) then
            res=-res
         end if
         return
      end if
      
      ! j1r=dble(j1)
      ! j2r=dble(j2)
      ! j3r=dble(j3)
      ! m1r=dble(m1)
      ! m2r=dble(m2)
      ! m3r=dble(m3)
      res = CG(j1,j2,j3,m1,m2,-m3)/(SQRT(2d0*j3+1d0))*(-1)**(j1-j2-m3)
   end function W3J

   !FACT(n) function checked for zero, returns double
   function FACTN(n) result (res)
      INTEGER(4) :: n
      real(8) :: res
      res = 0d0
      if(n>=0) then
         res = FACT(n)
      end if
   
   end function FACTN

   !Factorial of double type value, returns double
   function FACT(n) result (res)
      real(8) :: res
      integer(4) :: i,n
      
      if((n==0).OR.(n==1))then
         res = 1d0
         return
      end if
      
      if(factFlag.eqv..true.) then
         res = factorials(int(n,kind=4))
         return
      end if
      
      res = 1d0
      
      if(n<0) then
         STOP 1
      end if
      if(n<=1.0d0) then
         res = 1d0
         return
         write (*,*) 'lol2'
      end if
      
      do i= 1,n,1
         res = res*i
      end do
            
   end function FACT
end module wigner

module spectra
   use constants
   implicit none
   !molecular and measurement parameters
   real(8) :: temp_,mass_,fmin_,fmax_,resol_,calwidth_,pressMes_,pressCal_,tempCal_,molDens_
   
   private temp_,mass_,fmin_,fmax_,resol_,calwidth_,pressMes_,pressCal_,tempCal_,molDens_
   
 
CONTAINS
 
   
   !Shamelessly borrowed cause i'm too dumb too write qsort
   !https://gist.github.com/t-nissie/479f0f16966925fa29ea
   recursive subroutine quicksort(a, first, last,order)
      real(8)  a(*), x, t
      integer(4) first, last, order(*),tt
      integer(4) i, j

      x = a( (first+last) / 2 )
      i = first
      j = last
      do
         do while (a(i) < x)
           i=i+1
         end do
         do while (x < a(j))
           j=j-1
         end do
         if (i >= j) exit
         t = a(i);  a(i) = a(j);  a(j) = t
         tt=order(i); order(i)=order(j); order(j)=tt
         i=i+1
         j=j-1
      end do
      if (first < i-1) call quicksort(a, first, i-1,order)
      if (j+1 < last)  call quicksort(a, j+1, last,order)
   end subroutine quicksort   
   
   pure function Pressure2MolDens(press,temp)result(res)
      real(8),intent(in) :: press,temp
      real(8) res
      res=press*Na/(Rgas*temp)
   end function Pressure2MolDens
   
   pure function CONST2MOM(A) result(res)
      real(8),intent(in) :: A
      real(8) res
      res=h/(8*pi**2*cc*A)
   end function CONST2MOM
   
   !Expected to start from J=0, the higher end J, the better "accuracy"
   !ens in Hz
   pure function ExactPARTFUN(ens,n,temp,sym,endJ) result(res)
      integer(4),intent(in) :: n,sym,endJ
      real(8),intent(in) :: ens(n),temp
      real(8) res,buf
      integer(4) i,j,k,car
      
      res=0d0
      car=0
      do j=0,endJ
         buf=0d0
         do k = -j,j
            car=car+1
            buf=buf+dble(2*J+1)*exp(-h*ens(car)/(kb*temp))
         end do
         res=res+buf!*dble(2*j+1)
      end do
      res=res/sym
   end function ExactPARTFUN
   
   !Approximate partition function from rotational constants
   !A,B,C in Hz
   pure function PARTFUN(A,B,C,temp,symnum) result(res)
      integer(4),intent(in) :: symnum 
      real(8),intent(in) :: a,b,c,temp
      real(8) res,radconst
      !res=(8d0*pi**2*kb*temp/h**2)**(1.5d0)*(pi*CONST2MOM(A)*CONST2MOM(B)*CONST2MOM(C))**(0.5d0)
      !res=5.34d6/dble(symnum)*sqrt(temp**3/(A*B*C)*(1d3**3))
      parameter(radconst=h*cc/kb)
      res=sqrt(pi*temp**3/((A*B*C*1d9**3*Hz_2_cm**3*1d6)*radconst**3))
   end function PARTFUN
    
   !state population in percent
   !nu in Hz
   elemental function Calc_Prob(nu,J,Q,temp) result(res)
      integer(4),intent(in) :: J
      real(8),intent(in) :: nu,Q,temp
      real(8) res
      res=dble(2*J+1)*exp(-(h*nu)/(kb*temp))/Q
   end function Calc_Prob
    
   !Calculates percentual populations of given J,Tau energy states, Ms are degenerate
   !The sum of these is expected to give unity if accurate partition function is used
   !freqs in Hz
   function Calc_Frac_Populations(freqs,Js,N,Q,temp) result(res)
      integer(4),intent(in) :: N,Js(N)
      real(8),intent(in) :: freqs(N),Q,temp
      real(8) :: res(N),rbuf
      integer(4) i
      
      ! do i=1,N
         ! res(i)=Calc_Prob(freqs(i),Js(i),Q,temp)
      ! end do
      res=Calc_Prob(freqs,Js,Q,temp) !is this undefined behaviour I wonder, ie. passing 2 concurrent arrays to an elemental function
      
      !rbuf=sum(res)
      !rbuf=MAXVAL(res)
      !res=res!/rbuf
   end function Calc_Frac_Populations
   
   !get index of given J,T state in the state population array (given state pop. = (exp(-h*nu/(kb*t)))/(partition function))
   !J T idx
   !0 0   1
   !1-1   2
   !1 1   4
   !...
   function Calc_Frac_index(J,T)result(idx)
      integer(4) :: J,T,idx
      idx=j**2+j+t+1
   end function Calc_Frac_index
   
   
   
   !find the smallest difference in energy transitions
   function Find_Smallest_Gap(trans_ens,num) result(gap)
      integer(4) num,i,j
      real(8) trans_ens(num),gap,buf
   
      gap=1d50
      do i = 1,num
         if(trans_ens(i)<0d0)STOP 'Transition frequency cannot be negative'
      end do
      
      do i = 1,num-1
         do j = i+1,num
            buf=abs(trans_ens(i)-trans_ens(j))
            if(buf<gap)then
               gap=buf
            end if
         end do
      end do
   end function Find_Smallest_Gap
   
   !are doubles equal?
   function D_EQ(num1,num2,tol)result(res)
      real(8) num1,num2,tol
      logical res
      
      if(dabs(num1-num2)<=tol)then
         res = .true.
      else
         res = .false.
      end if
   end function D_EQ
   
   !gets the indices where overlap of intervals x1,x2 starts
   subroutine Intervals_Overlap_Start(x1,n,endIdx1,x2,m,endIdx2,idx1,idx2,tol)
      integer(4),intent(in) :: n,m,endIdx1,endIdx2
      real(8),intent(in) :: x1(n),x2(m),tol
      integer(4),intent(out) :: idx1,idx2
      integer(4) i,j,k
      do i = 1,endIdx1
         do j = 1,endIdx2
            if(D_EQ(x1(i),x2(j),tol))then
               idx1=i
               idx2=j
               return
            end if
         end do
      end do
   end subroutine Intervals_Overlap_Start
   
   !gets the indices where overlap of intervals x1,x2 ends
   subroutine Intervals_Overlap_End(x1,n,endIdx1,x2,m,endIdx2,idx1,idx2,tol)
      integer(4),intent(in) :: n,m,endIdx1,endIdx2
      real(8),intent(in) :: x1(n),x2(m),tol
      integer(4),intent(out) :: idx1,idx2
      integer(4) i,j,k
      do i = endIdx1,1,-1
         do j = endIdx2,1,-1
            if(D_EQ(x1(i),x2(j),tol))then
               idx1=i
               idx2=j
               return
            end if
         end do
      end do
   end subroutine Intervals_Overlap_End
   
   !gets where overlap of two bands starts and ends for both bands
   function Intervals_Overlap_Size(x1,n,endIdx1,x2,m,endIdx2,tol) result(res)
      integer(4),intent(in) :: n,m,endIdx1,endIdx2
      real(8),intent(in) :: x1(n),x2(m),tol
      integer(4) res
      integer(4) ovs1,ovs2,ove1,ove2
      
      call Intervals_Overlap_Start(x1,n,endIdx1,x2,m,endIdx2,ovs1,ovs2,tol)
      call Intervals_Overlap_End(x1,n,endIdx1,x2,m,endIdx1,ove1,ove2,tol)
      
      if((ovs2==1).AND.(ove2==endIdx2).AND.(endIdx1>endIdx2))then
         res=endIdx1
         return
      else if((ovs1==1).and.(ove1==endIdx1).AND.(endIdx1<endIdx2))then
         res=endIdx2
         return
      end if
      
      
      if((x1(1)>x2(1)).AND.(x1(endIdx1)>x2(endIdx2)))then
         res=ovs2+(ove2-ovs2)+(endIdx1-ove1)
      else if((x1(1)<x2(1)).AND.(x1(endIdx1)<x2(endIdx2)))then
         res=ovs1+(ove1-ovs1)+(endIdx2-ove2)
      else if((x1(1)>x2(1)).AND.(x1(endIdx1)<x2(endIdx2)))then
         res=endIdx2
      else if((x1(1)<x2(1)).AND.(x1(endIdx1)>x2(endIdx2)))then
         res=endidx1
      else if((D_EQ(x1(1),x2(1),tol)).AND.(D_EQ(x1(endIdx1),x2(endIdx2),tol)))then
         res=endidx1
      else
         STOP 'iz wronk overlap size'
      end if
   end function Intervals_Overlap_Size
   
   !assumes ordered values
   !checks if two bands overlap
   function Intervals_Overlap(x1,n,endIdx1,x2,m,endIdx2)result(res)
      integer(4) n,m,endIdx1,endIdx2
      real(8) x1(n),x2(m)
      logical res
      
      res=.false.
      if((x1(1)<=x2(endIdx2)).and.(x1(1)>=x2(1)))then 
         res=.true.
      else if((x2(endIdx2)>=x1(1)).and.(x2(endIdx2)<=x1(endIdx1)))then
         res=.true.
      else if((x1(endIdx1)>=x2(1)).and.(x1(endIdx1)<=x2(endIdx2)))then
         res=.true.
      else if((x2(1)<=x1(endIdx1)).and.(x2(1)>=x1(1)))then
         res=.true.
      end if
   end function Intervals_Overlap
   
   !nu - absorbing frequency in Hz (or GHz, MHz, KHz...)
   !temp - temperature in Kelvin
   !mass - mass of a single molecule in kg
   !result - Doppler width in units of nu
   function Doppler_Width(nu,temp,mass) result(res)
      real(8) nu,temp,mass,res
      res=2d0*sqrt(2*kb*temp/(mass))*nu/cc/2.3548d0
   end function Doppler_Width
   
   
   !Pressure broadening, argument breadth at 1mm Hg and 300K, press in mm Hg, temp in K 
   function Pressure_width(breadth,t1,p1,t2,p2) result(res)
      real(8),intent(in) :: breadth,t1,p1,t2,p2
      real(8) res
      res = t1*p2*breadth/(p1*t2)
   end function Pressure_width
   
   
   !returns a 2d array of logicals whether given bands overlap, diagonals are a band with itself, (2,1)==(1,2)
   function Find_band_overlaps(x,n,endIdx,siz,tol)result(res)
      integer(4) n,siz,endIdx(n)
      real(8) x(n,siz),tol
      logical res(n,n)
      integer(4) i,j
      
      res=.false.
      do i = 1,n
         do j = 1,n
            if(i==j)then
               res(i,j)=.true.
               cycle
            end if
            res(i,j) = Intervals_Overlap(x(i,1:endIdx(i)),size(x(i,1:endIdx(i)),dim=1),endIdx(i),x(j,1:endidx(j)),size(x(j,1:endIdx(j)),dim=1),endIdx(j))
         end do
      end do
   end function find_band_overlaps
   
   !overlaps two bands x1,y1 and x2,y2 into x3,y3
   !endIdxs are the ending indices of arrays which have to be larger than the amount of information in them (workaround cause no Lists)
   !resol is the distance at which two points should overlap,
   !
   !Author's notes:
   !uses simple Lambert-Beer law, ie. only adds two y points
   !it works but there is a great loss of accuracy the more it is used, you would need to supply it the exact same points in every x array
   !the initial idea was to save HDD space while preserving super narrow bands in a SINGLE file for a SUPER WIDE spectrum
   subroutine Band_overlap(x1,y1,n,endIdx1,x2,y2,m,endIdx2,x3,y3,r,startIdx3,resol,info)
      integer(4), intent(in) :: endIdx1,endIdx2,startIdx3,n,m,r
      real(8), intent(in) :: x1(n),y1(n),x2(m),y2(m),resol
      real(8), intent(out) :: x3(r),y3(r)
      logical, intent(out) :: info
      real(8) :: curRes
      integer(4) i,j,idx,ovs1,ovs2,ove1,ove2
           
           
      if(x1(endIdx1)==0)then
         stop 'x1 zero'
      end if
      if(x2(endidx2)==0)then
         stop 'x2 zero'
      end if
              
              
      !check for not overlapping bands
      if(Intervals_Overlap(x1,n,endIdx1,x2,m,endIdx2).eqv..false.)then
         j=startIdx3-1
         if(x1(1)<x2(1))then
            do i = 1,endIdx1
               j=j+1
               x3(j)=x1(i)
               y3(j)=y1(i)
            end do
            
            do i = 1,endIdx2
               j=j+1
               x3(j)=x2(i)
               y3(j)=y2(i)
            end do
         else if(x2(1)<x1(1))then
            do i = 1,endIdx2
               j=j+1
               x3(j)=x2(i)
               y3(j)=y2(i)
            end do
            
            do i = 1,endIdx1
               j=j+1
               x3(j)=x1(i)
               y3(j)=y1(i)
            end do
         end if
         do i = 1,j-1
            if(x3(i)>x3(i+1))then
            stop 'wrong overlap 1'
            end if
         end do
         info=.false.
         return
      end if
      
      call Intervals_Overlap_Start(x1,n,endIdx1,x2,m,endIdx2,ovs1,ovs2,resol)
      call Intervals_Overlap_End(x1,n,endIdx1,x2,m,endIdx2,ove1,ove2,resol)
           
      if((ovs1==1).AND.(ovs2==1).AND.(ove2==endidx2).AND.(ove1==endidx1))then
         if(endidx1>endidx2)then
            do i = 1,endidx2
               x3(i)=(x2(i)+x1(i))/2d0
               y3(i)=y2(i)+y1(i)
            end do
            curRes=x3(i-1)-x3(i-2)
            do j = i,endidx1
               x3(j)=x3(j-1)+curRes
               y3(j)=y1(j)
            end do
         else if(endIdx1==endIdx2) then
            do i = 1,endidx2
               x3(i)=(x2(i)+x1(i))/2d0
               y3(i)=y2(i)+y1(i)
            end do
            j=endidx1+1
         else if(endIdx2>endIdx1) then
            do i = 1,endidx1
               x3(i)=(x2(i)+x1(i))/2d0
               y3(i)=y2(i)+y1(i)
            end do
            curRes=x3(i-1)-x3(i-2)
            do j = i,endidx2
               x3(j)=x3(j-1)+curRes
               y3(j)=y2(j)
            end do
         end if
         do i = 1,j-2
            if(x3(i)>x3(i+1))then
            stop 'wrong overlap 5'
            end if
         end do
         return
      end if
           
           
      !x2 is inside x1
      if((ovs2==1).AND.(ove2==endIdx2).AND.(x1(1)<x2(1)).AND.(x1(endIdx1)>x2(endIdx2)))then
         idx=startIdx3
         do i = 1,ovs1-1
            x3(idx)=x1(i)
            y3(idx)=y1(i)
            idx=idx+1
         end do
         j = ovs1
         do i = ovs2,ove2
            x3(idx)=(x2(i)+x1(j))/2d0
            y3(idx)=y2(i)+y1(j)
            idx=idx+1
            j=j+1
         end do
         do i = ove1+1,endIdx1
            x3(idx)=x1(i)
            y3(idx)=y1(i)
            idx=idx+1
         end do
         do i = 1,idx-2
            if(x3(i)>x3(i+1))then
            stop 'wrong overlap 2'
            end if
         end do
         return
      !x1 is inside x2
      else if((ovs1==1).and.(ove1==endIdx1).AND.(x1(1)>x2(1)).AND.(x2(endIdx2)>x1(endIdx1)))then
         idx=startIdx3
         do i = 1,ovs2-1
            x3(idx)=x2(i)
            y3(idx)=y2(i)
            idx=idx+1
         end do
         j = ovs2
         do i = ovs1,ove1
            x3(idx)=(x1(i)+x2(j))/2d0
            y3(idx)=y1(i)+y2(j)
            idx=idx+1
            j=j+1
         end do
         do i = ove2+1,endIdx2
            x3(idx)=x2(i)
            y3(idx)=y2(i)
            idx=idx+1
         end do
         do i = 1,idx-2
            if(x3(i)>x3(i+1))then
            stop 'wrong overlap 3'
            end if
         end do
         return
      end if
      
      
      if((x1(1)<x2(1)).AND.(x1(endidx1)<x2(endidx2)))then
         idx=startIdx3
         do i = 1,ovs1-1
            x3(idx)=x1(i)
            y3(idx)=y1(i)
            idx=idx+1
         end do
         j = ovs2
         do i = ovs1,ove1
            if(j>endidx2)then
               x3(idx)=x1(i)
               y3(idx)=y1(i)
               exit
            end if
            x3(idx)=(x1(i)+x2(j))/2d0
            y3(idx)=y1(i)+y2(j)
            idx=idx+1
            j=j+1
         end do
         do i = ove2+1,endIdx2
            x3(idx)=x2(i)
            y3(idx)=y2(i)
            idx=idx+1
         end do
         
      else if((x1(1)>x2(1)).AND.(x1(endidx1)>x2(endidx2)))then
         idx=startIdx3
         do i = 1,ovs2-1
            x3(idx)=x2(i)
            y3(idx)=y2(i)
            idx=idx+1
         end do
         j = ovs1
         do i = ovs2,ove2
            if(j>endidx1)then
               x3(idx)=x2(i)
               y3(idx)=y2(i)
               exit
            end if

            x3(idx)=(x2(i)+x1(j))/2d0
            y3(idx)=y2(i)+y1(j)
            idx=idx+1
            j=j+1
         end do
         do i = ove1+1,endIdx1
            x3(idx)=x1(i)
            y3(idx)=y1(i)
            idx=idx+1
         end do
      end if
      !check for errors
      do i = 1,idx-2
         if(x3(i)>x3(i+1))then
         stop 'wrong overlap 4'
         end if
      end do
      info=.true.
   end subroutine Band_overlap
   
   recursive subroutine Make_Band_Overlaps(x_col,y_col,endIdxs,n,colSize,tole,xout,yout,m)
      integer(4) n,colSize,counter,endIdxs(colSize),curIndex,m,i,j
      real(8),allocatable :: x_col(:,:),y_col(:,:)
      real(8),allocatable :: x_col2(:,:),y_col2(:,:)
      real(8) :: xout(m),yout(m),tole
      integer(4),allocatable :: endIdxs2(:)
      logical infor
      
      curIndex=1
      counter=colsize/2+mod(colSize,2)
      allocate(x_col2(counter,n),y_col2(counter,n),endIdxs2(counter))
      do i = 1,colSize,2
         if((i+1)>colSize)then
            exit
         end if
         if(Intervals_overlap(x_col(i,:),n,endIdxs(i),x_col(i+1,:),n,endIdxs(i+1)).eqv..false.)then
         endIdxs2(curIndex) = endIdxs(i)+endIdxs(i+1)
         else
         endIdxs2(curIndex) = Intervals_Overlap_Size(x_col(i,:),n,endIdxs(i),x_col(i+1,:),n,endIdxs(i+1),tole)
         end if
         call Band_overlap(x_col(i,:),y_col(i,:),n,endIdxs(i),x_col(i+1,:),y_col(i+1,:),n,endIdxs(i+1),x_col2(curIndex,:),y_col2(curIndex,:),n,1,tole,infor)
         do while(x_col2(curIndex,endIdxs2(curIndex))==0d0)
            if(x_col2(curIndex,endIdxs2(curIndex))==0)then
               endIdxs2(curIndex)=endIdxs2(curIndex)-1
            end if
         end do
         do j = 1,endIdxs2(curIndex)-1
            if(x_col2(curIndex,j)>x_col2(curIndex,j+1))then
               stop 'wake me up inside' 
            end if
         end do
         !bufI=Intervals_Overlap_Size(x_col(i,:),,x_col(i+1,:))
         curIndex=curIndex+1
      end do
      if(mod(colSize,2)/=0)then
         x_col2(curIndex,:)=x_col(colSize,:)
         y_col2(curIndex,:)=y_col(colSize,:)
         endIdxs2(curIndex)=endIdxs(colSize)
      end if
      deallocate(x_col,y_col)
      if(counter==1)then
         xout=x_col2(1,1:endIdxs(1))
         yout=y_col2(1,1:endIdxs(1))
         return
      end if
      call Make_Band_Overlaps(x_col2,y_col2,endIdxs2,n,counter,tole,xout,yout,m)
   end subroutine Make_Band_Overlaps
   
   
   function CutFilter_Darr(arr,n,m) result(res)
      integer(4) n,m,i,j
      real(8) arr(n),res(m)
      
      if(n==m)then
         res = arr
         return
      end if
      
      !always watchout for unassigned memory, kids
      ! if((FINDLOC(isNan(res),.true.,1))>1)then
         ! !allocate(bufarr(cou))
         ! stop (FINDLOC(isNan(arr),.true.,1))
      ! end if
      
      res=0d0
      j=1
      do i = 1,n
         if(arr(i)/=0d0)then
            res(j)=arr(i)
            j = j+1
         end if
      end do
      j=j+1
   end function CutFilter_Darr
   
   function CutFilter_Iarr(arr,n,m) result(res)
      integer(4) n,m,i,j,arr(n),res(m)
      
      j=1
      do i = 1,n
         if(arr(i)/=0)then
            res(j)=arr(i)
            j = j+1
         end if
      end do
   end function CutFilter_Iarr
   
   !SoS
   !https://rosettacode.org/wiki/Sorting_algorithms/Insertion_sort#Fortran
   subroutine Insertion_sort(a,n,comp)
      implicit none
      integer(4) :: n, i, j,comp(n)
      real(8) :: a(n), x,y
    
      do i = 1,n
         comp(i)=i
      end do
      
      do i = 2, n
         x = a(i)
         y = comp(i)
         j = i - 1
         do while (j >= 1)
            if (a(j) <= x) exit
            a(j + 1) = a(j)
            comp(j+1)=comp(j)
            j = j - 1
         end do
         a(j + 1) = x
         comp(j+1)=y
      end do
      
   end subroutine Insertion_sort 
   
   subroutine Insertion_sort_WORK(a,n,endIdx,comp)
      implicit none
      integer(4) :: n, i, j,comp(n),endIdx
      real(8) :: a(n), x,y
    
      do i = 1,endIdx
         comp(i)=i
      end do
      
      do i = 2,endIdx
         x = a(i)
         y = comp(i)
         j = i - 1
         do while (j >= 1)
            if (a(j) <= x) exit
            a(j + 1) = a(j)
            comp(j+1)=comp(j)
            j = j - 1
         end do
         a(j + 1) = x
         comp(j+1)=y
      end do
      
   end subroutine Insertion_sort_WORK
   
   subroutine Insertion_sort_abs(a,n,comp)
      implicit none
      integer(4) :: n, i, j,comp(n)
      real(8) :: a(n), x,y
    
      do i = 1,n
         comp(i)=i
      end do
      
      do i = 2, n
         x = a(i)
         y = comp(i)
         j = i - 1
         do while (j >= 1)
            if (dabs(a(j)) <= dabs(x)) exit
            a(j + 1) = a(j)
            comp(j+1)=comp(j)
            j = j - 1
         end do
         a(j + 1) = x
         comp(j+1)=y
      end do
      
   end subroutine Insertion_sort_abs
   
   subroutine Insertion_sort_xcol(xcol,colSize,m,comp)
      implicit none
      integer(4) :: ColSize, i, j,comp(ColSize),m
      real(8) :: xcol(colSize,m),a(ColSize), x,y
    
      do i = 1,ColSize
         comp(i)=i
      end do
      a = xcol(:,1)
      do i = 2, ColSize
         x = a(i)
         y = comp(i)
         j = i - 1
         do while (j >= 1)
            if (a(j) <= x) exit
            a(j + 1) = a(j)
            comp(j+1)=comp(j)
            j = j - 1
         end do
         a(j + 1) = x
         comp(j+1)=y
      end do
      call Reorder_arr_col(xcol,colSize,m,comp)
   end subroutine Insertion_sort_xcol
   
   subroutine Reverse_arr(arr,n)
      integer(4) n,i
      real(8) arr(n),buf
      
      if(MODULO(n,2)==0)then
         do i = 1,n/2
            buf=arr(i)
            arr(i)=arr(n-i+1)
            arr(n-i+1)=buf
         end do
      else
         do i = 1,(n-1)/2
            buf=arr(i)
            arr(i)=arr(n-i+1)
            arr(n-i+1)=buf
         end do
      end if
   end subroutine Reverse_arr
   
   subroutine Reverse_arr_int(arr,n)
      integer(4) n,i
      integer(4) arr(n),buf
      
      if(MODULO(n,2)==0)then
         do i = 1,n/2
            buf=arr(i)
            arr(i)=arr(n-i+1)
            arr(n-i+1)=buf
         end do
      else
         do i = 1,(n-1)/2
            buf=arr(i)
            arr(i)=arr(n-i+1)
            arr(n-i+1)=buf
         end do
      end if
   end subroutine Reverse_arr_int
   
   !for trans_arr
   subroutine Reverse_arr_int_4(arr,n)
      integer(4) n,i
      integer(4) arr(n,4),buf(4)
      
      if(MODULO(n,2)==0)then
         do i = 1,n/2
            buf=arr(i,:)
            arr(i,:)=arr(n-i+1,:)
            arr(n-i+1,:)=buf
         end do
      else
         do i = 1,(n-1)/2
            buf=arr(i,:)
            arr(i,:)=arr(n-i+1,:)
            arr(n-i+1,:)=buf
         end do
      end if
   end subroutine Reverse_arr_int_4
   
   subroutine Reorder_arr(arr,n,order)
      integer(4) n,order(n),i
      real(8) arr(n),buf(n)
      
      buf=arr
      do i = 1,n
         arr(i)=buf(order(i))
      end do
   end subroutine Reorder_arr
   
   subroutine Reorder_arr_col(arr,colSize,n,order)
      integer(4) ColSize,n,order(colSize),i
      real(8) arr(colSize,n),buf(colSize,n)
      
      buf=arr
      do i = 1,colSize
         arr(i,:)=buf(order(i),:)
      end do
   end subroutine Reorder_arr_col
   
   subroutine Reorder_arr_WORK(arr,n,endIdx,order)
      integer(4) n,order(n),i,endIdx
      real(8) arr(n),buf(n)
      
      buf=arr
      do i = 1,endIdx
         arr(i)=buf(order(i))
      end do
   end subroutine Reorder_arr_WORK
   
   subroutine Reorder_arr_int(arr,n,order)
      integer(4) n,order(n),i,arr(n),buf(n)
      
      buf=arr
      do i = 1,n
         arr(i)=buf(order(i))
      end do
   end subroutine Reorder_arr_int
   
   !for trans_arr
   subroutine Reorder_arr_int_4(arr,n,order)
      integer(4) n,order(n),i,arr(n,4),buf(n,4)
      
      buf=arr
      do i = 1,n
         arr(i,:)=buf(order(i),:)
      end do
   end subroutine Reorder_arr_int_4
   
   !dip_str - <jkm|mu|j'k'm'>^2 = Dab, in Debye^2
   !nu - MHz
   function Abs_coeff(nu,N1,g1,N2,g2,dip_str,constantJPL,MW,absem) result(res)
      real(8) nu,N1,N2,dip_str
      integer(4) g1,g2
      real(8) res,bufr
      logical constantJPL,MW,absem(2)
      
      if(.not.absem(1) .and. N1/dble(g1)>N2/dble(g2))then
         res = 0d0
         return
      else if(.not.absem(2) .and. N1/dble(g1)<N2/dble(g2))then
         res = 0d0
         return
      end if
      
      !what
      if(MW)then
         bufr=4.16231d-5
      else
         bufr=4d0*4.16231d-5
      end if
      if(.not.constantJPL)then
         bufr=bufr/(cc*1d10)
      end if
      res=bufr*nu*1d3*dabs(N1/dble(g1)-N2/dble(g2))*dip_str
   end function Abs_coeff

   function Abs_coeff_MW(omega,N1,g1,N2,g2,dip_str,constant) result(res)
      real(8) omega,N1,N2,dip_str
      integer(4) g1,g2
      real(8) res,bufr
      logical constant
      
      if(constant.eqv..true.)then
         bufr=8d0*pi**3/(3d0*h*cc)
      else
         bufr=1d0
      end if
      res=bufr*omega*abs(N1/dble(g1)-N2/dble(g2))*dip_str
   end function Abs_coeff_MW
      
   function Reduce_IArr(arr,n,endidx,valu) result(res)
      integer(4) endidx,n,j,i,arr(n),res(endidx),valu
      
      j=1
      do i = 1,n
         if(arr(i)/=valu)then
            res(j)=arr(i)
            j=j+1
         end if
      end do
   end function Reduce_IArr
      
   function Reduce_filter_DArr_col(arr_col,n,colsize,filter,filteredSize) result(rescol)
      integer(4) i,j,n,colSize,filter(colSize),filteredSize
      real(8) arr_col(colSize,n),rescol(filteredSize,n)
      
      j=1
      do i = 1,colsize
         if(filter(i)/=0)then
            rescol(j,:)=arr_col(i,:)
            j=j+1
         end if
      end do
   end function Reduce_filter_DArr_col
   
   !Polavarapu 2017
   function Width2FWHM_Gauss(sigma) result(W)
      real(8) sigma,W
      W=2d0*sigma*sqrt(2d0*log(2d0))
   end function Width2FWHM_Gauss
   
   function FWHM2Width_Gauss(W) result(sigma)
      real(8) sigma,W
      sigma=W/2d0/sqrt(2d0*log(2d0))
   end function FWHM2Width_Gauss
   
   pure function Intensity_Gauss(area,W)result(y0)
      real(8),intent(in) :: area,W
      real(8) y0
      y0=area/(W*sqrt(2d0*pi))
   end function Intensity_Gauss
   
   pure function Intensity_Lorentz(area,W)result(y0)
      real(8),intent(in) :: area,W
      real(8) y0
      y0=area/(W*pi)
   end function Intensity_Lorentz
   
   pure function Intensity_Voigt(area,W)result(y0)
      real(8),intent(in) :: area,W
      real(8) y0
      y0=area/(W*pi)
   end function Intensity_Voigt
   
   !W = width (written as sigma, is not FWHM or HWHM or any other)
   !y0 = height
   !x0 = location of maximum
   elemental function Profile_Gauss(x,x0,W,y0) result(y)
      real(8),intent(in) :: x,x0,W,y0
      real(8) y
      y=1d0/(W*sqrt(2d0*pi))*exp(-0.5*((x-x0)/W)**2)
   end function Profile_Gauss
   
   elemental function Profile_Lorentz(x,x0,W,y0) result(y)
      real(8),intent(in) :: x,x0,W,y0
      real(8) y
      y=1d0/(W*pi)*((W**2)/((x-x0)**2+W**2))
   end function Profile_Lorentz
   
   pure function Profile_Voigt_Wrap(x,x0,AL,AD) result(res)
      real(8),intent(in) :: x,x0,AL,AD
      real(8) res
      res = Profile_Voigt(x,x0,AL,AD,-10000,1d0,10000)
   end function Profile_Voigt_Wrap
   
   pure function Profile_Voigt(nu,nu0,AL,AD,start,step,endd) result(res)
      real(8),intent(in) :: nu,nu0,AL,AD,step
      integer(4),intent(in) :: start,endd
      real(8) x,y,u,res,first,second,uSecond
      integer(4) i
      x = sqrt(log(2d0))*(nu-nu0)/AD
      y = sqrt(log(2d0))*AL/AD
      res=0d0
      
      !numerical integration
      do i = start,endd
         u=start+step*(i-start)
         uSecond=u+step
         first=exp(-u**2)/(y**2+(x-u)**2)
         second=exp(-uSecond**2)/(y**2+(x-uSecond)**2)
         res=res+(first+second)/2*step
      end do
      res=res*y/pi
   end function Profile_Voigt
   
end module spectra

program main
   use input
   use wigner
   use constants
   use rotor
   use spectra
   use omp_lib_kinds
   use omp_lib
   
   
   implicit none
   
   !include "omp_lib.h"
   !===================================================
   !array(countX,countY...)
   !
   !SPH_dip(3) - spherical tensor dipole moment
   !SPH_g(3,3) - mixed spherical tensor g-factor !TODO check validity
   !SPH_quad1(3) - spherical tensor of rank 1 quadrupole moment
   !SPH_quad2(5) - spherical tensor of rank 2 quadrupole moment
   !
   !fmin - start of the spectrum, cannot be negative
   !fmax - end of the spectrum
   !resolution - constant distance between adjacent x-values of the spectrum
   !
   !ezero -
   !press - pressure
   !temp - temperature
   !MolDens - molecular density in molecules/m^3, calculated from pressure and temperature
   !Q - rotational partition function
   !
   !startJ,endJ - Duh!
   !cou - number of possible transitions in the range(startJ,endJ,1)
   !dime_full - number of different J,Tau energy states
   !trans_arr(cou,4) - Saves the lower and upper states of transitions
   !ROT_STRS(cou) - array of rotational strengths for transitions
   !DIP_STRS(cou) - array of dipole strengths for transitions
   !TRANS_PROBS(cou) - array of CD transition probabilities !TODO
   !trans_en_arr(cou) - array of transition energies, normally in GHz
   !trans_abs(cou) - array of MW absorption coefficients, dependent on energy state populations
   !trans_probs_MW(cou) - array of MW absorption probabilities, independent of energy state populations
   !Fracpop(dime_full) - percentual populations of energy states, their sum should add up to one if exact partition function is used
   !===================================================
   
   
   COMPLEX(8) SPH_dip(3),SPH_g(3,3),SPH_quad1(3),SPH_quad2(5)
   REAL(8) gt_own(3,3),Ra,fmin,fmax,resolution,k,ezero,tol,time1,time2,rbuf,press,temp,MolDens,Q,calwidth,calpress,caltemp,baseline,outTol,buf(10),intensity_cutoff
   real(8), allocatable :: ROT_STRS(:), DIP_STRS(:),TRANS_PROBS(:),trans_en_arr(:),trans_abs(:),trans_probs_MW(:),trans_Fracpop(:),Fracpop(:),trans_en_arr_JPL(:)
   real(8), allocatable :: inten_JPL(:)
   INTEGER(4) i,ii,jj,dime,info,rep,dime_full,m,idx
   INTEGER(4) startJ,endJ,unitt,car,cou,spectraWorkArraySize,W3JArraySize,j1,bufi,bufI2(3),repaxesInt(3)
   integer(4), allocatable :: trans_arr(:,:),Js(:),trans_arr_JPL(:,:)
   
   character(80) outputfile,JPLFile,parfile
   character(80) inputfile,inputfileDalton
   integer(4) inputLength,outputlength,tempcharlen,tempcharlenchar,sta,pwidthh,tempp
   character(3)  profileFunction
   character(1)  leftright,repaxes(3)
   character(3)  OutUnitsStr,OutUnitsEn
   character(10) tempChar,pwidthchar
   
   real(8) pwidth
   
   
   !I guess they're not Flags per se but who cares, they're prettier to look at
   logical :: testFlag,w3jflaguse,quadflag,FFPEFLAG,dopflag,presflag,approxPartFFlag,HumanReadableFlag,detailOutputFlag,detailOutputFlagM,FastFlag,excelCompatible
   logical :: GIAOTensor,useSphericalG,dircoseFlag,ShafferFlag,lefthandedFlag,SphericalStrengthsFlag,SimpleSpectrumFlag,GTOWN_flag,SkipTransFlag, GaussianGTensorFlag
   logical :: PreviousCalcFlag,MWFlag,ownPartFunFlag,WriteMomentsFlag,expFlag,spectra_cutoff,switchUpAxes,dipstr_cutoff_percentual
   
   real(8) dipstr_cutoff,rotstr_cutoff,kuhnpar_cutoff
   
   !tolerance for double equality comparison (usually equality to zero)
   parameter(tol=1D-14)
   parameter(outTol=1d-17)
   !the Hamiltonian is stored in its block diagonal form, wasting a lot of space on RAM with zeroes
   REAL(8), allocatable :: Ham_full(:,:),Evec_full(:,:)
   REAL(8), allocatable :: eval_full(:)
   REAL(8), allocatable :: Evec(:,:),Eval(:),Ham(:,:)
            
   !output and input
   logical file_molParams(10),file_transitions(10),file_lineSpectrum(10),file_spectrum(10),file_detailtab(10),file_prn(10),stuffL,flag_absem(2)
   
   
   !parameterized types do not work well for what I'm about to do
   !if u make an allocatable of a param. type, all of its arrays are now allocatable too...sigh...whyyyyyyyyy
   type :: List_2D_D
      real(8),allocatable :: arr(:,:) 
   end type
   
   type :: List_1D_D
      real(8),allocatable :: arr(:) 
   end type
   
   type(List_2D_D),allocatable :: evec_full_list(:)
   type(List_1D_D),allocatable :: eval_full_list(:)
   
2003 format(A40,1G15.7)
2002 format(A40,1F15.7)
2001 format(A40,1I10)
2469 format(A20,1F15.7,A20)

   write(6,*)'RCD program starting...'

   !initialize flags
   factFlag=.false. !dont touch >:( , not for user
   W3JFlag=.false. !dont touch >:( , not for user
   
   !allocate(evec_full_list(3))
   !allocate(evec_full_list(1)%arr(5,5))
   
   !program defaults
   !this is my spaghetti Bolognese, there are many like it but this one is mine!
   W3JDiskFlag=.false. !store W3Js on a scratch file on disk instead of RAM? TODO
   W3JFlagUse=.false. !Precalculate
   DirCoseFlag=.true. !use direction cosines instead of W3J?
   ShafferFlag=.false. !use direction cosine convention of Shaffer and Loucke, which corresponds to the convention of "spherical rotation matrix" matrix elements in this program
   testFlag=.false. !test against literals?
   quadFlag=.false. !quadrupole contribution in RCD rotational strenghths?
   DopFlag=.false.  !include Doppler broadening of bands?
   GTOWN_flag=.false. !supply own g tensor is gtensor.par
   PresFlag=.false. !include pressure broadening of bands?
   approxPartFFlag = .false. !use approximate partition function?
   lefthandedFlag=.false. !left handed asymmetric rotor representation
   FFPEFlag=.false. !write floating point exceptions?
   HumanReadableFlag=.true. !Write results to RCD.TAB in decimal point format instead of exponential?
   DetailOutputFlag=.false. !write a massive output file for every JKM => J'K'M' transition
   FastFlag=.false. !assume all dipole moment components in space are equal and use the identity
   ExcelCompatible=.false. !encapsulate line spectrum Y points with zero so it's graphable as line graph in excel
   GIAOTensor=.false. !Use Gaussians rotational GIAO tensor instead of calculated one from paramagnetic susceptibility?
   useSphericalG=.false. !use spherical g tensor instead of explicit expansion
   SphericalStrengthsFlag=.false. !no touchy!, calculates spherical dipole and rotational strengths instead of cartesian strenghths
   SimpleSpectrumFlag=.true. !no touchy
   SkipTransFlag=.false. !not implemented, only do the transitions in the (fmin–fmax) range
   GaussianGTensorFlag=.true.
   PreviousCalcFlag=.false.
   MWFlag=.false.
   ownPartFunFlag=.false.
   writeMomentsFlag=.false.
   switchUpAxes=.false.
   
   
   expFlag=.true.
   spectra_cutoff=.true.
   dipstr_cutoff_percentual=.false.
   
   startJ=0
   endJ=8
   unitt=8!output unit
   press=100!Pascal
   temp=20!Kelvin
   baseline=1d14
   fmin=190.0d0
   fmax=220.0d0
   inputfile='G.OUT'!deprecated
   outUnitsStr='DEB'!DEB or AU
   outUnitsEn='GHz'
   
   resolution=1d-3
   
   !pressure width calibration
   calpress=100 !Pascal
   caltemp=200 !kelvin
   calwidth=2d-1 !in GHz
   
   sta=1
   call ReadFlags(sta)
   if(sta==0)write(6,*)'Found RCD.par'
   
   !pwidth=Pressure_width(calwidth,caltemp,calpress,temp,press)
   sta=1
   call GET_COMMAND_ARGUMENT(1,inputfile,status=sta)
   
   sta=1
   call GET_COMMAND_ARGUMENT(2,tempchar,status=sta)
   
   !oh my gooooooooood
   if(sta==0)then
      if(index(tempChar,'.')==0)then
         read(tempChar,'(I10)')tempp
         temp=dble(tempp)
      else
         read(tempChar,'(F10.5)')temp
      end if
      write(6,*)'Setting temperature to '//trim(tempChar)//' K'
   else
      file_spectrum(1)=.false.
      file_lineSpectrum(1)=.false.
   end if
   ! tempChar=adjustL(tempChar)
   ! tempCharLen=1
   ! tempp=temp
   ! do i = 1,6
      ! tempp=tempp/1d1
      ! if(tempp>1d0)then
         ! tempCharLen=tempCharLen+1
      ! else
         ! exit
      ! end if
   ! end do
   
   sta=1
   call GET_COMMAND_ARGUMENT(3,pwidthchar,status=sta)
   if(sta==0)then
      if(index(pwidthchar,'.')==0)then
         read(pwidthchar,'(i10)')pwidthh
         pwidth=dble(pwidthh)
      else
         read(pwidthchar,'(F10.5)')pwidth
      end if
      pwidth=pwidth*1d-3
      write(6,*)'Setting Lorentzian HWHM to '//trim(pwidthchar)//' MHz'
   end if
111 format(I6)  
112 format(F6.3) 
   inputLength=0
   outputLength=0
   do i = 1,80
      if(inputfile(i:i)==' ')then
         exit
      else
         inputLength=inputLength+1
      end if
   end do
   
   
   outputfile=inputfile(index(inputfile,'/',.true.)+1:index(inputfile,'.',.true.)-1)
   outputLength=index(adjustL(outputfile),' ',.false.)-1
   
   
   call Compute_factorials() !HERE
   
   
230 format(A40)   
231 format(1F15.3,' seconds') 
  
   !call DIR_COSE_WIGNER_COMPARISON()
  
   !load values into meh-moar-i
   parfile=(outputfile(1:outputLength))//'.par'
   sta=1
   call readCustomFile(parfile,trim(inputfile(1:index(inputfile,'.',.true.)))//'par',sta)
   if(sta==0)write(6,*)'Found '//trim(parfile)
   sta=1
   call readFile(inputfile,outputfile,outputLength,inputfileDalton,file_molParams,sta)
   if(sta==0)write(6,*)'Found '//trim(inputfile)
   Ra = Ray(abc(1),abc(2),abc(3))
   if(rep<1 .or. rep>3)then
      rep = REPRESENTATION(ra)
   end if
   !switch around axes due to representation chosen
   !im not 100% sure about this, I thought THAT was implicitly in the eigenvectors already
   !oh well, would be nice if molecular spectroscopists were less cryptic and less succinct
   !Like: should I do it for direction cosines and angular momentum operators too??? Probably not...I dunno...*sigh*
   if(switchUpAxes)then
      dip=RepAxesSwitch_V(dip,rep,lefthandedFlag)
      gt=RepAxesSwitch_T(gt,rep,lefthandedFlag)
      quad=RepAxesSwitch_T(quad,rep,lefthandedFlag)
   end if
   !Easy to compute (useless) values
   MolDens=Pressure2MolDens(press,temp) !Density in molecules/m^3
   dime_full=CALCULATE_HAMDIM(startJ,endJ)!Hamiltonian dimensions
   call cart2sph_v(dip,SPH_dip)
   call cart2sph_t_v(quad,SPH_quad1)
   call cart2sph_t(quad,SPH_quad2)
   call cart2sph_t_mix(gt,SPH_g)
   
   !assymmetric rotor
   write(6,*)
   if(lefthandedFlag)then
      leftright='L'
   else
      leftright='R'
   end if
   repaxesInt = RepAxesSwitch_get(rep,lefthandedFlag)
   if(switchUpAxes)then
      do i = 1,3
         select case(repaxesInt(i))
            case(1)
               repaxes(i)='a'
            case(2)
               repaxes(i)='b'
            case(3)
               repaxes(i)='c'
         end select
      end do
   else
      repaxes=['a','b','c']
   end if
   write(6,2002)'ROTATIONAL CONSTANTS:               A = ',abc(1)
   write(6,2002)'                                    B = ',abc(2)
   write(6,2002)'                                    C = ',abc(3)
   write(6,2002)'RAY PARAMETER:                          ',Ra
   !rep = 3 !1
   write(6,2004)'ASSYMMETRIC TOP REPRESENTATION:         ',rep,leftright
   write(6,2112)'[x,y,z] --> [',repAxes(1),',',repaxes(2),',',repaxes(3),']'
   write(6,2001)'STARTING J:                             ',startJ
   write(6,2001)'ENDING J:                               ',endJ
   write(6,*)
   write(6,2007)'Properties in molecular axes: '
   write(6,2007)'Dipole moment (Debye):        '
   write(6,2006)'X=              Y=              Z=           '
   write(6,2005)(dip(i)*AU2SI_debye,i=1,3)
   ! write(6,*)
   ! write(6,2006)'X=              Y=              Z=           '
   ! write(6,2007)'Quadrupole moment (Debye-Ang):'
   ! write(6,2005)((quad(jj,i)*AU2SI_debye*BohrR,i=1,3),jj=1,3)
   write(6,*)
   write(6,2006)'X=              Y=              Z=           '
   write(6,2007)'G-Tensor (1):                 '
   write(6,2005)((gt(jj,i),i=1,3),jj=1,3)
   
2004 format(A40,1I10,A1)
2007 format(A30)
2006 format(A45)
2005 format(3(F15.8,1X))
2112 format(A13,6(A1))
   write(6,230,advance='no')'DIAGONALIZING HAMILTONIAN...            ' 
   call CPU_TIME(time1)
   call CALCULATE_HAM()
   call CPU_TIME(time2)
   write (6,231)(time2-time1)
   !deallocate(HAM_FUll)
   call scripting()
   write(6,*)

   if(approxPartFFlag)then
      Q=PARTFUN(abc(1),abc(2),abc(3),temp,1)!TODO, user parameter for the symnum (the last argument)
   else
      if(.not.ownPartFunFlag)then
         dime=0
         do i = startJ,endJ
            dime = dime + i*2+1
         end do
         !i dont really feel like refactoring ExactPARTFUN() subroutine
         allocate(eval_full(dime))
         car=1
         do i = startJ,endJ
            do ii = 1,2*i+1
               eval_full(car)=eval_full_list(i-startJ+1)%arr(ii)
               car = car + 1
            end do
         end do
         Q=ExactPARTFUN(Eval_full*1d9,dime_full,temp,1,endJ) !Partition function
         deallocate(eval_full)
      end if
   end if

   if(file_lineSpectrum(1).or.file_spectrum(1))then
   write(6,2002)'TEMPERATURE (Kelvin):                   ',temp
   if(approxPartFFlag)then
      write(6,2002)'PARTITION FUNCTION (Approximated):      ',Q
   else if(.not.ownPartFunFlag)then
      write(6,2002)'PARTITION FUNCTION ("Exact"):           ',Q
   else if(ownPartFunFlag)then
      write(6,2002)'PARTITION FUNCTION (Provided):          ',Q
   end if
   if(presflag.and.file_spectrum(1))then
      write(6,2002)'PRESSURE HWHM (MHz):                    ',pwidth*1d3
   end if
   if(file_spectrum(1))then
      write(6,2002)'RESOLUTION (MHZ):                       ',resolution*1d3
   end if
   write(6,*)
   write(6,2002)'SPECTRUM START (GHz):                   ',fmin
   write(6,2002)'SPECTRUM END   (GHz):                   ',fmax
   end if
   
   
   if(.not.DIRCOSEFLAG)then
      SphericalStrengthsFlag = .true.
   end if
   write(6,230)'CALCULATING RCD...                           ' 
   call CPU_TIME(time1)
   call CALCULATE_RCD_ALL()
   !deallocate(Evec_full,eval_full,trans_probs)
   deallocate(Evec_full_list,eval_full_list,trans_probs)
   call CPU_TIME(time2)
   write(6,231)(time2-time1)
   close(69)
   
   ! if(W3JFlagUse)then
   ! deallocate(W3Js)
   ! end if
   !call SALZMAN_COMPARISON()
   
   
   
   write(6,*)
   write(6,230)'CALCULATING SPECTRA...                       ' 
   call CPU_TIME(time1)
   call CALCULATE_LINE_SPECTRUM(fmin,fmax,.false.)
   call CALCULATE_SPECTRUM(.false.)
   if(MWFlag)then
      !call CALCULATE_LINE_SPECTRUM(fmin,fmax,.true.)
      call CALCULATE_SPECTRUM(.true.)
   end if
   call CPU_TIME(time2)
   write (6,231)(time2-time1)
   
   write(6,*)
   print *,'PROGRAM EXITED NORMALLY'
   
   if(FFPEFLAG)then
      write(6,*)'UNDERFLOW AND DENORMAL ARE OKAY, OVERFLOW AND ZERO ARE BAD'
      stop
   end if
!  -------------------------------------------------------------
!  FUNCTIONS
!  -------------------------------------------------------------
   
   contains
            
   function Calc_storage_index(J1,T1,J2,T2)result(idx)
      integer(4) :: i,J1,T1,J2,T2,idx,endIdx,add
      idx = 1
      !if(0==J2-1)goto 9998
      if(j1==j2)then
         endIdx = J1-1
      else
         endIdx = J1
      end if
      if(J1==0)goto 9998
      do i = 0,endIdx
         if(i==j1)then
            idx = idx + Num_transitions(i,i)
         else
            idx = idx + Num_transitions(i,i+1)+Num_transitions(i,i)
         end if
      end do
9998  if(J1==J2)then
         add=0
         if(T1/=-J1)then
            do i = -J1,T1-1
               add=add + ((2*J1+1)-(i+J1+1))
            end do
         end if
         idx = idx + (t2-t1-1) + add
      else
         if(-J1==T1)goto 9999
         do i = -J1,T1-1
            idx = idx+(2*J2+1)
         end do
9999     idx = idx + J2 + t2
      end if    
   end function Calc_storage_index
            
   subroutine ReadCustomFile(filename,alternativeFile,sta)
      character(80) filename,check,units,exception
      character(*) :: alternativeFile
      integer(4) :: i,j,idxParLeft,idxParRight,sta
      logical FEx,useThis,switchUp
      real(8) bufr(3,3)
      
      useThis=.true.
      abc_found=.false.
      g_found=.false.
      dip_found=.false.
      q_found=.false.
      switchUp=.false.
      inquire(file=filename,exist=FEx)
      if(.not.FEX)then
         inquire(file=alternativeFile,exist=Fex)
         if(.not.Fex)then
            open(7,file=alternativeFile)
            write(7,1403)'ROTATIONAL CONSTANTS (GHz):   '
            write(7,1402)('_______________',i=1,3)
            write(7,*)
            write(7,1403)'DIPOLE MOMENTS (au):          '
            write(7,1402)('_______________',i=1,3)
            write(7,*)
            write(7,1403)'QUADRUPOLE MOMENTS (au2):     '
            write(7,1402)('_______________',i=1,3)
            write(7,1402)('_______________',i=1,3)
            write(7,1402)('_______________',i=1,3)
            write(7,*)
            write(7,1403)'G-TENSOR (1):                 '
            write(7,1402)('_______________',i=1,3)
            write(7,1402)('_______________',i=1,3)
            write(7,1402)('_______________',i=1,3)
            close(7)
            sta=-1
            return
         end if
      end if
1402  format(3(A15,1X)) 
1403  format(A30)
1404  format(1L)
      open(7,file=filename)
      sta=0
      read(7,2003)check
      idxParLeft=index(check,'(')
      idxParRight=index(check,')')
      units=check(idxParLeft+1:idxParRight-1)
      if(check(idxParRight+1:idxParRight+1)=='f')then
         read(7,2003)check
         goto 20
      end if
      call to_upper(units)
      read(7,2003)check
      if(index(check,'_')/=0)goto 20
      abc=str2num(check)
      select case(units)
         case('GHZ')
         
         case('CM-1')
            abc=abc*100d0*cc
         case('NM')
            abc=cc/(abc*1d-9)*1d-9
         case('MHZ')
            abc=abc*1d-3
         case('G.CM2')! oh my gooood
            abc=h/(abc/NA*1d-4*8d0*pi**2)*1d-6
         case('AMU.A2')
            abc=h/(abc/NA*1d-20*8d0*pi**2)*1d-6
         case default
            exception = 'Unknown units, ROTATIONAL CONSTANTS, in '//filename
            stop exception
      end select
      !ABC rotational constants
      !read(7,2000,err=20)(abc(i),i=1,3)
      abc_found=.true.
      
20    continue
      useThis=.true.
      read(7,2003)check
      read(7,2003)check
      idxParLeft=index(check,'(')
      idxParRight=index(check,')')
      units=check(idxParLeft+1:idxParRight-1)
      switchUp = index(check(idxParRight:),'r')/=0
      if(check(idxParRight+1:idxParRight+1)=='f')then
         read(7,2003)check
         goto 21
      end if
      call to_upper(units)
      read(7,2003)check
      if(index(check,'_')/=0)goto 21
      dip=str2num(check)
      select case(units)
         case('AU')
         
         case('DEBYE')
            dip=dip*SI2AU_debye
         case('C.M')
            dip=dip*SI2AU_debye/cc*1d-21
         case default
            exception = 'Unknown units, DIPOLE MOMENTS, in '//filename
            stop exception
      end select
      if(switchUp)then
         dip=RepAxesSwitch_V(dip,rep,lefthandedFlag)
      end if
      !quadrupole moments
      dip_found=.true.
      switchUp=.false.
21    continue
      useThis=.true.
      bufr=quad
      read(7,2003)check
      read(7,2003)check
      idxParLeft=index(check,'(')
      idxParRight=index(check,')')
      units=check(idxParLeft+1:idxParRight-1)
      switchUp = index(check(idxParRight:),'r')/=0
211   if(check(idxParRight+1:idxParRight+1)=='f')then
         do i = 1,3
            read(7,2003)check
         end do
         goto 22
      end if
      call to_upper(units)
      do i = 1,3
         read(7,2003)check
         if(index(check,'_')/=0)goto 222
         quad(i,:)=str2num(check)
      end do
      q_found=.true.
      select case(units)
         case('AU2')
            
         case('DEBYE.A')
            quad=quad*SI2AU_debye/bohrR
         case('DEBYE.AU')
            quad=quad*SI2AU_debye
         case('C.M2')
            quad=quad*SI2AU_debye/cc*1d-21*1D10/bohrR
         case default
            exception = 'Unknown units, QUADRUPOLE MOMENTS, in '//filename
            stop exception
      end select
      if(switchUp)then
         quad=RepAxesSwitch_T(quad,rep,lefthandedFlag)
         switchUp=.false.
      end if
      goto 22 !shameless use of goto
      
222   do j = 1,3-i
         read(7,2003)check
      end do
      quad = bufr
      !g-tensor
      
22    continue
      useThis=.true.
      bufr=gt
      read(7,2003)check
      read(7,2003)check
      idxParLeft=index(check,'(')
      idxParRight=index(check,')')
      switchUp = index(check(idxParRight:),'r')/=0
      if(check(idxParRight+1:idxParRight+1)=='f')then
         goto 25
      end if
      do i = 1,3
         read(7,2003)check
         if(index(check,'_')/=0)goto 24
         gt(i,:)=str2num(check)
      end do
      if(switchUp)then
         gt=RepAxesSwitch_T(gt,rep,lefthandedFlag)
      end if
      !read(7,2001,err=24)(gt(1,i),i=1,3)
      ! print *,gt(1,:)
      !read(7,2001,err=24)(gt(2,i),i=1,3)
      !read(7,2001,err=24)(gt(3,i),i=1,3)
      g_found=.true.
      goto 25 !shameless use of goto
24    gt=bufr
25    continue
      close(7)
2000  format(3(F15.8,1X))
2001  format(3(E15.8E2,1X))
2002  format(E15.8E2,1X)
2003  format(A80)
   end subroutine readCustomFile

             
   !sorta binary flags, implemented through strings :)
   subroutine ReadFlags_Binary(str,arr,n)
      integer(4),intent(in) :: n
      character(n),intent(in) :: str
      logical,intent(out) :: arr(n)
      integer(4) i

      arr=.false.
      do i = 1,n
         if(str(i:i)=='1')then
            arr(i)=.true.
         else if(str(i:i)==' ')then
            return
         end if
      end do
   
   end subroutine ReadFlags_Binary
               
   subroutine ReadFlags(sta)
      logical lex,logbuf
      character(80) FN
      integer(4) line,i,j,idx,sta
      
      inquire(file='RCD.PAR',exist=lex)
      if(.not.lex)then
         write(6,*)'RCD.PAR not found, using program defaults'
         sta=-1
         return
      end if
      sta=0
      open(unitt,file='RCD.PAR')
      line=0
      
2149  continue    
      read(unitt,2151,end=2150)FN
           
           
      if(FN(1:2)=='AE')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:2),flag_absem,2)
         line=line+1
      end if
      
      if(FN(1:23)=='Dipole strength minimum')then
         
         read(unitt,2151,end=2150)FN
         idx=index(FN,'%')
         if(idx>0)then
            read(FN(1:idx-1),2154)dipstr_cutoff
            dipstr_cutoff=dipstr_cutoff*1d-2
            dipstr_cutoff_percentual=.true.
         else
            read(FN,2154)dipstr_cutoff
         end if
         line=line+1
      end if
      if(FN(1:27)=='Rotational strength minimum')then
         read(unitt,2154,end=2150)rotstr_cutoff
         line=line+1
      end if
      if(FN(1:22)=='Kuhn parameter minimum')then
         read(unitt,2154,end=2150)kuhnpar_cutoff
         line=line+1
      end if
      if(FN(1:33)=='Minima for line and band spectra?')then
         read(unitt,2152,end=2150)spectra_cutoff
         line=line+1
      end if
      if(FN(1:17)=='Intensity minimum')then
         read(unitt,2154,end=2150)intensity_cutoff
         line=line+1
      end if
      if(FN(1:25)=='Switch up the dipole axes')then
         read(unitt,2152)switchUpAxes
         line=line+1
      end if
      
      
      
      if(FN(1:10)=='_MolParams')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:10),file_molParams,10)
         line=line+1
      end if
      if(FN(1:12)=='_transitions')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:10),file_transitions,10)
         line=line+1
      end if
      if(FN(1:14)=='_line_spectrum')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:10),file_lineSpectrum,10)
         line=line+1
      end if
      if(FN(1:9)=='_spectrum')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:10),file_spectrum,10)
         line=line+1
      end if
      if(FN(1:11)=='_Detail.TAB')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:10),file_detailtab,10)
         line=line+1
      end if
      if(FN(1:4)=='.PRN')then
         read(unitt,2151,end=2150)FN
         call ReadFlags_Binary(FN(1:10),file_prn,10)
         line=line+1
      end if
      
      
           
      if(FN(1:12)=='JPL cat file')then
         read(unitt,2151)JPLFile
         line=line+1
      end if
      
      if(FN(1:12)=="MW spectrum?")then
         read(unitt,2152)MWFlag
         line=line+1
      end if
      
      if(FN(1:25)=='Use previous calculation?')then
         read(unitt,2152)PreviousCalcFlag
         line=line+1
      end if
      
      if(FN(1:22)=='Write X and Y electric')then
         read(unitt,2152)WriteMomentsFlag
         line=line+1
      end if
      
      if(FN(1:25)=='Skip over transitions not')then
         read(unitt,2152)SkipTransFlag
         line=line+1
      end if
      
      if(FN(1:25)=="Use good ol' fashioned ca") then
         read(unitt,2152)DirCoseFlag
         line=line+1
      end if
      
      if(FN(1:25)=="   Use direction cosines ")then
         read(unitt,2155)ShafferFlag
         line=line+1
      end if
      
      if(FN(1:24)=='Precalculate factorials?') then
         read(unitt,2152)factFlag
         line=line+1
      end if
      
      if(FN(1:25)=='   Precalculate W3J symbo') then
         read(unitt,2155)W3JFlagUse
         line=line+1
      end if
      
      if(FN(1:25)=='   Store precalculated W3') then
         read(unitt,2155)W3JDiskFlag
         line=line+1
      end if
            
      if(FN(1:25)=='   Test functions against') then
         read(unitt,2155)testflag
         line=line+1
      end if
      
      if(FN(1:25)=='Include quadrupole contri') then
         read(unitt,2152)quadFlag
         line=line+1
      end if
      
      if(FN(1:25)=='Turn on Doppler broadenin') then
         read(unitt,2152)dopflag
         line=line+1
      end if
      
      if(FN(1:25)=='Turn on pressure broadeni') then
         read(unitt,2152)presflag
         line=line+1
      end if
      
      if(FN(1:25)=='Use approximate rotationa') then
         read(unitt,2152)approxPartFFlag
         line=line+1
      end if
      
      if(FN(1:25)=='   Your own partition fun' .and. .not. approxPartFFlag)then
         read(unitt,2156,err=5647)Q
         ownPartFunFlag=.true.
         line=line+1
         goto 2149
5647     ownPartFunFlag=.false.         
      end if
      
      if(FN(1:25)=='Write floating point exce') then
         read(unitt,2152)FFPEFLAG
         line=line+1
      end if
      
      if(FN(1:25)=='Write energies, dipole an') then
         read(unitt,2152)HumanReadableFlag
         line=line+1
      end if
      
      if(FN(1:22)=='Write extended output?') then
         read(unitt,2152)detailOutputFlag
         line=line+1
      end if
      
      if(FN(1:25)=='   Use lab axis electrica') then
         read(unitt,2155)FastFlag
         line=line+1
      end if
      
      if(FN(1:25)=='Encapsulate line spectrum') then
         read(unitt,2152)excelCompatible
         line=line+1
      end if
      
      if(FN(1:29)=='Use Gaussians rotational GIAO') then
         read(unitt,2152)GIAOTensor
         line=line+1
      end if
      
      if(FN(1:25)=='Use spherical g-tensor in')then
         read(unitt,2152)useSphericalG
         line=line+1
      end if
      
      if(FN(1:10)=='Starting J')then
         read(unitt,2153)startJ
         line=line+1
      end if
      
      if(FN(1:8)=='Ending J')then
         read(unitt,2153)endj
         line=line+1
      end if
      
      if(FN(1:25)=='Supply your own g-tensor ')then
         read(unitt,2152)GTOWN_flag
            if(GTOWN_flag)then
            open(222,file='gtensor.par')
            
            read(222,*)FN
            do i = 1,3
               read(2,1545)(gt_own(i,j),j=1,3)
            end do
1545        format(2X,3(F15.8,1X))         
            close(222)
         end if
      end if
      
      if(FN(1:25)=='Pressure width calibratio')then
         read(unitt,2151)FN
         read(FN(1:15),2154)calpress
         read(unitt,2151)FN
         read(FN(1:15),2154)caltemp
         read(unitt,2151)FN
         read(FN(1:15),2154)calwidth
         line=line+1
      end if
      
      if(FN(1:22)=='Measurement parameters')then
         
         read(unitt,2151)FN
         read(FN(1:15),2154)pwidth
         read(unitt,2151)FN
         read(FN(1:15),2154)temp
         !read(unitt,2151)FN
         !read(FN(1:15),2154)baseline
         read(unitt,2151)FN
         read(FN(1:15),2154)fmin
         read(unitt,2151)FN
         read(FN(1:15),2154)fmax
         read(unitt,2151)FN
         read(FN(1:15),2154)resolution
         resolution=resolution*1d-3
         line=line+1
      end if
      
      if(FN(1:24)=='Gaussian input file name')then
         read(unitt,*)inputfile
         line=line+1
      end if
            
      if(FN(1:25)=='Asymmetric top representa')then
         read(unitt,*)rep
         line=line+1
      end if
      
      if(FN(1:12)=='Left-Handed?')then
         read(unitt,*)lefthandedFlag
         line=line+1
      end if
      
      ! if(FN(1:14)=='Spectrum Range')then
         ! read(unitt,2151)FN
         ! read(FN(1:15),2154)
         ! read(unitt,2151)FN
         ! read(FN(1:15),2154)
         ! line=line+1
      ! end if
      
      goto 2149
2150  close(unitt)
2151  format(A80)    
2152  format(1L)
2153  format(I8)
2154  format(F15.8)
2155  format(3X,1L)
2156  format(3X,F15.8)
   end subroutine

   subroutine Filter_IArr(arr,outarr,fcount,n,limit)
      integer(4) n,limit,fcount,arr(n),outarr(n)
      
      outarr=1
      do i = 1,n
         if(arr(i)<limit)then
            outarr(i)=0
            fcount=fcount+1
         end if
      end do
   end subroutine Filter_IArr
   
   
   subroutine Filter_DArr_zero(arr,outarr,fcount,n)
      integer(4) n,i
      integer(4),intent(INOUT) :: fcount,outarr(n)
      real(8),intent(IN) :: arr(n)
      
      
      do i = 1,n
         if(arr(i)==0d0)then
            if(outarr(i)/=0)then
               outarr(i)=0
               fcount=fcount+1
            end if
         end if
      end do
   end subroutine Filter_DArr_zero
   
   
   subroutine Filter_DArr(arr,outarr,fcount,n,minv,maxv)
      integer(4) n,i
      integer(4),intent(INOUT) :: outarr(n)
      integer(4),intent(INOUT) :: fcount
      real(8),intent(IN) :: minV,maxV,arr(n)
      
      do i = 1,n
         if((arr(i)==0d0.or.(arr(i)<minV).or.(arr(i)>maxV)).and.outarr(i)/=0)then
            outarr(i)=0
            fcount=fcount+1
         end if
      end do
   end subroutine Filter_DArr
      
   !inner
   subroutine CALCULATE_LINE_SPECTRUM(minr,maxr,MW)
      real(8),allocatable :: x(:),y(:),yMW(:),xExcel(:),yExcel(:),yMWExcel(:)
      integer(4),allocatable :: orderXY(:)
      real(8),allocatable :: rot_strs_(:),dip_strs_(:),trans_ens_(:),stupidFortranBuffer(:),rot_strs_excel(:),dip_strs_excel(:),trans_ens_excel(:),fracpop_(:),fracpop_excel(:),fracpopL_(:),fracpopU_(:)
      real(8),allocatable :: fracpopL_excel(:),fracpopU_excel(:),bufarr(:)
      real(8) abscoeff,bufr,minr,maxr,resolutions,kuhnpar,abscoeffMW
      integer(4),allocatable :: trans_arr_(:,:),order(:),orderR(:),trans_arr_excel(:,:),filter(:)
      integer(4) idx1,idx2,filtered(cou),finalSize
      integer(4) i,curIndex,bufI,filteredCount,j
      logical MW,kuhn
      
      !save filteredCount
      
      if(.not.file_lineSpectrum(1))return
      !filter values out of frequency range
      filteredCount=0
      filtered=1
      allocate(stupidFortranBuffer(cou))
      stupidFortranBuffer=dabs(trans_en_arr)
      call Filter_DArr(dabs(trans_en_arr),filtered,filteredCount,cou,minr,maxr)
      stupidFortranBuffer = dip_strs*AU2SI_debye**2
      bufI=count(dip_strs==0d0)
      call Filter_DArr_zero(stupidFortranBuffer,filtered,filteredCount,cou)
      if(spectra_cutoff)then
         if(dipstr_cutoff_percentual)then
            call Filter_DArr(stupidFortranBuffer,filtered,filteredCount,cou,dipstr_cutoff*maxval(stupidFortranBuffer),1D3)
         else
            call Filter_DArr(stupidFortranBuffer,filtered,filteredCount,cou,dipstr_cutoff,1D3)
         end if
         if(.not.MW)then
            stupidFortranBuffer = dabs(rot_strs)*AU2SI_debye**2
         end if
         call Filter_DArr(stupidFortranBuffer,filtered,filteredCount,cou,rotstr_cutoff,1D3)
      end if
      !call ToJPLCAT()
      bufI=cou-filteredCount
      allocate(rot_strs_(bufI),dip_strs_(bufI),trans_ens_(bufI),trans_arr_(bufI,4),order(bufI),fracpopL_(bufI),fracpopU_(bufI),filter(bufI))
      !copy arrays
      

      stupidFortranBuffer=ROT_STRS*filtered

      rot_strs_=CutFilter_Darr(stupidFortranBuffer,cou,bufI)
      
      stupidFortranBuffer=DIP_STRS*filtered
      dip_strs_=CutFilter_Darr(stupidFortranBuffer,cou,bufI)
      
      trans_ens_=CutFilter_Darr(dabs(trans_en_arr)*filtered,cou,bufI)
      deallocate(stupidFortranBuffer)
      trans_arr_(:,1)=CutFilter_Iarr(((trans_arr(:,1)+endJ+1)*filtered),cou,bufI)
      trans_arr_(:,1)=trans_arr_(:,1)-(endJ+1)
      trans_arr_(:,2)=CutFilter_Iarr(((trans_arr(:,2)+endJ+1)*filtered),cou,bufI)
      trans_arr_(:,2)=trans_arr_(:,2)-(endJ+1)
      trans_arr_(:,3)=CutFilter_Iarr(((trans_arr(:,3)+endJ+1)*filtered),cou,bufI)
      trans_arr_(:,3)=trans_arr_(:,3)-(endJ+1)
      trans_arr_(:,4)=CutFilter_Iarr(((trans_arr(:,4)+endJ+1)*filtered),cou,bufI)
      trans_arr_(:,4)=trans_arr_(:,4)-(endJ+1)
      
      allocate(x(bufi),y(bufi),yMW(bufI))
      resolutions=resolution!GHz
      
      if(MW)then
         rot_strs_=dip_strs_
      end if
      
      curindex=1
      filter=1
      x=0
      y=0
      !$OMP PARALLEL PRIVATE(i,idx1,idx2,abscoeff,abscoeffMW,kuhnpar)
      !$OMP DO
      do i = 1,bufI
         kuhnpar=4d0*rot_strs_(i)/dip_strs_(i)
         if(.not.MW.and.dabs(kuhnpar)<kuhnpar_cutoff)then
            filter(i)=0
            fracpopL_(i)=0
            fracpopU_(i)=0
            !curIndex=curIndex+1
            cycle
         end if
         !write(unitt,*)'PEAK NO:',i
         idx1=Calc_Frac_index(trans_arr_(i,1),trans_arr_(i,2))
         idx2=Calc_Frac_index(trans_arr_(i,3),trans_arr_(i,4))
         abscoeff=Abs_coeff(dabs(trans_ens_(i)),Fracpop(idx1),trans_arr_(i,1)*2+1,Fracpop(idx2),trans_arr_(i,3)*2+1,rot_strs_(i)*(AU2SI_debye)**2,.true.,.false.,flag_absem)
         abscoeffMW=Abs_coeff(dabs(trans_ens_(i)),Fracpop(idx1),trans_arr_(i,1)*2+1,Fracpop(idx2),trans_arr_(i,3)*2+1,dip_strs_(i)*(AU2SI_debye)**2,.true.,.true.,flag_absem)
         ! if(dabs(trans_ens_(i))<1d-50)then!denormal catching
            ! filter(i)=0
            ! fracpopL_(i)=0
            ! fracpopU_(i)=0
            ! cycle
         ! end if
         x(i)=dabs(trans_ens_(i))
         y(i)=abscoeff
         yMW(i)=abscoeffMW
         if(abscoeff==0d0 .or. dabs(abscoeff)<intensity_cutoff)then
            filter(i)=0
         endif
         !curIndex=curIndex+1
         fracpopL_(i)=Fracpop(idx1)
         fracpopU_(i)=Fracpop(idx2)
      end do
      !$OMP END DO
      !$OMP END PARALLEL
      allocate(orderR(bufi))
      ! do i = 1,bufI
         ! if(dabs(y(i))<outtol)then
            ! y(i)=0d0
         ! end if
      ! end do
      ! allocate(orderR(bufi),grp(bufi))
      ! do i = 1,bufi
         ! grp(i)%value=x(i)
         ! grp(i)%order=i
      ! end do
      ! call qsort(grp,bufi)
      ! orderR=grp(:)%order
      ! x=grp(:)%value
      ! deallocate(grp)
      call Insertion_sort(x,bufi,orderR)
      call Reorder_arr(y,bufi,orderR)
      call Reorder_arr(yMW,bufi,orderR)
      call Reorder_arr_int_4(trans_arr_,bufi,orderR)
      call Reorder_arr(trans_ens_,bufi,orderR)
      call Reorder_arr(dip_strs_,bufi,orderR)
      call Reorder_arr(rot_strs_,bufi,orderR)
      call Reorder_arr(fracpopL_,bufI,orderR)
      call Reorder_arr(fracpopU_,bufI,orderR)
      call Reorder_arr_int(filter,bufI,orderR)
      !rot_strs_=rot_strs_*dabs(fracpopL_-fracpopU_)
      !dip_strs_=dip_strs_*dabs(fracpopL_-fracpopU_)
      
      if(excelCompatible)then
         finalSize=count(filter==1)*3+1
         allocate(xExcel(finalSize),yExcel(finalSize),yMWExcel(finalSize),trans_arr_excel(finalSize,4),trans_ens_excel(finalSize),dip_strs_excel(finalSize),rot_strs_excel(finalSize),fracpop_excel(finalSize))
         allocate(fracpopL_excel(finalSize),fracpopU_excel(finalSize))
         j=1
         xExcel(1)=0d0
         yExcel(1)=0d0
         yMWExcel(1)=0d0
         trans_arr_excel(1,:)=0d0
         trans_ens_excel(1)=0d0
         dip_strs_excel(1)=0d0
         rot_strs_excel(1)=0d0
         fracpopL_excel(1)=0d0
         fracpopU_excel(1)=0d0
         do i = 1,bufI
            if(filter(i)==0)cycle
            !I'm not spaghettying, I'm loop unrolling
            xExcel(2+(j-1)*3)=x(i)-resolutions/1d3
            xExcel(3+(j-1)*3)=x(i)
            xExcel(4+(j-1)*3)=x(i)+resolutions/1d3
            yExcel(2+(j-1)*3)=0d0
            yExcel(3+(j-1)*3)=y(i)
            yExcel(4+(j-1)*3)=0d0
            yMWExcel(2+(j-1)*3)=0d0
            yMWExcel(3+(j-1)*3)=yMW(i)
            yMWExcel(4+(j-1)*3)=0d0
            trans_arr_excel(2+(j-1)*3,:)=0d0
            trans_arr_excel(3+(j-1)*3,:)=trans_arr_(i,:)
            trans_arr_excel(4+(j-1)*3,:)=0d0
            trans_ens_excel(2+(j-1)*3)=0d0
            trans_ens_excel(3+(j-1)*3)=trans_ens_(i)
            trans_ens_excel(4+(j-1)*3)=0d0
            dip_strs_excel(2+(j-1)*3)=0d0
            dip_strs_excel(3+(j-1)*3)=dip_strs_(i)
            dip_strs_excel(4+(j-1)*3)=0d0
            rot_strs_excel(2+(j-1)*3)=0d0
            rot_strs_excel(3+(j-1)*3)=rot_strs_(i)
            rot_strs_excel(4+(j-1)*3)=0d0
            fracpopL_excel(2+(j-1)*3)=0d0
            fracpopL_excel(3+(j-1)*3)=fracpopL_(i)
            fracpopL_excel(4+(j-1)*3)=0d0
            fracpopU_excel(2+(j-1)*3)=0d0
            fracpopU_excel(3+(j-1)*3)=fracpopU_(i)
            fracpopU_excel(4+(j-1)*3)=0d0
            j=j+1
         end do
         deallocate(rot_strs_,trans_ens_,trans_arr_,dip_strs_,fracpopL_,fracpopU_)
         call Write_Line_Spectrum(xExcel,yExcel,yMWExcel,finalSize,trans_arr_excel,dip_strs_excel,rot_strs_excel,fracpopL_excel,fracpopU_excel,.true.,MW,filter)
         deallocate(xExcel,yExcel,orderr,trans_arr_excel,trans_ens_excel,dip_strs_excel,rot_strs_excel,fracpopL_excel,fracpopU_excel,filter)
         return
      end if
      !bufr = maxval(abs(y))
      !y=y/bufr
      call WRITE_LINE_SPECTRUM(x,y,yMW,bufi,trans_arr_,dip_strs_,rot_strs_,fracpopL_,fracpopU_,.false.,MW,filter)
      
      deallocate(rot_strs_,trans_ens_,trans_arr_,dip_strs_,fracpopL_,fracpopU_,filter)
      !close(unitt)
230   format(A45)   
      !write(6,*)
      !write(6,230,advance='no')''
      !write(6,*)'WRITTEN '//outputfile(1:outputLength)//'_line_spectrum'
      deallocate(x,y,yMW,orderR)
      
   end subroutine CALCULATE_LINE_SPECTRUM
   
   subroutine WRITE_LINE_SPECTRUM(x,y,yMW,n,transArr,dip,rot,fracpopL,fracpopU,excel,MW,filter)
      integer(4) n,i,filter(n)
      real(8) x(n),y(n),yMW(n)
      integer(4) transArr(n,4),bufI(3),Km1_1,K1_1,Km1_2,K1_2
      real(8) dip(n),rot(n),fracpopL(n),fracpopU(n)
      character(:),allocatable :: filee
      logical excel,MW
      
      
2486  format(4(1X,A20),6A4)   
      if(MW)then
         filee=outputfile(1:outputLength)//'.lsprMW_'//trim(tempChar)//'K'
      else
         filee=outputfile(1:outputLength)//'.lspr_'//trim(tempChar)//'K'
      end if
      open(unitt,file=filee)
      if(file_lineSpectrum(6))then
         write(unitt,2486,advance='no')'frequency','intensityMW','intensity','kuhnpar','  J1',' K-1','  K1','  J2',' K-1','  K1'
2485     format(A20) 
2484     format(2(A20)) 
 
         if(file_lineSpectrum(2))then
            write(unitt,2485,advance='no')'Dipole Str'
         end if
         if(file_lineSpectrum(3))then
            write(unitt,2485,advance='no')'Rotational Str'
         end if
         if(file_lineSpectrum(4))then
            write(unitt,2484,advance='no')'Lower State Pop.','Upper State Pop.'
         end if
         if(file_lineSpectrum(5))then
            write(unitt,*)'   TEMPERATURE = ',temp,'PARTITION FUNCTION = ',Q
         end if
      end if
      write(unitt,*)
      i=1
      do while (i<n)
         if(excel.and.mod(i-1,3)==0)then
            if(x(i+1)==0d0 .or. x(i+1) < fmin)then
               i=i+3
               cycle
            end if
         end if
         if(.not.excel.and.(x(i)==0d0 .or. x(i) < fmin .or. dip(i)<outtol .or. dabs(rot(i))<outtol).or..not.(filter(i)==1))then
            i=i+1
            cycle
         end if
         bufI=OldToNewNotation(transArr(i,1),transArr(i,2))
         Km1_1=bufI(2)
         K1_1=bufI(3)
         bufI=OldToNewNotation(transArr(i,3),transArr(i,4))
         Km1_2=bufI(2)
         K1_2=bufI(3)
         write(unitt,2487,advance='no')x(i),yMW(i),y(i),4d0*y(i)/yMW(i),transArr(i,1),Km1_1,K1_1,transArr(i,3),Km1_2,K1_2
         if(file_lineSpectrum(2))then
            write(unitt,2488,advance='no')dip(i)
         end if
         if(file_lineSpectrum(3))then
            write(unitt,2489,advance='no')rot(i)
         end if
         if(file_lineSpectrum(4))then
            write(unitt,2490,advance='no')fracpopL(i),fracpopU(i)
         end if
         write(unitt,*)
         i=i+1
      end do
      
2487  format(4(1X,E20.13E3),6I4)     
2488  format(E20.10)     
2489  format(E20.10)     
2490  format(2E20.10)     
      
      close(unitt)
      if(MW)then
         write(6,*)'WRITTEN '//filee
      else
         write(6,*)'WRITTEN '//filee
      end if
   END SUBROUTINE WRITE_LINE_SPECTRUM
   
   !inner
   !profile - enumerated value, currently LOR, GAU, VOI (Lorentzian,Gaussian,Voigt profile function)
   subroutine CALCULATE_SPECTRUM(MW)
      real(8),allocatable :: x_col(:,:),y_col(:,:),x_col2(:,:),y_col2(:,:)
      real(8),allocatable :: x(:),y(:),xy(:,:)
      integer(4),allocatable :: orderXY(:)
      real(8),allocatable :: rot_strs_(:),dip_strs_(:),bufR(:),trans_ens_(:),stupidFortranBuffer(:)
      real(8) dwidth,inten,curY,curX,abscoeff,stuff(cou)
      integer(4),allocatable :: trans_arr_(:,:),order(:),orderR(:),endIdxs(:),colOrder(:),endIdxs2(:)
      integer(4) idx1,idx2,colIdx,filtered(cou),finalSize
      integer(4) i,j,numX,alArrSize,curIndex,bufI,counter,filteredCount
      character(3) profile
      character(:),allocatable :: filee
      logical MW
      
      !integer(4),function :: OMP_get_thread_num
      ! interface
         ! function OMP_get_thread_num()
            ! integer(4) :: OMP_get_thread_num
         ! end function OMP_get_thread_num
      ! end interface
      
      ! interface 
         ! real(8) function Profile_Lorentz(a1,a2,a3,a4)
            ! real(8) :: Profile_Gauss
            ! real(8) :: a1,a2,a3,a4
         ! end function Profile_Lorentz
         ! function Profile_Gauss(a1,a2,a3,a4)
            ! real(8) :: Profile_Gauss
            ! real(8) :: a1,a2,a3,a4
         ! end function Profile_Gauss
      ! end interface      
      
      if(.not.(PresFlag.or.dopflag).or..not.file_spectrum(1))return
      
      !filter values out of frequency range
      filteredCount=0
      filtered=1
      stuff=dabs(trans_en_arr)
      !call Filter_DArr(stuff,filtered,filteredCount,cou,fmin,fmax)
      allocate(stupidFortranBuffer(cou))
      stupidFortranBuffer = dip_strs*AU2SI_debye**2
      call Filter_DArr_zero(stupidFortranBuffer,filtered,filteredCount,cou)
      if(spectra_cutoff)then
         if(dipstr_cutoff_percentual)then
            call Filter_DArr(stupidFortranBuffer,filtered,filteredCount,cou,dipstr_cutoff*maxval(stupidFortranBuffer),1D3)
         else
            call Filter_DArr(stupidFortranBuffer,filtered,filteredCount,cou,dipstr_cutoff,1D3)
         end if
         if(.not.MW)then
            stupidFortranBuffer = dabs(rot_strs)*AU2SI_debye**2
            call Filter_DArr(stupidFortranBuffer,filtered,filteredCount,cou,rotstr_cutoff,1D3)
         end if
      end if
      bufI=cou-filteredCount
      allocate(dip_strs_(bufI),rot_strs_(bufI),trans_ens_(bufI),trans_arr_(bufI,4),order(bufI))
      !copy arrays
      rot_strs_=0d0
      trans_ens_=0d0
      trans_arr_=0
      dip_strs_=CutFilter_Darr(DIP_STRS*filtered,cou,bufI)
      if(.not.MW)then
         rot_strs_=CutFilter_Darr(ROT_STRS*filtered,cou,bufI)
      end if
      trans_ens_=CutFilter_Darr(dabs(trans_en_arr)*filtered,cou,bufI)
      !guud trick, not hacky at all
      trans_arr_(:,1)=CutFilter_Iarr(((trans_arr(:,1)+endJ+1)*filtered),cou,bufI)-(endJ+1)
      trans_arr_(:,2)=CutFilter_Iarr(((trans_arr(:,2)+endJ+1)*filtered),cou,bufI)-(endJ+1)
      trans_arr_(:,3)=CutFilter_Iarr(((trans_arr(:,3)+endJ+1)*filtered),cou,bufI)-(endJ+1)
      trans_arr_(:,4)=CutFilter_Iarr(((trans_arr(:,4)+endJ+1)*filtered),cou,bufI)-(endJ+1)
      !deallocate(DIP_STRS,Rot_strs,trans_arr,trans_en_arr)
      do i = 1,bufI
         if((abs(trans_arr_(i,2))>trans_arr_(i,1)).or.(abs(trans_arr_(i,4))>trans_arr_(i,3)))then
            stop 'iz wronk'
         end if
      end do
      
      ! !Lorentzian
      ! if(presflag.eqv..true..and.dopflag.eqv..false.)then
         ! profPoint=>Profile_Lorentz
         ! intenPoint=>Intensity_Lorentz
      ! !Gaussian
      ! else if(presflag.eqv..false..and.dopflag.eqv..true.)then
         ! profPoint=>Profile_Gauss
         ! intenPoint=>Intensity_Gauss
      ! !Voigt, not implemented
      ! else if(presflag.eqv..true..and.dopflag.eqv..true.)then
         ! profPoint=>Profile_Voigt_wrap
         ! intenPoint=>Intensity_Voigt
      ! end if
      
      !call Insertion_sort_abs(rot_strs_,bufI,order)
      !call Reorder_arr(trans_ens_,bufI,order)
      !call Reorder_arr_int_4(trans_arr_,bufI,order)
      
      ! call Insertion_sort(trans_ens_,bufi,order)
      ! call Reorder_arr(rot_strs_,bufI,order)
      ! call Reorder_arr(dip_strs_,bufI,order)
      ! call Reorder_arr_int_4(trans_arr_,bufI,order)
      
      if(MW)then
         rot_strs_=dip_strs_
      end if
      finalSize=NINT((fmax-fmin)/resolution)
      allocate(x(finalSize),y(finalSize),bufr(finalSize))
      do i = 1,finalSize
         x(i)=fmin+resolution*i
      end do
      y=0d0
      
      !$OMP PARALLEL PRIVATE(idx1,idx2,abscoeff,bufr,i,dwidth) NUM_THREADS(4)
      !write(6,'(I2)')omp_get_thread_num()
      if(presflag.and.dopflag)then
         do i = 1,bufI
            idx1=Calc_Frac_index(trans_arr_(i,1),trans_arr_(i,2))
            idx2=Calc_Frac_index(trans_arr_(i,3),trans_arr_(i,4))
            dwidth=Doppler_width(trans_ens_(i),temp,mass*1D-3/NA)
            abscoeff=Abs_coeff(trans_ens_(i),Fracpop(idx1),trans_arr_(i,1)*2+1,Fracpop(idx2),trans_arr_(i,3)*2+1,rot_strs_(i)*(AU2SI_debye)**2,.true.,MW,flag_absem)
            do j=1,finalSize
               y(j)=y(j)+abscoeff*Profile_Voigt(x(j),trans_ens_(i),pwidth,dwidth,-10,5d-2,10)
            end do
         end do
      else if(presflag)then
         do i = 1,bufI
            idx1=Calc_Frac_index(trans_arr_(i,1),trans_arr_(i,2))
            idx2=Calc_Frac_index(trans_arr_(i,3),trans_arr_(i,4))
            abscoeff=Abs_coeff(trans_ens_(i),Fracpop(idx1),trans_arr_(i,1)*2+1,Fracpop(idx2),trans_arr_(i,3)*2+1,rot_strs_(i)*(AU2SI_debye)**2,.true.,MW,flag_absem)
            
            !$OMP WORKSHARE
            bufr=Profile_Lorentz(x,trans_ens_(i),pwidth,inten)
            y=y+abscoeff*bufr
            !$OMP END WORKSHARE
         end do
      else if(dopflag)then
         !$OMP DO
         do i = 1,bufI
            idx1=Calc_Frac_index(trans_arr_(i,1),trans_arr_(i,2))
            idx2=Calc_Frac_index(trans_arr_(i,3),trans_arr_(i,4))
            dwidth=Doppler_width(trans_ens_(i),temp,mass*1D-3/NA)
            abscoeff=Abs_coeff(trans_ens_(i),Fracpop(idx1),trans_arr_(i,1)*2+1,Fracpop(idx2),trans_arr_(i,3)*2+1,rot_strs_(i)*(AU2SI_debye)**2,.true.,MW,flag_absem)
            bufr=Profile_Gauss(x,trans_ens_(i),dwidth,inten)
            !$OMP CRITICAL
            y=y+abscoeff*bufr
            !$OMP END CRITICAL
         end do
         !$OMP END DO
      end if
      !$OMP END PARALLEL
      ! do i = 1,bufI
         ! idx1=Calc_Frac_index(trans_arr_(i,1),trans_arr_(i,2))
         ! idx2=Calc_Frac_index(trans_arr_(i,3),trans_arr_(i,4))
         ! dwidth=Doppler_width(trans_ens_(i),temp,mass*1D-3/NA)
         ! abscoeff=Abs_coeff(trans_ens_(i),Fracpop(idx1),trans_arr_(i,1)*2+1,Fracpop(idx2),trans_arr_(i,3)*2+1,rot_strs_(i)*(AU2SI_debye)**2,.true.,MW)
         ! if(abscoeff==0d0)cycle
         ! if(presflag.and.dopflag)then
            ! do j=1,finalSize
               ! y(j)=y(j)+abscoeff*Profile_Voigt(x(j),trans_ens_(i),pwidth,dwidth,-10,5d-2,10)
            ! end do
         ! else if(presflag)then
            ! y=y+abscoeff*Profile_Lorentz(x,trans_ens_(i),pwidth,inten)
         ! else if(dopflag)then
            ! y=y+abscoeff*Profile_Gauss(x,trans_ens_(i),dwidth,inten)
         ! end if
      ! end do
      
      
      if(MW)then
         filee=outputfile(1:outputLength)//'.sprMW_'//trim(tempChar)//'K'
      else
         filee=outputfile(1:outputLength)//'.spr_'//trim(tempChar)//'K'
      end if
      open(unitt,file=filee)
      call Write_Spectrum(x,y,finalSize,finalSize+1)
      close(unitt)
      !write(6,*)
      !write(6,230,advance='no')''
230   format(A45)   
      write(6,*)'WRITTEN '//filee
      ! deallocate(x,y,dip_strs_,trans_ens_,trans_arr_,rot_strs_,order)
      deallocate(x,y,dip_strs_,trans_ens_,trans_arr_,rot_strs_)
      return
      
   end subroutine CALCULATE_SPECTRUM
      
      
   subroutine Write_Spectrum(x,y,n,idx)
      integer(4) n,idx,i
      real(8) x(n),y(n)
      
      do i = 1,n
         write(unitt,1325)x(i),y(i)
      end do
      
1325  format(2(E25.15E3))     

      
      !call ARR2D_2_FILE_spec(xy,n,2,idx,unitt)
   end subroutine Write_Spectrum
      
   !writes the lines to that god awful JPL .cat format, hooray for cryptic symbols and intensity units
   subroutine ToJPLCAT()
      integer(4) i,Km1_1,Km1_2,K1_1,K1_2,j1,j2,t1,t2,bufI(3),idx1,idx2,orderR(cou)
      real(8) jplInten,trans_en_arr_(cou),fp1,fp2
      open(100,file=outputfile(1:outputLength)//'.cat')
      
      
      trans_en_arr_=dabs(trans_en_arr)
      call Insertion_sort(trans_en_arr_,cou,orderR)
      
      
      do i=1,cou
         j1=trans_arr(i,1)
         t1=trans_arr(i,2)
         j2=trans_arr(i,3)
         t2=trans_arr(i,4)
         idx1=Calc_Frac_index(trans_arr(i,1),trans_arr(i,2))
         idx2=Calc_Frac_index(trans_arr(i,3),trans_arr(i,4))
         bufI=OldToNewNotation(j1,t1)
         Km1_1=bufI(2)
         K1_1=bufI(3)
         bufI=OldToNewNotation(j2,t2)
         Km1_2=bufI(2)
         K1_2=bufI(3)
         fp1=Fracpop(idx1)
         fp2=Fracpop(idx2)
         
         if(fp1>fp2)then
            jplInten=4.16231D-5*dabs(trans_en_arr(i))*1D3*dip_strs(i)*(2*j1+1)*(fp1-fp2)
         else
            jplInten=4.16231D-5*dabs(trans_en_arr(i))*1D3*dip_strs(i)*(2*j1+1)*(fp2-fp1)
         end if
         write(100,2000)dabs(trans_en_arr(i)*1D3),0d0,log10(jplInten),3,0d0,trans_arr(i,3)*2+1,0,1404,j1,Km1_1,K1_1,0,0,0,j2,Km1_2,K1_2,0,0,0
      end do
      
2000  format(F13.4,F8.4,F8.4,I2,F10.4,I3,I7,I4,6I2,6I2)
      close(100)
   end subroutine ToJPLCAT
      
   !some useless function usage
   subroutine Scripting()
      integer(4) m1,m2,j1,j2,t1,t2,q1,q2,r1,r2,rank1,rank2,k1,k2,si
      real(8),allocatable :: evec1(:,:),evec2(:,:)
      complex(8) buf1,buf2,buf3,buf4
      real(8) buf5,buf6,arr1(11),arr2(14),arr1y(11),arr2y(14)
      real(8),allocatable :: arr3(:),arr3y(:)
      logical info
      
      j1=4
      j2=5
      t1=-2
      t2=-1
      allocate(evec1(2*J1+1,2*J1+1),evec2(2*J2+1,2*J2+1))
      call SLICE_EVEC(evec1,J1)
      call SLICE_EVEC(evec2,J2)
      buf1=0d0
      buf2=0d0
      buf3=0d0
      buf4=0d0
      buf5=0d0
      buf6=0d0
      
      ! !identity of sumMM'(<JKM|mu|J'K'M'><J'K'M'|mu|JKM>)=6*sumM(<JKM|muX|J'K'M+1><J'K'M+1|muX|JKM>)
      ! do m1=-j1,j1
         ! do m2=m1-1,m1+1,1
            ! buf1=buf1+TRANS_EL_X(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_EL_X(evec2,evec1,j2,j1,t2,t1,m2,m1)+TRANS_EL_Y(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_EL_Y(evec2,evec1,j2,j1,t2,t1,m2,m1)+TRANS_EL_Z(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_EL_Z(evec2,evec1,j2,j1,t2,t1,m2,m1)
         ! end do
      ! end do
      ! buf1=buf1/dble(2*J1+1)
      ! do m1=-j1,j1
         ! buf2=buf2+TRANS_EL_X(evec1,evec2,j1,j2,t1,t2,m1,m1+1)*TRANS_EL_X(evec2,evec1,j2,j1,t2,t1,m1+1,m1)
      ! end do
      ! buf2=buf2*6d0/dble(2*J1+1)
      
      ! do m1=-j1,j1
         ! do m2=m1-1,m1+1,1
            ! buf3=buf3+TRANS_EL_X(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_MAG_X(evec2,evec1,j2,j1,t2,t1,m2,m1)+TRANS_EL_Y(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_MAG_Y(evec2,evec1,j2,j1,t2,t1,m2,m1)+TRANS_EL_Z(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_MAG_Z(evec2,evec1,j2,j1,t2,t1,m2,m1)
         ! end do
      ! end do
      ! buf3=buf3/dble(2*J1+1)
      ! do m1=-j1,j1
         ! buf4=buf4+TRANS_EL_X(evec1,evec2,j1,j2,t1,t2,m1,m1+1)*TRANS_MAG_X(evec2,evec1,j2,j1,t2,t1,m1+1,m1)
      ! end do
      ! buf4=buf4*6d0/dble(2*J1+1)
      
      ! buf1=0d0
      ! do m1=-j1,j1
         ! do m2=m1-1,m1+1,1
            ! buf1=buf1+TRANS_EL_X(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_QUAD_YZ(evec2,evec1,j2,j1,t2,t1,m2,m1)+TRANS_EL_Y(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_QUAD_XZ(evec2,evec1,j2,j1,t2,t1,m2,m1)
         ! end do
      ! end do
      ! buf1=1.5d0*buf1
      
      ! buf2=0d0
      ! do m1=-j1,j1
         ! buf2=buf2+TRANS_EL_X(evec1,evec2,j1,j2,t1,t2,m1,m2)*TRANS_QUAD_YZ(evec2,evec1,j2,j1,t2,t1,m2,m1)
      ! end do
      ! buf2=6d0*buf2
      
      
      m1=2
      m2=1
      k1=-3
      k2=-2
      
      rank1=1
      rank2=1
      
      do q1=-rank1,rank1
         do q2=-rank1,rank1
            do r1=-rank2,rank2
               do r2=-rank2,rank2
                  
                  buf5 = WIGNER_MATEL(j1,j2,k1,k2,m1,m2,q1,q2,rank1)*WIGNER_MATEL(j2,j1,k2,k1,m2,m1,r1,r2,rank2)
                  buf6 = WIGNER_MATEL_2(rank1,q1,q2,rank2,r1,r2,j1,j2,k1,k2,m1,m2)
                  if((abs(buf5)>=1D-7).OR.(abs(buf6)>=1D-7))then
                     m1=m1+0
                  end if
               end do
            end do
         end do
      end do
      deallocate(evec1,evec2)
      
      arr1=(/2d0,4d0,6d0,8d0,10d0,12d0,0d0,0d0,0d0,0d0,0d0/)
      arr2=(/7.5d0,9.5d0,11.5d0,13.5d0,15.5d0,17.5d0,19.5d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0/)
      call random_number(arr1y)
      call random_number(arr2y)
      
      si = Intervals_overlap_size(arr1,11,6,arr2,14,7,1d0)
      allocate(arr3(si),arr3y(si))
      info=.true.
      call Band_overlap(arr1,arr1y,11,6,arr2,arr2y,14,7,arr3,arr3y,si,1,1d0,info)
      arr3=0d0
      arr3y=0d0
      call Band_overlap(arr2,arr2y,14,7,arr1,arr1y,11,6,arr3,arr3y,si,1,1d0,info)
      deallocate(arr3,arr3y)
      si = Intervals_overlap_size(arr1,11,6,arr1,11,6,1d0)
      allocate(arr3(si),arr3y(si))
      arr3=0d0
      arr3y=0d0
      call Band_overlap(arr1,arr1y,11,6,arr1,arr1y,11,6,arr3,arr3y,si,1,1d0,info)
      deallocate(arr3,arr3y)
      
      
      do j1=0,5
         do j2=j1-1,j1+1
            do k1=-j1,j1
               do k2=-j2,j2
                  do m1=-j1,j1
                     do m2=-j2,j2
                        buf5=-1d0/sqrt(2d0)*(WIGNER_MATEL(j1,j2,k1,k2,m1,m1+1,1,0,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m1+1,-1,0,1))
                        buf5=buf5*1d0
                     end do
                  end do
               end do
            end do
         end do
      end do

   end subroutine Scripting
         
   !analytical functions derived by salzmann
   !http://dx.doi.org/10.1063/1.474598
   subroutine SALZMAN_COMPARISON()
      real(8) Ds(18),Rs(18),buf
      integer(4) transs(18,4),i
      
      Ds=0d0
      Rs=0d0
      transs=0
      
      Rs(1)=1d0/2d0*dip(3)*(gt(1,2)-gt(2,1))
      Ds(1)=dip(3)**2
      transs(1,1)=0
      transs(1,2)=0
      transs(1,3)=1
      transs(1,4)=-1
      
      Rs(2)=1d0/2d0*dip(1)*(gt(2,3)-gt(3,2))
      Ds(2)=dip(1)**2
      transs(2,1)=0
      transs(2,2)=0
      transs(2,3)=1
      transs(2,4)=0
      
      Rs(3)=1d0/2d0*dip(2)*(gt(3,1)-gt(1,3))
      Ds(3)=dip(2)**2
      transs(3,1)=0
      transs(3,2)=0
      transs(3,3)=1
      transs(3,4)=1
      
      Rs(4)=-1d0/4d0*dip(2)*(gt(3,1)+gt(1,3))
      Ds(4)=dip(2)**2/2d0
      transs(4,1)=1
      transs(4,2)=-1
      transs(4,3)=1
      transs(4,4)=0
      
      Rs(5)=1d0/4d0*dip(1)*(gt(2,3)+gt(3,2))
      Ds(5)=dip(1)**2/2d0
      transs(5,1)=1
      transs(5,2)=-1
      transs(5,3)=1
      transs(5,4)=1
      
      Rs(6)=-1d0/4d0*dip(3)*(gt(1,2)+gt(2,1))
      Ds(6)=dip(3)**2/2d0
      transs(6,1)=1
      transs(6,2)=0
      transs(6,3)=1
      transs(6,4)=1
      
      Rs(7)=1d0/4d0*dip(1)*(gt(2,3)-3d0*gt(3,2))
      Ds(7)=dip(1)**2/2d0
      transs(7,1)=1
      transs(7,2)=-1
      transs(7,3)=2
      transs(7,4)=-1
      
      Rs(8)=1d0/4d0*dip(2)*(3d0*gt(3,1)-gt(1,3))
      Ds(8)=dip(2)**2/2d0
      transs(8,1)=1
      transs(8,2)=-1
      transs(8,3)=2
      transs(8,4)=0
      
      Rs(9)=1d0/4d0*dip(3)*(3d0*gt(1,2)-gt(2,1))
      Ds(9)=dip(3)**2/2d0
      transs(9,1)=1
      transs(9,2)=0
      transs(9,3)=2
      transs(9,4)=-1
      
      Rs(10)=1d0/4d0*dip(2)*(gt(3,1)-3d0*gt(1,3))
      Ds(10)=dip(2)**2/2d0
      transs(10,1)=1
      transs(10,2)=0
      transs(10,3)=2
      transs(10,4)=1
      
      Rs(11)=1d0/4d0*dip(3)*(gt(1,2)-3d0*gt(2,1))
      Ds(11)=dip(3)**2/2d0
      transs(11,1)=1
      transs(11,2)=1
      transs(11,3)=2
      transs(11,4)=0
      
      Rs(12)=1d0/4d0*dip(1)*(3d0*gt(2,3)-gt(3,2))
      Ds(12)=dip(1)**2/2d0
      transs(12,1)=1
      transs(12,2)=1
      transs(12,3)=2
      transs(12,4)=1
      
      Rs(13)=-1d0/4d0*dip(3)*(gt(1,2)+gt(2,1))
      Ds(13)=dip(3)**2/6d0
      transs(13,1)=2
      transs(13,2)=-1
      transs(13,3)=2
      transs(13,4)=0
      
      Rs(14)=1d0/4d0*dip(1)*(gt(2,3)+gt(3,2))
      Ds(14)=dip(1)**2/6d0
      transs(14,1)=2
      transs(14,2)=-1
      transs(14,3)=2
      transs(14,4)=1
      
      Rs(15)=-1d0/4d0*dip(2)*(gt(3,1)+gt(1,3))
      Ds(15)=dip(2)**2/6d0
      transs(15,1)=2
      transs(15,2)=0
      transs(15,3)=2
      transs(15,4)=1
      
      Rs(16)=1d0/2d0*dip(2)*(gt(3,1)-gt(1,3))
      Ds(16)=dip(2)**2/3d0
      transs(16,1)=2
      transs(16,2)=-1
      transs(16,3)=3
      transs(16,4)=0
      
      Rs(17)=1d0/2d0*dip(1)*(gt(2,3)-gt(3,2))
      Ds(17)=dip(1)**2/3d0
      transs(17,1)=2
      transs(17,2)=0
      transs(17,3)=3
      transs(17,4)=0
      
      Rs(18)=1d0/2d0*dip(3)*(gt(1,2)-gt(2,1))
      Ds(18)=dip(3)**2/3d0
      transs(18,1)=2
      transs(18,2)=1
      transs(18,3)=3
      transs(18,4)=0
      
      Rs=nucm_au*Rs
      
      open(unitt,file='COMPARISON.TAB')
      write(unitt,663)
      write(unitt,660)
660   format(60(1h-))
      
      do i = 1,18
      if(D_EQUAL(Ds(i),0.0d0).eqv..false.) then
         buf = 4.0d0*Rs(i)/Ds(i)
      else
         buf = 0.0d0
      end if
      
      
      write(unitt,661)i,0d0,Ds(i),Rs(i),buf,transs(i,1),transs(i,2),transs(i,3),transs(i,4),0d0
      end do
661   format(i7,f15.5,3(' ',E15.7E3),4i3,'    ',E15.7E3)
663   format('                  freq              D              R           4R/D J1 T1 J2 T2   Probab',/,'transition         GHz           au^2           au^2')
      close(unitt)
   end subroutine SALZMAN_COMPARISON
   
   !equality check of two doubles
   function D_EQUAL(num1,num2) result(res)
      real(8) num1, num2
      logical res
      
      if(abs(num1-num2)<outtol) then
         res = .true.
      else
         res = .false.
      end if
   end function
   
   
   !functionified intrinsic subroutine
   function DRAND() result(res)
      real(8) res
      call RANDOM_NUMBER(res)
   end function DRAND
   
   !inner function
   !calculates dimensions of the full hamiltonian in J range
   function CALCULATE_HAMDIM(LJ,HJ) result (res)
      integer(4), intent(in) :: LJ,HJ
      integer(4) res,arr(HJ-LJ+1),i,leng
   
      leng=HJ-LJ+1
      call HAM_DIM_SEQUENCE(LJ,HJ,arr)
      res = 0
      do i = 1,leng
         res = res + arr(i)
      end do
   end function CALCULATE_HAMDIM
   
   !inner function
   !calculate full hamiltonian for specified J range and diagonalize every J block seperately
   subroutine CALCULATE_HAM()
      integer(4) ii,idx,idx2
      real(8),allocatable :: E(:,:),rbuf(:)
      ! allocate(Ham_full(dime_full,dime_full),Evec_full(dime_full,dime_full),Eval_full(dime_full))
      ! Ham_full = 0.0d0
      ! Evec_full= 0.0d0
      ! eval_full= 0.0d0
      !call FULL_HAMILTONIAN_ASS(abc(1),abc(2),abc(3),0,endJ,rep,Ham_full,dime_full,lefthandedFlag)
      allocate(evec_full_list(endJ-startJ+1),eval_full_list(endJ-startJ+1))
      car = 1
      
      do i = startJ,endJ
         dime = i*2+1
         allocate(Ham(dime,dime),Eval(dime),Evec(dime,dime),E(dime,dime),rbuf(dime))
         E=0.0d0
         Ham = 0.0d0
         evec = 0.0d0
         eval = 0.0d0
         call ASS_ROTOR(abc(1),abc(2),abc(3),i,rep,Ham,dime,lefthandedFlag)
         Evec=Ham
         call DIAG_SYM(Eval,Evec,dime,info,.true.)
         if(info/=0) STOP 'Error at diagonalization'
         do ii = -i,+i
            E(ii+i+1,ii+i+1)=1d0
         end do
         do ii = -i,+i
            idx=ii+i+1
            rbuf=MATMUL(Ham-eval(idx)*E,evec(:,idx))
         end do
         call EVAL_TO_ENERGY(Eval,dime,abc(1),abc(2),abc(3),i)
         allocate(evec_full_list(car)%arr(dime,dime),eval_full_list(car)%arr(dime))
         evec_full_list(car)%arr = evec
         eval_full_list(car)%arr = eval
         !call COPY_ARRAY2D(Evec_full,dime_full,dime_full,Evec,dime,dime,car,car)
         !call COPY_ARRAY1D(Eval_full,dime_full,Eval,dime,car)
         deallocate(Ham,Eval,Evec,E,rbuf)
         car = car + 1
      end do
   end subroutine CALCULATE_HAM
   
   !get energy of a given J,T state (expecting M degenerate)
   function State_energy(J,T) result (res)
      integer(4) J,T
      real(8) res,arr(2*J+1)
      
      call SLICE_EVAL(arr,J)
      res = arr(T+J+1)
   end function State_energy
   
   !like factorial except addition
   function summ(num) result (res)
      integer(4) num,res,i
      res = 0
      if(num<=0)return
      
      do i = 1,num
         res = res + i
      end do
   end function summ
   
   !number of possible transitions for a pair of Js
   function Num_transitions(J1,J2) result (res)
      integer(4) res,J1,J2,cou1,cou2
      
      if(j1==j2)then
         res = summ(2*j1)
         return
      end if
      
      cou1=2*J1+1
      cou2=2*J2+1
      if(J1==0 .and. J2==0)then
         res = 0
         return
      end if
      res=cou2*cou1
   end function Num_transitions
   
   !calculate RCD from 0 to Jend
   subroutine CALCULATE_RCD_ALL()
      integer(4) J1,T1,T2,i,m,n,idx,Js(dime_full),Km1_1,Km1_2,K1_1,K1_2,denominator,curJ
      real(8) buf(10),time1,time2,evals(dime_full)
      character(80) chars,FN
      if(writeMomentsFlag)then
         chars=adjustl((adjustr(outputfile)//'_moments'))
         open(667,file=chars)
         write(667,615)'  Ener(GHz)     dipX(Deb)     dipY(Deb)     magX(Deb)     magY(Deb)  qdXZ(Deb.ANG)  qdYZ(Deb.ANG)  J1 K-1  K1  M1  J2 K-1  K1  M2'
         write(667,615)'_______________________________________________________________________________________________________________________________'
      end if
615   format(A127)   
      car=1
      cou=0
      idx=0
      do i = startJ,endJ
         do m = 1,2*i+1
            idx=idx+1
            Js(idx)=i
         end do
      end do
      allocate(Fracpop(dime_full))
      n=1
      do i = startJ,endJ
         do m = 1,2*i+1
            evals(n)=eval_full_list(i-startJ+1)%arr(m)
            n=n+1
         end do
      end do
      Fracpop=Calc_Frac_Populations(evals*1d9,Js,dime_full,Q,temp)
      

      
      do J1=startJ,endJ-1
            cou = cou + Num_transitions(J1,J1+1) + Num_transitions(J1,J1)
      end do
      cou=cou+summ(2*endj)
      allocate(ROT_STRS(cou),DIP_STRS(cou),TRANS_PROBS(cou),trans_arr(cou,4),trans_en_arr(cou))
      if(PreviousCalcFlag)then
         open(30,file=outputfile(1:outputLength)//'.trn')
         do i = 1,cou
660         continue
            if(HumanReadableFlag)then
               read(30,663,err=660,end=664)bufI,trans_en_arr(i),DIP_STRS(i),ROT_STRS(i),buf(1),trans_Arr(i,1),Km1_1,K1_1,trans_Arr(i,3),Km1_2,K1_2,buf(2),buf(3),buf(4)!,TRANS_PROBS(i),trans_abs(i),trans_probs_MW(i)
            else
               read(30,661,err=660,end=664)bufI,trans_en_arr(i),DIP_STRS(i),ROT_STRS(i),buf(1),trans_Arr(i,1),Km1_1,K1_1,trans_Arr(i,3),Km1_2,K1_2,buf(2),buf(3),buf(4)!,TRANS_PROBS(i),trans_abs(i),trans_probs_MW(i)
            end if
            trans_Arr(i,2)=Km1_1-K1_1
            trans_Arr(i,4)=Km1_2-K1_2
         end do
661      format(i7,E20.12,3(1X,E14.7E2),6i4,1X,E15.7E2,E15.7E2,E15.7E2)
663      format(i7,F15.8,3(1X,F14.7),6i4,1X,F15.7,F15.7,F15.7)
664      continue
         !if(strengthsUn=='au^2   ')then
         DIP_STRS=DIP_STRS*SI2AU_debye**2
         ROT_STRS=ROT_STRS*SI2AU_debye**2
         !end if
         close(30)
         !call WriteOutput()
         return
      end if
      
      if(file_detailtab(1))then
         if(DetailOutputFlag)then
            open(30,file=outputfile(1:outputLength)//'_DETAILN.TAB')
         else
            open(30,file=outputfile(1:outputLength)//'_DETAIL.TAB')
         end if
      end if
      write(6,*)
      write(6,2018)'J1  - J2'
      denominator=NINT(dble(endJ-startJ)/5d0)
      call CPU_TIME(time1)
      curJ=startJ
      do J1=startJ,endJ-1
         if(J1/=0)then
            call CALCULATE_RCD_JPAiR(J1,J1)
         end if
         !write(6,2017,advance='no')'                                        '
         if(mod(J1,denominator)==0 .and. J1/=0)then
            write(6,2015,advance='no')curJ,' - ',J1,' ...'
         end if
         call CALCULATE_RCD_Jpair(J1,J1+1)
         if(mod(J1,denominator)==0 .and. J1/=0)then
            call CPU_TIME(time2)
            write(6,2016)(time2-time1),' seconds'
            call CPU_TIME(time1)
            curJ=J1
         end if
         !if(J1==0)cycle
         !call CALCULATE_RCD_JPAiR(J1,J1)
      end do
     ! write(6,2017,advance='no')'                                        '
      ! write(6,2015,advance='no')endJ,' =>',endJ,'...'
      ! call CPU_TIME(time1)
      write(6,2015,advance='no')curJ,' - ',endJ,' ...'
      call CALCULATE_RCD_JPAiR(endJ,endJ)
      call CPU_TIME(time2)
      write(6,2016)(time2-time1),' seconds'
      ! call CPU_TIME(time2)
      ! write(6,2016)(time2-time1),' seconds'
      close(30)
2015  format(I2,A4,I2,A4)     
2016  format(1F7.3,A8) 
2014  format(A1,I3,A1)
2017  format(A40)      
2018  format(A8)
      close(667)
      call WriteOutput()
   end subroutine CALCULATE_RCD_ALL
      
      
   !uuuggggghhhhhhhhhhh
   !80 char limit is bad and you should feel bad for enforcing it
   function CheckJPLLetters(FN) result(res)
      character(24) FN
      character(25) checkStr
      integer(4) i
      logical res
      
      checkStr='ABCDEFGHIJKLMNOPQRSTUVWYZ'
      
      res = .true.
      do i=1,25
         if(index(FN,checkStr(i:i))/=0)then
            res = .false.
            return
         end if
      end do
      
      
   end function CheckJPLLetters
      
   subroutine LoadJPL()
      integer(4) n,i,m,j,ii
      character(80) FN
      character(12) tr
      real(8) bufR(10)
      integer(4) bufI(10),A(2)
      
      if(index(JPLFile,'.cat')==0)return
      
      open(unitt,file=JPLFile)
      
      n=0
      m=0
1999  read(unitt,2002,end=2001)FN
      read(FN(62:63),2003)A(1)
      read(FN(74:75),2003)A(2)
      if(A(1) == 0 .and. A(2) == 0)then
         m=m+1
      end if
      n=n+1
      goto 1999
2001  rewind(unitt)
      j=1
      allocate(trans_arr_JPL(6,m),trans_en_arr_JPL(m),inten_JPL(m))
      do i=1,n
         read(unitt,2002)FN
         read(FN(62:63),2003)A(1)
         read(FN(74:75),2003)A(2)
         !just why? because 80 character "limit"? that is just so stoopid
         if(A(1) == 0 .and. A(2) == 0 .and. CheckJPLLetters(FN(56:80)))then
            backspace(unitt)
            
            read(unitt,2000)trans_en_arr_JPL(j),bufR(1),inten_JPL(j),bufI(1),bufR(2),bufI(2),bufI(3),bufI(4),trans_arr_JPL(1,j),trans_arr_JPL(2,j),trans_arr_JPL(3,j),bufI(5),bufI(6),bufI(7),trans_arr_JPL(4,j),trans_arr_JPL(5,j),trans_arr_JPL(6,j),bufI(8),bufI(9),bufI(10)
            j=j+1
         end if
      end do
      close(unitt)
      inten_JPL=10.0d0**inten_JPL
      trans_en_arr_JPL=trans_en_arr_JPL*1d-3
2000  format(F13.4,F8.4,F8.4,I2,F10.4,I3,I7,I4,6I2,6I2)
2002  format(A80)
2003  format(I2)
   end subroutine LoadJPL
      
      
   function IARR_areEqual(arr1,arr2,n)result(res)
      integer(4) n,i
      integer(4) arr1(n),arr2(n)
      logical res
      
      res=.true.
      do i = 1,n
         if(arr1(i)/=arr2(i))then
            res = .false.
            return
         end if
      end do
      continue
   end function IARR_areEqual
      
   !writes neat file with transition energies, dipole strengths, rotational strengths and more!
   subroutine WriteOutput()
      real(8) rbuf,buf,transProb,Rot_strs_(cou),Dip_strs_(cou),trans_en_arr_(cou),fp1,fp2,jplInten,en1,en2,dipstrMax,abscoeff,abscoeffMW
      real(8),allocatable :: eval1(:),eval2(:)
      integer(4) i,j1,j2,t1,t2,idx1,idx2,bufI(3),Km1_1,Km1_2,K1_1,K1_2,j,bufi2
      character(7) energyUn,strengthsUn
      character(14) rotStrengthUn
      
      if(.not.file_transitions(1))return
      Rot_strs_=Rot_strs
      Dip_strs_=Dip_strs
      trans_en_arr_=trans_en_arr
      
      energyUn='GHz    '
      strengthsUn='au^2   '
      if(OutUnitsStr=='DEB')then
                                        
         Rot_strs_=Rot_strs_*AU2SI_debye**2 !goddamn units, uuuggggghhhhhhhhhhh
         Dip_strs_=Dip_strs_*AU2SI_debye**2
         strengthsUn='Debye^2'
         rotStrengthUn='10^-44 esu2cm2'
      else
         continue
      end if
      
      if(OutUnitsEn=='CM1')then
         trans_en_arr_=trans_en_arr_*1D9*Hz_2_cm
         energyUn='cm^-1  '
      else
         continue
      end if
      call LoadJPL()
      
      if(file_transitions(1))then
         open(unitt,file=outputfile(1:outputLength)//'.trn')
      end if
      
      if(index(JPLFile,'.cat')/=0)then
         open(unitt+2,file=outputfile(1:outputLength)//'_JPLcomparison')
         write(unitt+2,658)'Frequency (GHz)','JPL Frequency','Int (nm^2 MHz)','JPL Intensity','J1','K-1','K1','J2','K-1','K1'
      end if
      if(.not.PreviousCalcFlag)then
658   format(4A17,6A3)
      if(file_transitions(5))then
      write(unitt,662)energyUn,strengthsUn,strengthsUn
662   format('                       freq              D              R           4R/D  J1 K-1  K1  J2 K-1  K1       JPL_INTEN      Abs.coeff',/,'transition              ',A7,'    ',A7,' ',A14)
      write(unitt,660)
      end if
660   format(180(1h-))
      !rbuf=maxval(TRANS_PROBS,dim=1)
      
      !if(file_prn(1))open(666,file=outputfile(1:outputLength)//'_D.PRN')
      !if(file_prn(1))open(667,file=outputfile(1:outputLength)//'_R.PRN')
      dipstrMax = maxval(dip_strs_)
      do i = 1,cou
      if(dip_strs_(i)<outTol.or.dabs(rot_strs_(i))<outTol)cycle
      if(.not.D_EQUAL(DIP_STRS_(i),0.0d0)) then
         buf = 4.0d0*ROT_STRS_(i)/DIP_STRS_(i)
      else
         buf = 0.0d0
      end if
      if(file_transitions(6))then
         if((dip_strs_(i)<dipstr_cutoff.and..not.dipstr_cutoff_percentual))cycle
         if((dip_strs_(i)<dipstrMax*dipstr_cutoff.and.dipstr_cutoff_percentual) .or. dabs(rot_strs_(i)) < rotstr_cutoff .or. dabs(buf) < kuhnpar_cutoff)cycle
      end if
      j1=trans_arr(i,1)
      t1=trans_arr(i,2)
      j2=trans_arr(i,3)
      t2=trans_arr(i,4)
      
      bufI=OldToNewNotation(j1,t1)
      Km1_1=bufI(2)
      K1_1=bufI(3)
      bufI=OldToNewNotation(j2,t2)
      Km1_2=bufI(2)
      K1_2=bufI(3)
      
      idx1=Calc_Frac_index(j1,t1)
      idx2=Calc_Frac_index(j2,t2)
      
      allocate(eval1(2*j1+1),eval2(2*j2+1))
      call SLICE_EVAL(eval1,J1)
      call SLICE_EVAL(eval2,J2)
      
      en1=eval1(T1+J1+1)
      en2=eval2(T2+J2+1)
      
      fp1=exp(-en1*1D9*h/kb/temp)
      fp2=exp(-en2*1D9*h/kb/temp)
      ! if(trans_en_arr_(i)<0d0)then
         ! trans_en_arr_(i)=dabs(trans_en_arr_(i))
      ! end if
      
      jplInten=4.16231D-5*dabs(trans_en_arr_(i))*1D3*dip_strs_(i)*dble(2*j1+1)*dabs(fp1-fp2)/Q
      if(jplInten>0d0)then
         jplInten = log10(jplInten)
      else
         jplInten = 0d0
      end if
      !transprob=Fracpop(idx1)/dble(J1*2+1)-Fracpop(idx2)/dble(J2*2+1)
      if(trans_en_arr_(i)<0d0)then
         bufI2 = j1
         j1=j2
         j2=bufi2
         
         bufI2=Km1_1
         Km1_1=Km1_2
         Km1_2=bufi2
         
         bufI2=K1_1
         K1_1=K1_2
         K1_2=bufi2
         
         trans_en_arr_(i)=dabs(trans_en_arr_(i))
      end if
      
      abscoeff=Abs_coeff(dabs(trans_en_arr_(i)),fp1,j1*2+1,fp2,j2*2+1,rot_strs_(i),.true.,.false.,flag_absem)
      abscoeffMW=Abs_coeff(dabs(trans_en_arr_(i)),fp1,j1*2+1,fp2,j2*2+1,dip_strs_(i),.true.,.true.,flag_absem)
      if(file_transitions(4))then
         write(unitt,663,advance='no')i,trans_en_arr_(i),DIP_STRS_(i),ROT_STRS_(i),buf,j1,Km1_1,K1_1,j2,Km1_2,K1_2
         
         if(file_transitions(2))then
            write(unitt,664,advance='no')jplInten
         end if
         if(file_transitions(3))then
            write(unitt,665,advance='no')abscoeffMW,abscoeff
         end if
         write(unitt,*)
      else
         
         write(unitt,661,advance='no')i,trans_en_arr_(i),DIP_STRS_(i),ROT_STRS_(i),buf,j1,Km1_1,K1_1,j2,Km1_2,K1_2
         
         if(file_transitions(2))then
            write(unitt,6612,advance='no')jplInten
         end if
         if(file_transitions(3))then
            write(unitt,6613,advance='no')abscoeffMW,abscoeff
         end if
         write(unitt,*)
      end if
      
663   format(i7,F15.8,3(' ',F14.8),6i4,' ')
664   format(F15.8)
665   format(2F15.8)

661   format(i7,E20.13,3(' ',E14.8E2),6i4,' ')
6612  format(E15.7E2)
6613  format(2E15.7E3)
      if(index(JPLFile,'.cat')/=0)then
      do j=1,size(trans_en_arr_JPL)
         if(IARR_areEqual([j1,km1_1,k1_1,j2,km1_2,k1_2],trans_arr_JPL(:,j),6))then
            write(unitt+2,659)dabs(trans_en_arr(i)),trans_en_arr_JPL(j),jplInten,inten_JPL(j),j1,km1_1,k1_1,j2,km1_2,k1_2
         else
         
         end if
      end do
      end if
      
      deallocate(eval1,eval2)
      end do
659   format(2(1X,F16.8),2(1X,E16.10),6I3)      
      end if
      if(file_transitions(1))then
         close(unitt)
         write(6,*)'WRITTEN '//outputfile(1:outputLength)//'.trn'
      end if
      if(index(JPLFile,'.cat')/=0)then
         close(unitt+2)
      end if
      continue
   end subroutine WriteOutput
   
   subroutine WriteMoments(en,mux,muy,magx,magy,quadxz,quadyz,J1,km1,kp1,m1,j2,km2,kp2,m2)
      real(8) en
      complex(8) mux,muy,magx,magy,quadxz,quadyz
      integer(4) J1,km1,kp1,m1,j2,km2,kp2,m2
      
      !since these are (i think) purely real or imaginary quantities, you can just do abs()
      write(667,5001)en,aimag(mux),dble(muy),dble(magx),aimag(magy),aimag(quadxz),dble(quadyz),J1,km1,kp1,M1,J2,km2,kp2,M2
5001  format(E11.5E2,2X,E12.5E2,2X,E12.5E2,2X,E12.5E2,2X,E12.5E2,3X,E12.5E2,3X,E12.5E2,I4,I4,I4,I4,I4,I4,I4,I4)
   end subroutine WriteMoments
  
   !inner function
   !calculates RCD transitions for pair of Js for all Ts
   subroutine CALCULATE_RCD_Jpair(J1,J2)
      integer(4) J1,J2,T1,T2,idx1,idx2,m1,m2,groundKs(3),excitedKs(3)
      real(8) evec1(2*J1+1,2*J1+1),evec2(2*J2+1,2*J2+1)
      real(8) eval1(2*J1+1),eval2(2*J2+1),rots,dips,ener,dipsx,dipsy,dipss,rotss,rotsx,rotsy,rotsqx,rotsqy,rotsq,rotsmsum,rotsqsum
      complex(8) magx2,magy2,magz2,dipx1,dipx2,dipy1,dipy2,quadxz2,quadyz2,dipp1,dipp2,magg,quadd,dip1red,dip2red,magred,quadsum,magx22
      complex(8) carr(6),iu,quadred,dip01,mag02
      real(8) darr(9),bufr,avgMM,cosM,cosJ
      complex(8) dipM1,dipM2,magP2,magM2,quadM12,quadP12,quadP22,quadM22,dipp1red,dipp2red,dipm1red,dipm2red,magp2red,magm2red,quadp2red,quadm2red
      complex(8) dipsp,dipsm,rotsp,rotsm,rotsqp,rotsqm,dipsc,rotsc
      parameter(iu=(0d0,1d0))
      
      
      
      evec1=0.0d0
      evec2=0.0d0
      eval1=0.0d0
      eval2=0.0d0
      quadM12=0.0d0
      quadP12=0.0d0
      quadP22=0.0d0
      quadM22=0.0d0
      rotsqm=0.0d0
      quadp2red=0.0d0
      quadm2red=0.0d0
      call SLICE_EVEC(evec1,J1)
      call SLICE_EVEC(evec2,J2)
      call SLICE_EVAL(eval1,J1)
      call SLICE_EVAL(eval2,J2)
      avgMM=1.0d0/dble(2*J1+1)
      cosJ = DIR_COSE_J(J1,J2)*DIR_COSE_J(J2,J1)
      cosM=0d0
      
      do m1=-J1,J1
         !do m2=max(m1-1,-J2),min(m1+1,J2) !its the same (i switched M2 for M1+1 and then multiply the whole thing by 2 )
            cosM = cosM + dble(DIR_COSE_M(J1,J2,M1,M1+1,'X')*DIR_COSE_M(J2,J1,M1+1,M1,'X'))
         !end do
      end do
      cosM=cosM*4d0
      !cosM=cosM*6d0
      !lower state
      !$OMP PARALLEL PRIVATE(T1,T2,idx1,idx2,rotsc,dipsc,rots,dips) NUM_THREADS(4)
      !$OMP DO
      do T1=-J1,J1
         !higher state
         do T2=-J2,J2
            if((J1==J2).AND.(T1>=T2))cycle
            idx1=Calc_Frac_index(J1,T1)
            idx2=Calc_Frac_index(J2,T2)
            
            !Felt cute, might delete later
            !¯\_(ツ)_/¯
            !if(Fracpop(idx1)/dble(2*J1+1)-Fracpop(idx2)/dble(2*J2+1) < 1d-20)goto 6733
            
            rots=0d0
            dips=0d0
            if(SkipTransFlag.and.(dabs(eval2(T2+J2+1)-eval1(T1+J1+1))<fmin .or. dabs(eval2(T2+J2+1)-eval1(T1+J1+1))>fmax))then
               goto 6733
            end if


            rotsc=(0d0,0d0)
            dipsc=(0d0,0d0)
            
            call TRANS_DIPSTR(evec1,evec2,J1,J2,T1,T2,dipsc)
            call TRANS_ROTSTR(evec1,evec2,J1,J2,T1,T2,rotsc)
            dips=cosJ*cosM*avgMM*dble(dipsc)
            rots=nucm_cgs*cosJ*cosM*avgMM*aimag(rotsc)
6733        continue    
           ! car = Calc_storage_index(J1,T1,J2,T2)
            !$OMP CRITICAL
            ROT_STRS(car)=rots
            DIP_STRS(car)=dips
            trans_arr(car,1)=J1
            trans_arr(car,2)=T1
            trans_arr(car,3)=J2
            trans_arr(car,4)=T2
            trans_en_arr(car)=(eval2(T2+J2+1)-eval1(T1+J1+1))
            car=car+1
            !$OMP END CRITICAL
         end do
      end do
      !$OMP END DO
      !$OMP END PARALLEL
   end subroutine CALCULATE_RCD_Jpair
   
!----------------------------------
!MATRIX MANIPULATION AND STUFF
!----------------------------------
   
   !substitute values smaller than [toler] with 0.0d0
   subroutine FilterZeroes(cArr,dArr)
      complex(8),intent(inout) :: cArr(6)
      real(8),intent(inout) :: dArr(9)
      real(8) :: curd, toler
      complex(8) ::curc
      integer(4) i
      
      toler=1d-14
      do i = 1,6
         if((abs(dble(carr(i)))<toler).and.(dble(carr(i))/=0d0))then
            carr(i)=cmplx(0d0,aimag(carr(i)),kind=8)
         end if
         if((abs(AIMAG(carr(i)))<toler).and.(AIMAG(carr(i))/=0d0))then
            carr(i)=cmplx(dble(carr(i)),0d0,kind=8)
         end if
      end do
      do i = 1,9
         curd=darr(i)
         if(abs(curd)<toler)then
            darr(i)=0d0
         end if
      end do
      
   end subroutine FilterZeroes
        
   !get eigenvector matrix for given J
   subroutine SLICE_EVEC(curHam,J)
      INTEGER(4),INTENT(IN) :: J
      REAL(8), INTENT(OUT) :: curHAM(2*J+1,2*J+1)
      INTEGER(4) i,start
      
      if(J>endJ) STOP 'J higher than maximum allowed J'
      
      start=1
      do i=startJ,J-1
         start = start + 1 
      end do
      
      curHAM=Evec_full_list(start)%arr
   end subroutine SLICE_EVEC

   !get eigenvalues for given J
   subroutine SLICE_EVAL(curHam,J)
      INTEGER(4),INTENT(IN) :: J
      REAL(8), INTENT(OUT) :: curHAM(2*J+1)
      INTEGER(4) i,start
      
      if(J>endJ) STOP 'J higher than maximum allowed J'
      
      start=1
      do i=startJ,J-1
         start = start + 1 
      end do
      
      curHAM=eval_full_list(start)%arr
   end subroutine SLICE_EVAL

   !Mmmmm, yummy
   !get Hamiltonian for given J
   subroutine SLICE_HAM(curHam,J)
      INTEGER(4),INTENT(IN) :: J
      REAL(8), INTENT(OUT) :: curHAM(2*J+1,2*J+1)
      INTEGER(4) i,start
      
      if(J>endJ) STOP 'J higher than maximum allowed J'
      
      start=1
      do i=startJ,J-1
         start = start + (2*i+1) 
      end do
      
      curHAM=Ham_full(start:(start+2*i),start:(start+2*i))
   end subroutine SLICE_HAM
     
!-------------------------
!DIRECTION COSINES, ROTATION MATRICES
!-------------------------
     
   !matrix element of 2 multiplied Wigner rotation D-matrices, possibly wrong ¯\_(ツ)_/¯, see Angular Momentum; Devanathan
   function WIGNER_MATEL_2(jq,mq,kq,jr,mr,kr,J1,J2,K1,K2,M1,M2) result(res)
      integer(4) jq,mq,kq,jr,mr,kr,J1,J2,K1,K2,M1,M2,i
      real(8) res
      res=0d0
      do i = abs(jq-jr),abs(jq+jr)
         if((abs(mq+mr)>i).OR.(abs(kq+kr)>i))then
            cycle
         end if
         res = res + CG(jq,jr,i,kq,kr,kq+kr)*CG(jq,jr,i,mq,mr,mq+mr)*WIGNER_MATEL(J1,J2,K1,K2,M1,M2,mq+mr,kq+kr,i)
      end do
   end function WIGNER_MATEL_2
     
   !angular momentum matrix element of a Wigner rotational D-matrix
   function WIGNER_MATEL(J1,J2,K1,K2,M1,M2,q1,q2,rank) result (res)
      integer(4) J1,J2,K1,K2,M1,M2,q1,q2,rank
      real(8) res,buf,buf2,buf3
      
      if((abs(q1)>rank).OR.(abs(q2)>rank))STOP 'Dimension greater than rank'
      
      buf = sqrt(dble((2*J1+1)*(2*J2+1)))
      buf2=W3J(J2,rank,J1,K2,q2,-K1)
      buf3=W3J(j2,rank,J1,M2,q1,-M1)
      res=(-1.0d0)**(k1+m1)*buf*buf2*buf3
   end function
   
   !comparison of direction cosines found in Eshbach and in Shaffer and also rotation matrices turned into cosines
   subroutine DIR_COSE_WIGNER_COMPARISON()
      integer(4) i,j1,j2,k1,k2,m1,m2
      complex(8) buf1,buf2,buf3,buf4,buf5,buf6,buf7,buf8,buf9,buf10,cosxx,cosxy,cosxz,cosyx,cosyy,cosyz,coszx,coszy,coszz,summ
      character(26) space
      real(8) dipTest(3)
      
      open(unitt,file='DIRCOSE_WIGNER_COMPARISON.TAB')
      space='                          '
      write(unitt,'(A279)')space//'COSXX'//space//'COSXY'//space//'COSXZ'//space//'COSYX'//space//'COSYY'//space//'COSYZ'//space//'COSZX'//space//'COSZY'//space//'COSZZ'
      write(unitt,'(A136)')' J1 J2 K1 K2 M1 M2                                                                                                                      '
      write(unitt,'(A136)')
      !write(unitt,'(136(A1))',advance='no')('-',i=1,136)
      !write(unitt,*)
      
      dipTest(1)=0.570
      dipTest(2)=-0.468
      dipTest(3)=0.921
      
      do j1 = 0,1
         do j2=j1-1,j1+1
         if(j2<1)cycle
            do k1=-j1,j1
               do k2=k1-1,k1+1
                  if(abs(k2)>j2)cycle
                  do m1=-j1,j1
                     do m2=m1-1,m1+1
                        summ=0d0
                        if(abs(m2)>j2)cycle
                        if((m1==m2).AND.(k1==k2))cycle
                        write(unitt,2509)j1,j2,k1,k2,m1,m2
                        write(unitt,'(A1)',advance='no')'W' !WIGNER D-MATRIX
                        buf1=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'X','X')
                        buf2=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'X','Y')
                        buf3=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'X','Z')
                        buf4=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'Y','X')
                        buf5=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'Y','Y')
                        buf6=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'Y','Z')
                        buf7=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'Z','X')
                        buf8=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'Z','Y')
                        buf9=DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,'Z','Z')
                        write(unitt,2510)buf1,buf2,buf3,buf4,buf5,buf6,buf7,buf8,buf9
                        buf10=buf1*dipTest(1)+buf2*dipTest(2)+buf3*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPX' !Dipole lab axis X
                        write(unitt,2511)buf10
                        buf10=buf4*dipTest(1)+buf5*dipTest(2)+buf6*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPY' !Dipole lab axis Y
                        write(unitt,2511)buf10
                        buf10=buf7*dipTest(1)+buf8*dipTest(2)+buf9*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPZ' !Dipole lab axis Z
                        write(unitt,2511)buf10
                        write(unitt,'(A4)',advance='no')'SUM2' !Dipole lab axis Z
                        write(unitt,2511)dble(summ)
                        write(unitt,*)
                        
                        summ=0d0
                        write(unitt,'(A1)',advance='no')'E' !DIRECTION COSINE, Eshbach
                        call DIR_COSE_WRAP(j1,j2,k1,k2,m1,m2,'X',buf1,buf2,buf3,buf4,buf5,buf6,buf7,buf8,buf9)
                        cosxx=buf1*buf2*buf3
                        cosxy=buf4*buf5*buf6
                        cosxz=buf7*buf8*buf9
                        call DIR_COSE_WRAP(j1,j2,k1,k2,m1,m2,'Y',buf1,buf2,buf3,buf4,buf5,buf6,buf7,buf8,buf9)
                        cosyx=buf1*buf2*buf3
                        cosyy=buf4*buf5*buf6
                        cosyz=buf7*buf8*buf9
                        call DIR_COSE_WRAP(j1,j2,k1,k2,m1,m2,'Z',buf1,buf2,buf3,buf4,buf5,buf6,buf7,buf8,buf9)
                        coszx=buf1*buf2*buf3
                        coszy=buf4*buf5*buf6
                        coszz=buf7*buf8*buf9
                        write(unitt,2510)cosxx,cosxy,cosxz,cosyx,cosyy,cosyz,coszx,coszy,coszz
                        buf10=cosxx*dipTest(1)+cosxy*dipTest(2)+cosxz*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPX' !Dipole lab axis X
                        write(unitt,2511)buf10
                        buf10=cosyx*dipTest(1)+cosyy*dipTest(2)+cosyz*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPY' !Dipole lab axis Y
                        write(unitt,2511)buf10
                        buf10=coszx*dipTest(1)+coszy*dipTest(2)+coszz*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPZ' !Dipole lab axis Z
                        write(unitt,2511)buf10
                        write(unitt,'(A4)',advance='no')'SUM2' !Dipole lab axis Z
                        write(unitt,2511)dble(summ)
                        write(unitt,*)
                        
                        summ=0d0
                        write(unitt,'(A1)',advance='no')'S' !DIRECTION COSINE, Schaffer, Louck
                        call DIR_COSE_WRAP_SHAFFER(j1,j2,k1,k2,m1,m2,'X',buf1,buf2,buf3)
                        call DIR_COSE_WRAP_SHAFFER(j1,j2,k1,k2,m1,m2,'Y',buf4,buf5,buf6)
                        call DIR_COSE_WRAP_SHAFFER(j1,j2,k1,k2,m1,m2,'Z',buf7,buf8,buf9)
                        write(unitt,2510)buf1,buf2,buf3,buf4,buf5,buf6,buf7,buf8,buf9
                        buf10=buf1*dipTest(1)+buf2*dipTest(2)+buf3*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPX' !Dipole lab axis X
                        write(unitt,2511)buf10
                        buf10=buf4*dipTest(1)+buf5*dipTest(2)+buf6*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPY' !Dipole lab axis Y
                        write(unitt,2511)buf10
                        buf10=buf7*dipTest(1)+buf8*dipTest(2)+buf9*dipTest(3)
                        summ=summ+buf10**2
                        write(unitt,'(A4)',advance='no')'DIPZ' !Dipole lab axis Z
                        write(unitt,2511)buf10
                        write(unitt,'(A4)',advance='no')'SUM2' !Dipole lab axis Z
                        write(unitt,2511)dble(summ)
                        write(unitt,*)
                     end do
                  end do
               end do
            end do
         end do
      end do
2508  format()      
2509  format(6(I3))    
2510  format(9(F15.8,SP,F15.8,'i'))
2511  format((F15.8,SP,F15.8,'i')) 
      close(unitt)
   end subroutine DIR_COSE_WIGNER_COMPARISON
   
   !CARTESIAN direction cosines from SPHERICAL rotation matrices
   function DIR_COSE_FROM_WIGNER(j1,j2,k1,k2,m1,m2,labaxis,molaxis) result(res)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,iu
      
      if((labaxis/='X').AND.(labaxis/='Y').AND.(labaxis/='Z'))stop 'wrong dircose labaxis enum' 
      if((molaxis/='X').AND.(molaxis/='Y').AND.(molaxis/='Z'))stop 'wrong dircose molaxis enum' 
      res=(0d0,0d0)
      iu=(0d0,1d0)
      select case(labaxis)
         case('X')
            select case(molaxis)
               case('X')
                  res=0.5d0*(WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,-1,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,1,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,1,1))
               case('Y')
                  res=iu*0.5d0*(WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,1,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,-1,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,1,1))
               case('Z')
                  res=-1d0/sqrt(2d0)*(WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,0,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,0,1))
               case default
                  stop 'wrong molaxis enum'
               end select
         case('Y')
            select case(molaxis)
               case('X')
                  res=iu*0.5d0*(-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,1,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,1,1))
               case('Y')
                  res=0.5d0*(WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,1,1))
               case('Z')
                  res=iu*1d0/sqrt(2d0)*(WIGNER_MATEL(j1,j2,k1,k2,m1,m2,1,0,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,-1,0,1))
               case default
                  stop 'wrong molaxis enum'
               end select
         case('Z')
            select case(molaxis)
               case('X')
                  res=-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,0,-1,1)+WIGNER_MATEL(j1,j2,k1,k2,m1,m2,0,1,1)
               case('Y')
                  res=iu*(-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,0,-1,1)-WIGNER_MATEL(j1,j2,k1,k2,m1,m2,0,1,1))
               case('Z')
                  res=WIGNER_MATEL(j1,j2,k1,k2,m1,m2,0,0,1)
               case default
                  stop 'wrong molaxis enum'
               end select
         case default
            stop 'wrong labaxis enum'
      end select
   end function DIR_COSE_FROM_WIGNER
   
   subroutine DIR_COSE_WRAP(j1,j2,k1,k2,m1,m2,labaxis,jcosx,jkcosx,jmcosx,jcosy,jkcosy,jmcosy,jcosz,jkcosz,jmcosz)
      integer(4) j1,j2,k1,k2,m1,m2
      complex(8),intent(out) :: jcosx,jkcosx,jmcosx,jcosy,jkcosy,jmcosy,jcosz,jkcosz,jmcosz
      character(1) labaxis
      
      call DIR_COSE(j1,j2,k1,k2,m1,m2,labaxis,'X',jcosx,jkcosx,jmcosx)
      CALL DIR_COSE(j1,j2,k1,k2,m1,m2,labaxis,'Y',jcosy,jkcosy,jmcosy)
      CALL DIR_COSE(j1,j2,k1,k2,m1,m2,labaxis,'Z',jcosz,jkcosz,jmcosz)
   end subroutine DIR_COSE_WRAP
   
   !eschbach
   subroutine DIR_COSE(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8),intent(out) :: jcos,jkcos,jmcos
      
      if((labaxis/='X').AND.(labaxis/='Y').AND.(labaxis/='Z'))stop 'wrong dircose labaxis enum' 
      if((molaxis/='X').AND.(molaxis/='Y').AND.(molaxis/='Z'))stop 'wrong dircose molaxis enum' 
      
      jcos=(0d0,0d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      if(j2==j1+1)then
         call DIR_COSE_plus(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
         return
      else if(j2==j1)then
         call DIR_COSE_zero(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
         return
      else if(j2==j1-1)then
         call DIR_COSE_minus(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
         return
      end if
   end subroutine DIR_COSE
   
   !eschbach
   function DIR_COSE_J(j1,j2)result(jcos)
      integer(4) j1,j2,k1,k2,m1,m2,Jdiff
      complex(8) jcos
      
      jcos=0d0
      Jdiff=j2-j1
      if(ShafferFlag)then
         jcos=DIR_COSE_J_SHAFFER(j1,j2)
         return
      end if
      
      select case(Jdiff)
         case(1)
         jcos=(4d0*(J1+1)*sqrt(dble((2*J1+1)*(2*J1+3))))**(-1d0)
         case(0)
         jcos=(4d0*J1*(J1+1))**(-1d0)
         case(-1)
         jcos=(4d0*J1*sqrt(4d0*J1**2d0-1d0))**(-1d0)
      end select
   end function DIR_COSE_J
   
   !eschbach
   function DIR_COSE_K(j1,j2,k1,k2,molaxis)result(jkcos)
      integer(4) j1,j2,k1,k2,Jdiff,Kdiff
      character(1) :: molaxis
      complex(8) jkcos,PM,MP,xx
      
      if(ShafferFlag)then
         jkcos=DIR_COSE_k_SHAFFER(j1,j2,k1,k2,molaxis)
         return
      end if
      jkcos=(0d0,0d0)
      Jdiff=j2-j1
      Kdiff=K2-K1
      if(.NOT.(molaxis=='X'.OR.molaxis=='Y'.OR.molaxis=='Z'))then
         stop 'wrong molaxis enum DIR_COSE_K'
      end if
      if(kdiff > 0)then
         PM=(1d0,0d0)
         MP=(-1d0,0d0)
      else
         PM=(-1d0,0d0)
         MP=(1d0,0d0)
      end if
      select case(Jdiff)
         case(1)
            select case(abs(Kdiff))
               case(0)
                  if(molaxis /= 'Z')return
                  jkcos=2d0*sqrt(dble(((J1+1)**2-K1**2)))
               case(1)
                  if(molaxis == 'Z')return
                  if(molaxis == 'X')then
                     xx=PM*(0d0,1d0)
                  else
                     xx=(1d0,0d0)
                  end if
                  jkcos=xx*MP*sqrt(dble((J1+PM*K1+1)*(J1+PM*K1+2)))
            end select
         case(0)
            select case(abs(Kdiff))
               case(0)
                  if(molaxis /= 'Z')return
                  jkcos=dble(2*K1)
               case(1)
                  if(molaxis == 'Z')return
                  if(molaxis == 'X')then
                     xx=PM*(0d0,1d0)
                  else
                     xx=(1d0,0d0)
                  end if
                  jkcos=xx*sqrt(dble(J1*(J1+1)-K1*(K1+PM)))
            end select
         case(-1)
            select case(abs(Kdiff))
               case(0)
                  if(molaxis /= 'Z')return
                  jkcos=-2d0*sqrt(dble(J1**2-K1**2))
               case(1)
                  if(molaxis == 'Z')return
                  if(molaxis == 'X')then
                     xx=PM*(0d0,1d0)
                  else
                     xx=(1d0,0d0)
                  end if
                  jkcos=xx*MP*sqrt(dble((J1+MP*K1)*(J1+MP*K1-1)))
            end select
      end select
   end function DIR_COSE_K
  
   !eschbach
   function DIR_COSE_M(j1,j2,m1,m2,labaxis)result(jmcos)
      integer(4) j1,j2,m1,m2,Jdiff,mdiff
      character(1) :: labaxis
      complex(8) jmcos,PM,MP,xx
      
      if(ShafferFlag)then
         jmcos=DIR_COSE_M_SHAFFER(j1,j2,m1,m2,labaxis)
         return
      end if
      jmcos=(0d0,0d0)
      if(.NOT.(labaxis=='X'.OR.labaxis=='Y'.OR.labaxis=='Z'))then
         stop 'wrong labaxis enum DIR_COSE_M'
      end if
      Jdiff=j2-j1
      mdiff=m2-m1
      if(mdiff > 0)then
         PM=(1d0,0d0)
         MP=(-1d0,0d0)
      else
         PM=(-1d0,0d0)
         MP=(1d0,0d0)
      end if
      select case(Jdiff)
         case(1)
            select case(abs(Mdiff))
               case(0)
                  if(labaxis/='Z')return
                  jmcos=2d0*sqrt(dble((J1+1)**2-M1**2))
               case(1)
                  if(labaxis=='Z')return
                  if(labaxis == 'X')then
                     xx=MP*(0d0,1d0)
                  else
                     xx=(1d0,0d0)
                  end if
                  jmcos=xx*MP*sqrt(dble((J1+PM*M1+1)*(J1+PM*M1+2)))
            end select
         case(0)
            select case(abs(Mdiff))
               case(0)
                  if(labaxis/='Z')return
                  jmcos=dble(2*M1)
               case(1)
                  if(labaxis=='Z')return
                  if(labaxis == 'X')then
                     xx=MP*(0d0,1d0)
                  else
                     xx=(1d0,0d0)
                  end if
                  jmcos=xx*sqrt(dble(J1*(J1+1)-M1*(M1+PM)))
            end select
         case(-1)
            select case(abs(Mdiff))
               case(0)
                  if(labaxis/='Z')return
                  jmcos=-2d0*sqrt(dble(J1**2-M1**2))
               case(1)
                  if(labaxis=='Z')return
                  if(labaxis == 'X')then
                     xx=MP*(0d0,1d0)
                  else
                     xx=(1d0,0d0)
                  end if
                  jmcos=xx*MP*sqrt(dble((J1+MP*M1)*(J1+MP*M1-1)))
            end select
      end select
   end function DIR_COSE_M
 
   function DIR_COSE_J_SHAFFER(j1,j2)result(jcos)
      integer(4) j1,j2,k1,k2,m1,m2,Jdiff
      complex(8) jcos
      
      jcos=0d0
      Jdiff=j2-j1
      select case(Jdiff)
         case(1)
         jcos=(4d0*(J2)*sqrt(dble(4*J2**2-1)))**(-1d0)
         case(0)
         jcos=dble(4d0*J1*(J1+1))**(-1d0)
         case(-1)
         jcos=(4d0*J1*sqrt(dble(4*J1**2-1)))**(-1d0)
      end select
   end function DIR_COSE_J_SHAFFER
   
   function DIR_COSE_K_SHAFFER(j1,j2,k1,k2,molaxis)result(jkcos)
      integer(4) j1,j2,k1,k2,Jdiff
      character(1) :: molaxis
      complex(8) jkcos
   
      jkcos=(0d0,0d0)
      if(.NOT.(molaxis=='X'.OR.molaxis=='Y'.OR.molaxis=='Z'))then
         stop 'wrong molaxis enum DIR_COSE_K'
      end if
      Jdiff=j2-j1
      select case(Jdiff)
         case(1)
         if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
            jkcos=sqrt(dble((J2+K1)*(J2+K1+1)))
            if(molaxis=='Y')then
               jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
            end if   
         else if((k1==k2).AND.(molaxis=='Z'))then
            jkcos=2d0*sqrt(dble(j2**2-k1**2))
         else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
            jkcos=-sqrt(dble((J2-K1)*(J2-K1+1)))
            if(molaxis=='Y')then
               jkcos=CMPLX(0d0,dble(jkcos),kind=8)
            end if
         end if
         case(0)
         if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
            jkcos=-sqrt(dble(J1*(J1+1)-K1*(K1+1)))
            if(molaxis=='Y')then
               jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
            end if
            
         else if((k1==k2).AND.(molaxis=='Z'))then
            jkcos=2d0*K1
            
         else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
            jkcos=-sqrt(dble(J1*(J1+1)-K1*(K1-1)))
            if(molaxis=='Y')then
               jkcos=CMPLX(0d0,dble(jkcos),kind=8)
            end if
         end if
         case(-1)
         if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
            jkcos=sqrt(dble((J1-K1)*(J1-K1-1)))
            if(molaxis=='Y')then
               jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
            end if
         else if((k1==k2).AND.(molaxis=='Z'))then
            jkcos=-2d0*sqrt(dble(J1**2-K1**2))
         else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
            jkcos=-sqrt(dble((J1+K1)*(J1+K1-1)))
            if(molaxis=='Y')then
               jkcos=CMPLX(0d0,dble(jkcos),kind=8)
            end if
         end if
      end select
   end function DIR_COSE_K_SHAFFER
   
   function DIR_COSE_M_SHAFFER(j1,j2,m1,m2,labaxis)result(jmcos)
      integer(4) j1,j2,m1,m2,Jdiff
      character(1) :: labaxis
      complex(8) jmcos
      
      jmcos=(0d0,0d0)
      if(.NOT.(labaxis=='X'.OR.labaxis=='Y'.OR.labaxis=='Z'))then
         stop 'wrong labaxis enum DIR_COSE_M'
      end if
      Jdiff=j2-j1
      select case(Jdiff)
         case(1)
         if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
            jmcos=sqrt(dble((J2+M1)*(J2+M1+1)))
            if(labaxis=='Y')then
               jmcos=CMPLX(0d0,dble(jmcos),kind=8)
            end if
         else if((m1==m2).AND.(labaxis=='Z'))then
            jmcos=2d0*sqrt(dble(J2**2-M1**2))
         else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
            jmcos=-sqrt(dble((J2-M1)*(J2-M1+1)))
            if(labaxis=='Y')then
               jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
            end if
         end if
         case(0)
         if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
            jmcos=-sqrt(dble(J1*(J1+1)-M1*(M1+1)))
            if(labaxis=='Y')then
               jmcos=CMPLX(0d0,dble(jmcos),kind=8)
            end if
            
         else if((m1==m2).AND.(labaxis=='Z'))then
            jmcos=2d0*M1
            
         else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
            jmcos=-sqrt(dble(J1*(J1+1)-M1*(M1-1)))
            if(labaxis=='Y')then
               jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
            end if
         end if
         case(-1)
         if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
            jmcos=sqrt(dble((J1-M1)*(J1-M1-1)))
            if(labaxis=='Y')then
               jmcos=CMPLX(0d0,dble(jmcos),kind=8)
            end if
         else if((m1==m2).AND.(labaxis=='Z'))then
            jmcos=-2d0*sqrt(dble(J1**2-M1**2))
         else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
            jmcos=-sqrt(dble((J1+M1)*(J1+M1-1)))
            if(labaxis=='Y')then
               jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
            end if
         end if
      end select
   end function DIR_COSE_M_SHAFFER
 
   !eschbach
   subroutine DIR_COSE_plus(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,jcos,jkcos,jmcos
      
      if(j2/=j1+1)stop 'wrong dircose plus'
      
      jcos=(4d0*(J1+1)*sqrt(dble((2*J1+1)*(2*J1+3))))**(-1d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      
      !if(abs(k2-k1)>1)stop 'wrong dircose plus k'
      if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=-sqrt(dble((J1+K1+1)*(J1+K1+2)))
         if(molaxis=='X')then
            jkcos=CMPLX(0d0,dble(jkcos),kind=8)
         end if   
      else if((k1==k2).AND.(molaxis=='Z'))then
         jkcos=2d0*sqrt(dble((j1+1)**2-k1**2))
      else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=sqrt(dble((J1-K1+1)*(J1-K1+2)))
         if(molaxis=='X')then
            jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
         end if
      end if
      
      !if(abs(m2-m1)>1)stop 'wrong dircose plus m'
      if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=-sqrt(dble((J1+M1+1)*(J1+M1+2)))
         if(labaxis=='X')then
            jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
         end if
      else if((m1==m2).AND.(labaxis=='Z'))then
         jmcos=2d0*sqrt(dble((J1+1)**2-M1**2))
      else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=sqrt(dble((J1-M1+1)*(J1-M1+2)))
         if(labaxis=='X')then
            jmcos=CMPLX(0d0,dble(jmcos),kind=8)
         end if
      end if
   end subroutine DIR_COSE_plus

   !eschbach
   subroutine DIR_COSE_minus(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,jcos,jkcos,jmcos
      
      if(j2/=j1-1)stop 'wrong dircose minus'
      jcos=(4d0*J1*sqrt(4d0*J1**2d0-1d0))**(-1d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      
      if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=-sqrt(dble((J1-K1)*(J1-K1-1)))
         if(molaxis=='X')then
            jkcos=CMPLX(0d0,dble(jkcos),kind=8)
         end if
      else if((k1==k2).AND.(molaxis=='Z'))then
         jkcos=-2d0*sqrt(dble(J1**2-K1**2))
      else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=sqrt(dble((J1+K1)*(J1+K1-1)))
         if(molaxis=='X')then
            jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
         end if
      end if
      
      !if(abs(m2-m1)>1)stop 'wrong dircose plus m'
      if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=-sqrt(dble((J1-M1)*(J1-M1-1)))
         if(labaxis=='X')then
            jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
         end if
      else if((m1==m2).AND.(labaxis=='Z'))then
         jmcos=-2d0*sqrt(dble(J1**2-M1**2))
      else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=sqrt(dble((J1+M1)*(J1+M1-1)))
         if(labaxis=='X')then
            jmcos=CMPLX(0d0,dble(jmcos),kind=8)
         end if
      end if
   end subroutine DIR_COSE_minus

   !eschbach
   subroutine DIR_COSE_zero(j1,j2,k1,k2,m1,m2,labaxis,molaxis,jcos,jkcos,jmcos)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,jcos,jkcos,jmcos
      
      if(j2/=j1)stop 'wrong dircose zero'
      
      jcos=(4d0*J1*(J1+1))**(-1d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      
      !if(abs(k2-k1)>1)stop 'wrong dircose plus k'
      if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=sqrt(dble(J1*(J1+1d0)-K1*(K1+1d0)))
         if(molaxis=='X')then
            jkcos=CMPLX(0d0,dble(jkcos),kind=8)
         end if
         
      else if((k1==k2).AND.(molaxis=='Z'))then
         jkcos=2d0*K1
         
      else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=sqrt(dble(J1*(J1+1)-K1*(K1-1)))
         if(molaxis=='X')then
            jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
         end if
      end if
      
      !if(abs(m2-m1)>1)stop 'wrong dircose plus m'
      if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=sqrt(dble(J1*(J1+1)-M1*(M1+1)))
         if(labaxis=='X')then
            jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
         end if
         
      else if((m1==m2).AND.(labaxis=='Z'))then
         jmcos=2d0*M1
         
      else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=sqrt(dble(J1*(J1+1)-M1*(M1-1)))
         if(labaxis=='X')then
            jmcos=CMPLX(0d0,dble(jmcos),kind=8)
         end if
      end if
   end subroutine DIR_COSE_zero
   
   subroutine DIR_COSE_WRAP_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,cosx,cosy,cosz)
      integer(4) j1,j2,k1,k2,m1,m2
      complex(8),intent(out) :: cosx,cosy,cosz
      character(1) labaxis
      
      cosx=DIR_COSE_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,'X')
      cosy=DIR_COSE_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,'Y')
      cosz=DIR_COSE_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,'Z')
   end subroutine DIR_COSE_WRAP_SHAFFER
   
   function DIR_COSE_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis) result(res)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res
      
      if((labaxis/='X').AND.(labaxis/='Y').AND.(labaxis/='Z'))stop 'wrong dircose labaxis enum' 
      if((molaxis/='X').AND.(molaxis/='Y').AND.(molaxis/='Z'))stop 'wrong dircose molaxis enum' 
      
      res=(0d0,0d0)
      if(j2==j1+1)then
         res = DIR_COSE_plus_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis)
         return
      else if(j2==j1)then
         res = DIR_COSE_zero_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis)
         return
      else if(j2==j1-1)then
         res = DIR_COSE_minus_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis)
         return
      end if
   end function DIR_COSE_SHAFFER
   
   function DIR_COSE_plus_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis) result(res)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,jcos,jkcos,jmcos
      
      if(j2/=j1+1)stop 'wrong dircose plus'
      
      jcos=(4d0*(J2)*sqrt(dble(4d0*J2**2-1)))**(-1d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      
      !if(abs(k2-k1)>1)stop 'wrong dircose plus k'
      if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=sqrt(dble((J2+K1)*(J2+K1+1)))
         if(molaxis=='Y')then
            jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
         end if   
      else if((k1==k2).AND.(molaxis=='Z'))then
         jkcos=2d0*sqrt(dble(4*J2**2-k1**2))
      else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=-sqrt(dble((J2-K1)*(J2-K1+1)))
         if(molaxis=='Y')then
            jkcos=CMPLX(0d0,dble(jkcos),kind=8)
         end if
      end if
      
      !if(abs(m2-m1)>1)stop 'wrong dircose plus m'
      if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=sqrt(dble((J2+m1)*(J2+m1+1)))
         if(labaxis=='Y')then
            jmcos=CMPLX(0d0,dble(jmcos),kind=8)
         end if
      else if((m1==m2).AND.(labaxis=='Z'))then
         jmcos=2d0*sqrt(dble(4*J2**2-M1**2))
      else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=-sqrt(dble((J2-m1)*(J2-m1+1)))
         if(labaxis=='Y')then
            jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
         end if
      end if
      
      
      res = jcos*jkcos*jmcos
   end function DIR_COSE_plus_SHAFFER
   
   function DIR_COSE_minus_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis) result(res)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,jcos,jkcos,jmcos
      
      if(j2/=j1-1)stop 'wrong dircose minus'
      jcos=(4d0*J1*sqrt(4d0*J1**2-1d0))**(-1d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      
      if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=sqrt(dble((J1-K1)*(J1-K1-1)))
         if(molaxis=='Y')then
            jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
         end if
      else if((k1==k2).AND.(molaxis=='Z'))then
         jkcos=-2d0*sqrt(dble(4*J1**2-K1**2))
      else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=-sqrt(dble((J1+K1)*(J1+K1-1)))
         if(molaxis=='Y')then
            jkcos=CMPLX(0d0,dble(jkcos),kind=8)
         end if
      end if
      
      !if(abs(m2-m1)>1)stop 'wrong dircose plus m'
      if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=sqrt(dble((J1-m1)*(J1-m1-1)))
         if(labaxis=='Y')then
            jmcos=CMPLX(0d0,dble(jmcos),kind=8)
         end if
      else if((m1==m2).AND.(labaxis=='Z'))then
         jmcos=-2d0*sqrt(dble(4d0*J1**2-M1**2))
      else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=-sqrt(dble((J1+M1)*(J1+M1-1)))
         if(labaxis=='Y')then
            jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
         end if
      end if
      
      res = jcos*jkcos*jmcos
   end function DIR_COSE_minus_SHAFFER
   
   function DIR_COSE_zero_SHAFFER(j1,j2,k1,k2,m1,m2,labaxis,molaxis) result(res)
      integer(4) j1,j2,k1,k2,m1,m2
      character(1) labaxis,molaxis
      complex(8) res,jcos,jkcos,jmcos
      
      if(j2/=j1)stop 'wrong dircose zero'
      
      jcos=(4d0*J1*(J1+1))**(-1d0)
      jkcos=(0d0,0d0)
      jmcos=(0d0,0d0)
      
      !if(abs(k2-k1)>1)stop 'wrong dircose plus k'
      if((k2==k1+1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=-sqrt(dble(J1*(J1+1d0)-K1*(K1+1d0)))
         if(molaxis=='Y')then
            jkcos=-CMPLX(0d0,dble(jkcos),kind=8)
         end if
         
      else if((k1==k2).AND.(molaxis=='Z'))then
         jkcos=2d0*K1
         
      else if((k2==k1-1).AND.((molaxis=='X').OR.(molaxis=='Y')))then
         jkcos=-sqrt(dble(J1*(J1+1)-K1*(K1-1)))
         if(molaxis=='Y')then
            jkcos=CMPLX(0d0,dble(jkcos),kind=8)
         end if
      end if
      
      !if(abs(m2-m1)>1)stop 'wrong dircose plus m'
      if((m2==m1+1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=-sqrt(dble(J1*(J1+1)-M1*(M1+1)))
         if(labaxis=='Y')then
            jmcos=CMPLX(0d0,dble(jmcos),kind=8)
         end if
         
      else if((m1==m2).AND.(labaxis=='Z'))then
         jmcos=2d0*M1
         
      else if((m2==m1-1).AND.((labaxis=='X').OR.(labaxis=='Y')))then
         jmcos=-sqrt(dble(J1*(J1+1)-M1*(M1-1)))
         if(labaxis=='Y')then
            jmcos=-CMPLX(0d0,dble(jmcos),kind=8)
         end if
      end if
      
      
      res = jcos*jkcos*jmcos
   end function DIR_COSE_zero_SHAFFER   
   
!-----------------------
!TRANSITION MOMENTS
!-----------------------
!cg,ce - ground and excited state eigenvector MATRICES
!J1,J2 - main quantum numbers
!T1,T2 - molecular axis z projection "q. nums."
!M1,M2 - space axis z projection q. nums.
!res   - complex result
!totalreduced - complex result without direction cosine (rotation matrix) in terms of M
!-----------------------
   
   subroutine TRANS_DIPSTR(cg,ce,J1,J2,T1,T2,res)
      logical arrAssigned
      integer(4) j1,j2,t1,t2,i,k1,k2
      complex(8) res,buf1,buf2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      character(1) axes(3)
      parameter(axes=['X','Y','Z'])
      
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      buf1=0d0
      buf2=0d0
      !res=(0d0,0d0)
      do K1 = -J1,J1
         do K2 = max(K1-1,-J2),min(K1+1,J2)
            do i = 1,3
               buf1=buf1+DIR_COSE_K(J1,J2,K1,K2,axes(i))*dip(i)*cgb(K1+J1+1)*ceb(K2+J2+1)
            end do
         end do
      end do 
      do K1 = -J1,J1
         do K2 = max(K1-1,-J2),min(K1+1,J2)
            do i = 1,3
               buf2=buf2+DIR_COSE_K(J2,J1,K2,K1,axes(i))*dip(i)*cgb(K1+J1+1)*ceb(K2+J2+1)
            end do
         end do
      end do 
      
      
      
      res = buf1*buf2

   end subroutine TRANS_DIPSTR
   
   function eps(a,b,c)result(res) !didnt kill himself
      real(8) res
      character(1) a,b,c
      res=0d0
      
      if(a=='X')then
         if(b=='Y')then
            res=1d0
         else if(b=='Z')then
            res=-1d0
         end if
      else if(a=='Y')then
         if(b=='X')then
            res=-1d0
         else if(b=='Z')then
            res=1d0
         end if
      else if(a=='Z')then
         if(b=='X')then
            res=1d0
         else if(b=='Y')then
            res=-1d0
         end if
      end if
   end function eps
   
   subroutine TRANS_ROTSTR(cg,ce,J1,J2,T1,T2,res)
      integer(4) j1,j2,t1,t2,i,k1,k2,j,k
      complex(8) res,buf1,buf2,buf3,ga(3,3),iu,gcor(3)
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      character(1) axes(3)
      
      parameter(axes=['X','Y','Z'])
      parameter(iu=(0d0,1d0))
      !dis a constant
      do i = 1,3
         ga(i,1)=(gt(i,2)+iu*gt(i,1))*0.5d0
         ga(i,2)=gt(i,3)
         ga(i,3)=(gt(i,2)-iu*gt(i,1))*0.5d0
      end do
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
       
      !dis also a constant
      gcor(1)=0.5d0*iu*(gt(2,3)-gt(3,2))
      gcor(2)=0.5d0*iu*(gt(3,1)-gt(1,3))
      gcor(3)=0.5d0*iu*(gt(1,2)-gt(2,1))
      
      buf1=(0d0,0d0)
      buf2=(0d0,0d0)
      buf3=(0d0,0d0)
      !res=(0d0,0d0)
      do K1 = -J1,J1
         do K2 = max(K1-1,-J2),min(K1+1,J2)
            do i = 1,3
               buf1=buf1+DIR_COSE_K(J1,J2,K1,K2,axes(i))*dip(i)*cgb(K1+J1+1)*ceb(K2+J2+1)
            end do
         end do
      end do
      
      ! do K1 = -J1,J1
         ! do K2 = max(K1-2,-J2),min(K1+2,J2)
            ! buf2=(0d0,0d0)
            ! do i = 1,3
               ! buf2(i)=buf2(i)+DIR_COSE_K(J2,J1,K2,K1+1,axes(i))*Jminus_eval(J1,K1)*ga(i,3)+DIR_COSE_K(J2,J1,K2,K1-1,axes(i))*Jplus_eval(J1,K1)*ga(i,1)+DIR_COSE_K(J2,J1,K2,K1,axes(i))*K1*ga(i,2)
               ! buf2(i)=buf2(i)+DIR_COSE_K(J2,J1,K2,K1,axes(i))*gcor(i)
            ! end do
            ! !¯\_(ツ)_/¯
            ! !I forgot why I did it like this, but it works
            ! buf3=buf3+sum(buf2)*cgb(K1+J1+1)*ceb(K2+J2+1)
         ! end do
      ! end do
      do K1 = -J1,J1
         do K2 = max(K1-2,-J2),min(K1+2,J2)
            buf2=(0d0,0d0)
            do i = 1,3
               buf2=buf2+DIR_COSE_K(J2,J1,K2,K1+1,axes(i))*Jminus_eval(J1,K1)*ga(i,3)+DIR_COSE_K(J2,J1,K2,K1-1,axes(i))*Jplus_eval(J1,K1)*ga(i,1)+DIR_COSE_K(J2,J1,K2,K1,axes(i))*K1*ga(i,2)
            end do
            
            do i = 1,3
               buf2=buf2+DIR_COSE_K(J2,J1,K2,K1,axes(i))*gcor(i)
            end do
            buf3=buf3+buf2*cgb(K1+J1+1)*ceb(K2+J2+1)
         end do
      end do
      res=buf1*buf3
   end subroutine TRANS_ROTSTR
   
   !matrix element of transition electric dipole in cartesian X
   subroutine TRANS_EL_X(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8), intent(out) :: res,totalreduced 
      COMPLEX(8) buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag.eqv..true.)then
         call TRANS_EL_X_COSE(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
         return
      end if
      
      
      !not reachable
      buf1=0.0d0
      buf2=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)

      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0d0
            buf2=0d0
            do q = 1,3
               buf1 = buf1 + WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-2,rank)*sph_dip(q)
               buf2 = buf2 + WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-2,rank)*sph_dip(q)
            end do
            res=res + cgb(K1+J1+1)*ceb(K2+J2+1)*(-1.0d0/sqrt(2.0d0))*(buf1-buf2)
         end do
      end do
      
      !the totalreduced might be unreliable like this
      totalreduced=res/DIR_COSE_M(J1,J2,M1,M2,'X')
   end subroutine TRANS_EL_X
   
   !matrix element of transition electric dipole in cartesian X, using cartesian cosines
   subroutine TRANS_EL_X_COSE(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8), intent(inout) :: res,totalreduced 
      COMPLEX(8) buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      complex(8) jcos,jkcos,jmcos
      character(1) axes(3)
      
      parameter(axes=(/'X','Y','Z'/))
      buf1=0.0d0
      buf2=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      totalreduced=0d0
      
      
      do K1 = -J1,J1
         do K2 = max(K1-1,-J2),min(K1+1,J2)
            buf1=0.0d0
            do q = 1,3
               buf1=buf1+dip(q)*DIR_COSE_K(J1,J2,K1,K2,axes(q))
            end do
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*buf1
         end do
      end do
      res=totalreduced*DIR_COSE_M(J1,J2,M1,M2,'X')*DIR_COSE_J(J1,J2)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
   end subroutine TRANS_EL_X_COSE
   
   !matrix element of transition electric dipole in spherical q-coordinate (-1, 0 or 1)
   subroutine TRANS_EL_Q(cg,ce,J1,J2,T1,T2,M1,M2,qs,res,totalreduced)
      COMPLEX(8), intent(out) :: res,totalreduced 
      COMPLEX(8) buf1,buf2,iu
      integer(4) J1,J2,K1,K2,M1,M2,q,qs,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
            
      buf1=0.0d0
      buf2=0.0d0
      res=0.0d0
      rank=1
      iu=(0d0,1d0)
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      totalreduced=0d0
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0d0
            buf2=0d0
            do q = 1,3
               buf1 = buf1 + iuPow(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,q-2,K2)*sph_dip(q)
            end do
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf1)
         end do
      end do
      
      !the totalreduced might be unreliable like this
      res = totalreduced*W3J(J1,1,J2,-M1,qs,M2)
   end subroutine TRANS_EL_Q
   
   function iuPow(n) result(res)
      integer(4) n,modd
      complex(8) res
      
      modd=modulo(n,4)
      
      select case(modd)
         case(0)
            res=(1d0,0d0)
         case(1)   
            res=(0d0,1d0)
         case(2)
            res=(-1d0,0d0)
         case(3)
            res=(0d0,-1d0)
      end select
   end function iuPow
   
   !matrix element of transition electric dipole in cartesian Y
   subroutine TRANS_EL_Y(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8), intent(out) :: res,totalreduced 
      COMPLEX(8) buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag.eqv..true.)then
         call TRANS_EL_Y_COSE(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
         return
      end if
      
      buf1=0.0d0
      buf2=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0d0
            buf2=0d0
            do q = 1,3
               buf1 = buf1 + WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-2,rank)*sph_dip(q)
               buf2 = buf2 + WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-2,rank)*sph_dip(q)
            end do
            res=res + cgb(K1+J1+1)*ceb(K2+J2+1)*CMPLX(0.0d0,1.0d0,kind=8)*(1.0d0/sqrt(2.0d0))*(buf1+buf2)
         end do
      end do
      totalreduced=res/DIR_COSE_M(J1,J2,M1,M2,'Y')
   end subroutine TRANS_EL_Y
   
   !matrix element of transition electric dipole in cartesian Y, using cartesian cosines
   subroutine TRANS_EL_Y_COSE(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8), intent(inout) :: res,totalreduced 
      COMPLEX(8) buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      complex(8) jcos,jkcos,jmcos
      character(1) axes(3)
      
      parameter(axes=(/'X','Y','Z'/))
      buf1=0.0d0
      buf2=0.0d0
      res=0.0d0
      totalreduced=0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      
      
      
      do K1 = -J1,J1
         do K2 = max(K1-1,-J2),min(K1+1,J2)
            buf1=0.0d0
            do q = 1,3
               buf1=buf1+dip(q)*DIR_COSE_K(J1,J2,K1,K2,axes(q))
            end do
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*buf1*DIR_COSE_J(J1,J2)
         end do
      end do
      res=totalreduced*DIR_COSE_M(J1,J2,M1,M2,'Y')
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
   end subroutine TRANS_EL_Y_COSE
      
   !matrix element of transition electric dipole in cartesian Z
   subroutine TRANS_EL_Z(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8), intent(out) :: res,totalreduced 
      COMPLEX(8) buf1
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag.eqv..true.)then
         call TRANS_EL_Z_COSE(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
         return
      end if
      
      buf1=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0d0
            do q = 1,3
               buf1 = buf1 + WIGNER_MATEL(J1,J2,K1,K2,M1,M2,0,q-2,rank)*sph_dip(q)
            end do
            res=res + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf1)
         end do
      end do
      totalreduced=res/DIR_COSE_M(J1,J2,M1,M2,'Z')
   end subroutine TRANS_EL_Z
   
   !matrix element of transition electric dipole in cartesian Z, using cartesian cosines
   subroutine TRANS_EL_Z_COSE(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8), intent(inout) :: res,totalreduced 
      COMPLEX(8) buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      complex(8) jcos,jkcos,jmcos
      character(1) axes(3)
      
      parameter(axes=(/'X','Y','Z'/))
      buf1=0.0d0
      buf2=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      totalreduced=0d0
      
      do K1 = -J1,J1
         do K2 = max(K1-1,-J2),min(K1+1,J2)
            buf1=0.0d0
            do q = 1,3
               buf1=buf1+dip(q)*DIR_COSE_K(J1,J2,K1,K2,axes(q))
            end do
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*buf1*DIR_COSE_J(J1,J2)
         end do
      end do
      res=totalreduced*DIR_COSE_M(J1,J2,M1,M2,'Z')
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
   end subroutine TRANS_EL_Z_COSE
            
   !matrix element of transition magnetic dipole in cartesian X, using wigner matrices
   !iz dumb, dont use, use TRANS_MAG_Q or TRANS_MAG_SPACE_ALPHA_COSE instead
   !also, should be unreachable every time
   function TRANS_MAG_X_SPHG(cg,ce,J1,J2,T1,T2,M1,M2) result (res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4,buf5
      integer(4) J1,J2,K1,K2,M1,M2,rank,T1,T2,q
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            do q = 1,3
               buf1=buf1-WIGNER_MATEL(J1,J2,K1,K2+1,M1,M2,1,q-2,rank)*Jplus_sph_eval(J2,K2)*sph_g(q,1)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-2,rank)*K2*sph_g(q,2)
               buf3=buf3-WIGNER_MATEL(J1,J2,K1,K2-1,M1,M2,1,q-2,rank)*Jminus_sph_eval(J2,K2)*sph_g(q,3)
            end do
            buf4=buf1+buf2+buf3
            
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            do q = 1,3
               buf1=buf1-WIGNER_MATEL(J1,J2,K1,K2+1,M1,M2,-1,q-2,rank)*Jplus_sph_eval(J2,K2)*sph_g(q,1)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-2,rank)*K2*sph_g(q,2)
               buf3=buf3-WIGNER_MATEL(J1,J2,K1,K2-1,M1,M2,-1,q-2,rank)*Jminus_sph_eval(J2,K2)*sph_g(q,3)
            end do
            buf5=buf1+buf2+buf3
            res=res + cgb(K1+J1+1)*ceb(K2+J2+1)*(-1.0d0/sqrt(2.0d0))*(buf4-buf5)
         end do
      end do
      res = res
   end function TRANS_MAG_X_SPHG
   
   !matrix element of transition magnetic dipole in cartesian Y, using wigner matrices
   function TRANS_MAG_Y_SPHG(cg,ce,J1,J2,T1,T2,M1,M2) result (res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4,buf5
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            do q = 1,3
               buf1=buf1-WIGNER_MATEL(J1,J2,K1,K2+1,M1,M2,1,q-2,rank)*Jplus_sph_eval(J2,K2)*sph_g(q,1)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-2,rank)*K2*sph_g(q,2)
               buf3=buf3-WIGNER_MATEL(J1,J2,K1,K2-1,M1,M2,1,q-2,rank)*Jminus_sph_eval(J2,K2)*sph_g(q,3)
            end do
            buf4=buf1+buf2+buf3
            
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            do q = 1,3
               buf1=buf1-WIGNER_MATEL(J1,J2,K1,K2+1,M1,M2,-1,q-2,rank)*Jplus_sph_eval(J2,K2)*sph_g(q,1)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-2,rank)*K2*sph_g(q,2)
               buf3=buf3-WIGNER_MATEL(J1,J2,K1,K2-1,M1,M2,-1,q-2,rank)*Jminus_sph_eval(J2,K2)*sph_g(q,3)
            end do
            buf5=buf1+buf2+buf3
            res=res + cgb(K1+J1+1)*ceb(K2+J2+1)*CMPLX(0.0d0,1.0d0,kind=8)*(1.0d0/sqrt(2.0d0))*(buf4+buf5)
         end do
      end do
      res = res
   end function TRANS_MAG_Y_SPHG
   
   !matrix element of transition magnetic dipole in cartesian Z, using wigner matrices
   function TRANS_MAG_Z_SPHG(cg,ce,J1,J2,T1,T2,M1,M2) result (res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4
      integer(4) J1,J2,K1,K2,M1,M2,q,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            do q = 1,3
               buf1=buf1-WIGNER_MATEL(J1,J2,K1,K2+1,M1,M2,0,q-2,rank)*Jplus_sph_eval(J2,K2)*sph_g(q,1)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,0,q-2,rank)*K2*sph_g(q,2)
               buf3=buf3-WIGNER_MATEL(J1,J2,K1,K2-1,M1,M2,0,q-2,rank)*Jminus_sph_eval(J2,K2)*sph_g(q,3)
            end do
            buf4=buf1+buf2+buf3
            
            res=res + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf4)
         end do
      end do
      res = res
   end function TRANS_MAG_Z_SPHG
       
   !matrix element of transition magnetic dipole in spherical q-coordinate (-1,0 or 1), using wigner matrices
   subroutine TRANS_MAG_Q(cgv,ce,J1,J2,T1,T2,M1,M2,qs,res,totalreduced)    
      COMPLEX(8) res,totalreduced,buf1,buf2,buf3,buf4,gmix(3,3),iu
      integer(4) J1,J2,K1,K2,M1,M2,q,qs,rank,T1,T2,i
      real(8) cgv(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      res=0.0d0
      rank=1
      cgb=cgv(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      totalreduced=0d0
      iu=(0d0,1d0)
      !goto 27
      ! do i = 1,3
         ! gmix(1,i)=1d0/sqrt(2d0)*(gt(1,i)-iu*gt(2,i))
         ! gmix(2,i)=gt(3,i)
         ! gmix(3,i)=-1d0/sqrt(2d0)*(gt(1,i)+iu*gt(2,i))
      ! end do
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            !have fun figuring out what a phase convention is, why does every author need to choose his own and why nobody seems to care about it
            !:)
            !these are probably wrong
            !taken from: Molecular Vibrational/Rotational Spectra, Papousek, Aliev, 1982, page 305, (equation G.6.5)
            !further note, these are probably more correct than if I used direction cosines in King, Hainer, Cross publication because the phase convention is different (I guess???) compared to Papoušek, whose Hamiltonian I'm using
            !im so confused and tired of the topic of phase conventions
            do q = 1,3
               !-iu... minus because product of -1 and 1
               buf1=buf1-iu**(J1+J2-K2+1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,q-2,K2-1)*Jplus_sph_eval(J2,K2)*sph_g(q,1)
               !-iu... minus because anomalous definition in molecular frame A0=-Az
               buf2=buf2-iu**(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,q-2,K2)*K2*sph_g(q,2)
               !-iu... minus because product of 1 and -1
               buf3=buf3-iu**(J1+J2-K2-1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,q-2,K2+1)*Jminus_sph_eval(J2,K2)*sph_g(q,3)
            end do
            buf4=buf1+buf2+buf3
            
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf4)
         end do
      end do
      res = Nucm_AU*totalreduced*W3J(J1,1,J2,-M1,qs,M2)
      return
      
27    continue
      !This is the same as the upper relations
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0.0d0
            buf2=0.0d0
            buf3=0.0d0
            
            buf1=buf1+iuPow(J1+J2-K2-1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,-1,K2+1)*Jplus_sph_eval(J2,K2)*sph_g(1,1)
            buf1=buf1+iuPow(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,-1,k2)*K2*sph_g(1,2)
            buf1=buf1+iuPow(J1+J2-K2+1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,-1,K2-1)*Jminus_sph_eval(J2,K2)*sph_g(1,3)
            
            buf2=buf2+iuPow(J1+J2-K2-1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,0,K2+1)*Jplus_sph_eval(J2,K2)*sph_g(2,1)
            buf2=buf2+iuPow(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,0,K2)*K2*sph_g(2,2)
            buf2=buf2+iuPow(J1+J2-K2+1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,0,K2-1)*Jminus_sph_eval(J2,K2)*sph_g(2,3)
            
            buf3=buf3+iuPow(J1+J2-K2-1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,1,K2+1)*Jplus_sph_eval(J2,K2)*sph_g(3,1)
            buf3=buf3+iuPow(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,1,K2)*K2*sph_g(3,2)
            buf3=buf3+iuPow(J1+J2-K2+1-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,1,K2-1)*Jminus_sph_eval(J2,K2)*sph_g(3,3)
            
            
            buf4=buf1+buf2+buf3
            
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf4)
         end do
      end do
      res = Nucm_AU*totalreduced*W3J(J1,1,J2,-M1,qs,M2)
      
      
   end subroutine TRANS_MAG_Q
             
   function TRANS_MAG_SPACE_ALPHA_COSE_ANALYTICAL_Z(J1,J2,K1,K2,M1,M2) result(res)
      integer(4) J1,J2,K1,K2,M1,M2,absdiffk
      integer(4) i,j,diffJ,diffK,diffM,PMI,MPI
      complex(8) res,iu,PM,MP !PM = plus minus
      
      parameter(iu=(0d0,1d0))
      
      diffJ=J2-J1
      diffK=K2-K1
      res=(0d0,0d0)
      absdiffk=abs(diffK)
      if(M1/=M2)return
      
      select case(diffJ)
         case(0)
            select case(diffK)
               case(0)
                  res=nucm_cgs*M1*((gt(1,1)+gt(2,2))*0.5d0+dble(K1**2)/dble(J1*(J1+1))*(gt(3,3)-0.5d0*(gt(1,1)+gt(2,2)))+0.5d0*iu*dble(K1)/dble(J1*(J1+1))*(gt(2,1)-gt(1,2)))
               case(1)
                  !res=nucm_cgs*M1*(sqrt(dble(J1*(J1+1)-K1*(K1+1)))/dble(4*J1*(J1+1)))*(iu*(dble(K1)*(gt(3,1)+gt(1,3))+dble(K1+1)*(gt(1,3)+gt(3,1)))+dble(K1)*(gt(3,2)+gt(2,3))+dble(K1+1)*(gt(2,3)+gt(3,2)))
                  res=2d0*nucm_cgs*M1*(sqrt(dble(J1*(J1+1)-K1*(K1+1)))/dble(4*J1*(J1+1)))*(iu*(dble(K1)*(gt(3,1))+dble(K1+1)*(gt(1,3)))+dble(K1)*(gt(3,2))+dble(K1+1)*(gt(2,3)))
               case(2)
                  res=nucm_cgs*M1*(sqrt(dble((J1*(J1+1)-K1*(K1+1))*(J1*(J1+1)-(K1+1)*(K1+2))))/dble(8*J1*(J1+1)))*(2d0*(gt(2,2)-gt(1,1))+iu*(2d0*gt(1,2)+2d0*gt(2,1)))
               case default
                  
            end select
         case(1)
            select case(absdiffk)
               case(0)
                  !res=nucm_cgs*1d0/dble(2*(J1+1))*sqrt(dble(((J1+1)**2-K1**2)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(dble(K1)*(2d0*gt(3,3)-gt(1,1)-gt(2,2))-iu*(dble(J1)*(gt(1,2)-gt(2,1))+dble(J1+2)*(gt(1,2)-gt(2,1))))
                  res=nucm_cgs*1d0/dble(2*(J1+1))*sqrt(dble(((J1+1)**2-K1**2)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(dble(K1)*(2d0*gt(3,3)-gt(1,1)-gt(2,2))-iu*((gt(1,2)-gt(2,1))*(dble(J1)+2d0)))
                  !res=nucm_cgs*1d0/dble(2*(J1+1))*sqrt(dble(((J1+1)**2-K1**2)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(dble(K1)*(2d0*gt(3,3)-gt(1,1)-gt(2,2))-iu*(dble(J1)*(gt(1,2)-gt(2,1))))
               case(1)
                  if(diffK>0)then
                     PM=(1d0,0d0)
                     MP=(-1d0,0d0)
                     PMI=1d0
                     MPI=-1d0
                  else
                     PM=(-1d0,0d0)
                     MP=(1d0,0d0)
                     PMI=-1d0
                     MPI=1d0
                  end if
                  
                  res=nucm_cgs*1d0/dble(2*(J1+1))*sqrt(dble((J1+PMI*K1+1)*(J1+PMI*K1+2)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(-dble(K1)*(iu*gt(1,3)+PM*gt(2,3))-dble(K1+PMI)*(iu*gt(1,3)+PM*gt(2,3))+dble(J1+PMI*K1)*(gt(3,2)+PM*gt(3,1))+dble(J1+PMI*K1+1)*(gt(3,2)+iu*PM*gt(3,1)))
                  !res=nucm_cgs*1d0/dble(2*(J1+1))*sqrt(dble((J1+PMI*K1+1)*(J1+PMI*K1+2)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(-dble(K1+PMI)*(iu*gt(1,3)+PM*gt(2,3))+dble(J1+PMI*K1+1)*(gt(3,2)+PM*iu*gt(3,1)))
                  !res=nucm_cgs*1d0/dble(2*(J1+1))*sqrt(dble((J1+PMI*K1+1)*(J1+PMI*K1+2)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(-iu*gt(1,3)*dble(K1+1)+MP*gt(2,3)*dble(K1+PMI)+gt(3,2)*dble(J1+PMI*K1+1)+iu*gt(3,1)*dble(PMI*J1+K1+1))
               case(2)
                  if(diffK>0)then
                     PM=(1d0,0d0)
                     MP=(-1d0,0d0)
                     PMI=1d0
                     MPI=-1d0
                  else
                     PM=(-1d0,0d0)
                     MP=(1d0,0d0)
                     PMI=-1d0
                     MPI=1d0
                  end if
                  res=nucm_cgs*1d0/dble(4*(J1+1))*sqrt(dble((J1+PMI*K1)*(J1+PMI*K1+1)*(J1+PMI*K1+2)*(J1+PMI*K1+3)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(PM*(gt(1,1)-gt(2,2))-0.5d0*iu*(gt(1,2)+gt(1,2)+gt(2,1)+gt(2,1)))
                  !res=nucm_cgs*1d0/dble(4*(J1+1))*sqrt(dble((J1+PMI*K1)*(J1+PMI*K1+1)*(J1+PMI*K1+2)*(J1+PMI*K1+3)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(PM*(gt(1,1)-gt(2,2))-0.5d0*iu*(gt(1,2)+gt(2,1)))
                  !res=nucm_cgs*1d0/dble(4*(J1+1))*sqrt(dble((J1+PMI*K1+1)*(J1+PMI*K1+2)*(J1+PMI*K1+3)*((J1+1)**2-M1**2))/dble((2*J1+1)*(2*J1+3)))*(PM*(gt(1,1)-gt(2,2))-0.5d0*iu*(gt(1,2)+gt(2,1)))
                  !res=nucm_cgs*1d0/dble(4*(J1+1))*sqrt(dble((J1+1)**2-M1**2)/dble((2*J1+1)*(2*J1+3)))*dble(J1+PMI*K1+2)*sqrt(dble((J1-K1+MPI)*(J1+K1+PMI)))*(PM*(gt(1,1)+MP*gt(2,2))+MP*iu*(gt(2,1)+PM*gt(1,2)))
               case default
                  
            end select
         case default
            
      end select
      PMI=2
   end function TRANS_MAG_SPACE_ALPHA_COSE_ANALYTICAL_Z
             
   !matrix element of transition magnetic dipole in cartesian ALPHA (X,Y or Z), using direction cosines
   function TRANS_MAG_SPACE_ALPHA_COSE(cg,ce,J1,J2,T1,T2,M1,M2,labaxis) result(res)
      COMPLEX(8) res,buf(3),ga(3,3),iu,jkcos1,jkcos2,jkcos3,jmcos,gcor(3)
      integer(4) J1,J2,K1,K2,M1,M2,rank,T1,T2,i
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1),jcos,buf1,buf2,buf3,buf4
      character(1) labaxis,axes(3)
      logical fex
      
      axes=(/'X','Y','Z'/)
      iu=(0d0,1d0)
      
      do i = 1,3
         ga(i,1)=(gt(i,2)+iu*gt(i,1))*0.5d0
         ga(i,2)=gt(i,3)
         ga(i,3)=(gt(i,2)-iu*gt(i,1))*0.5d0
      end do
      gcor(1)=0.5d0*iu*(gt(2,3)-gt(3,2))
      gcor(2)=0.5d0*iu*(gt(3,1)-gt(1,3))
      gcor(3)=0.5d0*iu*(gt(1,2)-gt(2,1))
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      res=(0d0,0d0)
      jcos=DIR_COSE_J(J1,J2)
      jmcos=DIR_COSE_M(J1,J2,M1,M2,labaxis)
      do K1 = -J1,J1
         do K2 = max(K1-2,-J2),min(K1+2,J2) !or equivalently: K2 = -J2,J2, but matrix elements outside of the K1-2:K1+2 range are zero
            do i = 1,3
               jkcos1=DIR_COSE_K(J1,J2,K1,K2-1,axes(i))
               jkcos3=DIR_COSE_K(J1,J2,K1,K2+1,axes(i))
               jkcos2=DIR_COSE_K(J1,J2,K1,K2,axes(i))
               buf(i)=ga(i,1)*jkcos1*Jplus_eval(J2,K2)+ga(i,2)*jkcos2*K2+ga(i,3)*jkcos3*Jminus_eval(J2,K2)
            end do
            buf(1)=buf(1)+DIR_COSE_K(J1,J2,K1,K2,'X')*gcor(1)
            buf(2)=buf(2)+DIR_COSE_K(J1,J2,K1,K2,'Y')*gcor(2)
            buf(3)=buf(3)+DIR_COSE_K(J1,J2,K1,K2,'Z')*gcor(3)
            res=res+cgb(K1+J1+1)*ceb(K2+J2+1)*sum(buf)
         end do
      end do
2754  format(E15.8,1X,SP,E15.8,"i",SS,4X,E15.8,1X,SP,E15.8,"i",SS,6(I3,1X))      
2755  format(A92)
      res=NucM_CGS*res*jcos*jmcos
   end function TRANS_MAG_SPACE_ALPHA_COSE
    
   !matrix element of transition magnetic dipole in cartesian X
   subroutine TRANS_MAG_X(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8) res,totalreduced,buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag)then
         res = TRANS_MAG_SPACE_ALPHA_COSE(cg,ce,J1,J2,T1,T2,M1,M2,'X')
         return
      end if

      !total reduced might be unreliable like this
      res=NucM_AU*TRANS_MAG_X_SPHG(cg,ce,J1,J2,T1,T2,M1,M2)
      totalreduced=res/DIR_COSE_M(J1,J2,M1,M2,'X')
   end subroutine TRANS_MAG_X
   
   !matrix element of transition magnetic dipole in cartesian Y
   subroutine TRANS_MAG_Y(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8) res,totalreduced,buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag)then
         !call TRANS_MAG_ALPHA_COSE(cg,ce,J1,J2,T1,T2,M1,M2,'X',res,totalreduced)
         res = TRANS_MAG_SPACE_ALPHA_COSE(cg,ce,J1,J2,T1,T2,M1,M2,'Y')
         return
      end if
      
      res=NucM_AU*TRANS_MAG_Y_SPHG(cg,ce,J1,J2,T1,T2,M1,M2)
      totalreduced=res/DIR_COSE_M(J1,J2,M1,M2,'Y')
   end subroutine TRANS_MAG_Y
   
   !matrix element of transition magnetic dipole in cartesian Z
   subroutine TRANS_MAG_Z(cg,ce,J1,J2,T1,T2,M1,M2,res,totalreduced)
      COMPLEX(8) res,totalreduced,buf1,buf2
      integer(4) J1,J2,K1,K2,M1,M2,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag)then
         !call TRANS_MAG_ALPHA_COSE(cg,ce,J1,J2,T1,T2,M1,M2,'X',res,totalreduced)
         res = TRANS_MAG_SPACE_ALPHA_COSE(cg,ce,J1,J2,T1,T2,M1,M2,'Z')
         return
      end if
      
      res=NucM_AU*TRANS_MAG_Z_SPHG(cg,ce,J1,J2,T1,T2,M1,M2)
      totalreduced=res/DIR_COSE_M(J1,J2,M1,M2,'Z')
   end subroutine TRANS_MAG_Z
   
   !matrix element of transition electric quadrupole (rank 1) in spherical q-coordinate (-1,0 or 1), using wigner matrices
   subroutine TRANS_QUAD_Q_1(cg,ce,J1,J2,T1,T2,M1,M2,qs,res,totalreduced)
      COMPLEX(8) res,totalreduced,buf1
      integer(4) J1,J2,K1,K2,M1,M2,q,qs,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      buf1=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      totalreduced=0d0
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0d0
            do q = 1,3
               buf1 = buf1 + iuPow(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,1,J2,-K1,q-2,K2)*SPH_quad1(q)
            end do
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf1)
         end do
      end do
      
      !the totalreduced might be unreliable like this
      res = totalreduced*W3J(J1,1,J2,-M1,qs,M2)
   end subroutine TRANS_QUAD_Q_1
   
   !matrix element of transition electric quadrupole (rank 2) in spherical q-coordinate (-2, -1, 0, 1 or 2), using wigner matrices
   subroutine TRANS_QUAD_Q_2(cg,ce,J1,J2,T1,T2,M1,M2,qs,res,totalreduced)
      COMPLEX(8) res,totalreduced,buf1
      integer(4) J1,J2,K1,K2,M1,M2,q,qs,rank,T1,T2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      buf1=0.0d0
      res=0.0d0
      rank=1
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      totalreduced=0d0
      !|J,T,M> = sumK(Cjkm*|J,K,M>)
      do K1 = -J1,J1
         do K2 = -J2,J2
            buf1=0d0
            do q = 1,5
               buf1 = buf1 + iuPow(J1+J2-K2-K1)*(-1d0)**(J1-M1)*sqrt(dble((2*J1+1)*(2*J2+1)))*W3J(J1,2,J2,-K1,q-3,K2)*SPH_quad2(q)
            end do
            totalreduced=totalreduced + cgb(K1+J1+1)*ceb(K2+J2+1)*(buf1)
         end do
      end do
      
      !the totalreduced might be unreliable like this
      
      res = totalreduced*W3J(J1,2,J2,-M1,qs,M2)
   end subroutine TRANS_QUAD_Q_2
   
   !matrix element of transition electric quadrupole in cartesian XZ, using wigner matrices
   !dumb
   function TRANS_QUAD_XZ(cg,ce,J1,J2,T1,T2,M1,M2) result(res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4
      integer(4) J1,J2,T1,T2,M1,M2,q,rank,k1,k2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag.eqv..true.)then
         res=TRANS_QUAD_XZ_COSE(cg,ce,J1,J2,T1,T2,M1,M2)
         return
      end if
      
      res=0.0d0
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      do k1=-J1,J1
         do k2=-J2,J2
            
            rank=2
            buf1=0d0
            buf2=0d0
            do q = 1,5
               buf1=buf1+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-3,rank)*SPH_quad2(q)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-3,rank)*SPH_quad2(q)
            end do
            
            rank=1
            buf3=0d0
            buf4=0d0
            do q = 1,3
               buf3=buf3+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-2,rank)*SPH_quad1(q)
               buf4=buf4+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-2,rank)*SPH_quad1(q)
            end do
            res = res + cgb(K1+J1+1)*ceb(K2+J2+1)*(-1.0d0/2.0d0)*(buf1-buf2+buf3+buf4)
         end do
      end do
   end function TRANS_QUAD_XZ
   
   !matrix element of transition electric quadrupole in cartesian XZ, using FIRST RANK direction cosines
   !which means you have to sum over non-zero combinations of (J1,J3) and (J3,J2) states
   function TRANS_QUAD_XZ_COSE(cg,ce,J1,J2,T1,T2,M1,M2) result(res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4
      integer(4) J1,J2,T1,T2,M1,M2,q,rank,k1,k2,J3,K3,M3,i,j
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      character(1) axes(3)
   
      axes=(/'X','Y','Z'/)
      res=0.0d0
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      do k1=-J1,J1
         do k2=-J2,J2
            buf2=(0d0,0d0)
            buf1=(0d0,0d0)
            do i = 1,3
               do j =1,3
                  do J3=max(J1-1,J2-1),min(J1+1,J2+1)
                     do K3=max(k1-1,k2-1),min(k1+1,k2+1)
                        do M3=max(m1-1,m2-1),min(m1+1,m2+1)
                           if(((j3==j1).AND.(j3==0)).OR.((j3==j2).AND.(j3==0)))then
                              cycle
                           end if
                           !it just works
                           buf1=buf1+quad(i,j)*DIR_COSE_J(J1,J3)*DIR_COSE_J(J3,J2)*DIR_COSE_K(J1,J3,K1,K3,axes(i))*DIR_COSE_K(J3,J2,K3,K2,axes(j))*DIR_COSE_M(J1,J3,M1,M3,axes(1))*DIR_COSE_M(J3,J2,M3,M2,axes(3))
                        end do
                     end do
                  end do
                  !buf2=buf2+quad(i,j)*buf1
               end do
            end do
            res = res + cgb(K1+J1+1)*ceb(K2+J2+1)*buf1
         end do
      end do
   end function TRANS_QUAD_XZ_COSE
   
   !matrix element of transition electric quadrupole in cartesian YZ, using wigner matrices
   !dumb
   function TRANS_QUAD_YZ(cg,ce,J1,J2,T1,T2,M1,M2) result(res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4
      integer(4) J1,J2,T1,T2,M1,M2,q,rank,k1,k2
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      
      if(dircoseFlag.eqv..true.)then
         res=TRANS_QUAD_YZ_COSE(cg,ce,J1,J2,T1,T2,M1,M2)
         return
      end if
      
      buf1=0.0d0
      buf2=0.0d0
      buf3=0.0d0
      buf4=0.0d0
      res=0.0d0
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      do k1=-J1,J1
         do k2=-J2,J2
            
            rank=2
            buf1=0d0
            buf2=0d0
            do q = 1,5
               buf1=buf1+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-3,rank)*SPH_quad2(q)
               buf2=buf2+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-3,rank)*SPH_quad2(q)
            end do
            
            rank=1
            buf3=0d0
            buf4=0d0
            do q = 1,3
               buf3=buf3+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,1,q-2,rank)*SPH_quad1(q)
               buf4=buf4+WIGNER_MATEL(J1,J2,K1,K2,M1,M2,-1,q-2,rank)*SPH_quad1(q)
            end do
            res = res + cgb(K1+J1+1)*ceb(K2+J2+1)*CMPLX(0.0d0,1.0d0,kind=8)*(1.0d0/2.0d0)*(buf1+buf2+buf3-buf4)
         end do
      end do
   end function TRANS_QUAD_YZ
   
   !matrix element of transition electric quadrupole in cartesian YZ, using FIRST RANK direction cosines
   function TRANS_QUAD_YZ_COSE(cg,ce,J1,J2,T1,T2,M1,M2) result(res)
      COMPLEX(8) res,buf1,buf2,buf3,buf4
      integer(4) J1,J2,T1,T2,M1,M2,q,rank,k1,k2,J3,K3,M3,i,j
      real(8) cg(2*J1+1,2*J1+1),ce(2*J2+1,2*J2+1),cgb(2*J1+1),ceb(2*J2+1)
      character(1) axes(3)
   
      axes=(/'X','Y','Z'/)
      res=0.0d0
      cgb=cg(:,T1+J1+1)
      ceb=ce(:,T2+J2+1)
      do k1=-J1,J1
         do k2=-J2,J2
            buf2=(0d0,0d0)
            do i = 1,3
               do j =1,3
                  buf1=(0d0,0d0)
                  do J3=max(J1-1,J2-1),min(J1+1,J2+1)
                     do K3=max(k1-1,k2-1),min(k1+1,k2+1)
                        do M3=max(m1-1,m2-1),min(m1+1,m2+1)
                           if(((j3==j1).AND.(j3==0)).OR.((j3==j2).AND.(j3==0)))then
                              cycle
                           end if
                           buf1=buf1+DIR_COSE_J(J1,J3)*DIR_COSE_J(J3,J2)*DIR_COSE_K(J1,J3,K1,K3,axes(i))*DIR_COSE_K(J3,J2,K3,K2,axes(j))*DIR_COSE_M(J1,J3,M1,M3,axes(2))*DIR_COSE_M(J3,J2,M3,M2,axes(3))
                        end do
                     end do
                  end do
                  buf2=buf2+quad(i,j)*buf1
               end do
            end do
            res = res + cgb(K1+J1+1)*ceb(K2+J2+1)*buf2
         end do
      end do
   end function TRANS_QUAD_YZ_COSE
   

end program main 
!7700 lines bay-bee! That has to be a record.
   
   