c  This module contains profile routines
c
c-------------------------------------------
c
c
      function fuelon(psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************
c analytic fit to the elongation
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh, only: polasp
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) fuelon
      real(kind=dp) psi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   # option for n-T profile calculation: 1 if
c                           # calculated from prontp; else = 0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c ************ ************ ************ ************
c
      fuelon = polasp(1) + (polasp(2)-polasp(1))*psi*psi
c
      return
      end function fuelon


      subroutine funct1(n, xc, fc)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      USE Vclsfun1
      USE Vceqdsk, only: xxx, zzz
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n
      real(kind=dp) fc
      real(kind=dp), dimension(n) :: xc
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: lmhd, i, id
      real(kind=dp), dimension(3) :: zbx0, zbx1, zbx2, zbz0
      real(kind=dp) :: zh, zph, zcosph, fxxx, fzzz
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
!      integer , EXTERNAL :: ifix
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: valspl
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c

c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95

c
c   ****************************************************************
c
c
c   ****************************************************************
c
      psi = xc(1)
      theta = xc(2)
c
      if (abs(psi) < 1.E-10) psi = sign(1._dp,psi)*1.E-10
      psi = min(psilimit,psi)
c
      asinth = sin(theta)
c
c   ****************************************************************
c   evaluations of rshift, rho, dtrian, elong and their derivatives
c   ****************************************************************
c
!      lmhd = ifix(psi/dpsimhd) + 1
      lmhd = int(psi/dpsimhd) + 1
      zh = psi - psimhd(lmhd)
c
      do i = 1, 1
         id = i - 1
         zbx0(i) = valspl(zh,bx0,nprofn,lmhd,id)
         zbx1(i) = valspl(zh,bx1,nprofn,lmhd,id)
         zbx2(i) = valspl(zh,bx2,nprofn,lmhd,id)
         zbz0(i) = valspl(zh,bz0,nprofn,lmhd,id)
      end do
c
c   ****************************************************************
c   evaluation of xu(psi,theta), zu(psi,theta), and derivatives
c   ****************************************************************
c
      zph = theta - zbx2(1)*asinth
      zcosph = cos(zph)
c
      ux = zbx0(1) + zbx1(1)*zcosph
      uz = zbz0(1)*asinth
c
      fxxx = ux/ukzero
      fzzz = uz/ukzero

      fc = (xxx - fxxx)**2 + (zzz - fzzz)**2
      if (psi <= 0.) fc = 100.

      return
      end subroutine funct1

      function furmaj(psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************
c analytic fit to the major radius position
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh, only: rzero, rshift
!      use Vcraylh
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) furmaj
      real(kind=dp) psi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   # option for n-T profile calculation: 1 if
c                           # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c ************ ************ ************ ************
c
      furmaj = rzero + rshift*(1. - psi)
c
      return
      end function furmaj

      function furrho (psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************
c analytic fit to the minor radius
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh, only: rplasm
!      use Vcraylh
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) furrho
      real(kind=dp) psi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c ************ ************ ************ ************
c
      furrho = rplasm*psi
c
      return
      end function furrho
      function futria (psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************
c analytic fit to the triangularity
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh, only:  dtrian
!      use Vcraylh
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) futria
      real(kind=dp) psi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   # option for n-T profile calculation: 1 if
c                           # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c ************ ************ ************ ************
c
      futria = dtrian*psi*psi
c
      return
      end function futria
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c

      subroutine metrin
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c   ****************************************************************
c   *                                                              *
c   *      This modulus initializes the parametric repre-          *
c   *           sentation of  the plasma equilibrium con-          *
c   *           figuration, and plasma profiles.                   *
c   *      It is called from inital, if ieqdsk.lt.3                *
c   *                                                              *
c   ****************************************************************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vceqdsk
      use Vcmnew, only: conci
!      USE Vfwcd1
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, ijk, j, i
      real(kind=dp) :: zpi, sum
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: prone, prote, proti
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c
c   Comhpcsd
c
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95

c
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

c
c
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
c
c ************ ************ ************ ************ ************
c
c   mhd equilibrium expansion parameters
c
      bx0(:nmhd,1) = ukzero*(rmaj(:nmhd)-rmaj(1))
      bx1(:nmhd,1) = ukzero*rrho(:nmhd)
      bx2(:nmhd,1) = triang(:nmhd)
      bz0(:nmhd,1) = elong(:nmhd)*bx1(:nmhd,1)
c
      call cubspl (dpsimhd, bx0, nprofn, nmhd)
c
      call cubspl (dpsimhd, bx1, nprofn, nmhd)
c
      call cubspl (dpsimhd, bx2, nprofn, nmhd)
c
      call cubspl (dpsimhd, bz0, nprofn, nmhd)
c
c ************ ************ ************ ************
c   plasma shape and dimensions
c   magnetic field on the magnetic axis
c ************ ************ ************ ************
c
      psi = 1.
      theta = 0.
c
      call coords
c
      xmax = ux/ukzero
      theta = zpi
c
      call coords
c
      xmin = ux/ukzero
      urplas = rplasm*ukzero
      raxmag = rmaj(1)
      rshift = raxmag - rzero
      uraxmag = ukzero*raxmag
      baxis = bzero*rzero/raxmag
c
c ************ ************ ************ ************ ************
c  density,temperature,zeff profiles
c
c
      print *,'Executed code with improper indexing.'
      nion = nspec
      do ijk = 1, nprofs
         psi = float(ijk - 1)/float(nprofs - 1)
         ppsi(ijk) = psi
         pne(ijk) = prone(psi)
         pte(ijk) = prote(psi)
         pjavg(ijk) = pte(ijk)**1.5
         pti(ijk,1) = proti(psi)
      end do
      conci(:nion) = aconc(:nion)*azi(:nion)
      sum = 0.
      do i = 1, nion
         sum = sum + conci(i)
      end do
      do i = 1, nion
         conci(i) = conci(i)/sum
         aconc(i) = conci(i)/azi(i)
         pni(:nprofs,i) = pne(:nprofs)*aconc(i)
         conc(:nprofs,i) = pni(:nprofs,i)/pne(:nprofs)
      end do
      do i = 2, nion
         pti(:nprofs,i) = pti(:nprofs,1)
      end do
      zeff = 0.
      zeff = dot_product(aconc(:nion),azi(:nion)**2)
      tzeff(:nprofs,1) = zeff
      return
c
c ************ ************ ************ ************ ************
c
      end subroutine metrin


       function pro(psi, rplasm, acoef)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
!      use Viorlh
!      use Vcraylh
!      use Vchpcsd
!      use Vceqdsk
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) pro
      real(kind=dp) psi, rplasm
      real(kind=dp), dimension(4) :: acoef
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
      real(kind=dp) :: x, x2, arg
C-----------------------------------------------

c     Calculate ASDEX YAG1 type profiles.
c     acoef(i),i=1,4  must be specified.

      x = rplasm*psi
      x2 = x*x
      arg = acoef(4)
      do i = 1, 3
         arg = arg*x2 + acoef(4-i)
      end do
      pro = exp(arg)
      return
      end function pro
c
c
      subroutine modb
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c*****A subroutine to calculate mod-B on the rectangular grids of EQDSK.
c     This is for use mainly in plotting the mod-B surface for a low-A
c     tokamak.
c$$$$$$   TK Mau   01/95
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
!      use Viorlh
!      use Vcraylh
!      use Vchpcsd
      use Vceqdsk
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(4) :: jbd
      integer :: i, j, igrd
      real(kind=dp), dimension(nxa,4) :: feqdsp
      real(kind=dp), dimension(nxa,nza) :: pxx, pzz, pxxzz
      real(kind=dp), dimension(6*nza + 1) :: wkm
      real(kind=dp) :: dpflx, psim, hh, btor, dpdx, dpdz, bpol
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real(kind=dp) , EXTERNAL :: valspl, terp2  ! , sqrt
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

c
c
      jbd = 4
c
      call coeff2 (nxeqd, xeqd, nzeqd, zeqd, peqd, pxx, pzz, pxxzz,
     1   nxeqd, jbd, wkm)
c
      dpflx = 1./float(nxeqd - 1)
      feqdsp(:nxeqd,1) = feqd(:nxeqd)
      call cubspl (dpflx, feqdsp, nxa, nxeqd)
c
      do i = 1, nxeqd
         do j = 1, nzeqd
            psim = abs(peqd(i,j)/(psimag-psilim))
!            igrd = ifix(psim/dpflx) + 1
            igrd = int(psim/dpflx) + 1
            if (igrd <= nxeqd) then
               hh = psim - float(igrd - 1)*dpflx
               btor = valspl(hh,feqdsp,nxa,igrd,0)/xeqd(i)
            else
               btor = beqd*reqd/xeqd(i)
            endif
            dpdx = terp2(xeqd(i),zeqd(j),nxeqd,xeqd,nzeqd,zeqd,peqd,pxx,
     1         pzz,pxxzz,nxeqd,1,0)
            dpdz = terp2(xeqd(i),zeqd(j),nxeqd,xeqd,nzeqd,zeqd,peqd,pxx,
     1         pzz,pxxzz,nxeqd,0,1)
            bpol = sqrt(dpdx**2 + dpdz**2)/xeqd(i)
            bmod(i,j) = sqrt(btor**2 + bpol**2)
         end do
      end do
c
      return
      end subroutine modb
c
c
      subroutine profaxis(rn, expn1, expm1, dratio, rova)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vceqdsk
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) rn, expn1, expm1, dratio, rova
C-----------------------------------------------
c---------------------------------------------------------------------
c    This subroutine rescales the density and temperature of the max-
c    wellian species from the input values to the profile-specified
c    values at rovera.  The input values are thus interpreted to be
c    axis values (rovera=0) and runs done sweeping through various
c    values of rovera are automatically synchronized with respect to
c    radial variations of background quantities.
c---------------------------------------------------------------------
      if (abs(dratio - 1.) < 1.E-12) then
         rn = 1.0
      else
         rn = dratio + (1.0 - dratio)*(1. - rova**expn1)**expm1
      endif
      return
      end subroutine profaxis
c
      subroutine profin
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c      this subroutine initializes the density, temperature,
c      and poloidal/toroidal magnetic field tables, and
c      evaluates the coefficient for spline interpolation.
c      it is called once before proceeding to the integra-
c      tion of the ray equations for a given plasma.
c
c      independent variable for the profiles is the flux
c      variable psi, normalized so 0.le.psi.le.1.+(nprof-nprofs)*zdpsi
c      Also find poloidal flux function vs. psi (bh:032090)
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vceqdsk
      use Vcmnew
c     USE Vgrnout
      use Viogrl
      use Vctransp
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: lamin0 = 101
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: lamin, j, k, j1, k1, n, l, i1, i2, j2, jj, jj1, jj2,
     1   jj3, i5, jmd, jmd1, jmd2, ij, i, nbmax, l1, ik, il, k2, k3, i3
     2   , i4
c ----   TKM    07/02
      integer :: nrho1, nrho2
      real(kind=dp) :: delr
      real(kind=dp), dimension(101) :: wwork1, wwork2, xrho
c -------------  07/02
      real(kind=dp), dimension(lamin0) :: flam
      real(kind=dp), dimension(2) :: bscur
      real(kind=dp), dimension(nions + 1) :: den1, dden1, tem1, ttem1,
     1    azi1, atm1
      real(kind=dp), dimension(nprofm) :: dbt1r, xwork, ywork
      real(kind=dp), dimension(nprofm,4) :: dumf
      real(kind=dp), dimension(nprofm) :: ajjtr, dcurr, pptot,
     1    ajdia, ajbsr
      real(kind=dp), dimension(nprofm) :: rnustar
      real(kind=dp), dimension(nprofm) :: drr, drt1, drt2, dbtp2, dbt3r
      real(kind=dp), dimension(2*nprofm - 1) :: denln
      real(kind=dp), dimension(3) :: zv, zl, zq, zs
      real(kind=dp) :: zpi, zflux, zdth, zdthx, zk3, zsint, zvint,
     1    zlint, zqint,
     1   zfacq, zfluxq, ztanq, ru, dpsifdra, dra, tneint, tteint, ttiint
     2   , ppint, btold, amu0, denlt, rbeta, abmax, bp1, dabm, alm1,
     3   dbtt, dlp, bt1, btt1, dlpbp, dbtp1, dv, dparb2, xrad1, bjtor,
     4   dbtdl, dbpdl, bdb1, fcir, fmks, rmajx, epsll, rstar, ratsgn,
     5   aibs, abjold, abjnew, pscur, fpfs, ratioj
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real(kind=dp) , EXTERNAL :: qsaf, valspl, simp
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95

c
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  7/30/91    T.K. Mau
c********************************************
c  6/26/91,  Latest update: 06/02/00
c     Comnew
cNew common added for FWCD
c  Storage related to FWCD:
cSubroutines displh inital use Comnew1


c******      TKM   03/97, 09/99, 04/00, 06/00
c********************

c
c ************ ************ ************ ************ ************
c
c $$$$$$  TKM 10/91; 6/99; 2/00
!      parameter(lamin0=101)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
c $$$$$$$$$$$ Added by TK Mau on 10/26/91; 07/02
      data lamin/61/
      data nrho1/41/
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ************ ************ ************ ************ ************
c
      istop = 0
c
c ************ ************ ************ ************
c  check the number of points in the profile
c ************ ************ ************ ************
c
      if (nprof < 11) then
         write (iout, 9999) nprof
         istop = 1
         return
      endif
      if (nprof > nprofn) then
c
         write (iout, 9999) nprof
 9999    format('0',5x,"n. of points in the profile =",i4,
     1      " too large or too small for proper use")
         istop = 1
         return
c
      endif
c
c ************ ************ ************ ************ ************
c  transfer of the profiles for density & temperatures
c     to the tables for cubic interpolation
c ************ ************ ************ ************ ************
c
c**bh**      dpsi = 1./float(nprof-1)
      dpsi = ppsi(nprof)/float(nprof - 1)
      zflux = ppsi(nprof)
c***********************             SCC  12/12/95
      denc = pne(1)
      tempec = pte(1)
c        ztmpic = pti(1)
      if (nprof > nprofn) stop
c**bh**  tpsi(j) = ppsi(j)/zflux
      tpsi(:nprof) = ppsi(:nprof)
      tne(:nprof,1) = pne(:nprof)
      tte(:nprof,1) = pte(:nprof)
      tti(:nprof,1,:nspec) = pti(:nprof,:nspec)
      tni(:nprof,1,:nspec) = pni(:nprof,:nspec)
      tconc(:nprof,1,:nspec) = conc(:nprof,:nspec)
      tvlp(:nprof,1) = elp_tr(:nprof)
c$$$$$$    TKM   11/98
      ttani(:nprof,1) = tani(:nprof)
C******************************
c $$$$$$  Added by TK Mau on 10/30/91.
      if (ieqdsk == 0) then
         do j1 = 1, nprof
            ppra(j1,1) = 1.0
            ppra(j1,1) = ppra(j1,1) + sum(conc(j1,:nspec)*pti(j1,:nspec)
     1         /pte(j1))
            ppra(j1,1) = 1.6022E-10*pne(j1)*pte(j1)*ppra(j1,1)
         end do
      endif
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

c*****************************************************************
c  cubic spline interpolation of the profiles
c*****************************************************************
c
      call cubspl (dpsi, tne, nprofn, nprof)
      call cubspl (dpsi, tte, nprofn, nprof)
c------------------------SCC   4/23/96
      call cubspl (dpsi, tzeff, nprofn, nprof)
c--------------------------
c$$$$$$     TKM   11/98
      call cubspl (dpsi, ttani, nprofn, nprof)
      do k = 1, nspec
         call cubspl (dpsi, tti(1,1,k), nprofn, nprof)
         call cubspl (dpsi, tni(1,1,k), nprofn, nprof)
         call cubspl (dpsi, tconc(1,1,k), nprofn, nprof)
      end do

c***************************************************************
c  Required magnetic geometry is calculated in subroutine fiteqdsk
c  when ieqdsk.ge.3
c*****************************************************************
c
      if (ieqdsk < 3) then

c***************************************************************

c  specific volume of the magnetic surfaces
c  poloidal magnetic field and safety factor
c  volume(j) = volume element associated with tpsi(j)  (m**3)
c  zsurf(j)  = cross-sectional area element assoc]ated with tpsi(j) (m**2)
c  zlamb(j) = Eq 5.22 of IPP4/210
c  zqfac(j) = q(tpsi(j))/(B_T/B_p(tpsi(j)),  Eq 5.26
c***************************************************************
         zdth = zpi/200.
         zdthx = 2.*zdth/3.
c     ukzero is 2*pi/(free space wavenumber)  (m**-1)
         zk3 = ukzero**3
c     Loop over radial flux surfaces:
         do j = 2, nprof
            psi = tpsi(j)
            zsint = 0.
            zvint = 0.
            zlint = 0.
            zqint = 0.
            theta = 0.
            call coords
c     aj= J*ukzero**2; urhs=R*ukzero;  antau=N_tau*ukzero
            zs(3) = aj
            zv(3) = urhs*aj
            zl(3) = antau*antau/(aj*urhs)
            zq(3) = aj/urhs
c     Integrate over poloidal angle:
            do n = 1, 100
               zs(1) = zs(3)
               zv(1) = zv(3)
               zl(1) = zl(3)
               zq(1) = zq(3)
               do l = 2, 3
                  theta = theta + zdth
                  call coords
                  zs(l) = aj
                  zv(l) = urhs*aj
                  zl(l) = antau*antau/(aj*urhs)
                  zq(l) = aj/urhs
               end do
               zsint = zsint + zs(1) + 4.*zs(2) + zs(3)
               zvint = zvint + zv(1) + 4.*zv(2) + zv(3)
               zlint = zlint + zl(1) + 4.*zl(2) + zl(3)
               zqint = zqint + zq(1) + 4.*zq(2) + zq(3)
            end do
            volume(j) = 2.*zpi*zvint*dpsi*zdthx/zk3
            zsurf(j) = zsint*dpsi*zdthx/ukzero**2
            zlamb(j) = zlint*uraxmag*zdthx/(2.*zpi)
            zqfac(j) = zqint*zdthx/(2.*zpi*urplas)
         end do
         volume(1) = volume(2)/3.
c
c     zcurr(j) = I(tpsi(j))  Eq 5.20 of IPP4/210
c     pjavg(j) = current density at tspi(j)  (amps/m**2)
c     tqr(j,1)   = B_p(tpsi(j))/B_T   Eq 5.21
c     pqr(j,1)   = q(tpsi(j))    Eq 5.26
         zcurr(1) = 0.
         do j = 2, nprof
            zcurr(j) = zcurr(j-1) + 0.5*(zsurf(j-1)*pjavg(j-1)+zsurf(j)*
     1         pjavg(j))
         end do
         zcurr(2:nprof) = tcurr*zcurr(2:nprof)/zcurr(nprof)
         tqr(2:nprof,1) = 2.E-7*zcurr(2:nprof)/(rplasm*baxis*zlamb(2:
     1      nprof))
         pqr(2:nprof,1) = abs(zqfac(2:nprof)/tqr(2:nprof,1))
         tqr(1,1) = 0.
         pqr(1,1) = pqr(2,1)

c***********************************************************************
c   If isafa.ne.0., then using a q-profile input thru function qsaf,
c   reset pqr, tqr, zcurr, pjavg, and tcurr
c***********************************************************************
c--------SCC 8/18/94  add isafa in curray.v
c     if (qsafa.ne.0.0)  then
         if (isafa /= 0) then
            do j = 1, nprof
               pqr(j,1) = qsaf(tpsi(j))
               tqr(j,1) = btsign*zqfac(j)/pqr(j,1)
               zcurr(j) = 0.5E7*(urplas/ukzero)*zlamb(j)*tqr(j,1)*baxis
            end do
            tcurr = zcurr(nprofs)
            pjavg(2:nprofs) = (zcurr(2:nprofs)-zcurr(:nprofs-1))/dpsi/(
     1         0.5*(zsurf(2:nprofs)+zsurf(:nprofs-1)))
            pjavg(1) = 1.5*pjavg(2) - 0.5*pjavg(3)
            do j = nprofs, 2
               pjavg(j) = 0.5*(pjavg(j-1)+pjavg(j))
            end do
            if (nprof > nprofs) then
               pjavg(nprofs+1:nprof) = 0.0
            endif
         endif

c*****************************************************************
c  cubic spline interpolation of the profiles
c*****************************************************************
c
         call cubspl (dpsi, tqr, nprofn, nprof)
         call cubspl (dpsi, pqr, nprofn, nprof)
c

c****************************************************************
c  (Poloidal magnetic flux)/(2*pi) as a function of psi
c  (Formula derived from Brambilla notes for integral(B.dS_theta))
c****************************************************************
         tpsif(1,1) = 0.0
         do j = 2, nprof
            theta = zpi
            psi = 0.5*(tpsi(j-1)+tpsi(j))
            call coords
!            left = ifix(psi/dpsi) + 1
            left = int(psi/dpsi) + 1
            hh = psi - tpsi(left)
            tpsif(j,1) = tpsif(j-1,1) + valspl(hh,tqr,nprofn,left,0)*
     1         baxis*uraxmag*urplas/ukzero**2*dpsi
         end do

c     Renormalize tpsif to be neg. (max. abs value) at the
c     magnetic axis, and zero at the plasma boundary.
         tpsisav = tpsif(nprofs,1)
         tpsif(:nprof,1) = tpsif(:nprof,1) - tpsisav

         call cubspl (dpsi, tpsif, nprofn, nprof)
c
      endif
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c   Modified by T.K. Mau on July 30, 1991.
c   To set up spline fit for equivalent inverse aspect ratio, epsilon,
c    as a function of psi, or flux surface half-diameter at midplane.
c   This is used to account for neoclassical degradation of current
c    drive efficiency.
c
c     if(idrive.eq.0) return
      if (idrive /= 0) then
         epsl(1,1) = 0.
         binbd(1,1) = abs(baxis)
         if (ieqdsk <= 2) then
            do i1 = 2, nprof
               psi = ppsi(i1)
               do j1 = 1, 2
                  if (j1 == 1) then
                     theta = 0.
                  else
                     theta = zpi
                  endif
                  call coords
                  zfacq = urplas*antau/aj
                  zfluxq = valspl(0.,tqr,nprofn,i1,0)
                  ztanq = zfacq*zfluxq
                  acostq = btsign/sqrt(1. + ztanq*ztanq)
                  btor = baxis*uraxmag/urhs
                  btot = btor/acostq
                  if (j1 == 1) then
                     boutb = btot
                  else
                     binb = btot
                     binbd(i1,1) = binb
                  endif
               end do
               epsl(i1,1) = (binb - boutb)/(binb + boutb)
            end do
         else
            do i2 = 2, nprof
               psi = ppsi(i2)
c     binb = -1.0e12
c     boutb = 1.0e12
c     delan = zpi/float(lamin-1)
c     do 123 j2 = 1,lamin
c        theta = delan*float(j2-1)
               do j2 = 1, 2
                  if (j2 == 1) then
                     theta = 0.
                  else
                     theta = zpi
                  endif
                  call coords
                  ru = xu + raxmag
                  btor = fra(i2,1)/ru
                  dpsifdra = valspl(0.,tpsif,nprofn,i2,1)
                  bpol = dpsifdra*antau/(aj*ru)*ukzero
                  btot = sqrt(btor**2 + bpol**2)
c     if(btot.gt.binb) binb = btot
c     if(btot.lt.boutb) boutb = btot
                  if (j2 == 1) then
                     boutb = btot
                  else
                     binb = btot
                     binbd(i2,1) = binb
                  endif
               end do
               binbd(i2,1) = binb
               epsl(i2,1) = (binb - boutb)/(binb + boutb)
            end do
         endif
         call cubspl (dpsi, epsl, nprofn, nprof)
         call cubspl (dpsi, binbd, nprofn, nprof)
      endif
c     $$$$  Added by TK Mau on 10/13/92 for ARIES studies
c ---- Calculate n_e0/<n_e>, T_e0/<T_e>, T_e0/<T_e0>n, and p_0/<p>.
      dra = 1./float(nprofs - 1)
      volpla(1) = 0.
      do jj = 1, nprofs
         xwork(jj) = volume(jj)/dra
         ywork(jj) = tne(jj,1)*xwork(jj)
         if(jj>1)volpla(jj)=volpla(jj-1)+0.5*(volume(jj)+volume(jj-1))
      end do
      volpla(nprofs) = simp(nprofs,dra,xwork)
      tneint = simp(nprofs,dra,ywork)/denc
      ywork(:nprofs) = tte(:nprofs,1)*xwork(:nprofs)
      tteint = simp(nprofs,dra,ywork)/tempec
      ywork(:nprofs) = tte(:nprofs,1)*tne(:nprofs,1)*xwork(:nprofs)
      ttiint = simp(nprofs,dra,ywork)/(tempec*denc)
      ywork(:nprofs) = ppra(:nprofs,1)*xwork(:nprofs)
      ppint = simp(nprofs,dra,ywork)
      pavtne = volpla(nprofs)/tneint
      pavtte = volpla(nprofs)/tteint
      pavtti = tneint/ttiint
      pavpp = ppra(1,1)*volpla(nprofs)/ppint
c$$$$$      TKM   2/00
c  Recalculate plasma beta based on assumed n and T profiles
      if (alpte>0. .and. alpene>0.) then
         do k1 = 1, nprofs
            pptot(k1) = tne(k1,1)*tte(k1,1)
            pptot(k1)=pptot(k1)+sum(tni(k1,1,:nspec)*tti(k1,1,:nspec))
            pptot(k1) = 1.6022E-16*pptot(k1)
         end do
         xwork(1) = 0.
         ywork(1) = 0.
         xwork(2:nprofs) = volume(2:nprofs)/dra
         ywork(2:nprofs) = pptot(2:nprofs)*xwork(2:nprofs)
         btold = beta
         amu0 = zpi*4.E-7
         beta = 2.E6*amu0*simp(nprofs,dra,ywork)/beqd**2/simp(nprofs,dra
     1      ,xwork)
         betap = betap*beta/btold
      endif
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c**************    TKM   2/97, 2/00
c     Calculate |B_tor| and |B_p| along equatorial plane.
c     Also calculate line-averaged density along equatorial plane
      rmd(nprof) = raxmag
      btmd(nprof) = abs(baxis)
      bpmd(nprof) = 0.
      btpmd(nprof) = btmd(nprof)
      denln(nprof) = tne(nprof,1)
      do jmd = 1, nprof - 1
         jmd1 = nprof - jmd + 1
         jmd2 = 2*nprof - jmd
         rmd(jmd) = xcontr(48,jmd1)
         btmd(jmd) = abs(fra(jmd1,1))/rmd(jmd)
         bpmd(jmd) = bpcontr(48,jmd1)
         rmd(jmd2) = xcontr(3,jmd1)
         btmd(jmd2) = abs(fra(jmd1,1))/rmd(jmd2)
         bpmd(jmd2) = bpcontr(3,jmd1)
         btpmd(jmd) = sqrt(btmd(jmd)**2+bpmd(jmd)**2)
         btpmd(jmd2) = sqrt(btmd(jmd2)**2+bpmd(jmd2)**2)
         denln(jmd) = tne(jmd1,1)
         denln(jmd2) = tne(jmd1,1)
      end do
      denlt = 0.
      denlt = dot_product(0.5*(denln(:2*(nprof-1))+denln(2:2*nprof-1)),
     1   rmd(2:2*nprof-1)-rmd(:2*(nprof-1)))
      denlav = denlt/(rmd(2*nprof-1)-rmd(1))
c*************************
c $$$$    TK Mau 4/13/94; 7/95, 04/00
      rbeta = 1.
      if (kalfa > 0) then
         if (irayio == 0) then
c     if(irayio.gt.0) then
c     do 385 k = 1,nalfa
c$$$$$Source rate given in /cm**3/s for bmpwr(MW), ebkev(kV), and
c     volpla(m**3).
c     consbm = 6.241e15*bmpwr(k)/(ebkev(k)*azf(k)*volpla(nprofs))
c     do 386 j = 1,nprofs
c 386 pnfi(k,j) = consbm*pnfi(k,j)
c 385 continue
c     else
c ----    TKM    07/02
            if(idmpsw > 3) then
            open(8, file='snowmass.in', status='old')
            nrho2 = nrho1-1
c----- Read in normalized toroidal flux coordinates
            read(8,*) xrho(:nrho2)
            do i = nrho1,2,-1
               xrho(i) = xrho(i-1)
            enddo
            xrho(1) = 0.
c----- Read in fast alpha density and energy, 
c      and convert energies to isotropic Maxwellian temperatures
               read(8,*) wwork1(:nrho2)
               wwork1(nrho1) = 2.*wwork1(nrho2)-wwork1(nrho2-1)
               delr = 1./float(nprofs-1)
               do i = 1,nprofs
                  ra(i) = float(i-1)*delr
               enddo
               call intrpp('zero','free',xrho,wwork1,nrho1,ra,denfa,
     &                     nprofs)
               read(8,*) wwork1(:nrho2)
               read(8,*) wwork2(:nrho2)
               wwork1(:nrho2) = wwork1(:nrho2)+wwork2(:nrho2)
               wwork1(nrho1) = 2.*wwork1(nrho2)-wwork1(nrho2-1)
               call intrpp('zero','free',xrho,wwork1,nrho1,ra,wwork2,
     &                     nprofs)
               eav(:nprofs) = 4.160945e15*wwork2(:nprofs)/
     &                          denfa(:nprofs)
            else
               call alpress
            endif
c--------------- 07/02
            rbeta = 1./(1 - betaf/beta)
c     rbeta = 1.0
            do i = 1, nprof
               pnfi(:nalfa,i) = denfa(i)
               ptfi(:nalfa,i) = eav(i)
            end do
         endif
         do k = 1, nalfa
            dumf(:nprof,1) = pnfi(k,:nprof)/pnfi(k,1)
            call cubspl (dpsi, dumf, nprofn, nprof)
            tnf(k,:nprof,:) = dumf(:nprof,:)
            dumf(:nprof,1) = ptfi(k,:nprof)/ptfi(k,1)
            call cubspl (dpsi, dumf, nprofn, nprof)
            ttf(k,:nprof,:) = dumf(:nprof,:)
         end do
      endif
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c $$$$$$   Added by TK Mau on 10/25/91.
c      Calculate bootstrap current profile based on Hirshman-Sigmar
c       model
c
      if (ieqdsk < 3) return
      if (kboot == 0) return
      ajbsb(1) = 0.
      ajbst(1) = 0.
      ftrp(1) = 0.
      ajjtr(1) = 0.
      bttra(1) = baxis
c     ajtb(1) = -fra(1,1)*ppra(1,2)-7.958e5*fra(1,2)*
      ajtb(1)=(-fra(1,1)*ppra1(1,1)/presfr)-7.958E5*fra1(1,1)*baxis**2
c     ajtb(1) = ajtb(1)/dpsifra(1)
c  $$$$   TK Mau 9/3/92
      dbt1(1) = abs(baxis)
      dbt1r(1) = baxis**2/fra(1,1)
      dbt2(1) = baxis*baxis
      ajtrb(1) = ajtb(1)
c $$$$$$  TK Mau  12/6/94
      ajdit(1) = 0.
      ajdia(1) = 0.
      pptot(1) = ppeqd(1)
c----    TK Mau    5/02
      ajtor(1) = (-ppra1(1,1)/presfr*raxmag) - 7.958E5*fra(1,1)*
     &   fra(1,2)/dpsifra(1)/raxmag
c------------
c     ajtor(1) = -ppra(1,2)/presfr*raxmag-7.958e5*fra(1,1)*
c    &     fra(1,2)/raxmag
c     ajtor(1) = ajtor(1)/dpsifra(1)
c $$$$$$$$$$$$$
c  $$$$$$$$$
c ---- First calculate the ratio of trapped to circulating particles
c       for each flux surface
      do k1 = 2, nprofs
         nbmax = (nptsd - 1)/2 + 1
         abmax = fra(k1,1)/xcontr(nbmax,k1)
c $$$$  Added by TK Mau on 12/2/91
         bp1 = bpcontr(nbmax,k1)
         abmax = 1./sqrt(abmax**2 + bp1**2)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
         dabm = abmax/float(lamin - 1)
         do l1 = 1, lamin
            alm1 = float(l1 - 1)*dabm
c     if(l1.eq.1) alm1 = 1.e-4*dabm
            dbtt = 0.
            do ij = 4, nptsd - 2
               dlp = ((xcontr(ij,k1)-xcontr(ij-1,k1))**2+(zcontr(ij,k1)-
     1            zcontr(ij-1,k1))**2)**0.5
               bp1 = 0.5*(bpcontr(ij,k1)+bpcontr(ij-1,k1))
               bt1 = 2.*fra(k1,1)/(xcontr(ij,k1)+xcontr(ij-1,k1))
               btt1 = sqrt(bp1*bp1 + bt1*bt1)
               btt1 = abs(btt1)
               dlpbp = dlp/bp1
               if(1.-alm1*btt1>0.)dbtt=dbtt+sqrt(1.-alm1*btt1)*dlpbp
            end do
            flam(l1) = alm1/dbtt
         end do
         dbt1(k1) = 0.
         dbt1r(k1) = 0.
c $$$$$  TK Mau  12/6/94
c     ajdit(k1) = 0.
c $$$$$$$$$$$$$$$
         dbt2(k1) = 0.
c     dbor(k1) = 0.
         dbtp1 = 0.
         dv = 0.
c  $$$$  TK Mau  9/92;  6/99,  05/02
         ajtor(k1) =0.              ! 05/02
         dparb2 = 0.
         dbtp2(k1) = 0.
         drr(k1) = 0.
         drt1(k1) = 0.
         drt2(k1) = 0.
         ajjtr(k1) = 0.
         do ik = 4, nptsd - 2
            dlp = ((xcontr(ik,k1)-xcontr(ik-1,k1))**2+(zcontr(ik,k1)-
     1         zcontr(ik-1,k1))**2)**0.5
            xrad1 = 0.5*(xcontr(ik,k1)+xcontr(ik-1,k1))
            bt1 = fra(k1,1)/xrad1
            bp1 = 0.5*(bpcontr(ik,k1)+bpcontr(ik-1,k1))
            btt1 = sqrt(bp1*bp1 + bt1*bt1)
            dlpbp = dlp/bp1
            dbt1(k1) = dbt1(k1) + btt1*dlpbp
            dbt1r(k1) = dbt1r(k1) + bt1/xrad1*dlpbp
            drr(k1) = drr(k1) + xrad1*dlpbp
            drt1(k1) = drt1(k1) + dlpbp/xrad1
            drt2(k1) = drt2(k1) + dlpbp/xrad1**2
            dbtp2(k1) = dbtp2(k1) + bt1**2*dlpbp
            dbt3r(k1) = dbt3r(k1) + (bp1/btt1)**2*dlpbp
            dbt2(k1) = dbt2(k1) + btt1**2*dlpbp
c     dbor(k1) = dbor(k1)+bt1/xrad1*dlpbp
            dbtp1 = dbtp1 + bt1*dlpbp
c           bjtor = (-ppra1(k1,1)/presfr) - 
c    &              7.957747E5*fra(k1,1)*fra1(k1,1)/xrad1**2
            bjtor = (-ppra1(k1,1)/presfr) 
     &              - 7.957747E5*fra(k1,1)*fra(k1,2)/dpsifra(k1)
     1              /xrad1**2                         !  j_tor/R
c     bjtor = -ppra(k1,2)-7.958e5*fra(k1,1)*fra(k1,2)/xrad1**2
            ajjtr(k1) = ajjtr(k1) + bjtor*dlpbp  ! <j_tor/R>*dv
c                                                ! <j_tor>*dv
            ajtor(k1) = ajtor(k1) + bjtor*xrad1*dlpbp
            dv = dv + dlpbp
c ---- Calculate <b.grad B>/<B**2>  --  dparb2
            dbtdl = fra(k1,1)*(1./xcontr(ik,k1)-1./xcontr(ik-1,k1))/dlp
            dbpdl = (bpcontr(ik,k1)-bpcontr(ik-1,k1))/dlp
            bdb1 = bp1/btt1*2*(bp1*dbpdl + bt1*dbtdl)
            dparb2 = dparb2 + bdb1**2*dlpbp
c ------
         end do
c ---- Calculate <j.B>, <B>, <B**2>, <B_tor>
c     ajtb(k1) = -fra(k1,1)*ppra(k1,2)-7.958e5*fra(k1,2)*
         ajtb(k1) = (-fra(k1,1)*ppra1(k1,1)/presfr) - 7.958E5*fra1(k1,1)
     1      *dbt2(k1)/dv
c     ajtb(k1) = ajtb(k1)/dpsifra(k1)
         dparb2 = dparb2/dbt2(k1)
         dbt1(k1) = dbt1(k1)/dv                  ! <B>
         dbt1r(k1) = dbt1r(k1)/dv                ! <B_tor/R>
         dbt2(k1) = dbt2(k1)/dv                  ! <B**2>
c     dbor(k1) = dbor(k1)/dv
         bttra(k1) = dbtp1/dv                    ! <B_tor>
         drr(k1) = drr(k1)/dv                    ! <R>
         drt1(k1) = drt1(k1)/dv                  ! <1/R>
         drt2(k1) = drt2(k1)/dv                  ! <1/R**2>
         dbtp2(k1) = dbtp2(k1)/dv                ! <B_tor**2>
         ajtor(k1) = ajtor(k1)/dv                ! <j_tor>
         ajdit(k1) = (-drr(k1)) + drt1(k1)/drt2(k1)*dbtp2(k1)/dbt2(k1)
c     ajjtr(k1) = ajjtr(k1)*dpsifra(k1)
         fcir = 0.75*dbt2(k1)*dv*simp(lamin,dabm,flam)
c $$$$$$$$$$
         ftrp(k1) = (1. - fcir)/fcir
c ---- This part is related to computing the bootstrap current density
c      Preparing input parameters for CKBOOT
         den1(:nspec) = (1.E6*aconc(:nspec))*tne(k1,1)*rbeta
         tem1(:nspec) = 1.E3*tti(k1,1,:nspec)
         dden1(:nspec) = (1.E6*aconc(:nspec))*tne(k1,2)/dpsifra(k1)*
     1      rbeta
         ttem1(:nspec) = 1.E3*tti(k1,2,:nspec)/dpsifra(k1)
         azi1(:nspec) = azi(:nspec)
         atm1(:nspec) = 1.6726E-27*atm(:nspec)
c     if(irayio.eq.0.and.nspec.gt.1) then
c     tem1(nspec) = 1.e3*ttif(k1,1)*tempic(nspec)
c     ttem1(nspec) = 1.e3*ttif(k1,2)*tempic(nspec)/dpsifra(k1)
c     endif
         den1(nspec+1) = 1.E6*tne(k1,1)*rbeta
         tem1(nspec+1) = 1.E3*tte(k1,1)
         dden1(nspec+1) = 1.E6*tne(k1,2)/dpsifra(k1)*rbeta
         ttem1(nspec+1) = 1.E3*tte(k1,2)/dpsifra(k1)
         azi1(nspec+1) = -1.0
         atm1(nspec+1) = 9.1095E-31
         fmks = fra(k1,1)
         rmajx = 0.5*(xcontr(3,k1)+xcontr(48,k1))
         epsll = 0.5*abs(xcontr(3,k1)-xcontr(48,k1))/rmajx
c     call ckboot(nspec+1,atm1,azi1,tem1,den1,ttem1,dden1,epsl(k1,1),
         call ckboot (nspec + 1, atm1, azi1, tem1, den1, ttem1, dden1,
     1      epsll, ftrp(k1), rmajx, pqr(k1,1), fra(k1,1), rstar, bscur(1
     2      ))
         rnustar(k1) = rstar
         ajbsb(k1) = -bscur(1)
         ratsgn = ajbsb(k1)/ajtb(1)
         if (ratsgn < 0.) ajbsb(k1) = -ajbsb(k1)
c ---- Calculate <j.B>_target.
         if (k1 == nprofs) ajbsb(k1) = 0.
         ajtrb(k1) = ajtb(k1) - ajbsb(k1)        !  A-T/m**2
         ajbsr(k1) = ajbsb(k1)/dbt1r(k1)
c $$$$$  TK Mau  12/6/94
c      Calculate plasma diamagnetic current density (A/m**2)
c                                                ! <j_dia,tor/R>*dv
         ajdia(k1) = -ppra1(k1,1)*(1. - dbtp2(k1)/dbt2(k1))*dv
         ajdit(k1) = ppra1(k1,1)*ajdit(k1)       ! <j_dia,tor>
         ywork(k1) = -ppra1(k1,1)*dbt3r(k1)
c $$$$$$$$$$$$$$$$$$$$$$$
      end do
c $$$$  Added by TK Mau on 4/14/92
      rnustar(1) = rnustar(2)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ---- Calculate total plasma and bootstrap currents, and the bootstrap
c      current fraction.
c
      aibs = 0.
      zcurr(1) = 0.
c$$$$$   TK Mau  12/6/94
      dcurr(1) = 0.
c$$$$$$$$$$$$$
c $$$$  TK Mau 9/3/92 ; 6/99
      abjold = 0.
      dra = 1./float(nprofs - 1)
      do i2 = 2, nprofs
         zcurr(i2) = zcurr(i2-1) + 0.5E-6*(ajjtr(i2)*dpsifra(i2)+ajjtr(
     1      i2-1)*dpsifra(i2-1))*dra
c     zcurr(i2) = zcurr(i2-1)+0.5e-6*(ajbsb(i2)/dbt1(i2)*zsurf(i2)
c    &            +ajbsb(i2-1)/dbt1(i2-1)*zsurf(i2-1))
c$$$$$    TK Mau   12/6/94
         dcurr(i2) = dcurr(i2-1) + 0.5E-6*(ajdia(i2)*dpsifra(i2)+ajdia(
     1      i2-1)*dpsifra(i2-1))*dra
c$$$$$$$$$$$$$$$$$$$
         abjnew = 2.*zpi*pqr(i2,1)*ajbsb(i2)*dpsifra(i2)/dbt2(i2)
c     abjnew = pqr(i2,1)*ajbsb(i2)/dbt2(i2)
         aibs = aibs + 0.5E-6*(abjnew + abjold)*dra
         abjold = abjnew
      end do
      ywork(1) = 0.
      xwork(:nprofs) = ajdia(:nprofs)*dpsifra(:nprofs)
      ywork(:nprofs) = ywork(:nprofs)*dpsifra(:nprofs)
      dcurr(nprofs) = 1.E-6*simp(nprofs,dra,xwork)
      pscur = 1.E-6*simp(nprofs,dra,ywork)
      ywork(:nprofs) = pqr(:nprofs,1)*ajbsb(:nprofs)*dpsifra(:nprofs)/
     1   dbt2(:nprofs)
      aibs = 2.*zpi*1.E-6*simp(nprofs,dra,ywork)
      tcurr = zcurr(nprofs)                      ! Equlibrium current
      fbsc = abs(aibs/tcurr)                     ! bootstrap fraction
c $$$$$  TK Mau  12/6/94
      fdia = dcurr(nprofs)/tcurr          ! diamagnetic current fraction
      fpfs = pscur/tcurr
c $$$$$$$$$$$
c ---- Define toroidal current density profile
c     call cubspl(dra,zcurr,nprofm,nprofs)
c     ajtor(1) = ajtb(1)/baxis
c     ajtrt(1) = ajtor(1)
      ajbst(1) = 0.
      ajtar(1) = ajtor(1)
c     ajtor(i3) = zcurr(i3,2)/zsurf(i3)*dra*1.e6
c     ajtor(i3) = ajtb(i3)*bttra(i3)/dbt2(i3)
c     ajtrt(i3) = ajtrb(i3)*bttra(i3)/dbt2(i3)   ! A/m**2
c     ajbst(i3) = ajbsb(i3)*bttra(i3)/dbt2(i3)    ! A/m**2
      ajbst(2:nprofs) = ajbsb(2:nprofs)*drt1(2:nprofs)*dbtp2(2:nprofs)/
     1   dbt2(2:nprofs)/dbt1r(2:nprofs)          ! <j_bs,tor>
      ajtar(2:nprofs) = ajtor(2:nprofs) - ajbst(2:nprofs) - ajdit(2:
     1   nprofs)                                 ! <j_tar,tor>
c ----   TKM   09/99
c ---- Calculate total seed current as function of radius
      aisdt(1) = 0.
      do j1 = 2, nprof
         aisdt(j1) = aisdt(j1-1) + 0.5E-6*(ajtar(j1)*zsurf(j1)+ajtar(j1-
     1      1)*zsurf(j1-1))
      end do
c -------------------------
c ---- Calculate seed and reverse current components
      j1 = 1
      i4 = 2
  190 continue
      aiseed(j1) = 0.
  191 continue
      aiseed(j1) = aiseed(j1) + 0.5E-6*(ajtar(i4)*zsurf(i4)+ajtar(i4-1)*
     1   zsurf(i4-1))
      i4 = i4 + 1
      if (i4 > nprofs) return
      ratioj = ajtar(i4)/ajtar(i4-1)
      if (ratioj < 0.) then
         j1 = j1 + 1
c ---- TKM   6/99
         if (j1 > 10) return
c -------------------
         go to 190
      else
         go to 191
      endif
c
      return
      end subroutine profin
c
c
      subroutine profix
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c      this subroutine evaluates the local values of the
c      density, temperature, rotational transform, etc.,
c      required for integration of the ray equations,
c      using the spline interpolation initialized in profin.
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vceqdsk
      use Vcmnew
!      USE Vcmalfa
!      USE Vfwcd2
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, k, j
      real(kind=dp), dimension(nprofm,4) :: dumf
      real(kind=dp) :: zfacq, zfluxq, ztanq, zcosq2, zdq, ff, dffp,
     1    dpsifdra,
     1   ddpsifra, ru, zfacb, dbpsi, dbth
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real(kind=dp) , EXTERNAL :: valspl
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95

c
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

c $$$$$$      TKM    04/00
c$$$$$$$     TKM    11/98
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ************ ************ ************ ************ ************
c
!      left = ifix(psi/dpsi) + 1
      left = int(psi/dpsi) + 1
      hh = psi - tpsi(left)
      if (left > nprof) then
         left = nprof
         hh = 0.0
      endif
c
      dense = valspl(hh,tne,nprofn,left,0)
      derdne = valspl(hh,tne,nprofn,left,1)/max(dense,1.E-20_dp)
      tempe = valspl(hh,tte,nprofn,left,0)
      derte = valspl(hh,tte,nprofn,left,1)/max(tempe,1.E-20_dp)
      vloop = valspl(hh,tvlp,nprofn,left,0)
c------------------------SCC   4/23/96
      zeff = valspl(hh,tzeff,nprofn,left,0)
      if (alpene<0 .and. alpte<=0) trati(nion) = valspl(hh,ttani,nprofn,
     1   left,0)
c
      do i = 1, nspec
         densi(i) = valspl(hh,tni(1,1,i),nprofn,left,0)
         tempi(i) = valspl(hh,tti(1,1,i),nprofn,left,0)
         derdni(i) = valspl(hh,tni(1,1,i),nprofn,left,1)/max(densi(i),
     1      1.E-20_dp)
         derti(i) = valspl(hh,tti(1,1,i),nprofn,left,1)/max(tempi(i),
     1      1.E-20_dp)
         aconc(i) = valspl(hh,tconc(1,1,i),nprofn,left,0)
c          zeff=zeff+aconc(i)*azi(i)*azi(i)
      end do
      if (kalfa /= 0) then
         do k = 1, nalfa
            dumf(:nprof,:) = tnf(k,:nprof,:)
            densa(k) = pnfi(k,1)*valspl(hh,dumf,nprofn,left,0)
            densa(k) = max(0.0_dp,densa(k))
            dumf(:nprof,:) = ttf(k,:nprof,:)
            temsa(k) = ptfi(k,1)*valspl(hh,dumf,nprofn,left,0)
            if (temsa(k) < 0.) temsa(k) = 1.
         end do
      endif

c  ztanq = tan(cap_theta) * B_tau/B_phi (Eq. 5.24 of IPP 4/210).
      zfacq = urplas*antau/aj
      zfluxq = valspl(hh,tqr,nprofn,left,0)
      ztanq = zfacq*zfluxq
      zcosq2 = 1./(1. + ztanq*ztanq)
      acostq = btsign*sqrt(zcosq2)
      asintq = ztanq*acostq
c
c  dqpsi = d(cap_theta)/d(psi)
c  dqth  = d(cap_theta)/d(psi)

      zdq = ztanq*zcosq2
      dqpsi = zdq*(valspl(hh,tqr,nprofn,left,1)/zfluxq + dntaup - djp)
      dqth = zdq*(dntaut - djt)
c
      if (ieqdsk <= 2) then
c
         dompsi = (-dxpsi/urhs) + ztanq*dqpsi
         domth = (-dxth/urhs) + ztanq*dqth
c
         btor = baxis*uraxmag/urhs
         bpol = ztanq*btor
         btot = btor/acostq
c
      else
c
         ff = valspl(hh,fra,nprofn,left,0)
         dffp = valspl(hh,fra,nprofn,left,1)
         dpsifdra = valspl(hh,tpsif,nprofn,left,1)
         ddpsifra = valspl(hh,tpsif,nprofn,left,2)

         ru = xu + raxmag
         btor = ff/ru
         bpol = dpsifdra*antau/(aj*ru)*ukzero
         btot = sqrt(btor**2 + bpol**2)

         zfacb = ukzero**2*antau/(urhs*aj)

c  dbpsi = 1/btot * d(btot)/d(psi)
         dbpsi = 1./btot**2*(btor/ru*(dffp - ff*dxpsi/urhs) + zfacb**2*
     1      dpsifdra*ddpsifra + zfacb**2*((-dxpsi/urhs) + dntaup - djp)*
     2      dpsifdra**2)
         dbth = 1./btot**2*((-btor**2/urhs*dxth) + zfacb**2*((-dxth/urhs
     1      ) + dntaut - djt)*dpsifdra**2)

         dompsi = dbpsi + ztanq*dqpsi
         domth = dbth + ztanq*dqth

      endif
c
      return
      end subroutine profix

      function prone (psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c--------------------- ----------------------------------
c analytic fit to the electron density profile
c--------------------- ----------------------------------
c  ******  c ---old---  data       pint  /3.0/,       pext /2.3/
c  ******               data       pint  /2.0/,       pext /1./
c  ******  c--------------------- ----------------------------------
c  ******           prone = 0.1 + 0.9*((1.-psi**pint)**pext)
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
!      use Vcraylh
!      use Vchpcsd
!      use Vceqdsk
!      use Vcmnew
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) prone
      real(kind=dp) psi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c     dimension acoef(4)
c
c--------------------------------------------------------------------
c shot 26468
c     data acoef /-1.87, -0.57, -24.78, -181.38/
c--------------------------------------------------------------------
c     x=rplasm*psi
c     x2=x*x
c     arg = acoef(4)
c     do 10  i=1,3
c10   arg=arg*x2 + acoef(4-i)
c     prone = exp(arg)
c     prone = denedg + (denc-denedg)*(1.-psi**gamene)**alpene
c**************    TKM    2/97
c     print *, 'In function prone'
c     print *, 'In psi     = ',psi
c     print *, 'In denc    = ',denc
c     print *, 'In denedg  = ',denedg
c     print *, 'In frcne   = ',frcne
c     print *, 'In alpene  = ',alpene
c     print *, 'In alpene1 = ',alpene1
c     print *, 'In gamene  = ',gamene
c     print *, 'In gamene1 = ',gamene1
      prone = denc*(denedg + (1. - denedg)*(frcne*(1. - psi**gamene)**
     1   alpene + (1. - frcne)*(1. - psi**gamene1)**alpene1))
c*********************************
      return
      end function prone
c
      subroutine prontp
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c-------------------
c   From pressure profile ppra(1:nprofs) calculate
c   electron density profile pne(1:nprofs)
c   electron temperature profile pte(1:nprofs)
c   ion temperature profile  pti(1:nprofs)
c  Also input:
c       atomic wts  atm(1:nion)
c       charges     azi(1:nion)
c       concentration aconc(1:nion)
c       (Note:  conci(1:nion)=aconc(1:nion)*azi(1:nion))
c       central electron density    denc
c       z-effective        zeff
c     nprim   No. primary ion species
c     nimp    No. impurity species
c-------------------------------------
c*************  TKM  2/97, 8/98, 2/00
c Add input: ffast=fast pressure fraction
c            tite=ratio of Ti to Te
c All species have same n and T profiles, but n.ne.T
c     Seven options for profile specifications:
c     1. input: alpte = 0, alpene = 0, denc
c        profile: n=T=sqrt(p)
c        Given ne0 and Te0=0, calculate Te0 from p0,
c        and vice versa.
c     2. input: alpte > 0, alpene = 0
c        Given Te and Ti/Te, calculate n from p
c     3. input: alpene > 0, alpte = 0
c        Given n, Ti/Te, calculate Te from p
c     4. input: alpte < 0, alpene = 0,  gamene .ne. 0
c        Thermal plasma and beam profiles are separately given as
c        functions of rho in ONETWO output file.
c     5. input: alpte = 0, alpene < 0
c        Thermal plasma and beam profiles are given in TRANSP output
c        file given by Petty (GA). Input file : transp_ga.out
c     6. input: alpte < 0, and alpene < 0
c        Thermal plasma profiles and loop voltages are transfered from
c        TRANSP as functions of rho.
c     7. input: alpte > 0, alpene > 0
c        n and T profiles not necessarily consistent with p profile
c        Used for exploring initial HHFW results on NSTX
c     8. input: alpte > 0, alpene > 0, gamene < 0
c        Same as 7, except profile is given as function of r/a,
c        where r is half-radius, with gamene = |gamene|.
c     9. input: alpte < 0, alpene = 0,  gamene = 0
c        Electron temperature and density profiles are separately
c        given as functions of psi in output file, nstx.out.
c        For NSTX analysis (2001 Research Forum)
c**************************************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vparam
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vceqdsk
      use Vcmnew
      use Vctransp
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: ngd0 = 101
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer::nrho1,i,j,iu,ir,ii,l,nrho,ji,ij,ix,nai,nzi,ihm,iy,k
      integer::nrho2
      real(kind=dp), dimension(201) :: pwork
      real(kind=dp), dimension(nxa) :: qeqd1
      real(kind=dp), dimension(nprofm) :: qeqd2
      real(kind=dp), dimension(nxa) :: raa
      real(kind=dp), dimension(ngd0) :: xrho, yne, yte
      real(kind=dp), dimension(ngd0,nions) :: yni, yti
      real(kind=dp), dimension(ngd0) :: wwork1, wwork2, wwork3
      real(kind=dp) :: hconc, sum, sumx, draa, dra, file, status
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: prote, prone
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95

c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

c********************************************
c  6/26/91,  Latest update: 06/02/00
c     Comnew
cNew common added for FWCD
c  Storage related to FWCD:
cSubroutines displh inital use Comnew1


c******      TKM   03/97, 09/99, 04/00, 06/00
c********************

c
c----------------------
c************    TKM     06/97, 11/98
c ************ ************ ************ ************ ************
c
c$$$$$$    TKM    11/98
      data nrho1/41/
      data hconc/0.02/
c
c     Set default value of thermal anisotropy  to unity.
      ppra(:nprofs,1) = max(1.E-6_dp,ppra(:nprofs,1))
      tani(:nprofs) = 1.0
      pwork(:nprofs) = ppra(:nprofs,1)/ppra(1,1)
c
c     Set default value of thermal anisotropy  to unity.
      nion = nprim + nimp
c     do i=1,nprofs
c       tne(i,1)=sqrt(pwork(i))
c       tte(i,1)=tne(i,1)
c       do j=1,nion
c         tti(i,1,j)=tne(i,1)
c       enddo
c     end do
c-------------
c    from denc and ppra(1) find
c   tempec,tempic(1:nion)
c--------------------
      conci(:nion) = aconc(:nion)*azi(:nion)
      sum = 0.
      do i = 1, nion
         sum = sum + conci(i)
      end do
      conci(:nion) = conci(:nion)/sum
      aconc(:nion) = conci(:nion)/azi(:nion)
c       do j=1,nprofs
c         tni(j,1,i)=tne(j,1)*aconc(i)
c       enddo
c------------------
c  total number density
c-------------------
c$$$$    TK Mau   6/98
      sum = 0.
      sumx = 0.
      do i = 1, nion
         sum = sum + aconc(i)
         sumx = sumx + aconc(i)*tite(i)*(1. + 2.*trati(i))/3.
      end do
c     dentot=denc*(1.+sum)
c*******    TKM    8/98
      if (alpte<0. .or. alpene<0.) go to 100
c****************  TKM   2/97
      if (alpte==0. .and. alpene==0.) then
         do i = 1, nprofs
            tne(i,1) = sqrt(pwork(i))
            tte(i,1) = (1. - temedg)*tne(i,1) + temedg
            tne(i,1) = (1. - denedg)*tne(i,1) + denedg
            tti(i,1,:nion) = tne(i,1)
            tni(i,1,:nion) = tne(i,1)*aconc(:nion)
         end do
         if (tempec < 1.E-10) then
            tempec = (1. - ffast)*ppra(1,1)/(1.6022E-10*denc*(1. + sum))
         else
            denc=(1.-ffast)*ppra(1,1)/(1.6022E-10*tempec*(1.+sumx))
         endif
      else
         if (alpte>0. .and. alpene==0.) then
            do i = 1, nprofs
               psi = float(i - 1)/float(nprofs - 1)
               tte(i,1) = prote(psi)/tempec
            end do
            if (kboot == 2) then
               draa = 1./float(nxeqd - 1)
               do iu = 1, nxeqd
                  raa(iu) = float(iu - 1)*draa
                  qeqd1(iu) = prote(raa(iu))/tempec
               end do
               dra = 1./float(nprofs - 1)
               do ir = 1, nprofs
                  ra(ir) = float(ir - 1)*dra
               end do
               call intrpp ('zero', 'zero', tpsieqd, qeqd1, nxeqd, ra,
     1            qeqd2, nprofs)
               tte(:nprofs,1) = qeqd2(:nprofs)
            endif
            do i = 1, nprofs
               tne(i,1) = (1. - denedg)*pwork(i)/tte(i,1) + denedg
c              tti(i,1,j)=proti(psi)/tempic(j)
c********    TKM    06/97
c    For now, only allow same Te and Ti, and same ne and ni profiles
               tti(i,1,:nion) = tte(i,1)
c***************************
               tni(i,1,:nion) = tne(i,1)*aconc(:nion)
            end do
            denc=(1.-ffast)*ppra(1,1)/(1.6022E-10*tempec*(1.+sumx))
         endif
         if (alpte==0. .and. alpene>0.) then
c           denc = denc*(1. - ffast)
            do i = 1, nprofs
               psi = float(i - 1)/float(nprofs - 1)
               tne(i,1) = prone(psi)/denc
            end do
            if (kboot == 2) then
               draa = 1./float(nxeqd-1)            !   TKM 05/02
               do iu = 1, nxeqd
                  raa(iu) = float(iu - 1)*draa
                  qeqd1(iu) = prone(raa(iu))/denc
               end do
               dra = 1./float(nprofs - 1)
               do ir = 1, nprofs
                  ra(ir) = float(ir - 1)*dra
               end do
               call intrpp ('zero', 'zero', tpsieqd, qeqd1, nxeqd, ra,
     1            qeqd2, nprofs)
               tne(:nprofs,1) = qeqd2(:nprofs)
            endif
            do i = 1, nprofs
               tte(i,1) = (1. - temedg)*pwork(i)/tne(i,1) + temedg
c*****    (Te,Ti) and (ne,ni) have same profiles
               tti(i,1,:nion) = tte(i,1)
               tni(i,1,:nion) = tne(i,1)*aconc(:nion)
            end do
            tempec=(1.-ffast)*ppra(1,1)/(1.6022E-10*denc*(1.+sumx))
         endif
c$$$$$     TKM    2/00, 10/00
c  For testing initial HHFW experiments on NSTX
c
         if (alpte>0. .and. alpene>0.) then
            if (gamene > 0.) then
               do i = 1, nprofs
                  psi = float(i - 1)/float(nprofs - 1)
                  tne(i,1) = prone(psi)/denc
                  tte(i,1) = prote(psi)/tempec
               end do
               if (kboot == 2) then
                  draa = 1./float(nxeqd)
                  do iu = 1, nxeqd
                     raa(iu) = float(iu - 1)*draa
                     qeqd1(iu) = prone(raa(iu))/denc
                  end do
                  dra = 1./float(nprofs - 1)
                  do ir = 1, nprofs
                     ra(ir) = float(ir - 1)*dra
                  end do
                  call intrpp ('free', 'free', tpsieqd, qeqd1, nxeqd, ra
     1               , qeqd2, nprofs)
                  tne(:nprofs,1) = qeqd2(:nprofs)
                  do iu = 1, nxeqd
                     qeqd1(iu) = prote(raa(iu))/tempec
                  end do
                  call intrpp ('free', 'free', tpsieqd, qeqd1, nxeqd, ra
     1               , qeqd2, nprofs)
                  tte(:nprofs,1) = qeqd2(:nprofs)
               endif
            else
               gamene = -gamene
               do ii = 1, nprofs
                  tte(ii,1) = prote(roa(ii))/tempec
                  tne(ii,1) = prone(roa(ii))/denc
               end do
            endif
            do i = 1, nprofs
               tti(i,1,:nion) = tte(i,1)
               tni(i,1,:nion) = tne(i,1)*aconc(:nion)
            end do
         endif
c$$$$$$$$$$$       2/00, 10/00
      endif
c***********************
c$$$$$$$$$$       01/01
  105 continue
      tempic(:nion) = tite(:nion)*tempec
c
      do l = 1, nprofs
         tzeff(l,1) = 0.
         pne(l) = denc*tne(l,1)
         pte(l) = tempec*tte(l,1)
         do j = 1, nion
            pti(l,j) = tempic(j)*tti(l,1,j)
            pni(l,j) = pne(l)*aconc(j)
            conc(l,j) = aconc(j)
            tzeff(l,1) = tzeff(l,1) + aconc(j)*azi(j)**2
         end do
      end do
      return
c
c***********   TK Mau   11/98
  100 continue
      if (alpene == 0.) then
         if (gamene /= 0) then
c   Open file 'onetwo.out' and read in data
            open(8, file='onetwo.out', status='old')
            read (8, *) nrho, hconc
            read (8, *) (xrho(i),i=1,nrho)
            read (8, *) (yne(i),i=1,nrho)
            do ji = 1, 3
               read (8, *) (yni(i,ji),i=1,nrho)
            end do
            read (8, *) (yte(i),i=1,nrho)
            do ij = 1, 3, 2
               read (8, *) (yti(i,ij),i=1,nrho)
            end do
            close(8)
            yti(:nrho,2) = yti(:nrho,1)
c   Interpolate Ne, Te, and Ti profiles onto uniform rho grids.
            dra = 1./float(nprofs - 1)
            do ir = 1, nprofs
               ra(ir) = float(ir - 1)*dra
            end do
            denc = yne(1)
            qeqd1(:nrho) = yne(:nrho)/denc
            call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, tne(1,1)
     1         , nprofs)
            tempec = yte(1)
            qeqd1(:nrho) = yte(:nrho)/tempec
            call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, tte(1,1)
     1         , nprofs)
            if (nion > 3) then
               yni(:nrho,nion) = yni(:nrho,nion-1)
               yni(:nrho,nion-1) = hconc*yni(:nrho,1)
               yni(:nrho,1) = (1. - hconc)*yni(:nrho,1)
               yti(:nrho,nion) = yti(:nrho,nion-1)
               yti(:nrho,nion-1) = yti(:nrho,1)
            endif
            do j = 1, nion
               tempic(j) = yti(1,j)
               qeqd1(:nrho) = yti(:nrho,j)
               call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, pti(1
     1            ,j), nprofs)
               qeqd1(:nrho) = yni(:nrho,j)
               call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, pni(1
     1            ,j), nprofs)
            end do
            do l = 1, nprofs
               tzeff(l,1) = 0.
               pne(l) = denc*tne(l,1)
               pte(l) = tempec*tte(l,1)
               do j = 1, nion
                  conc(l,j) = pni(l,j)/pne(l)
                  tzeff(l,1) = tzeff(l,1) + conc(l,j)*azi(j)**2
               end do
            end do
            return
c
c$$$$$$$   TKM   01/01
         else
            open(8, file='nstx.out', status='old')
            do ir = 1, 101
               read (8, *) xrho(ir), yne(ir), yte(ir)
            end do
            close(8)
            tempec = yte(1)
            denc = yne(1)
            yte = yte/tempec
            yne = yne/denc
            denc = 1.E-6*denc
            tempec = 1.E-3*tempec
            draa = 1./float(nxeqd - 1)
            do iu = 1, nxeqd
               raa(iu) = float(iu - 1)*draa
            end do
            call intrpp ('zero', 'free', raa, tpsieqd, nxeqd, xrho,
     1         wwork1, 101)
            dra = 1./float(nprofs - 1)
            do ir = 1, nprofs
               ra(ir) = float(ir - 1)*dra
            end do
            call intrpp ('zero', 'free', wwork1, yne, 101, ra, qeqd2,
     1         nprofs)
            tne(:nprofs,1) = qeqd2(:nprofs)*(0.9*(1. - ra(:nprofs)**8)+
     1         0.1)
c           tne(ir,1) = qeqd2(ir)
            call intrpp ('zero', 'free', wwork1, yte, 101, ra, qeqd2,
     1         nprofs)
            do ir = 1, nprofs
               tte(ir,1) = qeqd2(ir)
               tti(ir,1,:nion) = tte(ir,1)
               tni(ir,1,:nion) = tne(ir,1)*aconc(:nion)
            end do
            go to 105
         endif
c$$$$$$$$$$        01/01
      else
         if (alpte < 0.) go to 110
c   Open file 'transp_ga.out' and read in data
         open(8, file='transp_ga.out', status='old')
         read (8, *) nrho, nai, nzi, ihm
         read (8, *) (xrho(i),i=1,nrho)
         do j = 1, 3
            read (8, *) (yni(i,j),i=1,nrho)
         end do
         read (8, *) (yti(i,1),i=1,nrho)
         read (8, *) (yte(i),i=1,nrho)
         read (8, *) (wwork1(i),i=1,nrho)
         read (8, *) (wwork2(i),i=1,nrho)
         read (8, *) (wwork3(i),i=1,nrho)
         close(8)
c
c   Interpolate Te, Ni and Ti profiles onto uniform rho grids.
         dra = 1./float(nprofs - 1)
         do ir = 1, nprofs
            ra(ir) = float(ir - 1)*dra
         end do
         qeqd1(:nrho) = 1.E-3*yte(:nrho)
         call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, tte(1,1),
     1      nprofs)
         tempec = tte(1,1)
         pte(:nprofs) = tte(:nprofs,1)
         if (nion > 3) then
            yni(:nrho,nion) = yni(:nrho,nion-1)
            yni(:nrho,nion-1) = hconc*yni(:nrho,1)
            yni(:nrho,1) = (1. - azi(nion-1)*hconc)*yni(:nrho,1)
            yti(:nrho,nion) = yti(:nrho,nion-1)
            yti(:nrho,nion-1) = yti(:nrho,1)
         endif
c
         do j = 1, nion
            qeqd1(:nrho) = yni(:nrho,j)
            call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, pni(1,j)
     1         , nprofs)
            if (j < nion) then
               qeqd1(:nrho) = 1.E-3*yti(:nrho,1)
               call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, pti(1
     1            ,j), nprofs)
               tempic(j) = pti(1,j)
            endif
         end do
c   Construct electron density profile from charge neutrality
         do iy = 1, nprofs
            pne(iy) = 0.
            do j = 1, nion
               pne(iy) = pne(iy) + azi(j)*pni(iy,j)
            end do
         end do
         denc = pne(1)
c   Define parallel temperature and thermal anisotropy of energetic
c   ion species (j=nion)
         qeqd1(:nrho) = 2.*wwork2(:nrho)/(1.6022E-16*yni(:nrho,nion))
         qeqd2(:nrho) = 0.5*wwork1(:nrho)/wwork2(:nrho)
         call intrpp ('zero', 'free', xrho, qeqd1, nrho, ra, pti(1,nion)
     1      , nprofs)
         call intrpp ('zero', 'free', xrho, qeqd2, nrho, ra, tani,
     1      nprofs)
c
c**** Read in data from TRANSP runs: profiles as functions of rho
c
 110  continue
         if (alpte < 0.) then
c           open(8, file='transp.out', status='old')
c           nrho2 = nrho_tr-1
c----- Read in normalized toroidal flux coordinates
c           do i = nrho_tr,2,-1
c              xrho_tr(i) = xrho_tr(i-1)
c           enddo
c           xrho_tr(1) = 0.
c----- Interpolate ion and electron densities from TRANSP to 
c       CURRAY radial coordinates
            do k = 1,nion
c              wwork1(:nrho2) = ni_tr(:nrho2,k)
               wwork1(:nrho_tr) = ni_tr(:nrho_tr,k)
c              call grid_value(wwork1,nrho_tr)
               call intrpp('zero','free',xrho_tr,wwork1,nrho_tr,ra,
     &            wwork2,nprofs)
               pni(:nprofs,k) = wwork2(:nprofs)
            enddo
            wwork1(:nrho_tr) = ne_tr(:nrho_tr)
c           call grid_value(wwork1,nrho_tr)
            call intrpp('zero','free',xrho_tr,wwork1,nrho_tr,ra,
     &            pne,nprofs)
            denc = pne(1)
c----- Interpolate electron and ion temperatures from TRANSP onto
c       CURRAY radial coordinates
            wwork1(:nrho_tr) = te_tr(:nrho_tr)
c           call grid_value(wwork1,nrho_tr)
            call intrpp('zero','free',xrho_tr,wwork1,nrho_tr,ra,pte,
     &                  nprofs)
            pte(:nprofs) = pte(:nprofs)
            tempec = pte(1)
c----- Interpolate thermal ion temperature profile
            do k = 1,nion
               wwork1(:nrho_tr) = ti_tr(:nrho_tr,k)
c              call grid_value(wwork1,nrho_tr)
               call intrpp('zero','free',xrho_tr,wwork1,nrho_tr,
     &            ra,wwork2,nprofs)
               pti(:nprofs,k) = wwork2(:nprofs)
               tempic(k) = pti(1,k)
            enddo
c
c----- Interpolate loop voltage profile
c
            wwork1(:nrho_tr) = elp_tr(:nrho_tr)
            elp_tr(:nrho_tr) = 0.
            call intrpp('zero','free',xrho_tr,wwork1,nrho_tr,ra,
     &         elp_tr,nprofs)
c
c----- Read in fast alpha and IC resonant densities and energies, 
c      and convert energies to isotropic Maxwellian temperatures
c           do k = 6,nion
c              read(8,*) wwork1(:nrho2)
c              read(8,*) wwork2(:nrho2)
c              wwork1(:nrho2) = wwork1(:nrho2)+wwork2(:nrho2)
c              call grid_value(wwork1,nrho1)
c              call intrpp('zero','free',xrho,wwork1,nrho1,ra,wwork2,
c    &                     nprofs)
c              pti(:nprofs,k) = 4.160945e15*wwork2(:nprofs)/
c    &                          pni(:nprofs,k)
c           enddo
c           tempic(:nion) = pti(1,:nion)
c            if (nion /= 4) then
c               call link ('unit59=terminal//')
c              write (6, 881) nion
c 881          format("nion must be 4.")
c              stop 88
c           endif
c           open(8, file='neprof', status='old')
c           do i = 1, nrho1
c              read (8, *) xrho(i), wwork1(i)
c           end do
c           close(8)
c           call intrpp ('zero', 'free', xrho, wwork1, nrho1, ra, pne,
c    1         nprofs)
c           pne(:nprofs) = 1.E13*pne(:nprofs)
c           denc = pne(1)
c           open(8, file='teprof', status='old')
c           do i = 1, nrho1
c              read (8, *) xrho(i), wwork1(i)
c           end do
c           close(8)
c           call intrpp ('zero', 'free', xrho, wwork1, nrho1, ra, pte,
c    1         nprofs)
c           tempec = pte(1)
c           open(8, file='ncprof', status='old')
c           do i = 1, nrho1
c              read (8, *) xrho(i), wwork1(i)
c           end do
c           close(8)
c           call intrpp ('zero', 'free', xrho, wwork1, nrho1, ra, wwork2
c    1         , nprofs)
c           pni(:nprofs,2) = 1.E-2*wwork2(:nprofs)*pne(:nprofs)
c           wwork3(:nprofs) = pne(:nprofs) - azi(2)*pni(:nprofs,2) - azi
c    1         (nion)*pni(:nprofs,nion)
c           pni(:nprofs,1) = (1. - hconc)*wwork3(:nprofs)
c           pni(:nprofs,nion-1) = hconc*wwork3(:nprofs)
c           open(8, file='tiprof', status='old')
c           do i = 1, nrho1
c              read (8, *) xrho(i), wwork1(i)
c           end do
c           close(8)
c           call intrpp ('zero', 'free', xrho, wwork1, nrho1, ra, pti(1,
c    1         1), nprofs)
c           tempic(1) = pti(1,1)
c           do k = 2, nion - 1
c              pti(:nprofs,k) = pti(:nprofs,1)
c              tempic(k) = pti(1,k)
c           end do
         endif
c
c*********************************
c
         do l = 1, nprofs
            tzeff(l,1) = 0.
            do j = 1, nion
               conc(l,j) = pni(l,j)/pne(l)
               tzeff(l,1) = tzeff(l,1) + conc(l,j)*azi(j)**2
            end do
         end do
      endif
      return
      end subroutine prontp
c
      subroutine grid_value(x,n)
c
      use kind_spec
      implicit none
      integer n,n1,i
      real(kind=dp), dimension(101) :: x, y
c
      n1 = n-1
      y(:n1) = x(:n1)
      x(2) = 0.5*(y(1)+y(2))
      x(1) = 2.*y(1)-x(2)
      do i = 3,n
         x(i) = 2.*Y(i-1)-x(i-1)
      enddo
      return
      end subroutine grid_value
c
      function prote(psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c--------------------- ----------------------------------
c analytic fit to the electron temperature profile
c--------------------- ----------------------------------
c  ******        data       pint  /2.0/,       pext /2.0/
c  ******        data       edge  /0.1/
c  ******  c--------------------- ----------------------------------
c  ******           prote = edge + (1.-edge)*(1.-psi**pint)**pext
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
!      use Vcraylh
!      use Vchpcsd
!      use Vceqdsk
!      use Vcmnew
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) prote
      real(kind=dp) psi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c     dimension acoef(4)
c
c--------------------------------------------------------------------
c shot 26471
c     data acoef /7.51, -13.45, 6.21, -125.64/
c--------------------------------------------------------------------
c     x=rplasm*psi
c     x2=x*x
c     arg = acoef(4)
c     do 10  i=1,3
c10   arg=arg*x2 + acoef(4-i)
c     prote = exp(arg)
c     prote=temedg + (tempec-temedg)*(1.-psi**gamte)**alpte
c**********   TKM   2/97
      prote = tempec*(temedg + (1. - temedg)*(frcte*(1. - psi**gamte)**
     1   alpte + (1. - frcte)*(1. - psi**gamte1)**alpte1))
c***************************
      return
      end function prote

      function proti (psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c--------------------- ----------------------------------
c analytic fit to the ion temperature profile
c--------------------- ----------------------------------
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
!      use Vcraylh
!      use Vchpcsd
!      use Vceqdsk
!      use Vcmnew
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) psi
      real(kind=dp) proti
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c     data       pint  /2.0/,       pext /1.0/
c     data       edge  /0.1/
c--------------------- ----------------------------------
c     proti = tiedg +(tempic(1)-tiedg)*(1.-psi**gamti)**alpti
c************  TKM   2/97
      proti = tempic(1)*(tiedg + (1. - tiedg)*(frcti*(1. - psi**gamti)**
     1   alpti + (1. - frcti)*(1. - psi**gamti1)**alpti1))
c****************************
      return
      end function proti
c
      subroutine subpar(psival, dene, teme, zef)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
c
c   given psi-value, evaluate densities and temperatures,and zeffective
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vceqdsk
      use Vcmnew
      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) psival, dene, teme, zef
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real(kind=dp) , EXTERNAL :: valspl
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.


c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95

c
c     dimension temi(nspi),deni(nspi)
c
c ************ ************ ************ ************ ************
c
      psi = psival
!      left = ifix(psi/dpsi) + 1
      left = int(psi/dpsi) + 1
      hh = psi - tpsi(left)
      if (left > nprof) then
         left = nprof
         hh = 0.0
      endif
c
      dene = valspl(hh,tne,nprofn,left,0)
      teme = valspl(hh,tte,nprofn,left,0)
c
      zef = 0.
      do i = 1, nspec
c          deni(i) = valspl(hh,tni(1,1,i),nprofn,left,0)
c          temi(i) = valspl(hh,tti(1,1,i),nprofn,left,0)
         aconc(i) = valspl(hh,tconc(1,1,i),nprofn,left,0)
c          zef=zef+aconc(i)*azi(i)*azi(i)
      end do
      zef = valspl(hh,tzeff,nprofn,left,0)
      return
      end subroutine subpar


c     The following subroutines tdxin13d, profaxis are from cql,
c        and can be used to produce parabolic profiles.
c
c
c
      subroutine tdxin13d(a, rya, rs, lrz, m, k, expn1, expm1)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:40   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
!      use Viorlh
!      use Vcraylh
!      use Vchpcsd
!      use Vceqdsk
!      use Vcmnew
      use Vsizes
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lrz, m, k
      real(kind=dp) rs, expn1, expm1
      real(kind=dp), dimension(m,0:lrz) :: a
      real(kind=dp), dimension(0:lrz) :: rya
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: ll
      real(kind=dp) :: dratio, rn

      save dratio, ll, rn
c
c
c     this is a utility parabloic "fill in" routine
c
c                                                ! was 1.e-90
      if (abs(a(k,0)) <= smallest) a(k,0) = smallest
      dratio = a(k,1)/a(k,0)
      do ll = 1, lrz
         call profaxis (rn, expn1, expm1, dratio, rya(ll))
         a(k,ll) = a(k,0)*rn
      end do
      return
      end subroutine tdxin13d
