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