      subroutine priver (nshell,ish,ia2,elemt,ide,did,isub,icomp,t,igr, PRIV001
     &                   ispa)                                          PRIV002
c ----------------------------------------------------------------------PRIV003
c     prints vertex coordinate table for each coordination shell        PRIV004
c ----------------------------------------------------------------------PRIV005
c     is : pointer to did locating begin of a shell                     PRIV006
c     ish(ims): coordination number of shells, ims=max number of shells PRIV007
c     structure of did(istor,8) :                                       PRIV008
c     did (i,1-3) :  x,y,z-fractional coordinate                        PRIV009
c     did(i,4) : distance of this point to cluster centre               PRIV010
c     did(i,5) : flag containing atom kind                              PRIV011
c     did(i,6-8) : cartesian coordinates                                PRIV012
c     did(1,j) : atom data for shell centre                             PRIV013
c     iang : number of different angles in a shell coordination         PRIV014
c ----------------------------------------------------------------------PRIV015
c     This program module is part of the PhysiSoft X-ray Library        PRIV016
c     and may not be sold or reproduced for commercial purposes.        PRIV017
c     Although it has been tested carefully, there is no warranty       PRIV018
c     regarding accuracy or freedom from side-effects.                  PRIV019
c     (C) 1986-1994 Bernhard Rupp and Anne Tabor-Morris                 PRIV020
c ----------------------------------------------------------------------PRIV021
c     SPECIAL NOTICE for FEFF users :                                   PRIV022
c     FEFF sections of the code are correspondingly commented and any   PRIV023
c     modifications should be easy, in fact.                            PRIV024
c     Anne - Tabor Morris, 1994                                         PRIV025
c ----------------------------------------------------------------------PRIV026
      parameter (iat=20,istor=2500,ims=100,ipr=7,ipx=7,iamax=1275)      PRIV027
c ----------------------------------------------------------------------PRIV028
                                                                        PRIV029
      character elemt*2,ide*4,lv,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,plumi,icomp*4,t*60        PRIV032
      dimension elemt(iat),ide(iat),xo(3),x1(3),x2(3),did(istor,8)      PRIV033
      dimension an(iamax),ish(ims),iss2(iat)                            PRIV034
      dimension iap(iamax,3),isub(ims,iat),iss(iat),ivec(2,8),x0(3)     PRIV035
      integer   igr(36)                                                 PRIV036
                                                                        PRIV037
      if (icomp.eq.'IBM ') then                                         PRIV038
         lv=char(179)                                                   PRIV039
         plumi=char(241)                                                PRIV040
      elseif (icomp.eq.'VAX ') then                                     PRIV041
         lv='|'                                                         PRIV042
         plumi=char(177)                                                PRIV043
      else                                                              PRIV044
         lv='|'                                                         PRIV045
         plumi=' '                                                      PRIV046
      end if                                                            PRIV047
                                                                        PRIV048
c --- FEFF- open file containing the FEFF data in overwrite mode --     PRIV049
      open (3,file='infeff.xyz',status='unknown')                       PRIV050
      write(3,*) 'File infeff.xyz - Version 1.1 (for FEFF5)'            PRIV051
      write(3,*) t                                                      PRIV052
      write (3,'(a,i3,a,12a1)') ' Space group Nr. ',ispa,' : ',         PRIV053
     &                          (igr(i),i=1,12)                         PRIV054
                                                                        PRIV055
c --- first shell, central atom located at 0, 0, 0, distance 0  --      PRIV056
      write(3,*)'SHELL           0 '                                    PRIV057
      write(3,*)'# atoms in shell, x,y,z, dist, element, atomic #'      PRIV058
      write(3,*)'1'                                                     PRIV059
      do 888 j=1,4                                                      PRIV060
888      write(3,*) 0.0                                                 PRIV061
                                                                        PRIV062
      call upstrg (elemt(ia2),2)                                        PRIV063
      iz=ielect (elemt(ia2))                                            PRIV064
      call makels(elemt(ia2))                                           PRIV065
      write(3,'(1x,a2,1x,a4)') elemt(ia2), ide(ia2)                     PRIV066
      write(3,*) iz                                                     PRIV067
c     make the element symbol mixed case again                          PRIV068
                                                                        PRIV069
c --- end FEFF first part -------------------------                     PRIV070
                                                                        PRIV071
c --- prepare for runtime format                                        PRIV072
      form1='(1x,a1,a,'                                                 PRIV073
      form2='(a2,a4,a2),'                                               PRIV074
      form3='x,a1)'                                                     PRIV075
      fmt1='(1x,a1, f8.3,a,'                                            PRIV076
      fmt2='(1x,i2,a1,i2),'                                             PRIV077
      fmt3='x,a1)'                                                      PRIV078
      fmt4='(1x,a1,26x,'                                                PRIV079
      fmt5='(1x,a1,a,i'                                                 PRIV080
      fmt6=',a,i'                                                       PRIV081
      fmt7=',a,a1,a,'                                                   PRIV082
                                                                        PRIV083
      istart=2                                                          PRIV084
c     isnr is INFEFF shell counter (subshells split into extra shells   PRIV085
      isnr = 0                                                          PRIV086
                                                                        PRIV087
c --- loop over all shells                                              PRIV088
      do 9000 i=1,nshell                                                PRIV089
c        reset subshell flag is                                         PRIV090
         is=0                                                           PRIV091
c        reset subshell flag for each non-equiv atom                    PRIV092
         do 2000 j=1,iat                                                PRIV093
            iss(j)=0                                                    PRIV094
            iss2(j)=0                                                   PRIV095
 2000    continue                                                       PRIV096
                                                                        PRIV097
c ---    retrive origin of cluster in cart.coord for angle calc.        PRIV098
         do 2015 j=1,3                                                  PRIV099
            x0(j)=did(1,j)                                              PRIV100
            xo(j)=did(1,j+5)                                            PRIV101
 2015    continue                                                       PRIV102
c ---    look, how many different atoms in shell                        PRIV103
         do 2001 j=1,iat                                                PRIV104
            if (isub(i,j).ne.0) then                                    PRIV105
               is=is+1                                                  PRIV106
c              is is the number of subshells                            PRIV107
               iss2(is)=j                                               PRIV108
c              set the flag for the is subshell to the non-equiv atom j PRIV109
               iss(j)=is                                                PRIV110
c              set the subshell number for the nonequiv. atom j         PRIV111
            end if                                                      PRIV112
 2001    continue                                                       PRIV113
c        if no subshells foud, set subshell counter to one ----         PRIV114
         if (is.eq.0) is=1                                              PRIV115
                                                                        PRIV116
c ---    SEXIE table header out ---                                     PRIV117
         do 2019 iii=ipr,ipx                                            PRIV118
            call frames (iii,1,icomp)                                   PRIV119
            write (iii,'(1x,a1,a,i3,a,a2,1x,a4,3(1x,f5.3),a,3f6.3,1x,a1)PRIV120
     &') lv,'Shell',i,': Central atom ',elemt(ia2),ide(ia2),            PRIV121
     &      (x0(j),j=1,3),',  cartes.',(xo(j),j=1,3),lv                 PRIV122
c           in case of subshell -----                                   PRIV123
            if (is.gt.1) then                                           PRIV124
               write (iii,'(1x,a1,a,i3,a,i3,a,41x,a1)')                 PRIV125
     &         lv,'Coordination number',ish(i),',',is,' subshells',lv   PRIV126
            else                                                        PRIV127
               write (iii,'(1x,a1,a,i3,a,42x,a1)')                      PRIV128
     &         lv,'Coordination number',ish(i),', no subshell',lv       PRIV129
            end if                                                      PRIV130
 2019    continue                                                       PRIV131
                                                                        PRIV132
c ---    generate runtime format --                                     PRIV133
         ix=is                                                          PRIV134
         if (is.gt.7) ix=7                                              PRIV135
         write(fms,'(a9,i2,a11,i2,a5)') form1,ix,form2,61-8*ix,form3    PRIV136
                                                                        PRIV137
         do 2029 iii=ipr,ipx                                            PRIV138
            write(iii,fms) lv,'Shell atom(s) : ',                       PRIV139
     &           (elemt(iss2(j)),ide(iss2(j)),'; ',j=1,ix),lv           PRIV140
            call frames(iii,2,icomp)                                    PRIV141
            write(iii,'(1x,a1,a,a,a1)') lv,                             PRIV142
     &      'Vector A - B    Sub-  Fractional coordinates  Cartesian ', PRIV143
     &      'coordinates  Distance',lv                                  PRIV144
            write(iii,'(1x,a1,a,a,a1)') lv,                             PRIV145
     &     ' Nr  Atom Atom  shell    X       Y       Z       x      y ',PRIV146
     &      '     z       A - B ',lv                                    PRIV147
            call frames(iii,2,icomp)                                    PRIV148
 2029    continue                                                       PRIV149
                                                                        PRIV150
c ---    print shell table for SEXIE.out ------------                   PRIV151
         k=1                                                            PRIV152
         do 2002 j=istart,istart+ish(i)-1                               PRIV153
            i2= int(did(j,5))                                           PRIV154
            if (is.le.1) iss(i2)=1                                      PRIV155
            do 2039 iii=ipr,ipx                                         PRIV156
            write(iii,'(1x,a1,i3,1x,a2,a4,a1,a2,a4,i2,2x,3(f7.3),1x,    PRIV157
     &      3(f8.3),f9.4,1x,a1)')lv,k,elemt(ia2),ide(ia2),'-',elemt(i2),PRIV158
     &      ide(i2),iss(i2),(did(j,l),l=1,3),(did(j,l+5),l=1,3),        PRIV159
     &      did(j,4),lv                                                 PRIV160
 2039       continue                                                    PRIV161
            k=k+1                                                       PRIV162
 2002    continue                                                       PRIV163
                                                                        PRIV164
c ---    FEFF requires special treatment of subshells -----             PRIV165
         do 3001 iis=1,is                                               PRIV166
           isnr=isnr+1                                                  PRIV167
           write(3,*) 'SHELL',isnr                                      PRIV168
           write(3,*) '# atoms in shell, x,y,z, dist, element, atomic #'PRIV169
c          determine isubsh the number of atoms in iis subshell         PRIV170
           isubsh=0                                                     PRIV171
           do 3002 j=istart,istart+ish(i)-1                             PRIV172
              i2 = int(did(j,5))                                        PRIV173
              if (i2.eq.iss2(iis)) isubsh=isubsh+1                      PRIV174
c             write(*,'(a,i3,a,i3,a,i3)')                               PRIV175
c    &         ' i2=',i2,', iss2(iis)=',iss2(iis),', isubsh=',isubsh    PRIV176
 3002      continue                                                     PRIV177
c          now we know how many of one kind in subshell                 PRIV178
           write(3,*) isubsh                                            PRIV179
c ---      retrieve the coordinates from did and subtract centre atom --PRIV180
           k=1                                                          PRIV181
           do 3003 j=istart,istart+ish(i)-1                             PRIV182
c ---      xyz coordinates                                              PRIV183
              i2= int(did(j,5))                                         PRIV184
c             write distance only when atom label matches ---           PRIV185
              if (i2.eq.iss2(iis)) then                                 PRIV186
                 do 3004 m=1,3                                          PRIV187
                    write (3,*) did(j,m+5)-did(1,m+5)                   PRIV188
c                   keep distance, if a hit                             PRIV189
                    shelld=did(j,4)                                     PRIV190
 3004            continue                                               PRIV191
              end if                                                    PRIV192
 3003      continue                                                     PRIV193
c          write shell distance, element type and z --                  PRIV194
           write(3,*) shelld                                            PRIV195
           i22= iss2(iis)                                               PRIV196
           call upstrg (elemt(i22),2)                                   PRIV197
           iz=ielect (elemt(i22))                                       PRIV198
           call makels(elemt(i22))                                      PRIV199
           write(3,'(1x,a2,1x,a4)')  elemt(i22), ide(i22)               PRIV200
           write(3,*)  iz                                               PRIV201
c ---      end FEFF -----------------------------------------           PRIV202
 3001    continue                                                       PRIV203
                                                                        PRIV204
         do 2049 iii=ipr,ipx                                            PRIV205
            if (ish(i).lt.2) then                                       PRIV206
               call frames (iii,3,icomp)                                PRIV207
               goto 8000                                                PRIV208
            end if                                                      PRIV209
            call frames(iii,2,icomp)                                    PRIV210
 2049    continue                                                       PRIV211
c ---    permutate points for angles --                                 PRIV212
         iang=1                                                         PRIV213
         ian=1                                                          PRIV214
         iover=0                                                        PRIV215
         an(1)=0.0                                                      PRIV216
         do 4002 j=0,ish(i)-1                                           PRIV217
            do 4003, k=j+1,ish(i)-1                                     PRIV218
               do 4004 l=1,3                                            PRIV219
                  x1(l)=did(istart+j,l+5)                               PRIV220
                  x2(l)=did(istart+k,l+5)                               PRIV221
 4004          continue                                                 PRIV222
               call vecang(xo,x1,xo,x2,ang)                             PRIV223
               do 6003 i1=1,ian                                         PRIV224
                  if (abs(ang-an(i1)).lt.0.1) then                      PRIV225
                     iap(iang,3)=i1                                     PRIV226
                     goto 6333                                          PRIV227
                  end if                                                PRIV228
 6003          continue                                                 PRIV229
               an(ian)=ang                                              PRIV230
               iap(iang,3)=ian                                          PRIV231
               if(ian.ge.iamax) goto 6999                               PRIV232
               ian=ian+1                                                PRIV233
 6333          continue                                                 PRIV234
               iap(iang,1)=j+1                                          PRIV235
               iap(iang,2)=k+1                                          PRIV236
               if (iang.ge.iamax) then                                  PRIV237
                  iover=1                                               PRIV238
                  goto 6999                                             PRIV239
               end if                                                   PRIV240
               iang=iang+1                                              PRIV241
 4003       continue                                                    PRIV242
 4002    continue                                                       PRIV243
 6999    continue                                                       PRIV244
         iang=iang-1                                                    PRIV245
         ian=ian-1                                                      PRIV246
                                                                        PRIV247
c ---    tabular list of angles --                                      PRIV248
         izap=int(ilog10(iang))+1                                       PRIV249
         izok=int(ilog10(ian))+1                                        PRIV250
         irip=13-izok-izap                                              PRIV251
                                                                        PRIV252
c ---    Uahhhh - 3.30 am syndrom - rip zok zap - rap it to the beat    PRIV253
         write(fms4,'(a10,i1,a4,i1,a8,i2,a5)')                          PRIV254
     &         fmt5,izap,fmt6,izok,fmt7,irip,form3                      PRIV255
         do 2059 iii=ipr,ipx                                            PRIV256
            write(iii,fms4) lv,                                         PRIV257
     &      'Total of ',iang,' calculated angles in ',ian,              PRIV258
     &      ' equivalent set(s) (',plumi,' 0.1 deg) : ',lv              PRIV259
            call frames(iii,2,icomp)                                    PRIV260
 2059    continue                                                       PRIV261
c ---    now, crank out angles table for output --                      PRIV262
         do 5001 j=1,ian                                                PRIV263
            jmp=0                                                       PRIV264
            il=1                                                        PRIV265
            do 5002 k=1,iang                                            PRIV266
               if (iap(k,3).eq.j.or.k.eq.iang) then                     PRIV267
                  if (iap(k,3).eq.j) then                               PRIV268
                     jmp=jmp+1                                          PRIV269
                     ivec(1,jmp-(il-1)*8)=iap(k,1)                      PRIV270
                     ivec(2,jmp-(il-1)*8)=iap(k,2)                      PRIV271
                  end if                                                PRIV272
                  if ((il.eq.1).and.(jmp.eq.8.or.k.eq.iang)) then       PRIV273
c ---                print first line --                                PRIV274
                     write(fms2,'(a15,i1,a14,i2,a5)')                   PRIV275
     &                     fmt1,jmp,fmt2,(8-jmp)*6+3,fmt3               PRIV276
                     do 2069 iii=ipr,ipx                                PRIV277
                        write(iii,fms2) lv,an(j),' between Vectors: ',  PRIV278
     &                  (ivec(1,l),'-',ivec(2,l),l=1,jmp),lv            PRIV279
 2069                continue                                           PRIV280
                     if (k.eq.iang) goto 5501                           PRIV281
                     il=il+1                                            PRIV282
                  elseif (mod(jmp,8).eq.0.or.k.eq.iang) then            PRIV283
c ---                any second line --                                 PRIV284
                     izap=jmp-(il-1)*8                                  PRIV285
                     if (izap.eq.0) goto 5501                           PRIV286
                     write(fms3,'(a11,i1,a14,i2,a5)')                   PRIV287
     &                     fmt4,izap,fmt2,(8-izap)*6+3,fmt3             PRIV288
                     do 2079 iii=ipr,ipx                                PRIV289
                        write(iii,fms3) lv,                             PRIV290
     &                  (ivec(1,l),'-',ivec(2,l),l=1,izap),lv           PRIV291
 2079                continue                                           PRIV292
                     if (k.eq.iang) goto 5501                           PRIV293
                     il=il+1                                            PRIV294
                  end if                                                PRIV295
               end if                                                   PRIV296
 5002       continue                                                    PRIV297
 5501       continue                                                    PRIV298
 5001    continue                                                       PRIV299
         do 2089 iii=ipr,ipx                                            PRIV300
            call frames(iii,3,icomp)                                    PRIV301
 2089    continue                                                       PRIV302
 8000    continue                                                       PRIV303
         do 2099 iii=ipr,ipx                                            PRIV304
            if (is.gt.ix) write(iii,'(/a,a/)')' List of Shell atoms',   PRIV305
     &         ' is incomplete due to format restrictions'              PRIV306
            if (iover.eq.1) write(iii,'(/a,a/)')' List of angles ',     PRIV307
     &         'is incomplete  - too many atoms (>48) in shell'         PRIV308
            istart=istart+ish(i)                                        PRIV309
 2099    continue                                                       PRIV310
 9000 continue                                                          PRIV311
                                                                        PRIV312
c --- FEFF ----------------------------                                 PRIV313
      write(3,*)  'EOF'                                                 PRIV314
      close(3,status='keep')                                            PRIV315
c --- end FEFF ------------------------                                 PRIV316
      return                                                            PRIV317
      end                                                               PRIV318
