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

MODULE diag_mod

  USE greens_mod
  USE teqSurf_mod

  IMPLICIT NONE

  REAL(rq), DIMENSION(:), ALLOCATABLE, TARGET, PRIVATE :: cq0,cq1,cq2,cq3,cq4,&
       cq5,cq6,dq0,dq1,dq2,dq3,dq4,dq5,dq6,cq7,cq8,cq9,cq10,dq7,dq8,dq9,&
       dq10,c0,c1,c2,c3,pswpts,brs,bzs,bps,bms,bts
  REAL(rq), DIMENSION(:,:), ALLOCATABLE, PRIVATE :: pdloop
  REAL(rq), PARAMETER, PRIVATE :: GAMMA=5._rq/3._rq
  INTEGER, PRIVATE :: mlm

CONTAINS

  SUBROUTINE d_bline(dd,lxx,lss)
    INTEGER, INTENT(IN) :: lxx,lss
    REAL(rq), INTENT(IN) ::  dd
    INTEGER :: jmx,lbdry,lvv

    IF(dd>=0) THEN
       lbdry=2
       lvv=0
       CALL psisrf_separatrix(t_pxpt,lbdry,t_r,t_z,t_psi)
       CALL maps_separatrix(t_pxpt,lvv)
    END IF
    pswpts=SQRT((t_rlsd(:,t_msrf,1)-t_raxis)**2+((t_zlsd(:,t_msrf,1)-&
         t_zaxis)/t_wvert)**2)
    IF(lss/=0) THEN
       CALL blined(dd,lxx,lss)
    ELSE
       cq3=t_rlsd(:,t_msrf,1)
       dq3=t_zlsd(:,t_msrf,1)
       CALL d_strkpl(t_pxpt)            !   reset strike points
    END IF
  END SUBROUTINE d_bline

  SUBROUTINE blined(ddd,lxx,ls)
    !.........................................................................
    !.. This function evaluates the distance along the field line from the
    !.. mid-plane to the divertor plate.
    !.. ls abs=1 inside; abs=2 outside. ls>0 to strike point ls<0 to boundary
    !.. dd-s the distance off the separatrix
    !.. distances are stored in pds: pds(1:2)   direct (total:poloidal)
    !..                              pds(3:4) indirect (total:poloidal)
    !.. indirect only occurs for a single null
    !.. rpts,zpts,cq5,cq7,cq6: coordinates,bpol,tot dist, pol dist; direct
    !.. dq6,dq7,dq5,cq4,dq4: coordinates,bpol,tot dist, pol dist; indirect
    !.. cq8,dq8: cq4,dq4; direct
    !.. cq9,dq9: cq4,dq4; inirect
    !.. dq10  k-perp squared for direct; cq10 for indirect
    !.. lxx=number of points for direct; mls=number of points indirect
    !.........................................................................
    INTEGER,  INTENT(IN) :: lxx,ls
    REAL(rq), INTENT(IN) ::  ddd
    INTEGER,  SAVE :: ii,iii,mlx,ml1
    REAL(rq), SAVE :: dd,rrig(2),zrig(2),zrst(2),zzst(2),zrml(2)
    REAL(rq) :: pds(8),xang,rstart,zstart,psill,batan,dbxpt,drxpt,pan,f,fx,&
         fxx,fxxx,psiv(t_jm,t_km),rit,rat,zra,zza,avert,rmlm,rut,zbps,zbrs,&
         zbzs,test,denom,a1
    INTEGER :: kl,lv,ll,ier,ibxpt,n,jss,j,k,l1,l,i,jer,iter,isw,nn
    include "debug.i"

    !.... Must find strike points on lower divertor plates
    !.... These are the inner and outer radius of crossings on the separatrix

    dd=ABS(ddd)
    ll=ls
    kl=t_km/2+1
    lv=1
    mlm=t_mls/2+1
    IF(ls<0) THEN
       lv=0
       ll=-ls
    END IF
    !...  Now find strike points
    IF(ll==1) THEN
       rstart=s_rcntr-s_rbore-dd
       zstart=t_zaxis
       rat=rstart-(s_rcntr-s_rbore)
       ier=6
       CALL boxd_interp (rstart,zstart,pds,ier,t_n4)
       psill=pds(1)
       IF(ier/=0) call errdetec("boxd_interp error in bline",1)
       IF(lv/=0) THEN   !   inside
          CALL d_strkpl(psill)
          IF(t_nsym<=1) THEN
             t_nstkpts=t_nstkpts/2
             DO iii=1,t_nstkpts
                t_zstkpt(iii)=-t_zstkpt(iii)
             END DO
          END IF
          IF(t_nstkpts/=2) lv=0  !  ignore strike points go to wall
       END IF
    ELSEIF(ll==2) THEN      !   outside
       rstart=s_rcntr+s_rbore+dd
       zstart=t_zaxis
       rat=rstart-(s_rcntr+s_rbore)
       ier=3
       call boxd_interp (rstart,zstart,pds,ier,t_n4)
       psill=pds(1)
       IF(ier/=0) call errdetec("boxd_interp error in bline",1)
       IF(lv/=0) THEN
          call d_strkpl(psill)
          IF(t_nsym<=1) THEN
             t_nstkpts=t_nstkpts/2
             DO iii=1,t_nstkpts
                t_zstkpt(iii)=-t_zstkpt(iii)
             END DO
          END IF
          IF(t_nstkpts/=2) lv=0  !  ignore strike points go to wall
       END IF
    END IF
    batan=atan2((s_zxpl-t_zaxis)/t_wvert,s_rxpl-t_raxis)+TWOPI
    dbxpt=TWOPI/(t_mls-1)
    ibxpt=batan/dbxpt+1
    ier=6
    call boxd_interp(s_rxpl,s_zxpl,pds,ier,t_n4)
    drxpt=sqrt(abs((psill-pds(1))*2/pds(4)))
    IF(lv==0) THEN
       psiv=RESHAPE(t_psi,(/t_jm,t_km/))
       j=t_jm
       k=kl
       pan=psiv(t_jm,kl)-psill
       pan=SIGN(1.0_rq,pan)
       DO k=kl,1,-1      !    look on outside boundary for 2nd crossing
          IF((psiv(j,k)-psill)*pan<0) EXIT
       END DO
       jss=t_jm
       IF(k==0) THEN   !   no crossing yet
          k=1
          DO j=t_jm,1,-1   !   look on bottom  boundary for 2nd crossing
             IF((psiv(j,k)-psill)*pan<0) EXIT
          END DO
          jss=1
       END IF
       n=j+t_jm*(k-1)
       CALL Siden(n,jss,f,fx,fxx,fxxx)
       dd=(psill-t_psi(n))/(t_psi(n+jss)-t_psi(n))
       IF(jss==1) THEN
          dd=dd*t_dr
       ELSEIF(jss==t_jm) THEN
          dd=dd*t_dz
       END IF
       CALL Newton(psill,dd,f,fx,fxx,fxxx)   !   found crossing
       IF(jss==1) THEN
          t_rstkpt(2)=t_r(j)+(dd+0.5*t_dr)
          t_zstkpt(2)=t_z(k)
       ELSEIF(jss==t_jm) THEN
          t_rstkpt(2)=t_r(j)
          t_zstkpt(2)=t_z(k)+(dd+0.5*t_dz)
       END IF
       j=1
       k=kl
       pan=psiv(j,k)-psill
       pan=sign(1.0_rq,pan)
       j=1
       DO k=kl,1,-1    !   look on inside  boundary for 1st crossing
          IF((psiv(j,k)-psill)*pan<0) EXIT
       END DO
       jss=t_jm
       IF(k==0) THEN   !   no crossing yet
          DO j=1,t_jm           !   look on bottom  boundary for 1st crossing
             IF((psiv(j,k)-psill)*pan<0) EXIT
          END DO
          j=j-1
          jss=1
       END IF
       n=j+t_jm*(k-1)
       CALL Siden(n,jss,f,fx,fxx,fxxx)
       dd=(psill-t_psi(n))/(t_psi(n+jss)-t_psi(n))-0.5_rq
       IF(jss==1) THEN
          dd=dd*t_dr
       ELSEIF(jss==t_jm) THEN
          dd=dd*t_dz
       END IF
       CALL Newton(psill,dd,f,fx,fxx,fxxx)   !   found crossing
       IF(jss==1) THEN
          t_rstkpt(1)=t_r(j)+(dd+0.5_rq*t_dr)
          t_zstkpt(1)=t_z(k)
       ELSEIF(jss==t_jm) THEN
          t_rstkpt(1)=t_r(j)
          t_zstkpt(1)=t_z(k)+(dd+0.5_rq*t_dz)
       END IF
    END IF
    l1=1
    IF(t_nsym==2) THEN
       l1=2
    END IF
100 continue
    IF(l1==1) THEN   !   direct
       t_rpts(1)=rstart
       t_zpts(1)=zstart
       IF(ll==2 .AND. ddd>0) THEN  !   outside
          ii=1
          DO l=t_mls-1,ibxpt+1,-1
             rit=rat+(drxpt-rat)*(t_mls-l)/(t_mls-ibxpt)
             ii=ii+1
             t_rpts(ii)=cq3(l)+rit
             t_zpts(ii)=dq3(l)
          END DO
          ii=ii+1
          t_zpts(ii)=s_zxpl
          t_rpts(ii)=s_rxpl+drxpt
          rrig(ll)=t_r(t_jm)+s_rbore
          xang=atan2(s_zlse(s_mlxe+1)-s_zxpl,s_rlse(s_mlxe+1)-s_rxpl)-Pi/4
          zrig(ll)=s_zxpl+tan(xang)*(rrig(ll)-s_rxpl)
       ELSEIF(ll==1 .AND. ddd>0) THEN   !   inside
          ii=1
          DO l=mlm+1,ibxpt
             rit=rat-(l-mlm)*(drxpt+rat)/(ibxpt-mlm+1)
             ii=ii+1
             t_rpts(ii)=cq3(l)+rit
             t_zpts(ii)=dq3(l)
          END DO
          ii=ii+1
          t_zpts(ii)=s_zxpl
          t_rpts(ii)=s_rxpl-drxpt
          rrig(ll)=t_r(1)-s_rbore
          xang=atan2(s_zlse(s_mlxe-1)-s_zxpl,s_rlse(s_mlxe-1)-s_rxpl)+Pi/4
          zrig(ll)=s_zxpl+tan(xang)*(rrig(ll)-s_rxpl)
       END IF
       iii=ll
       ml1=1 
       mlx=lxx
       zra=rrig(iii)
       zza=zrig(iii)
    ELSEIF(l1==2) THEN      !   indirect strike trajectories
       IF(ll==2 .AND. ddd>0) THEN       !   starts outside to inside
          DO l=1,mlm
             t_rpts(l)=cq3(l)
             t_zpts(l)=dq3(l)
             cq5(l)=pswpts(l)
             dq0(l)=t_brwpts(l)
             dq1(l)=t_bzwpts(l)
          END DO
          ii=ibxpt+1
          t_zpts(ii)=s_zxpl
          t_rpts(ii)=s_rxpl-drxpt
          rut=cq3(mlm)-(s_rcntr-s_rbore)
          DO l=mlm+1,ibxpt
             rit=rut-(l-mlm)*(drxpt+rut)/(ibxpt-mlm+1)
             t_rpts(l)=cq3(l)+rit
             t_zpts(l)=dq3(l)
          END DO
          rrig(3-ll)=t_r(1)-s_rbore
          xang=atan2(s_zlse(s_mlxe-1)-s_zxpl,s_rlse(s_mlxe-1)-s_rxpl)+Pi/4
          zrig(ll)=s_zxpl+tan(xang)*(rrig(ll)-s_rxpl)
       ELSEIF(ll==1 .AND. ddd>0) THEN !   starts inside to outside
          DO l=1,mlm
             t_rpts(l)=cq3(mlm+1-l)
             t_zpts(l)=dq3(mlm+1-l)
             cq5(l)=pswpts(mlm+1-l)
             dq0(l)=t_brwpts(mlm+1-l)
             dq1(l)=t_bzwpts(mlm+1-l)
          END DO
          rut=cq3(1)-(s_rcntr+s_rbore)
          ii=mlm
          DO l=t_mls-1,ibxpt+1,-1
             ii=ii+1
             rit=rut+(drxpt-rut)*(t_mls-l)/(t_mls-ibxpt)
             t_rpts(ii)=cq3(l)+rit
             t_zpts(ii)=dq3(l)
          END DO
          ii=ii+1
          t_zpts(ii)=s_zxpl
          t_rpts(ii)=s_rxpl+drxpt
          rrig(3-ll)=t_r(t_jm)+s_rbore
          xang=atan2(s_zlse(s_mlxe+1)-s_zxpl,s_rlse(s_mlxe+1)-s_rxpl)-Pi/4
          zrig(ll)=s_zxpl+tan(xang)*(rrig(ll)-s_rxpl)
       END IF
       ml1=mlm
       mlx=t_lmax
       iii=3-ll
       zra=rrig(iii)
       zza=zrig(iii)
    END IF
    IF(ddd>=0) THEN
       DO i=ml1,ii
          cq5(i)=sqrt((t_rpts(i)-zra)**2+(t_zpts(i)-zza)**2)
          dq0(i)=(t_rpts(i)-zra)/cq5(i)
          dq1(i)=(t_zpts(i)-zza)/cq5(i)
       END DO
       cq5(mlx)=sqrt((t_rstkpt(iii)-zra)**2+(t_zstkpt(iii)-zza)**2)
       dq0(mlx)=(t_rstkpt(iii)-zra)/cq5(mlx)
       dq1(mlx)=(t_zstkpt(iii)-zza)/cq5(mlx)
       zbps=(cq5(ii)-cq5(mlx))/(mlx-ii)
       zbrs=(dq0(ii)-dq0(mlx))/(mlx-ii)
       zbzs=(dq1(ii)-dq1(mlx))/(mlx-ii)
       DO i=ii+1,mlx
          cq5(i)=cq5(ii)-zbps*(i-ii)
          dq0(i)=dq0(ii)-zbrs*(i-ii)
          dq1(i)=dq1(ii)-zbzs*(i-ii)
          t_rpts(i)=zra+cq5(i)*dq0(i)
          t_zpts(i)=zza+cq5(i)*dq1(i)
       END DO
    ELSE
       IF(l1==1) THEN
          DO i=ml1,mlx
             t_rpts(i)=dq2(i)
             t_zpts(i)=cq2(i)
             cq5(i)=sqrt((t_rpts(i)-zra)**2+(t_zpts(i)-zza)**2)
             dq0(i)=(t_rpts(i)-zra)/cq5(i)
             dq1(i)=(t_zpts(i)-zza)/cq5(i)
          END DO
          rmlm=rstart
       ELSEIF(l1==2) THEN
          DO i=1,mlx
             t_rpts(i)=dq6(i)
             t_zpts(i)=dq7(i)
          END DO
          DO i=1,mlm
             cq5(i)=sqrt((t_rpts(i)-t_raxis)**2+(t_zpts(i)-t_zaxis)**2)
             dq0(i)=(t_rpts(i)-t_raxis)/cq5(i)
             dq1(i)=(t_zpts(i)-t_zaxis)/cq5(i)
          END DO
          DO i=ml1,mlx
             cq5(i)=sqrt((t_rpts(i)-zra)**2+(t_zpts(i)-zza)**2)
             dq0(i)=(t_rpts(i)-zra)/cq5(i)
             dq1(i)=(t_zpts(i)-zza)/cq5(i)
          END DO
          rmlm=t_rpts(ml1)
          jer=3
          DO iter=1,nter_interp
             ier=jer
             call boxd_interp(rmlm,t_zaxis,pds,ier,t_n4)
             test=abs(pds(1)/psill-1)
             IF(test<errt_rq) EXIT
             rmlm=rmlm+(psill-pds(1))/pds(2)
          END DO
       END IF
       !---- shift origin so as to preserve initial and final angle
       denom=dq1(mlx)*dq0(ml1)-dq0(mlx)*dq1(ml1)
       rrig(iii)=rrig(iii)+(dq1(mlx)*dq0(ml1)*(t_rstkpt(iii)-zrst(iii))-&
            dq0(mlx)*dq1(ml1)*(rmlm-zrml(iii))-dq0(mlx)*dq0(ml1)*&
            (t_zstkpt(iii)-zzst(iii)))/denom
       zrig(iii)=zrig(iii)+(dq1(mlx)*dq1(ml1)*(t_rstkpt(iii)-zrst(iii)-&
            rmlm+zrml(iii))-dq0(mlx)*dq1(ml1)*(t_zstkpt(iii)-zzst(iii)))/denom
       zra=rrig(iii)
       zza=zrig(iii)
       t_rpts(mlx)=t_rstkpt(iii)
       t_zpts(mlx)=t_zstkpt(iii)
       !DC      zpss=sqrt((rstkpt(iii)-zra)**2+(zstkpt(iii)-zza)**2)
       !DC      zq0s=(rstkpt(iii)-zra)/zpss
       !DC      zq1s=(zstkpt(iii)-zza)/zpss
       !DC      zps1=sqrt((rmlm-zra)**2+(t_zaxis-zza)**2)
       !DC      zq01=(rmlm-zra)/zps1
       !DC      zq11=(t_zaxis-zza)/zps1
       !---- end of origin shift
    END IF
    isw=0
    DO iter=1,nter_interp
       ier=6
       call boxm_interp(t_rpts,t_zpts,t_pdls,t_r,t_z,i_cps,isw,ier,t_n4)
       test=0
       DO i=1,mlx-1
          cq0(i)=psill-t_pdls(i,1)
          test=test+abs(cq0(i))
       END DO
       test=test/abs(psill*mlx)
       IF(test<errt_rq) EXIT
       DO i=1,mlx-1
          cq1(i)=t_pdls(i,2)*dq0(i)+t_pdls(i,3)*dq1(i)
          cq2(i)=t_pdls(i,4)*dq0(i)**2+2*t_pdls(i,5)*dq0(i)*dq1(i)+&
               t_pdls(i,6)*dq1(i)**2
          a1=2*cq0(i)*cq2(i)/cq1(i)**2+1
          cq5(i)=cq5(i)+2*cq0(i)/cq1(i)/(1+sqrt(abs(a1)))
       END DO
       DO i=1,ml1-1
          t_rpts(i)=t_raxis+cq5(i)*dq0(i)
          t_zpts(i)=t_zaxis+cq5(i)*dq1(i)
       END DO
       DO i=ml1,mlx-1
          t_rpts(i)=zra+cq5(i)*dq0(i)
          t_zpts(i)=zza+cq5(i)*dq1(i)
       END DO
    END DO
    zrst(iii)=t_rstkpt(iii)
    zzst(iii)=t_zstkpt(iii)
    zrml(iii)=t_rpts(ml1)
    DO i=1,mlx
       dq0(i)=(t_pdls(i,2)**2+t_pdls(i,3)**2)
       cq0(i)=((t_pdls(i,4)-t_pdls(i,6))*(t_pdls(i,2)**2-t_pdls(i,3)**2)+4*&
            t_pdls(i,2)*t_pdls(i,3)*t_pdls(i,5))/dq0(i)
       cq8(i)=-t_pdls(i,3)/t_rpts(i)
       dq8(i)=t_pdls(i,2)/t_rpts(i)
       cq5(i)=sqrt(dq0(i))/t_rpts(i) ! Bpol
       cq1(i)=-t_fwall*(t_pdls(i,2)/t_rpts(i)+cq0(i))/t_rpts(i)**2/dq0(i)/cq5(i)
       cq6(i+1)=sqrt((t_rpts(i+1)-t_rpts(i))**2+(t_zpts(i+1)-t_zpts(i))**2)
    END DO
    cq6(1)=0
    cq7(1)=0
    dq10(1)=0
    DO l=2,mlx
       dq10(l)=0.5_rq*cq6(l)*(cq1(l)+cq1(l-1))
       cq7(l)=cq6(l)*0.5_rq*(sqrt(1+(t_frsrf(t_msrf)/t_rpts(l)/cq5(l))**2)+&
            SQRT(1+(t_frsrf(t_msrf)/t_rpts(l-1)/cq5(l-1))**2))
    END DO
    DO l=2,mlx
       dq10(l)=dq10(l)+dq10(l-1)! local dq9
       cq7(l)=cq7(l)+cq7(l-1)   !   el
       cq6(l)=cq6(l)+cq6(l-1)   !   el pol
    END DO
    IF(l1==2) THEN
       dq6(t_lmax)=t_rpts(t_lmax)   !   r for indirect strike
       dq7(t_lmax)=t_zpts(t_lmax)   !   z for indirect strike
       dq5(t_lmax)=cq5(t_lmax)      !   bpoloidal for indirect strike
       cq4(t_lmax)=cq7(t_lmax)      !   toroidal distance for indirect strike
       dq4(t_lmax)=cq6(t_lmax)      !   poloidal distance for indirect strike 
       cq9(t_lmax)=cq8(t_lmax)      !   Br for indirect strike point
       dq9(t_lmax)=dq8(t_lmax)      !   Bz for indirect strike point
       cq10(t_lmax)=dq10(t_lmax)    !   local dq9
       pds(3)=cq7(t_lmax)
       pds(4)=cq6(t_lmax)
       l1=1
       go to 100
    ELSEIF(l1==1) THEN
       dq2(mlx)=t_rpts(mlx)
       cq2(mlx)=t_zpts(mlx)
    END IF
    pds(1)=cq7(lxx)
    pds(2)=cq6(lxx)
    nn=0
    IF(ll==1 .AND. nn/=0) THEN
       t_tlsoli(1,nn)=pds(1)
       t_plsoli(1,nn)=pds(2)
       IF(t_nsym==2) THEN
          t_tlsoli(2,nn)=pds(3)
          t_plsoli(2,nn)=pds(4)
       END IF
    END IF
    IF(ll==2 .AND. nn/=0) THEN
       t_tlsolo(1,nn)=pds(1)
       t_plsolo(1,nn)=pds(2)
       IF(t_nsym==2) THEN
          t_tlsolo(2,nn)=pds(3)
          t_plsolo(2,nn)=pds(4)
       END IF
    END IF
  END SUBROUTINE blined!

  SUBROUTINE diag
    include "debug.i"
    REAL(rq) ::  pds(8),bmdf(t_jm),bzft(t_jm),sump,tanskew,fcr,skew,avert,qq,&
         flxx,dd
    INTEGER :: ier,l,j,k,mq,msr,n1
    n1=0
    IF(ALLOCATED(cq0)) THEN
       n1=SIZE(cq0)
    END IF
    IF(n1/=t_mls) THEN
       IF(ALLOCATED(cq0)) DEALLOCATE(cq0,cq1,cq2,cq3,cq4,cq5,cq6,cq7,cq8,cq9,&
            cq10,dq0,dq3,dq4,dq5,dq6,dq7,dq8,dq9,dq10,pswpts)
       ALLOCATE(cq0(t_mls),cq1(t_mls),cq2(t_mls),cq3(t_mls),cq4(t_mls),&
            cq5(t_mls),cq6(t_mls),cq7(t_mls),cq8(t_mls),cq9(t_mls),&
            cq10(t_mls),dq0(t_mls),dq3(t_mls),&
            dq4(t_mls),dq5(t_mls),dq6(t_mls),dq7(t_mls),dq8(t_mls),dq9(t_mls),&
            dq10(t_mls),pswpts(t_mls))
    END IF
    n1=0
    IF(ALLOCATED(dq1))THEN
       n1=SIZE(dq1)
    END IF
    IF(n1/=t_mls) THEN
       IF(ALLOCATED(dq1))DEALLOCATE(dq1,dq2)
       ALLOCATE(dq1(t_mls),dq2(t_mls))
    END IF

    
    sump=TWOPI/(t_lmax-1)
    IF(t_m95==0) t_m95=.95_rq
    !     for parallel current diagnostics
    !
    !     compute flux surface quantities
    !

    ier=0
    CALL boxd_interp (t_raxis,t_zaxis,pds,ier,t_n4)
    IF(t_nsym==1) THEN
       t_esrf(1)=sqrt(pds(4)/pds(6))
       t_rsqbp(1)=TWOPI/(t_raxis*sqrt(pds(4)*pds(6)))
    ELSE
       skew=0.5_rq*atan(2*pds(5)/(pds(4)-pds(6)))
       fcr=pds(4)/pds(6)
       avert=sqrt(1+4*pds(5)**2/(pds(4)-pds(6))**2)
       t_esrf(1)=sqrt((fcr+1+(fcr-1)*avert)/(fcr+1-(fcr-1)*avert))
       t_rsqbp(1)=TWOPI/(t_raxis*sqrt(pds(4)*pds(6)-pds(5)**2))
       tanskew=tan(skew)**2
       t_rsqbp(1)=TWOPI*(1-tanskew)/t_raxis/sqrt((pds(4)-pds(6)*tanskew)*&
            (pds(6)-pds(4)*tanskew))
       t_esrf(1)=sqrt((fcr-tanskew)/(1-fcr*tanskew))
    END IF
    IF(t_ipj==0) CALL surfaces_separatrix(t_psibar,t_rlsd,t_zlsd)
    CALL get_surfint
    !... reset t_mls arrays to plasma surface
    l=t_msrf
    cq3=t_rlsd(:,l,1)
    dq3=t_zlsd(:,l,1)
    dq0=s_pin*t_zlsd(:,l,4)
    cq4=t_rlsd(:,l,2)/dq0
    dq4=t_zlsd(:,l,2)/dq0
    cq5=sqrt(cq4**2+dq4**2)
    dq5=t_frsrf(l)/cq3
    dq6=sqrt(cq5**2+dq5**2)
    !...  done
    CALL diaginv

    t_jparsrf=10.*(t_frsrf*t_pdsrf/t_bsqrf+t_fpsrf/FOURPI)
    t_jtsrf = 10.*(t_pdsrf+t_bsqrf*t_fpsrf/t_frsrf/FOURPI)/t_rsqirf
    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
    t_srsrf=t_prsrf*t_vptor**GAMMA

    t_ssave=t_srsrf+errt_rq*t_srsrf
    t_fsave=t_frsrf
    IF(t_ipj==0) THEN
       t_qsave   =t_qsrf
       t_jparsave=t_jparsrf
       t_jtsave  =t_jtsrf
       t_psave   =t_prsrf
       t_dpsi00=t_dpsi0
    ELSEIF(t_ipj==1) THEN
       t_qsave   =t_qsrf
       t_jparsave=t_jparsrf
    ELSEIF(t_ipj==2) THEN
       t_qsave   =t_qsrf
       t_jparsave=t_jparsrf
       t_psave   =t_prsrf
       t_dpsi00=t_dpsi0
    ELSEIF(t_ipj==3) THEN
       t_qsave   =t_qsrf
       t_jtsave  =t_jtsrf
    ELSEIF(t_ipj>3) THEN
       t_jparsave=t_jparsrf
       t_jtsave  =t_jtsrf
    END IF

    DO j=1,t_jm
       CALL g_flxfld(t_r(j),t_zaxis,bmdf(j),bzft(j),flxx)
    END DO
    t_fldind(1)=0
    DO j=2,t_jm-1
       t_fldind(j)=-0.5_rq*t_r(j)*(bzft(j+1)-bzft(j-1))/bzft(j)/t_dr
    END DO
    msr=t_msrf
    IF(t_pxpt==t_psil)msr=t_msrf-1
    mq=1
    t_qmin=xminaf(t_qsrf,1,msr,1,mq)
    t_rhomin=0
    IF(mq==1) THEN
       t_qmin=xmaxaf(t_qsrf,1,msr,1,mq)
       DO l=mq-1,1,-1
          IF(t_qsrf(l)<t_qmin) THEN
             t_qmin=t_qsrf(l)
          ELSE
             EXIT
          END IF
       END DO
       mq=l+1
    END IF
    IF(mq>1 .AND. mq<t_msrf) THEN
       dd=-0.5_rq*(t_qsrf(mq+1)-t_qsrf(mq-1))/(t_qsrf(mq+1)+t_qsrf(mq-1)-2*&
            t_qsrf(mq))
       t_qmin=t_qmin+0.5_rq*(t_qsrf(mq+1)-t_qsrf(mq-1))*dd
       t_rhomin=t_phibar(mq)+0.5*dd*(t_phibar(mq+1)-t_phibar(mq-1))+0.5_rq*&
            dd**2*(t_phibar(mq+1)+t_phibar(mq-1)-2*t_phibar(mq))
       t_rhomin=SQRT(ABS(t_rhomin))
    END IF
    t_aac=SQRT(ABS(t_ccf/t_crdn)/PI)
    WHERE(t_aac<t_acmin) t_aac=t_acmin
    !
    !     compute inductances , energy in mks units
    !
    IF(t_fix_bound) THEN
       k=0
       CALL vltsec(t_slfnd,k)
       t_vltsnd(1)=t_slfnd
       t_vltsnd(2)=g_flxc(t_raxis,t_zaxis)*MU0/20
       t_vltsnd(3)=g_flxc(s_rcntr,t_zaxis)*MU0/20
       t_slfnd=1.e6*abs(t_psires-t_vltsnd(1))/abs(t_placur)
       ! Get candidate strike-points (get rstkpt(1:nstkpts), etc.)
       CALL d_strkpl(t_pxpt)
       ! Distill strike-points (get rspt(1:nspt), etc.)
       CALL dstrkpl
    END IF
    ! STORED ENERGY [MJ] IN PF COIL SYSTEM...
    t_pfe0=0
    DO k=1,t_nc
       t_pfse(k)=0.5_rq*t_cc(k)*SUM(t_pfim(k,:)*t_cc)
       t_pfe0(k)=t_pfe0(k)+0.5_rq*t_pfim(k,k)*t_cc(k)**2
    ENDDO
    t_pfcse=SUM(t_pfse)
    t_wpf = t_pfcse*1.0e-03_rq
    t_wpt=t_plcm*t_psires+SUM(t_pfpsi*t_cc)
    t_wpt=5.0e-4_rq*t_wpt
    t_pftse=t_wpt*1.e+3_rq
    t_ccdir=0
    DO k=1,t_ngroup
       j=k+1
       if(k==t_ngroup) j=1
       t_ccdir=t_ccdir+(t_ccls(j)-t_ccls(k))**2/((t_rcg(j)-t_rcg(k))**2+&
            (t_zcg(j)-t_zcg(k))**2)
    END DO
    t_ccdir=SQRT(t_ccdir)
    IF( t_lasteq==1 .AND. t_lop0==1 ) THEN
       CALL pfcfld
    ELSEIF(t_kbfc==1) THEN
       CALL pfcfld
    END IF
  END SUBROUTINE diag

  SUBROUTINE newflux(lpest)
    ! Calculates other flux coordinates
    ! lpest: 0=equal arcs, 1=Hamada, 2=Pest coordinates
    INTEGER, INTENT(IN) :: lpest
    REAL(rq), PARAMETER :: y1=-666
    INTEGER :: l,ls
    CALL parsestr('svtitlet="Myflux"')
    DO l=2,t_msrf
       IF(lpest==0) THEN
          CALL parsestr('svtitlet="Equal arcs"')
          dq0=t_rlsd(:,l,4)*t_zlsd(:,l,4) ! = dl/d theta
       ELSEIF(lpest==1) THEN
          CALL parsestr('svtitlet="Hamada"')
          dq0=t_zlsd(:,l,4)
       ELSEIF(lpest==2) THEN	
          CALL parsestr('svtitlet="Pest"')
          dq0=t_zlsd(:,l,4)*t_frsrf(l)/t_qsrf(l)/t_rlsd(:,l,1)**2
       ELSEIF(lpest==3) THEN ! NCLASS
          CALL parsestr('svtitlet="NCLASS"')            
          dq0=t_zlsd(:,l,4)*sqrt(t_rlsd(:,l,4)**2+t_frsrf(l)**2/&
               t_rlsd(:,l,1)**2)
       END IF
       CALL spline_interp(t_tswpts,dq0,y1,y1,cq0,cq1,cq2,dq1)
       !        cos0(l)=TWOPI/dq1(t_mls)
       dq1=TWOPI*dq1/dq1(t_mls)
       cq1=sqrt((t_rlsd(:,l,1)-t_raxis)**2+((t_zlsd(:,l,1)-t_zaxis)/t_wvert)**2)
       CALL interp_interp(dq1,cq1,y1,y1,t_tswpts,dq2,cq2)
       cq1=t_tswpts-dq1
       CALL interp_interp(dq1,cq1,y1,y1,t_tswpts,cq0,cq2)
       cq0=cq0+t_tswpts
       t_rlsd(:,l,1)=dq2*cos(cq0)+t_raxis
       t_zlsd(:,l,1)=dq2*sin(cq0)*t_wvert+t_zaxis
    END DO
    !      cos0(1)=extrp(cos0,t_psibar,t_msrf,0,0)
  END SUBROUTINE newflux
  
  SUBROUTINE pfcfld
    INTEGER ncu,nbeg,nn,loop,loom,denom,nr,nz,ir,iz,l1,n,kl,jkl,l,j,i,ii,&
         mm,ifjx0,nbc,k,l2,i1,jk0p
    REAL(rq) ::  wk(t_jm0p,t_km0p),br0,bz0,brr,bzz,bbr,bbz,bmod,bmod0,bmax,fr,fz,&
         rg,zf,zg,rg0,zg0,drg,dzg,fl1,fl,b
    DATA ifjx0 /0/
    ncu=t_nc
    IF (t_nsymc == 1) ncu=t_nc/2
    !
    ! CURRENT DENSITY, SUM |I| AND SUM |I*L|...
    !
    nbc=0
    jk0p=t_jm0p*t_km0p
    t_pfjp=t_cc/(t_drc*t_dzc)
    t_pfil=ABS( TWOPI*t_rc*t_cc )
    t_pfcsi=SUM(abs(t_cc))
    t_pfcil=SUM(t_pfil)
    !
    ! B-FIELDS...
    !
    nbeg=1
    nn=0
    l1=1
    loop=0
    loom=0
    DO n=1,ncu
       t_pfbc(n)=0.0
       t_pfbr(n)=0.0
       t_pfbz(n)=0.0
       t_pffr(n)=0.0
       t_pffz(n)=0.0
       IF (t_kgreenc == 1) THEN ! USE STORED GREENS FUNCIONS...
          br0=0
          bz0=0
          kl=t_km
          IF (t_nsym <= 1) kl=t_km/2+1
          jkl=t_jm*kl
          l2=t_loop0(n)
          IF(t_iferro(n)==1) THEN
             loop=nn
             DO l=l1,l2
                nn=nn+1
                wk=t_gfbr(:,:,nn)
                t_br0p(nn)=SUM(RESHAPE(wk,(/jk0p/))*t_crj(:jk0p))
                wk=t_gfbz(:,:,nn)
                t_bz0p(nn)=SUM(RESHAPE(wk,(/jk0p/))*t_crj(:jk0p))
                t_br0p(nn)=-t_br0p(nn)*t_dr*t_dz/FOURPI*1.0e-04_rq
                t_bz0p(nn)=-t_bz0p(nn)*t_dr*t_dz/FOURPI*1.0e-04_rq
                br0=br0+t_br0p(nn)*t_ccf(l)
                bz0=bz0+t_bz0p(nn)*t_ccf(l)
             END DO
             br0=br0/t_cc(n)
             bz0=bz0/t_cc(n)
          ELSE
             nn=nn+1
             wk=t_gfbr(:,:,nn)
             t_br0p(nn)=SUM(RESHAPE(wk,(/jk0p/))*t_crj(:jk0p))*1.0e-04_rq
             wk=t_gfbz(:,:,nn)
             t_bz0p(nn)=SUM(RESHAPE(wk,(/jk0p/))*t_crj(:jk0p))*1.0e-04_rq
             t_br0p(nn)=-t_br0p(nn)*t_dr*t_dz/FOURPI
             t_bz0p(nn)=-t_bz0p(nn)*t_dr*t_dz/FOURPI
             br0=t_br0p(nn)
             bz0=t_bz0p(nn)
          END IF
       ELSE
          CALL g_fldp(100*t_rc(n),100*t_zc(n),br0,bz0,fl1)
          br0=1.0e-04_rq*br0
          bz0=1.0e-04_rq*bz0
       END IF
       l1=l2+1
       IF (t_ngp == 0) THEN
          rg0=t_rc(n) - 0.5_rq*t_drc(n)
          zg0=t_zc(n) - 0.5_rq*t_dzc(n)
          drg=t_drc(n)/t_nrc(n)
          dzg=t_dzc(n)/t_nzc(n)
          bbr=0
          bbz=0
          fr=0
          fz=0
          bmax=0
          DO k=0,t_nzc(n)
             DO j=0,t_nrc(n)
                rg=100*(rg0 + drg*j)
                zg=100*(zg0 + dzg*k)
                CALL g_flxfld(rg,zg,brr,bzz,fl)
                brr=1.0e-04_rq*brr + br0 !   MKS
                bzz=1.0e-04_rq*bzz + bz0
                b=brr**2 + bzz**2
                IF (b > bmax) bmax=b
                bbr=bbr + brr
                bbz=bbz + bzz
                fr=fr + 0.01_rq*rg*bzz
                fz=fz + 0.01_rq*rg*brr
             END DO
          END DO
          nr=t_nrc(n)+1
          nz=t_nzc(n)+1
          denom=nz*nr
       ELSE                   !   EFFI calculation
          IF (t_ngp == 1 .AND. t_iferro(n)==1) THEN
             loom=nbeg-1
             DO ir=1,t_nrc(n)
                DO iz=1,t_nzc(n)
                   loop=loop+1
                   loom=loom+1
                   t_brgp(loom)=t_br0p(loop)
                   t_bzgp(loom)=t_bz0p(loop)
                END DO
                loop=loop+1
                loom=loom+1
                t_brgp(loom)=t_br0p(loop)
                t_bzgp(loom)=t_bz0p(loop)
                DO iz=1,t_nzc(n)
                   loop=loop+1
                   loom=loom+1
                   t_brgp(loom)=.5_rq*(t_br0p(loop)+t_br0p(loop+1))
                   t_bzgp(loom)=.5_rq*(t_bz0p(loop)+t_bz0p(loop+1))
                   IF(ir/=t_nrc(n)) THEN
                      !  Re-store for right face
                      t_br0p(loop)=.5_rq*(t_br0p(loop)+t_br0p(loop+t_nzc(n)+2))
                      t_bz0p(loop)=.5_rq*(t_bz0p(loop)+t_bz0p(loop+t_nzc(n)+2))
                   END IF
                END DO
                loop=loop+1
                !  Store top field, overwrites bad value
                t_brgp(loom)=t_br0p(loop)
                t_bzgp(loom)=t_bz0p(loop)
                IF(ir/=t_nrc(n)) loop=loop-t_nzc(n)-1
             END DO
             DO iz=1,t_nzc(n)
                loop=loop+1
                loom=loom+1
                t_brgp(loom)=t_br0p(loop)
                t_bzgp(loom)=t_bz0p(loop)
             END DO
          END IF
          bbr=0
          bbz=0
          fr=0
          fz=0
          bmax=0
          DO nbc=nbeg,t_loopm(n)
             IF(t_iferro(n)==1) THEN
                brr=t_brgp(nbc)
                bzz=t_bzgp(nbc)
             ELSE
                bzz=bz0
                brr=br0
             END IF
             i1=1
             mm=0
             DO i=1,t_nc/(3-t_nsymc)
                IF(t_iferro(i)==1) THEN
                   DO ii=i1,t_loop0(i)
                      mm=mm+1
                      brr=brr + t_ccf(ii)*t_gsbr(mm,nbc)
                      bzz=bzz + t_ccf(ii)*t_gsbz(mm,nbc)
                   END DO
                ELSE
                   mm=mm+1
                   brr=brr + t_cc(i)*t_gsbr(mm,nbc)
                   bzz=bzz + t_cc(i)*t_gsbz(mm,nbc)
                END IF
                i1=t_loop0(i)+1
             END DO
             t_brgp(nbc)=brr
             t_bzgp(nbc)=bzz
             bbr=bbr + brr
             bbz=bbz + bzz
             bmod0=brr**2 + bzz**2
             fr=fr + t_rgp(nbc)*bzz
             fz=fz + t_rgp(nbc)*brr
             IF (bmod0 > bmax) bmax=bmod0
          END DO
          denom=(nbc-nbeg)
       END IF
       t_pffr(n)= TWOPI*fr*t_cc(n)/denom
       t_pffz(n)=-TWOPI*fz*t_cc(n)/denom
       t_pfbr(n)= bbr/denom
       t_pfbz(n)= bbz/denom
       t_pfbc(n)= SQRT(bmax)
       nbeg=nbc
    END DO
    !     
    !    HOOP STRESS, CRITICAL PACK CURRENT DENSITY AND MARGIN...
    !     
    DO n=1,ncu
       t_pfhs(n)=t_pffr(n)/(TWOPI*t_drc(n)*t_dzc(n))
       t_pfjc(n)= xpfjc( t_rc(n),t_drc(n),t_pfbz(n),t_pfbc(n),t_pftd,t_pfahs )
       t_pfjf(n)=abs( t_pfjp(n) )/t_pfjc(n)
    END DO
    !     
    ! COPY IF SYMMETRI!...
    !     
    IF (t_nsymc == 1) THEN
       t_pfbc(ncu+1:)= t_pfbc(:ncu)
       t_pfhs(ncu+1:)= t_pfhs(:ncu)
       t_pfms(ncu+1:)= t_pfms(:ncu)
       t_pfbz(ncu+1:)= t_pfbz(:ncu)
       t_pfbr(ncu+1:)=-t_pfbr(:ncu)
       t_pffz(ncu+1:)=-t_pffz(:ncu)
       t_pffr(ncu+1:)= t_pffr(:ncu)
       t_pfjc(ncu+1:)= t_pfjc(:ncu)
       t_pfjf(ncu+1:)= t_pfjf(:ncu)
    END IF
    !
    ! SAVE MAXIMUM VALUE OF ALLOWABLE FRACTION...
    !
    t_pfjx=xmaxaf( t_pfjf, 1, t_nfjx, 1, t_ifjx )
    t_pfbx=xmaxaf( t_pfbc, 1, t_nfjx, 1, t_ifbx )
    !
    ! NOTIFY USER IF LIMITING COIL CHANGES...
    !
    IF (t_ifjx /= ifjx0) THEN
       IF (ifjx0 == 0) THEN
          WRITE(STDOUT,101) t_pfid(t_ifjx)
          WRITE(t_logunit,101) t_pfid(t_ifjx)
       ELSE
          WRITE(STDOUT,102) t_pfid(t_ifjx), t_pfid(ifjx0)
          WRITE(t_logunit,102) t_pfid(t_ifjx), t_pfid(ifjx0)
       END IF
    END IF
    ifjx0=t_ifjx
    !
101 format('*** limiting coil is: ',a5,' ***')
102 format('*** limiting coil is: ',a5,' - was: ',a5,' ***')
  END SUBROUTINE pfcfld

  SUBROUTINE d_strkpl(pxp)
    !     
    !***********************************************************************
    !                                                                      *
    !     This routine finds "candidate" strike-points: there may be       *
    !     redundancies which can be distilled with dstrkpl                 *
    !                                                                      *
    !     nplates     : number of piece-wise straight segments modeling    *
    !                   the divertor plates                                *
    !                                                                      *
    !     rplate(i,1) : coordinates of the start of the ith segment        *
    !     zplate(i,1)                                                      *
    !                                                                      *
    !     rplate(i,2) : coordinates of the end of the ith segment          *
    !     zplate(i,2)                                                      *
    !                                                                      *
    !     nstkpts     : number of strike points found                      *
    !                                                                      *
    !     nsegs       : number of subdivisions each straight segment is    *
    !                   broken into for the search - once the subdivision  *
    !                   in which the strike point occurs is found, it is   *
    !                   subdivided again for more accuracy                 *
    !                                                                      *
    !     rstkpt(j)   : coordinates of the jth strike point.               *
    !     zstkpt(j)                                                        *
    !                                                                      *
    !                                                                      *
    !     The output consists of the point number, the plate (or segment)  *
    !     number, the coordinates of the strike point, the distance to the *
    !     x-point, the value of the flux and the difference between the    *
    !     x-point T_PSI and the strike-point T_PSI (measure of accuracy).  *
    !                                                                      *
    !***********************************************************************
    INTEGER :: i,j,l,ier,iter
    REAL(rq) :: rw1,zw1,rw2,zw2,drw,dzw,dw,ds,cost,sint,psip0,pxp,fpsi(8),&
         pp,dss,arg,test,d,rpl,zpl,psipl1
    t_nstkpts=0
    t_nspt=SIZE(t_rstkpt)
    IF( t_nplates<=0 .OR. pxp==0) RETURN
    l = 0
    DO i=1,t_nplates
       rw1  = t_rplate(i,1)
       zw1  = t_zplate(i,1)
       rw2  = t_rplate(i,2)
       zw2  = t_zplate(i,2)
       drw  = rw2 - rw1
       dzw  = zw2 - zw1
       dw   = sqrt( drw**2 + dzw**2 )
       ds   = dw/t_nsegs
       cost = drw/dw
       sint = dzw/dw

       ! SUBDIVIDE THE PLATE INTO NSEGS SEGMENTS, FIND T_PSI AT EACH
       ! END OF THE SUBDIVISION AND COMPARE TO pxp...
       psip0 = 0.0
       DO j=0,t_nsegs
          rpl = rw1 + ds*j*cost
          zpl = zw1 + ds*j*sint
          ier=0
          CALL boxd_interp( rpl, zpl, fpsi,ier,t_n4)
          IF( ier==0 .AND. psip0==0.0 ) THEN
             psip0 = fpsi(1)
          ELSEIF( ier==0 ) THEN
             psipl1 = fpsi(1)
             IF( (psipl1-pxp)*(pxp-psip0)>=0 ) THEN
                ! PXP IS BETWEEN THE TWO POINTS - REFINE SEARCH...
                pp=(psipl1-pxp)/(psipl1-psip0)
                dss=ds*j+pp*ds
                rpl=rw1+dss*cost
                zpl=zw1+dss*sint
                ier=0
                CALL boxd_interp( rpl, zpl, fpsi,ier,t_n4)
                DO iter=1,nter_interp
                   ier=0
                   arg=pxp-fpsi(1)
                   test=abs(arg/pxp)
                   IF(test<errt_rq) EXIT
                   dss=dss+arg/(cost*fpsi(2)+sint*fpsi(3))
                   rpl=rw1+dss*cost
                   zpl=zw1+dss*sint
                   CALL boxd_interp( rpl,zpl,fpsi,ier,t_n4)
                END DO
                IF (l < t_nspt) l=l+1
                t_rstkpt(l)=rpl
                t_zstkpt(l)=zpl
                t_bstkpt(l)=sqrt(fpsi(2)**2+fpsi(3)**2)/rpl
                IF(t_nsym<=1 .AND. t_zstkpt(l)<0) THEN
                   d = sqrt((t_rxpt-t_rstkpt(l))**2+(-t_zxpt-t_zstkpt(l))**2)
                ELSE
                   d = sqrt((t_rxpt-t_rstkpt(l))**2+(t_zxpt-t_zstkpt(l))**2)
                END IF
                t_dstkpt(l) = d
                t_lstkpt(l) = i
             END IF
             psip0 = psipl1
          END IF
       END DO ! j=0,t_nsegs
    END DO ! i=1,t_nplates
    t_nstkpts = l

  END SUBROUTINE d_strkpl

  SUBROUTINE dstrkpl
    !***********************************************************************
    !                                                                      *
    !     This routine distills the candidate strike-points from strkpl by *
    !     removing redundancies.  The distilled strike-point coordinates,  *
    !     the (X-point to S-point) distances and the poloidial field at    *
    !     the strike-points are returned in arrays rspt, zspt, dspt and    *
    !     bspt, and the number of entries in integer nspt.                 *
    !                                                                      *
    !     IF the configuration is limited, nspt=0, IF it is a single-null, *
    !     THEN nspt will be 2 or less, and IF double-null THEN nspt is 4   *
    !     or less.  The entries in the above arrays will be ordered from   *
    !     top to bottom and from inboard to outboard.                      *
    !                                                                      *
    !***********************************************************************
    REAL(rq), DIMENSION(SIZE(t_rstkpt)) :: rxstkpt,zxstkpt,astkpt,rtemp,ztemp,&
         dtest,btemp,dtemp
    REAL(rq) :: dmin,dmax,test,d
    INTEGER :: ia(SIZE(t_rstkpt)),i,j,m,iamax,jmin,n_max,imin,imax,ier

    IF (s_limiterd == 1) THEN
       t_nspt = 0
    ELSEIF (t_nstkpts > 0) THEN
       ! Get relevant x-point for each strike-point...
       IF (ABS((s_pxpu - s_pxpl) / t_dpsi0) < t_dn_criterion) THEN ! DN
          DO i = 1,t_nstkpts
             IF (t_zstkpt(i) > 0) THEN
                rxstkpt(i) = s_rxpu
                zxstkpt(i) = s_zxpu
             ELSE
                rxstkpt(i) = s_rxpl
                zxstkpt(i) = s_zxpl
             END IF
          END DO
       ELSE ! SN
          DO i = 1,t_nstkpts
             rxstkpt(i) = t_rxpt
             zxstkpt(i) = t_zxpt
          END DO
       END IF
       ! Strike-point angles relative to associated x-point...
       DO i = 1,t_nstkpts
          astkpt(i) = atan2(t_zstkpt(i)-zxstkpt(i),t_rstkpt(i)-rxstkpt(i))
          IF (astkpt(i) < 0) THEN
             astkpt(i) = astkpt(i) + TWOPI
          END IF
       END DO
       ! Group strike-points with similar angles...
       ia(1) = 1
       iamax = 1
       DO i = 2,t_nstkpts
          dmin = 1/errb_rq
          DO j = 1,i
             IF (j /= i) THEN
                d = ABS(astkpt(i) - astkpt(j))
                IF (d < dmin) THEN
                   dmin = d
                   jmin = j
                END IF
             END IF
          END DO
          IF (dmin > t_spt_angle) THEN
             iamax = iamax + 1
             ia(i) = iamax
          ELSE
             IF (t_zstkpt(i) / t_zstkpt(jmin) > 0) THEN
                ia(i) = ia(jmin)
             ELSE
                iamax = iamax + 1
                ia(i) = iamax
             END IF
          END IF
       END DO
       ! Select closest point in each group
       m = iamax
       IF (m > t_nstkpts) m = t_nstkpts
       DO j = 1,m
          dmin = 1/errb_rq
          DO i = 1,t_nstkpts
             IF (ia(i) == j) THEN
                IF (t_dstkpt(i) < dmin) THEN
                   dmin = t_dstkpt(i)
                   rtemp(j) = t_rstkpt(i)
                   ztemp(j) = t_zstkpt(i)
                   dtemp(j) = t_dstkpt(i)
                   btemp(j) = t_bstkpt(i)
                END IF
             END IF
          END DO
       END DO
       ! Restrict to 2 or 4 at most
       IF (ABS((s_pxpu - s_pxpl) / t_dpsi0) < t_dn_criterion) THEN
          n_max = 4
       ELSE
          n_max = 2
       END IF
       DO i = 1,m
          dtest(i) = dtemp(i)
       END DO
       DO i = 1,n_max - 1
          CALL xminmax(dtest,1,m,1,dmin,dmax,imin,imax)
          dtest(imin) = 1./errb_rq
       END DO
       CALL xminmax(dtest,1,m,1,dmin,dmax,imin,imax)
       j = 0
       DO i = 1,m
          IF (dtemp(i) <= dmin) THEN
             j = j + 1
             t_nspt = j
             t_rspt(j) = rtemp(i)
             t_zspt(j) = ztemp(i)
             t_dspt(j) = dtemp(i)
             t_bspt(j) = btemp(i)
          END IF
       END DO

       ! Put in standard order {TOP{IN,OUT},BOT{IN,OUT}}
       DO i = 1,t_nspt
          rtemp(i) = t_rspt(i)
          ztemp(i) = t_zspt(i)
          dtemp(i) = t_dspt(i)
          btemp(i) = t_bspt(i)
       END DO
       IF (t_nspt == 4) THEN
          IF (t_zspt(1) < 0 .AND. t_zspt(2) > 0) THEN
             IF (t_zspt(3) > 0) THEN
                t_rspt(1) = rtemp(3); t_rspt(3) = rtemp(1)
                t_zspt(1) = ztemp(3); t_zspt(3) = ztemp(1)
                t_dspt(1) = dtemp(3); t_dspt(3) = dtemp(1)
                t_bspt(1) = btemp(3); t_bspt(3) = btemp(1)
             ELSE
                t_rspt(1) = rtemp(4); t_rspt(4) = rtemp(1)
                t_zspt(1) = ztemp(4); t_zspt(4) = ztemp(1)
                t_dspt(1) = dtemp(4); t_dspt(4) = dtemp(1)
                t_bspt(1) = btemp(4); t_bspt(4) = btemp(1)
             END IF
          ELSEIF (t_zspt(1) > 0 .AND. t_zspt(2) < 0) THEN
             IF (t_zspt(3) > 0) THEN
                t_rspt(2) = rtemp(3); t_rspt(3) = rtemp(2)
                t_zspt(2) = ztemp(3); t_zspt(3) = ztemp(2)
                t_dspt(2) = dtemp(3); t_dspt(3) = dtemp(2)
                t_bspt(2) = btemp(3); t_bspt(3) = btemp(2)
             ELSE
                t_rspt(2) = rtemp(4); t_rspt(4) = rtemp(2)
                t_zspt(2) = ztemp(4); t_zspt(4) = ztemp(2)
                t_dspt(2) = dtemp(4); t_dspt(4) = dtemp(2)
                t_bspt(2) = btemp(4); t_bspt(4) = btemp(2)
             END IF
          ELSEIF (t_zspt(1) < 0 .AND. t_zspt(2) < 0) THEN
             t_rspt(1:2) = rtemp(3:4); t_rspt(3:4) = rtemp(1:2)
             t_zspt(1:2) = ztemp(3:4); t_zspt(3:4) = ztemp(1:2)
             t_dspt(1:2) = dtemp(3:4); t_dspt(3:4) = dtemp(1:2)
             t_bspt(1:2) = btemp(3:4); t_bspt(3:4) = btemp(1:2)
          END IF
       END IF
       IF (t_nspt == 2 .OR. t_nspt == 4) THEN
          IF (t_rspt(1) > t_rspt(2)) THEN
             rtemp(1) = t_rspt(1); t_rspt(1) = t_rspt(2); t_rspt(2) = rtemp(1)
             ztemp(1) = t_zspt(1); t_zspt(1) = t_zspt(2); t_zspt(2) = ztemp(1)
             dtemp(1) = t_dspt(1); t_dspt(1) = t_dspt(2); t_dspt(2) = dtemp(1)
             btemp(1) = t_bspt(1); t_bspt(1) = t_bspt(2); t_bspt(2) = btemp(1)
          END IF
       END IF
       IF (t_nspt == 4) THEN
          IF (t_rspt(3) > t_rspt(4)) THEN
             rtemp(3) = t_rspt(3); t_rspt(3) = t_rspt(4); t_rspt(4) = rtemp(3)
             ztemp(3) = t_zspt(3); t_zspt(3) = t_zspt(4); t_zspt(4) = ztemp(3)
             dtemp(3) = t_dspt(3); t_dspt(3) = t_dspt(4); t_dspt(4) = dtemp(3)
             btemp(3) = t_bspt(3); t_bspt(3) = t_bspt(4); t_bspt(4) = btemp(3)
          END IF
       END IF

    END IF

  END SUBROUTINE dstrkpl
  SUBROUTINE vltsec(vlt,iv)
    INTEGER, INTENT(IN) :: iv
    REAL(rq), INTENT(OUT) :: vlt
    INTEGER :: klm,jkl,j,k,l,jl,ju,n,ncl,l1,l2,kl,nn,i,ier,n1
    REAL(rq) :: zum(3),summ,sump,sumd,wk(t_jm0p,t_km0p)

    !    
    !     iv=2 average flux; iv=1 volt-second ; iv=3 flux at coils
    !
    n1=0
    IF(ALLOCATED(pdloop))THEN
       n1=SIZE(pdloop,1)
    END IF
    IF(n1/=t_nloop0p) THEN
       IF(ALLOCATED(pdloop)) DEALLOCATE(pdloop)
       ALLOCATE(pdloop(t_nloop,8))
    END IF
    jkl=t_jm0p*t_km0p
    ncl=t_nc	
    IF(t_nsym<=1) ncl=t_nc/2
    vlt=0.0
    summ=0
    sumd=-t_plc*FOURPI/(t_dr*t_dz)
    IF(iv==2 .OR. iv==0) THEN  !  average flux "t_psires"
       DO k=1,t_km0p
          sump=0
          IF(s_jbl(k)/=t_jm+1 .OR. s_jbu(k)/=0) THEN
             n=t_jm*(k-1)+s_jbl(k)
             sump=sump+.5*t_crj(n)/t_rm(n)*(1.-(t_psil-t_psi(n))/&
                  (t_psi(n)-t_psi(n-1)))*t_psi(n)
             n=t_jm*(k-1)+s_jbu(k)
             sump=sump+.5*t_crj(n)/t_rm(n)*(1.+(t_psil-t_psi(n))/&
                  (t_psi(n+1)-t_psi(n)))*t_psi(n)
          END IF
          nn=t_jm*(k-1)
          DO n=nn+s_jbl(k)+1,nn+s_jbu(k)-1
             sump=sump+t_psi(n)*t_crj(n)/t_rm(n)
          END DO
          summ=summ+sump
       END DO
       IF(t_nsym<=1) THEN
          summ=2*summ-sump  !   made use of symmetry
          summ=summ/sumd
       ELSE
          summ=summ/sumd
       END IF
       t_psires=summ*MU0/20
    END IF
    sumd=200*sumd/MU0
    IF(iv/=2) THEN  !  flux at coils and voltsecs
       IF(t_kgreenc==1) THEN
          nn=0
          l1=1
          DO i=1,ncl
             summ=0
             l2=t_loop0(i)
             IF(t_iferro(i)==1) THEN
                DO l=l1,l2
                   nn=nn+1
                   wk=t_gc(:,:,nn)
                   IF(t_nsym<=1) wk(:,t_km0p)=0.5_rq*wk(:,t_km0p)
                   summ=summ+SUM(RESHAPE(wk,(/jkl/))*t_crj(:jkl)/&
                        t_rm(:jkl))*t_ccf(l)
                END DO
                summ=summ/t_cc(i)
             ELSE
                nn=nn+1
                wk=t_gc(:,:,nn)
                IF(t_nsym<=1) wk(:,t_km0p)=0.5_rq*wk(:,t_km0p)
                summ=SUM(RESHAPE(wk,(/jkl/))*t_crj(:jkl)/t_rm(:jkl))
             END IF
             l1=l2+1
             t_pfpsi(i)=-5.0e-9_rq*t_dr*t_dz*summ
          END DO
          IF(t_nloop0p/=0 .AND. t_int_flag>=0) THEN
             DO l=1,t_nloop0p
                t_floop(l,1)=SUM(t_gpl(:t_jm0p*t_km0p,l,1)*t_crj(:t_jm0p*&
                     t_km0p))
                t_floop(l,2)=SUM(t_gpl(:t_jm0p*t_km0p,l,2)*t_crj(:t_jm0p*&
                     t_km0p))
                t_floop(l,3)=SUM(t_gpl(:t_jm0p*t_km0p,l,3)*t_crj(:t_jm0p*&
                     t_km0p))
             END DO
          END IF
       ELSE
          DO i=1,ncl
             t_pfpsi(i)=g_flxp(100*t_rc(i),100*t_zc(i))*MU0/20
          END DO
          IF(t_nloop0p/=0 .AND. t_int_flag>=0) THEN
             DO l=1,t_nloop0p
                CALL g_fldp(t_rloop(l),t_zloop(l),t_floop(l,2),t_floop(l,3),&
                     t_floop(l,1))
                t_floop(l,1)=t_floop(l,1)*MU0/20
                t_floop(l,2)=t_floop(l,2)*1.e-4_rq
                t_floop(l,3)=t_floop(l,3)*1.e-4_rq
             END DO
          END IF
       END IF
       DO i=1,ncl
          t_cmplas(i)=0.1_rq*t_pfpsi(i)/t_plc
       END DO
       IF(iv==0 .OR. iv==3) THEN
          DO i=1,ncl
             t_pfpsi(i)=t_pfpsi(i)+SUM(t_pfim(i,:)*t_cc)
          END DO
          IF(t_nloop0p/=0 .AND. t_int_flag>=0) THEN
             DO l=1,t_nloop0p
                t_floop(l,1)=t_floop(l,1)+SUM(t_plim(:,l,1)*t_cc)
                t_floop(l,2)=t_floop(l,2)+SUM(t_plim(:,l,2)*t_cc)
                t_floop(l,3)=t_floop(l,3)+SUM(t_plim(:,l,3)*t_cc)
             END DO
          ELSEIF(t_nloop0p/=0) THEN
             ier=6
             CALL boxm_interp(t_rloop,t_zloop,pdloop,t_r,t_z,i_cps,0,ier,t_n4)
             DO l=1,t_nloop0p
                t_floop(l,1)=pdloop(l,1)*MU0/20
                t_floop(l,2)=-pdloop(l,3)/t_rloop(l)*1.0e-4_rq
                t_floop(l,3)= pdloop(l,2)/t_rloop(l)*1.0e-4_rq
             END DO
          END IF
       END IF
       IF(ncl/=t_nc) THEN
          t_pfpsi(ncl+1:)=t_pfpsi(:ncl)
          t_cmplas(ncl+1:)=t_cmplas(:ncl)
       END IF
       t_vlts2D=t_cmplas*t_cc*1.0e6_rq
       vlt=SUM(t_vlts2D)
    END IF
  END SUBROUTINE vltsec

  FUNCTION xpfjc( rr, drr, bza, bmax, tdump, stress ) RESULT(xpf)
    !
    !***********************************************************************
    !                                                                      *
    !     XPFJC computes the allowable pack current density of a solenoid  *
    !     coil using the algorithm from J. Miller (SCMDG 88-5.1-90R).      *
    !     Based on helium-cooled (4.5-K) NbSn cable-in-conduit conductor.  *
    !                                                                      *
    !     RR      :  mean radius of coil [m]                                *
    !     DRR     :  radial build [m]                                       *
    !     BZA    :  average axial field in coil pack [T]                   *
    !     BMAX   :  maximum transverse field in coil pack [T]              *
    !     TDUMP  :  dump time constant [s]                                 *
    !     STRESS :  allowable hoop stress in steel [MPa]                   *
    !     XPFJC  := allowable current density [MA/sqm]                     *
    !     F(1)   := fraction NbSn superconductor                           *
    !     F(2)   := fraction stabiilzing copper                            *
    !     F(3)   := fraction helium passage                                *
    !     F(4)   := fraction of steel conduit                              *
    !     F(5)   := fraction of insulation                                 *
    !                                                                      *
    !***********************************************************************
    REAL(rq), INTENT(IN) :: rr,drr,bza,bmax,tdump,stress
    REAL(rq), PARAMETER ::&
         bcrit=23.0_rq,&       ! critical field for NbSn [T]
         utotal=7.0e+04_rq,&   ! Cu,SC sp. ht. integral [s*MA**2/m**4]
         fsc= 0.6_rq,&         ! S.C. Jcrit utilization factor
         fcu= 0.6_rq,&         ! fraction Cu/conductor
         fhe= 0.375_rq,&       ! fraction He
         fi = 0.1_rq           ! insultion factor
         
    REAL(rq) ::  a(5),xpf,falpha,atot
    INTEGER :: i
    !
    ! COMPUTE AREAS BASED ON 1-MA CURRENT...
    !
    IF( bmax<bcrit ) THEN
       a(1)   = sqrt( bmax )/( fsc*( 109*( 1 - bmax/bcrit ) )**2 )
       a(2)   = sqrt( 0.5_rq*tdump/utotal )*fcu**1.5
       a(3)   = fhe*( a(1) + a(2) )/( 1 - fhe )
       t_alpha  = ( rr + 0.5_rq*drr )/( rr - 0.5_rq*drr )
       falpha = 0.100_rq + 0.925_rq*t_alpha - 0.053_rq*t_alpha**2
       a(4)   = falpha*abs( bza )*rr/stress
       a(5)   = fi*( a(1) + a(2) + a(3) + a(4) )
       atot   = 0.0
       DO i=1,5
          atot = atot + a(i)
       END DO
       xpf = 1.0_rq/atot
    ELSE
       xpf = 1.0e-15_rq
    END IF
  END FUNCTION xpfjc
  FUNCTION xpfms( rrc, drrc, xj, bi, bo ) RESULT(xpf)
    !
    !  xpfms returns the maximum hoop stress in a solenoid, as a function of
    !  the coil mean radius (rrc), radial build (drrc), average current density
    !  (xj), axial field on the inner edge (bi) and axial field on the outer
    !  edge (bo)
    !
    !  Ref:"Superconducting Magnets", M.N.Wilson, 1983 Clarendon Press pp 40-47
    REAL(rq), INTENT(IN) :: rrc,drrc,xj,bi,bo
    REAL(rq), PARAMETER :: pois=0.333_rq  ! Poisson's ratio
    REAL(rq)a,b,xa,xk,xm,ck,cvk,fk,cm,cmv,fm,xpf,cvm

    a     = rrc - 0.5_rq*drrc
    b     = rrc + 0.5_rq*drrc
    xa    = b/a
    xk    = a*xj*( xa*bi - bo )/( xa - 1 )
    xm    = a*xj*( bi - bo )/( xa - 1 )
    ck    = 2*xa**2 + xa + 1
    cvk   = ( 1 + 2*pois )*( xa + 1 )/( 2 + pois )
    fk    = xk*( 2 + pois )/( 3*( xa + 1 ) )
    cm    = 2*xa**2 + 1
    cvm   = ( 1 + 3*pois )/( 3 + pois )
    fm    = xm*( 3 + pois )/8
    xpf   = fk*( ck - cvk ) - fm*( cm - cvm )
  END FUNCTION xpfms

  SUBROUTINE trap_pass(dparb2rf)
    REAL(rq), INTENT(OUT) :: dparb2rf(t_msrf)
    REAL(rq) :: zbsq,dparb2,sun,tum,tum1,tuml,tum2,rum3,grat,xlam,ylam,zjam,&
         eps,djard,dydx,rat,bmax,bbar,gjard,zum,zlam,zuml,zumu,tum3
    INTEGER :: ier,l,isw,jjj,nxl,mpp,lsm,niter,lxl,llam,ls,m
    REAL(rq), DIMENSION(:), POINTER :: mu
    !
    !--- Calculates trapped to passing (effective) on a surface
    !
    IF(SIZE(cq0)/=t_mls) THEN
       IF(ALLOCATED(cq0)) DEALLOCATE(cq0,cq1,cq2,cq3,cq4,cq5,cq6,cq7,cq8,cq9,&
            dq0,dq3,dq4,dq5,dq6,dq7,dq8,dq9,dq10)
       ALLOCATE(cq0(t_mls),cq1(t_mls),cq2(t_mls),cq3(t_mls),cq4(t_mls),cq5(t_mls),&
       cq6(t_mls),cq7(t_mls),cq8(t_mls),cq9(t_mls),dq0(t_mls),dq3(t_mls),dq4(t_mls),&
            dq5(t_mls),dq6(t_mls),dq7(t_mls),dq8(t_mls),dq9(t_mls),dq10(t_mls))
    END IF
    IF(SIZE(dq1)/=t_mls) THEN
       IF(ALLOCATED(dq1))DEALLOCATE(dq1,dq2)
       ALLOCATE(dq1(t_mls),dq2(t_mls))
    END IF

    mu=>cq9
    mlm=t_mls/2
    s_pin=SIGN(1.0_rq,t_dpsi0)
    DO l=t_msrf,2,-1
       cq1=t_rlsd(:,l,1)
       dq1=t_zlsd(:,l,1)
       dq0=s_pin*t_zlsd(:,l,4)
       cq6=t_rlsd(:,l,2)/dq0
       dq4=t_zlsd(:,l,2)/dq0
       cq5=sqrt(cq6**2+dq4**2)
       dq5=t_frsrf(l)/cq1
       dq6=sqrt(cq5**2+dq5**2)
       dq2=-TWOPI/(t_lmax-1)/s_pin*dq0
       ier=6
       IF(t_inv_eq/=0) THEN
          ier=0
          cq2=t_rhosq(l,:,1)
          CALL boxi_interp(cq2,t_tswpts,t_pdls,t_dpsi0,t_psix,t_wvert,ier,t_n6)
       ELSE
          isw=0;ier=6;
          CALL boxm_interp(cq1,dq1,t_pdls,t_r,t_z,i_cps,isw,ier,t_n4)
       END IF
       zbsq=t_bsqrf(l)        
       cq0(:t_lmax)=dq2(:t_lmax)/(cq1(:t_lmax)*dq6(:t_lmax)**2)**2*&
            ((dq4(:t_lmax)**2-cq6(:t_lmax)**2)*t_pdls(:t_lmax,5)-cq6(:t_lmax)*&
            (dq4(:t_lmax)*(t_pdls(:t_lmax,6)-t_pdls(:t_lmax,4))+&
            dq6(:t_lmax)**2))**2
       IF(t_nsym==1) THEN
          DO ls=1,mlm-1
             cq0(ls+mlm)=cq0(mlm-ls)
          END DO
       END IF
       DO ls=1,t_mls-1
          cq2(ls)=dq2(ls+1)+dq2(ls)
       END DO
       mu(1)=0
       rat=0.5_rq
       IF(t_lmax/=t_mls) rat=0.25_rq
       DO ls=1,t_mls-1
          mu(ls+1)=mu(ls)+rat*cq2(ls)
       END DO
       dparb2=SUM(cq0(:t_mls-1))
       dparb2rf(l)=dparb2/SUM(dq2(:t_mls-1))/t_bsqrf(l)
       bmax=xmaxaf(dq6,1,t_mls,1,jjj)

       sun=t_vpsrf(l)/TWOPI
       tum=zbsq
       bbar=sqrt(tum)
       gjard=0
       dq2=sqrt(abs(1-dq6/bmax))*(1+0.5*dq6/bmax)/dq6**2
       DO ls=2,t_mls
          gjard=gjard+(mu(ls)-mu(ls-1))*(dq2(ls)+dq2(ls-1))*0.5
       END DO
       gjard=gjard*tum/mu(t_mls)
       zbsq=gjard/(1-gjard)
       dq0=dq6
       dq1(2:t_mls)=0.5_rq*(mu(2:t_mls)-mu(:t_mls-1))

       DO ls=1,jjj-1           !   re-order ls=1 now refers to peak of mod-B
          cq0(ls)=dq1(jjj+1-ls) !   dl/B reordered
          dq4(ls)=dq0(jjj+1-ls) !   B re-orderred
       END DO
       m=t_mls+jjj
       DO ls=jjj,t_mls
          cq0(ls)=dq1(m-ls)
          dq4(ls)=dq0(m-ls)
       END DO

       DO ls=2,t_mls
          dq2(ls)=dq2(ls-1)+cq0(ls) !   integral dl/B
       END DO
       zum=0
       nxl=2*nter_interp
       eps=sqrt(1.-bbar/bmax)
       lxl=1+1./eps
       IF(lxl>nxl)nxl=lxl

       DO llam=1,nxl-1
          xlam=(llam-0.5_rq)/(nxl-1.)
          ylam=xlam*eps/(1.+eps-xlam) !   stretched coordinate
          dydx=eps*(1+eps)/(1+eps-xlam)**2 !   Jacobian
          zlam=(1-ylam**2)/bmax !   pitch angle relation to stretched 
          !        Now calculate <sqrt(1-lambda*B)>
          tum1=0
          DO ls=1,t_mls-1
             dq0(ls)=sqrt(1-zlam*dq4(ls))
          END DO
          DO ls=t_mls-2,1,-1
             tuml=.5_rq*cq0(ls)*(dq0(ls)+dq0(ls+1))
             tum1=tum1+tuml 
          END DO
          tum1=sun/tum1
          tum2=0
          DO ls=1,t_mls-1         !   now integrate lambda=mu/E
             zuml=(dq4(ls)-bmax)/(sqrt(1-zlam*dq4(ls))+ylam)
             zumu=(dq4(ls+1)-bmax)/(sqrt(1-zlam*dq4(ls+1))+ylam)
             tum2=tum2+0.5*zlam*(zumu+zuml)*cq0(ls)
          END DO
          tum3=dydx*zlam*bmax*tum1*tum2/sun
          zum=zum+tum3
       END DO
       zum=zum*1.5_rq/(nxl-1.)
       grat=(1+zum)*tum/bmax**2 !   fraction of circulating
       t_fttcsrf(l)=(1-grat)/grat
    END DO
  END SUBROUTINE trap_pass

  SUBROUTINE diaginv
    REAL(rq) :: hb,hc,hd,hh,hm,s_pin,dd,bbb,hinas,psires_
    INTEGER :: is(t_msrf),l,lvz,mq,n1
    
    s_pin=SIGN(1.0_rq,t_dpsi0)
    mlm=t_mls/2+1
    n1=0
    IF(ALLOCATED(c1)) THEN
       n1=SIZE(c1)
    END IF
    IF(n1/=t_msrf) THEN
       IF(ALLOCATED(c1)) DEALLOCATE(c0,c1,c2,c3)
       ALLOCATE(c0(t_msrf),c1(t_msrf),c2(t_msrf),c3(t_msrf))
    END IF
    n1=0
    IF(ALLOCATED(dq1))THEN
       n1=SIZE(dq1)
    END IF
    IF(n1/=t_mls) THEN
       IF(ALLOCATED(dq1))DEALLOCATE(dq1,dq2)
       ALLOCATE(dq1(t_mls),dq2(t_mls))
    END IF

    DO l=1,t_msrf
       t_asrf(l)=0.5_rq*(t_rlsd(1,l,1)-t_rlsd(mlm,l,1))
       t_rsrf(l)=0.5_rq*(t_rlsd(1,l,1)+t_rlsd(mlm,l,1))
    END DO
    DO l=2,t_msrf
       dq1=t_zlsd(:,l,1)
       t_esrf(l)=xmaxaf(dq1,1,t_mls,1,is(l))
    END DO
    DO l=2,t_msrf
       lvz=is(l)
       c0(l)=(t_zlsd(lvz+1,l,1)-t_zlsd(lvz-1,l,1))/t_tswpts(3)
       c1(l)=(t_zlsd(lvz+1,l,1)+t_zlsd(lvz-1,l,1)-2*t_zlsd(lvz,l,1))/&
            t_tswpts(2)**2
       c2(l)=-c0(l)/(errt_rq+c1(l))
       t_esrf(l)=(t_zlsd(lvz,l,1)+c0(l)*c2(l)+0.5_rq*c1(l)*c2(l)**2)
    END DO
    DO l=2,t_msrf
       lvz=is(l)
       c0(l)=(t_rlsd(lvz+1,l,1)-t_rlsd(lvz-1,l,1))/t_tswpts(3)
       c1(l)=(t_rlsd(lvz+1,l,1)+t_rlsd(lvz-1,l,1)-2*t_rlsd(lvz,l,1))/&
            t_tswpts(2)**2
       t_tusrf(l)=(t_rlsd(lvz,l,1)+c0(l)*c2(l)+0.5_rq*c1(l)*c2(l)**2)
    END DO
    DO l=2,t_msrf
       dq1=t_zlsd(:,l,1)
       t_tsrf(l)=xminaf(dq1,1,t_mls,1,is(l))
    END DO
    DO l=2,t_msrf
       lvz=is(l)
       c0(l)=(t_zlsd(lvz+1,l,1)-t_zlsd(lvz-1,l,1))/t_tswpts(3)
       c1(l)=(t_zlsd(lvz+1,l,1)+t_zlsd(lvz-1,l,1)-2*t_zlsd(lvz,l,1))/&
            t_tswpts(2)**2
       c2(l)=-c0(l)/(errt_rq+c1(l))
       t_tsrf(l)=(t_zlsd(lvz,l,1)+c0(l)*c2(l)+0.5_rq*c1(l)*c2(l)**2)
    END DO
    DO l=2,t_msrf
       lvz=is(l)
       c0(l)=(t_rlsd(lvz+1,l,1)-t_rlsd(lvz-1,l,1))/t_tswpts(3)
       c1(l)=(t_rlsd(lvz+1,l,1)+t_rlsd(lvz-1,l,1)-2*t_rlsd(lvz,l,1))/&
            t_tswpts(2)**2
       t_tlsrf(l)=(t_rlsd(lvz,l,1)+c0(l)*c2(l)+0.5_rq*c1(l)*c2(l)**2)
    END DO
    t_rbin=t_rsrf(t_msrf)-t_asrf(t_msrf)
    t_rbout=t_rsrf(t_msrf)+t_asrf(t_msrf)
    IF(t_pxpt==s_pxpl) THEN
       t_rxpf=t_tusrf(t_msrf)
       t_zxpf=t_esrf(t_msrf)
    ELSEIF(t_pxpt==s_pxpu) THEN
       t_rxpf=t_tlsrf(t_msrf)
       t_zxpf=t_tsrf(t_msrf)
    END IF
    DO l=2,t_msrf
       t_esrf(l)=0.5_rq*(t_esrf(l)-t_tsrf(l))/t_asrf(l)
       t_tusrf(l)=(t_rsrf(l)-t_tusrf(l))/t_asrf(l)
       t_tlsrf(l)=(t_rsrf(l)-t_tlsrf(l))/t_asrf(l)
    END DO
    DO l=1,t_msrf
       t_tsrf(l)=0.5_rq*(t_tusrf(l)+t_tlsrf(l))
       t_psrf(l)=t_psibar(l)*t_dpsi0+t_psix   
    END DO
    t_tlsrf(1)=extrp(t_tlsrf,t_asrf,t_msrf,0,0)
    t_tusrf(1)=extrp(t_tusrf,t_asrf,t_msrf,0,0)
    t_qsrf(1)=extrp(t_qsrf,t_asrf,t_msrf,0,0)
    t_vpsrf(1)=extrp(t_vpsrf,t_asrf,t_msrf,0,0)
    t_esrf(1)=extrp(t_esrf,t_asrf,t_msrf,0,0)
    t_tsrf(1)=0.5_rq*(t_tlsrf(1)+t_tusrf(1))
    DO l=1,t_msrf
       c0(l)=t_tsrf(l)*t_asrf(l)
    END DO
    !     Force t_tsrf->0 smoothly on axis (triangularity) and evaluate trider
!    CALL polyfit_interp(c0,t_msrf,0,c2,3)
    CALL polyfit_interp(c0,c3,t_psibar,t_dpoly,t_spoly,t_mpoly,3)
    DO l=2,t_msrf
       t_tsrf(l)=c0(l)/t_asrf(l)
       c1(l)=t_tsrf(l)*t_rsrf(l)/t_asrf(l)
    END DO
    t_trider=extrp(c1,t_psibar,t_msrf,0,0)
    t_tsrf(1)=0
    t_rsqirf(1)=1./t_raxis**2
    IF(t_wvert/=1) t_wvert=t_esrf(1)
    mq=1
    t_qmin=xminaf(t_qsrf,1,t_msrf,1,mq)
    t_rhomin=0
    IF(mq==1) THEN
       t_qmin=xmaxaf(t_qsrf,1,t_msrf,1,mq)
       DO l=mq-1,1,-1
          IF(t_qsrf(l)<t_qmin) THEN
             t_qmin=t_qsrf(l)
          ELSE
             EXIT
          END IF
       END DO

       mq=l+1
    END IF
    IF(t_ifluxcord==-1) THEN
       CALL fdInt(1.+rq/t_qsrf,t_phibar,t_msrf,c0)
       t_psibar=c0/c0(t_msrf)
    ELSE
       CALL fdInt(t_qsrf,t_psibar,t_msrf,t_qh)
       t_phibar=t_qh/t_qh(t_msrf)
    END IF
    t_dphi0=t_dpsi0*t_qh(t_msrf)
    IF(mq>1 .AND. mq<t_msrf) THEN
       dd=-0.5_rq*(t_qsrf(mq+1)-t_qsrf(mq-1))/(t_qsrf(mq+1)+t_qsrf(mq-1)-2*&
            t_qsrf(mq))
       t_qmin=t_qmin+0.5_rq*(t_qsrf(mq+1)-t_qsrf(mq-1))*dd
       t_rhomin=t_phibar(mq)+0.5_rq*dd*(t_phibar(mq+1)-t_phibar(mq-1))+0.5_rq*&
            dd**2*&
            (t_phibar(mq+1)+t_phibar(mq-1)-2*t_phibar(mq))
       t_rhomin=SQRT(ABS(t_rhomin))
    END IF
    CALL fdInt(t_cusrf,t_psrf,t_msrf,c1)
    t_bpsqva=c1(t_msrf)
    c2=t_prsrf*t_vpsrf*s_pin
    CALL fdInt(c2,t_psrf,t_msrf,c1)
    t_presva=c1(t_msrf)
    c2=t_prsrf**2*t_vpsrf*s_pin
    CALL fdInt(c2,t_psrf,t_msrf,c1)
    t_betal=c1(t_msrf)
    c2=t_risrf*t_vpsrf*s_pin/TWOPI
    CALL fdInt(c2,t_psrf,t_msrf,t_susrf)
    t_surf=t_susrf(t_msrf)
    CALL fdInt(t_cusrf,t_psrf,t_msrf,c1)
    t_bpsqva=c1(t_msrf)
    c2=t_vpsrf*s_pin
    CALL fdINT(c2,t_psrf,t_msrf,t_volsrf)
    t_volume=t_volsrf(t_msrf)
    c2=t_qsrf*t_psrf
    CALL fdInt(c2,t_psrf,t_msrf,c1)
    t_helicity=c1(t_msrf)
    CALL get95
    t_helicity=TWOPI**2*2.0e-16_rq*(t_qh(t_msrf)*t_dpsi0*t_psrf(t_msrf)-t_helicity)
    !Wb**2
    t_bpolsa=t_cusrf(t_msrf)/t_alsrf(t_msrf)
    bbb=(t_frsrf(t_msrf)/s_rcntr)**2
    IF(t_ipj==0 .AND. t_ipf<=0) bbb=t_bpolsa**2+bbb
    t_placur=t_plc*10
    t_placur=-10*s_pin*t_cusrf(t_msrf)/FOURPI
    t_presva=t_presva/t_volume
    psires_=(t_psil-t_bpsqva/t_cusrf(t_msrf))*MU0/20
    t_bpsqva=s_pin*TWOPI*t_bpsqva/t_volume
    t_betal=SQRT(t_betal/t_volume)
    t_al=t_alsrf(t_msrf)
    t_psipls=t_surf/t_al
    t_betae=8*PI*t_presva/bbb
    t_betal=8*PI*t_betal/bbb
    t_betap(1)=8*PI*t_presva/t_bpolsa**2
    t_betap(2)=t_presva*t_volume*2/(t_plc**2*t_raxis*2*PI)
    t_betap(3)=t_betap(2)*t_raxis/s_rcntr
    t_ctroy=1.0e+02_rq*s_rbore*SQRT(bbb)*t_betae/abs(t_placur)
    t_absflx=t_psix*MU0/20
    t_flxln=t_dpsi0*MU0/20
    IF(.NOT.t_fix_bound) THEN
       CALL vltsec(t_vltsnd(1),0)
       t_vltsnd(2)=g_flxc(t_raxis,t_zaxis)*MU0/20
       t_vltsnd(3)=g_flxc(s_rcntr,t_zaxis)*MU0/20
       t_slfnd=1.e6_rq*abs(t_psires-t_vltsnd(1))/abs(t_placur)
       ! Get candidate strike-points (get rstkpt(1:nstkpts), etc.)
       CALL d_strkpl(t_pxpt)
       ! Distill strike-points (get rspt(1:nspt), etc.)
       CALL dstrkpl
    END IF
    t_li(3)=2.0e-12_rq*t_bpsqva*t_volume/MU0**2/t_placur**2/s_rcntr
    t_psires=psires_
    t_psisep= t_psil*MU0/20
    t_li(3)=2*abs((t_psires-t_psisep)/(MU0*0.01_rq*s_rcntr*t_placur))
    t_li(1)=t_bpsqva/t_bpolsa**2
    t_li(2)=t_li(3)*s_rcntr/t_raxis
    t_lam(1)=t_betap(1)+0.5_rq*t_li(1)
    t_lam(2)=t_betap(2)+0.5_rq*t_li(2)
    t_lam(3)=t_betap(3)+0.5_rq*t_li(3)
    t_aspct=s_rcntr/s_rbore
    hinas=1./t_aspct
    hh=(1.+1.81_rq*SQRT(hinas)+2.05_rq*hinas)*LOG(8/hinas)-(2+9.25_rq*&
         SQRT(hinas)-1.21_rq*hinas)
    hb=0.73_rq*SQRT(hinas)*(1+2*hinas**4-6*hinas**5+3.7_rq*hinas**6)
    hc=1+0.98_rq*hinas**2+0.49_rq*hinas**4+1.47_rq*hinas**6
    hd=0.25_rq*hinas*(1+0.84_rq*hinas-1.44_rq*hinas**2)
    hm=(1-hinas)**2/((1-hinas)**2*hc+hd*SQRT(t_e95))
    t_xlfnd=0.25_rq*(hm-1)*(log(8*t_aspct)+t_betap(3)+0.5_rq*t_li(3)-1.5_rq)
    t_xlfnd=1.e4_rq*MU0*s_rcntr*(hh*(1-hinas)/(1-hinas+hb*t_e95)+0.5_rq*&
         t_li(3)- t_xlfnd)
    t_qstar=2.5_rq*s_rbore**2*abs(t_frsrf(t_msrf)/s_rcntr/t_placur)*(1+&
    t_e95**2)/s_rcntr
    CALL get95
    IF(t_ipj>4 .AND. t_fix_bound) CALL vltsec(t_vltsnd(1),3)

  END SUBROUTINE diaginv

  SUBROUTINE get95
    REAL(rq) :: dd,dm,dp,sp,spp
    INTEGER :: l

    dd=t_m95/(1-t_thetac)
    DO l=2,t_msrf
       IF(t_psibar(l)>dd) EXIT
    END DO
    IF(l/=t_msrf+1) THEN
       l=l-1
       dp=t_psibar(l+1)-t_psibar(l)
       dm=t_psibar(l-1)-t_psibar(l)
       dd=dd-t_psibar(l)
       sp=((t_qsrf(l+1)-t_qsrf(l))*dm/dp-(t_qsrf(l-1)-t_qsrf(l))*dp/dm)/&
            (dm-dp)
       spp=-2*((t_qsrf(l+1)-t_qsrf(l))/dp-(t_qsrf(l-1)-t_qsrf(l))/dm)/&
            (dm-dp)
       t_q95=t_qsrf(l)+sp*dd+0.5_rq*spp*dd**2
       sp=((t_esrf(l+1)-t_esrf(l))*dm/dp-(t_esrf(l-1)-t_esrf(l))*dp/dm)/&
            (dm-dp)
       spp=-2*((t_esrf(l+1)-t_esrf(l))/dp-(t_esrf(l-1)-t_esrf(l))/dm)/&
            (dm-dp)
       t_e95=t_esrf(l)+sp*dd+0.5_rq*spp*dd**2
       sp=((t_tsrf(l+1)-t_tsrf(l))*dm/dp-(t_tsrf(l-1)-t_tsrf(l))*dp/dm)/&
            (dm-dp)
       spp=-2*((t_tsrf(l+1)-t_tsrf(l))/dp-(t_tsrf(l-1)-t_tsrf(l))/dm)/&
            (dm-dp)
       t_t95=t_tsrf(l)+sp*dd+0.5_rq*spp*dd**2
       sp=((t_tusrf(l+1)-t_tusrf(l))*dm/dp-(t_tusrf(l-1)-t_tusrf(l))*dp/&
            dm)/(dm-dp)
       spp=-2*((t_tusrf(l+1)-t_tusrf(l))/dp-(t_tusrf(l-1)-t_tusrf(l))/&
            dm)/(dm-dp)
       t_tu95=t_tusrf(l)+sp*dd+0.5_rq*spp*dd**2
       sp=((t_tlsrf(l+1)-t_tlsrf(l))*dm/dp-(t_tlsrf(l-1)-t_tlsrf(l))*dp/&
            dm)/(dm-dp)
       spp=-2*((t_tlsrf(l+1)-t_tlsrf(l))/dp-(t_tlsrf(l-1)-t_tlsrf(l))/&
            dm)/(dm-dp)
       t_tl95=t_tlsrf(l)+sp*dd+0.5_rq*spp*dd**2
       sp=((t_frsrf(l+1)-t_frsrf(l))*dm/dp-(t_frsrf(l-1)-t_frsrf(l))*dp/&
            dm)/(dm-dp)
       spp=-2*((t_frsrf(l+1)-t_frsrf(l))/dp-(t_frsrf(l-1)-t_frsrf(l))/&
            dm)/(dm-dp)
       t_f95=t_frsrf(l)+sp*dd+0.5_rq*spp*dd**2
    ELSE
       t_q95=t_qsrf(t_msrf)
       t_e95=t_esrf(t_msrf)
       t_t95=t_tsrf(t_msrf)
       t_tu95=t_tusrf(t_msrf)
       t_tl95=t_tlsrf(t_msrf)
       t_f95=t_frsrf(t_msrf)
    END IF
    t_elongn=t_esrf(t_msrf)
    t_trian=t_tsrf(t_msrf)
    t_trianu=t_tusrf(t_msrf)
    t_trianl=t_tlsrf(t_msrf)
  END SUBROUTINE get95

  SUBROUTINE Siden(n,l,f,fx,fxx,fxxx)
    INTEGER, INTENT(IN) :: n,l
    REAL(rq), INTENT(OUT) :: f,fx,fxx,fxxx
    INTEGER :: i,j
    !     Evaluate cubic coeffients on side:centered from splines.
    if(l.eq.1) then
       i=2;j=1
    else
       i=1;j=2
    endif
    fxxx=6*(i_cps(n,i,j)+i_cps(n+l,i,j))-12*(i_cps(n+l,1,1)-i_cps(n,1,1))
    fx=i_cps(n+l,1,1)-i_cps(n,1,1)-fxxx/24
    fxx=(i_cps(n+l,i,j)-i_cps(n,i,j))
    f=0.5_rq*(i_cps(n+l,1,1)+i_cps(n,1,1))-0.125_rq*fxx
  END SUBROUTINE Siden

  SUBROUTINE Newton(psill,dd,f,fx,fxx,fxxx)
    REAL(rq),  INTENT(IN) :: psill,f,fx,fxx,fxxx
    REAL(rq), INTENT(INOUT) :: dd
    REAL(rq) :: arg,argx,test
    INTEGER :: i
    DO i=1,nter_interp
       arg=psill-(f+dd*(fx+0.5_rq*dd*(fxx+dd/3*fxxx)))
       argx=fx+dd*(fxx+0.5_rq*dd*fxxx)
       test=ABS(arg/psill)
       IF(test < errt_rq) EXIT
       dd=dd+arg/argx
    END DO
  END SUBROUTINE Newton

  SUBROUTINE get_surfint
    INTEGER :: lst,l,ihl,ihu,m,n1
    REAL(rq) :: vprime,rhyp,r2bp2s
    n1=0
    IF(ALLOCATED(brs))THEN
       n1=SIZE(brs)
    END IF
    IF(n1/=t_mls) THEN
       IF(ALLOCATED(brs)) DEALLOCATE(brs,bzs,bps,bms,bts)
       ALLOCATE(brs(t_mls),bzs(t_mls),bps(t_mls),bms(t_mls),bts(t_mls))
    END IF
    n1=0
    IF(ALLOCATED(dq1))THEN
       n1=SIZE(dq1)
    END IF
    IF(n1/=t_mls) THEN
       IF(ALLOCATED(dq1))DEALLOCATE(dq1,dq2)
       ALLOCATE(dq1(t_mls),dq2(t_mls))
    END IF
    DO l=2,t_msrf
       t_rls=t_rlsd(:,l,1)
       t_zls=t_zlsd(:,l,1)
       brs=s_pin*t_rlsd(:,l,2)/t_zlsd(:,l,4)
       bzs=s_pin*t_zlsd(:,l,2)/t_zlsd(:,l,4)
       bps=t_rlsd(:,l,4)
       bts=t_frsrf(l)/t_rls
       bms=sqrt(bps**2+bts**2)
       dq2=s_pin*TWOPI/(t_mls-1)*t_zlsd(:,l,4)
       dq2(t_mls)=0
       IF(t_use_halo.AND.t_lhalo<t_msrf) then
          IF(t_lhsrf(l,1)/=0) then
             ihl=t_lhsrf(l,1)
             dq2(ihl)=dq2(ihl)*(t_thhsrf(l,1)-t_tswpts(ihl))/t_tswpts(2)
             ihu=t_lhsrf(l,2)
             dq2(ihu)=dq2(ihu)*(t_tswpts(ihu)-t_thhsrf(l,2))/t_tswpts(2)
             IF(ihu-ihl>1) dq2(ihl+1:ihu-1)=0
          END IF
       END IF

       vprime       = SUM(dq2)
       t_cusrf(l)   = SUM(dq2*bps**2)
       t_rsqbp(l)   = SUM(dq2/t_rls**2)
       t_rsqrf(l)   = SUM(dq2*t_rls**2)/vprime
       t_c4srf(l)   = SUM(dq2*t_rls*bps)
       rhyp         = SUM(dq2*t_rls**2*bps**2/bms**2)
       r2bp2s       = SUM(dq2*t_rls**2*bps**2)
       t_r4bp2rf(l) = SUM(dq2*t_rls**4*bps**2)/vprime
       t_r2bzrf(l)  = SUM(dq2*t_rls**2*bzs)/vprime
       t_alsrf(l)   = SUM(dq2*bps)
       t_risrf(l)   = SUM(dq2/t_rls)/vprime
       t_bpsrf(l)   = t_alsrf(l)/vprime
       t_bsqrf(l)   = (t_cusrf(l)+t_frsrf(l)**2*t_rsqbp(l))/vprime
       t_rsqirf(l)  = t_rsqbp(l)/vprime
       t_qsrf(l)    = t_frsrf(l)*t_rsqbp(l)/TWOPI
       t_vpsrf(l)   = TWOPI*vprime
       t_c1srf(l)   = t_frsrf(l)*t_rsqbp(l)/TWOPI*r2bp2s
       t_c5srf(l)   = rhyp/(r2bp2s+errt_rq)
       t_c5srf(l)   = t_c5srf(l)*t_bsqrf(l)-1

    END DO
    t_rsqirf(1)    = 1/t_raxis**2
    t_risrf(1)     = 1/t_raxis
    t_bsqrf(1)     = t_frsrf(1)**2/t_raxis**2
    t_bpsrf(1)     = 0
    t_c1srf(1)     = 0
    t_c4srf(1)     = 0
    t_c5srf(1)     = 0
    t_r4bp2rf(1)   = 0
    t_r2bzrf(1)    = 0
    t_cusrf(1)     = 0
    t_alsrf(1)     =0
    t_rsqrf(1)     = t_raxis**2
    t_qsrf(1)      = extrp(t_qsrf,t_psibar,t_msrf,0,0)
    t_vpsrf(1)     = extrp(t_vpsrf,t_psibar,t_msrf,0,0)
    t_rsqbp(1)     = extrp(t_rsqbp,t_psibar,t_msrf,0,0)
    IF(t_psil==t_pxpt) then
       t_qsrf(t_msrf)   = extrp(t_qsrf,t_psibar,t_msrf,1,0)
       t_rsqbp(t_msrf)  = extrp(t_rsqbp,t_psibar,t_msrf,1,0)
       t_vpsrf(t_msrf)  = extrp(t_vpsrf,t_psibar,t_msrf,1,0)
       t_rsqirf(t_msrf) = extrp(t_rsqirf,t_psibar,t_msrf,1,0)
       t_risrf(t_msrf)  = extrp(t_risrf,t_psibar,t_msrf,1,0)
       t_rsqrf(t_msrf)  = extrp(t_rsqrf,t_psibar,t_msrf,1,0)
    END IF
    t_vptor=t_vpsrf
    IF(t_ifluxcord<=0) t_vptor=abs(t_vptor/t_qsrf)
    call currentCentroid

  END SUBROUTINE get_surfint

  SUBROUTINE limw_from_plates
     REAL(rq), DIMENSION(t_nplates) :: splate,dplate
     REAL(rq), DIMENSION(t_lmax) :: slimw,dummy
     REAL(rq) :: yb
     INTEGER i

     yb=t_splbdry
     splate(1)=0
     dplate(1)=0
     dummy=-999
     dplate(2:)=SQRT((t_rplate(2:,1)-t_rplate(:t_nplates-1,1))**2+ &
       (t_zplate(2:,1)-t_zplate(:t_nplates-1,1))**2)
     DO i=2,t_nplates
       splate(i)=splate(i-1)+dplate(i)
     END DO
     slimw=(/(i,i=0,t_lmax-1)/)*splate(t_nplates)/(t_lmax-1)
     dplate=t_rplate(:,1)
     CALL interp_interp(splate,dplate,yb,yb,slimw,t_rlimw,dummy)
     dplate=t_zplate(:,1)
     CALL interp_interp(splate,dplate,yb,yb,slimw,t_zlimw,dummy)

   END SUBROUTINE limw_from_plates

   SUBROUTINE currentCentroid

     INTEGER :: l,m
    l=t_mls-1
    m=t_msrf
    t_rcur=SUM(t_zlsd(:l,m,4)*t_rlsd(:l,m,4)*t_rlsd(:l,m,1)**2)/&
         SUM(t_zlsd(:l,m,4)*t_rlsd(:l,m,4))
    IF(t_nsym==1) THEN
       t_zcur=0
    ELSE
       t_zcur=SUM(t_zlsd(:l,m,4)*t_rlsd(:l,m,4)*t_zlsd(:l,m,1))/&
         SUM(t_zlsd(:l,m,4)*t_rlsd(:l,m,4))
    END IF
    DO l=1,t_msrf
       IF(t_rcur<0) THEN
          CALL errdetec("bad Jacobian in get_surfint",1)
       END IF
    END DO
    IF(l==t_msrf+1) t_rcur=SQRT(t_rcur)

  END SUBROUTINE currentCentroid


END MODULE diag_mod
