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