      subroutine celout (iatom,elemt,ide,x,y,z,imult,iwarn,foc,bf,      CELO001
     &             vez,t,cel,icomp,title,ucell,incel,istor,iat,lv,an,   CELO002
     &             f000,rofats,nel,xdens,izell)                         CELO003
c ----------------------------------------------------------------------CELO004
c     This program module is part of the author's X-ray Library         CELO005
c     and may not be sold or reproduced for commercial purposes.        CELO006
c     Although it has been tested carefully, there is no warranty       CELO007
c     regarding accuracy or freedom from side-effects.                  CELO008
c                   (C) 1986-1994 Bernhard Rupp                         CELO009
c ----------------------------------------------------------------------CELO010
c     CELOUT prints atom input and multiplicities, energies and z       CELO011
c ----------------------------------------------------------------------CELO012
c     File cell.dat contains unit cell parameters and atom positions    CELO013
c     in asymmetric unit (motif)                                        CELO014
c     File atom.dat contains title, unit cell parameters and atom       CELO015
c     position in asymmetric unit as needed for SCHAKAL program         CELO016
c     files : 6=screen, 7=sexie.out, 8=atom.dat, 9=cell.dat             CELO017
c ----------------------------------------------------------------------CELO018
      parameter (ixyz=8,icell=9)                                        CELO019
                                                                        CELO020
      character elemt*2,ide*4,lv,an,icomp*4,title*60,elem*2             CELO021
      dimension elemt(iat),ide(iat),x(iat),y(iat),z(iat),imult(iat)     CELO022
      dimension iwarn(iat),ed(4),x1(3),cel(6),ucell(istor,incel)        CELO023
      dimension foc(iat),bf(iat),rofats(nel)                            CELO024
                                                                        CELO025
c --- atom.dat and cell.dat -----------                                 CELO026
      open (icell,file='cell.dat',status='unknown')                     CELO027
      open (ixyz,file='atom.dat',status='unknown')                      CELO028
      write(ixyz,'(a,a)') 'TITL ',title                                 CELO029
      write(ixyz,'(a,6(1x,f9.4))') 'CELL', (cel(i), i=1,6)              CELO030
      write(icell,'(1x,6f12.5)') (cel(i),i=1,6)                         CELO031
                                                                        CELO032
c --- run over output twice, for screen and output file                 CELO033
      do 9001 ipr=6,7                                                   CELO034
      write(ipr,'(/a/)')'  Preparation of unit cell information follows'CELO035
      if (izell.eq.1) then                                              CELO036
      call frames (ipr,1,icomp)                                         CELO037
      write(ipr,'(1x,a1,2x,a,a,2x,a1)') lv, 'Coordinates, multiplicity',CELO038
     & ' and energy of non equivalent atoms in unit cell',lv            CELO039
      call frames (ipr,2,icomp)                                         CELO040
      write(ipr,'(1x,a1,a,a,a1)') lv,' Nr. Atom Label    X      Y  ',   CELO041
     & '    Z   Mult  z   K (eV)    L1      L2      L3  ',lv            CELO042
      call frames (ipr,2,icomp)                                         CELO043
      end if                                                            CELO044
                                                                        CELO045
      F000=0                                                            CELO046
      rztot=0                                                           CELO047
      rsum=0.0                                                          CELO048
      ierr=0                                                            CELO049
      avo=6.023e23                                                      CELO050
      atcc=1.0e24                                                       CELO051
      weit=0.0                                                          CELO052
      uweit=0.0                                                         CELO053
      do 0001 i=1,nel                                                   CELO054
         rofats(i)=0.0                                                  CELO055
 0001 continue                                                          CELO056
c --- crank out atom table --                                           CELO057
      do 0004 i=1,iatom                                                 CELO058
c ---    retrieve z and edge energies --                                CELO059
         call upstrg(elemt(i),2)                                        CELO060
         iz=ielect(elemt(i))                                            CELO061
         aw=atweit(iz)                                                  CELO062
         call makels (elemt(i))                                         CELO063
         if (iz.ge.1.and.iz.le.105) then                                CELO064
            ed(1)=energy(iz,1,1)*1000.0                                 CELO065
            do 0002 j=1,3                                               CELO066
               ed(j+1)=energy(iz,2,j)*1000.0                            CELO067
 0002       continue                                                    CELO068
         else                                                           CELO069
            do 0003 j=1,4                                               CELO070
               ed(j)=0.0                                                CELO071
 0003       continue                                                    CELO072
            ierr=1                                                      CELO073
         end if                                                         CELO074
         rztot=rztot+iz*imult(i)*foc(i)                                 CELO075
         rsum=rsum+imult(i)*foc(i)                                      CELO076
         weit=weit+aw*imult(i)*foc(i)                                   CELO077
         uweit=uweit+aw*foc(i)                                          CELO078
         rofats(iz)=rofats(iz)+imult(i)*foc(i)                          CELO079
         if (izell.eq.1) then                                           CELO080
         write(ipr,'(1x,a1,i4,a1,1x,a2,3x,a4,3(f7.4),i4,i4,f9.1,        CELO081
     &              3f8.1,a1)')                                         CELO082
     &      lv,i,'.',elemt(i),ide(i),x(i),y(i),z(i),imult(i),iz,        CELO083
     &      (ed(j),j=1,4),lv                                            CELO084
         end if                                                         CELO085
         if (ipr.eq.6) then                                             CELO086
            write (ixyz,'(a5,a4,3(1x,f9.6))')                           CELO087
     &         'ATOM ',elemt(i), X(I),Y(I),Z(I)                         CELO088
         end if                                                         CELO089
 0004 continue                                                          CELO090
                                                                        CELO091
      if (izell.eq.1) then                                              CELO092
      call frames (ipr,2,icomp)                                         CELO093
c --- warning if problems occurred --                                   CELO094
      isok=1                                                            CELO095
      do 0005 i=1,iatom                                                 CELO096
         if (iwarn(i).ne.0) then                                        CELO097
            write (ipr,'(1x,a1,a,i2,a,a,a1)') lv, ' Warning - atoms '   CELO098
     &      ,i, ' seem very close to each other - assume ',             CELO099
     &          'coordinate error  ',lv                                 CELO100
            isok=0                                                      CELO101
         end if                                                         CELO102
 0005 continue                                                          CELO103
      if (isok.eq.1) then                                               CELO104
         write (ipr,'(1x,a1,a,a,8x,a1)') lv, ' All equipoints of one ', CELO105
     &   'atom have reasonable distances from each other',lv            CELO106
      else                                                              CELO107
         write (ipr,'(1x,a1,a,a,a1)') lv, ' Check for errors in atom',  CELO108
     &  ' positions possibly yielding wrong multiplicities   ',lv       CELO109
      end if                                                            CELO110
                                                                        CELO111
c --- now crank out the positions --                                    CELO112
      write (ipr,'(1x,a1,a,a,a1)') lv, ' The equipoint transfor',       CELO113
     &  'mations generated following atoms in the unit cell :  ',lv     CELO114
      call frames (ipr,2,icomp)                                         CELO115
      write(ipr,'(1x,a1,19x,a,a,a1,a,a1)') lv,'  Fractional',           CELO116
     & ' Coord.   Cartesian coordinates (',an,')      Symm.',lv         CELO117
      write(ipr,'(1x,a1,a,a,a1)') lv,' Nr. Atom Pos.   Nr.   X      Y ',CELO118
     &       '     Z        x       y       z    focc Oper.',lv         CELO119
      call frames (ipr,2,icomp)                                         CELO120
      end if                                                            CELO121
c --- izell.eq.1                                                        CELO122
                                                                        CELO123
 9001 continue                                                          CELO124
                                                                        CELO125
c --- for each non equivalent atom in the unit cell                     CELO126
      do 0006 ia=1,iatom                                                CELO127
c --- find where its equivalent positions begin and end in ucell        CELO128
         ibeg=0                                                         CELO129
         do 0008 i=1,ia-1                                               CELO130
            ibeg=ibeg+imult(i)                                          CELO131
 0008    continue                                                       CELO132
         ibeg=ibeg+1                                                    CELO133
         iend=ibeg+imult(ia)-1                                          CELO134
c ---    and list all them all                                          CELO135
         do 0007 ip=ibeg,iend                                           CELO136
c ---       get the cartesian coordinates                               CELO137
            do 0009 j=1,3                                               CELO138
               x1(j)=ucell(ip,j)                                        CELO139
 0009       continue                                                    CELO140
            call tracor (x1,t)                                          CELO141
            isymop=int(ucell(ip,4))                                     CELO142
            id=int(ucell(ip,5))                                         CELO143
            if (id.ne.ia) then                                          CELO144
               write(*,*)' ** HORROR ** problem generating equivalents' CELO145
               pause                                                    CELO146
            end if                                                      CELO147
c ---       start listing ---                                           CELO148
            do 0010,ipr=6,icell                                         CELO149
            if (ipr.lt.ixyz) then                                       CELO150
               if (izell.eq.1) then                                     CELO151
                 write(ipr,'(1x,a1,i5,1x,a2,1x,a4,i6,3f7.4,             CELO152
     &                       1x,3f9.4,1x,f4.2,i3,1x,a1)') lv,           CELO153
     &   ia,elemt(ia),ide(ia),ip,(ucell(ip,i),i=1,3),(x1(i),i=1,3),     CELO154
     &                            foc(ia),isymop,lv                     CELO155
               end if                                                   CELO156
            elseif (ipr.eq.icell) then                                  CELO157
              call upstrg(elemt(ia),2)                                  CELO158
              iz=ielect(elemt(ia))                                      CELO159
              F000=F000+iz*foc(ia)                                      CELO160
              write(ipr,'(3i6, 3f8.5,5f8.3,i4,1x,a2,1x,a4)')            CELO161
     &        ip,ia,iz,(ucell(ip,i),i=1,3),foc(ia),bf(ia),              CELO162
     &        (x1(i),i=1,3),isymop,elemt(ia),ide(ia)                    CELO163
            end if                                                      CELO164
 0010    continue                                                       CELO165
 0007    continue                                                       CELO166
 0006 continue                                                          CELO167
                                                                        CELO168
c --- compute electron xdensity, atom xdensity, x-ray xdensity --       CELO169
      eldens=rztot/vez                                                  CELO170
      adens=rsum/vez                                                    CELO171
      xdens=(weit/vez)*(atcc/avo)                                       CELO172
                                                                        CELO173
      do 0012 ipr=6,7                                                   CELO174
c --- print unit cell statistics --                                     CELO175
      if (izell.eq.1) then                                              CELO176
         call frames (ipr,2,icomp)                                      CELO177
      else                                                              CELO178
         call frames (ipr,1,icomp)                                      CELO179
      end if                                                            CELO180
      write (ipr,'(1x,a1,a,f8.1,a,f5.4,a,a1,a,3x,a1)')                  CELO181
     &    lv,' U-cell contains :',rsum,                                 CELO182
     & '    atoms; average atom density is ',                           CELO183
     &   adens,' at/',an,'**3',lv                                       CELO184
      do 0020 i=1,nel                                                   CELO185
         if (rofats(i).gt.0.001) then                                   CELO186
            call ztosym(i,elem)                                         CELO187
            write (ipr,'(1x,a1,18x,f8.1,1x,a,a,42x,a1)')                CELO188
     &      lv, rofats(i), elem,' atoms',lv                             CELO189
         end if                                                         CELO190
 0020 continue                                                          CELO191
      write (ipr,'(1x,a1,16x,f10.1,a,f6.4,a,a1,a,3x,a1)')               CELO192
     & lv, rztot,      ' electrons; average el density is ',            CELO193
     &   eldens,' el/',an,'**3',lv                                      CELO194
                                                                        CELO195
      write (ipr,'(1x,a1,a,f10.2,a,5x,a1)') lv,                         CELO196
     & ' The molecular weight of the unit cell is         ',weit,       CELO197
     & ' gram       ',lv                                                CELO198
                                                                        CELO199
      write (ipr,'(1x,a1,a,f10.2,a,5x,a1)') lv,                         CELO200
     & ' The molecular weight of the asymmetric unit is   ',uweit,      CELO201
     & ' gram       ',lv                                                CELO202
                                                                        CELO203
      write (ipr,'(1x,a1,a,f10.2,a,5x,a1)') lv,                         CELO204
     & ' The calculated x-ray density of the material is  ',xdens,      CELO205
     & ' gram/cm**3 ',lv                                                CELO206
                                                                        CELO207
      write (ipr,'(1x,a1,a,f9.2,a,6x,a1)') lv,                          CELO208
     & ' Structure factor F(0,0,0) for this material is    ',F000,      CELO209
     & '           ',lv                                                 CELO210
                                                                        CELO211
      call frames (ipr,3,icomp)                                         CELO212
 0012 continue                                                          CELO213
                                                                        CELO214
      close (icell,status='keep')                                       CELO215
      close (ixyz, status='keep')                                       CELO216
                                                                        CELO217
      return                                                            CELO218
      end                                                               CELO219
