OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [execute/] [pr32604.f90] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 695 jeremybenn
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
 

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.