c
c  This module contains orbit-averaging routines
c--------------------------------------
c
c
      subroutine bavorb1(thetas, dla, ba, thetae, wk, wk1, wkt, nthpp0)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:19   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
c      use Vparam
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr 
      use Vcraylh
      use Vceqdsk, ONLY: ntitle, dat, ipestg, nxeqd, nzeqd, xdimeqd, 
     1   zdimeqd, reqd, redeqd, zmideqd, xma, zma, psimag, psilim, 
     2   beqd, toteqd, psimx1, psimx2, xax1, xax2, zax1, zax2, psisep, 
     3   xsep, zsep, feqd, presseqd, ffpeqd, ppeqd, peqd, qeqd, xeqd, 
     4   zeqd, psiadj, dpolflx, psieqd, tpsieqd, tpsifeqd, iounit1, 
     5   inoperm1, nptsdm1, nptsd, torflux, tpsisav, ra, psifra, 
     6   dpsifra, fra, fra1, cspln, pds, wnoperm, xcontr, zcontr, 
     7   bpcontr, btcontr, dstarp, b_fld, jacob, pprime, vprime, 
     8   chipsi, ncontr, dang, bperr, arcl, thet, anglex, csplnx, 
     9   csplnz, pdsx, pdsz, nlim, rlim, zlim, nlimiter, rlimiter, 
     .   zlimiter, lrz, nprim, nimp, nion, nti, zi, zeffz, r, raeqd, 
     1   psifeqd, te, ti, ti1, ene, enp, bmod, rmd, btmd, bpmd, btpmd, 
     2   roa
      use Vcmnew, only: cxc, czc
      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 nthpp0
      real, dimension(nthpp0 + 1) :: thetas
      real, dimension(0:nthpp0 - 1) :: dla, ba, thetae
      real, dimension(nthpp0 + 4) :: wk
      real, dimension(nthpp0 + 4,3) :: wk1
      real, dimension(nthpp0 + 4) :: wkt
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 :: nth, n, np, imn, imx, nt, it, ier
      real::pi,dthet,beq0,alenb,xmn,ymn,dymn,xmx,ymx,dymx,bmax,bmin
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  given nthp0,npsi0,psimx,psimn
c  find dl(1:nthp0)=dl/L line elements along field line
c    and bb(1:nthp0)=B(l)/B(0)
c  (for the bounce average integrals in adj)
c  typically npsi0=26,nthp0=60
c
C     integer ppsis,pthets,pdla,pba,pthete,dumptr
c
c  check if nthp0 is smaller than nthp00 and npsi0 is smaller than npsis
c
      pi = 4*atan(1.0E0)
      dpsis = (psimx - psimn)/(npsi0 - 1)
      dthet = 2*pi/nthp0
      write (iout3, 2000) nthp0, npsi0
      write (iout3, 2010) psimx, psimn
      do nth = 1, nthp0 + 1
         thetas(nth) = (nth - 1.25E0)*dthet
      end do
      do nth = 0, nthp0 - 1
         thetae(nth) = (nth + 0.25E0)*dthet
      end do
      write (iout3, 2020) (thetas(n),n=1,nthp0 + 1)
      write (iout3, 2020) (thetae(n),n=0,nthp0 - 1)
      do np = 1, npsi0
         psis(np) = psimn + dpsis*(np - 1)
         psi = psis(np)
         call subpar (psi, eden(np), etem(np), zefi(np))
         if (psi == 1.) psi = 1. - 1.E-5
         write (iout3, 2010) psi
         do nth = 1, nthp0 + 1
            theta = thetas(nth)
            call coords
            call profix
            cxc(nth,np) = xu + raxmag
            czc(nth,np) = zu
         end do
         theta = 0.
         call coords
         call profix
         beq0 = abs(btot)
         do nth = 0, nthp0 - 1
            theta = thetae(nth)
            call coords
            call profix
            ba(nth) = abs(btot/beq0)
            dla(nth) = sqrt((cxc(nth+2,np)-cxc(nth+1,np))**2+(czc(nth+2,
     1         np)-czc(nth+1,np))**2)*btot/bpol
         end do
         alenb = 0.
         alenb = sum(dla(:nthp0-1))
         dla(:nthp0-1) = dla(:nthp0-1)/alenb
C
C   determine bmax,bmin
C
         imn = 3
         imx = 3
         wk(:nthp0) = abs(ba(:nthp0-1))
         wkt(:nthp0) = thetae(:nthp0-1)
         do nt = 0, 3
            it = nthp0 + nt + 1
            wk(it) = abs(ba(nt))
            wkt(it) = thetae(nt) + 2.*pi
         end do
         do nt = 4, nthp0 + 2
            if (wk(nt) >= wk(imx)) imx = nt
            if (wk(nt) <= wk(imn)) imn = nt
         end do
         call icsccu (wkt, wk, nthp0 + 4, wk1, nthp0 + 4, ier)
         call xtrema (imn, xmn, ymn, dymn, nthp0 + 4, wkt, wk, wk1, ier)
         if (ier == 19) then
            write (iout4, 1001) ier
 1001       format(1x,'error-message 1: ',i3,
     1         ', xtrema failed to converge.')
            return                               ! stop
         endif
         call xtrema (imx, xmx, ymx, dymx, nthp0 + 4, wkt, wk, wk1, ier)
         if (ier == 19) then
            write (iout4, 1002) ier
 1002       format(1x,'error-message 2: ',i3,
     1         ', xtrema failed to converge.')
            return                               ! stop
         endif
         bmax = ymx*beq0
         bmin = ymn*beq0
         bbar(np) = 0.
         ba(:nthp0-1) = ba(:nthp0-1)/ymn
         bbar(np) = bbar(np) + sum(ba(:nthp0-1)*dla(:nthp0-1))
c          aspin(np)=(bmax-bmin)/(bmax+bmin) ! Apparently never used
         write (iout3, 2020) (dla(n),n=0,nthp0 - 1)
         write (iout3, 2020) (ba(n),n=0,nthp0 - 1)
         write (iout3, 2010) alenb, bmax, bmin
      end do
c
c---------------------------
c
 2000 format(1x,2i8)
 2010 format(4(2x,e20.12))
 2020 format(5(2x,e20.12))
      return 
      end subroutine bavorb1
      subroutine bavorbt
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:19   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
c      use Vparam
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr, nthp00
      use Vcraylh
      use Vceqdsk, ONLY: ntitle, dat, ipestg, nxeqd, nzeqd, xdimeqd, 
     1   zdimeqd, reqd, redeqd, zmideqd, xma, zma, psimag, psilim, 
     2   beqd, toteqd, psimx1, psimx2, xax1, xax2, zax1, zax2, psisep, 
     3   xsep, zsep, feqd, presseqd, ffpeqd, ppeqd, peqd, qeqd, xeqd, 
     4   zeqd, psiadj, dpolflx, psieqd, tpsieqd, tpsifeqd, iounit1, 
     5   inoperm1, nptsdm1, nptsd, torflux, tpsisav, ra, psifra, 
     6   dpsifra, fra, fra1, cspln, pds, wnoperm, xcontr, zcontr, 
     7   bpcontr, btcontr, dstarp, b_fld, jacob, pprime, vprime, 
     8   chipsi, ncontr, dang, bperr, arcl, thet, anglex, csplnx, 
     9   csplnz, pdsx, pdsz, nlim, rlim, zlim, nlimiter, rlimiter, 
     .   zlimiter, lrz, nprim, nimp, nion, nti, zi, zeffz, r, raeqd, 
     1   psifeqd, te, ti, ti1, ene, enp, bmod, rmd, btmd, bpmd, btpmd, 
     2   roa
      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:: pthets,pdla,pba,pthete,ndum
      integer:: pwk,pwk1,pwkt,ii,ierr,i,nthpp0
      real, allocatable, dimension(:) :: dum
      real :: stat
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   Common block for Comdynray
c
c
c  given nthp0,npsi0,psimx,psimn
c  find dl(1:nthp0)=dl/L line elements along field line
c    and bb(1:nthp0)=B(l)/B(0)
c  (for the bounce average integrals in adj)
c  typically npsi0=26,nthp0=60
c
c     pointer(dumptr,dum(1))
c     pointer(pthets,thetas(1:nthp0+1))
c     pointer(pdla,dla(0:nthp0-1))
c     pointer(pba,ba(0:nthp0-1))
c     pointer(pthete,thetae(0:nthp0-1))
c     pointer(pwk,wk(1:nthp0+4))
c     pointer(pwk1,wk1(1:nthp0+4,3))
c     pointer(pwkt,wkt(1:nthp0+4))
c
c  check if nthp0 is smaller than nthp00 and npsi0 is smaller than npsis
c
      if (npsi0>npsis .or. nthp0>nthp00-1) then
         write (iout4, *) 'npsi0 or nthp0 is too large in bavorbt'
         write (iout4, *) npsi0, nthp0
         write (iout4, *) npsis, nthp00
         stop 
      endif
      ii = 1
      pthets = ii
      ii = ii + nthp0 + 1
      pdla = ii
      ii = ii + nthp0
      pba = ii
      ii = ii + nthp0
      pthete = ii
      ii = ii + nthp0
      pwk = ii
      ii = ii + nthp0 + 4
      pwk1 = ii
      ii = ii + (nthp0 + 4)*3
      pwkt = ii
      ndum = ii + nthp0 + 4 - 1
c      call hpalloc(dumptr,ndum,ierr,1)
      if (.not.allocated(dum)) then
         ALLOCATE(dum(ndum),stat=ierr)
         if (ierr /= 0) then
            print *, 'dum could not be allocated in bavorbt'
            return 
         endif
      endif
      dum(:ndum) = 0.
      nthpp0 = nthp0
      call bavorb1 (dum(pthets), dum(pdla), dum(pba), dum(pthete), 
     1                 dum(pwk), dum(pwk1), dum(pwkt), nthpp0)
c      call hpdeallc(dumptr,ierr,0)
      DEALLOCATE(dum)
      return 
      end subroutine bavorbt
      subroutine vbak
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:01:19   6/14/01  
C...Switches: -p4 -yb
c-----------------
c  subroutine to calculate an array of b_ave=bbar as a function of psi
c  and akapa1(1:npsi0), akapa(1:npsi0); these are later used in j/p formula.
c--------------------
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr
      use Vcraylh
      use Vceqdsk
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci, 
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte, 
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet, 
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar, 
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg, 
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd, 
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof, 
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde, 
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct, 
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray, 
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2, 
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt, 
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge, 
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge, 
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf, 
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit, 
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam, 
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf, 
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita, 
     9   betaf
      USE Vblkcof
      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 :: np, ier
      real, dimension(3) :: bke
      real :: c2
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 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  6/26/91,  Latest update: 06/02/00
c     Comnew
cNew common added for FWCD
c  Storage related to FWCD:
cSubroutines displh inital use Comnew1
 
 
c******      TKM   03/97, 09/99, 04/00, 06/00
c********************
 
c----------------------------
c       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  input:  npsi0=# of psi-values for tabulation, the psi-values are in
c                the array psis(1:npsi0)
c          nthp0=# of poloidal theta values for averaging
c         temperatures in array etem(1:npsi0)
c $$$$    TKM    8/98
c----------------------
      do np = 1, npsi0
         c2 = 511.925/etem(np)
         if (c2 < 1.E3) then
c            call bskes(0.,c2,3,bke)
c            call mmbskr (c2, 0., 3, bke, ier)
            call dbesk(c2, 0., 2, 3, bke, ier)
            akapa1(np) = bke(2)/bke(3)
            akapa(np) = bke(1)/bke(2)
         else
            akapa1(np) = 1.
            akapa(np) = 1.
         endif
      end do
      call subcof (akz, bkz, az, bz)
      return 
      end subroutine vbak
