      subroutine shelgr (condis,conang,itot,did,elemt,ide,isearc,       SHEL001
     &           ia2,ish,dist,nshell,isub,ibook,icomp)                  SHEL002
c ----------------------------------------------------------------------SHEL003
c     group into shells and search for possible coordination            SHEL004
c ----------------------------------------------------------------------SHEL005
c     This program module is part of the PhysiSoft X-ray Library        SHEL006
c     and may not be sold or reproduced for commercial purposes.        SHEL007
c     Although it has been tested carefully, there is no warranty       SHEL008
c     regarding accuracy or freedom from side-effects.                  SHEL009
c                   (C) 1986-1990 Bernhard Rupp                         SHEL010
c ----------------------------------------------------------------------SHEL011
      parameter (iat=20,istor=2500,icr=40,ims=100,ipr=6,imaxl=12)       SHEL012
      character elemt*2,ide*4,star*2,cor*25,star2*3,lv,an,de,pm,icomp*4 SHEL013
      dimension elemt(iat),ide(iat),did(istor,8),cor(icr),ish(ims)      SHEL014
      dimension dist(ims),isub(ims,iat),isas(ims),dis(iat)              SHEL015
                                                                        SHEL016
      data (cor(i),i=1,icr)/                                            SHEL017
     & 'one other atom','linear','general twofold',                     SHEL018
     & 'planar triangle','regular triangle','general trifold',          SHEL019
     & 'tetrahedral','quadratic planar','plane rectangle',              SHEL020
     & 'planar fourfold','general fourfold',                            SHEL021
     & 'planar fivefold','general fivefold',                            SHEL022
     & 'regular hexagon','planar sixfold','octahedral',                 SHEL023
     & 'distorted octahedral','trigonal prism',                         SHEL024
     & 'trigonal antiprism','general sixfold','planar eightfold',       SHEL025
     & 'cubic','quadratic prism','quadratic antiprism',                 SHEL026
     & 'general prism','general antiprism','general eightfold',         SHEL027
     & 'simple cuboctahedron','reg. hexagonal prism','irreg. hex. prism'SHEL028
     & ,'truncated tetrahedron','doubly trnctd tetrahedron',            SHEL029
     & 'hexa-cuboctahedron', 'edge truncated cube',                     SHEL030
     & 'trnctd cube + octahedron','edge trnctd cube + cube',            SHEL031
     & 'doubly truncated cube','planar','no special name','    -N/A- '/ SHEL032
                                                                        SHEL033
      if (icomp.eq.'IBM ') then                                         SHEL034
         lv=char(179)                                                   SHEL035
         an=char(143)                                                   SHEL036
         de=char(248)                                                   SHEL037
         pm=char(241)                                                   SHEL038
      elseif (icomp.eq.'VAX ') then                                     SHEL039
         lv=char(124)                                                   SHEL040
         an=char(197)                                                   SHEL041
         de=char(176)                                                   SHEL042
         pm=char(177)                                                   SHEL043
      else                                                              SHEL044
         lv='|'                                                         SHEL045
         an='A'                                                         SHEL046
         de=' '                                                         SHEL047
         pm=' '                                                         SHEL048
      end if                                                            SHEL049
                                                                        SHEL050
c --- write shell table header                                          SHEL051
      do 2019 i=ipr,ipr+1                                               SHEL052
         if ((ia2.eq.1).and.(ibook.eq.1)) then                          SHEL053
             call frames (i,2,icomp)                                    SHEL054
         else                                                           SHEL055
             call frames (i,1,icomp)                                    SHEL056
         end if                                                         SHEL057
         write(i,'(1x,a1,a,a2,1x,a4,18x,a1)') lv,                       SHEL058
     &   ' Listing of coordination shells around central atom ',        SHEL059
     &   elemt(ia2),ide(ia2),lv                                         SHEL060
         call frames (i,2,icomp)                                        SHEL061
         write(i,'(1x,a1,a,a,3x,a1)') lv,                               SHEL062
     &   ' Shell     Vector      Coord.Nr.     Distance    ',           SHEL063
     &   '   Coordination Geometry ',lv                                 SHEL064
         call frames (i,2,icomp)                                        SHEL065
 2019 continue                                                          SHEL066
                                                                        SHEL067
c --- reset the pointers                                                SHEL068
      do 0001 i=1,ims                                                   SHEL069
         isas(i)=0                                                      SHEL070
         ish(i)=0                                                       SHEL071
         do 0001 j=1,iat                                                SHEL072
            isub(i,j)=0                                                 SHEL073
 0001 continue                                                          SHEL074
      do 3003 j=1,iat                                                   SHEL075
         dis(j)=0                                                       SHEL076
 3003 continue                                                          SHEL077
                                                                        SHEL078
c --- group into shells                                                 SHEL079
      ishell=1                                                          SHEL080
      nshell=1                                                          SHEL081
      star='*)'                                                         SHEL082
      itilt=0                                                           SHEL083
      isasu=0                                                           SHEL084
      do 1010 i=3,itot                                                  SHEL085
c ---    sort in subshells --                                           SHEL086
         star2='   '                                                    SHEL087
c ---    stop after imaxl shells only for special case for textbook --  SHEL088
         if ((ibook.eq.1.).and.(nshell.gt.imaxl)) then                  SHEL089
             goto 1010                                                  SHEL090
         end if                                                         SHEL091
         ix1=did(i-1,5)                                                 SHEL092
         isub(nshell,ix1)=isub(nshell,ix1)+1                            SHEL093
         dis(ix1)=did(i-1,4)                                            SHEL094
c ---    if difference larger than shell range, print new shell -       SHEL095
         if (abs(did(i,4)-did(i-1,4)).gt.condis) then                   SHEL096
            diff=did(i,4)-did(i-1,4)                                    SHEL097
c ---       warning, if shells are too close --                         SHEL098
            if (diff.lt.0.03) then                                      SHEL099
                star2='**)'                                             SHEL100
                itilt=1                                                 SHEL101
            end if                                                      SHEL102
c ---       start coordination geometry search --                       SHEL103
            if (isearc.eq.1) then                                       SHEL104
               call poscor(i,ishell,did,ipoly,conang,icr)               SHEL105
            else                                                        SHEL106
               ipoly=icr                                                SHEL107
            end if                                                      SHEL108
            do 2029 k=ipr,ipr+1                                         SHEL109
c ---       write single shell output ---                               SHEL110
            if (isas(nshell).eq.0) then                                 SHEL111
               write(k,'(1x,a1,1x,i3,3x,a2,1x,a4,a3,a2,1x,a4,1x,i4,a3,  SHEL112
     &              3x,f9.4,                                            SHEL113
     &                   8x,a,a1)')lv, nshell,elemt(ia2),ide(ia2),      SHEL114
     &         '-  ',elemt(did(i-1,5)),ide(did(i-1,5)),ishell,star2,    SHEL115
     &         did(i-1,4),cor(ipoly),lv                                 SHEL116
            else                                                        SHEL117
c ---       write modified output with subshells --                     SHEL118
               do 2002 j=1,iat                                          SHEL119
               if (isub(nshell,j).ne.0) then                            SHEL120
                 write(k,'(1x,a1,1x,i3,3x,a2,1x,a4,a3,a2,1x,a4,1x,i4,a2,SHEL121
     &                   4x,f9.4,                                       SHEL122
     &                      9x,24x,a1)') lv,                            SHEL123
     &            nshell,elemt(ia2),ide(ia2),'-  ',elemt(j),            SHEL124
     &            ide(j),isub(nshell,j),star,dis(j),lv                  SHEL125
               end if                                                   SHEL126
 2002          continue                                                 SHEL127
               write(k,'(1x,a1,1x,i3,3x,a,i4,a3,20x,a,a1)')             SHEL128
     &                lv, nshell,'Total coordination'                   SHEL129
     &               ,ishell,star2,cor(ipoly),lv                        SHEL130
            end if                                                      SHEL131
 2029       continue                                                    SHEL132
            dist(nshell)=did(i-1,4)                                     SHEL133
            ish(nshell)=ishell                                          SHEL134
            nshell=nshell+1                                             SHEL135
            ishell=1                                                    SHEL136
            do 3004 j=1,iat                                             SHEL137
               dis(j)=0                                                 SHEL138
 3004       continue                                                    SHEL139
         else                                                           SHEL140
            if (did(i-1,5).ne.did(i,5)) then                            SHEL141
               isas(nshell)=isas(nshell)+1                              SHEL142
               isasu=1                                                  SHEL143
            end if                                                      SHEL144
            ishell=ishell+1                                             SHEL145
         end if                                                         SHEL146
         if (nshell.gt.ims) goto 1019                                   SHEL147
 1010 continue                                                          SHEL148
                                                                        SHEL149
 1019 nshell=nshell-1                                                   SHEL150
                                                                        SHEL151
      do 2039 k=ipr,ipr+1                                               SHEL152
         if (isasu.gt.0.or.itilt.eq.1) then                             SHEL153
            call frames (k,2,icomp)                                     SHEL154
            if (isasu.gt.0) write (k,'(1x,a1,a,a,12x,a1)') lv,          SHEL155
     &      ' *)  subshell (more than one atom kind contributes to ',   SHEL156
     &      'this shell)',lv                                            SHEL157
            if (itilt.eq.1)  write (k,'(1x,a1,a,30x,a1)') lv,           SHEL158
     &      ' **) possible coincidence with following shell ',lv        SHEL159
         end if                                                         SHEL160
         call frames (k,3,icomp)                                        SHEL161
 2039 continue                                                          SHEL162
      if (ibook.eq.0) then                                              SHEL163
      if (nshell.ge.ims) then                                           SHEL164
         write (ipr,'(/a,i3,a/)') '  Shell grouping stopped after ',    SHEL165
     &                             ims,' shells.  Continuing.'          SHEL166
      end if                                                            SHEL167
       write (ipr,'(/a,a/)') '  Full listing of vertices is written to',SHEL168
     &                      ' output file'                              SHEL169
       write (ipr+1,'(/a,a/)')'  Full listing of vertex coordinates ',  SHEL170
     &                      'and angles follows '                       SHEL171
       end if                                                           SHEL172
                                                                        SHEL173
      return                                                            SHEL174
      end                                                               SHEL175
