ccsdnt.f 2.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
      MODULE m_ccsdnt
c...........................................................ccdnt
c charge and spin density calculations
c
      CONTAINS
      SUBROUTINE ccsdnt(
     >                  mrad,is,jtop,nsol,
     >                  l,xmj,kap1,kap2,gck,fck,rc2,
     <                  rhochr,rhospn)
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: mrad
      REAL xmj
      INTEGER is,jtop,kap1,kap2,l,nsol
C     ..
C     .. Array Arguments ..
      REAL fck(2,2,mrad),gck(2,2,mrad),rc2(mrad)
      REAL, INTENT (OUT) :: rhochr(mrad),rhospn(mrad)
C     ..
C     .. Local Scalars ..
      REAL cg1,cg2,cg4,cg5,cg8,cgo
      INTEGER ir,k,n
C     ..
C     .. Local Arrays ..
      REAL cgd(2),cgmd(2)
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,sqrt
C     ..
      DO ir = 1,mrad
         rhochr(ir) = 0.0
         rhospn(ir) = 0.0
      END DO
c                       -----------------------------------
c                       coeffisients for spin-density
c                       -----------------------------------
c      KAP1 = - L - 1
c      KAP2 = + L
      cg1 = -xmj/ (kap1+0.50)
      cg5 = -xmj/ (-kap1+0.50)
      cgd(1) = cg1
      cgmd(1) = cg5
      IF (abs(xmj).GT.l) THEN
         cg2 = 0.00
         cg4 = 0.00
         cg8 = 0.00
         cgd(2) = 0.00
         cgo = 0.00
         cgmd(2) = 0.00
      ELSE
         cg2 = -sqrt(1.0- (xmj/ (kap1+0.50))**2)
         cg4 = -xmj/ (kap2+0.50)
         cg8 = -xmj/ (-kap2+0.50)
         cgd(2) = cg4
         cgo = cg2
         cgmd(2) = cg8
      END IF
C
      DO n = 1,jtop
         DO k = 1,nsol
            rhochr(n) = rhochr(n) + rc2(n)*
     +                  (gck(k,is,n)**2+fck(k,is,n)**2)
            rhospn(n) = rhospn(n) + rc2(n)*
     +                  (gck(k,is,n)*gck(k,is,n)*cgd(k)-
     +                  fck(k,is,n)*fck(k,is,n)*cgmd(k))
         END DO
      END DO
c
      IF (nsol.GT.1) THEN
         DO n = 1,jtop
            rhospn(n) = rhospn(n) + rc2(n)*
     +                  (gck(1,is,n)*gck(2,is,n)*cgo*2.)
         END DO
      END IF
c
      END SUBROUTINE ccsdnt
      END MODULE m_ccsdnt