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 760

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.