OSDN Git Service

2007-07-04 Daniel Berlin <dberlin@dberlin.org>
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.fortran-torture / execute / pr32604.f90
1 MODULE TEST
2   IMPLICIT NONE
3   INTEGER, PARAMETER :: dp=KIND(0.0D0)
4   TYPE mulliken_restraint_type
5     INTEGER                         :: ref_count
6     REAL(KIND = dp)                 :: strength
7     REAL(KIND = dp)                 :: TARGET
8     INTEGER                         :: natoms
9     INTEGER, POINTER, DIMENSION(:)  :: atoms
10   END TYPE mulliken_restraint_type
11 CONTAINS
12   SUBROUTINE INIT(mulliken)
13    TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken
14    ALLOCATE(mulliken%atoms(1))
15    mulliken%atoms(1)=1
16    mulliken%natoms=1
17    mulliken%target=0
18    mulliken%strength=0
19   END SUBROUTINE INIT
20   SUBROUTINE restraint_functional(mulliken_restraint_control,charges, &
21                                 charges_deriv,energy,order_p)
22     TYPE(mulliken_restraint_type), &
23       INTENT(IN)                             :: mulliken_restraint_control
24     REAL(KIND=dp), DIMENSION(:, :), POINTER  :: charges, charges_deriv
25     REAL(KIND=dp), INTENT(OUT)               :: energy, order_p
26
27     INTEGER                                  :: I
28     REAL(KIND=dp)                            :: dum
29
30     charges_deriv=0.0_dp
31     order_p=0.0_dp
32
33     DO I=1,mulliken_restraint_control%natoms
34        order_p=order_p+charges(mulliken_restraint_control%atoms(I),1) &
35                       -charges(mulliken_restraint_control%atoms(I),2)
36     ENDDO
37    
38 energy=mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)**2
39    
40 dum=2*mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)
41     DO I=1,mulliken_restraint_control%natoms
42        charges_deriv(mulliken_restraint_control%atoms(I),1)=  dum
43        charges_deriv(mulliken_restraint_control%atoms(I),2)= -dum
44     ENDDO
45 END SUBROUTINE restraint_functional
46
47 END MODULE
48
49     USE TEST
50     IMPLICIT NONE
51     TYPE(mulliken_restraint_type) :: mulliken
52     REAL(KIND=dp), DIMENSION(:, :), POINTER  :: charges, charges_deriv
53     REAL(KIND=dp) :: energy,order_p
54     ALLOCATE(charges(1,2),charges_deriv(1,2))
55     charges(1,1)=2.0_dp
56     charges(1,2)=1.0_dp
57     CALL INIT(mulliken)
58     CALL restraint_functional(mulliken,charges,charges_deriv,energy,order_p)
59     write(6,*) order_p
60 END
61