! $Id: inv.f90,v 1.2 2007/07/23 16:00:58 meyer Exp $

MODULE inv_mod

  USE teqPol_mod
  USE source_mod

  IMPLICIT NONE

  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE ::  uk,vk,anu,a,ai,ha,pswpts,&
       c_0,c_1,c_2,c_3,dpsrf,qelm,pelm,selm,c_q,qq,tt,hh,rr,dq1,dq2,cq1,cq2
  REAL(rq), DIMENSION(:),POINTER, PRIVATE :: tet
  REAL(rq), DIMENSION(:,:), ALLOCATABLE, PRIVATE :: ur,ut,vz,vt,jac,e2
  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE :: y,y0,rajh,rajh0,drq,au,bu,&
       haaj0,hatj0,curk,fu,drq0,ajj,fi0,haaj,hatj,fi,drr,auq,buq,fuq,bet,&
       rosg,cp1,cp2,cp3,qrk_,fsp,fsp1,fsp2,fsp3,psp
  REAL(rq), DIMENSION(:), ALLOCATABLE, PUBLIC :: pst,tst
  REAL(rq), PRIVATE :: um,vm,psend,elong,rsj,rsj0,zdp0
  INTEGER,  PRIVATE :: nh,nst,mlm
  INTEGER, PARAMETER, PRIVATE :: GAMMA=5._rq/3._rq

CONTAINS
  
  SUBROUTINE polar1(kp,ip)
    !**************************************************************
    !  AUTHORS Triniti group                                      *
    !  MODIFIED by LDP                                            *
    !**************************************************************
    ! calculates inverse equilibrium

    !**************************************************************
    ! kp<=0: input qrk, pp(kp=0) or srk(kp=-1); output f          *
    ! kp= 3: input jrk, pp; output f and p preserved              *
    ! with                                                        *
    ! ip<0;  input psend; output=tpl(KA), pp(scaled), p fixed     *
    ! ip=0:  input fwall;output dpsi0, plc(amps*10) tpl(KA)       *
    ! ip> 0; input tpl; output psend, pp(scaled), p fixed         *
    !-------------------------------------------------------------*
    ! kp= 1: input pff and pp; output p and f; pp and pff scaled  *
    ! kp= 2: input jrk, pp; output f, pff; pp scaled to fix p     *
    ! with                                                        *
    ! ip= 0: input none; output tpl=current(KA), psend            *
    ! ip< 0: input psend; output tpl;                             *
    ! ip> 0: tpl input; output psend;                             *
    !**************************************************************
    INTEGER, INTENT(IN) :: kp,ip
    INTEGER :: ndbg,m,ii,jj,nsave,ntp,i,j,nal,jp,jps,ips
    REAL(rq) :: norm,rr(4),zz(4),dd(4),ps(4),fwalli,rrd(4),zzd(4),&
         za(3),ra(3),uu(2),vv(2),uk_(2),um0,ff(4),no_yint(1),xx(4)
    REAL(rq) :: a11,a22,ddd,ut2,vt2,ds1,ua1,va1,uc1,vc1,ss,al0,sf,sd,qc,&
         qr,yy,x1,x2,x3,rat_,al1,tok1,tok2,tok3,tok4,tok5,tok6,tok7,tok8,&
         fadd,dum,dvm,y1,yb,us,de1,de2,ppi,pffi,prj,bum,dfuv,&
         sigm,padd,pbnd,inv_x,frat
    LOGICAL ibd
    CHARACTER(len=128) :: mes
    SAVE ntp,nsave,inv_x,frat,ips,jp
    include "debug.i"
    DATA nsave /0/,ntp/0/,yb/777/,no_yint(1)/-999/,y1/-666/,inv_x/0/,frat/1/
    DATA ips /0/, jp/0/

    IF(t_npo*t_ntet/=nsave) THEN
       IF(nsave/=0) DEALLOCATE(ur,ut,vz,vt,jac,e2,cp1,cp2,cp3,qrk_,rosg)
       ALLOCATE(ur(t_npo,t_ntet),ut(t_npo,t_ntet),vz(t_npo,t_ntet),&
            vt(t_npo,t_ntet),jac(t_npo,t_ntet),e2(t_npo,t_ntet),cp1(t_npo),&
            cp2(t_npo),cp3(t_npo),qrk_(t_npo),rosg(t_npo))
       nsave=t_npo*t_ntet
       ur=0;vz=0;e2=0
    END IF
    IF(ntp/=t_ntet+1) THEN
       if(ntp/=0) DEALLOCATE(y,y0,rajh,rajh0,drq,au,bu,haaj0,hatj0,curk,&
            fu,drq0,ajj,fi0,haaj,hatj,fi,drr,auq,buq,fuq,bet,qq,tt,hh)
       ntp=t_ntet+1
       ALLOCATE(y(ntp),y0(ntp),rajh(ntp),rajh0(ntp),drq(ntp),au(ntp),&
            bu(ntp),haaj0(ntp),hatj0(ntp),curk(ntp),fu(ntp),drq0(ntp),&
            ajj(ntp),fi0(ntp),haaj(ntp),hatj(ntp),fi(ntp),drr(ntp),&
            auq(ntp),buq(ntp),fuq(ntp),bet(ntp),qq(t_ntet),tt(t_ntet),&
            hh(t_ntet))
       ntp=t_ntet+1
    END IF
    ibd=.true.
    IF(kp==1) THEN
       fwalli=t_f(1)**2
    ELSE
       fwalli=t_f(1)
    END IF
    pbnd=t_p(1)
    jac=0
    al1=1
    norm=1
    m=t_ntet+1
    t_qrk(1)=t_qrk(2)
    qrk_=t_qrk
    um0=um
    !     US=1./DKRI0
    us=t_ro
    nh=0
    IF(t_anun==0) t_anun=1

    !     By~iClEHiE plO}Adi KOvYXA
    !.....computation of cross-sectional area of plasma
    ss=uk(t_ntet)*(vk(2)-vk(t_ntet-1))
    ss=ss+SUM(uk(2:t_ntet-1)*(vk(3:)-vk(:t_ntet-2)))
    ss=ss*0.5_rq
    nal=0
    tok8=psend ! needed for ip=-2
    if(t_inv_x==0) jp=0
    jps=jp
    IF(abs(t_inv_x)/=0 .AND. t_inv_x/=inv_x) THEN
       DO jp=t_npo-1,1,-1
          IF(t_psiinv(jp)<=t_inv_x) EXIT
       END DO
       IF(ALLOCATED(psp)) THEN
          IF((SIZE(psp)/=jp)) DEALLOCATE(psp,fsp,fsp1,fsp2,fsp3)
       END IF
       IF(.NOT.ALLOCATED(psp)) ALLOCATE(psp(jp),fsp(jp),fsp1(jp),fsp2(jp),&
            fsp3(jp))
       inv_x=t_inv_x
    ELSE IF(t_inv_x==0 .OR. t_inv_x==1) THEN
          jp=t_npo+1
    END IF
    IF(ip/=ips .OR. jp/=jps) frat=1
    ips=ip

    !----------------------------------------------------------------------

1001 continue
    de1=0
    de2=0
    t_nitt=t_nitt+1
    !     HA~AlO PAC~ETA
    !.....start of calculation
    IF(t_iter_bdry .AND. ibd) THEN
       ! Move boundary points to conform with teq coordinates--LDP 96/1/7
       IF(t_nsym/=2) THEN
          uk_(1)=uk(1)
          uk_(2)=uk(t_ntet/2+1)
       END IF
       tt=atan2((vk-vm)/elong,uk-um)
       DO i=1,t_ntet
          IF(tt(i)>0) EXIT
       END DO
       DO j=i,t_ntet
          IF(tt(j)<=0) EXIT
       END DO
       DO i=j,t_ntet
          tt(i)=tt(i)+TWOPI
       END DO
       qq=uk
       call interp_interp(tt,qq,y1,y1,tet,uk,hh)
       qq=vk
       call interp_interp(tt,qq,y1,y1,tet,vk,hh)
       IF(t_nsym/=2) THEN
          uk_(1)=uk(1)
          uk_(2)=uk(t_ntet/2+1)
       END IF
    END IF
    !---- end of boundary move
    ibd=.true.
    t_ns1=0
    nst=3
    !     OKAjMlEHiE
    !.....boundary
    t_rork(:,1)=t_rork(:,t_ntet)
    t_aj(:,1)=t_aj(:,t_ntet)
    drr(2:t_ntet)=(((uk(2:)+uk(:t_ntet-1))*.5_rq-um)**2+((vk(2:)+&
         vk(:t_ntet-1))*0.5_rq-vm)**2)
    drr(m)=drr(2);drr(1)=drr(t_ntet)
    drr=0.5_rq*sqrt(drr)
    !-----------------------------------------------------------------------

    !     HA~AlxHyj {Ag: OpPEdElEHiE Y(1.5,J), I=2
    !.....beginning {Ag: determination of Y(3/2,j)}
    IF(nal==0) THEN
       al0=0
       nal=1
    ELSE
       al0=t_alfa1
    END IF
    DO i=1,t_npo
       ur(i,:)=(1-al0)*(um+t_rork(i,:)*(uk-um))+al0*ur(i,:)
       vz(i,:)=(1-al0)*(vm+t_rork(i,:)*(vk-vm))+al0*vz(i,:)
    END DO

    DO i=1,t_npo
       ut(i,2:)=ur(i,2:)-ur(i,:t_ntet-1)
       vt(i,2:)=vz(i,2:)-vz(i,:t_ntet-1)
    END DO
    t_crk(1)=0
    tok1=0
    !-----------------------------------------------------------------------
    !     C~ET pO KAvdOj pOBEPXHOCTi A(I)=CONST, I=3,T_NPO
    !.....calculation along each surface a(i)=constant

    DO i=2,t_npo ! Begin i loop---flux
       tok2=0
       tok3=0
       tok4=0
       tok5=0
       tok6=0
       tok7=0
       ppi=t_pp(i)
       pffi=t_pff(i)
       IF(t_ifluxcord==-1) THEN ! Now derivative wrt poloidal flux
          ppi=ppi*qrk_(i)
          pffi=pffi*qrk_(i)
       END IF
       DO j=2,t_ntet
          ua1=ur(i,j)-ur(i-1,j)+ur(i,j-1)-ur(i-1,j-1)
          va1=vz(i,j)-vz(i-1,j)+vz(i,j-1)-vz(i-1,j-1)
          ds1=ua1*(vt(i,j)+vt(i-1,j))-va1*(ut(i,j)+ut(i-1,j))
          uc1=0.25_rq*(ur(i,j)+ur(i-1,j)+ur(i,j-1)+ur(i-1,j-1))
          vc1=0.25_rq*(vz(i,j)+vz(i-1,j)+vz(i,j-1)+vz(i-1,j-1))
          ddd=sqrt((uc1-um)**2+(vc1-vm)**2)
          IF(ds1==0) THEN
             WRITE(mes,*)"TEQ failure in polar1: impending zero divide"
             CALL errdetec(mes,0)
          END IF
          drq(j+1)=4*ha(i)*drr(j)*ddd/ds1
          jac(i,j)=ds1*uc1
          a11=us/uc1
          a22=a11
          hatj(j+1)=(-a11*va1*(vt(i,j)+vt(i-1,j))-a22*ua1*(ut(i,j)+ut(i-1,j)))&
               /ds1*ha(i)
          ut2=2*(ut(i,j)**2+ut(i-1,j)**2)
          vt2=2*(vt(i,j)**2+vt(i-1,j)**2)
          haaj(j+1)=(a11*vt2+a22*ut2)/ds1*ha(i)
          IF(kp>1) THEN ! jrk as input
             fi(j+1)=ds1
          ELSEIF(i>jp) THEN
             fi(j+1)=-(ppi*uc1/us+0.5_rq*pffi*us/uc1)*ds1*0.25_rq
          ELSE ! here always derivs wrt poloidal flux
             fi(j+1)=-(ppi*uc1/us+kp*0.5_rq*pffi*us/uc1)*ds1*0.25_rq
          END IF
          tok7=tok7+4*(ut2+vt2)*uc1/ds1
          tok6=tok6+4*(ut2+vt2)/uc1*vc1/ds1
          tok5=tok5+4*(ut2+vt2)/uc1/ds1
          tok4=tok4+ds1/uc1
          tok3=tok3+ds1*uc1
          tok2=tok2+ds1/uc1
          rajh(j+1)=ds1/(uc1*4*ha(i))
       END DO
       t_crk(i)=2.5e+04_rq*tok5*anu(i)*ha(i)*us
       t_rrk(i)=tok7/tok5 ! radius squared of current centroid
       t_zrk(i)=tok6/tok5 !         height of current centroid
       IF(t_ifluxcord<=0) THEN
          t_vrk(i)=TWOPI**2*tok3/tok4
       ELSE
          t_vrk(i)=TWOPI*tok3/anu(i)/us*2e-2
       END IF
       jac(i,:)=jac(i,:)*0.5_rq/(anu(i)*ha(i)*FOURPI)
       t_trk(i)=0.5_rq*tok2*t_f(i)/anu(i)/ha(i)/FOURPI
       IF(kp/=0) t_qrk(i)=t_trk(i)
       IF(kp>1) THEN
          prj=1+tok5/tok4*(anu(i)*ha(i)/t_f(i))**2
          IF(kp==2) THEN ! jtsrf as input
             IF(t_ifluxcord==2) THEN
                pffi=2*(t_jrk(i)/qrk_(i)-ppi*tok3/tok4/us**2)/prj
             ELSE
                pffi=2*(t_jrk(i)-ppi*tok3/tok4/us**2)/prj
             END IF
          ELSEIF(kp==3) THEN ! jparsrf as input
             pffi=2*(t_jrk(i)*t_f(i)-ppi*tok3/tok4/us**2/prj)
          END IF
          IF(t_ifluxcord==-1) THEN
             t_pff(i)=pffi/qrk_(i) ! back to toroidal flux derivative
          ELSE
             t_pff(i)=pffi
          END IF
          DO j=2,t_ntet
             uc1=0.25_rq*(ur(i,j)+ur(i-1,j)+ur(i,j-1)+ur(i-1,j-1))
             fi(j+1)=-(ppi*uc1/us+0.5_rq*pffi*us/uc1)*fi(j+1)*0.25_rq
          END DO
       END IF
       !     OKAjMlEHiE
       !.....boundary
       fi(1)=fi(t_ntet)
       drq(1)=drq(t_ntet)
       haaj(1)=haaj(t_ntet)
       hatj(1)=hatj(t_ntet)
       rajh(1)=rajh(t_ntet)
       fi(2)=fi(m)
       drq(2)=drq(m)
       haaj(2)=haaj(m)
       hatj(2)=hatj(m)
       rajh(2)=rajh(m)
       rsj=us/SUM(rajh(3:))
       tok1=tok1+SUM(fi(2:t_ntet))
       IF(i==2) THEN

          ! HAXOdiM Y(1.5,J)
          ! .....we find Y(3/2,j)
          sf=0.5_rq*SUM(fi(2:t_ntet))
          sd=SUM(haaj(2:t_ntet))

          yy=sf/sd
          qrk_(1)=qrk_(2)
          t_qrk(1)=t_qrk(2)
          t_trk(1)=t_trk(2)
          IF (kp==0) THEN
             qc=TWOPI*(qrk_(1)+qrk_(2))/2*us
             qr=TWOPI*qrk_(2)*rsj/us
             yy=anu(2)
             t_f(2)=yy*qr
             t_f(1)=((sd+qc*qr)*yy-sf)/qc
             IF(nh/=0) THEN
                ff(2:4)=t_f(2:4)
                ps=t_psiinv(:4)
                t_f(1)=extrp(ff,ps,4,0,0)
             END IF
          END IF
          ! -----------------------------------------------------
          !     TO~HOCTi   TO~HOCTi   TO~HOCTi
          !.....precision
          y(:)=yy
          t_aj(i,:)=yy
          ! -----------------------------------------------------
       ELSE ! remaining surfaces
          ! -----------------------------------------------------
          !     pOlY~EHiE KO|fficiEHTOB AU, BU, CU, FU dlq PAzHOCTHyX YPABHEHij
          !.....calculation of coefficients AU,... for the difference equations
          !     YPABHEHiq PE{A\TCq METOdOM pPOgOHKi
          !.....equations solved by method of running(?) driving(?)
          ! -----------------------------------------------------
          DO j=2,t_ntet
             au(j)=-0.25_rq*hatj(j+1)
             bu(j)=0.25_rq*hatj(j)
             curk(j)=0.5_rq*(haaj(j+1)+haaj(j))-au(j)-bu(j)
             x1=y0(j)*0.5_rq*(haaj0(j+1)+haaj0(j))
             x2=-0.25_rq*hatj0(j+1)*(y0(j+1)+y0(j))
             x3=0.25_rq*hatj0(j)*(y0(j)+y0(j-1))
             fu(j)=0.25_rq*(fi(j)+fi(j+1)+fi0(j)+fi0(j+1))+x1+x2+x3
             ! BBEdEHiE BqzKOCTi  (DRQ(J),DRQ0(J)=0 pPi DR=0)
             ! .....conduction(?) of viscosity
             au(j)=au(j)+drq(j+1)
             bu(j)=bu(j)+drq(j)
             curk(j)=curk(j)+drq(j)+drq(j+1)
             fu(j)=fu(j)-drq0(j+1)*(y0(j+1)-y0(j))+drq0(j)*(y0(j)-y0(j-1))
          END DO
          !-------------------------------------------------------
          !     OpPEdElEHiE Y(I+0.5,J)
          !.....determination of Y(i+1/2,j)

          IF(kp==0 .AND.i<=jp) THEN
             ajj(2:m)=t_aj(i,:t_ntet);ajj(1)=t_aj(i,t_ntet)
             call quval(i)
             IF(i==jp) THEN
                psp=t_psiinv(:jp)
                fsp=t_f(:jp)
                CALL spline_interp(psp,fsp,t_splbdry,t_splbdry,fsp1,fsp2,fsp3,&
                     no_yint)
                t_pff(:jp)=2*t_f(:jp)*fsp1*t_psidinv(t_npo)/anu(t_npo)
                ddd=t_inv_x-psp(jp)
                xx(1)=fsp(jp)+ddd*(fsp1(jp)+0.5_rq*ddd*(fsp2(jp)+ddd*fsp3(jp)/&
                     3))
                xx(2)=fsp1(jp)+ddd*(fsp2(jp)+0.5_rq*ddd*fsp3(jp))
                xx(3)=fsp2(jp)+ddd*fsp3(jp)
                ddd=1-t_inv_x
                IF(iabs(ip)==2) THEN
                   xx(3)=frat*xx(3)
                END IF
                xx(4)=-2*(xx(2)+xx(3)*ddd)/ddd**2
                rr(1)=xx(1)+ddd*(xx(2)+0.5_rq*ddd*(xx(3)+ddd/3*xx(4)))
                rr(2)=xx(2)+ddd*(xx(3)+0.5_rq*ddd*xx(4))
                ddd=t_psiinv(i+1)-t_inv_x
                rr(1)=xx(1)+ddd*(xx(2)+0.5_rq*ddd*(xx(3)+ddd/3*xx(4)))
                rr(2)=xx(2)+ddd*(xx(3)+0.5_rq*ddd*xx(4))
                t_f(i+1)=rr(1)
                rr(2)=2*rr(1)*rr(2)*t_psidinv(t_npo)/anu(t_npo)
                t_pff(i+1)=rr(2)
             END IF
          ELSEIF(kp==0 .AND. i<t_npo) THEN
             ddd=t_psiinv(i+1)-t_inv_x
             rr(1)=xx(1)+ddd*(xx(2)+0.5_rq*ddd*(xx(3)+ddd/3*xx(4)))
             rr(2)=xx(2)+ddd*(xx(3)+0.5_rq*ddd*xx(4))
             t_f(i+1)=rr(1)
             rr(2)=2*rr(1)*rr(2)*t_psidinv(t_npo)/anu(t_npo)
!             t_pff(i+1)=t_alfa0*t_pff(i+1)+(1-t_alfa0)*rr(2)
               t_pff(i+1)=rr(2)
             call progc(au,bu,curk,fu,y)
          ELSE
             call progc(au,bu,curk,fu,y)
          END IF
          yy=SUM(y(2:t_ntet))/(t_ntet-1)
          e2(i,:)=abs((t_aj(i,:)-y(2:))/t_aj(i,:))
          t_aj(i,:)=y(2:)
          DO j=2,t_ntet
             IF(e2(i,j)>=de1) THEN
                de1=e2(i,j)
                ii=i;jj=j
             END IF
          END DO
       END IF
       !     pEPEpPiCBAiBAHiE zHA~EHij, pOlY~EHHyX HA pPEdydY}Ej pOBEPXHOCTi
       !.....save values obtained on previous surfac
       drq0=drq
       haaj0=haaj
       hatj0=hatj
       fi0=fi
       rajh0=rajh
       rsj0=rsj
       y0=y
       !...................................................................
    END DO ! i loop

    rat_=t_alfa0-(1-t_alfa0)*yy*TWOPI*us/psend
    IF(kp==2 .AND. (ip==0 .OR. ip==1)) THEN
       psend=psend*rat_
       anu=rat_*anu
       t_pp=t_pp/rat_
    ELSEIF(kp==3 .AND. (ip==1 .OR. ip==-1)) THEN
       IF(t_ifluxcord==2) THEN
          fwalli=fwalli*rat_
       ELSE
          fwalli=fwalli/rat_
       END IF
    ELSEIF(kp==1 .AND. (ip==0 .OR. ip==1)) THEN
       psend=psend*rat_
       anu=rat_*anu
       t_pp=t_pp/rat_
    END IF
    IF(kp>1) THEN
       t_f=0.5_rq*t_pff/t_f*anu*ha
       IF(t_ifluxcord==-1) t_f=t_f*qrk_
       t_f(1)=0
       DO i=2,t_npo
          t_f(i)=t_f(i-1)+t_f(i)
       END DO
       fadd=fwalli-t_f(t_npo)
       t_f=t_f+fadd
       t_frk=t_f
       DO i=t_npo,2,-1
          t_f(i)=0.5_rq*(t_f(i)+t_f(i-1))
       END DO
    END IF
    !-----------------------------------------------------------------------
    !     PE0{EHiE YPABHEHiq dlq RO(A,TETA)
    !.....solution of equation for R0
    call ruthere
    ff(:3)=t_f(t_npo-2:)
    ps(:3)=t_psiinv(t_npo-2:)
    ps(4)=1
    ff(4)=extrp(ff,ps,4,1,0)
    tok1=tok1*10/FOURPI
    IF(kp==0) tok1=2.5_rq*tok5*ha(t_npo)*anu(t_npo)*us/FOURPI
    IF(kp==1 .OR. kp==2) THEN
       IF(ip==1) THEN
          al1=t_alfa0+(1-t_alfa0)*tok1/t_tpl
       ELSEIF(ip==3) THEN
          al1=t_alfa0+(1-t_alfa0)*um/um0
       ELSEIF(ip==-1) THEN
          al1=t_alfa0-(1-t_alfa0)*yy*TWOPI*us/psend
       END IF
       al1=1/al1
       IF(kp==1) THEN
          t_pff=t_pff*al1
          t_pp=t_pp*al1
       ELSEIF(kp==2) THEN
          t_jrk=t_jrk*al1
       END IF
       norm=norm*al1
    ELSE
       IF(ip>=0 ) THEN
          IF(ip==1) THEN
             al1=(t_alfa0+(1-t_alfa0)*tok1/t_tpl)
          ELSEIF(ip==3) THEN
             al1=t_alfa0+(1-t_alfa0)*um/um0
          ELSEIF(kp==0) THEN
             al1=(t_alfa0+(1-t_alfa0)*ff(4)/fwalli)
          ELSE
             al1=1/(t_alfa0-(1-t_alfa0)*yy*TWOPI*us/psend)
          END IF
          al1=1/al1
          psend=psend*al1
          anu=anu*al1
          t_pp=t_pp/al1 ! preserves p
       END IF
       IF(ip==2) THEN
          frat=frat+(1-tok1/t_tpl)*100
       ELSEIF(ip==-2) THEN
          frat=frat+(1+yy*TWOPI*us/psend)*100
       END IF
    END IF
    t_anun=0.
    rosg(1)=0.
    t_rork(1,:)=0
    DO j=1,t_ntet
       e2(2:,j)=(t_rork(2:,j)-t_rork(:t_npo-1,j))*anu(2:)/t_aj(2:,j)
    END DO
    DO j=1,t_ntet-1
       bum=0
       DO i=2,t_npo
          bum=bum+e2(i,j)
          rosg(i)=bum
       END DO
       e2(2:,j)=t_rork(2:,j)
       t_rork(2:,j)=rosg(2:)/rosg(t_npo)
       e2(2:,j)=abs(e2(2:,j)-t_rork(2:,j))
       !     TO~HOCTi   TO~HOCTi   TO~HOCTi<<<<<
       !.....precision
       IF(j==1) THEN
          y(1)=((uk(1)-um)*(vk(2)-vk(t_ntet-1))-(vk(1)-vm)*(uk(2)-&
               uk(t_ntet-1)))*rosg(t_npo)
       ELSE
          y(j)=((uk(j)-um)*(vk(j+1)-vk(j-1))-(vk(j)-vm)*(uk(j+1)-uk(j-1)))*&
               rosg(t_npo)
       END IF
       t_anun=t_anun+y(j)
    END DO
    t_rork(:,t_ntet)=t_rork(:,1)
    e2(:,t_ntet)=e2(:,1)
    t_anun=4*ss/t_anun
    y(t_ntet)=y(1)
    !     TO~HOCTi   TO~HOCTi   TO~HOCTi<<<<<
    !.....precision
    !DC   de0=abs((an0-t_anun)/t_anun)
    !     OpPEdElEHiE MAgHiTHOj OCi
    !.....calculation of magnetic axis
    !     OpPEdElEHiE TO~Ki |KCTPEMYMA
    !.....calculation of peak current
    t_rrk(1)=extrp(t_rrk,t_psiinv,t_npo,0,0)
    t_zrk(1)=extrp(t_zrk,t_psiinv,t_npo,0,0)
    DO i=2,4
       ps(i)=sqrt(t_psiinv(i))
       ps(1)=0
       dum=0.
       dvm=0.
       dfuv=0.
       DO j=2,t_ntet
          sigm=(t_rork(i,j)**2-t_rork(i-1,j)**2)*0.5_rq*(t_rork(i,j)+t_rork(i-1,j))/& 
               ha(i)/anu(i)*y(j)
          dum=dum+uk(j)*sigm
          dvm=dvm+vk(j)*sigm
          dfuv=dfuv+sigm
       END DO
       rr(i)=dum
       zz(i)=dvm
       dd(i)=dfuv
    END DO
    dum=rr(2)/dd(2)
    dvm=zz(2)/dd(2)
    IF(ldbg10==1) THEN
       rr(1)=extrp(rr,ps,4,0,1)
       zz(1)=extrp(zz,ps,4,0,1)
       dd(1)=extrp(dd,ps,4,0,1)
       dum=rr(1)/dd(1)
       dvm=zz(1)/dd(1)
    ELSEIF(ldbg10==-1) THEN
       dum=sqrt(t_rrk(1));dvm=t_zrk(1)
    END IF
    um=(1-t_alfa1)*dum+t_alfa1*um
    vm=(1-t_alfa1)*dvm+t_alfa1*vm
    !----------------------------------------------------------------------
    !     C~ET ~iClA iTEPAcij
    !.....iteration count
    IF(t_ifluxcord<=0) THEN
       t_vrk=t_vrk/(t_f*us*1.e+03_rq)
    END IF
    IF(t_entropy_flag==1) THEN ! LDP 98/1/7 p' from entropy
       cp1=t_alfa0*t_srk*t_vrk**(-GAMMA)+(1-t_alfa0)*t_p
       cp1(1)=extrp(cp1,t_psiinv,t_npo,0,0)
       t_p=cp1
       yb=t_splbdry
       IF(t_filter_p<0) THEN
          CALL polyfit_interp(cp1,t_pp,t_psiinv,t_dpoli,t_spoli,t_mpoli,1)
          yb=777
       ELSEIF(t_filter_p==1) THEN
          CALL polyfit_interp(cp1,t_pp,t_psiinv,t_dpoli,t_spoli,t_mpoli,-2)
          ! Derivative on edge to zero
          yb=777
       ELSE
          call spline_interp(t_psiinv,cp1,yb,yb,t_pp,cp2,cp3,no_yint)
       END IF
    END IF

    nh=nh+1

    !..... reset anu IF t_ifluxcord=-1 and kp/=0

    IF(t_ifluxcord == -1 .AND. kp/=0) THEN
       anu=anu*qrk_
       qrk_=(1-t_alfa2)*qrk_+t_alfa2*qrk_
       anu=anu/qrk_
       psend=-anu(t_npo)*us*TWOPI
    END IF

    !-------------------------------------------------------------------------
    !     pPOBEPKi HA OKOH~AHiE
    !.....test for completion
!    IF(nh.ge.t_nht)go to 24
    DO j=2,t_ntet
       DO i=2,t_npo
          IF(e2(i,j).gt.de2)de2=e2(i,j)
       END DO
    END DO
    t_residj=max(de1,de2)
    IF (t_nprt59 == 2) THEN
!       call parsestr("debug_inv")
       t_anun=abs(1-t_anun)
       rat_=1+psend/(yy*TWOPI*us)
       WRITE(STDOUT,2000)nh,t_residj,t_anun,rat_,al1-1
       WRITE(t_logunit,2000)nh,t_residj,t_anun,rat_,al1-1
2000   format(' res(',i3,')= ',1pe10.3, &
            ' anun= ',1pe10.3,' rat= ',1pe10.3,' ',1pe10.3)
    END IF
    IF(t_residj > t_epsrk .AND. nh<t_nht) THEN
       go to 1001
    ELSEIF(t_residj>1000) THEN
       WRITE(mes,*) "inverse solver will diverge"
       CALL errdetec(mes,1)
    ELSEIF(nh>=t_nht .AND. t_nht>=30 .AND. t_fix_bound) THEN
       WRITE(mes,'(a,i4,a,1pe8.1,a,1pe8.1)')&
            " inverse solver failed to converge, nht = ",&
            t_nht," residj =",t_residj," epsrk =",t_epsrk
       CALL errdetec(mes,-1)
    END IF
    !     OKOH~ATElxHAq BydA~A
    !.....final output

!24  continue
    IF(t_nprt59 == 2) THEN
       WRITE(STDOUT,1000)um,vm,t_anun,nh
       WRITE(t_logunit,1000)um,vm,t_anun,nh
    END IF
1000 FORMAT(10X,'UM=',1pe10.3,',VM=',1pe10.3,',anun=',1pe10.3,',nh=',i4)
    ! 
    t_rork(:,1)=t_rork(:,t_ntet)
    !DC   pt02=to1k
    !     print *,'tok1==',tok1
    rat_=1
    IF(kp==1) THEN
       IF(ip==0 .OR. ip==1) rat_=-yy*TWOPI*us/psend
       t_f=t_pff*anu*ha*rat_
       t_p= t_pp*anu*ha*rat_
       IF(t_ifluxcord==-1) THEN
          t_f=t_f*t_qrk
          t_p=t_p*t_qrk
       END IF
       t_f(1)=0
       t_p(1)=0
       DO i=2,t_npo
          t_f(i)=t_f(i-1)+t_f(i)
          t_p(i)=t_p(i-1)+t_p(i)
       END DO
       fadd=fwalli-t_f(t_npo)
       padd=-t_p(t_npo)+pbnd
       t_f=t_f+fadd
       t_p=t_p+padd
       DO i=t_npo,2,-1
          t_p(i)=0.5_rq*(t_p(i)+t_p(i-1))
          t_f(i)=0.5_rq*(t_f(i)+t_f(i-1))
       END DO
       t_f=sqrt(t_f)
    ELSE
       IF(ip==1 .OR. (ip==0 .AND. kp==2)) rat_=-yy*TWOPI*us/psend
       t_p=t_pp*anu*ha*rat_
       IF(t_ifluxcord==-1) t_p=t_p*t_qrk
       t_p(1)=0
       DO i=2,t_npo
          t_p(i)=t_p(i-1)+t_p(i)
       END DO
       padd=-t_p(t_npo)+pbnd
       t_p=t_p+padd
       DO i=t_npo,2,-1
          t_p(i)=0.5_rq*(t_p(i)+t_p(i-1))
       END DO
    END IF
    t_anun=norm
    t_tpl=tok1
    psend=-yy*TWOPI*us
    t_qrk(1)=extrp(t_qrk,t_psiinv,t_npo,0,0)
    t_trk(1)=extrp(t_trk,t_psiinv,t_npo,0,0)
    t_vrk(1)=extrp(t_vrk,t_psiinv,t_npo,0,0)
    t_jrk(1)=extrp(t_jrk,t_psiinv,t_npo,0,0)
    t_f(1)=extrp(t_f,t_psiinv,t_npo,0,0)
    t_pff(1)=extrp(t_pff,t_psiinv,t_npo,0,0)
    t_p(1)=extrp(t_p,t_psiinv,t_npo,0,0)
    t_pp(1)=extrp(t_pp,t_psiinv,t_npo,0,0)
  END SUBROUTINE polar1

  SUBROUTINE quval(i)
    INTEGER :: n,m,nsix,ns0,i,j,k
    REAL(rq) :: alf,arfs,alfr,x,x1,x2,x3,ff,qq,alfs,dsu
    SAVE nsix
    data nsix /10/
    
    m=t_ntet+1
    n=t_ntet
    ns0=t_ns1
    t_ns1=0
    !     MACCiB Y(J) CHA~AlA - KAK BCpOMOgATElxHyj
    y(2:n)=ajj(2:n)

    !     OKAjMlEHiE AU,BU
    au(1)=au(n)
    au(m)=au(2)
    bu(1)=bu(n)
    bu(m)=bu(2)
    bet(2:n)=0.25_rq*TWOPI*(t_qrk(i-1)*rsj0*(rajh0(2:n)+rajh0(3:m))+t_qrk(i)*&
         rsj*(rajh(2:n)+rajh(3:m)))
    ff=t_f(i-1)
    qq=t_qrk(i)

    !     HA~AlO iTEPAcij
    DO k=1,nsix
    !----------------------------------------------------------------------
    !     ECli ~iClO iTEPAcij BHYTPi 'QUVAL' HA pPEdydY}Ej iTEPAcii 'POLAR'
    !     bylO BEliKO, TO HA~. pPiblivEHiE - C pPEdydY}EgO ClOq (T.E. Y0)
    !     TEKY}Ej iTEPAcii 'POLAR',  ECli HET,
    !     TO HA~. pPiblivEHiE - C pPEdydY}Ej iTEPAcii 'POLAR' (T.E. T_AJ(I,J))
    !----------------------------------------------------------------------
       IF(ns0<=nst) THEN
          y0(2:n)=y(2:n)
       ELSE
          ns0=0
       END IF
       !     C~ET~iK BHYTPEHHiX iTEPAcij
       fuq(2:n)=0.5_rq*(rajh(3:m)+rajh(2:n))/y0(2:n)
       alfs=SUM(fuq(2:n))
       fuq(2:n)=fuq(2:n)/y0(2:n)
       auq(2:n)=bu(3:m)
       buq(2:n)=au(:n-1)
       call progc (auq,buq,curk,fuq,y)
       alfs=TWOPI*qq/alfs**2
       x1=SUM(bet(2:n)*y(2:n))
       x2=SUM(fu(2:n)*y(2:n))
       x1=x1*alfs
       x2=x2*alfs
       x=(ff*x1+x2)/(1.+x1)
       dsu=ff-x
       fuq(2:n)=fu(2:n)+bet(2:n)*dsu
       call progc(au,bu,curk,fuq,y)

       !----------------------------------------------------------------------
       !     pPOBEPKA HA OKOH~AHiE
       DO j=2,n
          IF(abs((y(j)-y0(j))/y(j)).gt.t_epskrk) EXIT
       END DO
       IF(j>n) EXIT
    END DO
    IF(k.gt.nsix) THEN
       call errdetec("quval: failed to converge in jx iterations",0)
       RETURN
    END IF
    t_ns1=k
    t_f(i)=x
  END SUBROUTINE quval

  SUBROUTINE progc(a,b,c,g,u)
    REAL(rq), DIMENSION(:) :: a,b,c,g,u
    REAL(rq), DIMENSION(SIZE(a)) :: alf,betc,u0,f0
    REAL(rq) :: d,fi2,fi20
    INTEGER :: m,k

    m=SIZE(a)
    u0(2)=0
    u0(m)=0

    DO k=2,m-1
       f0(k)=g(k)
    END DO
    alf(3)=0
    DO k=3,m-1
       alf(k+1)=a(k)/(c(k)-alf(k)*b(k))
    END DO

    betc(3)=u0(2)
    DO k=3,m-1
       betc(k+1)=(f0(k)+betc(k)*b(k))/(c(k)-alf(k)*b(k))
    END DO
    DO k=m-1,3,-1
       u0(k)=alf(k+1)*u0(k+1)+betc(k+1)
    END DO

    DO k=2,m
       f0(k)=0
       u(k)=u0(k)
    END DO

    u0(2)=1
    u0(m)=1
    betc(3)=u0(2)
    DO k=3,m-1
       betc(k+1)=(f0(k)+betc(k)*b(k))/(c(k)-alf(k)*b(k))
    END DO
    DO k=m-1,3,-1
       u0(k)=alf(k+1)*u0(k+1)+betc(k+1)
    END DO

    u(1)=u(m-1)
    u0(1)=u0(m-1)
    fi20=a(2)*u0(3)-c(2)*u0(2)+b(2)*u0(1)
    fi2=a(2)*u(3)-c(2)*u(2)+b(2)*u(1)
    d=-(g(2)+fi2)/fi20

    DO k=1,m
       u(k)=u(k)+d*u0(k)
    END DO
  END SUBROUTINE progc

  SUBROUTINE start_inv(kp,ip)
    INTEGER, INTENT(IN) :: kp,ip
    INTEGER :: lfg,i,j
    REAL(rq) :: aa(t_msrf)
    IF(SIZE(i_rhosq,1)/=t_msrf*t_mls) THEN
       IF(ALLOCATED(i_rhosq)) DEALLOCATE(i_rhosq)
       IF(t_n6==6) THEN
          ALLOCATE(i_rhosq(t_msrf*t_mls,2,3))
       ELSEIF(t_n6==16) THEN
          ALLOCATE(i_rhosq(t_msrf*t_mls,4,4))
       END IF
       i_rhosq=0
    END IF
    CALL mach
    t_npo=t_msrf;t_ntet=t_mls
    CALL teq_interface
    t_psil=t_psrf(t_msrf)
    t_psix=t_psrf(1)
    lfg=t_entropy_flag
    t_entropy_flag=0
    IF(t_inv_eq>=0) THEN
       t_rork(2:,:)=SQRT((TRANSPOSE(t_rlsd(:,2:,1)-t_raxis)**2)+&
            (TRANSPOSE(t_zlsd(:,2:,1)-t_zaxis)**2)/t_wvert**2)
       DO i=2,t_npo
          t_rork(i,:)=t_rork(i,:)/t_rork(t_npo,:)
       END DO
       t_rork(1,:)=0
    ELSEIF(t_inv_eq==-1) THEN
       aa=(/(i,i=0,t_npo-1)/)/(t_npo-1._rq)
       DO j=1,t_ntet
          t_rork(:,j)=aa
       END DO
    ELSEIF(t_inv_eq==-2) THEN
       t_rork(2:,:)=SQRT((TRANSPOSE(t_rlsd(:,2:,1)-t_raxis)**2)+&
            (TRANSPOSE(t_zlsd(:,2:,1)-t_zaxis)**2)/t_wvert**2)
       DO i=2,t_npo
          t_rork(i,:)=t_rork(i,:)/t_rork(t_npo,:)
       END DO
       t_rork(1,:)=0
    END IF
    t_inv_eq=0
    call teq_inv(kp,ip)
    t_entropy_flag=lfg
    IF(t_entropy_flag/=0) t_ssave=abs(t_vptor)**GAMMA
  END SUBROUTINE start_inv

  SUBROUTINE escinv
    ! calls ESC (zakharov)
    INTEGER ifail,ns,imth,clockwise,ls,l,lss
    EXTERNAL esc00,escin,esc1,escGetPsibar,escGetPhibar,escGetG,escGetP,&
         escGetR,escGetZ,esc
    SAVE ns
    REAL(rq), DIMENSION(t_msrf) :: p_esc,q_esc,j_esc,s_esc,temp_esc,psi_esc,&
         phi_esc,p_temp,g_esc
    REAL(rq), DIMENSION(t_mls) ::  cq_,rb_,zb_,dq_
    REAL(rq) :: yp,rbtor,dummy,rr(4)
    DATA yp /-666/, imth /-10/, clockwise /0/ ! counter clockwise
    CHARACTER(len=32) label
    include "debug.i"
    IF(ns/=t_msrf .AND. ns/=0) THEN
       call esc1;t_ijob=0
    END IF
    ns=t_msrf
    rb_=t_rls*.01_rq;zb_=t_zls*.01_rq
    s_esc=(/(ls,ls=0,ns-1)/)/(ns-1.0)
    p_temp=SQRT(t_phibar)
    call interp_interp(p_temp,t_qsave,t_splbdry,t_splbdry,s_esc,q_esc,temp_esc)
    call interp_interp(p_temp,t_psave,t_splbdry,t_splbdry,s_esc,p_esc,temp_esc)
    call interp_interp(p_temp,t_jtsave,t_splbdry,t_splbdry,s_esc,j_esc,&
         temp_esc)
    p_esc=0.1_rq*p_esc*MU0       ! MKS
    j_esc=-s_pin*1.0e+4*j_esc/t_raxis*MU0 ! MKS and amps/M**2
    p_esc=p_esc/(1e6*MU0);j_esc=j_esc/(1e6_rq*MU0)
    rbtor=1.e-6_rq*abs(t_fwall)
    IF(t_ijob==0) THEN ! initialization
       label="esc_test"
       call esc00(label,t_msrf-1)
       call escin(p_esc,j_esc,s_esc,t_msrf,21,rb_,zb_,t_mls,rbtor,.01_rq*&
            t_raxis)
       call esc(ifail, t_ijob, t_mesc, dummy) !Execute ESC
       t_ijob=1
       IF(ifail /= 0) THEN ! Test against failure
          print *, 'ESC-failure ', ifail
          print *, 'possible causes are:'
          print *, 'ifail=2 problems near the boundary'
          print *, 'ifail=4 problems near the axis'
          print *, 'ifail=8 problems in the middle'
          print *, 'odd ifail numbers are usually tolerable'
       END IF
    END IF

    IF(t_inv_k==0) THEN
       Call escin(p_esc,q_esc,s_esc,t_msrf,26,rb_,zb_,t_mls,rbtor,.01_rq*&
            t_raxis)
    ELSE
       call escin(p_esc,j_esc,s_esc,t_msrf,21,rb_,zb_,t_mls,rbtor,.01_rq*&
            t_raxis)
       !     p_esc=p_esc*(1e6*MU0);j_esc=j_esc*(1e6*MU0)
       !     call esc_p_jparallel(p_esc,j_esc,rb_,zb_,t_mls,rbtor,.01_rq*&
    END IF
    call esc(ifail, t_ijob, t_mesc, dummy)
    IF(ifail /= 0) THEN ! Test against failure
       print *, 'ESC-failure ', ifail
       print *, 'possible causes are:'
       print *, 'ifail=2 problems near the boundary'
       print *, 'ifail=4 problems near the axis'
       print *, 'ifail=8 problems in the middle'
       print *, 'odd ifail numbers are usually tolerable'
    END IF
    call escGetPsibar(psi_esc,t_msrf)
    call escGetPhibar(phi_esc,t_msrf)
    call escGetG(g_esc,t_msrf)
    call escGetP(t_prsrf,t_msrf)
    call escGetR(t_rlsd(1,1,1),t_mls,t_msrf,clockwise)
    call escGetZ(t_zlsd(1,1,1),t_mls,t_msrf,clockwise)
    g_esc=1e6_rq*g_esc
    t_prsrf=t_prsrf*10/MU0
    t_rlsd(:,:,1)=100*t_rlsd(:,:,1);t_zlsd(:,:,1)=100*t_zlsd(:,:,1)
    t_raxis=t_rlsd(1,1,1);t_zaxis=t_zlsd(1,1,1)
    t_dpsi0=psi_esc(t_msrf);t_dphi0=phi_esc(t_msrf)
    psi_esc=psi_esc/t_dpsi0;psi_esc(1)=0
    phi_esc=phi_esc/t_dphi0;phi_esc(1)=0
    t_dpsi0=1e8*s_pin*t_dpsi0;t_dphi0=1e8_rq*s_pin*t_dphi0
    IF(ndbg28==1) THEN ! Using ESC coordinates
       call fdDeriv(t_prsrf,psi_esc,t_msrf,t_pdsrf);t_pdsrf=t_pdsrf/t_dpsi0
       t_frsrf=g_esc
       call fdDeriv(t_frsrf,psi_esc,t_msrf,t_fpsrf);t_fpsrf=t_fpsrf/t_dpsi0
       p_temp=sqrt(psi_esc)
       t_rhosq(:,:,1)=transpose(t_rlsd(:,:,1))
       call bispline_interp(p_temp,t_tswpts,t_rhosq,imth,t_n6)
       t_rlsd(:,:,3)=transpose(t_rhosq(:,:,2))
       t_rlsd(:,:,2)=transpose(t_rhosq(:,:,3))
       t_rhosq(:,:,1)=transpose(t_zlsd(:,:,1))
       call bispline_interp(p_temp,t_tswpts,t_rhosq,imth,t_n6)
       t_zlsd(:,:,3)=transpose(t_rhosq(:,:,2))
       t_zlsd(:,:,2)=transpose(t_rhosq(:,:,3))
       t_rhosq(:,:,1)=t_zlsd(:,:,1)
       DO l=2,t_msrf
          t_rlsd(:,l,3)=t_rlsd(:,l,3)*0.5_rq/(p_temp(l)*t_dpsi0)
          t_zlsd(:,l,3)=t_zlsd(:,l,3)*0.5_rq/(p_temp(l)*t_dpsi0)
       END DO
       t_zlsd(:,:,4)=(t_rlsd(:,:,3)*t_zlsd(:,:,2)-t_rlsd(:,:,2)*&
            t_zlsd(:,:,3))*t_rlsd(:,:,1)
       DO ls=1,t_mls
          rr(2:)=t_zlsd(ls,2:4,4)
          t_zlsd(ls,1,4)=extrp(rr,p_temp,4,0,0)
       END DO
       t_rlsd(:,:,4)=sqrt(t_rlsd(:,:,2)**2+t_zlsd(:,:,2)**2)/abs(t_zlsd(:,:,4))
       t_psrf=t_psix+psi_esc*t_dpsi0
       dpsrf(2:)=t_psrf(2:)-t_psrf(:t_msrf-1)
       call get_surfint
       p_temp=t_cusrf/t_frsrf/.4_rq/PI
       call fdDeriv(p_temp,psi_esc,t_msrf,t_jtsrf)
       t_jtsrf=-t_frsrf**2*t_jtsrf/TWOPI/q_esc/t_dpsi0
       call remark("in escinv")
       CALL debugger
    END IF
    call interp_interp(psi_esc,t_prsrf,t_splbdry,t_splbdry,t_psibar,t_prsrf,&
         t_pdsrf)
    call interp_interp(psi_esc,g_esc,t_splbdry,t_splbdry,t_psibar,t_frsrf,t_fpsrf)
    t_pdsrf=t_pdsrf/t_dpsi0;t_fpsrf=t_fpsrf/t_dpsi0
    DO l=2,t_msrf
       t_rls=t_rlsd(:,l,1);t_zls=t_zlsd(:,l,1)
       cq_=atan2((t_zls-t_zaxis)/t_wvert,t_rls-t_raxis)
       DO ls=1,t_mls
          IF(cq_(ls)>=0)EXIT
       END DO
       DO lss=ls,t_mls
          IF(cq_(lss)<0) cq_(lss)=cq_(lss)+TWOPI
       END DO
       cq_(t_mls)=cq_(t_mls)+TWOPI
       call interp_interp(cq_,t_rls,yp,yp,t_tswpts,rb_,dq_)
       t_rlsd(:,l,3)=rb_
       t_rlsd(:,l,4)=dq_
       call interp_interp(cq_,t_zls,yp,yp,t_tswpts,zb_,dq_)
       t_zlsd(:,l,3)=zb_
       t_zlsd(:,l,4)=dq_
    END DO
    t_rlsd(:,1,3)=t_raxis;t_zlsd(:,1,3)=t_zaxis
    DO ls=1,t_mls
       p_temp=(t_rlsd(ls,:,3)-t_raxis)**2+((t_zlsd(ls,:,3)-t_zaxis)/t_wvert)**2
       call interp_interp(psi_esc,p_temp,t_splbdry,t_splbdry,t_psibar,pswpts,&
            temp_esc)
       t_rlsd(ls,:,1)=t_raxis+sqrt(pswpts)*t_brwpts(ls)
       t_zlsd(ls,:,1)=t_zaxis+sqrt(pswpts)*t_bzwpts(ls)*t_wvert
    END DO
!    IF(ndbg28==1) call parsestr('<<"exiting escinv";debugger')
  END SUBROUTINE escinv

  SUBROUTINE teq_inv(kp,ip)
    ! calls polar1 to calculate inverse coordinates      
    ! ********************************************************************
    !  kp=0: input qsave and t_psave or t_ssave on t_entropy_flag;         *
    !        output t_frsrf with t_psave fixed IF input.                 *
    !  kp=3: input jparsave--->t_jparsrf, t_psave; output t_frsrf        *
    !  with:                                                             *
    !  ip<0: input dpsi00; output plc(amps*10) tpl(KA)                   *
    !  ip=0: input t_fwall;output t_dpsi0, plc(amps*10) tpl(KA)          *
    !  ip>0: input plcm; output t_dpsi0 (dpsi00=t_dpsi0)                 *
    ! ------------------------------------------------------------------ *
    !  kp=1: input FF'=fpsrf*t_frsrf, t_psave; output FF', T_P' (scaled) *
    !  kp=2: input jtsave--->t_jtsrf, t_psave; output  jtsave(scaled)    *
    !        and t_frsrf with t_psave fixed                              *
    !  with                                                              *
    !  ip=0: no input; output plc (tpl) and t_dpsi0 (dpsi00=t_dpsi0)     *
    !  ip<0: input dpsi00; output plc and                                *
    !  ip>0; input plcm; output t_dpsi0=dpsi00;                          *
    ! ********************************************************************
    include "debug.i"
    INTEGER kp,ip 
    REAL(rq) :: pdp,pdm,qdp,qdm,qp,dflat,dmn,qpp,qppp,qq,zpsend,&
    bel(3,3),rel(3),rho(t_mls),zdpsi0,zt_frsrf,zdpsi00,y1,aa(4),bb(4),&
         fff(1),ffp(1),aaa(1),yb,noyint(1),wp0,qcelm_,pcelm_,scelm_,qmin,&
         qmn,dflas,dms,denom,eps
    INTEGER :: npoo,nteto,i,lelm_,iqq,l,lmt,lms,lflas,j,m3,m4,m5,iq,ls,lss,&
         mmm,jj,iter
    integer :: sz
    SAVE npoo,nteto,noyint,y1
    DATA noyint(1)/-999_rq/,y1/-666_rq/
    DATA npoo/0/,nteto/0/

    IF(npoo/=t_npo) THEN
       IF(npoo/=0)DEALLOCATE(anu,a,ai,ha,c_0,c_1,c_2,c_3,dpsrf,qelm,pelm,&
            selm)
       ALLOCATE(anu(t_npo),a(t_npo),ai(t_npo),ha(t_npo),c_0(t_npo),c_1(t_npo),&
            c_2(t_npo),c_3(t_npo),dpsrf(t_npo),qelm(t_npo),pelm(t_npo),&
            selm(t_npo))
       a=(/(i,i=0,t_npo-1)/)/(t_npo-1._rq)
       ai(2:)=(a(2:)+a(:t_npo-1))/2
       ha(2:)=a(2:)-a(:t_npo-1)
       ai(1)=0;ha(1)=0
       c_0=0;c_1=0;c_2=0;c_3=0
    END IF
    IF(nteto/=t_ntet) THEN
       IF(ALLOCATED(uk))DEALLOCATE(uk,vk,pswpts,c_q)
       ALLOCATE(uk(t_ntet),vk(t_ntet),pswpts(t_ntet),c_q(t_ntet))
       uk=0;vk=0;c_q=0
       nteto=t_ntet
    END IF
    sz = 0; if (allocated(t_vp)) sz = size(t_vp)
    IF(t_msrf/=sz) 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(SIZE(s_jbl)/=t_km) THEN
       IF(ALLOCATED(s_jbl)) DEALLOCATE(s_jbl,s_jbu)
       ALLOCATE(s_jbl(t_km),s_jbu(t_km))
    END IF

    ! For rezonine
    IF(t_ntet==t_mls .AND. t_npo==t_msrf) THEN
       sz = 0; if (allocated(tst)) sz = size(tst)
       IF(sz/=t_ntet) THEN
          IF(ALLOCATED(tst)) DEALLOCATE(tst)
          ALLOCATE(tst(t_ntet))
          tst=t_tswpts
       END IF
       sz = 0; if (allocated(pst)) sz = size(pst)
       IF(sz/=t_npo) THEN
          IF(ALLOCATED(pst)) DEALLOCATE(pst)
          ALLOCATE(pst(t_npo))
          pst=t_psibar
       END IF
    END IF
    
    CALL i_t(i_rhosq)
    s_pin=SIGN(1.0_rq,t_dpsi0)
    yb=t_splbdry
    t_fwall=t_ro*t_btor
    tet=>t_tswpts
    IF(t_inv_flag<=0) THEN
       IF(t_use_halo) call haloboundary
       IF(t_inv_eq==0) THEN
          uk=t_rls
          vk=t_zls
          um=t_raxis
          vm=t_zaxis
          elong=t_wvert ! for inv
       END IF
       IF(uk(1)==0) THEN ! must initialize
          uk=t_rls
          vk=t_zls
       END IF
    END IF
    npoo=t_npo
    ! begin disruption models OR ELM model
    IF(t_vpsrf(1)==0)t_vpsrf=1
    IF(t_ifluxcord<=0) THEN
       t_vptor=abs(t_vpsrf/t_qsrf)
    ELSE
       t_vptor=t_vpsrf
    END IF
    qelm=t_qsave
    selm=t_ssave
    pelm=t_psave
    IF(t_use_halo .AND. t_lhalo<t_msrf) THEN
       zdpsi0=t_dpsi0;zdpsi00=t_dpsi00
       t_dpsi00=(t_psih-t_psix);t_dpsi0=t_dpsi00
       c_0=t_psix+(t_psih-t_psix)*t_psibar
       call interp_interp(t_psrf,qelm,yb,yb,c_0,c_1,c_2)
       qelm=c_1
       call interp_interp(t_psrf,selm,yb,yb,c_0,c_1,c_2)
       selm=c_1
       call interp_interp(t_psrf,pelm,yb,yb,c_0,c_1,c_2)
       pelm=c_1
    END IF
    IF(t_lelm/=0) THEN
       IF(t_lelm>0) THEN
          qcelm_=t_qcelm/(1-t_rhosrf(t_lelm))**3
          pcelm_=t_pcelm/(1-t_rhosrf(t_lelm))**3
          scelm_=t_scelm/(1-t_rhosrf(t_lelm))**3
          lelm_=t_lelm
          c_3=(t_rhosrf-t_rhosrf(t_lelm))**3
          c_2=c_3
       ELSEIF(t_lelm<0) THEN
          lelm_=-t_lelm
          qcelm_=t_qcelm/(1-t_rhosrf(lelm_))**4
          pcelm_=t_pcelm/(1-t_rhosrf(lelm_))**3
          scelm_=t_scelm/(1-t_rhosrf(lelm_))**3
          c_2=(t_rhosrf-t_rhosrf(lelm_))**3
          c_3=c_2*(1-t_rhosrf)
       END IF
       IF(t_pcelm>0) THEN
          pelm=t_psave*(1+pcelm_*c_2)
       ELSEIF(t_pcelm<0) THEN
          pelm=t_psave/(1-pcelm_*c_2)
       END IF
       IF(t_scelm>0) THEN
          selm=t_ssave*(1+scelm_*c_2)
       ELSEIF(t_scelm<0) THEN
          selm=t_ssave/(1-scelm_*c_2)
       END IF
       IF(t_qcelm>0) THEN
          qelm=t_qsave*(1+qcelm_*c_3)
       ELSEIF(t_qcelm<0) THEN
          qelm=t_qsave/(1-qcelm_*c_3)
       END IF
    END IF
    IF(t_lflat>0) THEN
       qelm=t_qsave
       qmin=xminaf(qelm,1,t_msrf,1,iq)
       IF(iq/=1 .AND. qmin>1) THEN
          qmin=qmin-(qelm(iq+1)-qelm(iq-1))**2/(qelm(iq+1)+qelm(iq-1)-&
               2*qelm(iq))/8
       ELSE
          iq=1
       END IF
       DO l=t_msrf-1,1,-1
          IF(qelm(l)<t_qflat) EXIT
       END DO
       t_lflat=l+1
       pdp=t_rhosrf(t_lflat+1)-t_rhosrf(t_lflat)
       pdm=t_rhosrf(t_lflat-1)-t_rhosrf(t_lflat)
       qdp=(qelm(t_lflat+1)-qelm(t_lflat))/pdp
       qdm=(qelm(t_lflat-1)-qelm(t_lflat))/pdm
       qpp=(qdp-qdm)/(pdp-pdm)
       qp=(qdp*pdm-qdm*pdp)/(pdm-pdp)
       qq=t_qflat-qelm(t_lflat)
       dflat=2*qq/qp/(1+sqrt(1+2*qq*qpp/qp**2))
       qp=qp+qpp*dflat
       dflat=dflat+t_rhosrf(t_lflat)
       dmn=-3*t_qrat*(t_qflat-qmin)/qp
       qpp=-2*qp/dmn ! makes q', q''=0 ,at joint
       qppp=-qpp/dmn ! makes q', q''=0 ,at joint
       qmn=t_qflat+dmn*(qp+0.5_rq*dmn*(qpp+dmn*qppp/3._rq))
       dmn=dmn+dflat
       DO l=2,t_lflat
          IF(t_rhosrf(l)>dmn) EXIT
       END DO
       lmt=l
       DO l=lmt,t_lflat-1
          c_3(l)=t_rhosrf(l)-dflat
          qelm(l)=t_qflat+c_3(l)*(qp+0.5_rq*c_3(l)*(qpp+c_3(l)*qppp/3._rq))
       END DO
       lms=0
       IF(iq>1 .AND. qelm(1)>t_qflat) THEN
          DO l=2,lmt
             IF(qelm(l)<t_qflat) EXIT
          END DO
          lflas=l-1
          pdp=t_rhosrf(lflas+1)-t_rhosrf(lflas)
          pdm=t_rhosrf(lflas-1)-t_rhosrf(lflas)
          qdp=(qelm(lflas+1)-qelm(lflas))/pdp
          qdm=(qelm(lflas-1)-qelm(lflas))/pdm
          qpp=(qdp-qdm)/(pdp-pdm)
          qp=(qdp*pdm-qdm*pdp)/(pdm-pdp)
          qq=t_qflat-qelm(lflas)
          dflas=2*qq/qp/(1+sqrt(1+2*qq*qpp/qp**2))
          qp=qp+qpp*dflas
          dflas=dflas+t_rhosrf(lflas)
          dms=3*(qmn-t_qflat)/qp
          qpp=-2*qp/dms ! makes q',q''=0 ,at joint
          qppp=-qpp/dms ! makes q',q''=0 ,at joint
          qmn=t_qflat+dms*(qp+0.5_rq*dms*(qpp+dms*qppp/3._rq))
          dms=dms+dflas
          DO l=lflas+1,t_lflat-1
             IF(t_rhosrf(l)>dms) EXIT
          END DO
          lms=l-1
          DO l=lflas+1,lms
             c_3(l)=t_rhosrf(l)-dflas
             qelm(l)=t_qflat+c_3(l)*(qp+0.5_rq*c_3(l)*(qpp+c_3(l)*qppp/3._rq))
          END DO
       END IF
       DO l=lms+1,lmt-1
          qelm(l)=qmn
       END DO
    END IF
    IF(t_lflat/=0) THEN
       selm=t_scflat*t_ssave
       pelm=t_scflat*t_psave
    END IF

    !  end models

    !  limit q(1) for reverse shear

    IF(qelm(1) > t_qmax) THEN
       qmin=xminaf(qelm,1,t_msrf,1,iq)
       IF(iq/=1) THEN
          qmin=qmin-(qelm(iq+1)-qelm(iq-1))**2/(qelm(iq+1)+qelm(iq-1)-&
               2*qelm(iq))/8
       END IF
       eps=(qelm(1)/t_qmax-1)/(qelm(1)/t_qmax-qmin/t_qmax)**2
       DO i=1,iq
          qelm(i)=qelm(i)/(1+eps*((qelm(i)-qmin)/t_qmax)**2)
       END DO
    END IF
    !   end limit
    IF(t_dpsi00==0) t_dpsi00=t_dpsi0
    IF(t_dphi00==0) t_dphi00=t_dphi0

    ! inputs for inverse equilibrium
    IF(t_inv_flag<=0) THEN
       IF(t_nitt<=1 .AND. t_wvert/=1) THEN
          IF(t_esrf(1)/=0 .AND. t_fix_bound) t_wvert=t_esrf(1)
       END IF
       elong=t_wvert
       IF(t_ifluxcord==-1) THEN
          zdp0=t_dphi00
          IF(t_ipj==2 .AND. .NOT.t_fix_bound) zdp0=t_dphi0
       ELSE
          zdp0=t_dpsi00
          IF(t_ipj==2 .AND. .NOT.t_fix_bound) zdp0=t_dpsi0
       END IF
       t_tpl=t_plcm*1.e+03
       t_inv_eq=1
       IF(t_fix_bound) t_inv_eq=2
       IF(t_inv_eq==1) THEN 
          IF(t_ipj==0 .OR. t_ipj>5) THEN
             IF(t_raxis==0) THEN
                t_raxis=um;t_zaxis=vm
                pswpts=(t_rls-t_raxis)**2+((t_zls-t_zaxis)/t_wvert)**2
                c_q=atan2((t_zls-t_zaxis)/t_wvert,t_rls-t_raxis)
                DO i=1,t_mls
                   IF(c_q(i)>0) EXIT
                END DO
                DO j=i,t_mls
                   IF(c_q(j)<0) EXIT
                END DO
                c_q(j:)=c_q(j:)+TWOPI
                call interp_interp(c_q,pswpts,y1,y1,t_tswpts,pswpts,noyint)
                t_rls=t_raxis+sqrt(pswpts)*cos(t_tswpts)
                t_zls=t_zaxis+sqrt(pswpts)*sin(t_tswpts)*t_wvert
             END IF
             uk=t_rls*t_alfa1+uk*(1-t_alfa1)
             vk=t_zls*t_alfa1+vk*(1-t_alfa1)
          END IF
       ELSEIF(t_nitt==0 .AND. t_inv_eq==2) THEN
          uk=t_rls
          vk=t_zls
       END IF
       denom=t_prsx*t_betaj
       IF(kp==0) THEN
          IF(t_entropy_flag>0) THEN
             pelm=selm/(t_vptor)**GAMMA
             t_psave=pelm
          ELSEIF(t_entropy_flag<0 .AND. t_nitt<=1) THEN
             pelm=selm/(t_vptor)**GAMMA
             t_psave=pelm
          END IF
          call interp_interp(t_rhosrf,qelm,yb,yb,t_psiinv,t_qrk,c_3)
          call interp_interp(t_rhosrf,selm,yb,yb,t_psiinv,t_srk,c_3)
          call interp_interp(t_rhosrf,t_frsrf,yb,yb,t_psiinv,t_f,t_pff)
          t_srk=4e-3_rq*PI*s_pin*t_ro*t_srk/zdp0
          t_f=t_f/(t_ro*1.e+03_rq)
          t_pff=2*s_pin*t_f*t_pff/zdp0
          t_f(t_npo)=t_frsrf(t_msrf)/(t_ro*1.e+03_rq)
          t_f(1)=t_frsrf(t_msrf)/(t_ro*1.e+03_rq) ! boundary condition
       ELSE
          IF(kp==1) t_frsrf=t_fsave
          call interp_interp(t_rhosrf,t_qsrf,yb,yb,t_psiinv,t_qrk,c_3)
          call interp_interp(t_rhosrf,t_frsrf,yb,yb,t_psiinv,t_f,t_pff)
          t_f=t_f/(t_ro*1.e+03_rq)
          t_pff=2*s_pin*t_f*t_pff/zdp0
          t_pff(1)=extrp(t_pff,ai,t_npo,0,0)
          t_f(1)=t_frsrf(t_msrf)/(t_ro*1.e+03_rq) ! boundary condition
          IF(kp==3) THEN
             call interp_interp(t_rhosrf,t_jparsave,yb,yb,t_psiinv,t_jrk,c_3)
             t_jrk=FOURPI*s_pin*t_jrk/10.0_rq
          ELSEIF(kp==2) THEN
             call interp_interp(t_rhosrf,t_jtsave,yb,yb,t_psiinv,t_jrk,c_3)
             t_jrk=FOURPI*s_pin*t_jrk/(1e+04_rq*t_ro)
          END IF
          !          t_fpsrf=t_fpsrf/zdp0
       END IF
       IF(ip/=1 .AND. ip/=-1 .AND. kp/=1 .AND. kp/=2) THEN
          IF(t_ifluxcord==2) THEN
             t_f(1)=t_fwall/(t_ro*1.e+03_rq) ! boundary condition
          ELSE
             t_f(1)=abs(t_fwall)/(t_ro*1.e+03_rq) ! boundary condition
          END IF
       END IF
       ! Set up arary v which can be filtered
       IF(t_ifluxcord==-1) THEN
          t_v=pelm/denom/t_dpsi00
       ELSE
          t_v=pelm/denom/zdp0
       END IF
       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
       ELSEIF(t_filter_p<0) THEN
          CALL polyfit_interp(t_v,t_vp,t_psibar,t_dpoly,t_spoly,t_mpoly,1)
          yb=777
       ELSE
          DO i=1,3
             bel(i,1)=1
             bel(i,2)=t_psibar(i+2);bel(i,3)=t_psibar(i+2)*sqrt(t_psibar(i+2))
          END DO
          call rmInvert(bel,3,3)
          DO i=1,3
             rel(i)=0
             DO j=1,3
                rel(i)=rel(i)+bel(i,j)*t_v(j+2)
             END DO
          END DO
          t_v(1)=rel(1)
          t_v(2)=rel(1)+t_psibar(2)*(rel(2)+sqrt(t_psibar(2))*rel(3))
       END IF
       call spline_interp(t_psibar,t_v,yb,yb,t_vp,t_vpp,t_vppp,noyint)
       t_pdsrf=t_vp*denom
       IF(t_ifluxcord==-1) THEN ! this is computed for consistancy
          t_prsrf=t_v*denom*t_dpsi00
       ELSE
          t_prsrf=t_v*denom*zdp0
       END IF
       yb=t_splbdry ! reset

       ! begin inverse solver
       call interp_interp(t_rhosrf,t_v,yb,yb,t_psiinv,t_p,t_pp)
       IF(t_entropy_flag>0) THEN
          ! difference needed for entropy option
          t_p=FOURPI*1.e-3_rq*s_pin*t_ro*t_p*denom
       ELSE
          t_p=FOURPI*t_p*1e-6_rq*t_dpsi0*denom
       END IF
       t_pp=FOURPI*t_pp*1e-3_rq*s_pin*t_ro*denom
       t_p(1)=FOURPI*t_v(t_msrf)*1e-6_rq*t_dpsi0*denom ! boundary condition
       anu=s_pin*zdp0*1e-3_rq/t_ro*t_psidinv
       IF(t_ifluxcord==-1) THEN
          anu=anu/t_qrk
          t_pp=t_pp*t_dpsi00/zdp0 ! now derivative wrt toroidal flux
          t_p=t_p*t_dpsi00/zdp0 ! For q input, t_p is not recomputed
          t_fpsrf=t_fpsrf*t_qsrf ! this is computed for local info
       END IF
       DO j=1,t_ntet
          t_aj(:,j)=anu
       END DO
       psend=-anu(t_npo)*TWOPI*t_ro

       zpsend=psend
       IF(t_ifluxcord==-1) zpsend=zpsend*t_qrk(t_npo)
       call polar1(kp,ip)
       t_raxis=um;t_zaxis=vm 
       IF(kp==1 .AND. ip>-1) THEN
          t_prsx=t_prsx*t_anun*psend/zpsend
       END IF
       ! end inverse solver

       ! set t_dpsi0 from psend
       IF(t_ifluxcord==-1) THEN
          t_dphi0=zdp0*psend/zpsend*t_qrk(t_npo)
          zdp0=t_dphi0
       ELSE
          t_dpsi0=zdp0*psend/zpsend
          zdp0=t_dpsi0
       END IF
       ! set geometry in eq variables

       t_rhosq(:,:,1)=(ur(:,:)-um)**2+((vz(:,:)-vm)/elong)**2 ! rho**2
       t_rlsd(:,:,1)=transpose(ur(:,:))
       t_zlsd(:,:,1)=transpose(vz(:,:))
       IF(.NOT.t_iter_bdry) THEN ! convert back to polar coordinates
          IF(SIZE(dq1)/=t_mls) THEN
             IF(ALLOCATED(dq1)) DEALLOCATE(dq1,dq2,cq1,cq2)
             ALLOCATE(dq1(t_mls),dq2(t_mls),cq1(t_mls),cq2(t_mls))
          END IF
!          call parsestr('"equal arc boundary";debugger')
          call get_rhosq
          IF(t_n6==6) THEN
             m3=3;m4=4;m5=5
          ELSEIF(t_n6==16) THEN
             m3=5;m4=6;m5=3
          END IF
          t_brwpts=(uk-t_raxis)/sqrt(t_rhosq(t_msrf,:,1))
          t_bzwpts=(vk-t_zaxis)/sqrt(t_rhosq(t_msrf,:,1))
          call spline_interp(t_tswpts,t_brwpts,y1,y1,cq1,cq2,dq2,c_q)
          call spline_interp(t_tswpts,t_bzwpts,y1,y1,dq1,cq2,dq2,c_q)
          DO l=1,t_msrf
             rho=sqrt(abs(t_rhosq(l,:,1)))+errt_rq
             t_rlsd(:,l,2)=0.5_rq*t_rhosq(l,:,m3)/rho*t_brwpts+rho*cq1
             t_zlsd(:,l,2)=0.5_rq*t_rhosq(l,:,m3)/rho*t_bzwpts+rho*dq1
             t_rlsd(:,l,3)=0.5_rq*t_rhosq(l,:,2)/rho*t_brwpts/t_dpsi0
             t_zlsd(:,l,3)=0.5_rq*t_rhosq(l,:,2)/rho*t_bzwpts/t_dpsi0
             ! Jacobian
             t_zlsd(:,l,4)=0.5_rq*elong*t_rhosq(l,:,2)*t_rlsd(:,l,1)/t_dpsi0
             ! Bpol
             t_rlsd(:,l,4)=sqrt(t_rlsd(:,l,2)**2+t_zlsd(:,l,2)**2)/&
                  abs(t_zlsd(:,l,4)) ! Bpol
          END DO
          t_rlsd(:,1,4)=errt_rq
          dq1=atan2((vk-vm)/t_wvert,uk-um)
          DO ls=2,t_mls-1
             IF(dq1(ls)<0) EXIT
          END DO
          DO lss=ls,t_mls
             dq1(lss)=dq1(lss)+TWOPI
          END DO
!          call parsestr('"back to equal angle";debugger')
          DO l=2,t_msrf
             pswpts=t_rhosq(l,:,1)
             call interp_interp(dq1,pswpts,y1,y1,t_tswpts,dq2,cq1)
             t_rhosq(l,:,1)=dq2
          END DO
       END IF
       ! get derivative of t_rhosq
       IF(ndbg2==0) THEN
          ! First force t_rhosq smoothly to zero at axis
          DO ls=1,t_mls
             c_0=t_rhosq(:,ls,1)
             t_rhosq(1,ls,1)=extrp(c_0,t_rhosrf,t_msrf,0,0)
             c_q(ls)=t_rhosq(1,ls,1)
             t_rlsd(ls,1,1)=t_raxis
             t_zlsd(ls,1,1)=t_zaxis
          END DO
          DO l=1,t_msrf
             IF(l==1) THEN
                t_rhosq(l,:,1)=errt_rq**2*t_raxis**2
             ELSE
                t_rhosq(l,:,1)=t_rhosq(l,:,1)-c_q
             END IF
             t_rlsd(:,l,1)=t_raxis+sqrt(abs(t_rhosq(l,:,1)))*cos(t_tswpts)
             t_zlsd(:,l,1)=t_zaxis+sqrt(abs(t_rhosq(l,:,1)))*sin(t_tswpts)*&
                  t_wvert
          END DO
       END IF
       !end smooth
    ELSE
       t_rls=uk;t_zls=vk
       call escinv
       t_rhosq(:,:,1)=transpose((t_rlsd(:,:,1)-t_raxis)**2+((t_zlsd(:,:,1)-&
            t_zaxis)/t_wvert)**2)
    END IF
    t_rls=t_rlsd(:,t_msrf,1)
    t_zls=t_zlsd(:,t_msrf,1)
    call get_rhosq

    IF(t_n6==6) THEN
       m3=3;m4=4;m5=5
    ELSEIF(t_n6==16) THEN
       m3=5;m4=6;m5=3
    END IF

    IF(t_ifluxcord==-1) THEN
       IF(kp==0) THEN
          t_qsrf=t_qsave
          c_0=1/t_qsrf
          call spline_interp(t_phibar,c_0,yb,yb,c_1,c_2,c_3,t_psibar)
          t_dpsi0=t_dphi0*t_psibar(t_msrf)
          t_psibar=t_psibar/t_psibar(t_msrf)
          t_qh=t_phibar*t_dphi0/t_dpsi0
       ELSE
          t_qrk(1)=extrp(t_qrk,t_psiinv,t_npo,0,0)
          call interp_interp(t_psiinv,t_qrk,yb,yb,t_rhosrf,t_qsrf,c_1)
          c_0=1/t_qsrf
          call spline_interp(t_phibar,c_0,yb,yb,c_1,c_2,c_3,t_psibar)
          t_dpsi0=t_dphi0*t_psibar(t_msrf)
          t_psibar=t_psibar/t_psibar(t_msrf)
          zdp0=t_dphi0
          t_qh=t_phibar*t_dphi0/t_dpsi0
       END IF
       call spline_interp(t_psibar,t_qsrf,yb,yb,c_1,c_2,c_3,noyint)
       DO l=1,t_msrf
          t_rhosq(l,:,2)= t_rhosq(l,:,2)*t_qsrf(l)*t_dpsi0/t_dphi0
          t_rhosq(l,:,m4)= t_rhosq(l,:,m4)*t_qsrf(l)*t_dpsi0/t_dphi0
          t_rhosq(l,:,m5)=(t_rhosq(l,:,m5)*t_qsrf(l)+t_rhosq(l,:,2)*c_1(l))*&
               t_qsrf(l)*(t_dpsi0/t_dphi0)**2
       END DO
    END IF
    !   get flux coordinates, Jacobian and Bpol

    t_brwpts=cos(t_tswpts)
    t_bzwpts=sin(t_tswpts)
    DO l=1,t_msrf
       rho=sqrt(abs(t_rhosq(l,:,1)))+errt_rq
       t_rlsd(:,l,1)=rho*t_brwpts+t_raxis
       t_zlsd(:,l,1)=rho*t_bzwpts*elong+t_zaxis
       t_rlsd(:,l,2)=(0.5_rq*t_rhosq(l,:,m3)/rho*t_brwpts-rho*t_bzwpts)
       t_zlsd(:,l,2)=(0.5_rq*t_rhosq(l,:,m3)/rho*t_bzwpts+rho*t_brwpts)*elong
       t_rlsd(:,l,3)=0.5_rq*t_rhosq(l,:,2)/rho*t_brwpts/t_dpsi0
       t_zlsd(:,l,3)=0.5_rq*t_rhosq(l,:,2)/rho*t_bzwpts*elong/t_dpsi0
       t_zlsd(:,l,4)=0.5_rq*elong*t_rhosq(l,:,2)*t_rlsd(:,l,1)/t_dpsi0
       ! Jacobian
       t_rlsd(:,l,4)=sqrt(t_rlsd(:,l,2)**2+t_zlsd(:,l,2)**2)/abs(t_zlsd(:,l,4))
       ! Bpol
    END DO
    t_zlsd(:,1,4)=0.5_rq*elong*t_rhosq(1,:,2)*t_raxis/t_dpsi0
    t_rlsd(:,1,4)=errt_rq
    !   end get Jacobian
    IF(t_inv_flag<=0) THEN
       ! Get T_P, T_P' and T_F, T_F'
       IF(t_entropy_flag>0) THEN
          t_p=t_p*1.e-3_rq*s_pin*t_dpsi0/t_ro
       END IF
       IF(t_use_halo) THEN
          c_0=t_rhosrf
          mmm=t_msrf
          IF(t_use_halo .AND. t_lhalo<t_msrf) THEN
             c_0=(t_psrf-t_psix)/t_dpsi0
             t_dpsi00=zdpsi00;t_dpsi0=zdpsi0
             mmm=t_lhalo-1
          END IF
          call interp_interp(t_psiinv,t_p,yb,yb,c_0,c_1,c_2)
          t_prsrf(:mmm)=c_1(:mmm)/(FOURPI*1.e-6_rq)
          t_pdsrf(:mmm)=c_2(:mmm)/(FOURPI*1.e-6_rq*zdp0)
          call interp_interp(t_psiinv,t_f,yb,yb,c_0,c_1,c_2)
          t_frsrf(:mmm)=c_1(:mmm)*t_ro*1e3
          t_fpsrf(:mmm)=c_2(:mmm)*t_ro*1e3/zdp0
          IF(t_lhalo<t_msrf-2) THEN 
             ! Now make fpsrf continuous across halo boundary
             aaa=1
             call interp_interp(t_psiinv,t_f,yb,yb,aaa,fff,ffp)
             fff(1)=fff(1)*t_ro*1e3
             ffp(1)=ffp(1)*t_ro*1e3/zdp0
             aa(1)=t_psih;aa(2:)=t_psrf(t_lhalo:t_lhalo+2)
             bb(2:)=t_fpsrf(t_lhalo:t_lhalo+2)
             bb(1)=extrp(bb,aa,4,0,0)
             t_fpsrf(t_lhalo:t_msrf)=t_fpsrf(t_lhalo:t_msrf)*ffp(1)/bb(1)
             fff(1)=t_frsrf(1)
             call spline_interp(t_psrf,t_fpsrf,yb,yb,c_1,c_2,c_3,t_frsrf)
             t_frsrf=t_frsrf+fff(1)
          END IF
       ELSE
          call interp_interp(t_psiinv,t_f,yb,yb,t_psibar,t_frsrf,t_fpsrf)
          t_frsrf=t_frsrf*t_ro*1e3
          t_fpsrf=t_fpsrf*t_ro*1e3/zdp0
          call interp_interp(t_psiinv,t_p,yb,yb,t_psibar,t_prsrf,t_pdsrf)
          t_prsrf=t_prsrf/(FOURPI*1.e-6_rq)
          t_pdsrf=t_pdsrf/(FOURPI*1.e-6_rq*zdp0)
       END IF
    END IF
    ! Note that what follows is broken IF t_ifluxcord < 0, this option of using    ! v and w to calculate the currents rather than a direct interpolation from
    ! the inverse solver will probably disappear. The only issue is current on
    ! the edge in free boundary mode and transport. And, the ohm's law will
    ! either drive the current to zero or there will be current on open field
    ! lines which will THEN be handled as done in SSPX and THEN no problem.

    t_w=(t_frsrf**2-t_frsrf(t_msrf)**2)/(t_dpsi0*8*PI*t_prsx)
    t_wp=t_fpsrf*t_frsrf/(t_dpsi0*FOURPI*t_prsx)
    IF(t_filter_wp==999) THEN
       wp0=0
       jj=.9_rq*t_msrf+t_filter_wp
       call splider_interp(t_rhosrf,t_wp,t_w,t_wpp,t_wppp,ndbg10,wp0,jj,ldbg8)
       wp0=0
    ELSEIF(t_filter_wp==-999) THEN
       wp0=t_wp(t_msrf)
       jj=0.9_rq*t_msrf
       call splider_interp(t_rhosrf,t_wp,t_w,t_wpp,t_wppp,ndbg10,wp0,jj,ldbg8)
    ELSE
       IF(t_filter_wp>2) THEN
          CALL fdInt(t_wp,t_psibar,t_msrf,t_w)
          t_w=zero_der_interp(t_psibar,t_w,t_filter_wp)
       ELSEIF(t_filter_wp>0) THEN
          CALL polyfit_interp(t_frsrf,t_fpsrf,t_psibar,t_dpoly,t_spoly,&
               t_mpoly,-2)
          t_fpsrf=t_fpsrf/t_dpsi0
          t_w=(t_frsrf**2-t_frsrf(t_msrf)**2)/(t_dpsi0*8*PI)/t_prsx
          yb=777
       ELSEIF(t_filter_wp<0) THEN
          CALL polyfit_interp(t_frsrf,t_fpsrf,t_psibar,t_dpoly,t_spoly,&
               t_mpoly,1)
          t_fpsrf=t_fpsrf/t_dpsi0
          t_w=(t_frsrf**2-t_frsrf(t_msrf)**2)/(t_dpsi0*8*PI)/t_prsx
          yb=777
       ELSE
          DO i=1,3
             bel(i,1)=1;bel(i,2)=t_psibar(i+2);bel(i,3)=t_psibar(i+2)*&
                  sqrt(t_psibar(i+2))
          END DO
          call rmInvert(bel,3,3)
          DO i=1,3
             rel(i)=0
             DO j=1,3
                rel(i)=rel(i)+bel(i,j)*t_w(j+2)
             END DO
          END DO
          t_w(1)=rel(1)
          t_w(2)=rel(1)+t_psibar(2)*(rel(2)+sqrt(t_psibar(2))*rel(3))
       END IF
       call spline_interp(t_psibar,t_w,yb,yb,t_wp,t_wpp,t_wppp,noyint)
    END IF

    ! Reset coordinate system and renormalize F and T. Note have to avoid
    ! cumulative errors from interpolation/extrapolation from inverse
    ! cordinates. We do this by forcing qsrf=qsave  by recalculating
    ! frsrf and calculating prsrf from psave. ssave later:LDP 17/01/03
    !
    IF(t_inv_flag<=0 .AND. (kp==1 .OR. kp==2 .AND. ip/=0)) THEN
       t_psave=t_anun*t_psave
       IF(kp==2) t_jtsave=t_anun*t_jtsave
       IF(kp==1) t_fsave=t_frsrf
    END IF
    IF(t_inv_flag==-1 .OR. t_inv_flag==2) THEN
       t_prsrf=t_psave
       t_psrf=t_psix+t_dpsi0*t_psibar
       call fdDeriv(t_prsrf,t_psrf,t_msrf,t_pdsrf)
       DO l=1,t_msrf
          c_3=s_pin*TWOPI/(t_mls-1)*t_zlsd(:,l,4)
          c_3(1)=0.5_rq*c_3(1);c_3(t_mls)=0.5_rq*c_3(t_mls)
          t_qsrf(l)=SUM(c_3/t_rlsd(:,l,1)**2)
          t_vpsrf(l)=SUM(c_3)
          IF(kp==3) THEN
             c_1(l)=SUM(c_3*t_rlsd(:,l,4)**2)/t_vpsrf(l)
             c_2(l)=t_qsrf(l)/t_vpsrf(l)
          ELSEIF(kp==2) THEN
             c_1(l)=FOURPI*t_pdsrf(l)*t_vpsrf(l)/t_qsrf(l)
             c_2(l)=SUM(c_3*t_rlsd(:,l,4)**2)
          END IF
       END DO
       IF(kp==0) THEN
          t_frsrf=TWOPI*t_qsave/t_qsrf
          call fdDeriv(t_frsrf,t_psrf,t_msrf,t_fpsrf)
       ELSE
          c_0=t_frsrf
          DO iter=1,nter_interp
             IF(kp==2) THEN
                c_3=(.4*PI*t_jtsave-c_1)*(c_2/t_qsrf/c_0**2+1)
                call fdInt(c_3,t_psrf,t_msrf,c_0)
                c_0=sqrt(2*(c_0-c_0(t_msrf))+t_fwall**2)
                t_fpsrf=c_3/c_0
             ELSEIF(kp==3) THEN
                t_fpsrf=.4*PI*t_jparsave-FOURPI*t_pdsrf*c_0/(c_1+c_0**2*c_2)
                call fdInt(t_fpsrf,t_psrf,t_msrf,c_0)
                c_0=c_0-c_0(t_msrf)+t_frsrf(t_msrf)
             END IF
             IF(SUM(abs(c_0/t_frsrf-1))<100*t_msrf*errt_rq) EXIT
             t_frsrf=c_0
          END DO
!          IF(iter>nter_interp) call parsestr('<<"new iter";debugger')
       END IF
    END IF

    !   Calculate surface integrals..
    call maps_inv(t_msrf) ! pdld
    call get_surfint

    IF(t_ifluxcord>=0) THEN 
!       CALL fdInt(t_qsrf,t_psibar,t_msrf,t_qh)
       call spline_interp(t_psibar,t_qsrf,yb,yb,c_1,c_2,c_3,t_qh)
       t_phibar=t_qh/t_qh(t_msrf)
       t_dphi0=t_dpsi0*t_qh(t_msrf)
       zdp0=t_dpsi0
    END IF
!    IF(t_inv_p==1) then
!       t_psil=t_psix+t_dpsi0
!    ELSE
!       t_psil=t_psix+t_dpsi0 ! Is OK, LDP 16/01/03: NO 16/04/03 WHY?
!    END IF
    t_psix=t_psil-t_dpsi0
    t_psrf=t_psix+t_psibar*t_dpsi0
    dpsrf(2:)=t_psrf(2:)-t_psrf(:t_msrf-1)

    IF(t_inv_flag<=0) THEN
       !   Reset dpsi00, dphi00
       IF(ip==0 .OR. ip==1 .OR. ip==2) THEN
          t_dpsi00=t_dpsi0
          t_dphi00=t_dphi0
       END IF
       IF(t_ifluxcord==-1) THEN
          t_pdsrf=t_pdsrf*t_qsrf
          t_fpsrf=t_fpsrf*t_qsrf
       END IF
    ELSE
       t_dpsi00=t_dpsi0
       t_dphi00=t_dphi0
    END IF

    c_0=-t_cusrf/(t_frsrf*FOURPI/10)
    t_srsrf  = t_prsrf*t_vptor**GAMMA
    IF(kp==0 .AND. t_ifluxcord/=2 .AND. t_inv_x==0) THEN
       call spline_interp(t_psrf,c_0,yb,yb,c_1,c_2,c_3,noyint)
       t_jtsrf  = t_frsrf**2*c_1/TWOPI/t_qsrf
    ELSE
       t_jtsrf=(t_fpsrf*t_bsqrf/t_frsrf+FOURPI*t_pdsrf)/t_rsqirf/.4/Pi
    END IF
    t_jparsrf= t_jtsrf*t_frsrf*t_rsqirf/t_bsqrf
    t_plc=-s_pin*t_cusrf(t_msrf)/FOURPI
    IF(t_ifluxcord<=0) THEN
       t_vptor=abs(t_vpsrf/t_qsrf)
    ELSE
       t_vptor=t_vpsrf
       IF(t_ifluxcord==2) t_jtsrf=t_qsrf*t_jtsrf ! LDP RFP
    END IF
    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))
    s_rcntr=t_rsrf(t_msrf)
    s_rbore=t_asrf(t_msrf)
    IF(t_itimestep_converged .AND. t_fix_bound) t_inv_eq=3
    IF(t_inv_eq==3) THEN
       call s_source_inv ! In case we want to get the external flux
    END IF
    call diaginv
    t_inv_eq=1
  END SUBROUTINE teq_inv

  SUBROUTINE get_rhosq
    REAL(RQ) :: c_3
    INTEGER l,ls,imth
    DATA imth /-10/ ! extrapolates 1st derivative, periodic
    CALL bispline_interp(t_psibar,t_tswpts,i_rhosq,imth,t_n6)
    IF(t_n6==7) THEN !  get 2nd derivs divide by 2 
       DO l=1,t_msrf
          DO ls=1,t_mls-1
             t_rhosq(l,ls,6)=(3*(t_rhosq(l,ls+1,1)-t_rhosq(l,ls,1))/&
                  t_tswpts(2)-(t_rhosq(l,ls+1,3)+2*t_rhosq(l,ls,3)))/&
                  t_tswpts(2)
          END DO
       END DO
       DO l=1,t_msrf
          t_rhosq(l,t_mls,6)=t_rhosq(l,1,6)
       END DO
       DO l=1,t_msrf-1
          c_3=t_psibar(l+1)-t_psibar(l)
          t_rhosq(l,:,5)=(3*(t_rhosq(l+1,:,1)-t_rhosq(l,:,1))/c_3-&
               (t_rhosq(l+1,:,2)+2*t_rhosq(l,:,2)))/c_3
       END DO
       t_rhosq(t_msrf,:,5)=(t_rhosq(t_msrf,:,2)-t_rhosq(t_msrf-1,:,2))/c_3-&
            t_rhosq(t_msrf-1,:,5)
    END IF
  END SUBROUTINE get_rhosq

  SUBROUTINE i_t(rhosq)
    USE sep_math
    USE teq_mod, only : t_msrf,t_mls,t_n6
    REAL(rq), TARGET, INTENT(INOUT) :: rhosq(t_msrf,t_mls,t_n6)
    t_rhosq=>rhosq
  END SUBROUTINE i_t

  SUBROUTINE maps_inv(l)
!-------------------------------------------------
!---- Gets pdls:psi,psir,psiz,psirr,psirz,psizz.  
!---- Use t_rhosq, the coordinate transformation.           
!-------------------------------------------------
    INTEGER :: l,ls,m3,m4,m5,m6,n1
    n1=0
    IF(ALLOCATED(dq1)) THEN
       n1=SIZE(dq1)
    END IF
    IF(n1/=t_mls) THEN
       IF(ALLOCATED(dq1)) DEALLOCATE(dq1,dq2,cq1,cq2)
       ALLOCATE(dq1(t_mls),dq2(t_mls),cq1(t_mls),cq2(t_mls))
    END IF
    IF(t_n6==6) THEN
       m3=3
       m4=4
       m5=5
       m6=6
    ELSEIF(t_n6==16) THEN
       m3=5
       m4=6
       m5=3
       m6=9
    END IF
    IF(l==t_msrf .OR. l==1) THEN
       t_brwpts=cos(t_tswpts)
       t_bzwpts=sin(t_tswpts)
       t_rlsd(:,1,1)=t_raxis
       t_zlsd(:,1,1)=t_zaxis
    END IF
    cq2=sqrt(t_rhosq(l,:,1))
    cq1=-t_bzwpts/cq2 ! thR!
    dq1=t_brwpts/cq2/t_wvert ! thZ
    dq2=(t_brwpts**2-t_bzwpts**2)/t_rhosq(l,:,1)/t_wvert !-thRZ
    ls=t_lmax
    t_pdls(:ls,2)=(2*cq2(:ls)*t_brwpts(:ls)-t_rhosq(l,:ls,m3)*cq1(:ls))/&
         t_rhosq(l,:ls,2) ! psiR
    t_pdls(:ls,3)=(2*cq2(:ls)*t_bzwpts(:ls)/t_wvert-t_rhosq(l,:ls,m3)*&
         dq1(:ls))/&
         t_rhosq(l,:ls,2) ! psiZ
    t_pdls(:ls,4)=(2-2*t_rhosq(l,:ls,m5)*t_pdls(:ls,2)**2-2*&
         t_rhosq(l,:ls,m4)*t_pdls(:ls,2)*cq1(:ls)-2*t_rhosq(l,:ls,m6)*&
         cq1(:ls)**2+2*t_wvert*t_rhosq(l,:ls,m3)*cq1(:ls)*dq1(:ls))/&
         t_rhosq(l,:ls,2)
    t_pdls(:ls,5)=-(2*t_rhosq(l,:ls,m5)*t_pdls(:ls,2)*t_pdls(:ls,3)+&
         t_rhosq(l,:ls,m4)*(t_pdls(:ls,2)*dq1(:ls)+t_pdls(:ls,3)*cq1(:ls))+&
         2*t_rhosq(l,:ls,m6)*cq1(:ls)*dq1(:ls)-t_rhosq(l,:ls,m3)*dq2(:ls))/&
         t_rhosq(l,:ls,2)
    t_pdls(:ls,6)=(2/t_wvert**2-2*t_rhosq(l,:ls,m5)*t_pdls(:ls,3)**2-2*&
         t_rhosq(l,:ls,m4)*t_pdls(:ls,3)*dq1(:ls)-2*t_rhosq(l,:ls,m6)*&
         dq1(:ls)**2-2/t_wvert*t_rhosq(l,:ls,m3)*cq1(:ls)*dq1(:ls))/&
         t_rhosq(l,:ls,2)
    t_pdls(:,2:6)=t_pdls(:,2:6)*t_dpsi0
    t_pdls(:,1) =t_psix+t_psibar(l)*t_dpsi0
  END SUBROUTINE maps_inv

END MODULE inv_mod
