      subroutine multi2 (iatom,ibravl,x,y,z,fs,ts,imult,isymce,ns,igen, MULT001
     &                   iwarn,cel,ucell,incel,istor,iat,iatcnt)        MULT002
c ----------------------------------------------------------------------MULT003
c     This program module is part of the author's X-ray Library         MULT004
c     and may not be sold or reproduced for commercial purposes.        MULT005
c     Although it has been tested carefully, there is no warranty       MULT006
c     regarding accuracy or freedom from side-effects.                  MULT007
c                   (C) 1986-1994 Bernhard Rupp                         MULT008
c ----------------------------------------------------------------------MULT009
c     MULTI2 finds multiplicities of special positions                  MULT010
c ----------------------------------------------------------------------MULT011
c     Latest revision : Scaling box values changed to avoid 'SELFATOMS' MULT012
c ----------------------------------------------------------------------MULT013
                                                                        MULT014
      dimension x(iat),y(iat),z(iat),imult(iat),ts(3,24),fs(3,3,24)     MULT015
      dimension b1(3,9),tsb(3),xyz(3),iwarn(iat)                        MULT016
      dimension cel(6), ucell(istor,incel), xyz1(3)                     MULT017
                                                                        MULT018
      data ((b1(i,j),i=1,3),j=1,9)/0.0,0.0,0.0, 0.5,0.5,0.5,            MULT019
     & 0.6666667,0.3333333,0.3333333, 0.5,0.5,0.0, 0.0,0.5,0.5,         MULT020
     & 0.5,0.0,0.5, 0.5,0.5,0.0, 0.3333333,0.6666667,0.6666667,         MULT021
     & 0.,0.,0./                                                        MULT022
                                                                        MULT023
c --- number of bravais translations                                    MULT024
      nbra=1                                                            MULT025
      if (ibravl.gt.1) nbra=2                                           MULT026
      if (ibravl.eq.3) nbra=3                                           MULT027
      if (ibravl.eq.4) nbra=4                                           MULT028
                                                                        MULT029
c --- initialize total atom counter                                     MULT030
      iatcnt=0                                                          MULT031
c --- initialize                                                        MULT032
                                                                        MULT033
c --- loop over all inequivalent atoms                                  MULT034
      do 0006 ia=1,iatom                                                MULT035
         iwarn(ia)=0                                                    MULT036
c ---    set the check atom to the given inequivalent position ia       MULT037
         xyz1(1)=x(ia)                                                  MULT038
         xyz1(2)=y(ia)                                                  MULT039
         xyz1(3)=z(ia)                                                  MULT040
         imult(ia)=0                                                    MULT041
         isymop=0                                                       MULT042
c ---    make positive and add the first atom given into the ucell      MULT043
         iatcnt=iatcnt+1                                                MULT044
         do 0001 i=1,3                                                  MULT045
            if (xyz1(i).lt.0.0) xyz1(i)=xyz1(i)+1.0                     MULT046
c ---       put the first atom given as inquivalent into the ucell      MULT047
            ucell(iatcnt,i)=xyz1(i)                                     MULT048
 0001    continue                                                       MULT049
         ucell(iatcnt,4)=1                                              MULT050
         ucell(iatcnt,5)=ia                                             MULT051
c ---    loop over 192 equivalent positions                             MULT052
         do 0004 j=1,ns                                                 MULT053
c ---    loop over bravais lattice points                               MULT054
            do 0004 nb=1,nbra                                           MULT055
               anti=1.0                                                 MULT056
 0002          dif=0.0                                                  MULT057
c ---          calculate atom coordinates                               MULT058
               do 0003 i=1,3                                            MULT059
                  xyz(i)=anti*(ts(i,j)+fs(1,i,j)*xyz1(1)+fs(2,i,j)*     MULT060
     &                   xyz1(2)+fs(3,i,j)*xyz1(3))                     MULT061
                  if (nb.eq.1) tsb(i)=b1(i,1)                           MULT062
                  if (nb.eq.2) tsb(i)=b1(i,ibravl)                      MULT063
                  if (nb.eq.4) tsb(i)=b1(i,6)                           MULT064
                  if ((nb.eq.3).and.(ibravl.eq.3)) tsb(i)=b1(i,8)       MULT065
                  if ((nb.eq.3).and.(ibravl.eq.4)) tsb(i)=b1(i,5)       MULT066
c ---             add bravais lattice vectors                           MULT067
                  xyz(i)=xyz(i)+tsb(i)                                  MULT068
                                                                        MULT069
c ---             normalize in box (0 < x < 1)                          MULT070
                  if (xyz(i).ge.1.99999) xyz(i)=xyz(i)-2.0              MULT071
                  if (xyz(i).ge.0.99999) xyz(i)=xyz(i)-1.0              MULT072
                  if (xyz(i).lt.-1.00001) xyz(i)=xyz(i)+2.0             MULT073
                  if (xyz(i).lt.-0.00001) xyz(i)=xyz(i)+1.0             MULT074
 0003          continue                                                 MULT075
               isymop=isymop+1                                          MULT076
c ---          check, if we had that triple already in memory           MULT077
c              COMMENT : I have selected 0.1 A as a cutoff for deter-   MULT078
c              mining whether atoms coincide or not. This and the nor-  MULT079
c              malization box above can be changed when problems occur -MULT080
c              but it's most likely bad input causing such......        MULT081
               do 2001 ii=1,iatcnt                                      MULT082
                  ikeep=3                                               MULT083
                  do 2002 ik=1,3                                        MULT084
c                    write(*,*) abs(xyz(ik)-st(ia,ii,ik))*cel(ik)       MULT085
                     if(abs(xyz(ik)-ucell(ii,ik))*cel(ik).lt.0.1)then   MULT086
                        ikeep=ikeep-1                                   MULT087
                      end if                                            MULT088
 2002             continue                                              MULT089
                  if (ikeep.eq.0) goto 2003                             MULT090
 2001          continue                                                 MULT091
                                                                        MULT092
c ---          if atom needs to be kept, store it and increment counter MULT093
               iatcnt=iatcnt+1                                          MULT094
c ---          warn if iatcnt exceeds istor ---                         MULT095
               if (iatcnt.gt.istor) then                                MULT096
                  write(*,'(a/a,i5/a)')'  ****WARNING****',             MULT097
     &            ' Unit cell contains too many atoms :',istor,         MULT098
     &            ' You need to increase parameter ISTOR '              MULT099
                   pause                                                MULT100
               end if                                                   MULT101
               do 2004 ik=1,3                                           MULT102
                  ucell(iatcnt,ik)=xyz(ik)                              MULT103
 2004          continue                                                 MULT104
               ucell(iatcnt,4)=isymop                                   MULT105
               ucell(iatcnt,5)=ia                                       MULT106
c ---          maintenance only --                                      MULT107
c              write(*,'(a,i3,a,f4.1,a,3f5.3),a,i3')                    MULT108
c     &     ' np=',j,'anti=',anti,'tsb(i)=',(tsb(i),i=1,3),             MULT109
c     &     ' sym=',isymop                                              MULT110
                                                                        MULT111
c ---          goto here if atom not to be kept                         MULT112
 2003          continue                                                 MULT113
                                                                        MULT114
c ---          calculate number imult of coinciding atoms               MULT115
               dif=0.0                                                  MULT116
               do 0005 k=1,3                                            MULT117
                  difi=abs(xyz(k)-xyz1(k))*cel(k)                       MULT118
                  dif=dif+difi                                          MULT119
 0005          continue                                                 MULT120
                                                                        MULT121
c ---          imult counts how many coincidences (not multiplicity)    MULT122
               if (dif.lt.0.001) then                                   MULT123
                  imult(ia)=imult(ia)+1                                 MULT124
               else                                                     MULT125
                  if (dif.lt.0.1) iwarn(ia)=3                           MULT126
               end if                                                   MULT127
                                                                        MULT128
c ---          check for centrosymmetry                                 MULT129
               if (isymce.ne.1) go to 0004                              MULT130
               if (anti.eq.-1.) go to 0004                              MULT131
               anti=-1.0                                                MULT132
               go to 0002                                               MULT133
 0004    continue                                                       MULT134
         if (imult(ia).eq.0) then                                       MULT135
            write (*,'(a,i3)')' WARNING - bad multiplicity for atom ',iaMULT136
         else                                                           MULT137
c ---       now imult is converted into true multiplicity --            MULT138
            imult(ia)=igen/imult(ia)                                    MULT139
         end if                                                         MULT140
c         pause                                                         MULT141
 0006 continue                                                          MULT142
      return                                                            MULT143
      end                                                               MULT144
