c-------------------------------------------------------------------
      subroutine trxpl_mkgs2_aggr(npts,rho,n,T,sum1,sum2,sum3,sum4)
c
      use trxpl_gs2_module
      implicit NONE
c
      integer npts                      ! no. of pts in profiles
      real*8 rho(npts)                  ! radial flux coordinate
c
c  work arrays...
c
      real*8 n(npts),T(npts)            ! n & T of ions
      real*8 sum1(npts),sum2(npts)      ! n*Z and n*Z*Z sums
      real*8 sum3(npts),sum4(npts)      ! n*A and n*T sums
c
c---------------------------------------------
      real*8 nsum(npts)
      logical iexclud(num_species),iaggr(num_species)
      logical lxout,lchar,lyes,ltmp,ltmp2
      integer lnout,i,j,k,ion,ierr,iopts,ktype
      integer ibc1,ibc2,ishift
      real*8 zbc1,zbc2
c
      integer icounts(0:7)
      character*17 lbls(0:7),mklbl
      integer ilist(num_species,7),inlist(7)
      character*1 cid(7)
c
      data lbls/'electrons','thermal ions','impurity ions','beam ions',
     >     'RF tail ions','fusion products','all fast ions',
     >     'therm + fast ions'/
c
      data mklbl/'?aggregator'/     ! marker label for ions aggregated away
c
      data cid/'1','2','3','4','5','6','7'/
c
c---------------------------------------------
c
      iexclud=.false.
      iaggr=.false.
c
      inlist=0
      ilist=0
c
      i=lnout(0)
c
      if(gsmoo) then
         write(i,*) ' *** cannot aggregate ion species after smoothing!'
         write(i,*) '     to redo, go to smoothing routine and request'
         write(i,*) '     to cancel all smoothing.'
         call upaust(0)
         call uclear
         return
      endif
      if(gaggr) then
         write(i,*) ' *** ion species were already aggregated!'
         write(i,*) '     to redo, go back to top of program and reread'
         write(i,*) '     the input data...'
         call upaust(0)
         call uclear
         return
      endif
c
 10   continue
      icounts=0
      do j=1,num_species
         if((.not.iexclud(j)).and.(.not.iaggr(j))) then
            icounts(ltype(j))=icounts(ltype(j))+1
            if(ltype(j).gt.2) icounts(6)=icounts(6)+1
         endif
      enddo
c
c  if any fast ions or thermal ions are already aggregated, fast + thermal 
c  aggregation is not an option -- impurity aggregation (inlist(2)) not a
c  factor.
c
      if(max(inlist(1),inlist(3),inlist(4),inlist(5),inlist(6)).eq.0)
     >     then
         icounts(7)=icounts(1)+icounts(6) ! fast + thermal
      else
         icounts(7)=0           ! cannot aggregate fast & thermal
      endif
c
      i=lnout(0)
      if(lxout(0)) then
         write(i,*) ' %trxpl_mkgs2_aggr -- species of like type can be'
         write(i,*) '  "aggregated" into a nominal ion specie a, with'
         write(i,*) ' '
         write(i,*) '     Za = sum[i]ni*Zi^2/sum[i]ni*Zi'
         write(i,*) '     na = sum[i]ni*Zi/Za'
         write(i,*) '     Ta = sum[i]ni*Ti/sum[i]ni'
         write(i,*) '     Aa = sum[i]ni*Ai/sum[i]ni'
         write(i,*) ' '
         write(i,*) '  and the sums are over a selected subset of ion'
         write(i,*) '  species.  Note that Z and A become profile'
         write(i,*) '  functions.'
         write(i,*) ' '
         write(i,*)
     >    '  On entry to trxpl_mkgs2_aggr, exclusion flags are cleared.'
         write(i,*) ' '
         do j=1,num_species
            if(j.eq.1) then
               ltmp=.TRUE.
               ltmp2=.FALSE.
            else
               ltmp=iexclud(j)
               ltmp2=iaggr(j)
            endif
            write(i,1001) j,slabel(j),ltmp,ltmp2
 1001       format(' specie ',i3,'.  ',a,' EXCLUDED = ',L1,
     >         ' AGGREGATED = ',L1)
         enddo
         write(i,*) ' '
      endif
      iopts=0
      if(icounts(1).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "I" to aggregate thermal ion species'
      endif
      if(icounts(2).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "X" to aggregate impurity ion species'
      endif
      if(icounts(3).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "B" to aggregate beam ion species'
      endif
      if(icounts(4).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "R" to aggregate RF tail ion species'
      endif
      if(icounts(5).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "P" to aggregate fusion product species'
      endif
      if(icounts(6).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "F" to aggregate all fast ion species'
      endif
      if(icounts(7).gt.1) then
         iopts=iopts+1
         write(i,*) ' -> enter "G" to aggregate thermal and fast '//
     >        'species together.'
      endif
      if(iopts.gt.0) then
         write(i,*) ' -> enter "Z" to set exclude flag for a specie'
      else
         write(i,*)
     >      ' ** no more ion species can be aggregated at this time.'
      endif
      write(i,*) ' -> enter "A" to accept & execute aggregations.'
      write(i,*) '   (caution:  cannot re-enter this routine after "A")'
      write(i,*) ' -> enter "Q" to quit without aggregating ions.'
c
      call uread('trxpl_mkgs2_agg:  ion aggregation option:$')
c
      ktype=0
c
      if(lchar('Q')) then
         return
      else if(lchar('A')) then
         go to 200
      else if(lchar('Z')) then
         j=0
         if(lxout(0)) write(i,*) ' enter "0" to skip this...'
         call ureadi(' enter id number of ion specie to exclude:$',j)
         if(j.eq.0) go to 10
         if((j.le.1).or.(j.gt.num_species)) then
            call uermsi('%trxpl_mkgs2:  invalid specie id:',j,0)
         else
            iexclud(j)=.TRUE.
         endif
         go to 10
      endif
      if(icounts(1).gt.1) then
         if(lchar('I')) then
            ktype=1
            go to 100  ! avoid further "lchar" calls
         endif
      endif
      if(icounts(2).gt.1) then
         if(lchar('X')) then
            ktype=2
            go to 100  ! avoid further "lchar" calls
         endif
      endif
      if(icounts(3).gt.1) then
         if(lchar('B')) then
            ktype=3
            go to 100  ! avoid further "lchar" calls
         endif
      endif
      if(icounts(4).gt.1) then
         if(lchar('R')) then
            ktype=4
            go to 100  ! avoid further "lchar" calls
         endif
      endif
      if(icounts(5).gt.1) then
         if(lchar('P')) then
            ktype=5
            go to 100  ! avoid further "lchar" calls
         endif
      endif
      if(icounts(6).gt.1) then
         if(lchar('F')) then
            ktype=6
            go to 100  ! avoid further "lchar" calls
         endif
      endif
      if(icounts(7).gt.1) then
         if(lchar('G')) then
            write(i,*) ' %CAUTION -- wide variation in energy may occur'
            write(i,*) '  between thermal and fast species.'
            call uread(
     >           ' verify aggregation of thermal and fast species?'//
     >           ' (Y/N):$')
            if(.not.lyes(0)) go to 10
            ktype=7
            go to 100  ! avoid further "lchar" calls
         endif
      endif
c
 100  continue
      if(ktype.eq.0) then
         call uermsg('%trxpl_mkgs2_agg:  invalid option code.',' ',0)
         go to 10
      endif
c
      do j=1,num_species
         if(.not.iexclud(j)) then
            if(  (ltype(j).eq.ktype) .or.
     >           ((ktype.eq.6).and.(ltype(j).gt.2)) .or.
     >           ((ktype.eq.7).and.((ltype(j).eq.1).or.(ltype(j).gt.2)))
     >           ) then
               inlist(ktype)=inlist(ktype)+1
               ilist(inlist(ktype),ktype)=j
               iaggr(j)=.TRUE.
            endif
         endif
      enddo
c
      go to 10
c
 200  continue
c
      ibc1=1
      zbc1=0.0d0
      ibc2=0
      zbc2=0.0d0
c
      if(inlist(7).gt.0) then
         fast_aggr=.TRUE.
      else
         fast_aggr=.FALSE.
      endif
c
      do j=1,7
         if(inlist(j).gt.0) then
            nsum = 0.0d0
            sum1 = 0.0d0
            sum2 = 0.0d0
            sum3 = 0.0d0
            sum4 = 0.0d0
            do k=1,inlist(j)
               ion=ilist(k,j)
c
               call eq_rgetf(npts,rho,id_norig(ion),0,n,ierr)
               if(ierr.ne.0) call errmsg_exit('?trxpl_gs2_aggr 1??')
c
               call eq_rgetf(npts,rho,id_torig(ion),0,T,ierr)
               if(ierr.ne.0) call errmsg_exit('?trxpl_gs2_aggr 2??')
               T=T*Tconv(ion)
c
               nsum=nsum+n
               sum1=sum1+n*Zplas(ion)
               sum2=sum2+n*Zplas(ion)*Zplas(ion)
               sum3=sum3+n*Aplas(ion)
               sum4=sum4+n*T
c
               Aplas(ion)=0.0d0
               Zplas(ion)=0.0d0
               Tconv(ion)=1.0d0
               id_norig(ion)=0
               id_torig(ion)=0
               ltype(ion)=0
               slabel(ion)=mklbl
c
            enddo
c
            sum3=sum3/nsum              ! <A>
            sum4=sum4/nsum              ! <T>
            sum2=sum2/sum1              ! <Z>          ... conserve zeff
            sum1=sum1/sum2              ! new density      & quasineutrality
c
            ion=ilist(1,j)
            ltype(ion)=j
            slabel(ion)=lbls(j)//' (aggregate)'
c
c  store the new aggregate ion specie parameters as spline or hermite
c  ...in place of the first of the ions that is being aggregated away
c
            call eqm_rhofun(iorder,id_rho,'N_AGGR'//cid(j),sum1,
     >         ibc1,zbc1,ibc2,zbc2,id_norig(ion),ierr)
            if(ierr.ne.0) call errmsg_exit(
     >         ' ?trxpl_mkgs2_aggr:  eqm_rhofun error (n)')
c
            if(j.gt.2) then
               call eqm_rhofun(iorder,id_rho,'T_AGGR'//cid(j),sum4,
     >            ibc1,zbc1,ibc2,zbc2,id_torig(ion),ierr)
               if(ierr.ne.0) call errmsg_exit(
     >            ' ?trxpl_mkgs2_aggr:  eqm_rhofun error (T)')
            else
               ! thermal ions stick with original Ti or Tx/Tmj
               if(j.eq.1) id_torig(ion)=id_tmj
               if(j.eq.2) id_torig(ion)=id_tx
            endif
c
            call eqm_rhofun(iorder,id_rho,'Z_AGGR'//cid(j),sum2,
     >         ibc1,zbc1,ibc2,zbc2,id_zprof(ion),ierr)
            if(ierr.ne.0) call errmsg_exit(
     >         ' ?trxpl_mkgs2_aggr:  eqm_rhofun error (Z)')
c
            call eqm_rhofun(iorder,id_rho,'A_AGGR'//cid(j),sum3,
     >         ibc1,zbc1,ibc2,zbc2,id_aprof(ion),ierr)
            if(ierr.ne.0) call errmsg_exit(
     >         ' ?trxpl_mkgs2_aggr:  eqm_rhofun error (A)')
c
            gaggr=.TRUE.
c
         endif        ! #aggregate-list.gt.1
c
      enddo
c
      if(.not.gaggr) then
         write(i,*) ' %no ions aggregated-- can re-enter.'
      else
c
c  squeeze out ion species being aggregated away
c
         ishift=0
         do k=1,num_species
            if(slabel(k).eq.mklbl) then
               ishift=ishift+1
            else if(ishift.gt.0) then
               Aplas(k-ishift)=Aplas(k)
               Zplas(k-ishift)=Zplas(k)
               id_zprof(k-ishift)=id_zprof(k)
               id_aprof(k-ishift)=id_aprof(k)
               Tconv(k-ishift)=Tconv(k)
               id_norig(k-ishift)=id_norig(k)
               id_torig(k-ishift)=id_torig(k)
               ltype(k-ishift)=ltype(k)
               slabel(k-ishift)=slabel(k)
            endif
         enddo
c
         num_species=num_species-ishift
         if(num_reft.gt.1) then
            do k=1,num_species
               if(ltype(k).eq.1) num_reft=k ! take last non-impurity therm. ion
            enddo
         endif
 
      endif
c
      return
      end
