diff --git a/src/empirical_parameters.F b/src/empirical_parameters.F index a70b5b66c1..5f8aafd9d6 100644 --- a/src/empirical_parameters.F +++ b/src/empirical_parameters.F @@ -101,7 +101,7 @@ CONTAINS CALL cfield(string,ilen) natom_types = SIZE ( atom_names ) iat = str_search(atom_names,natom_types,string) - nkind = nkind + 1 + nkind = nkind + 1 DO CALL read_line @@ -124,7 +124,7 @@ CONTAINS ALLOCATE (read_ep(iat)%hardness_param(nset), stat = ios) IF (ios /= 0 ) CALL stop_memory & ( 'read_emporical_parameters', 'read_ep%l', nset ) - element_symbol (iat) = string + element_symbol (iat) = string END IF CASE ( 'EMPAR') @@ -132,7 +132,7 @@ CONTAINS read_ep(iat) % l (i) = get_int() read_ep(iat) % hk_param (i) = get_real() read_ep(iat) % hardness_param (i) = get_real() - + CASE ( 'END') ilen = 0 CALL cfield(string2,ilen) @@ -140,7 +140,7 @@ CONTAINS END SELECT END DO - + CALL read_line END DO @@ -190,28 +190,28 @@ CONTAINS IF (globenv%print_level>=0) THEN DO i = 1, nkind - + WRITE ( iw, '( A,T61,A )' ) ' EMPIRICAL_PARAMETERS| atom type ', & ADJUSTR ( empparm(i) % aname ) WRITE ( iw, '( A,T71,I10 )' ) ' EMPIRICAL_PARAMETERS| Number of sets ', & empparm(i) % nset - + DO iset = 1, empparm (i) % nset - + WRITE ( iw, '( A,T71,I10 )' ) ' EMPIRICAL| angular momentum number ', & - empparm(i) % l (iset) + empparm(i) % l (iset) WRITE ( iw, '( A,T71,F12.6 )' ) ' EMPIRICAL| Hohemberg-Kohn parameter ', & - empparm(i) % hk_param (iset) - + empparm(i) % hk_param (iset) + WRITE ( iw, '( A,T71,F12.6 )' ) ' EMPIRICAL| Hardness parameter ', & - empparm(i) % hardness_param (iset) + empparm(i) % hardness_param (iset) END DO WRITE ( iw,'( )' ) END DO - + END IF END IF @@ -233,7 +233,7 @@ CONTAINS IF (ios /= 0 ) CALL stop_memory & ( 'read_molecule_section', ' deallocate read_ep%l' ) - END DO + END DO IF (ASSOCIATED(read_ep)) DEALLOCATE (read_ep, stat = ios) IF (ios /= 0 ) CALL stop_memory & @@ -241,10 +241,8 @@ CONTAINS END SUBROUTINE read_empirical_parameters -!!***** !****************************************************************************** END MODULE empirical_parameters -!!***** !****************************************************************************** diff --git a/src/force_control.F b/src/force_control.F index c71a4ca3ad..833c85afcb 100644 --- a/src/force_control.F +++ b/src/force_control.F @@ -98,8 +98,8 @@ SUBROUTINE force_1 ( struc, inter, thermo, simpar, ewald_param, box_change, & CASE ( 'POL' ) CALL pol_force_control ( struc % molecule, struc % pnode, struc % part, & struc % box, struc % box_ref, struc % drho_basis_info, & - struc % rho0_basis_info, struc % coef_pos (1), struc % coef_vel (1), & - struc % coef_force (1), thermo, inter%potparm, inter%empparm, & + struc % rho0_basis_info, struc % coef_pos (1), struc % coef_vel (1), & + struc % coef_force (1), thermo, inter%potparm, inter%empparm, & ewald_param, simpar % ensemble, globenv, struc%ll_data ) CASE ( 'TBMD' ) diff --git a/src/linklist_overlap_list.F b/src/linklist_overlap_list.F index cb4b6d04aa..8ea4e81b0a 100644 --- a/src/linklist_overlap_list.F +++ b/src/linklist_overlap_list.F @@ -213,11 +213,11 @@ SUBROUTINE overlap_list(n_images,n_cell,pnode,part,box, & DO jkind = 1, nkind ll => part(ii) % cell_ol % pTYPE ( jkind ) % ll - + DO jpart = 1, part(ii) % cell_ol % natoms(jkind ) - + j = ll%atom - + ! use black/white scheme to avoid double counting IF (include_list(ii,j)) THEN @@ -228,9 +228,9 @@ SUBROUTINE overlap_list(n_images,n_cell,pnode,part,box, & ! look for a match in the exclusion list (j in excl of pnode(i)) SELECT CASE (nexcl) - + CASE DEFAULT - + IF ( .NOT. get_match(j,elist,nexcl)) THEN CALL update_verlet_list(n_images ( ikind, jkind, : ), & part(j), j, & @@ -239,7 +239,7 @@ SUBROUTINE overlap_list(n_images,n_cell,pnode,part,box, & END IF CASE (0) - + CALL update_verlet_list(n_images(ikind,jkind,:),part(j),j, & pnode(i),hmat,h_inv,perd,rlist_cutsq(ikind,jkind ), & current_neighbor,list_type) @@ -273,10 +273,10 @@ SUBROUTINE overlap_list(n_images,n_cell,pnode,part,box, & ll => cell_ll(index(1),index(2),index(3)) % pTYPE ( jkind ) %ll DO jpart = 1, cell_ll(index(1),index(2),index(3)) %natoms(jkind) - + ipair=ipair+1 j = ll%atom - + SELECT CASE (nexcl) CASE DEFAULT @@ -305,11 +305,11 @@ SUBROUTINE overlap_list(n_images,n_cell,pnode,part,box, & ll => ll%next END DO - + END DO - + END DO - + IF ( first_time .AND. globenv % print_level>4 & .OR. globenv % print_level>9) THEN IF (globenv % ionode) WRITE (globenv % scr,'(A,i10,T54,A,T71,I10 )' ) & diff --git a/src/linklist_utilities.F b/src/linklist_utilities.F index 19e67c7500..a7df704c77 100644 --- a/src/linklist_utilities.F +++ b/src/linklist_utilities.F @@ -114,7 +114,7 @@ MODULE linklist_utilities pnode%nneighbor = pnode%nneighbor + 1 CASE (2) pnode%nsneighbor = pnode%nsneighbor + 1 - END SELECT + END SELECT current_neighbor%p => part current_neighbor%index = j diff --git a/src/pol_coefs.F b/src/pol_coefs.F index c1d9a67346..da8eb5050a 100644 --- a/src/pol_coefs.F +++ b/src/pol_coefs.F @@ -123,7 +123,7 @@ MODULE pol_coefs END DO CLOSE (666) - END SELECT + END SELECT ! fills the remaining information... @@ -165,32 +165,33 @@ MODULE pol_coefs DO ii = 1, natoms ipart = ki(ikind)%atom_list(ii) - ncgf = ki(ikind) % orb_basis_set % ncgf + ncgf = ki(ikind) % orb_basis_set % ncgf - DO icgf = 1, ncgf - icoef = part ( ipart ) % coef_list( icgf ) - ao % coef_to_basis_set ( icoef ) = ikind - ao % coef_to_part ( icoef ) = ipart + DO icgf = 1, ncgf + icoef = part ( ipart ) % coef_list( icgf ) + ao % coef_to_basis_set ( icoef ) = ikind + ao % coef_to_part ( icoef ) = ipart - IF (flag) THEN - ao % kind_info (icoef) % orb_basis_set => ki (ikind) % orb_basis_set - ao % kind_info (icoef) % orb_basis_set_name = ki (ikind) % orb_basis_set_name - ao % kind_info (icoef) % number_of_grid_points = ki (ikind) % number_of_grid_points - ao % kind_info (icoef) % element_symbol = ki (ikind) % element_symbol - ao % kind_info (icoef) % natom = ki (ikind) % natom - ao % kind_info (icoef) % z = ki (ikind) % z - IF (.NOT.ASSOCIATED(ao % kind_info (icoef) % atom_list)) THEN - ALLOCATE (ao % kind_info (icoef) % atom_list (natoms) , STAT = ios) - END IF - DO iat = 1, natoms - ao % kind_info (icoef) % atom_list (iat) = ki (ikind) % atom_list (iat) - END DO - END IF + IF (flag) THEN + ao % kind_info (icoef) % orb_basis_set => ki (ikind) % orb_basis_set + ao % kind_info (icoef) % orb_basis_set_name = ki (ikind) % orb_basis_set_name + ao % kind_info (icoef) % number_of_grid_points = & + ki (ikind) % number_of_grid_points + ao % kind_info (icoef) % element_symbol = ki (ikind) % element_symbol + ao % kind_info (icoef) % natom = ki (ikind) % natom + ao % kind_info (icoef) % z = ki (ikind) % z + IF (.NOT.ASSOCIATED(ao % kind_info (icoef) % atom_list)) THEN + ALLOCATE (ao % kind_info (icoef) % atom_list (natoms) , STAT = ios) + END IF + DO iat = 1, natoms + ao % kind_info (icoef) % atom_list (iat) = ki (ikind) % atom_list (iat) + END DO + END IF ENDDO - - END DO - - END DO + + END DO + + END DO END SUBROUTINE get_kind_and_part_index diff --git a/src/pol_setup.F b/src/pol_setup.F index 536b1bd2d2..5a1f4821c5 100644 --- a/src/pol_setup.F +++ b/src/pol_setup.F @@ -61,8 +61,8 @@ MODULE pol_setup ! locals INTEGER :: i,nrho0,ndrho,ikind,ncgf,isos,imol, icount - TYPE ( read_basis_type ), POINTER, DIMENSION (:) :: pol_basis - TYPE ( read_basis_type ), POINTER, DIMENSION (:) :: rho0_basis + TYPE ( read_basis_type ), POINTER, DIMENSION (:) :: pol_basis + TYPE ( read_basis_type ), POINTER, DIMENSION (:) :: rho0_basis LOGICAL :: flag ! count the total number of basis functions for @@ -150,7 +150,7 @@ MODULE pol_setup END IF DEALLOCATE (ki(ikind)%atom_list,STAT=istat) IF (istat /= 0) CALL stop_memory("allocate_pol_basis_info", & - "ki(ikind)%atom_list") + "ki(ikind)%atom_list") DEALLOCATE (ki(ikind)%elec_conf,STAT=istat) IF (istat /= 0) CALL stop_memory("allocate_pol_basis_info","ki(ikind)%elec_conf") END DO @@ -212,9 +212,9 @@ MODULE pol_setup CALL read_basis_set(ki(ikind)%element_symbol,ki(ikind)%orb_basis_set_name, & ki(ikind)%orb_basis_set, globenv) - CALL init_cphi(ki(ikind)% orb_basis_set) - - CALL get_radii(ki(ikind), moliNFo(ikind)%eps) + CALL init_cphi(ki(ikind)% orb_basis_set) + + CALL get_radii(ki(ikind), moliNFo(ikind)%eps) ENDDO @@ -248,7 +248,7 @@ MODULE pol_setup ENDDO END SUBROUTINE get_atom_list !------------------------------------------------------------------------------! - SUBROUTINE get_radii(ki,eps) + SUBROUTINE get_radii(ki,eps) IMPLICIT NONE @@ -280,10 +280,10 @@ MODULE pol_setup END DO ki%orb_basis_set%kind_radius = kind_radius - END SUBROUTINE get_radii + END SUBROUTINE get_radii !------------------------------------------------------------------------------ - SUBROUTINE get_number_of_coefs(ki, part, ncoefs) + SUBROUTINE get_number_of_coefs(ki, part, ncoefs) IMPLICIT NONE @@ -302,14 +302,14 @@ MODULE pol_setup DO ii = 1, ki(ikind)%natom i = ki(ikind)%atom_list(ii) - + NULLIFY (part(i) % coef_list) ncgf = ki(ikind)% orb_basis_set % ncgf ncoefs = ncoefs + ki(ikind)% orb_basis_set % ncgf - ALLOCATE(part (i) %coef_list(ncgf), STAT=isos) + ALLOCATE(part (i) %coef_list(ncgf), STAT=isos) IF (isos/=0) CALL stop_memory('get_number_of_coef', 'coeflist') - + DO icgf = 1, ncgf icount = icount + 1 part (i) % coef_list(icgf)=icount @@ -321,7 +321,7 @@ MODULE pol_setup END SUBROUTINE get_number_of_coefs !------------------------------------------------------------------------------ - SUBROUTINE get_rcutsq_cgf(ki,rsq) + SUBROUTINE get_rcutsq_cgf(ki,rsq) IMPLICIT NONE @@ -339,7 +339,7 @@ MODULE pol_setup DO j = 1, size (ki) rcut = ki(i)%orb_basis_set%kind_radius + & - ki(j)%orb_basis_set%kind_radius + ki(j)%orb_basis_set%kind_radius rsq (i,j) = rcut * rcut END DO