TABLE OF CONTENTS


ABINIT/band2eps [ Programs ]

[ Top ] [ Programs ]

NAME

 band2eps

FUNCTION

 Draws the phonon dispersion curve in Encapsuled PostScript (EPS)
 in black and white or in color according to the displacement participation
 of each atom.

COPYRIGHT

 Copyright (C) 1999-2018 ABINIT group (FDortu,MVeithen)
 This file is distributed under the terms of the
 GNU General Public License, see ~abinit/COPYING
 or http://www.gnu.org/copyleft/gpl.txt .
 For the initials of contributors, see ~abinit/doc/developers/contributors.txt .

INPUTS

  (main routine)

OUTPUT

  (main routine)

PARENTS

CHILDREN

      abi_io_redirect,abimem_init,band2eps_dtset_free,instrng,inupper
      invars11,outvars_band2eps,xmpi_end,xmpi_init

SOURCE

 32 #if defined HAVE_CONFIG_H
 33 #include "config.h"
 34 #endif
 35 
 36 #include "abi_common.h"
 37 
 38 
 39 program band2eps
 40 
 41  use defs_basis
 42  use defs_abitypes
 43  use m_abimover
 44  use m_build_info
 45  use m_xmpi
 46  use m_abicore
 47  use m_errors
 48  use m_effective_potential
 49  use m_multibinit_dataset
 50  use m_effective_potential_file
 51  use m_band2eps_dataset
 52 
 53  use m_io_tools,      only : open_file
 54  use m_fstrings,      only : int2char4, tolower, inupper
 55  use m_time,          only : asctime
 56  use m_parser,        only : instrng
 57 
 58 !This section has been created automatically by the script Abilint (TD).
 59 !Do not modify the following lines by hand.
 60 #undef ABI_FUNC
 61 #define ABI_FUNC 'band2eps'
 62 !End of the abilint section
 63 
 64  implicit none
 65 
 66 !Arguments -----------------------------------
 67 
 68 !Local variables-------------------------------
 69 !no_abirules
 70  integer,parameter :: master=0
 71  character(len=fnlen) :: filnam(4)
 72  real(dp) :: E,deltaE
 73  integer :: comm,EmaxN,EminN,kmaxN,kminN,lastPos,lenstr,pos,posk
 74  integer :: iatom,ii,imode,io,iqpt,jj,nqpt
 75  integer :: nproc,my_rank
 76  integer :: option,unt1,unt2,unt3
 77  logical :: iam_master
 78 !array
 79  real(dp),allocatable :: phfrq(:),phfrqqm1(:)
 80  real(dp),allocatable :: color(:,:)
 81  real(dp) :: facUnit,norm,renorm
 82  real(dp),allocatable :: colorAtom(:,:)
 83  real(dp),allocatable :: displ(:,:)
 84  type(band2eps_dataset_type) :: inp
 85  character(len=500) :: message
 86  character(len=strlen) :: string
 87   !scale : hold the scale for each line (dimension=nlines)
 88   !qname : hold the name (gamma,R,etc..) for each extremity of line (dimension=nlines+1)
 89   !nqptl : =nqpt by line (dimension=nlines)
 90   !nlines : number of lines
 91   !Emin is the minimum energy of the vertical axe
 92   !Emax is the maximum energy of the vertical axe
 93   !EminN is the minimum value of the vertical axe(in point)
 94   !EmaxN is the maximum value of the vertical axe(in point)
 95   !kminN is the minimum value of the horizontal axe(in point)
 96   !kmaxN is the maximum value of the horizontal axe(in point)
 97   !E,deltaE,pos are a work variables
 98   !gradRes is the number of intervals for the graduation along vertical axe
 99 
100 ! *********************************************************************
101 
102 !Change communicator for I/O (mandatory!)
103  call abi_io_redirect(new_io_comm=xmpi_world)
104 
105 !Initialize MPI
106  call xmpi_init()
107  comm = xmpi_world
108 
109 !MPI variables
110  nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
111  iam_master = (my_rank == master)
112 
113 !Initialize memory profiling if it is activated
114 !if a full abimem.mocc report is desired, set the argument of abimem_init to "2" instead of "0"
115 !note that abimem.mocc files can easily be multiple GB in size so don't use this option normally
116 #ifdef HAVE_MEM_PROFILING
117  call abimem_init(0)
118 #endif
119 
120 !read the .file file
121 !File names refer to following files, in order:
122 !(1) Formatted input file
123 !(2) EPS graphic
124 !(3) Input phonon energies (from sortph.f)
125 !(4) Input displacements (from sortph.f)
126  write(std_out,*)' Give name for formatted input file : '
127  read(std_in, '(a)',IOSTAT=io) filnam(1)
128  write(std_out,'(a,a)' )'-   ',trim(filnam(1))
129 
130  write(std_out,*)' Give name for formatted output eps file : '
131  read(std_in, '(a)',IOSTAT=io) filnam(2)
132  write(std_out,'(a,a)' )'-   ',trim(filnam(2))
133 
134  write(std_out,*)' Give name for formatted phonon frequency file : '
135  read(std_in, '(a)',IOSTAT=io) filnam(3)
136  write(std_out,'(a,a)' )'-   ',trim(filnam(3))
137 
138  write(std_out,*)' Give name for formatted displacements file : '
139  read(std_in, '(a)',IOSTAT=io) filnam(4)
140  write(std_out,'(a,a)' )'-   ',trim(filnam(4))
141 
142 !Read the input file, and store the information in a long string of characters
143 !strlen from defs_basis module
144  write(std_out,'(a,a)') 'Opening and reading input file: ', filnam(1)
145  option=1
146  call instrng (filnam(1),lenstr,option,strlen,string)
147  !To make case-insensitive, map characters to upper case:
148  call inupper(string(1:lenstr))
149 
150 !Read the input file
151  call invars11(inp,lenstr,string)
152  if(inp%prtout == 1) call outvars_band2eps(inp,std_out)
153 
154 !Open the '.eps' file for write
155  write(std_out,'(a,a)') 'Creation of file ', filnam(2)
156  if (open_file(filnam(2),message,newunit=unt1,form="formatted",status="unknown",action="write") /= 0) then
157    MSG_ERROR(message)
158  end if
159 !Open the phonon energies file
160  if (open_file(filnam(3),message,newunit=unt2,form="formatted") /= 0) then
161    MSG_ERROR(message)
162  end if
163  if(filnam(4)/='no') then
164 !  Open the displacements file
165    if (open_file(filnam(4),message,newunit=unt3,form="formatted",status="old",action='read') /= 0) then
166      MSG_ERROR(message)
167    end if
168  end if
169 
170 
171 !Boundings of the plot (only the plot and not what is around)
172  EminN=6900
173  EmaxN=2400
174  kminN=2400
175  kmaxN=9600
176 
177 !Allocate dynamique variables
178  ABI_ALLOCATE(phfrqqm1,(3*inp%natom))
179  ABI_ALLOCATE(phfrq,(3*inp%natom))
180  ABI_ALLOCATE(color,(3,3*inp%natom))
181  ABI_ALLOCATE(colorAtom,(3,inp%natom))
182 !colorAtom(1,1:5) : atoms contributing to red (ex : [1 0 0 0 0])
183 !colorAtom(2,1:5) : atoms contributing to green (ex : [0 1 0 0 0])
184 !colorAtom(3,1:5) : atoms contributing to blue (ex : [0 0 1 1 1])
185 !tranfert color from input
186  colorAtom(1,:) = inp%red
187  colorAtom(2,:) = inp%green
188  colorAtom(3,:) = inp%blue
189  ABI_ALLOCATE(displ,(inp%natom,3*inp%natom))
190 !Read end of input file
191 
192 !Multiplication factor for units (from Hartree to cm-1 or THz)
193  if(inp%cunit==1) then
194    facUnit=Ha_cmm1
195  elseif(inp%cunit==2) then
196    facUnit=Ha_THz
197  else
198  end if
199 !calculate nqpt
200  nqpt=0
201  do ii=1,inp%nlines
202    nqpt=nqpt+inp%nqline(ii)
203  end do
204 !compute normalisation factor
205  renorm=0
206  do ii=1,inp%nlines
207    renorm=renorm+inp%nqline(ii)*inp%scale(ii)
208  end do
209  renorm=renorm/nqpt
210 !Calculate inp%min and inp%max
211  inp%min=inp%min/FacUnit
212  inp%max=inp%max/FacUnit
213 
214 !*******************************************************
215 !Begin to write some comments in the eps file
216 !This is based to 'xfig'
217 
218  write(unt1,'(a)') '% !PS-Adobe-2.0 EPSF-2.0'
219  write(unt1,'(a)') '%%Title: band.ps'
220  write(unt1,'(a)') '%%BoundingBox: 0 0 581 310'
221  write(unt1,'(a)') '%%Magnification: 1.0000'
222 
223  write(unt1,'(a)') '/$F2psDict 200 dict def'
224  write(unt1,'(a)') '$F2psDict begin'
225  write(unt1,'(a)') '$F2psDict /mtrx matrix put'
226  write(unt1,'(a)') '/col-1 {0 setgray} bind def'
227  write(unt1,'(a)') '/col0 {0.000 0.000 0.000 srgb} bind def'
228  write(unt1,'(a)') 'end'
229  write(unt1,'(a)') 'save'
230  write(unt1,'(a)') 'newpath 0 310 moveto 0 0 lineto 581 0 lineto 581 310 lineto closepath clip newpath'
231  write(unt1,'(a)') '-36.0 446.0 translate'
232  write(unt1,'(a)') '1 -1 scale'
233 
234  write(unt1,'(a)') '/cp {closepath} bind def'
235  write(unt1,'(a)') '/ef {eofill} bind def'
236  write(unt1,'(a)') '/gr {grestore} bind def'
237  write(unt1,'(a)') '/gs {gsave} bind def'
238  write(unt1,'(a)') '/sa {save} bind def'
239  write(unt1,'(a)') '/rs {restore} bind def'
240  write(unt1,'(a)') '/l {lineto} bind def'
241  write(unt1,'(a)') '/m {moveto} bind def'
242  write(unt1,'(a)') '/rm {rmoveto} bind def'
243  write(unt1,'(a)') '/n {newpath} bind def'
244  write(unt1,'(a)') '/s {stroke} bind def'
245  write(unt1,'(a)') '/sh {show} bind def'
246  write(unt1,'(a)') '/slc {setlinecap} bind def'
247  write(unt1,'(a)') '/slj {setlinejoin} bind def'
248  write(unt1,'(a)') '/slw {setlinewidth} bind def'
249  write(unt1,'(a)') '/srgb {setrgbcolor} bind def'
250  write(unt1,'(a)') '/rot {rotate} bind def'
251  write(unt1,'(a)') '/sc {scale} bind def'
252  write(unt1,'(a)') '/sd {setdash} bind def'
253  write(unt1,'(a)') '/ff {findfont} bind def'
254  write(unt1,'(a)') '/sf {setfont} bind def'
255  write(unt1,'(a)') '/scf {scalefont} bind def'
256  write(unt1,'(a)') '/sw {stringwidth} bind def'
257  write(unt1,'(a)') '/tr {translate} bind def'
258  write(unt1,'(a)') '/tnt {dup dup currentrgbcolor'
259 
260  write(unt1,'(a)') '4 -2 roll dup 1 exch sub 3 -1 roll mul add'
261  write(unt1,'(a)') '4 -2 roll dup 1 exch sub 3 -1 roll mul add'
262  write(unt1,'(a)') '4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb}'
263  write(unt1,'(a)') 'bind def'
264  write(unt1,'(a)') '/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul'
265  write(unt1,'(a)') ' 4 -2 roll mul srgb} bind def'
266  write(unt1,'(a)') '/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def'
267  write(unt1,'(a)') '/$F2psEnd {$F2psEnteredState restore end} def'
268  write(unt1,'(a)') '$F2psBegin'
269  write(unt1,'(a)') '%%Page: 1 1'
270  write(unt1,'(a)') '10 setmiterlimit'
271  write(unt1,'(a)') '0.06000 0.06000 sc'
272 
273 !****************************************************************
274 !Begin of the intelligible part of the postcript document
275 
276  write(unt1,'(a)') '%**************************************'
277 !****************************************************************
278 !Draw the box containing the plot
279  write(unt1,'(a)') '%****Big Box****'
280  write(unt1,'(a)') '12 slw'
281  write(unt1,'(a,i4,a,i4,a,i4,a,i4,a,i4,a,i4,a,i4,a,i4,a)') 'n ', kminN,' ', EmaxN,&
282 & ' m ', kmaxN,' ', EmaxN, ' l ', &
283 & kmaxN,' ', EminN, ' l ', kminN,' ', EminN, ' l'
284  write(unt1,'(a)') 'cp gs col0 s gr'
285 
286 !****************************************************************
287 !Write unit on the middle left of the vertical axe
288  write(unt1,'(a)') '%****Units****'
289 
290  if(inp%cunit==1) then
291 !  1/lambda
292    write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
293    write(unt1,'(a)') '1425 5650 m'
294    write(unt1,'(3a)') 'gs 1 -1 sc  90.0 rot (Frequency ',achar(92),'(cm) col0 sh gr'
295 !  cm-1
296    write(unt1,'(a)') '/Times-Roman ff 200.00 scf sf'
297    write(unt1,'(a)') '1325 4030 m'
298    write(unt1,'(a)') 'gs 1 -1 sc 90.0 rot  (-1) col0 sh gr'
299    write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
300    write(unt1,'(a)') '1425 3850 m'
301    write(unt1,'(3a)') 'gs 1 -1 sc  90.0 rot (',achar(92),')) col0 sh gr'
302  else
303 !  Freq
304    write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
305    write(unt1,'(a)') '825 4850 m'
306    write(unt1,'(a)') 'gs 1 -1 sc  90.0 rot (Freq) col0 sh gr'
307 !  THz
308    write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
309    write(unt1,'(a)') '825 4350 m'
310    write(unt1,'(a)') 'gs 1 -1 sc 90.0 rot  (THz) col0 sh gr'
311  end if
312 !*****************************************************************
313 !Write graduation on the vertical axe
314  write(unt1,'(a)') '%****Vertical graduation****'
315  deltaE=(inp%max-inp%min)/inp%ngrad
316 
317 !Replacing do loop with real variables with standard g95 do loop
318  E=inp%min
319  do
320 !  do E=inp%min,(inp%max-deltaE/2),deltaE
321    if (E >= (inp%max-deltaE/2)-tol6) exit
322    pos=int(((EminN-EmaxN)*E &
323 &   +EmaxN*inp%min -EminN*inp%max)/(inp%min-inp%max))
324 
325 !  write the value of energy(or frequence)
326    write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
327    write(unt1,'(i4,a,i4,a)') kminN-800,' ',pos+60,' m'        !-1300 must be CHANGED
328 !  as a function of the width of E
329    write(unt1,'(a,i6,a)') 'gs 1 -1 sc (', nint(E*facUnit),') col0 sh gr'
330 
331 !  write a little bar
332    write(unt1,'(a,i4,a,i4,a,i4,a,i4,a)') 'n ', kminN,' ',pos ,' m ', kminN+100,' ', pos, ' l'
333    write(unt1,'(a)') 'gs col0 s gr '
334 
335    E = E+deltaE
336  end do
337 
338 !do the same thing for E=inp%max (floating point error)
339  write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
340  write(unt1,'(i4,a,i4,a)') kminN-800,' ',EmaxN+60,' m'        !-1300 must be changed as E
341  write(unt1,'(a,i6,a)') 'gs 1 -1 sc (', nint(inp%max*facUnit),') col0 sh gr'
342 
343 
344 !draw zero line
345  E=0
346  pos=int(((EminN-EmaxN)*E &
347 & +EmaxN*inp%min -EminN*inp%max)/(inp%min-inp%max))
348  write(unt1,'(a,i4,a,i4,a,i4,a,i4,a)') 'n ', kminN,' ',pos ,' m ', kmaxN,' ', pos, ' l'
349  write(unt1,'(a)') 'gs col0 s gr '
350 
351 
352 !******************************************************
353 !draw legend of horizontal axe
354 !+vertical line
355 
356  write(unt1,'(a)') '%****Horizontal graduation****'
357 
358  lastPos=kminN
359 
360  do ii=0,inp%nlines
361 
362    if(ii/=0) then
363      posk=int(((kminN-kmaxN)*(inp%nqline(ii))) &
364 &     *inp%scale(ii)/renorm/(-nqpt))
365    else
366      posk=0
367    end if
368 
369    posk=posk+lastPos
370    lastPos=posk
371 
372    if(tolower(inp%qpoint_name(ii+1))=='gamma') then             !GAMMA
373      write(unt1,'(a)') '/Symbol ff 270.00 scf sf'
374      write(unt1,'(i4,a,i4,a)') posk-100,' ', 7150, ' m'
375      write(unt1,'(a)') 'gs 1 -1 sc (G) col0 sh gr'
376    elseif(tolower(inp%qpoint_name(ii+1))=='lambda') then              !LAMBDA
377      write(unt1,'(a)') '/Symbol ff 270.00 scf sf'
378      write(unt1,'(i4,a,i4,a)') posk-100,' ', 7150, ' m'
379      write(unt1,'(a)') 'gs 1 -1 sc (L) col0 sh gr'
380    else                                     !autre
381      write(unt1,'(a)') '/Times-Roman ff 270.00 scf sf'
382      write(unt1,'(i4,a,i4,a)') posk-100,' ', 7150, ' m'
383      write(unt1,'(a,a1,a)') 'gs 1 -1 sc (',inp%qpoint_name(ii+1),') col0 sh gr'
384    end if
385 
386 !  draw vertical line
387    write(unt1,'(a,i4,a,i4,a,i4,a,i4,a)') 'n ', posk,' ',EminN ,' m ', posk,' ', EmaxN, ' l'
388    write(unt1,'(a)') 'gs col0 s gr '
389 
390  end do
391 
392 !***********************************************************
393 !Write the bands (the most important part actually)
394 
395  write(unt1,'(a)') '%****Write Bands****'
396 
397  lastPos=kminN
398 
399  read(unt2,*) (phfrqqm1(ii),ii=1,3*inp%natom)
400 
401  do jj=1,inp%nlines
402    do iqpt=1,inp%nqline(jj)
403      read(unt2,*) (phfrq(ii),ii=1,3*inp%natom)
404      do imode=1,3*inp%natom
405 
406        if(filnam(4)/='no') then       !calculate the color else in black and white
407          do iatom=1,inp%natom
408            read(unt3,*) displ(iatom,imode)
409          end do
410 !        normalize displ
411          norm=0
412          do iatom=1,inp%natom
413            norm=norm+displ(iatom,imode)
414          end do
415 
416          do iatom=1,inp%natom
417            displ(iatom,imode)=displ(iatom,imode)/norm
418          end do
419 
420 !        Treat color
421          color(:,imode)=0
422          do ii=1,inp%natom
423 !          Red
424            color(1,imode)=color(1,imode)+displ(ii,imode)*colorAtom(1,ii)
425 !          Green
426            color(2,imode)=color(2,imode)+displ(ii,imode)*colorAtom(2,ii)
427 !          Blue
428            color(3,imode)=color(3,imode)+displ(ii,imode)*colorAtom(3,ii)
429          end do
430        end if
431 
432        pos=int(((EminN-EmaxN)*phfrqqm1(imode) &
433 &       +EmaxN*inp%min -EminN*inp%max)/(inp%min-inp%max))
434 
435        posk=int(((kminN-kmaxN)*(iqpt-1) &
436 &       *inp%scale(jj)/renorm/(-nqpt)))
437        posk=posk+lastPos
438 
439        write(unt1,'(a,i5,a,i5,a)') 'n ',posk,' ',pos,' m'
440 
441        pos=int(((EminN-EmaxN)*phfrq(imode) &
442 &       +EmaxN*inp%min -EminN*inp%max)/(inp%min-inp%max))
443        posk=int(((kminN-kmaxN)*(iqpt) &
444 &       *inp%scale(jj)/renorm/(-nqpt)))
445        posk=posk+lastPos
446        write(unt1,'(i5,a,i5,a)') posk,' ',pos,' l gs'
447 
448 
449        if(filnam(4)/='no') then     !(in color)
450          write(unt1,'(f6.3,a,f6.3,a,f6.3,a)') color(1,imode),' ', &
451 &         color(2,imode),' ',color(3,imode), ' srgb s gr'
452        else
453          write(unt1,'(f6.3,a,f6.3,a,f6.3,a)') 0.0,' ', &
454 &         0.0,' ',0.0, ' srgb s gr'
455        end if
456 
457 
458      end do
459 
460      phfrqqm1=phfrq
461 
462    end do
463    lastPos=posk
464 
465  end do
466 
467 
468 !**********************************************************
469 !Ending the poscript document
470  write(unt1,'(a)') '$F2psEnd'
471  write(unt1,'(a)') 'rs'
472 
473  !call abinit_doctor("__band2eps")
474 
475  call band2eps_dtset_free(inp)
476 
477  call xmpi_end()
478 
479  end program band2eps