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
|
MODULE TEST
IMPLICIT NONE
INTEGER, PARAMETER :: dp=KIND(0.0D0)
TYPE mulliken_restraint_type
INTEGER :: ref_count
REAL(KIND = dp) :: strength
REAL(KIND = dp) :: TARGET
INTEGER :: natoms
INTEGER, POINTER, DIMENSION(:) :: atoms
END TYPE mulliken_restraint_type
CONTAINS
SUBROUTINE INIT(mulliken)
TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken
ALLOCATE(mulliken%atoms(1))
mulliken%atoms(1)=1
mulliken%natoms=1
mulliken%target=0
mulliken%strength=0
END SUBROUTINE INIT
SUBROUTINE restraint_functional(mulliken_restraint_control,charges, &
charges_deriv,energy,order_p)
TYPE(mulliken_restraint_type), &
INTENT(IN) :: mulliken_restraint_control
REAL(KIND=dp), DIMENSION(:, :), POINTER :: charges, charges_deriv
REAL(KIND=dp), INTENT(OUT) :: energy, order_p
INTEGER :: I
REAL(KIND=dp) :: dum
charges_deriv=0.0_dp
order_p=0.0_dp
DO I=1,mulliken_restraint_control%natoms
order_p=order_p+charges(mulliken_restraint_control%atoms(I),1) &
-charges(mulliken_restraint_control%atoms(I),2)
ENDDO
energy=mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)**2
dum=2*mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)
DO I=1,mulliken_restraint_control%natoms
charges_deriv(mulliken_restraint_control%atoms(I),1)= dum
charges_deriv(mulliken_restraint_control%atoms(I),2)= -dum
ENDDO
END SUBROUTINE restraint_functional
END MODULE
USE TEST
IMPLICIT NONE
TYPE(mulliken_restraint_type) :: mulliken
REAL(KIND=dp), DIMENSION(:, :), POINTER :: charges, charges_deriv
REAL(KIND=dp) :: energy,order_p
ALLOCATE(charges(1,2),charges_deriv(1,2))
charges(1,1)=2.0_dp
charges(1,2)=1.0_dp
CALL INIT(mulliken)
CALL restraint_functional(mulliken,charges,charges_deriv,energy,order_p)
write(6,*) order_p
END
|
