LCOV - code coverage report
Current view: top level - core - corehff.f (source / functions) Hit Total Coverage
Test: combined.info Lines: 0 15 0.0 %
Date: 2019-09-08 04:53:50 Functions: 0 1 0.0 %

          Line data    Source code
       1             : c............................................................corehff
       2           0 :       SUBROUTINE corehff(mrad,kap1,kap2,xmj,s,nsol,bhf,gck,fck,
       3           0 :      +                   rc,dx,jtop)
       4             : C   ********************************************************************
       5             : C   *                                                                  *
       6             : C   *   CALCULATE THE RELATIVISTIC HYPERFINE FIELDS FOR THE            *
       7             : C   *                  CURRENT  CORE STATE S                           *
       8             : C   *                                                                  *
       9             : C   *   THE WAVE FUNCTION  {G(K,S),F(K,S)}  IS NORMALIZED TO 1         *
      10             : C   *                                                                  *
      11             : C   ********************************************************************
      12             : 
      13             :       IMPLICIT NONE
      14             : C CONVERSION FACTOR FOR HYPERFINE FIELDS FROM A.U. TO GAUSS
      15             : C                                      ELECTRON CHARGE     IN ESU
      16             : C                                      BOHR-RADIUS         IN CM
      17             : c
      18             : c
      19             : C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      20             : C   ANGULAR HYPERFINE MATRIX ELEMENTS   SEE E.G.  E.M.ROSE
      21             : C        THE FACTOR  I  HAS BEEN OMITTED
      22             : C
      23             : C     .. Parameters ..
      24             :       REAL e0
      25             :       PARAMETER (e0=1.6021892e-19*2.997930e+09)
      26             :       REAL a0
      27             :       PARAMETER (a0=0.52917706e-08)
      28             :       REAL cautog
      29             :       PARAMETER (cautog=e0/ (a0*a0))
      30             : C     ..
      31             : C     .. Scalar Arguments ..
      32             :       INTEGER, INTENT (IN) :: mrad
      33             :       REAL bhf,dx,xmj
      34             :       INTEGER jtop,kap1,kap2,nsol,s
      35             : C     ..
      36             : C     .. Array Arguments ..
      37             :       REAL fck(2,2,mrad),gck(2,2,mrad),rc(mrad)
      38             : C     ..
      39             : C     .. Local Scalars ..
      40             :       INTEGER n
      41             : C     ..
      42             : C     .. Local Arrays ..
      43           0 :       REAL ame(2,2),rint(mrad)
      44             : C     ..
      45             : C     .. External Functions ..
      46             :       REAL rsimp
      47             :       EXTERNAL rsimp
      48             : C     ..
      49             : C     .. Intrinsic Functions ..
      50             :       INTRINSIC real,sqrt
      51             : C     ..
      52           0 :       ame(1,1) = 4.0*kap1*xmj/ (4.0*kap1*kap1-1.0)
      53           0 :       IF (nsol.EQ.2) THEN
      54           0 :          ame(2,2) = 4.0*kap2*xmj/ (4.0*kap2*kap2-1.0)
      55           0 :          ame(2,1) = sqrt(0.25- (xmj/real(kap1-kap2))**2)
      56           0 :          ame(1,2) = ame(2,1)
      57             :       END IF
      58             : C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      59           0 :       IF (nsol.EQ.1) THEN
      60           0 :          DO n = 1,jtop
      61             :             rint(n) = (gck(1,s,n)*fck(1,s,n)+fck(1,s,n)*gck(1,s,n))*
      62           0 :      +                ame(1,1)
      63             :          END DO
      64             :       ELSE
      65           0 :          DO n = 1,jtop
      66             :             rint(n) = (gck(1,s,n)*fck(1,s,n)+fck(1,s,n)*gck(1,s,n))*
      67             :      +                ame(1,1) + (gck(2,s,n)*fck(2,s,n)+
      68             :      +                fck(2,s,n)*gck(2,s,n))*ame(2,2) +
      69             :      +                (gck(2,s,n)*fck(1,s,n)+fck(2,s,n)*gck(1,s,n))*
      70             :      +                ame(2,1) + (gck(1,s,n)*fck(2,s,n)+
      71           0 :      +                fck(1,s,n)*gck(2,s,n))*ame(1,2)
      72             :          END DO
      73             :       END IF
      74           0 :       bhf = -cautog*rsimp(mrad,rint,rc,jtop,dx)*0.001
      75             : c      write(6,'(''hf='',e14.7)') BHF
      76           0 :       RETURN
      77             :       END

Generated by: LCOV version 1.13