      subroutine priver (nshell,ish,ia,elemt,ide,did,icomp,iat,iclust,  PRIV001
     &  idim,ims,lv,pm,igeom,geom,igeo,omit,ialsym,ipower,icharg,charge,PRIV002
     &  foc)                                                            PRIV003
c ----------------------------------------------------------------------PRIV004
c     PRIVER prints vertex coordinate table for each coordination shell PRIV005
c ----------------------------------------------------------------------PRIV006
c     is : pointer to did locating begin of a shell                     PRIV007
c     ish(ims): coordination number of shells, ims=max number of shells PRIV008
c     structure of did(istor,8) :                                       PRIV009
c     did (i,1-3) :  x,y,z-fractional coordinate                        PRIV010
c     did(i,4) : distance of this point to cluster centre               PRIV011
c     did(i,5) : flag containing atom kind                              PRIV012
c     did(i,6-8) : cartesian coordinates                                PRIV013
c     did(1,j) : atom data for shell centre                             PRIV014
c     iang : number of different angles in a shell coordination         PRIV015
c                                                                       PRIV016
c     revision 5.0 : hands foc to praxis for p-axis caclulation         PRIV017
c                                                                       PRIV018
c     revision 4.1 : does principal axis transformation (PAT) in sub-   PRIV019
c     routine praxis v=normalized eigenvectors, d=eigenvalues           PRIV020
c ----------------------------------------------------------------------PRIV021
c     This program module is part of the author's X-ray Library         PRIV022
c     and may not be sold or reproduced for commercial purposes.        PRIV023
c     Although it has been tested carefully, there is no warranty       PRIV024
c     regarding accuracy or freedom from side-effects.                  PRIV025
c                   (C) 1986-1994 Bernhard Rupp                         PRIV026
c ----------------------------------------------------------------------PRIV027
      parameter (ipr=7,ipx=7,iamax=1275,isubsh=48)                      PRIV028
                                                                        PRIV029
      character elemt*2,ide*4,fms*29,form1*9,form2*11,form3*5           PRIV030
      character fms2*37,fmt1*15,fmt2*14,fmt3*5,fmt4*11,fms3*33          PRIV031
      character fmt5*10,fmt6*4,fms4*31,fmt7*8,pm,icomp*4,lv,geom*25     PRIV032
      integer*2 ialsym(iclust*10,4)                                     PRIV033
      real v(3,3),d(3),omit                                             PRIV034
      dimension elemt(iat),ide(iat),xo(3),x1(3),x2(3),did(iclust,idim)  PRIV035
      dimension an(iamax),ish(ims),iss2(isubsh),geom(igeo),igeom(ims)   PRIV036
      dimension iap(iamax,3),ivec(2,8),x0(3),charge(iat),foc(iat)       PRIV037
                                                                        PRIV038
c --- prepare for runtime format                                        PRIV039
      form1='(1x,a1,a,'                                                 PRIV040
      form2='(a2,a4,a2),'                                               PRIV041
      form3='x,a1)'                                                     PRIV042
      fmt1='(1x,a1, f8.3,a,'                                            PRIV043
      fmt2='(1x,i2,a1,i2),'                                             PRIV044
      fmt3='x,a1)'                                                      PRIV045
      fmt4='(1x,a1,26x,'                                                PRIV046
      fmt5='(1x,a1,a,i'                                                 PRIV047
      fmt6=',a,i'                                                       PRIV048
      fmt7=',a,a1,a,'

      istart=2                                                          PRIV051
c --- loop over all shells                                              PRIV052
      do 0002 i=1,nshell                                                PRIV053
c ---   print only if distance less than dprt --                        PRIV054
         if(did(istart,4).gt.omit) return                               PRIV055
c ---    retrive origin of cluster in cart.coord for angle calc.        PRIV056
         do 2015 j=1,3                                                  PRIV057
            x0(j)=did(1,j)                                              PRIV058
            xo(j)=did(1,j+5)                                            PRIV059
 2015    continue                                                       PRIV060
c ---    reset subshell flag is                                         PRIV061
         is=1                                                           PRIV062
c        reset subshell flag for each non-equiv atom                    PRIV063
         do 2000 j=1,isubsh                                             PRIV064
            iss2(j)=0                                                   PRIV065
 2000    continue                                                       PRIV066
c ---    look, how many different atoms in shell                        PRIV067
         do 2001 j=istart,istart+ish(i)-2                               PRIV068
            iss2(is)=did(j,5)                                           PRIV069
            if (did(j,5).ne.did(j+1,5)) then                            PRIV070
c ---          increment subshell counter --                            PRIV071
               is=is+1                                                  PRIV072
c              is is the number of subshells                            PRIV073
               iss2(is)=did(j+1,5)                                      PRIV074
c              set the flag for the is subshell to the non-equiv atom j PRIV075
            end if                                                      PRIV076
 2001    continue                                                       PRIV077
                                                                        PRIV078
c ---    SEXIE table header out ---                                     PRIV079
         do 2019 iii=ipr,ipx                                            PRIV080
            call frames (iii,1,icomp)                                   PRIV081
            write (iii,'(1x,a1,a,i3,a,a2,1x,a4,3(1x,f5.3),a,3f6.3,1x,a1)PRIV082
     &          ') lv,'Shell',i,': Central atom ',elemt(ia),ide(ia),    PRIV083
     &          (x0(j),j=1,3),',  cartes.',(xo(j),j=1,3),lv             PRIV084
c           in case of subshell -----                                   PRIV085
            if (is.gt.1) then                                           PRIV086
               write (iii,'(1x,a1,a,i3,a,i3,a,41x,a1)')                 PRIV087
     &         lv,'Coordination number',ish(i),',',is,' subshells',lv   PRIV088
            else                                                        PRIV089
               write (iii,'(1x,a1,a,i3,a,42x,a1)')                      PRIV090
     &         lv,'Coordination number',ish(i),', no subshell',lv       PRIV091
            end if                                                      PRIV092
 2019    continue                                                       PRIV093
                                                                        PRIV094
         iloc=1                                                         PRIV095
c ---    do the principal axis transformation to find local symmetry -- PRIV096
         if (iloc.ge.1) then                                            PRIV097
            iend=istart+ish(i)-1                                        PRIV098
c ---       v is normalized eigenvector, d is eigenvalues of PAT --     PRIV099
            call praxis(did,iclust,idim,istart,iend,v,d,ipower,icharg,  PRIV100
     &                   iat,charge,foc)                                PRIV101
         end if                                                         PRIV102
                                                                        PRIV103
c ---    generate runtime format --                                     PRIV104
         ix=is                                                          PRIV105
c ---    for some reason, this cretin of a compiler forgets what form1  PRIV106
c        and form2 are......                                            PRIV107
         form1='(1x,a1,a,'                                              PRIV108
         form2='(a2,a4,a2),'                                            PRIV109
         if (is.gt.7) ix=7                                              PRIV110
         write(fms,'(a9,i2,a11,i2,a5)') form1,ix,form2,61-8*ix,form3    PRIV111
         ik=igeom(i)                                                    PRIV112
         do 2029 iii=ipr,ipx                                            PRIV113
            write(iii,fms) lv,'Shell atom(s) : ',                       PRIV114
     &           (elemt(iss2(j)),ide(iss2(j)),'; ',j=1,ix),lv           PRIV115
c ---       presumed geometry ---                                       PRIV116
            write(iii,'(1x,a1,a,a25,25x,a1)') lv,                       PRIV117
     &      'Possible ligand geometry : ',geom(ik),lv                   PRIV118
            call frames(iii,2,icomp)                                    PRIV119
c ---       print a line with eigenvectors and eigenvalues of PAT       PRIV120
            if(iloc.ge.1) then                                          PRIV121
          write(iii,'(1x,a1,1x,a,a1)') lv,                              PRIV122
     &    'Normalized Eigenvectors followed by Eigenvalues of Principal PRIV123
     &Axis Transform.',lv                                               PRIV124
          write(iii,'(1x,a1,1x,a,i1,$)') lv,                            PRIV125
     &    'Order of crystal field term : ',ipower                       PRIV126
          if (icharg.eq.0) then                                         PRIV127
             write(iii,'(a,a1)')                                        PRIV128
     &        ', no ligand charges considered (charge(n)=1) ',lv        PRIV129
          else                                                          PRIV130
             write(iii,'(a,i1,a1)')                                     PRIV131
     &        ', ligand charges were applied  = charge(n)**',icharg,lv  PRIV132
          end if                                                        PRIV133
            call frames(iii,2,icomp)                                    PRIV134
          write(iii,'(1x,a1,a1,3f5.2,a3,3f5.2,a3,3f5.2,a2,3f7.3,2x,a1)')PRIV135
     &    lv,'(',(v(j,1),j=1,3),'),(',(v(j,2),j=1,3),'),(',             PRIV136
     &    (v(j,3),j=1,3),'),',(d(j),j=1,3),lv                           PRIV137
              call frames(iii,2,icomp)                                  PRIV138
            end if                                                      PRIV139
c ---       header line for ligand table ---                            PRIV140
            write(iii,'(1x,a1,a,a,a1)') lv,                             PRIV141
     &      'Ligand    Sym. Trans. Fractional coordinates  Cartesian ', PRIV142
     &      'coordinates  Distance',lv                                  PRIV143
            write(iii,'(1x,a1,a,a,a1)') lv,                             PRIV144
     &     ' Nr  Atom Oper. Vect.    X       Y       Z       x      y ',PRIV145
     &      '     z       A - B ',lv                                    PRIV146
            call frames(iii,2,icomp)                                    PRIV147
 2029    continue                                                       PRIV148
                                                                        PRIV149
c ---    print shell table for SEXIE.out ------------                   PRIV150
         k=1                                                            PRIV151
         do 2002 j=istart,istart+ish(i)-1                               PRIV152
            i2= int(did(j,5))                                           PRIV153
            isy=int(did(j,9))                                           PRIV154
            do 2039 iii=ipr,ipx                                         PRIV155
c            write(iii,'(1x,a1,i3,1x,a2,a4,a1,a2,a4,2x,2x,3(f7.3),1x,   PRIV156
c     &      3(f8.3),f9.4,1x,a1)')lv,k,elemt(ia),ide(ia),'-',elemt(i2), PRIV157
c     &      ide(i2),(did(j,l),l=1,3),(did(j,l+5),l=1,3),               PRIV158
c     &      did(j,4),lv                                                PRIV159
            write(iii,'(1x,a1,i3,1x,a2,a4,1x,i3,1x,3i2,3(f7.3),1x,      PRIV160
     &      3(f8.3),f9.4,1x,a1)')lv,k,elemt(i2),ide(i2),ialsym(isy,4),  PRIV161
     &      (ialsym(isy,jk),jk=1,3),(did(j,l),l=1,3),(did(j,l+5),l=1,3),PRIV162
     &      did(j,4),lv                                                 PRIV163
 2039       continue                                                    PRIV164
            k=k+1                                                       PRIV165
 2002    continue                                                       PRIV166
                                                                        PRIV167
         do 2049 iii=ipr,ipx                                            PRIV168
            if (ish(i).lt.2) then                                       PRIV169
               call frames (iii,3,icomp)                                PRIV170
               goto 8000                                                PRIV171
            end if                                                      PRIV172
            call frames(iii,2,icomp)                                    PRIV173
 2049    continue                                                       PRIV174
c ---    permutate points for angles --                                 PRIV175
         iang=1                                                         PRIV176
         ian=1                                                          PRIV177
         iover=0                                                        PRIV178
         an(1)=0.0                                                      PRIV179
         do 4002 j=0,ish(i)-1                                           PRIV180
            do 4003, k=j+1,ish(i)-1                                     PRIV181
               do 4004 l=1,3                                            PRIV182
                  x1(l)=did(istart+j,l+5)                               PRIV183
                  x2(l)=did(istart+k,l+5)                               PRIV184
 4004          continue                                                 PRIV185
               call vecang(xo,x1,xo,x2,ang)                             PRIV186
               do 6003 i1=1,ian                                         PRIV187
                  if (abs(ang-an(i1)).lt.0.1) then                      PRIV188
                     iap(iang,3)=i1                                     PRIV189
                     goto 6333                                          PRIV190
                  end if                                                PRIV191
 6003          continue                                                 PRIV192
               an(ian)=ang                                              PRIV193
               iap(iang,3)=ian                                          PRIV194
               if(ian.ge.iamax) goto 6999                               PRIV195
               ian=ian+1                                                PRIV196
 6333          continue                                                 PRIV197
               iap(iang,1)=j+1                                          PRIV198
               iap(iang,2)=k+1                                          PRIV199
               if (iang.ge.iamax) then                                  PRIV200
                  iover=1                                               PRIV201
                  goto 6999                                             PRIV202
               end if                                                   PRIV203
               iang=iang+1                                              PRIV204
 4003       continue                                                    PRIV205
 4002    continue                                                       PRIV206
 6999    continue                                                       PRIV207
         iang=iang-1                                                    PRIV208
         ian=ian-1                                                      PRIV209
                                                                        PRIV210
c ---    tabular list of angles --                                      PRIV211
         izap=int(ilog10(iang))+1                                       PRIV212
         izok=int(ilog10(ian))+1                                        PRIV213
         irip=13-izok-izap                                              PRIV214
                                                                        PRIV215
c ---    Uahhhh - 3.30 am syndrom - rip zok zap - rap it to the beat    PRIV216
         write(fms4,'(a10,i1,a4,i1,a8,i2,a5)')                          PRIV217
     &         fmt5,izap,fmt6,izok,fmt7,irip,form3                      PRIV218
         do 2059 iii=ipr,ipx                                            PRIV219
            write(iii,fms4) lv,                                         PRIV220
     &      'Total of ',iang,' calculated angles in ',ian,              PRIV221
     &      ' equivalent set(s) (',pm,' 0.1 deg) : ',lv                 PRIV222
            call frames(iii,2,icomp)                                    PRIV223
 2059    continue                                                       PRIV224
c ---    now, crank out angles table for output --                      PRIV225
         do 5001 j=1,ian                                                PRIV226
            jmp=0                                                       PRIV227
            il=1                                                        PRIV228
            do 5002 k=1,iang                                            PRIV229
               if (iap(k,3).eq.j.or.k.eq.iang) then                     PRIV230
                  if (iap(k,3).eq.j) then                               PRIV231
                     jmp=jmp+1                                          PRIV232
                     ivec(1,jmp-(il-1)*8)=iap(k,1)                      PRIV233
                     ivec(2,jmp-(il-1)*8)=iap(k,2)                      PRIV234
                  end if                                                PRIV235
                  if ((il.eq.1).and.(jmp.eq.8.or.k.eq.iang)) then       PRIV236
c ---                print first line --                                PRIV237
                     write(fms2,'(a15,i1,a14,i2,a5)')                   PRIV238
     &                     fmt1,jmp,fmt2,(8-jmp)*6+3,fmt3               PRIV239
                     do 2069 iii=ipr,ipx                                PRIV240
                        write(iii,fms2) lv,an(j),' between Vectors: ',  PRIV241
     &                  (ivec(1,l),'-',ivec(2,l),l=1,jmp),lv            PRIV242
 2069                continue                                           PRIV243
                     if (k.eq.iang) goto 5501                           PRIV244
                     il=il+1                                            PRIV245
                  elseif (mod(jmp,8).eq.0.or.k.eq.iang) then            PRIV246
c ---                any second line --                                 PRIV247
                     izap=jmp-(il-1)*8                                  PRIV248
                     if (izap.eq.0) goto 5501                           PRIV249
                     write(fms3,'(a11,i1,a14,i2,a5)')                   PRIV250
     &                     fmt4,izap,fmt2,(8-izap)*6+3,fmt3             PRIV251
                     do 2079 iii=ipr,ipx                                PRIV252
                        write(iii,fms3) lv,                             PRIV253
     &                  (ivec(1,l),'-',ivec(2,l),l=1,izap),lv           PRIV254
 2079                continue                                           PRIV255
                     if (k.eq.iang) goto 5501                           PRIV256
                     il=il+1                                            PRIV257
                  end if                                                PRIV258
               end if                                                   PRIV259
 5002       continue                                                    PRIV260
 5501       continue                                                    PRIV261
 5001    continue                                                       PRIV262
         do 2089 iii=ipr,ipx                                            PRIV263
            call frames(iii,3,icomp)                                    PRIV264
 2089    continue                                                       PRIV265
 8000    continue                                                       PRIV266
         do 2099 iii=ipr,ipx                                            PRIV267
            if (is.gt.ix) write(iii,'(/a,a/)')' List of subshell atoms' PRIV268
     &         ,' on top is incomplete due to format restrictions'      PRIV269
            if (iover.eq.1) write(iii,'(/a,a/)')' List of angles ',     PRIV270
     &         'is incomplete  - too many atoms (>48) in shell'         PRIV271
            istart=istart+ish(i)                                        PRIV272
 2099    continue                                                       PRIV273
 0002 continue                                                          PRIV274
      return                                                            PRIV275
      end                                                               PRIV276
