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