Skip to content

Commit

Permalink
subsys: remove POINTER spec from dummy arguments
Browse files Browse the repository at this point in the history
  • Loading branch information
@dev-zero
dev-zero committed Feb 4, 2021
1 parent fd041f4 commit 73ecce9
Show file tree
Hide file tree
Showing 11 changed files with 503 additions and 604 deletions.
129 changes: 58 additions & 71 deletions src/subsys/atomic_kind_types.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -90,28 +90,26 @@ SUBROUTINE deallocate_atomic_kind_set(atomic_kind_set)

INTEGER :: ikind, nkind

IF (ASSOCIATED(atomic_kind_set)) THEN

nkind = SIZE(atomic_kind_set)

DO ikind = 1, nkind
IF (ASSOCIATED(atomic_kind_set(ikind)%fist_potential)) THEN
CALL deallocate_potential(atomic_kind_set(ikind)%fist_potential)
END IF
IF (ASSOCIATED(atomic_kind_set(ikind)%atom_list)) THEN
DEALLOCATE (atomic_kind_set(ikind)%atom_list)
END IF
CALL shell_release(atomic_kind_set(ikind)%shell)

CALL damping_p_release(atomic_kind_set(ikind)%damping)
END DO
DEALLOCATE (atomic_kind_set)
ELSE
IF (.NOT. ASSOCIATED(atomic_kind_set)) THEN
CALL cp_abort(__LOCATION__, &
"The pointer atomic_kind_set is not associated and "// &
"cannot be deallocated")
END IF

nkind = SIZE(atomic_kind_set)

DO ikind = 1, nkind
IF (ASSOCIATED(atomic_kind_set(ikind)%fist_potential)) THEN
CALL deallocate_potential(atomic_kind_set(ikind)%fist_potential)
END IF
IF (ASSOCIATED(atomic_kind_set(ikind)%atom_list)) THEN
DEALLOCATE (atomic_kind_set(ikind)%atom_list)
END IF
CALL shell_release(atomic_kind_set(ikind)%shell)

CALL damping_p_release(atomic_kind_set(ikind)%damping)
END DO
DEALLOCATE (atomic_kind_set)
END SUBROUTINE deallocate_atomic_kind_set

! **************************************************************************************************
Expand Down Expand Up @@ -140,7 +138,7 @@ SUBROUTINE get_atomic_kind(atomic_kind, fist_potential, &
rcov, rvdw, z, qeff, apol, cpol, mm_radius, &
shell, shell_active, damping)

TYPE(atomic_kind_type) :: atomic_kind
TYPE(atomic_kind_type), INTENT(IN) :: atomic_kind
TYPE(fist_potential_type), OPTIONAL, POINTER :: fist_potential
CHARACTER(LEN=2), INTENT(OUT), OPTIONAL :: element_symbol
CHARACTER(LEN=default_string_length), &
Expand Down Expand Up @@ -231,35 +229,32 @@ SUBROUTINE get_atomic_kind_set(atomic_kind_set, &
shell_check_distance, &
damping_present)

TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
TYPE(atomic_kind_type), DIMENSION(:), INTENT(IN) :: atomic_kind_set
INTEGER, DIMENSION(:), INTENT(OUT), OPTIONAL :: atom_of_kind, kind_of, natom_of_kind
INTEGER, INTENT(OUT), OPTIONAL :: maxatom, natom, nshell
LOGICAL, INTENT(OUT), OPTIONAL :: fist_potential_present, shell_present, &
shell_adiabatic, shell_check_distance, &
damping_present

INTEGER :: atom_a, iatom, ikind, nkind
TYPE(atomic_kind_type), POINTER :: atomic_kind
TYPE(damping_p_type), POINTER :: damping
TYPE(fist_potential_type), POINTER :: fist_potential
TYPE(shell_kind_type), POINTER :: shell

IF (ASSOCIATED(atomic_kind_set)) THEN

IF (PRESENT(maxatom)) maxatom = 0
IF (PRESENT(natom)) natom = 0
IF (PRESENT(nshell)) nshell = 0
IF (PRESENT(shell_present)) shell_present = .FALSE.
IF (PRESENT(shell_adiabatic)) shell_adiabatic = .FALSE.
IF (PRESENT(shell_check_distance)) shell_check_distance = .FALSE.
IF (PRESENT(damping_present)) damping_present = .FALSE.
IF (PRESENT(atom_of_kind)) atom_of_kind(:) = 0
IF (PRESENT(kind_of)) kind_of(:) = 0
IF (PRESENT(natom_of_kind)) natom_of_kind(:) = 0

nkind = SIZE(atomic_kind_set)
DO ikind = 1, nkind
atomic_kind => atomic_kind_set(ikind)
IF (PRESENT(maxatom)) maxatom = 0
IF (PRESENT(natom)) natom = 0
IF (PRESENT(nshell)) nshell = 0
IF (PRESENT(shell_present)) shell_present = .FALSE.
IF (PRESENT(shell_adiabatic)) shell_adiabatic = .FALSE.
IF (PRESENT(shell_check_distance)) shell_check_distance = .FALSE.
IF (PRESENT(damping_present)) damping_present = .FALSE.
IF (PRESENT(atom_of_kind)) atom_of_kind(:) = 0
IF (PRESENT(kind_of)) kind_of(:) = 0
IF (PRESENT(natom_of_kind)) natom_of_kind(:) = 0

nkind = SIZE(atomic_kind_set)
DO ikind = 1, nkind
ASSOCIATE (atomic_kind=>atomic_kind_set(ikind))
CALL get_atomic_kind(atomic_kind=atomic_kind, &
fist_potential=fist_potential, &
shell=shell, &
Expand Down Expand Up @@ -306,10 +301,8 @@ SUBROUTINE get_atomic_kind_set(atomic_kind_set, &
IF (PRESENT(natom_of_kind)) THEN
natom_of_kind(ikind) = atomic_kind_set(ikind)%natom
END IF
END DO
ELSE
CPABORT("The pointer atomic_kind_set is not associated")
END IF
END ASSOCIATE
END DO

END SUBROUTINE get_atomic_kind_set

Expand All @@ -332,7 +325,7 @@ SUBROUTINE set_atomic_kind(atomic_kind, element_symbol, name, mass, kind_number,
fist_potential, shell, &
shell_active, damping)

TYPE(atomic_kind_type), POINTER :: atomic_kind
TYPE(atomic_kind_type), INTENT(INOUT) :: atomic_kind
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: element_symbol, name
REAL(KIND=dp), INTENT(IN), OPTIONAL :: mass
INTEGER, INTENT(IN), OPTIONAL :: kind_number, natom
Expand All @@ -344,38 +337,32 @@ SUBROUTINE set_atomic_kind(atomic_kind, element_symbol, name, mass, kind_number,

INTEGER :: n

IF (ASSOCIATED(atomic_kind)) THEN

IF (PRESENT(element_symbol)) atomic_kind%element_symbol = element_symbol
IF (PRESENT(name)) atomic_kind%name = name
IF (PRESENT(mass)) atomic_kind%mass = mass
IF (PRESENT(kind_number)) atomic_kind%kind_number = kind_number
IF (PRESENT(natom)) atomic_kind%natom = natom
IF (PRESENT(atom_list)) THEN
n = SIZE(atom_list)
IF (n > 0) THEN
IF (ASSOCIATED(atomic_kind%atom_list)) THEN
DEALLOCATE (atomic_kind%atom_list)
END IF
ALLOCATE (atomic_kind%atom_list(n))
atomic_kind%atom_list(:) = atom_list(:)
atomic_kind%natom = n
ELSE
CPABORT("An invalid atom_list was supplied")
IF (PRESENT(element_symbol)) atomic_kind%element_symbol = element_symbol
IF (PRESENT(name)) atomic_kind%name = name
IF (PRESENT(mass)) atomic_kind%mass = mass
IF (PRESENT(kind_number)) atomic_kind%kind_number = kind_number
IF (PRESENT(natom)) atomic_kind%natom = natom
IF (PRESENT(atom_list)) THEN
n = SIZE(atom_list)
IF (n > 0) THEN
IF (ASSOCIATED(atomic_kind%atom_list)) THEN
DEALLOCATE (atomic_kind%atom_list)
END IF
ALLOCATE (atomic_kind%atom_list(n))
atomic_kind%atom_list(:) = atom_list(:)
atomic_kind%natom = n
ELSE
CPABORT("An invalid atom_list was supplied")
END IF
IF (PRESENT(fist_potential)) atomic_kind%fist_potential => fist_potential
IF (PRESENT(shell)) THEN
atomic_kind%shell => shell
CALL shell_retain(shell)
END IF
IF (PRESENT(shell_active)) atomic_kind%shell_active = shell_active

IF (PRESENT(damping)) atomic_kind%damping => damping

ELSE
CPABORT("The pointer atomic_kind is not associated")
END IF
IF (PRESENT(fist_potential)) atomic_kind%fist_potential => fist_potential
IF (PRESENT(shell)) THEN
atomic_kind%shell => shell
CALL shell_retain(shell)
END IF
IF (PRESENT(shell_active)) atomic_kind%shell_active = shell_active

IF (PRESENT(damping)) atomic_kind%damping => damping

END SUBROUTINE set_atomic_kind

Expand All @@ -386,7 +373,7 @@ END SUBROUTINE set_atomic_kind
!> \author Teodoro Laino [tlaino] - University of Zurich 10.2008
! **************************************************************************************************
PURE FUNCTION is_hydrogen(atomic_kind) RESULT(res)
TYPE(atomic_kind_type), POINTER :: atomic_kind
TYPE(atomic_kind_type), INTENT(IN) :: atomic_kind
LOGICAL :: res

res = TRIM(atomic_kind%element_symbol) == "H"
Expand Down
36 changes: 16 additions & 20 deletions src/subsys/cell_types.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,10 +97,8 @@ MODULE cell_types
! **************************************************************************************************
SUBROUTINE cell_clone(cell_in, cell_out)

TYPE(cell_type), POINTER :: cell_in, cell_out

CPASSERT(ASSOCIATED(cell_in))
CPASSERT(ASSOCIATED(cell_out))
TYPE(cell_type), INTENT(IN) :: cell_in
TYPE(cell_type), INTENT(OUT) :: cell_out

cell_out%deth = cell_in%deth
cell_out%perd = cell_in%perd
Expand All @@ -121,10 +119,8 @@ END SUBROUTINE cell_clone
! **************************************************************************************************
SUBROUTINE cell_copy(cell_in, cell_out)

TYPE(cell_type), POINTER :: cell_in, cell_out

CPASSERT(ASSOCIATED(cell_in))
CPASSERT(ASSOCIATED(cell_out))
TYPE(cell_type), INTENT(IN) :: cell_in
TYPE(cell_type), INTENT(INOUT) :: cell_out

cell_out%deth = cell_in%deth
cell_out%perd = cell_in%perd
Expand Down Expand Up @@ -186,14 +182,14 @@ END SUBROUTINE parse_cell_line
SUBROUTINE get_cell(cell, alpha, beta, gamma, deth, orthorhombic, abc, periodic, &
h, h_inv, id_nr, symmetry_id)

TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
REAL(KIND=dp), INTENT(OUT), OPTIONAL :: alpha, beta, gamma, deth
LOGICAL, INTENT(OUT), OPTIONAL :: orthorhombic
REAL(KIND=dp), DIMENSION(3), INTENT(OUT), OPTIONAL :: abc
INTEGER, DIMENSION(3), INTENT(OUT), OPTIONAL :: periodic
REAL(KIND=dp), DIMENSION(3, 3), INTENT(OUT), &
OPTIONAL :: h, h_inv
INTEGER, INTENT(out), OPTIONAL :: id_nr, symmetry_id
INTEGER, INTENT(OUT), OPTIONAL :: id_nr, symmetry_id

IF (PRESENT(deth)) deth = cell%deth ! the volume
IF (PRESENT(orthorhombic)) orthorhombic = cell%orthorhombic
Expand Down Expand Up @@ -239,7 +235,7 @@ END SUBROUTINE get_cell
! **************************************************************************************************
SUBROUTINE get_cell_param(cell, cell_length, cell_angle, units_angle, periodic)

TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: cell_length
REAL(KIND=dp), DIMENSION(3), INTENT(OUT), OPTIONAL :: cell_angle
INTEGER, INTENT(IN), OPTIONAL :: units_angle
Expand Down Expand Up @@ -276,7 +272,7 @@ END SUBROUTINE get_cell_param
! **************************************************************************************************
SUBROUTINE set_cell_param(cell, cell_length, cell_angle, periodic, do_init_cell)

TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(INOUT) :: cell
REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: cell_length, cell_angle
INTEGER, DIMENSION(3), INTENT(IN), OPTIONAL :: periodic
LOGICAL, INTENT(IN) :: do_init_cell
Expand Down Expand Up @@ -325,7 +321,7 @@ END SUBROUTINE set_cell_param
! **************************************************************************************************
SUBROUTINE init_cell(cell, hmat, periodic)

TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(INOUT) :: cell
REAL(KIND=dp), DIMENSION(3, 3), INTENT(IN), &
OPTIONAL :: hmat
INTEGER, DIMENSION(3), INTENT(IN), OPTIONAL :: periodic
Expand Down Expand Up @@ -476,7 +472,7 @@ END SUBROUTINE init_cell
FUNCTION plane_distance(h, k, l, cell) RESULT(distance)

INTEGER, INTENT(IN) :: h, k, l
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
REAL(KIND=dp) :: distance

REAL(KIND=dp) :: a, alpha, b, beta, c, cosa, cosb, cosg, &
Expand Down Expand Up @@ -540,7 +536,7 @@ END FUNCTION plane_distance
FUNCTION pbc1(r, cell) RESULT(r_pbc)

REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
REAL(KIND=dp), DIMENSION(3) :: r_pbc

REAL(KIND=dp), DIMENSION(3) :: s
Expand Down Expand Up @@ -577,7 +573,7 @@ END FUNCTION pbc1
FUNCTION pbc2(r, cell, nl) RESULT(r_pbc)

REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
INTEGER, DIMENSION(3), INTENT(IN) :: nl
REAL(KIND=dp), DIMENSION(3) :: r_pbc

Expand Down Expand Up @@ -618,7 +614,7 @@ END FUNCTION pbc2
FUNCTION pbc3(ra, rb, cell) RESULT(rab_pbc)

REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: ra, rb
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
REAL(KIND=dp), DIMENSION(3) :: rab_pbc

INTEGER :: icell, jcell, kcell
Expand Down Expand Up @@ -663,7 +659,7 @@ END FUNCTION pbc3
FUNCTION pbc4(r, cell, positive_range) RESULT(r_pbc)

REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell
LOGICAL :: positive_range
REAL(KIND=dp), DIMENSION(3) :: r_pbc

Expand Down Expand Up @@ -705,7 +701,7 @@ SUBROUTINE real_to_scaled(s, r, cell)

REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: s
REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell

IF (cell%orthorhombic) THEN
s(1) = cell%h_inv(1, 1)*r(1)
Expand Down Expand Up @@ -733,7 +729,7 @@ SUBROUTINE scaled_to_real(r, s, cell)

REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: r
REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: s
TYPE(cell_type), POINTER :: cell
TYPE(cell_type), INTENT(IN) :: cell

IF (cell%orthorhombic) THEN
r(1) = cell%hmat(1, 1)*s(1)
Expand Down

0 comments on commit 73ecce9

Please sign in to comment.