1! 2! Copyright (C) 1996-2016 The SIESTA group 3! This file is distributed under the terms of the 4! GNU General Public License: see COPYING in the top directory 5! or http://www.gnu.org/copyleft/gpl.txt. 6! See Docs/Contributors.txt for a list of contributors. 7! 8 subroutine coceri(iza, xa, cell, na, sname ) 9c ******************************************************************* 10c Writes coordinates in format to be read by CERIUS 11c 12c It implies atomic symbols, atomic coordinates (fractional format) 13c and lattice parameters (modules (in Ang) and angles) 14c 15c Written by E. Artacho. December 1997. 16c ********* INPUT *************************************************** 17c integer iza(na) : Atomic numbers of different atoms 18c double xa(3,na) : Atom coordinates (in Bohr) 19c double cell(3,3) : Lattice vectors (in Bohr) 20c integer na : Number of atoms 21c character slabel*20 : Label for file naming 22c character sname*150 : Label for the title 23c ****************************************************************** 24 25 use precision, only: dp 26 use periodic_table, only: symbol 27 use files, only: slabel, label_length 28 use units, only: Pi, Ang 29 30 implicit none 31 32 character(len=150) :: sname 33 integer :: na 34 integer :: iza(na) 35 real(dp) :: cell(3,3) 36 real(dp) :: xa(3,na) 37 external io_assign, io_close 38 39c Internal variables and arrays 40 41 character(len=label_length+4) :: fname 42 character(len=2) :: sym 43 integer :: unit, ix, iv, i, ia 44 real(dp) :: celang(3) 45 real(dp) :: cellm(3) 46 real(dp) :: recell(3,3) 47 real(dp) :: xac(3) 48 49! automatic array 50 51 real(dp) :: xap(3,na) 52 53c Find lattice parameters out of lattice vectors: first modules: 54 55 do iv = 1, 3 56 cellm(iv) = 0.0d0 57 do ix = 1, 3 58 cellm(iv) = cellm(iv) + cell(ix,iv)*cell(ix,iv) 59 enddo 60 cellm(iv) = sqrt(cellm(iv)) 61 enddo 62 63c and angles 64 65 celang(1) = 0.d0 66 do ix = 1, 3 67 celang(1) = celang(1) + cell(ix,2)*cell(ix,3) 68 enddo 69 celang(1) = acos(celang(1)/(cellm(2)*cellm(3)))*180.d0/pi 70 celang(2) = 0.d0 71 do ix = 1, 3 72 celang(2) = celang(2) + cell(ix,1)*cell(ix,3) 73 enddo 74 celang(2) = acos(celang(2)/(cellm(1)*cellm(3)))*180.d0/pi 75 celang(3) = 0.d0 76 do ix = 1, 3 77 celang(3) = celang(3) + cell(ix,1)*cell(ix,2) 78 enddo 79 celang(3) = acos(celang(3)/(cellm(1)*cellm(2)))*180.d0/pi 80 81c Obtain fractional coordinates (reclat inverts matrix) 82 83 call reclat(cell, recell, 0) 84 do ia = 1,na 85 do ix = 1,3 86 xac(ix) = xa(ix,ia) 87 enddo 88 do ix = 1,3 89 xap(ix,ia) = recell(1,ix) * xac(1) + 90 . recell(2,ix) * xac(2) + 91 . recell(3,ix) * xac(3) 92 enddo 93 enddo 94 95 96c Find file name 97 98 fname = trim(slabel) // '.xtl' 99 100 write(6,'(/,2a)')'coceri: Writing CERIUS coordinates into file ', 101 . fname 102 103 call io_assign(unit) 104 open( unit, file=fname, form = 'formatted', status='unknown') 105 rewind(unit) 106 107c Write file 108 109 write(unit,'(a,a70)') 'TITLE ', sname 110 write(unit,'(a)') 'DIMENSION 3' 111 write(unit,'(a,6f11.5)') 112 . 'CELL', (cellm(iv)/Ang,iv=1,3), (celang(i),i=1,3) 113 write(unit,'(a)') 'SYMMETRY NUMBER 1 LABEL P1' 114 write(unit,'(3a)') 115 . 'SYM MAT 1.000000 0.000000 0.000000 0.000000', 116 . ' 1.000000 0.000000 0.000000 0.000000', 117 . ' 1.000000 0.0000 0.0000 0.0000' 118 write(unit,'(/,a)') 'ATOMS' 119 write(unit,'(2a)') 'NAME X Y Z ', 120 . 'CHARGE TEMP OCCUP SCAT' 121 do ia = 1, na 122 sym = symbol(iza(ia)) 123 write(unit,'(2x,a2,3f11.5,3f8.4,3x,a2)') 124 . sym, (xap(i,ia),i=1,3), 0.d0, 0.d0, 1.d0, sym 125 enddo 126 write(unit,'(a)') 'EOF' 127 128 call io_close(unit) 129 130 end 131 132