c
c  this module contains routines for computing magnetic field geometry
c----------------------------------------------------------------------
c
      subroutine bfield(psic, thetac, bfld)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      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   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) psic, thetac, bfld
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   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
      if (psic > 0.) then
         psi = psic
         theta = thetac
         call coords
         call profix
         bfld = btot
         return
      endif
      bfld = beqd
      return
      end subroutine bfield
c
      subroutine coords
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb
c
c   ****************************************************************
c   *                                                              *
c   *      this modulus evaluates x,z, their derivatives           *
c   *           with respect to psi and theta, and the             *
c   *           metric elements for use in the ion cyclotron       *
c   *           ray tracing program                                *
c   *                                                              *
c   ****************************************************************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh
      use Vceqdsk
      use kind_spec

      implicit none
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: lmhd, i, id, ier
      real(kind=dp), dimension(3) :: zbx0, zbx1, zbx2, zbz0
      real(kind=dp) :: twopi, zh, zph, zcosph, zsinph, zzss, zzcs,
     1    zzdcos, zddxpp
     1   , zddxpt, zddxtt, zddzpp, zddzpt, zddztt, theta1, zntau2
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
c
      data twopi/6.28318530717959/
c

      if (ieqdsk <= 2) then
c   ****************************************************************
c   Evaluation of plasma shape coords and derivatives
c   from Brambilla representation of the flux surfaces:
c   ****************************************************************


         psi = max(accur,psi)
c
         acosth = cos(theta)
         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)
         if (lmhd > nmhd) then
            lmhd = nmhd
            zh = 0.0
         endif
c
         do i = 1, 3
            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)
         zsinph = sin(zph)
         zzss = zsinph*asinth
         zzcs = zcosph*asinth
         zzdcos = 1. - zbx2(1)*acosth
c
         ux = zbx0(1) + zbx1(1)*zcosph
         uz = zbz0(1)*asinth
c
         urhs = uraxmag + ux
c
         dxpsi = zbx0(2) + zbx1(2)*zcosph + zbx1(1)*zbx2(2)*zzss
         dxth = -zbx1(1)*zsinph*zzdcos
c
         dzpsi = zbz0(2)*asinth
         dzth = zbz0(1)*acosth
c
         zddxpp = zbx0(3) + zbx1(3)*zcosph + (2.*zbx1(2)*zbx2(2)+zbx1(1)
     1      *zbx2(3))*zzss - zbx1(1)*zbx2(2)*zbx2(2)*zzcs*asinth
         zddxpt = ((-zbx1(2)*zsinph)+zbx1(1)*zbx2(2)*zzcs)*zzdcos + zbx1
     1      (1)*zbx2(2)*zsinph*acosth
         zddxtt = -zbx1(1)*(zcosph*zzdcos*zzdcos + zbx2(1)*zzss)
c
         zddzpp = zbz0(3)*asinth
         zddzpt = zbz0(2)*acosth
         zddztt = -uz


      else
c   ****************************************************************
c   Evaluation of plasma shape coords and derivatives from
c   EQDSK representation of flux surfaces:
c   ****************************************************************


c        Get a theta1 value corresponding to theta, in [0.,twopi):
         if (theta >= 0.) then
            theta1 = mod(theta,twopi)
         else
            theta1 = mod((-theta),twopi)
            theta1 = twopi - theta1
         endif

         call dbcevl1 (thet, nptsd, ra, nprof, csplnx, nptsdm1, theta1,
     1      psi, pdsx, ier, 6)
         call dbcevl1 (thet, nptsd, ra, nprof, csplnz, nptsdm1, theta1,
     1      psi, pdsz, ier, 6)

c        xu is distance (meters) measured from magnetic axis.
c        zu is from equatorial plane.
         xu = pdsx(1) - raxmag
         zu = pdsz(1)

         ux = xu*ukzero
         uz = zu*ukzero
         urhs = pdsx(1)*ukzero

         dxpsi = pdsx(3)*ukzero
         dxth = pdsx(2)*ukzero
         dzpsi = pdsz(3)*ukzero
         dzth = pdsz(2)*ukzero

         zddxpp = pdsx(6)*ukzero
         zddxpt = pdsx(4)*ukzero
         zddxtt = pdsx(5)*ukzero
         zddzpp = pdsz(6)*ukzero
         zddzpt = pdsz(4)*ukzero
         zddztt = pdsz(5)*ukzero


      endif


c
c   ****************************************************************
c
c   evaluation of the jacobian, g, ntau, and derivatives
c
c   ****************************************************************
c
      zntau2 = dxth*dxth + dzth*dzth
      antau = sqrt(zntau2)
      aj = dxpsi*dzth - dzpsi*dxth
      ag = dxpsi*dxth + dzpsi*dzth
c
c  log. deriv. of antau & aj, ord. deriv. of ag
c
      dntaup = (dxth*zddxpt + dzth*zddzpt)/zntau2
      dntaut = (dxth*zddxtt + dzth*zddztt)/zntau2
      djp = (zddxpp*dzth + zddzpt*dxpsi - zddxpt*dzpsi - zddzpp*dxth)/aj
      djt = (zddxpt*dzth + zddztt*dxpsi - zddxtt*dzpsi - zddzpt*dxth)/aj
      dgp = zddxpp*dxth + zddxpt*dxpsi + zddzpp*dzth + zddzpt*dzpsi
      dgt = zddxpt*dxth + zddxtt*dxpsi + zddzpt*dzth + zddztt*dzpsi
c
      return
      end subroutine coords
c
      subroutine fiteqdsk
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb

c     Obtain equilibrium data for ray tracing from EQDSK (ieqdsk.ge.3).
c     For ieqdsk.ge.3, replaces subroutine metrin, and most of profin.
c     For ieqdsk.eq.4, the extended eqdsk is used for plasma profiles.
c     Data is read from a file connected to iounit1.
c     Take   psi  (Brambilla) = normalized ONETWO rho coord,
c                               (sqrt(toroidal flux/bzero)).
c            theta(Brambilla) = ordinary angle on flux surface,
c                               measured about the magnetic axis.
c     Set up splines of X(theta,psi),Z(theta,psi) to be used for
c       the tokamak magnetic geometry.
c     Set other tokamak parameters.
c     If ieqdsk.eq.4, then set up plasma temp and density profiles
c       from data on an extended EQDSK.
c
c     This version corrects for difference in sign convention
c     between Brambilla's phi and EFIT's phi (toroidal angle)
c      Feb. 9,1994. SCC
c------------------------------

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh, only: imax,ukzero, urplas, uraxmag, raxmag, xmin,
     1   xmax, baxis, dpolas, dd, psi, theta, zsurf, volume, pqr,
     2   ppra, ppra1, tpsif, dpsi, tqr, tzeff
      use Vceqdsk
      use Vcmnew, only: dlob, zetab, enbeam, wbeam, lrza,
     1                  ebkev, bmpwr, azf, atmf, nalfa, pnfi, pnf
      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, j, ix, iz, ierr, inset, iounitx, iauto, iautoc, ier,
     1   jj, i1, jmd, jmd1, jmd2, ir, k, kdeu, nbeams, niont
      real(kind=dp), dimension(nxa) :: fpeqd
      real(kind=dp), dimension(nprofm) :: ywork, xwork
      real(kind=dp), dimension(lrza) :: dumf
      real(kind=dp), dimension(nprofm) :: dumf1, dv, ds
      real(kind=dp) :: frcpr, gampr, alppr, gampr1, alppr1, zpi, amu0,
     1    err, end,
     1   pres0, delpsi, psin, bisign, delx, delz, dra, xminc, xmaxc,
     2   zminc, zmaxc, ddx, ddz, xcmin, xcmax, zcmin, zcmax, zxcmin,
     3   zxcmax, xzcmin, xzcmax, dthet, cost, sint, psiang, cosdd, ddd,
     4   rminor, dv1, dlp, bp1, rad1, bt1, dlpbp, dl, bpsep, rmina,
     5   bpedge, hconc, zdecay, enetot, ene00, ratden
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: max0
      real(kind=dp) , EXTERNAL :: 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  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

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 $$$$  Added by TK Mau on 2/26/92.
c $$$$$$      TKM     04/00
c  $$$$   TK Mau    9/28/94, 06/00
      data frcpr,gampr,alppr,gampr1,alppr1/0.55,2.25,0.0,1.0,2.0/
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      zpi = 4.*atan2(1.,1.)
c $$$$   TK Mau   10/13/92
      amu0 = zpi*4.E-7
c $$$$$$$$$$$$$$$$$
c
c   First change sign of relevant quantities to correct for difference
c   in sign convention between Brambilla's phi and EFIT's phi
c   Definition of vec(B) is
c       vec(B)=f(psi)*grad(phi(Bram)) + grad(phi(Bram)) x grad(psi)
c------------------------------------
c$$$$$$   TKM    06/00
c     Use analytic form for pressure profile
      if (alppr > 0.) then
         pres0 = presseqd(1)
         delpsi = 1./float(nxeqd - 1)
         do i = 1, nxeqd
            psin = delpsi*float(i - 1)
            presseqd(i) = pres0*(frcpr*(1. - psin**gampr)**alppr + (1.
     1          - frcpr)*(1. - psin**gampr1)**alppr1)
            ppeqd(i) = -pres0*(frcpr*alppr*gampr*psin**(gampr - 1.)*(1.
     1          - psin**gampr)**(alppr - 1.) + (1. - frcpr)*alppr1*
     2         gampr1*psin**(gampr1 - 1.)*(1. - psin**gampr1)**(alppr1
     3          - 1.))
            ppeqd(i) = ppeqd(i)/(psilim - psimag)
         end do
      endif
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c     psimag = -psimag
c     psilim = -psilim
      beqd = -beqd
      toteqd = -toteqd
c     psisep = -psisep
      feqd(:nxeqd) = -feqd(:nxeqd)
c*****   TKM   06/97
c     ffpeqd(:nxeqd) = -ffpeqd(:nxeqd)
c*********************
c     ppeqd(:nxeqd) = -ppeqd(:nxeqd)
c     peqd(:nxeqd,:nzeqd) = -peqd(:nxeqd,:nzeqd)
      btsign = sign(1.0_dp,beqd)
      bisign = sign(1.0_dp,toteqd)
c**********     TKM     3/97
c  Adjust plasma pressure for ARIES-ST studies of HHFW heating
      presseqd(:nxeqd) = presfr*presseqd(:nxeqd)
      ppeqd(:nxeqd) = presfr*ppeqd(:nxeqd)
c*******************************
      if (psiadj /= 0.0) then
c     Adjust psi values slighlty (a kluge to cope with eqdsks
c     for which the plasma is a little too close to the grid boundary):
         write (59, 8291) psiadj
 8291    format("adjusting psi-values by fractional amount",f10.3)
         delpsi = psiadj*(psimag - psilim)
         peqd(:nxeqd,:nzeqd) = peqd(:nxeqd,:nzeqd) - delpsi
         psimag = psimag - delpsi
         psimx1 = psimx1 - delpsi
         psimx2 = psimx2 - delpsi
      endif
c
c     xeqd,zeqd-grid where xeqd is major radius:
      delx = xdimeqd/(nxeqd - 1.)
      delz = zdimeqd/(nzeqd - 1.)
      do ix = 1, nxeqd
         xeqd(ix) = redeqd + (ix - 1)*delx
      end do
      do iz = 1, nzeqd
         zeqd(iz) = zmideqd - 0.5*zdimeqd + (iz - 1)*delz
      end do

c     tpsifeqd: eqdsk poloidal flux function-coordinate,
c     equispaced from psimag to psilim.
      dpolflx = (psilim - psimag)/(nxeqd - 1)
      do ix = 1, nxeqd
         tpsifeqd(ix) = psimag + (ix - 1)*dpolflx
      end do
c*************   TKM    2/97
c     Calculate mod-B values for plotting
c     Useful for low-aspect-ratio and/or high-beta tokamaks
      call modb
c****************************************
c
c     Obtain toroidal flux as a function of the equispaced poloidal flux:
c
      call trap2 (tpsifeqd, qeqd, torflux, nxeqd)
c
c     Holger St. John sign convention of torflux (see subroutine
c     reqdsk in ONETWO).
c****************************
      torflux(:nxeqd) = -2.*zpi*torflux(:nxeqd)
c****************************
c     Obtain the tpsieqd grid (ONETWO radial variable on equispaced poloidal
c     flux function grid, from the magnetic axis to the plasma edge).
      tpsieqd(:nxeqd) = sqrt(abs(torflux(:nxeqd)/(zpi*beqd)))

      tpsisav = tpsieqd(nxeqd)

c     Normalize:
      tpsieqd(:nxeqd) = tpsieqd(:nxeqd)/tpsisav

c     Define normalized equispaced radial grid ra (nprof in length,
c     extending past plasma surface at ra(nprofs)=1.).

      dra = 1./(nprofs - 1.)
      do j = 1, nprofs
         ra(j) = (j - 1.)*dra
      end do

c     Interpolate poloidal flux function onto the ra grid,
c     (ra(1) to ra(nprofs)) to get psifra:

      call intrpp ('free', 'free', tpsieqd, tpsifeqd, nxeqd, ra, psifra
     1   , nprofs)

c     Calculate the flux surface contours corresponding to psifra:


c     First bicubic spline peqd (and since cntour needs max peqd on axis,
c     temporarily invert peqd):
      peqd(:nxeqd,:nzeqd) = -peqd(:nxeqd,:nzeqd)*bisign

c     Check adaquate length for wnoperm:
      if (2*nxeqd*nzeqd + 2*max(nxeqd,nzeqd) > inoperm1) stop 42
      call ibcccu(peqd,xeqd,nxeqd,zeqd,nzeqd,cspln,nxeqd,wnoperm,ierr)

      peqd(:nxeqd,:nzeqd) = -peqd(:nxeqd,:nzeqd)*bisign

c     To get contours at nprofs surfaces:

      if (nptsd > nptsdm - 4) stop 43
      xcontr(:nptsd,1) = xma
      zcontr(:nptsd,1) = zma
      ncontr(1) = nptsd

c     The contour search area can be restricted by an amount
c     inset, from the grid boundary.  St. John uses inset=1 in some
c     D3D eqdsk cases to avoid difficulties near the coils.

      inset = 0
      xminc = xeqd(1+inset)
      xmaxc = xeqd(nxeqd-inset)
      zminc = zeqd(1+inset)
      zmaxc = zeqd(nzeqd-inset)
c      nptsdm1 = 120           Set in var.br
c      bperr = 1.e100         Set in var.br
c      dang = 4.0             Set in var.br
c      arcl = 1.e100          Set in var.br
      iounitx = 0
      iauto = 1
      ddx = 0.0
      ddz = 0.0

      do j = 2, nprofs
c     As the bndry is neared, specify step size for contour finding:
         if (j >= nprofs - 1) then
            ddx = 0.5*delx
            ddz = 0.5*delz
         endif
         call cntour (xma, zma, (-bisign*psifra(j,1)),xcmin,xcmax,zcmin,
     1      zcmax,zxcmin,zxcmax,xzcmin,xzcmax,dang,arcl,bperr,ddx,ddz,
     2      xminc,xmaxc,zminc,zmaxc,iauto,iautoc,xcontr(1,j), zcontr(1,j
     3      ), ncontr(j), xeqd, nxeqd, zeqd, nzeqd, cspln, 2, 2*nzeqd,
     4      iounitx, nptsdm1, ierr, bpcontr(1,j), 0)
c     To check angles with DDT:
         imax = ncontr(j)
         anglex(:imax) = atan2(zcontr(:imax,j)-zma,xcontr(:imax,j)-xma)*
     1      180./zpi
      end do
c
c     Check that the ncontr(j) = ntpsd:
      do j = 1, nprofs
         if (ncontr(j) /= nptsd) stop 44
      end do


c     Extend contours beyond plasma edge:
c     (Form additional contours outside the boundary flux surface
c     by extending along each ray which originates at the magnetic
c     axis, by a distance such that the additional flux surfaces are
c     (ra(jj)-1.)*tpsisav beyond the boundary flux surface).

c     Theta vector:
      dthet = 2.*zpi/(nptsd - 1.)
      do i = 1, nptsd
         thet(i) = (i - 1)*dthet
      end do

      do j = 1, nptsd
         cost = cos(thet(j))
         sint = sin(thet(j))
c     Get dirn. of normal to flux surface
         call dbcevl1 (xeqd, nxeqd, zeqd, nzeqd, cspln, nxeqd, xcontr(j,
     1      nprofs), zcontr(j,nprofs), pds, ier, 3)
         psiang = atan2((-pds(3)),(-pds(2)))
         if (psiang < 0.) psiang = psiang + 2.*zpi
c     The following cosine accounts for the ray from the magnetic
c     axis not being colinear with the normal to the magnetic surface.
         cosdd = cos(thet(j)-psiang)
         do jj = nprofs + 1, nprof
            dd = (ra(jj)-1.)*tpsisav/cosdd
            ddd = sqrt((xcontr(j,nprofs)-xma)**2+(zcontr(j,nprofs)-zma)
     1         **2) + dd
            xcontr(j,jj) = xma + ddd*cost
            zcontr(j,jj) = zma + ddd*sint
         end do
      end do

      ncontr(nprofs+1:nprof) = nptsd

c
c     Extend the contours 2 points in theta at either end of the
c     theta grid, as a measure to reduce edge effects:

      thet(nptsd+3) = thet(nptsd) + dthet
      thet(nptsd+4) = thet(nptsd) + 2.*dthet
      thet(nptsd+2:3:(-1)) = thet(nptsd:1:(-1))
      thet(1) = -2.*dthet
      thet(2) = -dthet

      ncontr(:nprof) = ncontr(:nprof) + 4
      xcontr(nptsd+3,:nprof) = xcontr(2,:nprof)
      xcontr(nptsd+4,:nprof) = xcontr(3,:nprof)
      zcontr(nptsd+3,:nprof) = zcontr(2,:nprof)
      zcontr(nptsd+4,:nprof) = zcontr(3,:nprof)
      bpcontr(nptsd+3,:nprof) = bpcontr(2,:nprof)
      bpcontr(nptsd+4,:nprof) = bpcontr(3,:nprof)
      xcontr(nptsd+2:3:(-1),:nprof) = xcontr(nptsd:1:(-1),:nprof)
      zcontr(nptsd+2:3:(-1),:nprof) = zcontr(nptsd:1:(-1),:nprof)
      bpcontr(nptsd+2:3:(-1),:nprof) = bpcontr(nptsd:1:(-1),:nprof)
      xcontr(1,:nprof) = xcontr(nptsd,:nprof)
      xcontr(2,:nprof) = xcontr(nptsd+1,:nprof)
      zcontr(1,:nprof) = zcontr(nptsd,:nprof)
      zcontr(2,:nprof) = zcontr(nptsd+1,:nprof)
      bpcontr(1,:nprof) = bpcontr(nptsd,:nprof)
      bpcontr(2,:nprof) = bpcontr(nptsd+1,:nprof)

      nptsd = nptsd + 4

c
c
c
c     Spline the xcontr(ra,thet) and zcontr(ra,thet) arrays,
c     thus obtaining X(theta,psi), Z(theta,psi).
c     (Except X is measured from the machine axis, whereas X-Bram
c      is measured from the magnetic axis).

      call ibcccu (xcontr, thet, nptsd, ra, nprof, csplnx, nptsdm1,
     1   wnoperm, ierr)

      call ibcccu (zcontr, thet, nptsd, ra, nprof, csplnz, nptsdm1,
     1   wnoperm, ierr)



c     Set br variables:
c     Plasma shape and magnetic field on axis.
      rzero = reqd
      bzero = abs(beqd)
      tcurr = toteqd
      raxmag = xma
      rshift = raxmag - rzero
      baxis = feqd(1)/raxmag

      psi = 1.
      theta = 0.
      call dbcevl1 (thet, nptsd, ra, nprof, csplnx, nptsdm1, theta, psi
     1   , pdsx, ier, 1)
      xmax = pdsx(1)
      psi = 1.
      theta = zpi
      call dbcevl1 (thet, nptsd, ra, nprof, csplnx, nptsdm1, theta, psi
     1   , pdsx, ier, 1)
      xmin = pdsx(1)
      rminor = 0.5*(xmax - xmin)

c     Here we define rplasm = ONETWO rho variable at plasma edge,
c     rather than (xma-xmin)/2, as in Brambilla flux surface representation.
      rplasm = tpsisav

c     ukzero (free space wavenumber) is set in subroutine inital.
      urplas = rplasm*ukzero
      uraxmag = raxmag*ukzero

c     Interpolate feqd onto ra grid giving fra, and set up splines:

      call intrpp ('free', 'free', tpsieqd, feqd, nxeqd, ra, fra, nprofs
     1   )
      fra(nprofs+1:nprof,1) = bzero*rzero*btsign

      call cubspl (dra, fra, nprofn, nprofs)

c     Form d(poloidal flux function)/d(rho/a) on the ra grid,
c     out to the plasma edge:
      call cubspl (dra, psifra, nprofn, nprofs)
      dpsifra(:nprofs) = psifra(:nprofs,2)
c
c     if(irayio.gt.0) return
      psinm(:nprofs) = 1. - abs((psifra(:nprofs,1)-psilim)/(psimag-
     1   psilim))
c
c     Get volume of flux surfaces at points out to the plasma surface,
c     using volume = 2*pi*integeral{dl_pol/B_p)*dpsifra*dra:
c $$$$$$$$$$$  Modified and added by T.K. Mau on 10/11/91/
c     Using area = integral{dl_pol/(B_p*R0}*dpsifra*dra
c     Define <J.B> and <B> in MKS units, used for current profiles

      call intrpp ('zero', 'free', tpsieqd, presseqd, nxeqd, ra, ppra,
     1   nprofs)
      call cubspl (dra, ppra, nprofn, nprofs)
c $$$$  Added by TK Mau on 12/2/91,  05/02/02
c     fpeqd(:nxeqd) = ffpeqd(:nxeqd)/feqd(:nxeqd)
      fpeqd(1) = (-3.*feqd(1)+4.*feqd(2)-feqd(3))/(2.*dpolflx)
      do i = 2,nxeqd-1
         fpeqd(i) = (feqd(i+1)-feqd(i-1))/(2.*dpolflx)
      enddo
      if(ffpeqd(nxeqd) == 0.) then
         fpeqd(nxeqd) = 0.
      else
         fpeqd(nxeqd) = (3.*feqd(nxeqd)-4.*feqd(nxeqd-1)+
     &                  feqd(nxeqd-2))/(2.*dpolflx)
      endif

      call intrpp ('free', 'free', tpsieqd, fpeqd, nxeqd, ra, fra1,
     1   nprofs)
      call cubspl (dra, fra1, nprofn, nprofs)
      call intrpp ('free', 'free', tpsieqd, ppeqd, nxeqd, ra, ppra1,
     1   nprofs)
      call cubspl (dra, ppra1, nprofn, nprofs)
c $$$$$$$$$$$$$$$$$$
      call intrpp ('free', 'free', tpsieqd, qeqd, nxeqd, ra, pqr, nprofs
     1   )
      zsurf(1) = 0.
      xwork(1) = 0.
      do j = 2, nprofs
         dv(j) = 0.0
         ds(j) = 0.0
         dlob(j) = 0.0
         dv1 = 0.
         do i = 4, nptsd - 2
            dlp = ((xcontr(i,j)-xcontr(i-1,j))**2+(zcontr(i,j)-zcontr(i-
     1         1,j))**2)**0.5
            bp1 = 0.5*(bpcontr(i,j)+bpcontr(i-1,j))
            rad1 = 0.5*(xcontr(i,j)+xcontr(i-1,j))
            bt1 = fra(1,1)/rad1
            dlpbp = dlp/bp1
            dv(j) = dv(j) + dlpbp
            dlob(j) = dlob(j) + dlp/sqrt(bt1**2 + bp1**2)
            ds(j) = ds(j) + dlpbp/rad1
            dv1 = dv1 + dlp*bp1
         end do
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c ---- Calculate incremental volume
         volume(j) = abs(2.*zpi*dv(j)*dra*dpsifra(j))
c ---- Calculate incremental cross section area
         zsurf(j) = ds(j)*dra*abs(dpsifra(j))
         xwork(j) = 2.*zpi*dv1*abs(dpsifra(j))
      end do
      volume(1) = volume(2)/3.
      dlob(1) = 0.25*dlob(2)
      dlob(nprofs) = 0.25*dlob(nprofs-1) + 0.75*dlob(nprofs)
c ---- Calculate incremental volumes and areas at center and edge
c     dv(1) = 1.75*dv(2)-0.75*dv(3)
c     volume(1) = 0.5*zpi*dra*abs(dv(1)*(0.75*dpsifra(1)+0.25*
c    &            dpsifra(2)))
c     ds(1) = 1.75*ds(2)-0.75*ds(3)
c     zsurf(1) = 0.25*dra*abs(ds(1)*(0.75*dpsifra(1)+0.25*
c    &           dpsifra(2)))
c     volume(nprofs) = 0.5*zpi*dra*abs((0.75*dv(nprofs)+0.25*
c    &                 dv(nprofs-1))*(0.75*dpsifra(nprofs)+0.25*
c    &                 dpsifra(nprofs-1)))
c     zsurf(nprofs) = 0.25*dra*abs((0.75*ds(nprofs)+0.25*
c    &                ds(nprofs-1))*(0.75*dpsifra(nprofs)+0.25*
c    &                dpsifra(nprofs-1)))
c ---- Calculate internal plasma inductance
      ali3 = 2.*simp(nprofs,dra,xwork)/(reqd*(amu0*toteqd)**2)
c ---- Calculate total and poloidal (Shafranov) betas.
      dl = 0.
      do i = 4, nptsd - 2
         dlp = ((xcontr(i,nprofs)-xcontr(i-1,nprofs))**2+(zcontr(i,
     1      nprofs)-zcontr(i-1,nprofs))**2)**0.5
         dl = dl + dlp
      end do
      xwork(1) = 0.
      xwork(2:nprofs) = volume(2:nprofs)/dra
      ywork(2:nprofs) = ppra(2:nprofs,1)*xwork(2:nprofs)
      bpsep = amu0*toteqd/dl
      beta = 2.*amu0*simp(nprofs,dra,ywork)/beqd**2/simp(nprofs,dra,
     1   xwork)
      betap = beta*(beqd/bpsep)**2
c $$$$$$$$$$$$$$$$$$

      volume(1) = volume(2)/3.
c
c $$$$$$$$    TKM   10/00
c Define array r/a versus rho
      rmd(nprof) = raxmag
      roa(1) = 0.
      do jmd = 1, nprof - 1
         jmd1 = nprof - jmd + 1
         jmd2 = 2*nprof - jmd
         rmd(jmd) = xcontr(48,jmd1)
         rmd(jmd2) = xcontr(3,jmd1)
         roa(jmd1) = rmd(jmd2) - rmd(jmd)
      end do
      rmina = rmd(2*nprof-1) - rmd(1)
      roa(2:nprof) = roa(2:nprof)/rmina
c $$$$$$$$$$$$$$$$$
c     Extend volume and poloidal flux function beyond the plasma
c     edge, from ra(nprofs) to ra(nprof).
c     Simply take volume increments as volumes added by each additional
c     surface, and poloidal flux fctn increments as plasma edge pol field
c     at theta=0, ra=1., times added poloidal directed area / (2*pi):

      call dbcevl1 (xeqd, nxeqd, zeqd, nzeqd, cspln, nxeqd, xcontr(1,
     1   nprofs), zcontr(1,nprofs), pds, ier, 3)
      bpedge = (pds(2)**2+pds(3)**2)**.5/xcontr(1,nprofs)

      do j = nprofs + 1, nprof
         dv(j) = 0.
         dv(j) = dv(j) + sum(0.5*(xcontr(4:nptsd-2,j)+xcontr(3:nptsd-3,j
     1      ))*((xcontr(4:nptsd-2,j)-xcontr(3:nptsd-3,j))**2+(zcontr(4:
     2      nptsd-2,j)-zcontr(3:nptsd-3,j))**2)**.5)
c $$$$  Modified by T.K. Mau on 1/31/92.
         volume(j) = 2.*zpi*dv(j)*dra*abs(tpsisav)
c $$$$$$$$$$$$$$$$$
         psifra(j,1) = psifra(j-1,1) + bpedge*xcontr(1,j)*dra*tpsisav*
     1      bisign
      end do

      call cubspl (dra, psifra, nprofn, nprof)


c*************************************************************************
c     To obtain equivalence with Brambilla psi-theta representation
c     of the flux surfaces, using the above ra and thet:
c           psi = ra
c           theta = thet
c     Then the Brambilla equilibrium arrays are tpsi = ra
c                                               ppsi = ra
c                                              tpsif = psifra
c                                                tqr = B_p(psi)/B_T(psi)
c*************************************************************************

      dpsi = dra
      ppsi(:nprof) = ra(:nprof)
      tpsif(:nprof,:) = psifra(:nprof,:)

      tqr(:nprof,1) = tpsif(:nprof,2)/(tpsisav*fra(:nprof,1))

      call cubspl (dpsi, tqr, nprofn, nprof)



      if (ieqdsk == 4) then

c*************************************************************************
c     Continue reading eqdsk if ieqdsk.eq.4, i.e., an extended eqdsk
c     is being used, such as from cql3d with eqsource="tsc".
c*************************************************************************
!         call link ('unit59=terminal//')
         write (6, 8250)
 8250    format('Reading eqdsk')
         read (iounit1, 8210) nlim, nlimiter
 8210 format(5i5)

c     if (nlim.ne.0) then
         read (iounit1, 8200) (rlim(i),zlim(i),i=1,nlim)
         read (iounit1, 8200) (rlimiter(i),zlimiter(i),i=1,nlimiter)
c     endif
c..................................................................
c     The following output is not part of the "official" eqdsk.
c..................................................................
 8200 format(5e16.9)
         nti = 1
         read (iounit1, 8210) lrz, nprim, nimp, nti
         if (lrz > lrza) stop 60
         nion = nprim + nimp
         read (iounit1, 8200) (atm(k),k=1,nion)
         do k = 1, nion
            read (iounit1, 8200) (zi(j,k),j=1,lrz)
         end do
         read (iounit1, 8200) (zeffz(j),j=1,lrz)
         read (iounit1, 8200) (r(j),j=1,lrz)
         read (iounit1, 8200) (psifeqd(j),j=1,lrz)
         read (iounit1, 8200) (te(j),j=1,lrz)
         do k = 1, nti
            read (iounit1, 8200) (ti(j,k),j=1,lrz)
         end do
         read (iounit1, 8200) (ene(j),j=1,lrz)
         do k = 1, nion
            read (iounit1, 8200) (enp(j,k),j=1,lrz)
         end do
         raeqd(:lrz) = r(:lrz)/r(lrz)
c---- Latest update:   TKM   05/00
c-----Include a small concentration of hydrogen, for DIII-D runs
         hconc = 0.02
         if (hconc > 0.) then
            do k = 1, nion
               if (atm(k)==2 .and. zi(1,k)==1.) kdeu = k
            end do
            nion = nion + 1
            atm(nion) = 1.
            zi(:lrz,nion) = 1.
            enp(:lrz,nion) = hconc*enp(:lrz,kdeu)
            enp(:lrz,kdeu) = (1. - zi(:lrz,nion)*hconc)*enp(:lrz,kdeu)
         endif
c
C*****************************************************
c-----Read beam ion data directly from ONETWO;  TKM  04/00, 05/00
         read (iounit1, 8220) nalfa, nbeams
         if (nalfa /= 0) then
            do k = 1, nalfa
               read (iounit1, 8230) ebkev(k), bmpwr(k), azf(k), atmf(k)
               read (iounit1, 8200) (pnf(j,k),j=1,lrz)
               read (iounit1, 8200) (zetab(j,k),j=1,lrz)
               dumf(:lrz) = pnf(:lrz,k)
               call intrpp ('zero', 'free', raeqd, dumf, lrz, ra, dumf1
     1            , nprofs)
               pnfi(k,:nprofs) = dumf1(:nprofs)
               if (iedge == 1) then
                  do j = nprofs + 1, nprof
                     zdecay = exp((-0.5*float(j + nprofs)))
                     pnfi(k,j) = pnfi(k,nprofs)*zdecay
                  end do
               endif
            end do
c
c $$$$   TKM   09/99, 04/00
c ----Read beam ion density and Maxw. temperature profiles, and
c     assign them after primary and impurity ion species.
            nion = nion + 1
            read (iounit1, 8200) (enbeam(j),j=1,lrz)
            read (iounit1, 8200) (wbeam(j),j=1,lrz)
            zi(:lrz,nion) = azf(1)
            ti(:lrz,nion) = wbeam(:lrz)
            enp(:lrz,nion) = 1.E6*enbeam(:lrz)
            atm(nion) = atmf(1)
c
C**************************
C  profile of density and temperature are generalized  SCC 12/12/95
c  Include possibility of one beam ion species   TKM 04/00, 05/00
C***************************
         endif
         nspec = nion
         enetot = sum(ene(:lrz))
         azi(:nion) = zi(1,:nion)
         do k = 1, nion
            enp(:lrz,k) = enp(:lrz,k)*zi(:lrz,k)/azi(k)
         end do
c----- Adjust electron density to assure neutrality.
         ene00 = ene(1)
         do j = 1, lrz
            ene(j) = 0.
            ene(j) = ene(j) + sum(azi(:nion)*enp(j,:nion))
            ene(j) = 1.E-6*ene(j)
         end do
         niont = nion
         if (nalfa > 0) niont = nion - 1
         do k = 1, nion
            enp(:lrz,k) = 1.E-6*enp(:lrz,k)*ene00/ene(1)
            if (k>1 .and. k<=niont) then
               where (ti(:lrz,k) <= 0.) ti(:lrz,k) = ti(:lrz,1)
            endif
         end do
c----- Adjust back to original peak electron density
         ratden = 1.E-6*ene00/ene(1)
         ene(:lrz) = ratden*ene(:lrz)
         enp(:lrz,:nion) = ratden*enp(:lrz,:nion)
         nalfa = 0
c     Initialize ne, te, ti profiles from plasma center to edge.

         call intrpp ('zero', 'free', raeqd, ene, lrz, ra, pne, nprofs)
         call intrpp ('zero', 'free', raeqd, te, lrz, ra, pte, nprofs)
c-------------------SCC  4/23/96
         call intrpp ('zero', 'free', raeqd, zeffz(1), lrz, ra, tzeff(1,
     1      1), nprofs)
c---------------------------
         do k = 1, nion
            call intrpp ('zero', 'free', raeqd, ti(1,k), lrz, ra, pti(1,
     1         k), nprofs)
            call intrpp ('zero', 'free', raeqd, enp(1,k), lrz, ra, pni(1
     1         ,k), nprofs)
         end do
         do k = 1, nion
            conc(:nprofs,k) = pni(:nprofs,k)/pne(:nprofs)
         end do

c     Extend beyond plasma surface if iedge=1:
         if (iedge == 1) then
            do j = nprofs + 1, nprof
               zdecay = exp((-float(j - nprofs)/2.))
               pne(j) = pne(nprofs)*zdecay
               pte(j) = pte(nprofs)*zdecay
               pni(j,:nion) = pni(j,:nion)*zdecay
               pti(j,:nion) = pti(j,:nion)*zdecay
               conc(j,:nion) = pni(j,:nion)/pne(j)
            end do
         endif
c $$$$$$$$$$$$$
 8220    format(2i5)
 8230    format(4e16.9)
         write (59, 8240) nspec, (pni(1,k),k=1,nspec), (pti(1,k),k=1,
     1      nspec)
 8240    format('nspec=',i5,/,'deni(0)=',3(e16.4,3x),/,'temi(0)=',3(
     1      e16.4,3x))
c
      endif
      return
c
      end subroutine fiteqdsk
c
c
      subroutine lsfun1(n, m, xc, fc)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh, only: psi, theta, asinth, bx0, bx1, bx2, bz0, ux, uz,
     1                   ukzero, raxmag
      use Vceqdsk
      USE Vclsfun1
      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, m
      real(kind=dp), dimension(n) :: xc
      real(kind=dp), dimension(m) :: fc
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
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real(kind=dp) , EXTERNAL :: valspl  !  , abs, sin
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.0_dp,psi)*1.E-10
c********************************
c     if(psi.gt.psilimit)  psi=psilimit
c************************** 2/14/92  BH
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 + (raxmag - rzero)
      fzzz = uz/ukzero

      fc(1) = xxx - fxxx
      fc(2) = zzz - fzzz
      if (psi <= 0.) then
         fc(1) = 100.
         fc(2) = 100.
      endif

      return
      end subroutine lsfun1
      subroutine mhdebm
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb
c
c---------------------------
c  This subroutine replaces fiteqdsk. Instead of requiring an eqdsk-file,
c  it reads in MHDE data from Bob-Miller's MHDE-code and processes the
c  required input for coords and profix and profin
c  Calls mhdebm1
c  ieqdsk = 5 to call this routine.
c-----------------------------
c------------------------------

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh, only: baxis, pqr, torflx, ukzero, urplas,
     1        raxmag, xmin, xmax, dpolas, ppra, ppra1, dpsi,
     2        uraxmag, zsurf, volume, tpsif, tqr
      use Vceqdsk
      use Vcmnew, only: dlob
!      USE Vfwcd3
!      USE Vcmalfa, ONLY: lrza
      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 :: nnpsi, nnthet, n, j, jr, i, jj, ierr
      real(kind=dp), dimension(nprofm) :: ywork, xwork, dumf1, dv, ds
      real(kind=dp) :: zpi, amu0, qaxis, dthet, dra, pax, bisign,
     1    rminor, dv1,
     1   dlp, bp1, rad1, bt1, dlpbp, dl, bpsep
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: simp  !  , abs
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       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    6                modcd
c $$$$$$       TKM    04/00
c
c
c  dimension pprime,chipsi,vprime,b_fld,dstarp,btcontr,jacob,
c  torflx
c  in curray.v
c

c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      zpi = 4.*atan2(1.,1.)
      amu0 = zpi*4.E-7
c $$$$$$$$$$$$$$$$$

      call mhdebm1 (nprofm, nptsdm, nnpsi, nnthet, iounit1, iout, dumf1
     1   , jacob, xcontr, zcontr, b_fld, dstarp, bpcontr, btcontr, ra,
     2   pprime, chipsi, xwork, ywork, vprime, thet, qaxis, dthet, dra,
     3   pax, btsign, rzero, bzero, baxis, psimag, psilim, xdimeqd,
     4   zdimeqd, redeqd, zmideqd, xma, zma, toteqd)
      reqd = rzero
      nprof = nnpsi
      nprofs = nprof
      nptsd = 2*nnthet - 1
      dra = ra(2) - ra(1)
      fra(:nprof,1) = dumf1(:nprof)
      pqr(:nprof,1) = xwork(:nprof)
      psifra(:nprof,1) = ywork(:nprof)
      call cubspl (dra, fra, nprofn, nprofs)
      call cubspl (dra, psifra, nprofn, nprofs)
      call cubspl (dra, pqr, nprofn, nprofs)
c-------------------------
c  get toroidal flux function
c--------------------------
      beqd = bzero*btsign
      bisign = sign(1.0_dp,toteqd)
      torflx(1) = 0.
      do n = 2, nprof
         torflx(n) = torflx(n-1) + 0.5*(xwork(n-1)+xwork(n))*(ywork(n)-
     1      ywork(n-1))
      end do
      torflx(:nprof) = -2.*zpi*torflx(:nprof)
      rrho(:nprof) = sqrt(abs(torflx(:nprof)/(zpi*beqd)))
      tpsisav = rrho(nprof)

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


      ncontr(:nprof) = nptsd

c-----------------
c  implement up-down symmetry
c------------------
      do j = nnthet + 1, nptsd
         jr = 2*nnthet - j
         thet(j) = thet(j-1) + dthet
         jacob(j,:nprof) = jacob(jr,:nprof)
         xcontr(j,:nprof) = xcontr(jr,:nprof)
         zcontr(j,:nprof) = -zcontr(jr,:nprof)
         b_fld(j,:nprof) = b_fld(jr,:nprof)
         dstarp(j,:nprof) = dstarp(jr,:nprof)
         bpcontr(j,:nprof) = bpcontr(jr,:nprof)
         btcontr(j,:nprof) = btcontr(jr,:nprof)
      end do

c
c     Extend the contours 2 points in theta at either end of the
c     theta grid, as a measure to reduce edge effects:

      thet(nptsd+3) = thet(nptsd) + dthet
      thet(nptsd+4) = thet(nptsd) + 2.*dthet
      thet(nptsd+2:3:(-1)) = thet(nptsd:1:(-1))
      thet(1) = -2.*dthet
      thet(2) = -dthet

      ncontr(:nprof) = ncontr(:nprof) + 4
      xcontr(nptsd+3,:nprof) = xcontr(2,:nprof)
      xcontr(nptsd+4,:nprof) = xcontr(3,:nprof)
      zcontr(nptsd+3,:nprof) = zcontr(2,:nprof)
      zcontr(nptsd+4,:nprof) = zcontr(3,:nprof)
      bpcontr(nptsd+3,:nprof) = bpcontr(2,:nprof)
      bpcontr(nptsd+4,:nprof) = bpcontr(3,:nprof)
      xcontr(nptsd+2:3:(-1),:nprof) = xcontr(nptsd:1:(-1),:nprof)
      zcontr(nptsd+2:3:(-1),:nprof) = zcontr(nptsd:1:(-1),:nprof)
      bpcontr(nptsd+2:3:(-1),:nprof) = bpcontr(nptsd:1:(-1),:nprof)
      xcontr(1,:nprof) = xcontr(nptsd,:nprof)
      xcontr(2,:nprof) = xcontr(nptsd+1,:nprof)
      zcontr(1,:nprof) = zcontr(nptsd,:nprof)
      zcontr(2,:nprof) = zcontr(nptsd+1,:nprof)
      bpcontr(1,:nprof) = bpcontr(nptsd,:nprof)
      bpcontr(2,:nprof) = bpcontr(nptsd+1,:nprof)

      nptsd = nptsd + 4

c
c
c
c     Spline the xcontr(ra,thet) and zcontr(ra,thet) arrays,
c     thus obtaining X(theta,psi), Z(theta,psi).
c     (Except X is measured from the machine axis, whereas X-Bram
c      is measured from the magnetic axis).

      call ibcccu (xcontr, thet, nptsd, ra, nprof, csplnx, nptsdm1,
     1   wnoperm, ierr)

      call ibcccu (zcontr, thet, nptsd, ra, nprof, csplnz, nptsdm1,
     1   wnoperm, ierr)



c     Set br variables:
c     Plasma shape and magnetic field on axis.
      tcurr = toteqd
      raxmag = xma
      rshift = raxmag - rzero

      xmax = redeqd + xdimeqd
      xmin = redeqd
      rminor = 0.5*(xmax - xmin)

c     Here we define rplasm = ONETWO rho variable at plasma edge,
c     rather than (xma-xmin)/2, as in Brambilla flux surface representation.
      rplasm = tpsisav

c     ukzero (free space wavenumber) is set in subroutine inital.
      urplas = rplasm*ukzero
      uraxmag = raxmag*ukzero


c     Form d(poloidal flux function)/d(rho/a) on the ra grid,
c     out to the plasma edge:
      dpsifra(:nprofs) = psifra(:nprofs,2)

c     Get volume of flux surfaces at points out to the plasma surface,
c     using volume = 2*pi*integeral{dl_pol/B_p)*dpsifra*dra:
c $$$$$$$$$$$  Modified and added by T.K. Mau on 10/11/91/
c     Using area = integral{dl_pol/(B_p*R0}*dpsifra*dra
c     Define <J.B> and <B> in MKS units, used for current profiles
      ppra(nprof,1) = 0.
      do n = nprof - 1, 1, -1
         ppra(n,1) = ppra(n+1,1) + 0.5*(pprime(n)+pprime(n+1))*(ywork(n)
     1      -ywork(n+1))
      end do
      call cubspl (dra, ppra, nprofn, nprofs)
c $$$$  Added by TK Mau on 12/2/91
      fra1(:nprof,1) = -(dstarp(1,:nprof)+4*zpi*xcontr(3,:nprof)*pprime(
     1   :nprof))/fra(:nprof,1)
      call cubspl (dra, fra1, nprofn, nprofs)
      ppra1(:nprof,1) = pprime(:nprof)
      call cubspl (dra, ppra1, nprofn, nprofs)
c $$$$$$$$$$$$$$$$$$
      zsurf(1) = 0.
      xwork(1) = 0.
      do j = 2, nprofs
         dv(j) = 0.0
         ds(j) = 0.0
         dlob(j) = 0.0
         dv1 = 0.
         do i = 4, nptsd - 2
            dlp = ((xcontr(i,j)-xcontr(i-1,j))**2+(zcontr(i,j)-zcontr(i-
     1         1,j))**2)**0.5
            bp1 = 0.5*(bpcontr(i,j)+bpcontr(i-1,j))
            rad1 = 0.5*(xcontr(i,j)+xcontr(i-1,j))
            bt1 = fra(1,1)/rad1
            dlpbp = dlp/bp1
            dv(j) = dv(j) + dlpbp
            dlob(j) = dlob(j) + dlp/sqrt(bt1**2 + bp1**2)
            ds(j) = ds(j) + dlpbp/rad1
            dv1 = dv1 + dlp*bp1
         end do
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c ---- Calculate incremental volume
         volume(j) = abs(2.*zpi*dv(j)*dra*dpsifra(j))
c ---- Calculate incremental cross section area
         zsurf(j) = ds(j)*dra*abs(dpsifra(j))
         xwork(j) = 2.*zpi*dv1*abs(dpsifra(j))
      end do
      volume(1) = volume(2)/3.
      dlob(1) = 0.25*dlob(2)
      dlob(nprofs) = 0.25*dlob(nprofs-1) + 0.75*dlob(nprofs)
c ---- Calculate incremental volumes and areas at center and edge
c     dv(1) = 1.75*dv(2)-0.75*dv(3)
c     volume(1) = 0.5*zpi*dra*abs(dv(1)*(0.75*dpsifra(1)+0.25*
c    &            dpsifra(2)))
c     ds(1) = 1.75*ds(2)-0.75*ds(3)
c     zsurf(1) = 0.25*dra*abs(ds(1)*(0.75*dpsifra(1)+0.25*
c    &           dpsifra(2)))
c     volume(nprofs) = 0.5*zpi*dra*abs((0.75*dv(nprofs)+0.25*
c    &                 dv(nprofs-1))*(0.75*dpsifra(nprofs)+0.25*
c    &                 dpsifra(nprofs-1)))
c     zsurf(nprofs) = 0.25*dra*abs((0.75*ds(nprofs)+0.25*
c    &                ds(nprofs-1))*(0.75*dpsifra(nprofs)+0.25*
c    &                dpsifra(nprofs-1)))
c ---- Calculate internal plasma inductance
      ali3 = 2.*simp(nprofs,dra,xwork)/(reqd*(amu0*toteqd)**2)
c ---- Calculate total and poloidal (Shafranov) betas.
      dl = 0.
      do i = 4, nptsd - 2
         dlp = ((xcontr(i,nprofs)-xcontr(i-1,nprofs))**2+(zcontr(i,
     1      nprofs)-zcontr(i-1,nprofs))**2)**0.5
         dl = dl + dlp
      end do
      xwork(1) = 0.
      xwork(2:nprofs) = volume(2:nprofs)/dra
      ywork(2:nprofs) = ppra(2:nprofs,1)*xwork(2:nprofs)
      bpsep = amu0*toteqd/dl
      beta = 2.*amu0*simp(nprofs,dra,ywork)/beqd**2/simp(nprofs,dra,
     1   xwork)
      betap = beta*(beqd/bpsep)**2
c $$$$$$$$$$$$$$$$$$

      volume(1) = volume(2)/3.


c*************************************************************************
c     To obtain equivalence with Brambilla psi-theta representation
c     of the flux surfaces, using the above ra and thet:
c           psi = ra
c           theta = thet
c     Then the Brambilla equilibrium arrays are tpsi = ra
c                                               ppsi = ra
c                                              tpsif = psifra
c                                                tqr = B_p(psi)/B_T(psi)
c*************************************************************************

      dpsi = dra
      ppsi(:nprof) = ra(:nprof)
      tpsif(:nprof,:) = psifra(:nprof,:)

      tqr(:nprof,1) = tpsif(:nprof,2)/(tpsisav*fra(:nprof,1))

      call cubspl (dpsi, tqr, nprofn, nprof)





      return

      end subroutine mhdebm
      subroutine mhdebm1(kpsi, kthet, npsi, nthet, iounit1, iout, f_bal
     1   , jacob, xcontr, zcontr, b_fld, dstarp, bpcontr, btcontr, ra,
     2   pprime, chipsi, pqr1, psiv, vprime, thec, qaxis, dthe, dpsi,
     3   pax, btsign, rzero, bzero, baxis, psimag, psilim, xdimeqd,
     4   zdimeqd, redeqd, zmideqd, xma, zma, totcur)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
!      use Viorlh, only: bzero, rzero, btsign
!      use Vcraylh, only: dpsi
!      use Vceqdsk, only: psimag, psilim
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer kpsi, kthet, npsi, nthet, iounit1, iout
      real(kind=dp) qaxis, dthe, pax, dpsi, btsign, rzero, bzero,
     1    baxis, psimag,
     1   psilim, xdimeqd, zdimeqd, redeqd, zmideqd, xma, zma, totcur
      real(kind=dp), dimension(kpsi) :: f_bal
      real(kind=dp), dimension(kthet,kpsi) :: jacob, xcontr, zcontr,
     1    b_fld,
     1   dstarp, bpcontr, btcontr
      real(kind=dp), dimension(kpsi) :: ra, pprime, chipsi, pqr1,
     1    psiv, vprime
      real(kind=dp), dimension(kthet) :: thec
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, j, n0, n
      real(kind=dp) :: alpsi, psibnd
      real(kind=dp), dimension(kpsi,kthet) :: dummy
      real(kind=dp), dimension(kpsi) :: dummee
      real(kind=dp) :: zpi, xthe, zthe, xpsi, zpsi, denom, psix, psiz,
     1    bval,
     1   rbpsq, facp, facx, facf, facj, facb, facdsp, amu0, end, gpsi2,
     2   zmax, reqd, fpi
      character, dimension(10) :: line*8
C-----------------------------------------------
c
c---------------------------
c  This subroutine replaces fiteqdsk. Instead of requiring an eqdsk-file,
c  it reads in MHDE data from Bob-Miller's MHDE-code and processes the
c  required input for coords and profix and profin
c-----------------------------

      data facp/1.E-8/
      data facx/1.E-2/
      data facf/1.E-6/
      data facj/1.E-6/
      data facb/1.E-4/
      data facdsp/1.E-4/

c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      zpi = 4.*atan2(1.,1.)
      amu0 = zpi*4.E-7
c $$$$$$$$$$$$$$$$$


c-------------------------------
c  read in Bob Miller's dskbal file
c----------------------------
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 100) npsi, nthet
  100 format(2i5)
      if (npsi>kpsi .or. nthet>kthet) then
         write (iout, 400) npsi, kpsi, nthet, kthet
  400    format(2x,'Either npsi or nthet is too large:','npsi=',i6,2x,
     1      'kpsi=',i6,';  nthet=',i6,2x,'kthet=',i6)
         stop
      endif
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) qaxis, dthe, dpsi, alpsi, psibnd, pax
  200 format(5e16.8)
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (f_bal(i),i=1,npsi)    !f_bal is f
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (ra(i),i=1,npsi)       ! psi coordinate 0-1
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (thec(j),j=1,nthet)    ! theta coordinat 0-pi
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) ((dummy(i,j),i=1,npsi),j=1,nthet)
      jacob(:nthet,:npsi) = transpose(dummy(:npsi,:nthet))
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) ((dummy(i,j),i=1,npsi),j=1,nthet)
      xcontr(:nthet,:npsi) = transpose(dummy(:npsi,:nthet))
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) ((dummy(i,j),i=1,npsi),j=1,nthet)
      zcontr(:nthet,:npsi) = transpose(dummy(:npsi,:nthet))
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) ((dummy(i,j),i=1,npsi),j=1,nthet)
      b_fld(:nthet,:npsi) = transpose(sqrt(dummy(:npsi,:nthet)))
c------------------
c  b_fld is magnitude of local b-field
c-------------------
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) ((dummy(i,j),i=1,npsi),j=1,nthet)
      dstarp(:nthet,:npsi) = transpose(dummy(:npsi,:nthet))
c---------------------
c  dstarp is del(star) of psiv, i.e., 4*pi*R*jphi/c
c---------------------
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (pprime(i),i=1,npsi)   !=pprime
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (dummee(i),i=1,npsi)   !=0
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (dummee(i),i=1,npsi)   !=0
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (dummee(i),i=1,npsi)   !=0
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (dummee(i),i=1,npsi)   !=0
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) ((dummy(i,j),i=1,npsi),j=1,nthet)
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (dummee(i),i=1,npsi)   !=0
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (dummee(i),i=1,npsi)   !=0
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200) (chipsi(i),i=1,npsi)
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200, end=300) (pqr1(i),i=1,npsi)
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200, end=300) (psiv(i),i=1,npsi)
      read (iounit1, '(10a8)') (line(i),i=1,10)
      read (iounit1, 200, end=300) (vprime(i),i=1,npsi)
c---------------------------
c  psiv is poloidal flux function (psi in GS eqn.)
c  chipsi is d(psiv)/d(psic)
c  pqr1 is safety factor
c  vprime is dV/d(psiv)
c-----------------------
  300 continue
c---------------------------
c
      thec(nthet) = zpi
c-----------------------------------------------------------------------
c compute (r*bp)^2/b for stambaugh -- omegaE
c-----------------------------------------------------------------------
      do i = 2, npsi - 1
         do j = 1, nthet
            bval = f_bal(i)/xcontr(j,i)
            xpsi = (xcontr(j,i+1)-xcontr(j,i-1))/(2.*dpsi)
            zpsi = (zcontr(j,i+1)-zcontr(j,i-1))/(2.*dpsi)
            if (j/=1 .and. j/=nthet) then
               xthe = (xcontr(j+1,i)-xcontr(j-1,i))/(2.*dthe)
               zthe = (zcontr(j+1,i)-zcontr(j-1,i))/(2.*dthe)
            else
               xthe = 0.
               if (j == 1) zthe = zcontr(2,i)/dthe
               if (j == nthet) zthe = -zcontr(nthet-1,i)/dthe
            endif
            denom = 1./(xpsi*zthe - zpsi*xthe)
            psix = zthe*denom
            psiz = -xthe*denom
            gpsi2 = psix**2 + psiz**2
            rbpsq = gpsi2*chipsi(i)**2
c           omegE(j,i)=rbpsq/bval
            bpcontr(j,i) = sqrt(rbpsq/xcontr(j,i)**2)
            btcontr(j,i) = bval
c           omegE(j,i)=rbpsq/sqrt(bt(j,i)**2+bp(j,i)**2)
         end do
      end do
      i = npsi
c        omegE(i,j)=amax1(2.*omegE(i-1,j)-omegE(i-2,j),0.)
      btcontr(:nthet,i) = max(2.*btcontr(:nthet,i-1)-btcontr(:nthet,i-
     1   2),0.0_dp)
      bpcontr(:nthet,i) = max(2.*bpcontr(:nthet,i-1)-bpcontr(:nthet,i-
     1   2),0.0_dp)
      i = 1
c        omegE(i,j)=0.
      bpcontr(:nthet,i) = 0.
      btcontr(:nthet,i) = f_bal(i)/xcontr(:nthet,i)

c----------------------------
c  calculate quantities needed in raypat,coords and profix
c-----------------------------
      btsign = sign(1.0_dp,btcontr(1,1))
      rzero = 0.5E0*(xcontr(1,npsi)+xcontr(nthet,npsi))
      baxis = btcontr(1,1)
      psimag = psiv(1)
      psilim = psiv(npsi)
      xdimeqd = xcontr(1,npsi) - xcontr(nthet,npsi)
      zmax = zcontr(1,npsi)
      zmax = max(maxval(zcontr(:nthet,npsi)),zmax)
      zdimeqd = 2.*zmax
      reqd = rzero
      redeqd = xcontr(nthet,npsi)
      zmideqd = 0.
      xma = xcontr(1,1)
      zma = zcontr(1,1)
c-----------------
c  bzero is nominal b-field at rzero
c-----------------
      if (rzero < xma) then
         n0 = npsi - 1
         do n = npsi - 2, 1, -1
            if (rzero >= xcontr(nthet,n)) n0 = n
         end do
         bzero = b_fld(nthet,n0) + (rzero - xcontr(nthet,n0))*(b_fld(
     1      nthet,n0+1)-b_fld(nthet,n0))/(xcontr(nthet,n0+1)-xcontr(
     2      nthet,n0))
      else if (rzero >= xma) then
         n0 = 1
         do n = 2, npsi - 1
            if (rzero >= xcontr(1,n)) n0 = n
         end do
         bzero = b_fld(1,n0) + (rzero - xcontr(1,n0))*(b_fld(1,n0+1)-
     1      b_fld(1,n0))/(xcontr(1,n0+1)-xcontr(1,n0))
      endif
c-----------------
c  totcur is total current
c------------------
      fpi = 4.E0*zpi
      dummy(:npsi,:nthet) = transpose(dstarp(:nthet,:npsi)*jacob(:nthet,
     1   :npsi)/xcontr(:nthet,:npsi)**2)
      do i = 1, npsi
         dummee(i) = 0.
         dummee(i) = dummee(i) + sum(0.5*(dummy(i,:nthet-1)+dummy(i,2:
     1      nthet)))
      end do
      totcur = sum(0.5*(dummee(:npsi-1)+dummee(2:npsi)))
      totcur = 2.*totcur*10.*dthe*dpsi/fpi
c     totcur in amps.

c*******************************
c  change units from cgs to MKS
      f_bal(:npsi) = f_bal(:npsi)*facf
      jacob(:nthet,:npsi) = jacob(:nthet,:npsi)*facj
      xcontr(:nthet,:npsi) = facx*xcontr(:nthet,:npsi)
      zcontr(:nthet,:npsi) = facx*zcontr(:nthet,:npsi)
      b_fld(:nthet,:npsi) = b_fld(:nthet,:npsi)*facb
      dstarp(:nthet,:npsi) = dstarp(:nthet,:npsi)*facdsp
      bpcontr(:nthet,:npsi) = bpcontr(:nthet,:npsi)*facb
      btcontr(:nthet,:npsi) = btcontr(:nthet,:npsi)*facb
      pprime(:npsi) = pprime(:npsi)*1.E7
      chipsi(:npsi) = chipsi(:npsi)*facp
      vprime(:npsi) = vprime(:npsi)*1.E2
      psiv(:npsi) = psiv(:npsi)*facp
      bzero = bzero*facb
      baxis = baxis*facb
      psimag = psimag*facp
      psilim = psilim*facp
      xdimeqd = xdimeqd*facx
      zdimeqd = zdimeqd*facx
      redeqd = redeqd*facx
      rzero = rzero*facx
      zmideqd = zmideqd*facx
      xma = xma*facx
      zma = zma*facx




      return

      end subroutine mhdebm1
c
      function qsaf (psi)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:54   6/14/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      use Viorlh
      use Vcraylh, only: tpsi, zlamb, zqfac
      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   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) qsaf
      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-----------------------------------------------
      integer :: left
      real(kind=dp) :: dpsi
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c--------SCC  5/23/95

      if (psi <= 1.) then
         if (qsafa > 0.) then
            qsaf = qsaf0/(1. - (1. - qsaf0/qsafa)*psi**2)
         else
            qsaf = qsaf0*(1. - (1. - abs(qsafa)/qsaf0)*psi**2)
         endif
      else if (psi > 1.) then
         dpsi = tpsi(2) - tpsi(1)
!         left = ifix(psi/dpsi) + 1
         left = int(psi/dpsi) + 1
         if (left >= nprof) left = nprof - 1
         qsaf = abs(qsafa)*(zqfac(left)*zlamb(left)+(psi-tpsi(left))*(
     1      zqfac(left+1)*zlamb(left+1)-zqfac(left)*zlamb(left))/dpsi)/(
     2      zqfac(nprofs)*zlamb(nprofs))
      endif
      return
      end function qsaf

