URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [execute/] [pr32604.f90] - Rev 843
Go to most recent revision | Compare with Previous | Blame | View Log
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
Go to most recent revision | Compare with Previous | Blame | View Log