! $Id: source.f90,v 1.2 2007/07/23 16:00:58 meyer Exp $
 MODULE source_mod
  USE diag_mod
  USE teqPol_mod, only : t_inv_p,t_inv_x
  IMPLICIT NONE
  REAL(rq), DIMENSION(:), ALLOCATABLE,TARGET :: t_wp,t_wpp,t_wppp,t_vp,t_vpp,&
       t_vppp,crjr,psish,crje,rmsh
  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE :: qelm,pelm,selm,rsrv,vptor,&
       gsrf,ea,eax,fff,ffm,x_s,u_s,v_s,w_s,p_c,p_x,p_pc,xx,xd,pcs,ppcs,xxm,&
       yy,pp,wk,ff,f_c,f_pc
  REAL(rq), DIMENSION(:,:), ALLOCATABLE, PRIVATE :: wsk,hh
  INTEGER, DIMENSION(:), ALLOCATABLE, PRIVATE :: k_p,ip,k_f,jnte,knte,ncgp,&
       jbl2,jbu2
  REAL(rq), DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: s1,s2,s3,s4,s5
  REAL(rq), DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: rsh,zsh,rlsh,zlsh,&
       rce,zce,cce,rcesh,zcesh,cedge,aaa,cs1,cs2,cs3,f_,w_,wp_,psb
  REAL(rq), PRIVATE :: dps,nsp,csph(4),plce,ppe(1),ffpe(1),f_f(1),a,c,s,f(1),&
       d(1,2)
  INTEGER, PRIVATE :: nefit,mlm,mlsh,n_s,lb
  INTEGER, PARAMETER, PRIVATE :: GAMMA=5._rq/3._rq

CONTAINS
 
  SUBROUTINE s_adiabat
    include "debug.i"

    INTEGER lmn,ier,nlagu,lelm_,l,ilag,ll,nlag,jp
    REAL(rq) :: pds(8),prsxo,zamma,yb,tanskew,qcelm_,pcelm_,scelm_,&
         pdp,pdm,fwallu,qdp,qdm,qpp,qp,dflat,dmn,qppp,denom,one,wn,&
         wp0,wnrm,test,qmn,dd,inv_x,xx(4),ddd
         
    SAVE prsxo,nlag,fwallu,inv_x,jp
    DATA prsxo/0/,nlag/20/,fwallu/0/,inv_x/0/
    IF(t_inv_p==0) THEN
       fwallu=ABS(t_fwall)
    ELSEIF(fwallu==0) THEN ! fwall after convergence is always ro*btor and
                           ! and fwallu retains the value of frsrf(msrf) that
                           ! is needed for inv_p=1,-1
       fwallu=ABS(t_fwall)
    END IF
    IF(t_msrf/=SIZE(t_vp)) THEN
       IF(ALLOCATED(t_vp)) DEALLOCATE(t_vp,t_vpp,t_vppp,t_wp,t_wpp,t_wppp)
       ALLOCATE(t_vp(t_msrf),t_vpp(t_msrf),t_vppp(t_msrf),t_wp(t_msrf),&
            t_wpp(t_msrf),t_wppp(t_msrf))
    END IF
    IF(t_msrf/=SIZE(qelm)) THEN
       IF(ALLOCATED(qelm)) DEALLOCATE(qelm,pelm,selm,rsrv,vptor,gsrf,cs1,&
            cs2,cs3,f_,w_,wp_)
       ALLOCATE(qelm(t_msrf),pelm(t_msrf),selm(t_msrf),rsrv(t_msrf),&
            vptor(t_msrf),gsrf(t_msrf),cs1(t_msrf),cs2(t_msrf),cs3(t_msrf),&
            f_(t_msrf),w_(t_msrf),wp_(t_msrf))
    END IF

    IF(jp==0) jp=0.9*t_msrf
    IF(t_inv_x/=0 .AND. t_inv_x/=inv_x) THEN
       inv_x=t_inv_x
       DO jp=t_msrf-1,2,-1
          IF(t_psibar(jp)<=inv_x) EXIT
       END DO
       IF(ALLOCATED(aaa)) DEALLOCATE(aaa,psb)
       ALLOCATE(aaa(t_msrf-jp),psb(jp))
       psb=t_psibar(:jp)
    END IF
    IF(prsxo==0) prsxo=t_prsx
    prsxo=t_prsx ! FIX LDP
    t_ipp=999 ! Fix for new source logic LDP
    nlagu=nlag
    qelm=t_qsave
    selm=t_ssave
    pelm=t_psave
    IF(t_scl==0) t_scl=1.0
    ! This logic models an ELM
    IF(t_lelm/=0) THEN
       IF(t_lelm>0) THEN
          qcelm_=t_qcelm/(1-t_psibar(t_lelm))**3
          pcelm_=t_pcelm/(1-t_psibar(t_lelm))**3
          scelm_=t_scelm/(1-t_psibar(t_lelm))**3
          lelm_=t_lelm
          cs3(t_lelm:)=(t_psibar(t_lelm:)-t_psibar(t_lelm))**3
          cs2(t_lelm:)=cs3(t_lelm:)
       ELSEIF(t_lelm<0) THEN
          lelm_=-t_lelm
          qcelm_=t_qcelm/(1-t_psibar(lelm_))**4
          pcelm_=t_pcelm/(1-t_psibar(lelm_))**3
          scelm_=t_scelm/(1-t_psibar(lelm_))**3
          cs2(lelm_:)=(t_psibar(lelm_:)-t_psibar(lelm_))**3
          cs3(lelm_:)=cs2(lelm_:)*(1-t_psibar(lelm_:))
       END IF
       IF(t_pcelm>0) THEN
          pelm(lelm_:)=t_psave(lelm_:)*(1+pcelm_*cs2(lelm_:))
       ELSEIF(t_pcelm<0) THEN
          pelm(lelm_:)=t_psave(lelm_:)/(1-pcelm_*cs2(lelm_:))
       END IF
       IF(t_scelm>0) THEN
          selm(lelm_:)=t_ssave(lelm_:)*(1+scelm_*cs2(lelm_:))
       ELSEIF(t_scelm<0) THEN
          selm(lelm_:)=t_ssave(lelm_:)/(1-scelm_*cs2(lelm_:))
       END IF
       IF(t_qcelm>0) THEN
          qelm(lelm_:)=t_qsave(lelm_:)*(1+qcelm_*cs3(lelm_:))
       ELSEIF(t_qcelm<0) THEN
          qelm(lelm_:)=t_qsave(lelm_:)/(1-qcelm_*cs3(lelm_:))
       END IF
    END IF
    ! This logic models the current flattening following a disruption
    IF(t_lflat>0) THEN
       DO l=1,t_msrf
          t_lflat=l
          IF(t_qsave(l)>t_qflat) EXIT
       END DO
       pdp=t_psibar(t_lflat+1)-t_psibar(t_lflat)
       pdm=t_psibar(t_lflat-1)-t_psibar(t_lflat)
       qdp=(t_qsave(t_lflat+1)-t_qsave(t_lflat))/pdp
       qdm=(t_qsave(t_lflat-1)-t_qsave(t_lflat))/pdm
       qpp=(qdp-qdm)/(pdp-pdm)
       qp=(qdp*pdm-qdm*pdp)/(pdm-pdp)
       dflat=2*(t_qflat-t_qsave(t_lflat))/qp/(1+sqrt(1+2*&
            (t_qflat-t_qsave(t_lflat))*qpp/qp**2))
       qp=qp+qpp*dflat
       dflat=dflat+t_psibar(t_lflat)
       dmn=-3_rq*t_qrat*(t_qflat-t_qsave(1))/qp
       qpp=-2_rq*qp/dmn
       qppp=-qpp/dmn
       qmn=t_qflat+dmn*(qp+0.5_rq*dmn*(qpp+dmn*qppp/3.0))
      dmn=dmn+dflat
       DO l=1,t_msrf
          lmn=l
          IF(t_psibar(l)>dmn) EXIT
       END DO
       DO l=1,lmn-1
          qelm(l)=qmn
       END DO
       DO l=lmn,t_lflat-1
          dmn=t_psibar(l)-dflat
          qelm(l)=t_qflat+dmn*(qp+0.5_rq*dmn*(qpp+dmn*qppp/3.0))
       END DO
    END IF
    IF(t_lflat/=0) THEN
       IF(t_entropy_flag==0) THEN
          pelm=t_scflat*t_psave
       ELSE
          selm=t_scflat*t_ssave
       END IF
    END IF
    ! END of disruption model
    CALL allocate_separatrix(t_jm,t_km,t_mls,t_nsym,t_n4)
    CALL surfaces_separatrix(t_psibar,t_rlsd,t_zlsd)
    mlm=t_mls/2+1
    t_asrf=0.5_rq*(t_rlsd(t_mls,:,1)-t_rlsd(mlm,:,1))
    t_rsrf=0.5_rq*(t_rlsd(t_mls,:,1)+t_rlsd(mlm,:,1))
    call get_surfint
    f_=TWOPI*qelm/t_rsqbp ! new F
    ier=0
    call boxd_interp (t_raxis,t_zaxis,pds,ier,s_n4)
    IF(t_nsym==2) THEN ! should get same answer as above.
       s_skew=0.5_rq*atan(2*pds(5)/(pds(4)-pds(6)))
       tanskew=tan(s_skew)**2
    END IF

    IF(t_mdpsi.eq.0) THEN
       ll=15
    ELSE
       ll=t_mdpsi
    END IF
  
    denom=prsxo*t_betaj
    ! w_ needs fwallu
    rsrv=t_frsrf*t_fpsrf/FOURPI
    IF(t_ifluxcord==0) THEN
       vptor=t_vpsrf/t_qsrf
    ELSE
       vptor=t_vpsrf
    END IF
    IF(t_entropy_flag==0) THEN
       t_v=pelm/denom/(t_psil-t_psix)
    ELSEIF(t_entropy_flag>0) THEN
       pelm=selm/vptor**GAMMA ! new P
       t_psave=pelm
       t_v=pelm/denom/(t_psil-t_psix)
    ELSEIF(t_entropy_flag<0 .AND. t_nitt==0) THEN
       pelm=selm/vptor**GAMMA ! new P
       t_psave=pelm
       t_v=pelm/denom/(t_psil-t_psix)
    END IF
    w_=(t_w-t_w(ll))/t_scl ! even this subtract. necessitates 2*errt
    yb=t_splbdry
    IF(t_filter_p>2) THEN
       t_v=zero_der_interp(t_psibar,t_v,t_filter_p)
    ELSEIF(t_filter_p>0) THEN
       CALL polyfit_interp(t_v,t_vp,t_psibar,t_dpoly,t_spoly,t_mpoly,-2)
       ! derivative=zero on edge
       yb=777
    ELSEIF(t_filter_p<0) THEN
       CALL polyfit_interp(t_v,t_vp,t_psibar,t_dpoly,t_spoly,t_mpoly,-2)
       yb=777
    END IF
    CALL spline_interp(t_psibar,t_v,yb,yb,t_vp,t_vpp,t_vppp,noint)
    one=1
    DO ilag=1,1
       IF(t_ipj==3) THEN ! jpar and psave profile
          IF(ilag==1) THEN
             call spline_interp(t_psibar,t_v,t_splbdry,t_splbdry,t_vp,t_vpp,&
                  t_vppp,noint)
          END IF
          t_qsrf=t_rsqbp*t_frsrf/TWOPI
          cs1=TWOPI*t_qsrf+t_cusrf/t_frsrf
          t_wp=(t_jparsave*.4_rq*PI-2*denom*t_vp*t_vpsrf/cs1)
          CALL fdInt(t_wp,t_psrf,t_msrf,t_w)
          wn=fwallu-t_w(t_msrf)
          t_w=t_w+wn
          t_w=t_w**2/(2*FOURPI*t_dpsi0)
          call spline_interp(t_psibar,t_w,t_splbdry,t_splbdry,t_wp,t_wpp,&
               t_wppp,noint)
       ELSE  ! q-profile from diff equation, P from p/s save
          IF(ilag==1) THEN
             t_w=t_cusrf/f_
             call spline_interp(t_psrf,t_w,t_splbdry,t_splbdry,wp_,t_wpp,&
                  t_wppp,noint)
          END IF
          cs1=t_frsrf/f_
          cs1=(cs1*(1+cs1)**2*2/((1+cs1)**3+cs1-1))**t_one_pow
          ! --- inverse average of used and wanted
          cs2=t_cusrf/f_+TWOPI*qelm
          cs3=2*denom*t_vp*t_vpsrf/f_+wp_
          t_wp=-cs1*f_**2*cs3/FOURPI/cs2
       END IF ! t_ipj
       yb=t_splbdry
       IF(t_ipj==3) THEN
          ! --- do nothing
       ELSEIF(t_inv_x/=0) THEN
          CALL spline_interp(psb,t_wp,t_splbdry,t_splbdry,gsrf,t_wpp,&
               t_wppp,t_w)
          CALL spline_interp(psb,t_w,yb,yb,t_wp,t_wpp,t_wppp,noint)
          ddd=inv_x-psb(jp)
          xx(1)=t_w(jp)+ddd*(t_wp(jp)+0.5_rq*ddd*(t_wpp(jp)+ddd*t_wppp(jp)/3))
          xx(2)=t_wp(jp)+ddd*(t_wpp(jp)+0.5*ddd*t_wppp(jp))
          xx(3)=t_wpp(jp)+ddd*t_wppp(jp)
          ddd=1-inv_x
          xx(4)=-2*(xx(2)+xx(3)*ddd)/ddd**2
          aaa=t_psibar(jp+1:)-inv_x
          t_w(jp+1:)=xx(1)+aaa*(xx(2)+0.5_rq*aaa*(xx(3)+aaa*xx(4)/3))
          t_wp(jp+1:)=xx(2)+aaa*(xx(3)+0.5_rq*aaa*xx(4))
          t_wpp(jp+1:)=xx(3)+aaa*xx(4)
          t_wppp(jp+1:)=xx(4)
       ELSEIF(t_filter_wp==999) THEN
          wp0=0
          call splider_interp(t_psibar,t_wp,t_w,t_wpp,t_wppp,ndbg10,wp0,jp,&
               ldbg8)
       ELSEIF(t_filter_wp==-999) THEN
          wp0=t_wp(t_msrf)
          call splider_interp(t_psibar,t_wp,t_w,t_wpp,t_wppp,ndbg10,wp0,jp,&
               ldbg8)
       ELSE
          CALL fdInt(t_wp,t_psibar,t_msrf,t_w)
          IF(t_filter_wp>2) THEN
             t_w=zero_der_interp(t_psibar,t_w,t_filter_wp,10,"edge")
          ELSEIF(t_filter_wp>0) THEN
             CALL polyfit_interp(t_w,t_wp,t_psibar,t_dpoly,t_spoly,t_mpoly,-2)
             ! zeroes derivative at edge
             yb=777
          ELSEIF(t_filter_wp<0) THEN
             CALL polyfit_interp(t_w,t_wp,t_psibar,t_dpoly,t_spoly,t_mpoly,1)
             yb=777
          END IF
          call spline_interp(t_psibar,t_w,yb,yb,t_wp,t_wpp,t_wppp,noint)
       END IF
       wn=t_w(t_msrf)
       t_w=t_w-wn
       test=SUM(abs(w_-t_w))/SUM(abs(w_)+abs(t_w))
       cs3=(fwallu**2+2.*FOURPI*t_w*(t_psil-t_psix))
       w_=t_w
       DO l=1,t_msrf
          IF(cs3(l)<=0) call errdetec("fsq<0 in adiabat",1)
       END DO
       t_frsrf=sqrt(cs3)
       IF(test<=2*errt_rq) EXIT
    END DO

    t_fpsrf=FOURPI*t_wp/t_frsrf
    t_pdsrf=denom*t_vp
    t_prsrf=denom*(t_psil-t_psix)*t_v
    t_srsrf=t_prsrf*vptor**GAMMA
    t_w=t_w/prsxo
    t_wp=t_wp/prsxo
    t_wpp=t_wpp/prsxo
    t_wppp=t_wppp/prsxo
    prsxo=t_prsx
    t_jtsrf = 10.*(t_pdsrf+t_bsqrf*t_fpsrf/t_frsrf/FOURPI)/t_rsqirf
    call spline_interp(t_psibar,t_qsrf,t_splbdry,t_splbdry,cs1,cs2,cs3,t_qh)
    t_phibar=t_qh/t_qh(t_msrf)
    IF(t_ifluxcord==2) t_jtsrf=t_qsrf*t_jtsrf
    IF(t_inv_p==-1) THEN
       dd=t_dpsi00/t_dpsi0
       fwallu=fwallu*(t_deltad*dd+1-t_deltad)
       t_fwall=fwallu ! Note at convergence fwall set back to ro*btor
    ELSEIF(t_inv_p==1) THEN
       dd=t_plcm*1.0e+05_rq/t_plc
       fwallu=fwallu*(t_deltad*dd+1-t_deltad)
       t_fwall=fwallu ! Note at convergence fwall set back to ro*btor
    END IF
    IF(ndbg21==1) call debugger
  END SUBROUTINE s_adiabat

!========================================================================
!    calculates total current(plc) and adds relaxation to cjr
!========================================================================
  SUBROUTINE s_current
    REAL(rq) :: suml,sumu,sumc,f1,f2,plco,plcinv,gg,aa,rlsmin,rlsmax,&
         zlsmin,zlsmax
    INTEGER k,jl,ju,j,kl,ku,nnl,nnu,mlsl,mlsu,n,n1
    SAVE plco
    DATA plco / 0.0 /
    n1=0
    IF(ALLOCATED(crjr)) THEN
       n1=SIZE(crjr)
    END IF
    IF(n1/=t_jmkm) THEN
       IF(ALLOCATED(crjr)) DEALLOCATE(crjr)
       ALLOCATE(crjr(t_jmkm))
       crjr=0
    END IF

    IF(t_ipj==11) THEN
       t_plc=-s_pin*t_cusrf(t_msrf)/FOURPI
       return
    END IF
    plcinv=t_plc
    IF((t_kedge==0 .or. t_kedge==10) .AND. t_ipf>=0) THEN
       gg=t_frsrf(t_msrf)*t_fpsrf(t_msrf)
       aa=t_pdsrf(t_msrf)
       t_plc=0
       suml=0
       kl=0
       DO k=1,t_km
          jl=s_jbl(k)
          ju=s_jbu(k)
          IF(jl/=t_jm+1 .AND. ju/=0 .AND. s_jcr(k,1)/=0 .AND. s_jcr(k,2)/=0)&
               THEN
             !   endpoints
             IF(kl==0) kl=k
             IF(t_kedge/=10) THEN
                nnl=jl+t_jm*(k-1)
                nnu=ju+t_jm*(k-1)
                f1=-FOURPI*s_rcr(k,1)*aa-gg/s_rcr(k,1)
                f2=-FOURPI*s_rcr(k,2)*aa-gg/s_rcr(k,2)
                t_plc=t_plc-.5_rq*(t_crj(nnl)/i_r(jl)+f2)*(i_r(jl)-&
                     s_rcr(k,2))/t_dr+.5_rq*t_crj(nnl)/i_r(jl)
                t_plc=t_plc+.5_rq*(t_crj(nnu)/i_r(ju)+f1)*(i_r(ju)-&
                     s_rcr(k,1))/t_dr+.5_rq*t_crj(nnu)/i_r(ju)
             END IF
             sumc=0
             DO j=jl,ju
                sumc=sumc+t_crj(j+t_jm*(k-1))/i_r(j)
             END DO
             t_plc=t_plc-sumc
             IF(suml==0)suml=sumc
             ku=k
          END IF
       END DO
       sumu=sumc
       !---     top and bottom
       call xminmax(s_zlse,1,s_mlse,1,zlsmin,zlsmax,mlsl,mlsu)
       rlsmin=s_rlse(mlsl)
       rlsmax=s_rlse(mlsu)
       f1=-FOURPI*rlsmin*aa-gg/rlsmin
       f2=-FOURPI*rlsmax*aa-gg/rlsmax
       t_plc=t_plc-0.5_rq*((zlsmax-i_z(ku))*(s_rcr(ku,1)-s_rcr(ku,2))*f2-&
            (zlsmin-i_z(kl))*(s_rcr(kl,1)-s_rcr(kl,2))*f1)/t_dr/t_dz+0.5_rq*&
            (sumu+suml)
       !---     END for top and bottom
       t_plc=t_plc*t_dr*t_dz/FOURPI
    ELSEIF(t_kedge>0 .AND. t_ipf>0) THEN
       t_plc=0
       do k=1,t_km
          nnl=jbl2(k)+t_jm*(k-1)
          nnu=jbu2(k)+t_jm*(k-1)
          do n=nnl,nnu
             t_plc=t_plc+t_crj(n)/t_rm(n)
          END do
       END do
       t_plc=-t_plc*t_dr*t_dz/FOURPI
    ELSE
       t_plc=-sum(t_crj/t_rm)*t_dr*t_dz/FOURPI
    END IF
    IF(t_plc==0) CALL errdetec("t_plc=0 in current",0)
    IF(t_ipj>9) THEN
       t_crj=t_crj*plcinv/t_plc
       t_plc=plcinv
    END IF
    t_plc=t_alpha*plco+(1.-t_alpha)*t_plc
    t_crj=t_alpha*crjr+(1.-t_alpha)*t_crj
    plco=t_plc
    IF(t_ipj>=3) t_plc=-s_pin*t_cusrf(t_msrf)/FOURPI
    RETURN
  END SUBROUTINE s_current

  SUBROUTINE s_sourceGS(psin,rsin,crj,pvec)
    !========================================================
    !
    !  sourceGS - calls source for the complete grid
    !  returns crj, the rhs of G-S eq and pvec, F
    !  overwrites psin BEWARE
    !
    !========================================================
    REAL(rq), DIMENSION(:), INTENT(INOUT) :: psin
    REAL(rq), DIMENSION(:), INTENT(IN)    :: rsin
    REAL(rq), DIMENSION(:), INTENT(OUT)   :: crj,pvec
    REAL(rq) ,DIMENSION(SIZE(crj)) :: bt

    INTEGER :: nkl,n,nn,i,n1
    include "debug.i"
    n1=0
    IF(ALLOCATED(p_x)) THEN
       n1=SIZE(p_x)
    END IF
    IF(n1/=s_mxpt) THEN
       IF(ALLOCATED(p_x)) DEALLOCATE(p_x,p_c,p_pc,k_p,f_c,f_pc,k_f)
       ALLOCATE(p_x(s_mxpt),p_c(s_mxpt),p_pc(s_mxpt),k_p(s_mxpt),f_c(s_mxpt),&
            f_pc(s_mxpt),k_f(s_mxpt))
       p_x=0;p_c=0;p_pc=0;k_p=0;f_c=0;f_pc=0;k_f=0
    END IF
    nn=0
    crj=0
    pvec=0
    p_x=0;p_c=0;p_pc=0
    bt=0
    DO n=1,t_jmkm
       IF(s_lxpt(n)==0) THEN
          nn=nn+1
          k_p(nn)=n
          p_x(nn)=(psin(n)-t_psix)/(t_psil-t_psix)
       END IF
    END DO
    call s_source(p_x,p_c,p_pc,0) ! Pressure
    IF(t_ircwt==9) CALL parsestr("relax_s")
    call s_source(p_x,f_c,f_pc,1) ! F
    DO n=1,s_mxpt
       i=k_p(n)
       crj(i)=-FOURPI*rsin(i)**2*p_pc(n)-f_pc(n)*f_c(n)
       pvec(i)=p_c(n)
       bt(i)=f_c(n)
    END DO

    IF(s_nxpt/=0) THEN ! outside region is force free
       IF(SIZE(p_x)/=s_nxpt) THEN
          IF(ALLOCATED(p_x)) DEALLOCATE(p_x,f_c,f_pc,k_f)
          ALLOCATE(p_x(s_nxpt),f_c(s_nxpt),f_pc(s_nxpt),k_f(s_nxpt))
          p_x=0;f_c=0;f_pc=0;k_f=0
       END IF
       nn=0
       DO n=1,t_jmkm
          IF(s_lxpt(n)==-1) THEN
             nn=nn+1
             k_f(nn)=n
             p_x(nn)=(psin(n)-t_psix)/(t_psil-t_psix)
          END IF
       END DO
       call s_source(p_x,f_c,f_pc,2) ! F
       DO n=1,s_nxpt
          i=k_f(n)
          crj(i)=-f_pc(n)*f_c(n)
          bt(i)=f_c(n)
       END DO
    END IF
    psin=bt
    WHERE(s_lxpt==1) psin=t_fwall

    IF(t_ipp==-999) RETURN

    IF(t_kedge<0) THEN  !  just sets up current on grid
       call s_current
       return
    ELSEIF(t_kedge==0 .or. t_kedge==10) THEN
       call s_current
    ELSEIF(t_kedge==1) THEN
       call s_edgecur1
       call s_current
    ELSE
       call s_edgecur2
       call s_current
    END IF

  END SUBROUTINE s_sourceGS

  SUBROUTINE s_source(x,pc,ppc,jip)
    !
    !*********************************************************************
    !                                                                    *
    !  SOURCE CALCULATES PRESSURE,ETC AND/OR F AS A FUNCTION OF FLUX     *
    !  RETURNS P,P'IF JIP=0 or F,F' IF JIP/=0 IN PC,PPC                  *
    !  RETURNS OHMIC PROFILE in PC IF JIP=-1                             *
    !  N IS THE DIMENSION of X (DIMENSIONLESS FLUX),P, AND PPC           *
    !  IPP IPF -- (INPUT) OPTION FLAG FOR FUNCTIONAL FORM IN X           *
    !  PROFILE                                                           *
    !  IPP=1   P' STRICKLER'S FORM, exp(-ALFA(1)*x)                      *
    !  IPP=2   P' exp-(ALFA(1)*x)-AAP*(-ALFA(1)*BETP(1)*x      )         *
    !  IPP=3   P = (1-X**BETP(1))**ALFA(1)                               *
    !  IPP=4   P FLAT TO AAP THEN (1-((X-AAP)/(1-AAP))**BETP(1))**ALFA(1)*
    !  IPP=5   P=(1-XX)**ALFA                                            *
    !          XX=X**BETA; BETA<2 ELSE  XX=((X+2-BETA)/(3-BETA))**2      *
    !          AND BECOMES HOLLOW                                        *
    !  IPP=6   P=(1-XA)**AA; IF ALFA>1 XA=XX AND AA=ALFA                 *
    !          ELSE AA=1 AND XA=XX/(1-ALFA*(1-XX)/XX*ALOG(1-XX))         *
    !          XX=X**BETA; BETA<2 ELSE  XX=((X+2-BETA)/(3-BETA))**2      *
    !          AND BECOMES HOLLOW                                        *
    !  IPP=7   EFIT FORMS USES PEFIT/FEFIT/ AS COEFFS. FOR P'            *
    !  IPP=|999| SPLINE; USES V,VP,VPP,VPPP                              *
    !  *******************************************************************
    !  IPJ=0   FF'-PROFILE SPECIFIED WITH IPF SEE IPP ABOVE              *
    !  IPF<=0  SPHEROMAK(RFP) LAMBDA=1+SUM(ASPH(I)*X**I  (INSIDE)        *
    !  IPF<0   SPHEROMAK OUTSIDE WITH BSPH F=FWALL AT PSI=0              *
    !          RFP WITH BTOR <0                                          *
    !  IPJ=2   OHMIC PROFILE FIXED USES IPF FORMS: NOTE USES PC          *
    !  IPJ=3   FF' FROM JPARSAVE AND PSAVE, P FROM PSAVE                 *
    !  IPJ=5   FF' FROM QSAVE and P FROM PSAVE                           *
    !  EPP     ADDS A BUMP TO P ~EPP*X**|NPP|*(1-X)**2;                  *
    !          (1-X)**2 PART IF NPP<0; NORMALIZED TO EPP                 *
    !  EPF     ADDS A BUMP TO FF' USING NPF, SEE EPP. WILL ALSO ADD      *
    !          BUMP TO OHMIC PROFILE IF JIP=-1                           *
    !  IPF=|999| SPLINE; USES W,WP,WPP,WPPP IF IPJ>=2 USES SAME          *
    !          COEFFICIENTS FOR FF'                                      *
    !                                                                    *
    !*********************************************************************
    INTEGER, INTENT(IN) :: jip
    REAL(rq), DIMENSION(:), INTENT(IN)  :: x
    REAL(rq), DIMENSION(:), INTENT(OUT) :: pc,ppc
    INTEGER  :: mbsp,i,j,k,l,n,ispc,jjp,nn,ier,no
    REAL(rq) :: t0,temx,tempx,ss(2,2),tt(2),bdc(t_jm)
    REAL(rq) :: pds(8),nasp1,nbsp1,zpsph,zcsph(4),zpemp,zpump,z0(4)
    REAL(rq) :: coef,fwallsq,zbf,zprbet,pemp,pump,fp,fp_pri,sqzbf,d_s
    REAL(rq) :: fdf,zfp,xp,xpp,dx,suma,sumf,z00,alfe,zz,bbp,pfn,fpf,ppn,fpp
    REAL(rq) :: rll,ruu,zzz
    include "debug.i"
    
    n_s=SIZE(x)
    IF(ALLOCATED(ea)) THEN
       IF(n_s/=SIZE(ea)) &
          DEALLOCATE(ea,eax,fff,ffm,x_s,u_s,v_s,w_s,xx,xd,pcs,&
            ppcs,xxm,yy,ip,wsk)
    ENDIF
    IF (.NOT.ALLOCATED(ea)) THEN
       ALLOCATE(ea(n_s),eax(n_s),fff(n_s),ffm(n_s),x_s(n_s),u_s(n_s),v_s(n_s),&
            w_s(n_s),xx(n_s),xd(n_s),pcs(n_s),ppcs(n_s),xxm(n_s),yy(n_s),&
            ip(n_s),wsk(n_s,0:4))
       ea=0;eax=0;ffm=0;x_s=0;u_s=0;v_s=0;w_s=0;xx=0;xd=0;ppcs=0;pcs=0;xxm=0
       yy=0;ip=0;wsk=0
    END IF

    IF(ALLOCATED(t_vp)) THEN
       IF(t_msrf/=SIZE(t_vp)) &
          DEALLOCATE(t_vp,t_vpp,t_vppp,t_wp,t_wpp,t_wppp)
    ENDIF
    IF(.NOT.ALLOCATED(t_vp)) THEN
       ALLOCATE(t_vp(t_msrf),t_vpp(t_msrf),t_vppp(t_msrf),t_wp(t_msrf),&
            t_wpp(t_msrf),t_wppp(t_msrf))
       IF(IABS(t_ipf)==999)&
            CALL spline_interp(t_psibar,t_w,t_splbdry,t_splbdry,t_wp,t_wpp,&
            t_wppp,noint)
       IF(IABS(t_ipp)==999)&
            CALL spline_interp(t_psibar,t_v,t_splbdry,t_splbdry,t_vp,t_vpp,&
            t_vppp,noint)
    END IF
    nefit=5
    coef=-5.0e-09*t_dr*t_dz
    IF(t_ircwt==9) THEN
       wsk(:,0:4)=0
    END IF

    dps=t_psil-t_psix
    fwallsq=t_frsrf(t_msrf)**2
    IF(t_inv_eq==0) fwallsq=t_fwall**2 ! LDP 97/08/014
    zbf=FOURPI*(1.-t_betaj)*t_ro**2
    zprbet=t_prsx*t_betaj

    !
    ! Spheromak logic
    !
    zpsph=0
    zcsph=0
    nasp1=t_nasp+1
    nbsp1=t_nbsp+1
    pemp=0
    pump=0
    fp=1+sum(t_asph)
    fp_pri=fp
    IF(t_ipf==0 .OR. t_ipf==-1) sqzbf=sqrt(zbf*t_prsx)
    IF(t_ipf==-1) THEN ! Spheromak with gun
       zpsph=0
       IF(t_psph/=0) zpsph=(t_psph-t_psix)/(t_psil-t_psix)
       z0(1)=-t_psix/dps
       z0(2)=z0(1)**2
       z0(3)=z0(1)**3
       z0(4)=z0(1)**t_nbsp
       csph=t_bsph/z0
       IF(t_gsph/=0 .AND. t_xsph/=0) THEN
          temx=t_xsph**t_gsph
          IF(t_gsph==-1) THEN
             tempx=log(t_xsph)
          ELSE
             tempx=(t_xsph**(t_gsph+1)-1)/(t_gsph+1)
          END IF
       END IF
       zcsph=0
       IF(t_bsph_flag/=0) THEN
          IF(t_psph==0) THEN ! continuous derivative for lambda
             fdf=(t_asph(1)+2*t_asph(2)+3*t_asph(3)+t_nasp*t_asph(4))/(1+&
                  sum(t_asph))
             call sph(csph,t_bsph,z0,fdf,t_bsph_flag,t_nbsp)
          ELSE
             IF(t_bsph(1)/=0) THEN
                zcsph(1)=-t_bsph(1)/zpsph
             ELSEIF(t_bsph(2)/=0) THEN
                zcsph(2)=-t_bsph(2)/zpsph**2
             ELSEIF(t_bsph(3)/=0) THEN
                zcsph(3)=-t_bsph(3)/zpsph**3
             ELSEIF(t_bsph(4)/=0) THEN
                zcsph(4)=-t_bsph(4)/zpsph**t_nbsp
             ELSE
                zcsph(4)=-1/zpsph**t_nbsp
             END IF
          END IF
       END IF
       fp=(1+sum(t_asph))/(1+sum(csph))
       zfp=(1+sum(t_asph))/(1+sum(zcsph))
       ! lamda on plasma edge or at gun IF (rgun,zgun) set
       fwallsq=t_fwall**2
       zpemp=zfp*((1-z0(1))+zcsph(1)*(1-z0(2))/2+zcsph(2)*(1-z0(3))/3+&
            zcsph(3)*(1-z0(3)*z0(1))/4+zcsph(4)*(1-z0(4)*z0(1))/nbsp1)
       zpump=zpemp/(1+sum(t_asph))
       pemp=fp*((1-z0(1))+csph(1)*(1-z0(2))/2+csph(2)*(1-z0(3))/3+&
            csph(3)*(1-z0(3)*z0(1))/4+csph(4)*(1-z0(4)*z0(1))/nbsp1)
       pump=pemp/(1+sum(t_asph))
       IF(t_rgun/=0) THEN 
          call boxd_interp(t_rgun,t_zgun,pds,ier,s_n4)
          z00=(pds(1)-t_psix)/t_dpsi0
       ELSE ! "rgun" at extremum in flux
          rll=t_rwl(t_km-1);zzz=i_z(t_km-1);ruu=t_rwu(t_km-1)
          
          DO j=1,t_jm
             bdc(j)=(t_psi(j+t_jm*(t_km-2))-t_psix)/dps
          END DO
          t0=xminaf(bdc,t_jwl(t_km-1),t_jwu(t_km-1),1,j)
          ier=1
          IF(j<t_jwl(t_km-1)) THEN
             call boxd_interp(rll,zzz,pds,ier,s_n4)
             t0=(pds(1)-t_psix)/dps
          ELSEIF(j>t_jwu(t_km-1)) THEN
             call boxd_interp(ruu,zzz,pds,ier,s_n4)
             t0=(pds(1)-t_psix)/dps
          ELSEIF(j/=t_jwl(t_km-1) .AND. j/=t_jwu(t_km-1)) THEN
             xp=0.5_rq*(bdc(j+1)-bdc(j-1))
             xpp=bdc(j+1)+bdc(j-1)-2*bdc(j)
             dx=-xp/xpp
             t0=t0+dx*(xp+0.5_rq*dx*xpp)
          END IF
          t_fgun= -(fp*((t0-1)+csph(1)*(t0**2-1)/2+csph(2)*(t0**3-1)/3+&
               csph(3)*(t0**4-1)/4+csph(4)*(t0**nbsp1-1)/nbsp1)+pemp)*&
               sqzbf+t_fwall
          t_lamdagun=-sqzbf*fp*(1+csph(1)*t0+csph(2)*t0**2+csph(3)*t0**3+&
               csph(4)*t0**t_nbsp)/t_dpsi0
       END IF
       suma=sqzbf**2*(1+sum(t_asph))
       ! outside delta F/(psil-psix)
    ELSEIF(t_ipf==-8) THEN
       sumf=zbf*(1+sum(t_asph))
       pemp=-sumf*t_psil/dps/zbf
       t_lamdagun=-sqrt(-t_prsx*sumf*dps/t_psil)/dps
    END IF
    !
    ! END Spheromak logic
    !

    IF(t_ipj==0 .AND. (t_ipf==0 .or. t_ipf==1)) THEN 
       pc=t_fwall ! spheromak
    ELSE
       pc=fwallsq
    END IF

    IF(jip==0) THEN
       ispc=1
    ELSE
       ispc=0
    END IF
    jjp=iabs(jip)

    !     Profiles for either FF' or P' or <J.B>

    IF(t_ipp==iabs(999) .AND. jip==0) THEN ! splines for P'
       !        zprbet=betaj
       DO nn=1,n_s
          DO l=2,t_msrf
             IF(t_psibar(l)>=x(nn)) EXIT
          END DO
          ip(nn)=l-1
       END DO
       DO nn=1,n_s
          i=ip(nn)
          zz=x(nn)-t_psibar(i)
          pc(nn)=(t_v(i)+zz*(t_vp(i)+0.5_rq*zz*(t_vpp(i)+zz*t_vppp(i)/3)))*dps
          ppc(nn)=(t_vp(i)+zz*(t_vpp(i)+0.5_rq*zz*t_vppp(i)))
       END DO
       !
    ELSEIF((t_ipf==iabs(999) .or. t_ipj/=0) .AND. jip==1) THEN
       ! splines for FF'
       zbf=FOURPI
       DO nn=1,n_s
          DO l=2,t_msrf
             IF(t_psibar(l)>=x(nn)) EXIT
          END DO
          ip(nn)=l-1
       END DO
       DO nn=1,n_s
          i=ip(nn)
          zz=x(nn)-t_psibar(i)
          pc(nn)=(t_w(i)+zz*(t_wp(i)+0.5_rq*zz*(t_wpp(i)+zz*t_wppp(i)/3)))*dps
          ppc(nn)=(t_wp(i)+zz*(t_wpp(i)+0.5_rq*zz*t_wppp(i)))
       END DO
       !
    ELSEIF((jip==0 .AND. t_ipp==1) .or. (jjp==1 .AND. t_ipf==1)) THEN
       CALL Expalf(t_alfa(ispc),x,pc,ppc)  ! Strickler's form
       ! 
    ELSEIF((jip==0 .AND. t_ipp==2) .or. (jjp==1 .AND. t_ipf==2)) THEN
       !  Diff of Strickler's
       CALL Expalf(t_alfa(ispc),x,pcs,ppcs)
       alfe=t_alfa(ispc)*t_betp(ispc)
       CALL Expalf(alfe,x,pc,ppc)
       pc =(pc-t_aap*pcs)
       ppc=(ppc-t_aap*ppcs)
       ! 
    ELSEIF((jip==0 .AND. t_ipp==3) .or. (jjp==1 .AND. t_ipf==3)) THEN
       ! ppc=(1.-x**t_betp)**t_alfa;
       CALL Parab(t_alfa(ispc),t_betp(ispc),x,pc,ppc)
       ! 
    ELSEIF((jip==0 .AND. t_ipp==4) .or. (jjp==1 .AND. t_ipf==4)) THEN
       ! flat out to x=aap
       IF(t_aap/=0) THEN
          x_s=x
          WHERE (x<=t_aap)
             x_s=0
          ELSEWHERE
             x_s=(x-t_aap)/(1-t_aap)
          END WHERE
          CALL Parab(t_alfa(ispc),t_betp(ispc),x_s,pc,ppc)
          ppc=ppc/(1-t_aap)
          WHERE(x<=t_aap)
             ppc=0
          END WHERE
       ELSE
        CALL Parab(t_alfa(ispc),t_betp(ispc),x,pc,ppc)         
       END IF
       ! 
    ELSEIF((jip==0 .AND. t_ipp==5) .or. (jjp==1 .AND. t_ipf==5)) THEN
       !   hollow current
       IF(t_betp(ispc)<=2) THEN
          xx=x**(t_betp(ispc)-1)
          xd=t_betp(ispc)*xx
          xx=xx*x
       ELSE
          xd=2*(x+2-t_betp(ispc))/(3-t_betp(ispc))**2
          xx=0.5_rq*xd*(x+2-t_betp(ispc))
       END IF
       pc=abs(1-xx)**(t_alfa(ispc)-1)
       ppc=-t_alfa(ispc)*pc*xd/dps
       pc=pc*(1-xx)
       ! 
    ELSEIF((jip==0 .AND. t_ipp==6) .or. (jjp==1 .AND. t_ipf==6)) THEN
       IF(t_betp(ispc)<=2) THEN
          xx=x**(t_betp(ispc)-1)
          xd=t_betp(ispc)*xx
          xx=xx*x
       ELSE
          xd=2*(x+2.-t_betp(ispc))/(3.-t_betp(ispc))**2
          xx=0.5_rq*xd*(x+2.-t_betp(ispc))
       END IF
       xxm=abs(1.-xx)
       IF(t_alfa(ispc)>=1) THEN
          pcs=xxm**(t_alfa(ispc)-1)
          ppc=t_alfa(ispc)*pcs/dps*xd
          pc=pcs*xxm
       ELSEIF(t_alfa(ispc)<1) THEN
          pcs=xxm*(log(abs(xxm-errb_rq))-errt_rq)/(xx+&
               errt_rq)
          ppcs=(t_alfa(ispc)-1)*pcs+1
          pc=(1.-pcs/ppcs)
       END IF
    ELSEIF(t_ipp==7 .AND. jip==0) THEN  !  Efit form for P'
       IF(t_nbsp>4) nefit=nbsp1
       CALL Efit(x,pc,ppc,t_pefit(1),t_pefit(2),t_pefit(3),t_pefit(4),&
            t_pefit(5))
       !
    ELSEIF(t_ipf==7 .AND. jjp==1) THEN  !  Efit form for FF'
       CALL Efit(x,pc,ppc,t_fefit(1),t_fefit(2),t_fefit(3),t_fefit(4),&
            t_fefit(5))
       !
    ELSEIF((jip==0 .AND. t_ipp==8) .or. (jjp==1 .AND. t_ipf==8)) THEN
       ! sum of two pieces
       xxm=abs(1.-x)+errb_rq
       pcs=(1.-t_betp(ispc))*xxm**(t_ipp-6)
       ppcs=(t_ipp-6)*pcs
       pcs=pcs*xxm
       IF(t_alfa(ispc)>=1) THEN
          yy=t_betp(ispc)*xxm**(t_alfa(ispc)-1)
          pc=(pcs+yy*xxm)
          ppc=-(ppcs+t_alfa(ispc)*yy)/dps
       ELSEIF(t_alfa(ispc)<1) THEN
          yy=(t_alfa(ispc)-1)*xxm*log(abs(xxm))/x+1
          pc=(pcs+t_betp(1)*(1.-x/yy))
          ppc=pcs   !   not complete must fix
       END IF
    END IF
    !
    IF(t_epf/=0 .AND. iabs(t_ipf)/=999 .AND. jip==-1) THEN
       ! Add a bump to the ohmic current
       bbp=0
       pcs=0
       IF(t_ipp==4) THEN ! correction for x>aap
          bbp=t_aap
          xx=(x-bbp)/(1-bbp)
       ELSE
          xx=x
       END IF
       IF(t_npf<0) THEN
          pfn=-t_npf
          fpf=-t_npf
          fpf=(1.+fpf)**(1+pfn)/fpf**pfn
          WHERE(x>bbp) 
             pcs=t_epf*fpf*xx**pfn*(1-xx)
          END WHERE
       ELSE
          WHERE(x>bbp) 
             pcs=t_epf*xx**t_npf
          END WHERE
       END IF
       pc=pc+pcs
    END IF

    IF(jip==-1) THEN ! Only for Ohmic profile
       pc=t_prsx*pc*t_ro**2
       return
    END IF
    ! 
    ! END profiles for either FF' or P' or <J.B>
    !
    IF(jip==0) THEN
       IF(t_epp/=0 .AND. iabs(t_ipp)/=999) THEN ! Add a bump to the pressure 
          bbp=0
          IF(t_ipp==4) THEN ! correction for x>aap
             bbp=t_aap
             xx=(x-bbp)/(1-bbp)
          ELSE
             xx=x
          END IF
          pcs=0
          ppcs=0
          IF(t_npp<0) THEN
             ppn=-t_npp
             fpp=t_epp*(ppn/2+1)**2*(1+2/ppn)**ppn
             WHERE(x>bbp)
                pcs=fpp*xx**ppn*(1-xx)**2
             ELSEWHERE
                pcs=fpp*xx**(ppn-1)*(1-xx)*(ppn-(ppn+2)*&
                xx)/(dps*(1-bbp))
             END WHERE
          ELSE
             fpp=t_epp*(t_npp+1)*(1+1/t_npp)**t_npp
             WHERE(xx>bbp)
                pcs=fpp*(t_npp-(t_npp+1)*xx)*xx**(t_npp-1)/&
                     (dps*(1-bbp))
             ELSEWHERE
                ppcs=fpp*(1.-xx)*xx**t_npp
             END WHERE
          END IF
          pc=pc+pcs
          ppc=ppc+ppcs
       END IF
       !
       pc =zprbet*pc
       ppc=zprbet*ppc
       return
    END IF
    !
    ! Spheromak
    IF(t_ipf==8 .or. t_ipf==-8) THEN  !  Spheromak, but FF'
       IF(jip==1) THEN ! inside separatrix
          IF(t_nasp>4) nefit=nasp1
          CALL Efit(x,pcs,ppc,1.0_rq,t_asph(1),t_asph(2),t_asph(3),t_asph(4))
          pc=(pemp+2*pcs)
          IF(t_ircwt==9) THEN
             d_s=-1_rq/dps
             IF(t_lsph/=0) wsk(:,0)=d_s
             IF(t_nsph>=1) wsk(:,1)=d_s*x
             IF(t_nsph>=2) wsk(:,2)=d_s*x_s
             IF(t_nsph>=3) wsk(:,3)=d_s*u_s
             IF(t_nsph==4) wsk(:,4)=d_s*v_s
          END IF
       ELSEIF(jip==2) THEN ! outside plasma
          ppc=pemp*(t_psix+x*dps)/t_psil**2
          pc=pemp*((t_psix+x*dps)/t_psil)**2
          IF(t_ircwt==9) THEN
             IF(t_lsph/=0) wsk(:,0)=ppc/sumf
             IF(t_nsph>=1) wsk(:,1)=ppc/sumf
             IF(t_nsph>=2) wsk(:,2)=ppc/sumf
             IF(t_nsph>=3) wsk(:,3)=ppc/sumf
             IF(t_nsph==4) wsk(:,4)=ppc/sumf
          END IF
       END IF
       ! 
       ELSEIF(t_ipf==0 .or. t_ipf==-1) THEN ! Spheromak
       IF(jip==1) THEN ! inside separatrix
          nsp=t_nasp
          CALL Sphero(x,eax,ea,t_asph(1),t_asph(2),t_asph(3),t_asph(4))
          ppc=-ea
          pc=-(eax+pemp)
          IF(t_ircwt==9) THEN
             IF(t_lsph/=0) wsk(:,0)=(eax+pemp)/dps+ea*(x-1+pump)
             IF(t_nsph>=1) wsk(:,1)=(eax+pemp)*x/dps+&
                  ea*((u_s-1)/2+pump)
             IF(t_nsph>=2) wsk(:,2)=(eax+pemp)*u_s/dps+&
                  ea*((v_s-1)/3+pump)
             IF(t_nsph>=3) wsk(:,3)=(eax+pemp)*v_s/dps+&
                  ea*((w_s-1)/4+pump)
             IF(t_nsph==4) wsk(:,4)=(eax+pemp)*x_s/dps+&
                  ea*((x_s-1)/(nsp+1)+pump)
          END IF
       ELSEIF(jip==2) THEN ! outside region od spheromak
          nsp=t_nbsp
          CALL Sphero(x,xd,xx,csph(1),csph(2),csph(3),csph(4))
          ppc=-xx*fp
          pc=-(xd*fp+pemp)
          IF(t_gsph==-1) THEN
             WHERE(x>=t_xsph .AND. x<1)
                xx=1/x/dps
                xd=log(x)
                ppc=-xx*fp_pri
                pc=-(xd*fp_pri+pemp)
             END WHERE

             WHERE(x<t_xsph)
                xx=temx/dps
                xd=tempx+(x-t_xsph)*temx
                ppc=-xx*fp_pri
                pc=-(xd*fp_pri+pemp)
             END WHERE
          ELSEIF(t_gsph/=0) THEN
             WHERE(x>=t_xsph .AND. x<1)
                xx=x**t_gsph/dps
                xd=(x**(t_gsph+1)-1)/(t_gsph+1)
                ppc=-xx*fp_pri
                pc=-(xd*fp_pri+pemp)
             END WHERE

             WHERE(x<t_xsph)
                xx=temx/dps
                xd=tempx+(x-t_xsph)*temx
                ppc=-xx*fp_pri
                pc=-(xd*fp_pri+pemp)
             END WHERE
          END IF
          IF(zpsph/=0) THEN
             CALL Sphero(x,xd,xx,zcsph(1),zcsph(2),zcsph(3),zcsph(4))
             WHERE(x<1 .AND. x>zpsph)
                ppc=-xx*zfp
                pc=-(xd*zfp+zpemp)
             END WHERE
          END IF
          IF(t_ircwt==9) THEN ! Speheromak reconstruction (needs work
             IF(t_lsph/=0) wsk(:,0)=2*pc*ppc/suma
             IF(t_nsph>=1) wsk(:,1)=2*pc*ppc/suma
             IF(t_nsph>=2) wsk(:,2)=2*pc*ppc/suma
             IF(t_nsph>=3) wsk(:,3)=2*pc*ppc/suma
             IF(t_nsph==4) wsk(:,4)=2*pc*ppc/suma
          END IF
       END IF
    END IF
    !
    IF(t_ipf==0 .or. t_ipf==-1) THEN
       pc=sqzbf*pc+t_fwall ! spheromak
       ppc=sqzbf*ppc
    ELSE
       IF(t_epf/=0 .AND. t_ipj==0 .AND. iabs(t_ipf)/=999)THEN
          ! Add a bump to FF'
          IF(t_ipf==4) THEN
             bbp=t_aap
             xx=(x-t_aap)/(1-t_aap)
          ELSE
             xx=x
             bbp=0
          END IF
          IF(t_npf<0) THEN
             pfn=-t_npf
             fpf=t_epf*(pfn/2+1)**2*(1+2/pfn)**pfn
             xx=(x-bbp)/(1-bbp)
             WHERE(x>bbp)
                pc=pc+fpf*xx**pfn*(1-xx)**2
                ppc=ppc+fpf*xx**(pfn-1)*(1-xx)* (pfn-(pfn+2)*&
                     xx)/(dps*(1-bbp))
             END WHERE
          ELSE   
             fpf=t_epf*(t_npf+1)*(1+1/t_npf)**t_npf
             WHERE(x>bbp)
                pc=pc+fpf*(1.-xx)*xx**t_npf
                ppc=ppc+fpf*(t_npf-(t_npf+1)*xx)*xx**(t_npf-1)/&
                     (dps*(1-bbp))
             END WHERE
          END IF
       END IF
       ! 
       pc=2*zbf*t_prsx*pc+fwallsq
       ppc=zbf*t_prsx*ppc
       DO i=1,n_s
          IF(pc(i)<0) THEN
             call remark('warning("fsq<0 use absolute value and continue")')
             EXIT
          END IF
       END DO
       pc=sqrt(abs(pc))
       ppc=ppc/pc
       
    END IF
    ! 
    IF(t_ircwt==9) THEN ! spheromak
       call reconstruct(wsk,SIZE(ea),jip)
       IF(t_lsph==1 .AND. jip==0) THEN
          DO j=1-iabs(t_lsph),t_nsph
             t_splw(t_nloop0p+1,j)=1.e-6*t_fgun/FP
          END DO
       ELSE
          t_gplc=-1e-5*zbf*t_prsx*t_gplc/FOURPI
          t_gcw=coef*zbf*t_prsx*t_gcw*t_gcw
          t_gplw=zbf*t_prsx*t_gplw
       END IF
    END IF

  END SUBROUTINE S_SOURCE

  SUBROUTINE sph(csph,t_bsph,z0,del,bsph_flag,t_nbsp)

    REAL(rq) :: csph(4),t_bsph(4),z0(4),ss(2,2),tt(2),del,uu,t_nbsp,n1,n2
    INTEGER bsph_flag,l1,l2

    uu=csph(1)*(1-del)+csph(2)*(2-del)+csph(3)*(3-del)+csph(4)*(t_nbsp-del)&
         -del
    IF(bsph_flag<5) THEN
       l1=bsph_flag
       n1=l1
       IF(l1==4) n1=t_nbsp
       csph(l1)=(uu-csph(l1)*(n1-del))/(del-n1)
       t_bsph(l1)=z0(l1)*csph(l1)
    ELSE
       l1=bsph_flag/10
       l2=bsph_flag-10*l1
       n1=l1
       n2=l2
       IF(l1==4) THEN
          n1=t_nbsp
       ELSEIF(l2==4) THEN
          n2=t_nbsp
       END IF
       ss(1,1)=n1*z0(l1)
       ss(1,2)=n2*z0(l2)
       ss(2,1)=(n1-del)
       ss(2,2)=(n2-del)
       call rmInvert(ss,2,2)
       tt(2)=uu-csph(l1)*(n1-del)-csph(l2)*(n2-del)
       uu=csph(1)*z0(1)+2*csph(2)*z0(2)+3*csph(3)*z0(3)+t_nbsp*csph(4)*z0(4)
       tt(1)=uu-n1*csph(l1)*z0(l1)-n2*csph(l2)*z0(l2)
       csph(l1)=-ss(1,1)*tt(1)-ss(1,2)*tt(2)
       csph(l2)=-ss(2,1)*tt(1)-ss(2,2)*tt(2)
       t_bsph(l1)=z0(l1)*csph(l1)
       t_bsph(l2)=z0(l2)*csph(l2)
    END IF

    RETURN
  END SUBROUTINE sph

  SUBROUTINE reconstruct(wsk,n,jin)
    INTEGER, INTENT(IN) :: jin,n
    REAL(rq), INTENT(IN) :: wsk(n,0:t_nsph)
    INTEGER :: jix(n_s),i,j,nn
    REAL(rq) :: rr(n_s)

    IF(jin==0) THEN
       t_gcw=0
       t_gplc=0
       t_gplw=0
       DO i=1,t_jmkm
          IF(s_lxpt(i)==0) THEN ! inside separatrix
             nn=nn+1
             jix(nn)=i
             rr(nn)=t_rm(i)
          END IF
       END DO
    ELSE
       DO i=1,t_jmkm
          IF(s_lxpt(i)==-1) THEN ! outside separatrix
             nn=nn+1
             jix(nn)=i
             rr(nn)=t_rm(i)
          END IF
       END DO
    END IF

    DO j=1,1-iabs(t_lsph),t_nsph
       DO nn=1,n_s
          i=jix(nn)
          t_gcw(:,j)=t_gcw(:,j)+t_gc(i,1,:)*wsk(nn,j)/rr(nn)
          t_gplw(:,j,:)=t_gplw(:,j,:)+t_gpl(i,:,:)/rr(nn)
       END DO
       t_gplc(j)=t_gplc(j)+sum(wsk(:,j)/rr)
    END DO
    RETURN

  END SUBROUTINE reconstruct

  SUBROUTINE s_xohmic(nret,iter)
    USE teqGS_mod, only : t_prsx01
    include "debug.i"
    !
    ! compute t_w,wp,wpp,wppp for subroutine source
    ! t_frsrf is leftover-on CALL to xohmic from equila, an initial cond.
    !
    REAL(rq) :: pds(8),wp0,dps,fwallu,test
    REAL(rq), DIMENSION(t_msrf) :: cs1,cs2,cs3
    INTEGER nret,iter,ier,l,n1
    n1=0
    IF(ALLOCATED(t_wp)) THEN
       n1=SIZE(t_wp)
    END IF
    IF(n1/=t_msrf) THEN
       IF(ALLOCATED(t_vp)) DEALLOCATE(t_wp,t_wpp,t_wppp,t_vp,t_vpp,t_vppp)
       ALLOCATE(t_wp(t_msrf),t_wpp(t_msrf),t_wppp(t_msrf),t_vp(t_msrf),&
            t_vpp(t_msrf),t_vppp(t_msrf))
    END IF
    n1=0
    IF(ALLOCATED(s1)) THEN
       n1=SIZE(s1)
    END IF
    IF(n1/=t_msrf) THEN
       IF(ALLOCATED(s1)) DEALLOCATE(s1,s2,s3,s4)
       ALLOCATE(s1(t_msrf),s2(t_msrf),s3(t_msrf),s4(t_msrf))
    END IF
    
    iter=1
    CALL surfaces_separatrix(t_psibar,t_rlsd,t_zlsd)
    CALL get_surfint
    cs1=t_bsqrf-t_frsrf**2*t_rsqirf
    t_rls=t_rlsd(:,t_msrf,1)
    t_zls=t_zlsd(:,t_msrf,1)
    ier=0
    CALL boxd_interp(t_raxis,t_zaxis,pds,ier,s_n4)
    IF(ier/=0) CALL errdetec("xohmic: boxd_interp error",1)
    ! IF sigma not=0 & ixpt=1, THEN psil ne psilim but plasma is still limited
    dps=t_psil-t_psix
    IF(t_ipj==1) THEN
       IF(t_prsx01==0) t_prsx01=t_prsx
       t_jtsrf=t_jtsave/t_prsx01/10
       t_prsrf=t_psave/t_prsx01
       CALL fdDeriv(t_prsrf,t_psibar,t_msrf,t_pdsrf);t_pdsrf=t_pdsrf/dps
       t_ipp=999;t_ipf=999 ! This option only uses cubic splines in source
    ELSEIF(t_ipj<0) THEN
       call remark("trouble: disconnected")
    ELSE
       IF(t_nitt==0) THEN
          CALL s_source(t_psibar,s1,s2,-1) ! Ohmic profile
          CALL s_source(t_psibar,s3,s4,0)
          s1=s1/t_prsx
          s3=s3/t_prsx
          s4=s4*dps/t_prsx
       END IF
       t_jtsrf=-s1/dps
       t_prsrf=s3
       t_pdsrf=s4/dps
    END IF
    cs3=t_w
    cs2=t_frsrf**2
    fwallu=t_fwall
    DO iter=1,nret
       t_bsqrf=cs1+cs2*t_rsqirf
       t_wp=cs2*(t_jtsrf*t_rsqirf-t_pdsrf)/t_bsqrf
       wp0=0
       CALL splider_interp(t_psibar,t_wp,t_w,t_wpp,t_wppp,ndbg10,wp0,0,ldbg8)
       cs2=fwallu**2+2.*FOURPI*t_prsx*dps*t_w
       test=sum(abs(t_w-cs3))/sum(abs(t_w)+abs(cs3))
       cs3=t_w
       if(ndbg28==9 .and. t_ipj==1) call debugger
       IF(test<=errt_rq) EXIT
    END DO

    DO l=1,t_msrf
       IF(cs2(l)<0) CALL errdetec("fsq lt.0 in xohmic",1)
    END DO
    t_v=t_prsrf/dps/t_betaj
    t_frsrf=sqrt(fwallu**2+2.*FOURPI*t_prsx*dps*t_w)
    t_fpsrf=FOURPI*t_prsx*t_wp/t_frsrf
    t_pdsrf=t_prsx*t_pdsrf
    t_prsrf=t_prsx*t_prsrf
    IF(t_ifluxcord==0) THEN
       cs1=t_vpsrf/t_qsrf
    ELSE
       cs1=t_vpsrf
    END IF
    t_srsrf=t_prsrf*cs1**GAMMA
    CALL spline_interp(t_psibar,t_qsrf,t_splbdry,t_splbdry,cs1,cs2,cs3,t_qh)
    t_phibar=t_qh/t_qh(t_msrf)
    CALL spline_interp(t_psibar,t_v,t_splbdry,t_splbdry,t_vp,t_vpp,t_vppp,&
         noint)
    t_jtsrf=10.*(t_pdsrf+t_bsqrf*t_fpsrf/t_frsrf/FOURPI)/t_rsqirf
    RETURN

  END SUBROUTINE s_xohmic

  SUBROUTINE Expalf(e1,e2,e3,e4)
    REAL(rq), INTENT(IN)  :: e1
    REAL(rq), DIMENSION(:), INTENT(IN)  :: e2
    REAL(rq), DIMENSION(:), INTENT(OUT) :: e3,e4
    !
    !     calculates exponential profile
    !
    ea=exp(-e1)
    eax=exp(-e1*e2)
    e3=(ea*(1+(1.-e2)*e1)-eax)/e1/(ea-1)
    e4=(eax-ea)/dps/(ea-1)

  END SUBROUTINE Expalf

  SUBROUTINE Parab(e1,e2,e3,e4,e5)
    REAL(rq), INTENT(IN) :: e1,e2
    REAL(rq), DIMENSION(:), INTENT(IN)  :: e3
    REAL(rq), DIMENSION(:), INTENT(OUT) :: e4,e5
    !
    !     calculates polynomial form
    !
    u_s=abs(e3)+errb_rq
    fff=u_s**(e2-1)
    ffm=abs(1-fff*u_s)+errb_rq
    e4=ffm**(e1-1)
    e5=-e1*e2*e4*fff/dps
    e4=e4*ffm
  END SUBROUTINE Parab

  SUBROUTINE Efit(e1,e2,e3,e4,e5,e6,e7,e8)
    REAL(rq), INTENT(IN) :: e4,e5,e6,e7,e8
    REAL(rq), DIMENSION(:), INTENT(IN)  :: e1
    REAL(rq), DIMENSION(:), INTENT(OUT) :: e2,e3
    x_s=e1**2
    u_s=x_s*e1
    v_s=u_s*e1**(nefit-4)
    e3=-(e4+e1*e5+x_s*e6+u_s*e7+v_s*e8)/dps
    e2=e4*(1-e1)+e5/2*(1-x_s)+e6/3*(1-u_s)+e7/4*&
         (1-u_s*e1)+e8/nefit*(1-v_s*e1)
  END SUBROUTINE Efit

  SUBROUTINE Sphero(e1,e2,e3,e4,e5,e6,e7)
    REAL(rq), INTENT(IN) :: e4,e5,e6,e7
    REAL(rq), DIMENSION(:), INTENT(IN)  :: e1
    REAL(rq), DIMENSION(:), INTENT(OUT) :: e2,e3
    u_s=e1**2
    v_s=u_s*e1
    w_s=v_s*e1
    if(e7/=0) x_s=e1**nsp
    e2=e1-1+e4*(u_s-1)/2+e5*(v_s-1)/3+e6*(w_s-&
         1)/4+e7*(e1*x_s-1)/(nsp+1)
    e3=(1+e4*e1+e5*u_s+e6*v_s+e7*x_s)/dps
  END SUBROUTINE Sphero

  SUBROUTINE s_get_flux(rr,tt,lxp,jmk,ps)
    !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    !-- Computes pol_flux, ps on the fixed grid from inverse coordinates
    !-- rr(t_jmkm) is rho**2 and tt(t_jmkm) is the angle for the grid points
    !-- This works for an arbitrary r,z grid
    !-- Tests to see IF jmk=t_jmkm to calculate cps's etc
    !-- Note uses iabs(jmk) and number
    !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    INTEGER, INTENT(IN) :: jmk
    REAL(rq), DIMENSION(jmk), INTENT(IN)  :: rr,tt
    REAL(rq), DIMENSION(jmk), INTENT(INOUT) :: ps
    INTEGER,  DIMENSION(jmk), INTENT(IN)  :: lxp

    REAL(rq) :: rmax,zmax
    INTEGER ier,jm_km,lmx,n,l,ll,iii,ls
    INTEGER, DIMENSION(t_lmax) :: iwk_
    REAL(rq), DIMENSION(t_lmax) :: p_,r_,z_,uu_,ww_
    !
    !
    jm_km=iabs(jmk)
    lmx=0
    ier=6
    DO n=1,jm_km
       IF(lxp(n)==0) THEN
          lmx=lmx+1
          iwk_(lmx)=n
          uu_(lmx)=rr(n)
          ww_(lmx)=tt(n)
       END IF
       IF(lmx==t_lmax .or. (n==jm_km .AND. lmx/=0)) THEN ! vectors t_lmax long
          rmax=uu_(lmx)
          zmax=ww_(lmx)
          IF(lmx<t_lmax) THEN
             DO l=lmx+1,t_lmax ! fill up array
                uu_(l)=rmax
                ww_(l)=zmax
             END DO
          END IF
          CALL boxi_interp(uu_,ww_,t_pdls,t_dpsi0,t_psix,t_wvert,ier,t_n6)
          DO ll=1,lmx
             ps(iwk_(ll))=t_pdls(ll,1)
          END DO
          IF(jmk==t_jmkm) THEN
             DO ll=1,lmx
                iii=iwk_(ll)
                i_cps(iii,1,1)=t_pdls(ll,1)
                i_cps(iii,2,1)=t_pdls(ll,2)
                i_cps(iii,1,2)=t_pdls(ll,3)
                i_cps(iii,2,2)=t_pdls(ll,5)
             END DO
             p_=t_pdls(:,1)
             CALL interp_interp(t_psrf,t_frsrf,t_splbdry,t_splbdry,p_,r_,z_)
             DO ll=1,lmx
                iii=iwk_(ll)
                t_bt(iii)= r_(ll)/t_rm(iii)
                t_br(iii)=-i_cps(iii,1,2)/t_rm(iii)
                t_bz(iii)= i_cps(iii,2,1)/t_rm(iii)
                t_bp(iii)= sqrt(t_br(iii)**2+t_bz(iii)**2)
                t_bmod(iii)=sqrt(t_bt(iii)**2+t_bp(iii)**2)
             END DO
          END IF
          lmx=0
       END IF
    END DO
    t_rls=t_rlsd(:,t_msrf,1) ! reset
    t_zls=t_zlsd(:,t_msrf,1)
  END SUBROUTINE s_get_flux

  SUBROUTINE s_source_inv
    !--- Finds cps from inverse equilibrium
    include "debug.i"
    REAL(rq), DIMENSION(t_msrf) :: w_,v_,u_
    REAL(rq), DIMENSION(t_jm) :: rpl,zpl,spl,tpl
    REAL(rq), DIMENSION(t_jmkm) :: ps1,ps2,ps3
    REAL(rq), DIMENSION(t_mls) :: cq
    INTEGER,  DIMENSION(t_jmkm) :: lxp
    REAL(rq) :: y1,yn
    INTEGER j,k,m,lmin,n1

    n1=0
    if(ALLOCATED(crjr)) then
       n1=SIZE(crjr)
    end if
    if(n1/=t_jmkm) then
       IF(ALLOCATED(crjr))  DEALLOCATE(crjr)
       ALLOCATE(crjr(t_jmkm))
       crjr=0
    end if

    ps1=atan2((t_zm-t_zaxis)/t_wvert,t_rm-t_raxis)
    where(ps1<0) ps1=ps1+TWOPI
    cq=t_rhosq(t_msrf,:t_mls,1)
    !     Find out whether grid point is inside(lxp=0) or outside plasma
    y1=-666
    yn=-666
    CALL interp_interp(t_tswpts,cq,y1,yn,ps1,ps2,ps3)
    ps3=(t_rm-t_raxis)**2+((t_zm-t_zaxis)/t_wvert)**2
    lxp=0
    where(ps3>ps2) lxp=1

    if(t_use_halo .AND. t_lhalo<t_msrf) then  ! zero current outside first wall
       zpl=xmaxaf(t_zplate,1,t_nplates,1,lmin)
       rpl=i_r
       tpl=atan2((zpl-t_zaxis)/t_wvert,rpl-t_raxis)
       WHERE(tpl<0)tpl=tpl+TWOPI
       spl=sqrt((rpl-t_raxis)**2+((zpl-t_zaxis)/t_wvert)**2)
       CALL interp_interp(tpl,spl,t_splbdry,t_splbdry,ps1,ps2,ps3)
       ps3=(t_rm-t_raxis)**2+((t_zm-t_zaxis)/t_wvert)**2
    end if

    DO k=1,t_km
       DO j=1,t_jm
          if(lxp(j+t_jm*(k-1))==0) EXIT
       END DO
       s_jbl(k)=j
       DO j=t_jm,1,-1
          if(lxp(j+t_jm*(k-1))==0) EXIT
       END DO
       s_jbu(k)=j
    END DO

    !     Find flux on fixed grid inside plasma; uses lxp
    CALL s_get_flux(ps3,ps1,lxp,t_jmkm,t_psi)
    w_=-t_fpsrf*t_frsrf
    v_=-FOURPI*t_pdsrf
    if(t_filter_wp/=0) then
       DO m=t_msrf-1,1,-1
          if(t_asrf(t_msrf)-t_asrf(m)>2*t_dr) EXIT
       END DO
       u_=1
       u_(m:)=(1-(t_psibar(m:)-t_psibar(m))**10/(1-t_psibar(m))**10)
       w_=w_*u_
       v_=v_*u_
    end if
    CALL interp_interp(t_psrf,w_,t_splbdry,t_splbdry,t_psi,t_crj,ps3)
    CALL interp_interp(t_psrf,v_,t_splbdry,t_splbdry,t_psi,ps2,ps3)
    t_crj=t_crj+ps2*t_rm**2
    where(lxp==1) t_crj=0
    if(t_ipf<0) then ! get current on open field lines
       CALL s_setcrjX
!       CALL parsestr("setcrjX")
       if(t_fix_bound) where(lxp==1) t_crj=crjr
    end if
    t_crj=t_alpha*crjr+(1-t_alpha)*t_crj
    IF(t_fix_bound) RETURN
    t_plc=-sum(t_crj/t_rm)*t_dr*t_dz/FOURPI

  END SUBROUTINE s_source_inv

  FUNCTION cspX(x,x_1,x_2,x_3,x_4,x_n1) RESULT(rr)
    REAL(rq), DIMENSION(:), INTENT(IN) ::  x
    REAL(rq), INTENT(IN) :: x_1,x_2,x_3,x_4,x_n1
    REAL(rq), DIMENSION(SIZE(x)) :: xx_1,xx_2,xx_3,xx_4,xx_n
    REAL(rq), DIMENSION(SIZE(x),2) :: rr
    REAL(rq) :: n1
    
    n1=1+t_nbsp
    xx_1=x
    xx_2=xx_1*xx_1
    xx_3=xx_2*xx_1
    xx_4=xx_3*xx_1
    xx_n=xx_1
    IF(t_bsph(4)/=0) THEN
       xx_n=xx_1**t_nbsp
    END IF
    rr(:,1)=1+xx_1*csph(1)+xx_2*csph(2)+xx_3*csph(3)+xx_n*csph(4)
    rr(:,2)=(xx_2-x_2)*csph(1)/2+(xx_3-x_3)*csph(2)/3+(xx_4-x_4)*&
         csph(3)/4+(xx_n*x-x_n1)*csph(4)/n1+xx_1-x_1
  END FUNCTION cspX
 
  SUBROUTINE s_setcrjX
    USE teqPol_mod, only : t_inv_k
    INTEGER i,k, n0, n1, n2, n3, n4
    REAL(rq) :: x_1,x_2,x_3,x_4,x_n1,e(1,2),f(1),esph(4),fsph(4),fw_
    REAL(rq), SAVE :: fw
    INTEGER, SAVE :: iw
    DATA fw /0.0/, iw /1/
    
    IF(t_fix_bound) THEN
       t_fwall=t_fpsrf(t_msrf)*t_psil
       t_btor=t_fwall/t_ro
       RETURN
    END IF

    IF(fw==0) fw=t_fwall
    f=1.0_rq
    lb=0
    a=t_frsrf(t_msrf)/(t_fpsrf(t_msrf)*t_psil)

    ! Force t_crj to be continuous across separatrix
    x_1=-t_psix/t_dpsi0
    x_2=x_1*x_1
    x_3=x_2*x_1
    x_4=x_3*x_1
    x_n1=x_1**t_nbsp
    fsph(1)=x_1;fsph(2)=x_2;fsph(3)=x_3;fsph(4)=x_n1
    csph=t_bsph/fsph
    IF(t_bsph_flag/=0) THEN
       s=extrp(t_fpsrf,t_psibar,t_msrf,1,1)/t_fpsrf(t_msrf)
       call sph(csph,t_bsph,fsph,s,t_bsph_flag,t_nbsp)
    END IF
    x_n1=x_n1*x_1
    s=1+SUM(csph)
    d=cspX(f,x_1,x_2,x_3,x_4,x_n1)*t_dpsi0/t_psil/s
    IF(s/=1) lb=1  ! t_bsph's--->csph's
    IF(t_crj_flag) THEN
       DO i=1,4
          IF(t_bsph(i)==0) EXIT
       END DO
       esph=t_bsph;esph(i)=1
       csph=esph/fsph
       e=cspX(f,x_1,x_2,x_3,x_4,x_n1)*t_dpsi0/t_psil
       esph(i)=(a-d(1,2))*s/(e(1,2)-a*(SUM(esph)-s))
       csph=esph/fsph
       c=0
       lb=1 ! csph's
    ELSE
       lb=0 ! old way
       a=a/d(1,2)
       c=t_psil*(1-a)
    END IF
    ! End force of continuity of t_crj across separatrix

    DO k = 1,t_km
       IF (t_jwl(k) /= (t_jm+1) .AND. t_jwl(k) /= t_jwu(k)) THEN
          ! inside flux conserver
          n0 = t_jm * (k - 1)
          n3 = 0
          n4 = -1
          IF (s_jbl(k) == (t_jm + 1)) THEN ! No confinement region
             n1 = n0 + t_jwl(k)
             n2 = n0 + t_jwu(k)
             n4=-2
          ELSE
               !  Inside of confinement region...
             n1 = n0 + t_jwl(k)
             n2 = n0 + s_jbl(k) - 1
               ! Outside of confinement region...
             n3 = n0 + s_jbu(k) + 1
             n4 = n0 + t_jwu(k) 
          END IF
          IF(n2>=n1) THEN
             ALLOCATE(pp(n2+1-n1),ff(n2+1-n1),hh(n2+1-n1,2),wk(n2+1-n1))
             pp=(t_psi(n1:n2)-t_psix)/t_dpsi0
             IF(lb==0) THEN
                wk=t_fpsrf(t_msrf)*(t_psi(n1:n2)-c)
                t_crj(n1:n2)=-t_fpsrf(t_msrf)*wk
             ELSE
                hh=cspX(pp,x_1,x_2,x_3,x_4,x_n1)/s
                wk=t_fpsrf(t_msrf)*(t_dpsi0*hh(:,2)-c)
                t_crj(n1:n2)=-t_fpsrf(t_msrf)*hh(:,1)*wk
             END IF
             IF(n4==-2 .AND. t_gsph/=0) THEN
                IF(t_gsph==-1) THEN
                   ff=1/pp
                   a=t_fpsrf(t_msrf)*t_dpsi0
                   WHERE(pp<1)
                      wk=t_frsrf(t_msrf)+a*log(pp)
                   END WHERE
                ELSE
                   a=t_fpsrf(t_msrf)/t_dpsi0/(1+t_gsph)
                   WHERE(pp<1)
                      ff=pp**t_gsph
                      wk=t_frsrf(t_msrf)+a*(pp*ff-1)
                   END WHERE
                END IF
                hh(:,1)=t_crj(n1:n2)
                WHERE(pp<1)
                   hh(:,1)=-wk*t_fpsrf(t_msrf)*ff
                END WHERE
                t_crj(n1:n2)=hh(:,1)
             END IF
             t_bt(n1:n2)=wk/t_rm(n1:n2)
             DEALLOCATE(hh,pp,wk,ff)
          END IF
          IF(n4>n3) THEN
             ALLOCATE(pp(n4+1-n3),wk(n4+1-n3),hh(n4+1-n3,2))
             pp=(t_psi(n3:n4)-t_psix)/t_dpsi0
             IF(lb==0) THEN
                wk=t_fpsrf(t_msrf)*(t_psi(n3:n4)-c)

             ELSE
                hh=cspX(pp,x_1,x_2,x_3,x_4,x_n1)/s
                wk=t_fpsrf(t_msrf)*(t_dpsi0*hh(:,2)-c)
             END IF
             t_crj(n3:n4)=-t_fpsrf(t_msrf)*wk
             t_bt(n3:n4)=wk/t_rm(n3:n4)
             DEALLOCATE(hh,pp,wk)
          END IF
       END IF
    END DO
    t_fgun=t_frsrf(t_msrf)
    IF(t_nitt==1 .OR. t_nitt==iw) THEN
       fw=t_fwall
       iw=t_nitt+t_nl
    END IF
!    t_fwall=fw*d(1,2)
!    CALL parsestr("fwall=pin*jparTor(mtor)*psiEdge/5")
    IF(t_inv_k==3) t_fwall=t_jparsave(t_msrf)*TWOPI*t_psil/5
    t_fwall=t_fwall*d(1,2)
    t_btor=t_fwall/t_ro
    t_bt=t_bt+1.e-20_rq

  END SUBROUTINE s_setcrjX

  SUBROUTINE shift
!
!---   Calculates shifted mesh for 2nd order current and recaculates mesh
!      if the inverse equilibrium is being used
!    Determine plasma-boundary crossing-points on shifted grid if t_kedge>1
!
      REAL(rq) :: pdbs(t_jm,1),bdd(t_jm)
      INTEGER :: j,k,n,ier,isw,lbdry
      IF(SIZE(psish)/=t_jmkm) THEN
         IF(ALLOCATED(rsh)) DEALLOCATE(rsh,zsh,psish,rmsh)
         ALLOCATE(rsh(t_jm),zsh(t_km),psish(t_jmkm),rmsh(t_jmkm))
      END IF
      IF(SIZE(crje)/=t_jmkm) THEN
         IF(ALLOCATED(crje)) DEALLOCATE(crje,jbl2,jbu2)
         ALLOCATE(crje(t_jmkm),jbl2(t_km),jbu2(t_km))
         crje=0
         jbl2=0
         jbu2=0
      END IF
      rsh=t_r-0.5_rq*t_dr ! set up shifted grid
      zsh=t_z-0.5_rq
      rmsh=t_rm-0.5_rq*t_dr
      isw=0
      DO k=1,t_km                ! compute flux on shifted grid 
         bdd=zsh(k)
         ier=1
         call boxm_interp(rsh,bdd,pdbs,t_r,t_z,i_cps,isw,ier,t_n4)
         DO j=1,t_jm
            n=(k-1)*t_jm+j
            psish(n)=pdbs(j,1)
         END DO
      END DO
      lbdry=2
      call psisrf_separatrix(t_psil,lbdry,rsh,zsh,psish)
      IF(SIZE(rlsh)/=s_mlse) THEN
         IF(ALLOCATED(rlsh)) DEALLOCATE(rlsh,zlsh)
         ALLOCATE(rlsh(s_mlse),zlsh(s_mlse))
      END IF
      t_psi=i_cps(:,1,1)
      mlsh=s_mlse
      rlsh=s_rlse     ! crossing-points on shifted grid
      zlsh=s_zlse
    END SUBROUTINE shift

    SUBROUTINE s_edgecur1

      ! calculate correction-current per box around plasma edge
      REAL(rq) :: f0,f1,f2,f01,f02, r10,z10,r20,z20,dre,dze,on_(1),cc_1,&
           cc_2,cc_3,cc_4,cor,dr1,dr2,dz1,dz2
      INTEGER :: mend,m,j,k,n,isign,kstart,klower,nlower
      IF(SIZE(rce)/=t_jqm) THEN
         IF(ALLOCATED(rce)) DEALLOCATE(rce,zce,cce,jnte,knte,ncgp,rcesh,zcesh,&
              cedge)
         ALLOCATE(rce(t_jqm),zce(t_jqm),cce(t_jqm),jnte(t_jqm),knte(t_jqm),&
              ncgp(t_jqm),rcesh(t_jqm),zcesh(t_jqm),cedge(t_jqm))
      END IF
      IF(SIZE(crje)/=t_jmkm) THEN
         IF(ALLOCATED(crje)) DEALLOCATE(crje,jbl2,jbu2)
         ALLOCATE(crje(t_jmkm),jbl2(t_km),jbu2(t_km))
         crje=0
         jbl2=0
         jbu2=0
      END IF
      on_=1
      call s_source(on_,f_f,ppe,0)
      call s_source(on_,f_f,ffpe,1)
      ffpe=ffpe*f_f
      f2= (-FOURPI*s_rlse(1)**2*ppe(1)-ffpe(1) )/s_rlse(1) !   f2=fedge
      mend=s_mlse-1; ! if(t_nsym=1) mend= from s_mlse, & FIX PLCE & test depos
      DO m=1,mend
         dre=s_rlse(m+1)-s_rlse(m)
         dze=s_zlse(m+1)-s_zlse(m)
         ! j,k,n are indices of lower left corner of each box.
         ! reference corner (rce,zce and f0) chosen so t_crj always nonzero.

         IF(dze>0) THEN
            IF(dre<0) THEN
               !ur
               j=1+(s_rlse(m+1)-t_r(1))*(1+errt_rq)/t_dr
               k=1+(s_zlse(m)-t_z(1))*(1+errt_rq)/t_dz
               rce(m)=t_r(j)
               zce(m)=t_z(k)
               n=(k-1)*t_jm+j
               isign=1
               f0=t_crj(n)/t_r(j)
               f01=t_crj(n+1)/t_r(j+1)
               f02=t_crj(n+t_jm)/t_r(j)
               cc_3=t_crj(n)/t_r(j)
               cc_4=t_crj(n-1-t_jm)/t_r(j-1)
               cc_1=t_crj(n-1)/t_r(j-1)
               cc_2=t_crj(n-t_jm)/t_r(j)
            ELSE
               !lr
               j=1+(s_rlse(m)-t_r(1))*(1+errt_rq)/t_dr
               k=1+(s_zlse(m)-t_z(1))*(1+errt_rq)/t_dz
               rce(m)=t_r(j)
               zce(m)=t_z(k+1)
               n=(k-1)*t_jm+j
               isign=-1
               f0=t_crj(n+t_jm)/t_r(j)
               f01=t_crj(n)/t_r(j)
               f02=t_crj(n+1+t_jm)/t_r(j+1)
               cc_3=t_crj(n+t_jm)/t_r(j)
               cc_4=t_crj(n+2*t_jm-1)/t_r(j-1)
               cc_1=t_crj(n+2*t_jm)/t_r(j)
               cc_2=t_crj(n+t_jm-1)/t_r(j-1)
            END IF

         ELSE
            IF(dre<0) THEN
               !ul
               j=1+(s_rlse(m+1)-t_r(1))*(1+errt_rq)/t_dr
               k=1+(s_zlse(m+1)-t_z(1))*(1+errt_rq)/t_dz
               rce(m)=t_r(j+1)
               zce(m)=t_z(k)
               n=(k-1)*t_jm+j
               isign=-1
               f0=t_crj(n+1)/t_r(j+1)
               f01=t_crj(n+1+t_jm)/t_r(j+1)
               f02=t_crj(n)/t_r(j)
               cc_3=t_crj(n+1)/t_r(j+1)
               cc_4=t_crj(n-t_jm+2)/t_r(j+2)         
               cc_1=t_crj(n+2)/t_r(j+2)
               cc_2=t_crj(n-t_jm+1)/t_r(j+1)
            ELSE
               !ll
               j=1+(s_rlse(m)-t_r(1))*(1+errt_rq)/t_dr
               k=1+(s_zlse(m+1)-t_z(1))*(1+errt_rq)/t_dz
               rce(m)=t_r(j+1)
               zce(m)=t_z(k+1)
               n=(k-1)*t_jm+j
               isign=1
               f0=t_crj(n+1+t_jm)/t_r(j+1)
               f01=t_crj(n+t_jm)/t_r(j)
               f02=t_crj(n+1)/t_r(j+1)
               cc_3=t_crj(n+t_jm+1)/t_r(j+1)
               cc_4=t_crj(n+2*t_jm+2)/t_r(j+2)
               cc_1=t_crj(n+t_jm+2)/t_r(j+2)
               cc_2=t_crj(n+2*t_jm+1)/t_r(j+1)
            END IF
         END IF
         jnte(m)=j
         knte(m)=k 
         f1=f2
         f2= (-FOURPI*s_rlse(m+1)**2*ppe(1)-ffpe(1))/s_rlse(m+1)
         r10=s_rlse(m)-rce(m)
         r20=s_rlse(m+1)-rce(m)
         z10=s_zlse(m)-zce(m)
         z20=s_zlse(m+1)-zce(m)
         cce(m)=( (r10*z20 - r20*z10)*(f0+f1+f2) +&
              isign*( r10*z10*(f0+f1+f01) + r20*z20*(f0+f2+f02) ) )/6
         cce(m)=cce(m)-.25*t_dr*t_dz*(f0+f01+f02) ! already included in pdesol
         cor=t_dr*t_dz*((cc_1+cc_2+cc_3+cc_4)/4-(cc_1+cc_2)/6-(cc_3+cc_4)/3)
         IF(t_kedge==-1) cce(m)=cce(m)-cor*(1-(ABS(r20)+ABS(z20))/(t_dr+t_dz))

      END DO
      plce=0
      DO m=1,mend  ! change t_r,zce from reference pt to wire pt
         rce(m)=.5_rq*(rce(m)+.5_rq*(s_rlse(m)+s_rlse(m+1)))
         zce(m)=.5_rq*(zce(m)+.5_rq*(s_zlse(m)+s_zlse(m+1)))
         cce(m)=-cce(m)/FOURPI
         plce=plce+cce(m)
      END DO
      cce(s_mlse)=cce(1)
      rce(s_mlse)=rce(1)
      zce(s_mlse)=zce(1)

      ! deposit edge-current on grid
      ! crje(t_jmkm) ! -4*pi*R*J/c
      ! cce is input wire current in esu/sec
      crje=0
      DO m=1,mend
         j=jnte(m)
         k=knte(m)
         n=(k-1)*t_jm+j
         dr1 = rce(m) - t_r(j)
         dr2 = t_r(j+1) - rce(m)
         dz1 = zce(m) - t_z(k)
         dz2 = t_z(k+1) - zce(m)
         crje(n)      = crje(n) + cce(m)*t_r(j)*dr2*dz2
         crje(n+1)    = crje(n+1) + cce(m)*t_r(j+1)*dr1*dz2
         crje(n+t_jm)   = crje(n+t_jm) + cce(m)*t_r(j)*dr2*dz1
         crje(n+t_jm+1) = crje(n+t_jm+1) + cce(m)*t_r(j+1)*dr1*dz1
      END DO
      DO n=1,t_jmkm
         crje(n)=-crje(n)*4*Pi/(t_dr*t_dz)**2
      END DO
      ! symmetrize assumes upper is done
      IF(t_nsym==10) THEN  ! ???? check prob not here
         kstart = t_km/2 + 2
         DO k=kstart,t_km
            DO j=1,t_jm
               klower = t_km - k + 1
               nlower = (klower - 1)*t_jm + j
               n = (k - 1)*t_jm + j
               crje(nlower) = crje(n)
            END DO
         END DO
      END IF

      ! correct t_crj
      t_crj=t_crj+crje
      jbl2=s_jbl
      jbu2=s_jbu

      ! adjust jbu,jbl  ! WARNING: modified jbl,jbu should have different names
      ! within EDGECUR1 to avoid conflict with values computed
      ! in PSILMS
      ! bugs IF bean shaped
      DO k=1,s_kx-1
         IF(jbl2(k+1)/=t_jm+1) jbl2(k)=jbl2(k+1)-1
         IF(jbu2(k+1)/=0) jbu2(k)=jbu2(k+1)+1
      END DO
      DO k=t_km,s_kx+1,-1
         IF(jbl2(k-1)/=t_jm+1) jbl2(k)=jbl2(k-1)-1
         IF(jbu2(k-1)/=0) jbu2(k)=jbu2(k-1)+1
      END DO
      jbl2(s_kx)=jbl2(s_kx)-1
      jbu2(s_kx)=jbu2(s_kx)+1

      ! compute plas. current. pdesol knows nothing about boundary.
      ! t_crj covers a cell.
      ! seems to me psiscl should be scaling to this plc.
    END SUBROUTINE s_edgecur1

    SUBROUTINE s_edgecur2
      ! Compute 2nd-order-accurate current and Grad-Shafranov source in edge
      !  cells, Should work for bean-shaped as well as convex boundaries

      REAL(rq) :: f0(3),f1,f2,f00,f01,f02,r10,z10,r20,z20,wt,w01,w02,on_(1)
      REAL(rq) :: dre,dze,dse,ca,sa,dy,da,dy1,dy2,re0,ze0,psid(6),aay,bby,&
           ccy,ddy,cc_1,cc_2,cc_3,cc_4,cor
      INTEGER :: kl,ku,j,k,m,n,jn,jref,kref,isign,ier
      REAL(rq) :: psiv(t_jm,t_km)
      include "debug.i"

      IF(SIZE(rce)/=t_jqm) THEN
         IF(ALLOCATED(rce)) DEALLOCATE(rce,zce,cce,jnte,knte,ncgp,rcesh,zcesh,&
              cedge)
         ALLOCATE(rce(t_jqm),zce(t_jqm),cce(t_jqm),jnte(t_jqm),knte(t_jqm),&
              ncgp(t_jqm),rcesh(t_jqm),zcesh(t_jqm),cedge(t_jqm))
      END IF

      psiv=RESHAPE(t_crj,(/t_jm,t_km/))
      on_=1
      call s_source(on_,f_f,ppe,0)
      call s_source(on_,f_f,ffpe,1)
      ffpe=ffpe*f_f
      f2=(-FOURPI*rlsh(1)**2*ppe(1)-ffpe(1))/rlsh(1) ! -(4*pi/!)*J_tor at edge,
                                                     ! at t_r=rlsh(1)
      kl=t_km+1
      ku=0
      DO m=1,mlsh-1
         dre=rlsh(m+1)-rlsh(m)
         dze=zlsh(m+1)-zlsh(m)
         ! j,k,ncgp are indices of lower left corner of each cell on shifted
         ! grid, and of point at which current is corrected on original grid.
         ! reference corner (rcesh, zcesh, f00) chosen so crjsh always nonzero.
         ! indices of reference corner on shifted grid = (jref,kref).
         IF(dze>0) THEN
            IF(dre<0) THEN
               !ur
               j=1+(rlsh(m+1)-rsh(1))*(1+errt_rq)/t_dr
               k=1+(zlsh(m)-zsh(1))*(1+errt_rq)/t_dz
               rcesh(m)=rsh(j)
               zcesh(m)=zsh(k)
               isign=1
               jref=j
               kref=k
               f00=psiv(jref,kref)/rsh(jref)
               f01=psiv(jref+1,kref)/rsh(jref+1)
               f02=psiv(jref,kref+1)/rsh(jref)
               cc_3=psiv(j,k)/rsh(j)
               cc_4=psiv(j-1,k-1)/rsh(j-1)
               cc_1=psiv(j-1,k)/rsh(j-1)
               cc_2=psiv(j,k-1)/rsh(j) 
            ELSE
               !lr
               j=1+(rlsh(m)-rsh(1))*(1+errt_rq)/t_dr
               k=1+(zlsh(m)-zsh(1))*(1+errt_rq)/t_dz
               rcesh(m)=rsh(j)
               zcesh(m)=zsh(k+1)
               isign=-1
               jref=j
               kref=k+1
               f00=psiv(jref,kref)/rsh(jref)
               f01=psiv(jref,kref-1)/rsh(jref)
               f02=psiv(jref+1,kref)/rsh(jref+1)
               cc_3=psiv(j,k+1)/rsh(j)
               cc_4=psiv(j-1,k+2)/rsh(j-1)
               cc_1=psiv(j,k+2)/rsh(j)
               cc_2=psiv(j-1,k+1)/rsh(j-1)
            END IF
         ELSE
            IF(dre<0) THEN
               !ul
               j=1+(rlsh(m+1)-rsh(1))*(1+errt_rq)/t_dr
               k=1+(zlsh(m+1)-zsh(1))*(1+errt_rq)/t_dz
               rcesh(m)=rsh(j+1)
               zcesh(m)=zsh(k)
               isign=-1
               jref=j+1
               kref=k
               f00=psiv(jref,kref)/rsh(jref)
               f01=psiv(jref,kref+1)/rsh(jref)
               f02=psiv(jref-1,kref)/rsh(jref-1)
               cc_3=psiv(j+1,k)/rsh(j+1)
               cc_4=psiv(j+2,k-1)/rsh(j+2)
               cc_1=psiv(j+2,k)/rsh(j+2)
               cc_2=psiv(j+1,k-1)/rsh(j+1)
            ELSE
               !ll
               j=1+(rlsh(m)-rsh(1))*(1+errt_rq)/t_dr
               k=1+(zlsh(m+1)-zsh(1))*(1+errt_rq)/t_dz
               rcesh(m)=rsh(j+1)
               zcesh(m)=zsh(k+1)
               isign=1
               jref=j+1
               kref=k+1
               f00=psiv(jref,kref)/rsh(jref)
               f01=psiv(jref-1,kref)/rsh(jref-1)
               f02=psiv(jref,kref-1)/rsh(jref)
               cc_3=psiv(j+1,k+1)/rsh(j+1)
               cc_4=psiv(j+2,k+2)/rsh(j+2)
               cc_1=psiv(j+2,k+1)/rsh(j+2)
               cc_2=psiv(j+1,k+2)/rsh(j+1)
            END IF
         END IF
         kl=min0(kl,k)
         ku=max0(ku,k)
         ncgp(m)=(k-1)*t_jm+j 
         f1=f2  ! f1=(-4*pi/!)*J_tor at edge, t_r=rlsh(m)
         f2= (-FOURPI*rlsh(m+1)**2*ppe(1)-ffpe(1))/rlsh(m+1) ! at t_r=rlsh(m+1)
         r10=rlsh(m)-rcesh(m)
         r20=rlsh(m+1)-rcesh(m)
         z10=zlsh(m)-zcesh(m)
         z20=zlsh(m+1)-zcesh(m)
         !        J_tor/! integrated over grid-point-centered cell r(j), z(k):
         IF(t_kedge /= 3)THEN
            cedge(m)=-(1./6./FOURPI)*((r10*z20 - r20*z10)*(f00+f1+f2) +&
                 isign*(r10*z10*(f00+f1+f01)+r20*z20*(f00+f2+f02)))
         END IF
         IF(t_kedge.eq.3)THEN  ! correct discontinuity proportional to f_rz
            w01=0.
            w02=0.
            IF(r10*z10 /= 0.)w01=1.
            IF(r20*z20 /= 0.)w02=1.
            wt=.5_rq/(2+w01+w02)/FOURPI    
            cedge(m)=-wt*(f00+w01*f01+w02*f02+.5_rq*(f1+f2))*&
                 (r10*z20-r20*z10+isign*(r10*z10+r20*z20))
         END IF
         cor=t_dr*t_dz*((cc_1+cc_2+cc_3+cc_4)/4-(cc_1+cc_2)/6-(cc3+cc_4)/3)
         cedge(m)=cedge(m)+cor*(1-(abs(r20)+abs(z20))/(t_dr+t_dz))
         !        correct for curvature of plasma edge:
         IF(ndbg26<0) THEN
            dse=sqrt(dre**2+dze**2)
            sa=dze/dse
            ca=-dre/dse
            re0=.5_rq*(rlsh(m)+rlsh(m+1))
            ze0=.5_rq*(zlsh(m)+zlsh(m+1))
            ier=0
            call boxd_interp(re0,ze0,psid,ier,t_n4)
            aay=psid(4)*sa*sa+2.*psid(6)*ca*sa+psid(5)*ca*ca
            bby=psid(2)*sa+psid(3)*ca
            ccy=t_psil-psid(1)
            ddy=bby+sign(1._rq,bby)*sqrt(bby*bby+2*aay*ccy)
            dy1=1.e20
            dy2=1.e20         
            IF(aay /= 0.)dy1=-ddy/aay
            IF(ddy /= 0.)dy2=ccy/ddy
            dy=min(abs(dy1),abs(dy2))  ! distance from chord to boundary
            da=2.*dse*dy/3.  ! area between chord & boundary
            cedge(m)=cedge(m)-.5_rq*(f1+f2)*da/FOURPI
         END IF
      END DO
      cedge(mlsh)=cedge(1)
      rcesh(mlsh)=rcesh(1)
      zcesh(mlsh)=zcesh(1)
      ncgp(mlsh)=ncgp(1)

! correct t_crj in edge-cells:

      DO m=1,mlsh
         t_crj(ncgp(m))=-t_rm(ncgp(m))*cedge(m)*FOURPI/t_dr/t_dz
      END DO

      ! determine jbl2,jbu2, the indices in the r-array of the inner and outer 
      ! boundaries of the region where the 2nd-order crj /= 0. they DO not
      ! necessarily = jbl(k)
      jbl2=t_jm+1
      jbu2=0
      DO k=kl,ku
        DO j=1,t_jm
          n=(k-1)*t_jm+j
          IF(t_crj(n)/=0) EXIT
       END DO
       jbl2(k)=j
       DO j=t_jm,1,-1
          n=(k-1)*t_jm+j
          IF(t_crj(n)/=0) EXIT
       END DO
       jbu2(k)=j
      END DO
    END SUBROUTINE s_edgecur2

    SUBROUTINE s_fix_edge(ps)
      REAL(rq), INTENT(IN) :: ps
      REAL(rq) ::  yb,dummy,wpn,c0(t_msrf),c1(t_msrf)
      INTEGER mx,l
      mx=t_msrf
      IF(ps<1) THEN
        c1=(ps-t_psibar)**2
        dummy=xminaf(c1,1,t_msrf,1,mx)
        c0(:mx)=1
        yb=(1-t_psibar(mx))**10
        c0(mx+1:)=(1-((t_psibar(mx+1:)-t_psibar(mx)))**10/yb)
        t_vp=t_pdsrf*c0
        t_wp=2*t_fpsrf*t_frsrf*c0
     ELSE
        t_vp=t_pdsrf*c0
        t_wp=2*t_fpsrf*t_frsrf*c0
     END IF
     yb=t_splbdry
     CALL spline_interp(t_psibar,t_vp,yb,yb,t_vpp,t_vppp,c1,t_v)
     CALL spline_interp(t_psibar,t_wp,yb,yb,t_wpp,t_wppp,c1,t_w)
     wpn=t_frsrf(t_msrf)**2/t_dpsi0
     DO l=1,t_msrf
        t_v(l)=t_v(l)-t_v(t_msrf)
        t_w(l)=(t_w(l)-t_w(t_msrf))+wpn
     END DO
     IF(t_filter_p>2) THEN
        t_v=zero_der_interp(t_psibar,t_v,t_filter_p)
     ELSEIF(t_filter_p/=0) THEN
        CALL polyfit_interp(t_v,t_vp,t_psibar,t_dpoly,t_spoly,t_mpoly,-2)
        ! zeroes derivative at edge
        yb=777
     END IF
     CALL spline_interp(t_psibar,t_v,yb,yb,t_vp,t_vpp,t_vppp,noint)
     yb=t_splbdry
     IF(t_filter_wp>2) THEN
        t_w=zero_der_interp(t_psibar,t_w,t_filter_wp)
     ELSEIF(t_filter_wp/=0) THEN
        CALL polyfit_interp(t_w,t_wp,t_psibar,t_dpoly,t_spoly,t_mpoly,-2)
        ! zeroes derivative at edge
        yb=777
     END IF
     CALL spline_interp(t_psibar,t_w,yb,yb,t_wp,t_wpp,t_wppp,noint)
     t_prsrf=t_v*t_dpsi0
     t_pdsrf=t_vp
     t_frsrf=SQRT(t_w*t_dpsi0)
     t_fpsrf=0.5*t_wp/t_frsrf
     t_v=t_v/t_betaj
     t_vp=t_vp/t_betaj
     t_vp=t_vp/t_betaj
     t_vpp=t_vpp/t_betaj
     t_w=t_w/(8*PI)
     t_wp=t_wp/(8*PI)
     t_wpp=t_wpp/(8*PI)
     t_wppp=t_wppp/(8*PI)
     t_prsx=1.0000000001
     t_ipscl=-1
     t_ipp=999
     t_ipf=999
   END SUBROUTINE s_fix_edge

END MODULE source_mod

