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
      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 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
      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, dimension(3) :: zbx0, zbx1, zbx2, zbz0
      real :: twopi, zh, zph, zcosph, zsinph, zzss, zzcs, 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 , 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 = amax1(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 = amod(theta,twopi)
         else
            theta1 = amod((-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
      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, iounit, iauto, iautoc, ier, 
     1   jj, i1, jmd, jmd1, jmd2, ir, k, kdeu, nbeams, niont
      real, dimension(nxa) :: fpeqd
      real, dimension(nprofm) :: ywork, xwork
      real, dimension(lrza) :: dumf
      real, dimension(nprofm) :: dumf1, dv, ds
      real :: frcpr, gampr, alppr, gampr1, alppr1, zpi, amu0, 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 , 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     Read the eqdsk:
      read (iounit1, 8190) ntitle, dat, ipestg, nxeqd, nzeqd
      if (nxeqd/=nxa .or. nzeqd/=nza) then
!         call link ('unit59=terminal//')
         write (6, 8180) nxeqd, nzeqd
         stop 40
 8180    format("nxa,nza must be adjusted to eqdsk dimensions:",2i5)
      endif
      read (iounit1, 8200) xdimeqd, zdimeqd, reqd, redeqd, zmideqd
      read (iounit1, 8200) xma, zma, psimag, psilim, beqd
      read (iounit1, 8200) toteqd, psimx1, psimx2, xax1, xax2
      read (iounit1, 8200) zax1, zax2, psisep, xsep, zsep
      read (iounit1, 8200) (feqd(i),i=1,nxeqd)
      read (iounit1, 8200) (presseqd(i),i=1,nxeqd)
      read (iounit1, 8200) (ffpeqd(i),i=1,nxeqd)
      read (iounit1, 8200) (ppeqd(i),i=1,nxeqd)
      read (iounit1, 8200) ((peqd(i,j),i=1,nxeqd),j=1,nzeqd)
      read (iounit1, 8200, err=8280, end=8280) (qeqd(i),i=1,nxeqd)
 
 
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 $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      psimag = -psimag
      psilim = -psilim
      beqd = -beqd
      toteqd = -toteqd
      psisep = -psisep
      feqd(:nxeqd) = -feqd(:nxeqd)
c*****   TKM   06/97
      ffpeqd(:nxeqd) = -ffpeqd(:nxeqd)
c*********************
      ppeqd(:nxeqd) = -ppeqd(:nxeqd)
      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
 
 8190 format(a40,a8,3i4)
 8200 format(5e16.9)
 8210 format(5i5)
      go to 8300
 
 8280 continue
      write (59, 8290)
 8290 format("error or no q-profile in eqdsk file")
      stop 41
 8300 continue
 
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:
 
      call trap2 (tpsifeqd, qeqd, torflux, nxeqd)
 
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, nprof
         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
      iounit = 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      iounit, 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
      fpeqd(:nxeqd) = ffpeqd(:nxeqd)/feqd(:nxeqd)
      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
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..................................................................
         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
      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, dimension(n) :: xc
      real, 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, dimension(3) :: zbx0, zbx1, zbx2, zbz0
      real :: 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 , 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
      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, dimension(nprofm) :: ywork, xwork, dumf1, dv, ds
      real :: zpi, amu0, qaxis, dthet, dra, pax, bisign, 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 , 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
      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 qaxis, dthe, pax, dpsi, btsign, rzero, bzero, baxis, psimag, 
     1   psilim, xdimeqd, zdimeqd, redeqd, zmideqd, xma, zma, totcur
      real, dimension(kpsi) :: f_bal
      real, dimension(kthet,kpsi) :: jacob, xcontr, zcontr, b_fld, 
     1   dstarp, bpcontr, btcontr
      real, dimension(kpsi) :: ra, pprime, chipsi, pqr1, psiv, vprime
      real, 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 :: alpsi, psibnd
      real, dimension(kpsi,kthet) :: dummy
      real, dimension(kpsi) :: dummee
      real :: zpi, xthe, zthe, xpsi, zpsi, denom, psix, psiz, 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) = amax1(2.*btcontr(:nthet,i-1)-btcontr(:nthet,i-
     1   2),0.0_dp)
      bpcontr(:nthet,i) = amax1(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 = amax1(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
      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 qsaf
      real 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 :: 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
 
