c3d.F90

Go to the documentation of this file.

! This file is part of the 'atomes' software.
!
! 'atomes' is free software: you can redistribute it and/or modify it under the terms
! of the GNU Affero General Public License as published by the Free Software Foundation,
! either version 3 of the License, or (at your option) any later version.
!
! 'atomes' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
! without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
! See the GNU General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License along with 'atomes'.
! If not, see <https://www.gnu.org/licenses/>
!
! Copyright (C) 2022-2024 by CNRS and University of Strasbourg
!
 
INTEGER (KIND=c_int) FUNCTION read_c3d (c3d_f, lc3d) bind (C,NAME='read_c3d_')
 
!
! Lecture of atom types and coordinates - C3D files
!
 
USE parameters
 
IMPLICIT NONE
 
LOGICAL :: isok
INTEGER (KIND=c_int), INTENT(IN) :: lc3d
CHARACTER (KIND=c_char), DIMENSION(*), INTENT(IN) :: c3d_f
CHARACTER (LEN=lc3d) :: c3d_file
INTERFACE
INTEGER FUNCTION test_length(UNITFILE, NATL)
  INTEGER, INTENT(IN) :: unitfile, natl
END FUNCTION
END INTERFACE
 
do i=1, lc3d
  c3d_file(i:i) = c3d_f(i)
enddo
 
read_c3d=1
 
inquire (file=c3d_file, exist=isok)
if (isok) then
 
  open (unit=20, file=c3d_file, action='read', status='old', err=001)
  ns=0
  read (20, *, err=002) na
  ns = test_length(20, na+1)
  if (ns .eq. 1) then
    rewind(20)
    if (allocated(fullpos)) deallocate(fullpos)
    allocate (fullpos(na,3,ns), stat=err)
    if (err .ne. 0) then
      call show_error ("Impossible to allocate memory"//char(0), &
                       "Function: read_c3d"//char(0), "Table: FULLPOS"//char(0))
    endif
    if (allocated(tab_of_type)) deallocate(tab_of_type)
    allocate (tab_of_type(na), stat=err)
    if (err .ne. 0) then
      call show_error ("Impossible to allocate memory"//char(0), &
                       "Function: read_c3d"//char(0), "Table: TAB_OF_TYPE"//char(0))
    endif
    do i=1, ns
      read (20, *, err=002)
      do j=1, na
        read (20, *, err=002) tab_of_type(j), k, fullpos(j,1,i), fullpos(j,2,i), fullpos(j,3,i)
      enddo
    enddo
    read_c3d=0
  else
    read_c3d=2
  endif
 
  002 continue
 
  close (20)
 
  001 continue
 
endif
 
END FUNCTION
 
INTEGER (KIND=c_int) FUNCTION write_c3d (c3d_f, lc3d, fc3d, tc3d) bind (C,NAME='write_c3d_')
 
!
! output of atom types and coordinates - Chem3D files
!
 
USE parameters
 
IMPLICIT NONE
 
INTEGER (KIND=c_int), INTENT(IN) :: lc3d, fc3d, tc3d
CHARACTER (KIND=c_char), DIMENSION(*), INTENT(IN) :: c3d_f
DOUBLE PRECISION, DIMENSION(3) :: savep
CHARACTER (LEN=lc3d) :: c3d_file
INTERFACE
INTEGER FUNCTION test_length(UNITFILE, NATL)
  INTEGER, INTENT(IN) :: unitfile, natl
END FUNCTION
END INTERFACE
 
do i=1, lc3d
  c3d_file(i:i) = c3d_f(i)
enddo
 
write_c3d=1
open (unit=20, file=c3d_file, action='write', status='unknown', err=001)
 
do i=1, ns
  write (20, '(i10)') na
  write (20, *)
  do j=1, na
    if (fc3d .eq. 1) then
      if (ncells .gt. 1) then
        nbox => the_box(i)
      else
        nbox => the_box(1)
      endif
      savep = matmul(fullpos(j,:,i),nbox%carttofrac)
    else
      savep = fullpos(j,:,i)
      if (tc3d .eq. 1) then
        savep(:) = savep(:)/angtobohr
      endif
    endif
    write (20, '(a2,3x,i2,3(3x,f15.10))', err=002) tl(lot(j)), 0, savep
  enddo
enddo
write_c3d=0
 
002 continue
 
close (20)
 
001 continue
 
END FUNCTION