src/dispersion.f90: mark colddisp a pure function

src/dispersion.f90

@@ -10,32 +10,43 @@ module dispersion
   real(wp_), dimension(npts+1), save :: ttv,extv
 !
 contains
-!
-!
-subroutine colddisp(xg,yg,npl,nprf,sox)  
-! solution cold dispersion relation
-!
+
+
+pure function colddisp(xg, yg, npl, sox) result(npr)
+  ! Cold plasma dispersion relation
+
+  ! Given the parallel component of refractive index returns
+  ! the orthogonal one.
+  !
+  ! Reference: IFP-CNR Internal Report FP 05/1 - App. A
+  !
   implicit none
-! arguments
-!  xg   = omegap^2/omega^2
-!  yg   = omegac/omega
-!  npl  = N parallel to B
-!  nprf = N perpendicular to B (cold)
-!  sox  = mode (-1 => O mode, +1 => X mode)
-  real(wp_) :: xg,yg,npl,nprf,sox
-! local variables
-  real(wp_) :: yg2,npl2,dnl,del,dxg
-!  
-  npl2=npl*npl
-  dnl=one-npl2
-  dxg=one-xg
-  yg2=yg*yg
-  del=sqrt(dnl*dnl+4.0_wp_*npl2*dxg/yg2)
-  nprf=sqrt(dxg-npl2-xg*yg2*(one+npl2+sox*del)/(dxg-yg2)/2.0_wp_)
-!
-end subroutine colddisp
-!
-!
+
+  ! subroutine arguments
+
+  ! CMA diagram variables: X=(ω_pe/ω)², Y=ω_ce/ω
+  real(wp_), intent(in) :: xg, yg
+
+  ! cold refractive index: N∥, N⊥
+  real(wp_), intent(in)  :: npl
+  real(wp_)              :: npr
+
+  ! sign of polarisation mode: -1 ⇒ O, +1 ⇒ X
+  real(wp_), intent(in) :: sox
+
+  ! local variables
+  real(wp_) :: yg2, npl2, dnl, del, dxg
+
+  npl2 = npl**2
+  yg2  = yg**2
+  dnl  = one - npl2
+  dxg  = one - xg
+  del  = sqrt(dnl**2 + 4.0_wp_*npl2*dxg/yg2)
+  npr  = sqrt(dxg - npl2 - xg*yg2 * (one + npl2 + sox*del)/(dxg - yg2)/2.0_wp_)
+
+end function colddisp
+
+
 !
 subroutine harmnumber(yg,mu,npl,nhmin,nhmax,iwr)
 ! computation of minimum and maximum harmonic
@@ -114,26 +125,35 @@ subroutine warmdisp(xg,yg,mu,npl,nprf,sox,lrm,err,nprr,npri,fast,imx,ex,ey,ez)
   complex(wp_) :: cc0,cc2,cc4,discr,rdiscr,npra2,npra,npr,npr2,e330,e11,e22, &
                   e12,e13,e23,a11,a22,a33,a12,a13,a23,a330,a1122,a123,a330n, &
                   cc0t,cc2t,cc4t
-  complex(wp_) :: epsl(3,3,lrm),sepsl(3,3)
+
+  ! eij: dielectric tensor
+
+  complex(wp_) :: epsl(3,3,lrm)  !
+  complex(wp_) :: sepsl(3,3)     !  
+
 !
   err=0
   errnpr=one
-  npra2=nprf**2
+  npra2=nprf**2  ! first guest N⊥ (usually cold)
   npl2=npl*npl
   dnl=one-npl2
   imxx=abs(imx)
-!
-  if (fast.eq.1) then
+
+  ! Compute dielectric tensor elements
+  ! returns ε^l/X
+  if (fast == 1) then
     call diel_tens_wr(yg,mu,npl,a330,epsl,lrm)
   else
     call diel_tens_fr(yg,mu,npl,a330,epsl,lrm,fast)
   end if
-  a330= xg*a330
-  e330= one + a330
-!
-  do
-    do i=1,imxx
-!  
+
+  a330 = xg*a330
+  e330 = one + a330
+
+  tries_loop: do
+    iterations_loop: do i=1, imxx
+
+      ! sum the ε^l up to lrm
       do j=1,3
         do k=1,3
           sepsl(k,j)=czero
@@ -142,86 +162,84 @@ subroutine warmdisp(xg,yg,mu,npl,nprf,sox,lrm,err,nprr,npri,fast,imx,ex,ey,ez)
           end do
         end do
       end do
-!
+
       npra=sqrt(npra2)
-!
+
       a11 = xg*sepsl(1,1)
       a22 = xg*sepsl(2,2)
       a12 = xg*sepsl(1,2)
       a33 = xg*sepsl(3,3)
       a13 = xg*sepsl(1,3)
       a23 = xg*sepsl(2,3)
-!      a31 = a13
-!      a32 =-a23
-!
+      ! a31 = a13
+      ! a32 =-a23
+
       e11 = one + a11
       e22 = one + a22
       e12 = a12
-!      e33 = e330 + npra2*a33
+      ! e33 = e330 + npra2*a33
       e13 = npra*a13
       e23 = npra*a23
-!      e21 =-e12
-!      e31 = e13
-!      e32 =-e23
-!
-!      if(i.gt.2.and.errnpr.lt.1.0e-3_wp_) exit
-!
-      cc4 = (a11 + dnl)*(one - a33) + (a13 + npl)*(a13 + npl)
-      cc2 =-a12*a12*(one - a33) + two*a23*a12*(a13 + npl) &
+      ! e21 =-e12
+      ! e31 = e13
+      ! e32 =-e23
+
+      ! A, B, C coefficients of the biquadratic (eq. 29)
+      ! AN⊥⁴ + BN⊥² + C = 0
+      cc4 = (a11 + dnl)*(one - a33) + (a13 + npl)*(a13 + npl)   ! A
+      cc2 =-a12*a12*(one - a33) + two*a23*a12*(a13 + npl) &     ! B
            -(e330 + (a22 + dnl)*(one - a33) - a23*a23)*(a11 + dnl) &
            -(a13 + npl)*(a13 + npl)*(a22 + dnl)
-      cc0 = e330*((a11 + dnl)*(a22 + dnl) + a12*a12)
-!
+      cc0 = e330*((a11 + dnl)*(a22 + dnl) + a12*a12)            ! C
+
       cc4t = cc4 - one
       cc2t = half*cc2 + dnl
       cc0t = cc0 - dnl*dnl
-!
+
       a1122 = a11*a22 + a12*a12
       a330n = a330 + dnl*a33
       a123  = a12*a23 - a13*a22
-!
+
+      ! Discriminant Δ = B² - 4*A*C
+      ! Note: this has been rewritten to avoid floating points cancellation
       discr = (cc2t*cc2t - cc0t*cc4t) &
              -( npl2*a1122 + dnl*a22*a330n + (dnl*a23)**2 + two*dnl*npl*a123 &
                + a1122*a330n + dnl*a13*a123 + dnl*a23*(a12*a13 + a11*a23) )
-!
-!      if(yg.gt.one) then
-!        s=sox
-!        if(dimag(discr).LE.zero) s=-s
-!      else
-!        s=-sox
-!        if(dimag(discr).ge.zero) s=-s
-!      end if
-!
+
       rdiscr=sqrt(discr)
-      if(dimag(rdiscr/cc4).gt.0.0d0) then
-!      if(dimag(discr).gt.0.0d0) then
-        s=sox
+
+      ! Choice of the solution (±) for the given mode
+      if(dimag(rdiscr/cc4) > zero) then
+        s = sox
       else
-        s=-sox
+        s = -sox
       end if
-!
-      npr2=(s*rdiscr - half*cc2)/cc4
-!
+
+      npr2 = (s*rdiscr - half*cc2)/cc4
+
       errnpr=abs(one-abs(npr2)/abs(npra2))
       if(i.gt.1.and.errnpr.lt.1.0e-5_wp_) exit
       npra2=npr2
-    end do
+    end do iterations_loop
 
     if(i.gt.imxx.and.imxx.gt.1) then
       if (imx.lt.0) then
+        ! first try failed
         err=1
         imxx=1
         npra2=nprf**2
       else
+        ! first try failed, no retry
         err=2
         exit
       end if
     else
+      ! converged or second try
       exit
     end if
-        
-  end do 
-!
+
+  end do tries_loop
+
   if(dble(sqrt(npr2)).lt.zero.or.npr2.ne.npr2.or.abs(npr2).ge.huge(one).or. &
      abs(npr2).le.tiny(one)) then
     npr2=czero