      subroutine celout (iatom,elemt,ide,x,y,z,imult,iwarn,st,ipt,      CELO001
     &                   dismax,vez,t,cel,icomp,title)                  CELO002
c ----------------------------------------------------------------------CELO003
c     prints atom input and multiplicities, energies and z              CELO004
c ----------------------------------------------------------------------CELO005
c     This program module is part of the PhysiSoft X-ray Library        CELO006
c     and may not be sold or reproduced for commercial purposes.        CELO007
c     Although it has been tested carefully, there is no warranty       CELO008
c     regarding accuracy or freedom from side-effects.                  CELO009
c                   (C) 1986-1991 Bernhard Rupp                         CELO010
c                       Revised 6/28/93                                 CELO011
c ----------------------------------------------------------------------CELO012
c     File cell.dat contains unit cell parameters and atom positions    CELO013
c     in asymmetric unit cell                                           CELO014
c     File atom.dat contains title, unit cell parameters and atom       CELO015
c     position in asymmetric unit cell as needed for SCHAKAL program    CELO016
c     files : 6=screen, 7=sexie.out, 8=atom.dat, 9=cell.dat             CELO017
c ----------------------------------------------------------------------CELO018
      parameter (iat=20, ixyz=8)                                        CELO019
                                                                        CELO020
      character elemt*2,ide*4,lv,an,icomp*4,title*60                    CELO021
      dimension elemt(iat),ide(iat),x(iat),y(iat),z(iat),imult(iat)     CELO022
      dimension iwarn(iat),st(iat,192,4),ipt(iat),iz(iat),ed(iat,4)     CELO023
      dimension x1(3),cel(6),aw(iat)                                    CELO024
                                                                        CELO025
      if (icomp.eq.'IBM ') then                                         CELO026
         lv=char(179)                                                   CELO027
         an=char(143)                                                   CELO028
      else                                                              CELO029
         lv='|'                                                         CELO030
         an='A'                                                         CELO031
      end if                                                            CELO032
                                                                        CELO033
      iztot=0                                                           CELO034
      isum=0                                                            CELO035
      ierr=0                                                            CELO036
      avo=6.023e23                                                      CELO037
      atcc=1.0e24                                                       CELO038
      weit=0.0                                                          CELO039
      ilast=9                                                           CELO040
                                                                        CELO041
c --- atom.dat and cell.dat -----------                                 CELO042
                                                                        CELO043
      open (ilast,file='cell.dat',status='unknown')                     CELO044
      open (ixyz,file='atom.dat',status='unknown')                      CELO045
      write(ixyz,'(a,a)') 'TITL ',title                                 CELO046
      write(ixyz,'(a,6(1x,f9.4))') 'CELL', (cel(i), i=1,6)              CELO047
      write(ilast,'(1x,6f12.5)') (cel(i),i=1,6)                         CELO048
                                                                        CELO049
c --- retrieve z and edge energies --                                   CELO050
      do 0001 i=1,iatom                                                 CELO051
         call upstrg(elemt(i),2)                                        CELO052
         iz(i)=ielect (elemt(i))                                        CELO053
         aw(i)=atweit (iz(i))                                           CELO054
         call makels (elemt(i))                                         CELO055
         if (iz(i).ge.1.and.iz(i).le.105) then                          CELO056
            ed(i,1)=energy(iz(i),1,1)*1000.0                            CELO057
            do 0002 j=1,3                                               CELO058
               ed(i,j+1)=energy(iz(i),2,j)*1000.0                       CELO059
 0002       continue                                                    CELO060
         else                                                           CELO061
            do 0003 j=1,4                                               CELO062
               ed(i,j)=0.0                                              CELO063
 0003       continue                                                    CELO064
            ierr=1                                                      CELO065
         end if                                                         CELO066
         iztot=iztot+iz(i)*imult(i)                                     CELO067
         isum=isum+imult(i)                                             CELO068
         weit=weit+aw(i)*imult(i)                                       CELO069
 0001 continue                                                          CELO070
      eldens=iztot/vez                                                  CELO071
      adens=isum/vez                                                    CELO072
      dens=(weit/vez)*(atcc/avo)                                        CELO073
                                                                        CELO074
c --- run over output twice, for screen and output file                 CELO075
      do 9001 ipr=6,7                                                   CELO076
      write(ipr,'(/a/)')'  Preparation of unit cell information follows'CELO077
      call frames (ipr,1,icomp)                                         CELO078
      write(ipr,'(1x,a1,2x,a,a,2x,a1)') lv, 'Coordinates, multiplicity',CELO079
     & ' and energy of non equivalent atoms in unit cell',lv            CELO080
      call frames (ipr,2,icomp)                                         CELO081
      write(ipr,'(1x,a1,a,a,a1)') lv,' Nr. Atom Label    X      Y  ',   CELO082
     & '    Z   Mult  z   K (eV)    L1      L2      L3  ',lv            CELO083
      call frames (ipr,2,icomp)                                         CELO084
                                                                        CELO085
c --- crank out atom table --                                           CELO086
      do 0004 i=1,iatom                                                 CELO087
        write(ipr,'(1x,a1,i2,a1,3x,a2,3x,a4,3(f7.4),i4,i4,f9.1,         CELO088
     &              3f8.1,a1)')                                         CELO089
     &     lv,i,'.',elemt(i),ide(i),x(i),y(i),z(i),imult(i),iz(i),      CELO090
     &     (ed(i,j),j=1,4),lv                                           CELO091
        if (ipr.eq.6) then                                              CELO092
            write (ixyz,'(a5,a4,3(1x,f9.6))')                           CELO093
     &         'ATOM ',elemt(i), X(I),Y(I),Z(I)                         CELO094
        end if                                                          CELO095
 0004 continue                                                          CELO096
                                                                        CELO097
      call frames (ipr,2,icomp)                                         CELO098
      isok=1                                                            CELO099
      do 0005 i=1,iatom                                                 CELO100
         if (iwarn(i).ne.0) then                                        CELO101
            write (ipr,'(1x,a1,a,i2,a,a,a1)') lv, ' Warning - atoms '   CELO102
     &      ,i, ' seem very close to each other - assume ',             CELO103
     &          'coordinate error  ',lv                                 CELO104
            isok=0                                                      CELO105
         end if                                                         CELO106
 0005 continue                                                          CELO107
      if (isok.eq.1) then                                               CELO108
         write (ipr,'(1x,a1,a,a,8x,a1)') lv, ' All equipoints of one ', CELO109
     &   'atom have reasonable distances from each other',lv            CELO110
      else                                                              CELO111
         write (ipr,'(1x,a1,a,a,a1)') lv, ' Check for errors in atom',  CELO112
     &  ' positions possibly yielding wrong multiplicities   ',lv       CELO113
      end if                                                            CELO114
c --- now crank out the positions --                                    CELO115
      write (ipr,'(1x,a1,a,a,a1)') lv, ' The equipoint transfor',       CELO116
     &  'mations generated following atoms in the unit cell :  ',lv     CELO117
      call frames (ipr,2,icomp)                                         CELO118
      write(ipr,'(1x,a1,19x,a,a,a1,a,a1)') lv,' Fractional',            CELO119
     & ' Coord.   Cartesian coordinates (',an,')            ',lv        CELO120
      write(ipr,'(1x,a1,a,a,a1)') lv,' Nr. Atom Pos.Nr.   X      Y  ',  CELO121
     & '    Z        x      y      z    Dist to Origin ',lv             CELO122
      call frames (ipr,2,icomp)                                         CELO123
 9001 continue                                                          CELO124
                                                                        CELO125
      do 9002 ipr=6,ilast                                               CELO126
      do 1003 ia=1,iatom                                                CELO127
c ---    ipt(ia)=imult(ia)                                              CELO128
         do 1004 ip=1,ipt(ia)                                           CELO129
            do 1005 j=1,3                                               CELO130
               x1(j)=st(ia,ip,j)                                        CELO131
 1005       continue                                                    CELO132
c ---       t is already expanded with unit cell dimensions ---         CELO133
            call tracor (x1,t)                                          CELO134
                                                                        CELO135
            if (ipr.lt.8) then                                          CELO136
              if (ip.eq.1) then                                         CELO137
                 write(ipr,'(1x,a1,i3,4x,a2,3x,i3,1x,3f7.4,             CELO138
     &                       1x,3f8.4,1x,f10.4,4x,a1)')                 CELO139
     &           lv,ia,elemt(ia),ip,(st(ia,ip,i),i=1,3),(x1(i),i=1,3),  CELO140
     &           st(ia,ip,4),lv                                         CELO141
              else                                                      CELO142
                 write(ipr,'(1x,a1,3x,4x,2x,3x,i3,1x,3f7.4,             CELO143
     &                       1x,3f8.4,1x,f10.4,4x,a1)') lv,             CELO144
     &                           ip,(st(ia,ip,i),i=1,3),(x1(i),i=1,3),  CELO145
     &           st(ia,ip,4),lv                                         CELO146
              end if                                                    CELO147
            elseif (ipr.eq.9) then                                      CELO148
              if (ip.eq.1) then                                         CELO149
                 write(ipr,'(1x,i3,4x,a2,3x,i3,1x,3f7.4,                CELO150
     &                       1x,3f8.4,1x,f10.4)')                       CELO151
     &           ia,elemt(ia),ip,(st(ia,ip,i),i=1,3),(x1(i),i=1,3),     CELO152
     &           st(ia,ip,4)                                            CELO153
              else                                                      CELO154
                 write(ipr,'(1x,3x,4x,2x,3x,i3,1x,3f7.4,                CELO155
     &                       1x,3f8.4,1x,f10.4)')                       CELO156
     &                           ip,(st(ia,ip,i),i=1,3),(x1(i),i=1,3),  CELO157
     &           st(ia,ip,4)                                            CELO158
              end if                                                    CELO159
            end if                                                      CELO160
 1004    continue                                                       CELO161
         if (ipr.lt.8) call frames (ipr,2,icomp)                        CELO162
 1003 continue                                                          CELO163
 9002 continue                                                          CELO164
                                                                        CELO165
      do 9003 ipr=6,7                                                   CELO166
c --- print the maximum distance  within the unit cell --               CELO167
      write (ipr,'(1x,a1,a,f8.4,1x,a1,19x,a1)')                         CELO168
     & lv, ' Maximum distance within asymmetric unit cell is',          CELO169
     & dismax,an,lv                                                     CELO170
      write (ipr,'(1x,a1,a,i5,a,f5.4,a,a1,a,3x,a1)')                    CELO171
     & lv, ' Unit cell contains :',isum,                                CELO172
     & ' atoms; average atom density is ',                              CELO173
     &   adens,' atoms/',an,'**3',lv                                    CELO174
      write (ipr,'(1x,a1,18x,i8,a,f6.4,a,a1,a,3x,a1)')                  CELO175
     & lv, iztot, ' electrons; average el density is ',                 CELO176
     &   eldens,' el/',an,'**3',lv                                      CELO177
      write (ipr,'(1x,a1,a,f7.4,a,8x,a1)') lv,                          CELO178
     & ' The calculated X-ray density of this material is ',dens,       CELO179
     & ' gram/cm**3 ',lv                                                CELO180
                                                                        CELO181
      call frames (ipr,3,icomp)                                         CELO182
 9003 continue                                                          CELO183
                                                                        CELO184
      close (ilast,status='keep')                                       CELO185
      close (ixyz, status='keep')                                       CELO186
                                                                        CELO187
      return                                                            CELO188
      end                                                               CELO189
