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

MODULE gradsh_mod

  USE inv_mod
  USE teqGS_mod
  USE teqSubs_mod, only : svd_Invert,t_stretch

  IMPLICIT NONE

  REAL(rq), PRIVATE :: zgplc(0:4),fcr,fcz,fcrr,fczz,rsk(2),rump,zump,gamm,&
       zpl
  INTEGER,  PRIVATE :: lfbd,ngrup,jsvd,jbd,jbdrl,jbdr,jbdz,jbdvltf,jbdaxis,&
       npdesol,kim,nsvd,lsvd,ibcntrl,msvd,jbig,jbdxr,jbdxz
  INTEGER,  DIMENSION(:), ALLOCATABLE, PRIVATE :: jlim
  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE :: evec,rvec,dvec,zvec,onec,&
       psia,psib,zsvd,vbcp,rcls,zcls,psir,rlo,rup,rdi,bda,bdb,bdc,bdd
  REAL(rq), DIMENSION(:,:), ALLOCATABLE, PRIVATE :: gmatfbd,wk,umat,psiv,&
       asvd,pfbd
  REAL(rq), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: gmat
  REAL(rq), DIMENSION(:,:), ALLOCATABLE :: amat,bmat
  REAL(rq), DIMENSION(:), ALLOCATABLE :: avec
  REAL(rq) :: x_l,a_ll,s_l,d_l,q_l,a_lmax,a_ln
  DATA lsvd/0/,ibcntrl/0/

CONTAINS
  
  SUBROUTINE gs_bndpsi(kalc)
    !
    !     Compute a new boundary condition given a current
    !     density, crj, on the 2d mesh, and compute the error, resb.
    !

    REAL(rq) :: bnrm,cof,ww(t_jm,t_km0p)
    INTEGER kalc,na,kb,jb,nbu,n,kl,k,j,lb,jko
    SAVE jko
    IF(jko/=2*(t_jm+t_km)) THEN
       IF(jko/=0) DEALLOCATE(psia,psib)
       jko=2*(t_jm+t_km)
       ALLOCATE(psia(jko),psib(jko))
    END IF
    IF(t_int_flag<=0) THEN
       wk(:,1)=t_psiw
       wk(:,2)=t_psi
    ELSE
       wk(:,1)=0
       wk(:,2)=t_psi-t_psiw
    END IF
    t_resb=0.
    bnrm=0.
    cof=-t_dr*t_dz/FOURPI
    IF(kalc==0) return
    IF(t_nsym==2) THEN
       na=1
       DO kb=1,t_km
          DO jb=1,t_jm
             lb=(jb-1)*(jb-t_jm)*(kb-1)*(kb-t_km)
             IF(lb==0) THEN
                nbu=(kb-1)*t_jm+jb
                psia(na)=wk(nbu,2)
                IF(t_kgreenc==1) THEN ! used stored value
                   ww=t_gp(:,:,na)
                   psib(na)=cof*sumxpy(ww,t_crj,t_jmkm)+wk(nbu,1)
                ELSE
                   psib(na)=g_flxp(t_r(jb),t_z(kb))+wk(nbu,1)
                END IF
                bnrm=bnrm+abs(psib(na))
                t_resb=t_resb+abs(psib(na)-psia(na))
                wk(nbu,2)=gamm*psia(na)+(1.-gamm)*psib(na)
                na=na+1
             END IF
          END DO
       END DO
    ELSE
       !     
       !     symmetric about t_z=0 case
       !
       kl=t_km/2+1
       IF(kalc==0) return
       na=1
       DO kb=kl,t_km
          DO jb=1,t_jm
             lb=(jb-1)*(jb-t_jm)*(kb-1)*(kb-t_km)
             IF(lb==0) THEN
                nbu=(kb-1)*t_jm+jb
                psia(na)=wk(nbu,2)
                IF(t_kgreenc==1) THEN ! used stored values
                   ww(:,:)=t_gp(:,:,na)
                   psib(na)=cof*sumxpy(ww,t_crj,t_jm*kl)+wk(nbu,1)
                ELSE
                   psib(na)=g_flxp(t_r(jb),t_z(kb))+wk(nbu,1)
                END IF
                bnrm=bnrm+abs(psib(na))
                t_resb=t_resb+abs(psib(na)-psia(na))
                wk(nbu,2)=gamm*psia(na)+(1.-gamm)*psib(na)
                na=na+1
             END IF
          END DO
       END DO
       psiv=RESHAPE(wk(:,2),(/t_jm,t_km/))
       DO k=1,kl-1
          DO j=1,t_jm
             psiv(j,k)=psiv(j,t_km+1-k)
          END DO
       END DO
       wk(:,2)=RESHAPE(psiv,(/t_jmkm/))
    END IF ! symmetry

    IF(t_int_flag<=0) THEN
       t_psi=wk(:,2)
    ELSE
       t_psi=wk(:,2)+t_psiw
    END IF
    IF(bnrm==0)CALL errdetec("Fatal: bnrm = 0 in bndpsi",1)
    t_resb=t_resb/bnrm
  END SUBROUTINE gs_bndpsi

  SUBROUTINE gs_clcalc
    REAL(rq) :: a2,dr1,dr2,dz1,dz2
    INTEGER n,nn,j,k,kstart,klower,nlower
    t_clj=0
    IF(t_int_flag==1) RETURN
    DO nn=1,t_ncf
       IF(t_intc(nn)==1) THEN
          a2 = t_dr*t_dz
          j = t_jnt(nn)
          k = t_knt(nn)
          n = (k - 1)*t_jm + j
          dr1 = t_rcf(nn) - t_r(j)
          dr2 = t_r(j + 1) - t_rcf(nn)
          dz1 = t_zcf(nn) - t_z(k)
          dz2 = t_z(k + 1) - t_zcf(nn)
          t_clj(n) = t_clj(n) + t_ccf(nn)*t_r(j)*dr2*dz2/a2
          t_clj(n + 1) = t_clj(n + 1) + t_ccf(nn)*t_r(j + 1)*dr1*dz2/a2
          t_clj(n + t_jm) = t_clj(n + t_jm) + t_ccf(nn)*t_r(j)*dr2*dz1/a2
          t_clj(n + t_jm + 1) = t_clj(n + t_jm + 1) + t_ccf(nn)*t_r(j + 1)*&
               dr1*dz1/a2
       END IF
    END DO
    t_clj=-t_clj*FOURPI*1.0e+05_rq/t_dr/t_dz
    IF(t_nsym>=2) RETURN
    kstart = t_km/2 + 2
    DO k=kstart,t_km
       DO j=1,t_jm
          klower = t_km - k + 1
          nlower = (klower - 1)*t_jm + j
          n = (k - 1)*t_jm + j
          t_clj(nlower) = t_clj(n)
       END DO
    END DO
  END SUBROUTINE gs_clcalc

  SUBROUTINE gs_curcal(ncal)
    !
    !     compute delta-I/I for variable-current coils ( ic(j) not 0 ).
    !     constraints controlled by nbd,rbd,zbd, vltf,rl,cejima,ifxc.
    !     minimization options controlled by ircwt
    !
    INTEGER, INTENT(INOUT) :: ncal
    REAL(rq) :: pds(8),ff,vlts,aaa,fcrz
    INTEGER j,jrwct,n,i,k,isw,l,nn,jer,kk,nloo,l0,l1,ier,n1
    include "debug.i"

    ier=0
    n1=0
    IF(ALLOCATED(evec)) THEN
       n1=SIZE(evec)
    END IF
    IF(n1/=t_nc) THEN
       IF(ALLOCATED(evec)) DEALLOCATE(evec,rvec,dvec,zvec,onec,vbcp,rcls,zcls)
       ALLOCATE(evec(t_nc),rvec(0:t_nc),dvec(t_nc),zvec(0:t_nc),onec(0:t_nc),&
            vbcp(t_nc),rcls(t_nc),zcls(t_nc))
       vbcp = 0.0_rq ! Temporary fix, LDP will fix properly later. JAC 05/19/05
    END IF
    rcls=t_rc*100;zcls=t_zc*100
    n1=0
    IF(ALLOCATED(pfbd)) THEN
       n1=SIZE(pfbd,1)
    END IF
    IF(n1/=t_nfbd .AND. t_nfbd/=0) THEN
       IF(ALLOCATED(pfbd)) DEALLOCATE(pfbd)
       ALLOCATE(pfbd(t_nfbd,8))
    END IF
    n1=0
    IF(ALLOCATED(gmat)) THEN
       n1=SIZE(gmat,1)
    END IF
    IF(t_ngroup/=0 .AND. n1/=t_ngroup) THEN
       IF(ALLOCATED(gmat)) DEALLOCATE(gmat)
       ALLOCATE(gmat(t_ngroup,t_ngroup,5))
    END IF
    n1=0
    IF(ALLOCATED(gmatfbd)) THEN
       n1=SIZE(gmatfbd,1)*SIZE(gmatfbd,2)
    END IF
    IF(n1/=t_nfbd*t_ngroup .AND. t_nfbd*t_ngroup/=0) THEN
       IF(ALLOCATED(gmatfbd)) DEALLOCATE(gmatfbd)
       ALLOCATE(gmatfbd(t_nfbd,t_ngroup))
    END IF
    n1=0
    IF(ALLOCATED(umat)) THEN
       n1=SIZE(umat,1)*SIZE(umat,2)
    END IF
    IF(n1/=(t_nc+1)*(t_ngroup+2) .AND. t_ngroup/=0) THEN
       IF(ALLOCATED(umat)) DEALLOCATE(umat)
       ALLOCATE(umat(0:t_nc,0:t_ngroup+1))
    END IF
    n1=0
    IF(ALLOCATED(jlim)) THEN
       n1=SIZE(jlim)
    END IF
    IF(n1/=t_nlim .AND. t_nlim/=0) THEN
       IF(ALLOCATED(jlim)) DEALLOCATE(jlim)
       ALLOCATE(jlim(t_nlim))
    END IF
    DO j=1-iABS(t_lsph),t_nsph
       zgplc(j)=t_gplc(j)
    END DO

    jrwct=0
    t_ccls=0
    onec=0
    rvec=0
    zvec=0
    dvec=0
    lfbd=0
    ngrup=t_ngroup
    IF(t_ircwt==9) ngrup=t_ngroup-t_nsph-iabs(t_lsph)
    DO n=1,t_nfbd
       IF(t_alfbd(n)/=0) THEN
	  lfbd=1
          EXIT
       END IF
    END DO
    DO j=1,t_nc
       IF(t_ict(j)==0) THEN
          t_ccls(t_ic(j))=t_ccls(t_ic(j))+t_cc(j) ! parallel
       ELSE
          t_ccls(t_ic(j))=t_cc(j) ! series
       END IF
    END DO
    IF(t_ircwt>5 .AND. t_ircwt/=7 .OR. t_iflxc==1) THEN
       IF(t_ipj<10) THEN
          CALL vltsec(vlts,3)
       ELSE
          t_pfpsi=t_pfse
       END IF
       DO i=1,t_nc
          zvec(t_ic(i))=zvec(t_ic(i))+t_pfpsi(i)*t_cc(i)/t_ccls(t_ic(i))
       END DO
       DO i=1,t_nc
          t_pfpci(t_ic(i))=zvec(t_ic(i))
       END DO
       onec(1:)=t_pfpsi-t_pfps0
       dvec=t_dt*t_thetat*t_rxc
       evec=onec(1:)+dvec*t_cc+t_dt*(1-t_thetat)*t_rxc*t_cc0
       onec(1:)=onec(1:)*t_cc
       zvec=0
       IF(t_ircwt==10 .OR. t_ircwt==9 .OR. t_ircwt==8) THEN
          WHERE(t_iloop==1)
             t_gloop=(t_floop(:,1)-t_floop0)/t_sigloop
          ELSEWHERE
             t_gloop=(sin(t_thloop)*t_floop(:,2)-cos(t_thloop)*t_floop(:,3)-&
                  t_floop0)/t_sigloop
          ENDWHERE
          onec(1:t_nloop)=t_gloop
          IF(t_lsph==1) onec(t_nloop+1)=1.e-6_rq*(t_fgun-t_f_gun0)
          IF(t_deltad/=1.0) THEN
             DO k=1-iabs(t_lsph),t_nsph ! update from prsx and flux change
                WHERE(t_iloop==1)
                   t_splw(:,k)=-t_deltad*t_gplw(:,k,1)/t_sigloop+(1.0_rq-&
                        t_deltad)*t_splw(:,k)
                ELSEWHERE
                   t_splw(:,k)=-t_deltad*(sin(t_thloop)*t_gplw(:,k,2)-&
                        cos(t_thloop)*t_gplw(:,k,3))+(1.0_rq-t_deltad)*&
                        t_splw(:,k)
                ENDWHERE
             END DO
          END IF
       END IF
    END IF
    ! set up refrence point for nbd or t_nfbd
    IF(s_limiterd==0) THEN
       !BUG? IF theta ne 0, don't you want t_r,t_z at t_psi=psil?, ie, make
       ! rbd,zbd's define the p=0 surface, not the xpt surface?
       !At any rate beware: thetac /=0--> t_psi(rbd,zbd) /= psil=t_psi(rls,zls)
       IF(t_ixpt/=3) THEN
          fcr = t_rxpt
          fcz = t_zxpt
       ELSE
          fcr = s_rcntr-s_rbore;   fcz = t_zaxis
       END IF
       IF(t_ixpt==4) fcrz=t_psil
       IF(t_ixpt==5) fcrz=t_psix+t_dpsi00
    ELSE
       fcr = t_rlim(0)
       fcz = t_zlim(0)
    END IF
    CALL boxd_interp(fcr,fcz,pds,ier,t_n4)
    fcrz =pds(1)
    IF(t_ixpt==4) fcrz=t_psil
    IF(t_ixpt==5) fcrz=t_psix+t_dpsi00
    ! end setup of reference points
    IF(t_iflxc==1 .AND. t_dt/=0) THEN !  feedback on vertical stability
       IF(ibcntrl==1)THEN     ! shape control                           !4.96
          CALL bcontrol(t_dt) ! time advanced in transStep; need arg/=0 !5.96
          DO i=1,t_ncplot                                               !5.94
             evec(i)=evec(i)-t_dt*t_thetat*vbcp(i)*t_cc(i)              !5.94
          END DO                                                        !5.94
          IF(t_nsymc == 1 .AND. t_ncplot /= t_nc)THEN                   !5.94
             DO i=1,t_ncplot                                            !9.94
                evec(t_nc/2+i)=evec(i)                                  !9.94
             END DO                                                     !9.94
          END IF                                                        !9.94
       END IF
       IF(t_nfbc>0) THEN
          IF(t_nmsc/=1) THEN
             ier=3
             isw=0
             CALL boxm_interp(t_rloop,t_zloop,t_ploop,i_r,i_z,i_cps,isw,ier,&
                  t_n4)
             nloo=0
             DO l=1,t_nloop
                IF(t_iloop(l)==4) THEN
                   t_gloop(l)=-s_pin*(t_ploop(l,1)-t_pxpt)/&
                        sqrt(t_ploop(l,2)**2+t_ploop(l,3)**2)*1.e-2_rq
                   t_floop(l,1)=TWOPI*1.0e-08_rq*t_ploop(l,1)
                   t_floop(l,2)=-t_ploop(l,3)/t_rloop(l) ! br
                   t_floop(l,3)=t_ploop(l,2)/t_rloop(l)  ! bz
                   nloo=nloo+1
                ELSEIF(t_iloop(l)==6) THEN
                   t_gloop(l)=-t_plc*1.e-5_rq
                ELSEIF(t_iloop(l)==7) THEN
                   t_gloop(l)=-t_ccls(t_ic(l-nloo))
                ELSEIF(t_iloop(l)==t_nloop) THEN
                   t_gloop(l)=t_zaxis*1.e-2_rq !if zcur wanted in circuits.bas
                END IF
             END DO
          END IF
       END IF
    END IF
    IF(ncal/=-1) THEN
       CALL gs_curmat1
    END IF
    gmat(:,:,4)=0
    jbd=t_nbd
    jbdrl=0
    jbdr=0
    jbdz=0
    jbdxr=0
    jbdxz=0
    jbdvltf=0
    jbdaxis=0
    zpl=1.e8_rq/TWOPI
    IF(t_plcx/=0) THEN
       jbd=jbd+1
       jbdaxis=jbd
       rvec(jbd)=(t_psix-t_plcx)
       ncal=1
    ELSEIF(t_cejima==0 .AND. t_vltf/=0.0) THEN !     VS=t_vltf
       jbd=jbd+1
       jbdvltf=jbd
       IF(t_iflxc/=1 .AND. t_ircwt/=6 .AND. t_ircwt/=7) CALL vltsec(vlts,1)
       rvec(jbd)=(vlts-t_vltf)*zpl
    ELSEIF(t_cejima/=0.0 .AND. t_vltf/=0.0) THEN !    Ejima formula
       jbd=jbd+1
       jbdvltf=jbd
       CALL vltsec(vlts,2)
       rvec(jbd)=(t_psires-t_vltf+FOURPI*t_cejima*t_plcm*s_rcntr/1000)*zpl
       ncal=1
    END IF
    IF(t_jaxis/=0 .OR. t_kaxis/=0) THEN
       ier=3
       CALL boxd_interp(t_raxis0,t_zaxis0,pds,ier,t_n4)
       ier=1
       jbd=jbd+1
       jbdr=jbd
       rvec(jbd)=-pds(3)*t_raxis0
       jbd=jbd+1
       jbdz=jbd
       rvec(jbd)= pds(2)*t_raxis0
    END IF
    IF(t_jxp/=0 .OR. t_kxp/=0) THEN
       ier=3
       CALL boxd_interp(t_rxpt0,t_zxpt0,pds,ier,t_n4)
       ier=1
       jbd=jbd+1
       jbdxr=jbd
       rvec(jbd)=-pds(3)*t_rxpt0
       jbd=jbd+1
       jbdxz=jbd
       rvec(jbd)= pds(2)*t_rxpt0
    END IF
    IF(t_nlim/=0) THEN          !  holds point to be on scrapeoff layer
       DO nn=1,t_nlim
          jbd=jbd+1
          jlim(nn)=jbd
          ier=1
          CALL boxd_interp(t_rlim(nn),t_zlim(nn),pds,ier,t_n4)
          rvec(jbd)=pds(1)
          IF(t_dlim(nn)>=0) THEN
             rsk(nn)=s_rcntr+s_rbore+t_dlim(nn)
          ELSE
             rsk(nn)=s_rcntr-s_rbore+t_dlim(nn)
          END IF
          ier=1
          CALL boxd_interp(rsk(nn),t_zaxis,pds,ier,t_n4)
          rvec(jbd)=rvec(jbd)-pds(1)
       END DO
    END IF
    IF(t_rl/=0 .AND. t_nsymc==2) THEN
       jbd=jbd+1
       jbdrl=jbd
       IF(t_irl>0) THEN
          !--- distance between separatrices equal to t_rl, upper Xpt inactive
          IF(t_rl>0) THEN
             rump=s_rcntr+s_rbore+t_rl
          ELSEIF(t_rl<0) THEN
             rump=s_rcntr-s_rbore+t_rl
          END IF
          zump=t_zaxis
          ier=1
          CALL boxd_interp(rump,zump,pds,ier,t_n4)
          ff=pds(1)
          ier=1
          fcrr=s_rxpu
          fczz=s_zxpu
          CALL boxd_interp(fcrr,fczz,pds,ier,t_n4)
          rvec(jbd)=ff-pds(1)
       ELSEIF(t_irl<0) THEN
          !--- distance between separatrices equal to t_rl, lower Xpt inactive
          IF(t_rl>0) THEN
             rump=s_rcntr+s_rbore+t_rl
          ELSEIF(t_rl<0) THEN
             rump=s_rcntr-s_rbore+t_rl
          END IF
          zump=t_zaxis
          ier=1
          CALL boxd_interp(rump,zump,pds,ier,t_n4)
          ff=pds(1)
          ier=1
          fcrr=s_rxpl
          fczz=s_zxpl
          CALL boxd_interp(fcrr,fczz,pds,ier,t_n4)
          rvec(jbd)=ff-pds(1)
       ELSEIF(t_irl==0) THEN
          rump=s_rxpu
          zump=s_zxpu
          ier=1
          CALL boxd_interp(rump,zump,pds,ier,t_n4)
          ff=pds(1)
          fcrr=s_rxpl
          fczz=s_zxpl
          ier=1
          CALL boxd_interp(fcrr,fczz,pds,ier,t_n4)
          rvec(jbd)=ff-pds(1)-(t_psil-t_psix)*t_rl
       END IF
    END IF
    
    ! --- Finish calculation of constraints
    t_jbdcir=jbd
    IF(t_iflxc==1) THEN
       t_jbdcir=t_ncircuit+jbd
    ELSE
       ! t_ncircuit=t_jbdcir LDP 2003/03/08 Cannot imagine why this 
       ! was ever done but will have to watch this.
    END IF
    jbig=0
    IF(t_ircwt==10 .AND. t_nloop<=t_ngroup .AND. t_almim==0) THEN
       jbig=t_jbdcir+t_ngroup
       IF(SIZE(avec)/=jbig) THEN
          IF(ALLOCATED(avec)) DEALLOCATE(avec,amat,bmat)
          ALLOCATE(avec(jbig),amat(jbig,jbig),bmat(jbig,jbig))
          amat=0;avec=0;bmat=0
       END IF
    END IF
    jsvd=0
    IF(lfbd==1) THEN
       jsvd=0 !   use rmInvert and standard logic
    ELSEIF((t_almim==0 .AND. t_ncircuit/=0) .AND. ((t_ircwt==6 .AND. &
         t_ncircuit/=t_ngroup) .OR. t_ircwt==-1 .OR. t_ircwt==9)) THEN
       jsvd=1 ! use SVD or rmInvert IF lsvd=0 for full matrix with multipliers
    ELSE
       jsvd=0 ! use rmInvert and standard logic
    END IF
    IF(t_jbdcir==0) THEN ! will minimize with no constraints
       IF(ncal==-1) go to 400
       go to 100
    END IF
    ier=1
    jer=1
    DO i=1,t_nbd
       ier=jer
       CALL boxd_interp (t_rbd(i),t_zbd(i),pds,ier,t_n4)
       t_psibd(i)=pds(1)
       rvec(i)=t_psibd(i)-fcrz
    END DO
    ! LDP for t_ircwt
    DO i=1,jbd
       rvec(i)=rvec(i)/zpl
    END DO
    !
    IF(t_iflxc==1) THEN
       zvec=0
       DO i=1,t_nc
          zvec(t_ic(i))=zvec(t_ic(i))+t_cc(i)*evec(i)
       END DO
       zvec(1:ngrup)=zvec(1:ngrup)/t_ccls(1:ngrup)
       DO n=1,t_nc
          rvec(t_ix(n))=zvec(t_ic(n))
       END DO

       IF(t_ircwt==9 .AND. t_lsph==-1) THEN
          rvec(t_ncircuit)=(1.e-5_rq*t_plc-t_plcm)
       END IF

       IF(t_dt/=0 .AND. ncal/=-1) THEN  !  green's functions for IR

          umat=0
          zvec=0
          DO i=1,t_nc
             zvec(t_ic(i))=zvec(t_ic(i))-dvec(i)*t_cc(i)**2
          END DO
          DO i=1,ngrup
             umat(i,i)=umat(i,i)+zvec(i)*zpl/t_ccls(i)**2
          END DO
          DO i=1,ngrup
             DO n=1,t_nc
                zvec(t_ix(n))=umat(t_ic(n),i)
             END DO
             DO j=1,t_jbdcir
                gmat(j,i,4)=gmat(j,i,4)+zvec(j)
             END DO
          END DO

       END IF
    END IF
    !
    IF(ncal==-1)  THEN
       IF(t_jbdcir==t_ngroup .AND. t_ircwt/=9) THEN ! nothing to minimize
          jrwct=1
          onec(1:t_jbdcir)=0
          dvec(:t_jbdcir)=rvec(1:t_jbdcir)
          go to 300
       ELSE
          go to 400                        ! something to minimize
       END IF
    END IF

    CALL gs_calcMatrices

    IF(t_jbdcir==t_ngroup) THEN   !  nothing to minimize
       jrwct=1
       onec(1:t_jbdcir)=0
       dvec(:t_jbdcir)=rvec(1:t_jbdcir)
       go to 200
    END IF
!-----------------
100 continue
    CALL gs_curmat3
400 continue
    IF(t_ircwt<=5) THEN
       zvec=0
       IF(t_ircwt==1) THEN
          DO i=1,t_nc
             zvec(t_ic(i))=zvec(t_ic(i))+(t_cc(i)-t_cc0(i))*t_cc(i)
          END DO
          zvec(1:t_ngroup)=zvec(1:t_ngroup)/t_ccls(1:t_ngroup)
       ELSE
          zvec(1:t_ngroup)=t_ccls(1:t_ngroup)
       END IF
       DO i=1,t_ngroup
          onec(i)=SUM(umat(i,1:t_ngroup)*zvec(1:t_ngroup))
       END DO
    ELSEIF(t_ircwt==6) THEN
       zvec=0
       DO i=1,t_nc
          zvec(t_ic(i))=zvec(t_ic(i))+onec(i)
       END DO
       DO i=1,t_ngroup
          onec(i)=SUM(umat(1:t_ngroup,i)*zvec(1:t_ngroup)/t_ccls(1:t_ngroup))
       END DO
    ELSEIF(t_ircwt==7) THEN     ! total PF energy
       zvec=0
       DO i=1,t_nc
          zvec(t_ic(i))=zvec(t_ic(i))+onec(i)
       END DO
       DO i=1,t_ngroup
          onec(i)=0.5_rq*(SUM(umat(i,1:t_ngroup)*t_ccls(1:t_ngroup))+zvec(i)/&
               t_ccls(i))
       END DO
    ELSEIF(t_ircwt==10 .OR. t_ircwt==9 .OR. t_ircwt==8) THEN
       DO i=1,ngrup
          zvec(i)=SUM(umat(1:t_nloop,i)*onec(1:t_nloop))
       END DO
       DO k=1-iabs(t_lsph),t_nsph
          kk=k+ngrup+iabs(t_lsph)
          nloo=t_nloop
          IF(t_lsph==1) nloo=nloo+1
          zvec(kk)=SUM(t_splw(:nloo,k)*onec(1:nloo))
       END DO
       DO i=1,t_ngroup
          onec(i)=zvec(i)
       END DO
       IF(jbig/=0) avec(1:t_ngroup)=-onec(1:t_ngroup)
    END IF
    IF(lfbd/=0) THEN
       ier=3
       isw=0
       CALL boxm_interp(t_rfbd,t_zfbd,pfbd,i_r,i_z,i_cps,isw,ier,t_n4)
       DO i=1,ngrup
          onec(i)=onec(i)+(SUM(pfbd(:,1)*t_alfbd(:t_nfbd)*gmatfbd(:,i))-fcrz*&
               SUM(t_alfbd(:t_nfbd)*gmatfbd(:,i)))/zpl
       END DO
    END IF
    IF(t_jbdcir/=0 .AND. t_almim/=0) THEN
       DO i=1,t_ngroup
          onec(i)=onec(i)-t_almim*SUM(gmat(:t_jbdcir,i,1)*rvec(1:t_jbdcir))
       END DO
    END IF
    !     IF(t_ircwt==9 .AND. t_dt==0) THEN
    !     skip
    IF(jsvd==1 .OR. t_ircwt==8) THEN
       !     skip
    ELSE
       DO i=1,t_ngroup
          zvec(i)=SUM(gmat(i,:,3)*onec(1:t_ngroup))
       END DO
       onec(1:t_ngroup)=zvec(1:t_ngroup)
    END IF
    !    end of minimization
    IF(t_jbdcir==0)THEN
       zvec=0
       go to 101               ! nothing to constrain
    END IF
    !
    IF(jbig==0) THEN
       DO i=1,t_jbdcir
          dvec(i)=SUM(gmat(i,:,1)*onec(1:t_ngroup))+rvec(i)
       END DO
    ELSE
       avec(t_ngroup+1:jbig)=+rvec(1:t_jbdcir)
    END IF

    IF(ncal==-1) go to 300

    !---Now calculate matrix to invert for constraint
    IF(jbig/=0) THEN
       bmat=amat
!       CALL rmInvert(bmat,jbig,jbig)
       CALL svd_Invert(bmat)
    ELSE
       DO i=1,t_ngroup
          IF(t_ircwt>=4 .OR. lfbd/=0) THEN
             DO j=1,t_jbdcir
                gmat(i,j,5)=SUM(gmat(i,:,3)*gmat(j,:,1))
             END DO
          ELSE
             DO j=1,t_jbdcir
                gmat(i,j,5)=gmat(i,i,3)*gmat(j,i,1)
             END DO
          END IF
       END DO
       DO i=1,t_jbdcir
          DO j=1,t_jbdcir
             gmat(i,j,2)=SUM(gmat(i,:,1)*gmat(:,j,5))
          END DO
       END DO
       !     invert matrix to solve gmat(,,2)*zvec=dvec
    END IF
200 continue
    IF(jsvd==1) THEN
       !       CALL parsestr("new_min(2)")
       DO i=1,t_ncircuit
          asvd(t_ngroup+i,:t_ngroup)=-gmat(i,:t_ngroup,1)
          asvd(:t_ngroup,t_ngroup+i)=-gmat(i,:t_ngroup,1)
       END DO
       IF(lsvd==0) THEN
          CALL rmInvert(asvd,msvd,nsvd)
       ELSE
          CALL svd_Invert(asvd)
       END IF
    ELSEIF(t_ircwt==8) THEN
       !       CALL parsestr("svd_(2)")
    ELSEIF(jbig==0) then
       CALL rmInvert(gmat(1,1,2),t_ngroup,t_jbdcir)
    END IF
300 continue
    IF(jsvd==1 .OR. t_ircwt==8) go to 101
    DO i=1,t_jbdcir
       zvec(i)=SUM(gmat(i,:t_jbdcir,2)*dvec(:t_jbdcir))
    END DO
    IF(jrwct==0) THEN
       DO j=1,t_ngroup
          dvec(j)=SUM(gmat(j,:t_jbdcir,5)*zvec(1:t_jbdcir))
       END DO
       zvec(1:)=dvec
    END IF
101 continue
    IF(jsvd==1) THEN
       nsvd=t_ngroup+t_ncircuit
       msvd=nsvd
       IF(SIZE(zsvd)/=nsvd) THEN
          IF(SIZE(zsvd)>1) DEALLOCATE(asvd,zsvd)
          ALLOCATE(asvd(nsvd,nsvd),zsvd(nsvd))
       END IF
       zsvd(:t_ngroup)=-onec(1:t_ngroup)
       zsvd(t_ngroup+1:t_ncircuit+t_ngroup)=-rvec(1:t_ncircuit)
       DO i=1,t_ngroup
          zvec(i)=SUM(asvd(i,:)*zsvd)
       END DO
    ELSEIF(t_ircwt==8) THEN
       !       CALL parsestr("new_min(3)")
       !       CALL parsestr("svd_(3)")
    ELSEIF(jbig==0) then
       zvec(1:ngrup)=-onec(1:ngrup)+zvec(1:ngrup)
    ELSE
       DO i=1,ngrup
          zvec(i)=SUM(bmat(i,:)*avec)
       END DO
    END IF
    dvec=t_cc
    IF( ncal==0 ) RETURN
    zvec(1:ngrup)=zvec(1:ngrup)*(1-t_alpcoil)
    IF(t_ircwt==9) THEN
       zvec(ngrup+1:t_ngroup)=zvec(ngrup+1:t_ngroup)*(1-t_alpsph)
       DO k=1,t_nsph
          kk=k+ngrup+iabs(t_lsph)
          t_asph(k)=t_asph(k)+zvec(kk)
       END DO
       IF(t_lsph/=0) THEN
          aaa=1+zvec(ngrup+1)
          IF(iabs(t_ipf)==8) THEN
             t_prsx=t_prsx*aaa
          ELSE
             t_prsx=t_prsx*aaa**2
          END IF
          DO k=1,4
             t_asph(k)=t_asph(k)/aaa
          END DO
       END IF
    END IF
    DO n=1,t_nc
       IF(t_ic(n)/=0)t_cc(n)=t_cc(n)*(1+zvec(t_ic(n))/t_ccls(t_ic(n)))
    END DO
    t_ccls(1:ngrup)=t_ccls(1:ngrup)+zvec(1:ngrup)

    IF(t_magfac /= 0.)THEN 
       DO i=1,t_ncf
          t_ccfd(i)=t_ccf(i)-t_ccmf(i) ! save filament current
       END DO
       CALL gs_curmag  ! compute magnetization current
       DO i=1,t_ncf   ! reset filements to driven current
          t_ccf(i)=t_ccfd(i)
       END DO
    END IF  ! t_magfac/=0
    l0=1
    DO n=1,t_nc ! set filaments
       ff=t_cc(n)/dvec(n)
       DO l=l0,t_loop0(n)
          t_ccf(l)=t_ccf(l)*ff
       END DO
       l0=t_loop0(n)+1
    END DO
    IF(t_magfac /= 0.) THEN     ! add magnetization
       DO i=1,t_ncf
          t_ccf(i)=t_ccf(i)+t_ccmf(i)
       END DO
    END IF  ! t_magfac/=0
    t_psi=t_psi-t_psiw
    CALL gs_psiext
    t_psi=t_psi+t_psiw
    ncal=-1                   !  don't recalculate inverse
  END SUBROUTINE gs_curcal

  SUBROUTINE gs_curmat1
    REAL(rq) ::  ff_(t_nc),fbr_(t_nc),fbz_(t_nc),rmt
    INTEGER inum,izpt,n_,i,j,n,ii
    ! Matrices(Greens's functions) for fuzzy boundary points and flux at coils
    inum=0
    umat=0
    IF(lfbd/=0) THEN
       rmt=TWOPI*1.0e-03_rq
       CALL mutual_utils(rcls,zcls,fcr,fcz,ff_,fbr_,fbz_,inum)
       rvec(1:)=ff_
       IF(t_ixpt>=4 .AND. s_limiterd==0) THEN
          CALL mutual_utils(rcls,zcls,t_raxis,t_zaxis,ff_,fbr_,fbz_,inum)
          IF(t_ixpt==5) THEN
             rvec(1:)=ff_
          ELSEIF(t_ixpt==4) THEN
             rvec(1:)=t_theta*ff_+(1-t_theta)*rvec(1:)
          END IF
       END IF

       DO i=1,t_nfbd
          zvec=0
          CALL mutual_utils(rcls,zcls,t_rfbd(i),t_zfbd(i),ff_,fbr_,fbz_,inum)
          DO j=1,t_nc
             zvec(t_ic(j))=zvec(t_ic(j))+rmt*(ff_(j)-rvec(j))*t_cc(j)
          END DO
          DO n=1,ngrup
             gmatfbd(i,n)=zvec(n)/t_ccls(n)
          END DO
       END DO
       zvec=0
    END IF
    IF(t_iflxc==1) THEN
       DO i=1,t_nc
          DO j=1,t_nc
             umat(t_ic(i),t_ic(j))=umat(t_ic(i),t_ic(j))+t_cc(i)*t_pfim(i,j)*&
                  t_cc(j)
          END DO
       END DO
       DO i=1,ngrup
          umat(i,1:ngrup)=umat(i,1:ngrup)/t_ccls(i)/t_ccls(1:ngrup)
       END DO
       DO j=1,ngrup
          DO n=1,t_nc
             zvec(t_ix(n))=umat(t_ic(n),j)
          END DO
          DO i=1,t_ncircuit
             gmat(i,j,2)=zvec(i)
          END DO
       END DO
       IF(t_ircwt==9) THEN
          DO i=1-iabs(t_lsph),t_nsph
             ii=i+ngrup+iabs(t_lsph)
             zvec=0
             DO n=1,t_nc
                zvec(t_ix(n))=zvec(t_ix(n))-t_cc(n)*t_gcw(n,i)/t_ccls(t_ic(n))
             END DO
             DO j=1,t_ncircuit
                gmat(j,ii,2)=zvec(j)
             END DO
          END DO
          IF(t_lsph==-1) THEN
             DO i=1-iabs(t_lsph),t_nsph
                ii=i+ngrup+iabs(t_lsph)
                gmat(t_ncircuit,ii,2)=-zgplc(i)
             END DO
          END IF
       END IF
    END IF
  END SUBROUTINE gs_curmat1

  SUBROUTINE gs_curmat3
    INTEGER :: ncsy,i,j,k,n,kk,nloo,jj
    REAL(rq) ::  sumg,alfo,alfn
    ! Matrix(Green's function) for minimizations: see ircwt
    ncsy=t_nc/(3-t_nsymc)
    umat=0
    IF(t_ircwt<4 .AND. t_ircwt>0) THEN
       zvec=0
       DO j=1,t_nc
          IF(t_ircwt==0) THEN
             zvec(t_ic(j))=zvec(t_ic(j))+(t_cc(j)*t_rc(j))**2*t_svec(j)
          ELSEIF(t_ircwt==1) THEN
             zvec(t_ic(j))=zvec(t_ic(j))+t_cc(j)**2*t_svec(j)
          ELSEIF(t_ircwt==2) THEN
             zvec(t_ic(j))=zvec(t_ic(j))+t_cc(j)**2*t_svec(j)
          ELSEIF(t_ircwt==3) THEN
             zvec(t_ic(j))=zvec(t_ic(j))+(t_cc(j)/t_drc(j)/t_dzc(j))**2*&
                  t_svec(j)
          END IF
       END DO
       DO i=1,ngrup
          umat(i,i)=zvec(i)/t_ccls(i)**2
       END DO
       gmat(:ngrup,:ngrup,3)=umat(1:ngrup,1:ngrup)
    ELSEIF(t_ircwt==4 .OR. t_ircwt==6 .OR. t_ircwt==7) THEN
       !     minimize wpf, delta t_pfpsi or wpt
       DO j=1,t_nc
          DO i=1,t_nc
             umat(t_ic(i),t_ic(j))=umat(t_ic(i),t_ic(j))+t_cc(i)*t_cc(j)*&
                  t_pfim(i,j)
          END DO
       END DO
       DO i=1,ngrup
          umat(i,1:ngrup)=umat(i,1:ngrup)/t_ccls(i)/t_ccls(1:ngrup)
       END DO
       IF(t_ircwt==4 .OR. t_ircwt==7) THEN
          gmat(:,:,3)=umat(1:t_ngroup,1:t_ngroup)
       ELSEIF(t_ircwt==6) THEN   !   minimize flux difference at coils
          DO i=1,t_ngroup
             IF(t_icc(i)==0 .AND. t_almim/=0) umat(i,1:t_ngroup)=0
          END DO
          gmat(:,:,3)=MATMUL(&
               TRANSPOSE(umat(1:ngrup,1:ngrup)),umat(1:ngrup,1:ngrup))
       END IF

    ELSEIF(t_ircwt==5) THEN   !   minimizes B**2 at coils
       DO j=1,t_nc/(3-t_nsymc)
          DO i=1,t_nc/(3-t_nsymc)
             umat(t_ic(i),t_ic(j))=umat(t_ic(i),t_ic(j))+t_cc(i)*t_cc(j)*&
                  t_pbim(i,j)
          END DO
       END DO
       DO i=1,t_ngroup
          umat(i,1:ngrup)=umat(i,1:ngrup)/t_ccls(i)/t_ccls(1:ngrup)
          gmat(i,:,3)=umat(i,1:ngrup)
       END DO

    ELSEIF(t_ircwt==10 .OR. t_ircwt==9 .OR. t_ircwt==8) THEN
       ! loop measurements
       DO n=1,t_nloop
          zvec(:t_nc)=0
          DO i=1,t_nc
             IF(t_iloop(n)==1) THEN ! flux
                zvec(t_ic(i))=zvec(t_ic(i))+t_cc(i)*t_plim(i,n,1)/t_sigloop(n)
             ELSEIF(t_iloop(n)==2) THEN ! field              
                zvec(t_ic(i))=zvec(t_ic(i))+t_cc(i)*(t_plim(i,n,2)*sin(&
                     t_thloop(n))-t_plim(i,n,3)*cos(t_thloop(n)))/t_sigloop(n)
             END IF
          END DO
          umat(n,1:ngrup)=zvec(1:ngrup)
       END DO
       DO i=1,t_nloop
          umat(i,1:ngrup)=umat(i,1:ngrup)/t_ccls(1:ngrup)
       END DO
       gmat(:,:,3)=MATMUL(&
            TRANSPOSE(umat(1:t_nloop,1:ngrup)),umat(1:t_nloop,1:ngrup))
       IF(jbig/=0) THEN
          amat(:ngrup,:ngrup)=gmat(:,:,3)
       END IF
       DO k=1-iabs(t_lsph),t_nsph
          WHERE(t_iloop==1)
             t_splw(:,k)=-t_gplw(:,k,1)/t_sigloop
          ELSEWHERE
             t_splw(:,k)=-(sin(t_thloop)*t_gplw(:,k,2)-cos(t_thloop)*&
                  t_gplw(:,k,3))
          ENDWHERE
       END DO
       DO k=1-iabs(t_lsph),t_nsph
          kk=k+ngrup+iabs(t_lsph)
          DO n=1,ngrup
             gmat(n,kk,3)=SUM(umat(1:t_nloop,n)*t_splw(:,k))
             gmat(kk,n,3)=gmat(n,kk,3)
          END DO
          DO j=1-iabs(t_lsph),t_nsph
             jj=j+ngrup+iabs(t_lsph)
             nloo=t_nloop
             IF(t_lsph==1)nloo=t_nloop+1
             gmat(kk,jj,3)=SUM(t_splw(:nloo,k)*t_splw(:nloo,j))
          END DO
       END DO
    ELSEIF(t_ircwt==-1) THEN ! (dI/t_dz)**2
       gmat(:,:,3)=0
       IF(t_nsymc==2) THEN
          alfo=t_svec(t_ngroup)/((t_rcg(1)-t_rcg(t_ngroup))**2+(t_zcg(1)-&
               t_zcg(t_ngroup))**2)
       ELSE
          alfo=0
       END IF
       DO i=1,t_ngroup
          j=i+1
          IF(i==t_ngroup) j=1
          alfn=t_svec(i)/((t_rcg(j)-t_rcg(i))**2+(t_zcg(j)-t_zcg(i))**2)
          umat(i,i)=alfn+alfo
          IF(i<t_ngroup) umat(i,j)=-alfn
          umat(i,i-1)=-alfo
          alfo=alfn
       END DO
       gmat(:,:,3)=umat(1:,1:t_ngroup)
    END IF
    IF(lfbd/=0) THEN
       DO j=1,ngrup
          DO i=1,ngrup
             zvec(i)=SUM(gmatfbd(:t_nfbd,i)*gmatfbd(:t_nfbd,j)*&
                  t_alfbd(:t_nfbd))
          END DO
          gmat(:,j,3)=gmat(:,j,3)+zvec(1:ngrup)
       END DO
    END IF

    IF(t_jbdcir/=0 .AND. t_almim/=0) THEN 
       !  add the square of the constrain to function too minimize: 
       !  removes singularity in inverse
       gmat(:,:,3)=gmat(:,:,3)+t_almim*MATMUL(&
            TRANSPOSE(gmat(:t_jbdcir,:,1)),gmat(:t_jbdcir,:,1))
    END IF
    IF(t_ircwt>=4 .OR. lfbd/=0 .OR. t_jbdcir/=0) THEN
       !  continue minimization (common)
       IF(t_ircwt==8) THEN
          !      CALL parsestr("svd_(1)")
       ELSEIF(jsvd==1) THEN
          asvd=0
          DO i=1,msvd*nsvd
             asvd(i,1)=0
          END DO
          asvd(:t_ngroup,:t_ngroup)=gmat(:,:,3)
       ELSEIF(jbig==0) THEN
          CALL rmInvert(gmat(1,1,3),t_ngroup,t_ngroup)
       END IF
    ELSE
       DO i=1,t_ngroup
          gmat(i,i,3)=1./gmat(i,i,3)
       END DO
    END IF
  END SUBROUTINE gs_curmat3

  SUBROUTINE gs_calcMatrices
    REAL(rq) ::  pds(8),ff_(t_nc),fbr_(t_nc),fbz_(t_nc),rmt
    INTEGER ::  inum,jnum,i,j,ier,nlo
    inum=0;jnum=3
    !--- Now calculate Matrices for constraints
    umat=0
    rmt=-1.e+05_rq
    CALL mutual_utils(rcls,zcls,fcr,fcz,ff_,fbr_,fbz_,inum)
    zvec(1:)=ff_

    IF(t_ixpt>=4 .AND. s_limiterd==0) THEN
       CALL mutual_utils(rcls,zcls,t_raxis,t_zaxis,ff_,fbr_,fbz_,inum)
       IF(t_ixpt==5) THEN
          zvec(1:)=ff_
       ELSEIF(t_ixpt==4) THEN
          zvec(1:)=t_theta*ff_+(1-t_theta)*zvec(1:)
       END IF
    END IF
    DO i=1,t_nbd
       CALL mutual_utils(rcls,zcls,t_rbd(i),t_zbd(i),ff_,fbr_,fbz_,inum)
       dvec=rmt*(ff_-zvec(1:))*t_cc
       DO j=1,t_nc
          umat(i,t_ic(j))=umat(i,t_ic(j))+dvec(j)
       END DO
    END DO

    IF(jbdaxis/=0) THEN       !  FIXING FLUX ON AXIS
       i=jbdaxis
       CALL mutual_utils(rcls,zcls,t_raxis,t_zaxis,ff_,fbr_,fbz_,inum)
       dvec=rmt*ff_*t_cc
       DO j=1,t_nc
          umat(i,t_ic(j))=umat(i,t_ic(j))+dvec(j)
       END DO

    ELSEIF(jbdvltf/=0) THEN !  FIXING VOLTSECONDS
       i=jbdvltf
       CALL mutual_utils(rcls,zcls,t_raxis,t_zaxis,ff_,fbr_,fbz_,inum)
       dvec=rmt*ff_*t_cc
       DO j=1,t_nc
          umat(i,t_ic(j))=umat(i,t_ic(j))+dvec(j)
       END DO
    END IF

    IF(t_jaxis/=0 .OR. t_kaxis/=0) THEN ! Fixing axis
       CALL mutual_utils(rcls,zcls,t_raxis0,t_zaxis0,ff_,fbr_,fbz_,jnum)
       dvec=rmt*fbr_*t_cc*t_raxis0**2
       DO j=1,t_nc
          umat(jbdr,t_ic(j))=umat(jbdr,t_ic(j))+dvec(j)
       END DO
       dvec=rmt*fbz_*t_cc*t_raxis0**2
       DO j=1,t_nc
          umat(jbdz,t_ic(j))=umat(jbdz,t_ic(j))+dvec(j)
       END DO
    END IF

    IF(t_jxp/=0 .OR. t_kxp/=0) THEN ! Fixing X-point
       CALL mutual_utils(rcls,zcls,t_rxpt0,t_zxpt0,ff_,fbr_,fbz_,jnum)
       dvec=rmt*fbr_*t_cc*t_rxpt0**2
       DO j=1,t_nc
          umat(jbdxr,t_ic(j))=umat(jbdxr,t_ic(j))+dvec(j)
       END DO
       dvec=rmt*fbz_*t_cc*t_rxpt0**2
       DO j=1,t_nc
          umat(jbdxz,t_ic(j))=umat(jbdxz,t_ic(j))+dvec(j)
       END DO
    END IF

    IF(t_nlim/=0) THEN
       DO nlo=1,t_nlim
          i=jlim(nlo)
          CALL mutual_utils(rcls,zcls,rsk(nlo),t_zaxis,ff_,fbr_,fbz_,inum)
          CALL mutual_utils(rcls,zcls,t_rlim(nlo),t_zlim(nlo),fbr_,ff_,fbz_,&
               inum)
          dvec=rmt*(fbr_-ff_)*t_cc
          DO j=1,t_nc
             umat(i,t_ic(j))=umat(i,t_ic(j))+dvec(j)
          END DO
       END DO
    END IF

    IF(t_rl/=0 .AND. t_nsymc==2) THEN !   FIX DIST. BETWEEN SEP.
       i=jbdrl
       CALL mutual_utils(rcls,zcls,fcrr,fczz,ff_,fbr_,fbz_,inum)
       CALL mutual_utils(rcls,zcls,rump,zump,fbr_,ff_,fbz_,inum)
       dvec=rmt*(fbr_-ff_)*t_cc
       DO j=1,t_nc
          umat(i,t_ic(j))=umat(i,t_ic(j))+dvec(j)
       END DO
    END IF

    IF(jbd>0) THEN
       DO j=1,ngrup
          gmat(:jbd,j,1)=umat(1:jbd,j)/t_ccls(j) ! must remove t_cc
       END DO
    END IF

    IF(t_iflxc==1) THEN         !    FIXING FLUX AT COILS
       DO i=jbd+1,t_jbdcir
          gmat(i,:,1)=-gmat(i,:,2)*zpl+gmat(i,:,4)
       END DO
    END IF

    gmat(:t_jbdcir,:,1)=gmat(:t_jbdcir,:,1)/zpl
    gmat(:t_jbdcir,:,2)=gmat(:t_jbdcir,:,1)
    IF(jbig/=0) THEN
       DO i=1,t_jbdcir
          amat(:ngrup,ngrup+i)=gmat(i,:,1)
          amat(ngrup+i,:ngrup)=gmat(i,:,1)
       END DO
    END IF


  END SUBROUTINE gs_calcMatrices

  SUBROUTINE gs_equil0
    INTEGER :: n1
    n1=0
    IF (ALLOCATED(wk)) THEN
       n1=SIZE(wk,1)
    END IF
    IF(n1/=t_jmkm) THEN
       IF(ALLOCATED(wk)) DEALLOCATE(wk,psiv,psir,rlo,rup,rdi,bda,bdb,bdc,bdd)
       ALLOCATE(wk(t_jmkm,4),psiv(t_jm,t_km),psir(t_jmkm),rlo(t_jm),rup(t_jm),&
            rdi(t_jm),bda(t_km),bdb(t_km),bdc(t_jm),bdd(t_jm))
       wk=0
    END IF
    CALL setpfc !  finds filament currents etc
    CALL get_greens
    CALL gs_equila
    t_fwall=t_ro*t_btor ! To accomodate adiabat options:LDP
  END SUBROUTINE gs_equil0

  SUBROUTINE gs_equila
    include "debug.i"
    REAL(rq), SAVE ::  raxx,zaxx,zvert,prsxx,tp,prsxest
    INTEGER :: kxpl,iter,nitt_,jedge,n,i
    IF(t_nl==-1) THEN
       IF(t_lop0==1 .OR. t_kbfc==1) CALL pfcfld
       RETURN
    END IF
    IF(t_ipscl==1) THEN
       s_pin=sign(1.0_rq,t_dpsi00)
    ELSE
       s_pin=-sign(1.0_rq,t_plcm)
       ! Can now change sign of current in mid stream
    END IF
    t_nitr = 0
    t_nitt = 0
    CALL setcls  !  need before initsi IF initflx=1
    npdesol=1
    CALL gs_pdesol !  stupid must set up pdesol
    IF(npdesol<t_jmkm)npdesol=t_jmkm

    !  set initial flux
    prsxest = t_betx*(t_plcm*2.0e05_rq/t_rb)**2/FOURPI
    IF( t_keqic == 2 ) THEN
       CALL initsi  ! beware: psil,x, ebdu etc. enter at their present values
       IF( t_initflx==4 ) THEN
          t_prsx = t_prsx00
       ELSE
          t_prsx = prsxest
       END IF
    ELSEIF( t_keqic == 0 ) THEN
       IF( t_prsx<=0.0 ) t_prsx = prsxest
    ELSEIF( t_keqic == 1 .AND. t_ncallsf==1 ) THEN
       CALL initsi
       IF( t_initflx==4 ) THEN
          t_prsx = t_prsx00
       ELSE
          t_prsx = prsxest
       END IF
    ELSEIF( t_keqic == 3 .AND. t_ncallsf==1 ) THEN
       CALL initsi
       IF( t_initflx==4 ) THEN
          t_prsx = t_prsx01
       ELSE
          t_prsx = prsxest
       END IF
    END IF
    t_fwall=t_btor*t_ro ! DO here so hybrid can vary btor
    IF(t_ipj<3 .OR. t_frsrf(t_msrf)==0) THEN
       IF(t_ipf==0) THEN
          t_frsrf(t_msrf)=t_fwall ! to accomodate RFP
       ELSE
          t_frsrf(t_msrf)=abs(t_fwall)
       END IF
    END IF
    !
    IF( t_ksave == 1 ) THEN
       t_psi00=t_psi
       ! IF t_ksave=1 after an t_ipj=4 run, DO not want prsx00=1
       IF(t_ipj<3) THEN; t_prsx00 = t_prsx
          ! t_ipj=4: the following coding works only after done.
          !         ELSE; zbetaj=t_ro**2*vp(1)/(wp(1)+t_ro**2*vp(1))
          !               t_prsx00=-wp(1)*prsx*(psil-psix)/(t_ro**2*(1-zbetaj))
       END IF
       t_ksave = 0
    END IF
    !
    ! *****************
    !   IF you change the order of the following and don't check that t_keqic=0
    !   still works, including t_ipj=5, i'm taking a contract out. lll
    ! *****************
    !
    IF(t_ipj>=3) THEN
       !        t_prsx=1.0
    ELSEIF(t_prsx==0) THEN
       t_prsx=prsxx
    ELSEIF(t_keqic==0 .AND. t_prsx==1.0) THEN
       t_prsx=t_prsx01
    END IF
    t_delta=t_deltac   !  not relaxation; can scale i.c.
    t_theta=t_thetac
    t_deltad=t_deltadc
    gamm=0.
    !  from initsi:
    t_alpha  =0.
    t_alpcoil=0.
    t_alpsph =0.
    IF(t_ixpo == 0) THEN
       kxpl=2
       s_kxpu=t_km-1
       s_lxpt=0
       t_ixp = 0
    ELSE
       t_ixp = t_ixpt  !  be sure new psilms does something ok IF no xpt
    END IF
    t_sigma=0.
    t_rlimm=t_rlim(0);t_zlimm=t_zlim(0)
    IF(t_ipj<6 .AND. t_inv_eq==0) THEN
       CALL gs_psiext ! want t_psiw to reflect t_ccf, independent of t_keqic
       CALL gs_separatrix
       IF(t_ipj/=0 .AND. t_ipj<3 .AND. t_inv_eq==0) CALL s_xohmic(nter_interp,&
            iter)
    END IF
    IF(t_ipj==3 .OR. t_ipj==4 .OR. t_ipj==5) THEN
       CALL s_adiabat ! uses q or jpar
    ELSEIF(t_inv_eq==1) THEN
       IF(s_jx/=0) CALL gs_pdesol
       CALL gs_psiext ! want t_psiw to reflect t_ccf, independent of t_keqic
       CALL gs_separatrix
       t_dpsi0=t_psil-t_psix ! ldp 11/2/96
       nitt_=t_nitt
       t_inv_eq=0
       t_fix_bound=.false.
       CALL teq_inv(t_inv_k,t_inv_p)
       t_nitt=nitt_
       CALL s_source_inv
    END IF
    IF(t_ipj==0 .AND. t_inv_eq==0) THEN
       CALL s_source(t_psibar,t_prsrf,t_pdsrf,0)
       CALL s_source(t_psibar,t_frsrf,t_fpsrf,1)
    END IF
    jedge=t_kedge
    IF(t_kedge==2) t_kedge=-1
    IF(t_inv_eq==0 .OR. (t_ipf==999 .AND. iabs(t_ipp)==999)) THEN
       t_clj=t_psi        ! t_clj,crje calculated later, ok here
       IF(t_ipf/=-1 .AND. t_ipf/=-8) THEN ! No outside region
          WHERE(s_lxpt<0) s_lxpt=1
       END IF
       CALL s_sourceGS(t_clj,t_rm,t_crj,t_pvec)
       t_bt=t_clj/t_rm
       t_kedge=jedge
       IF(t_kedge==2) THEN
          CALL shift
          CALL s_sourceGS(psish,rmsh,t_clj,crje)
          t_bt=psish/t_rm
       END IF
    END IF
    t_kedge=jedge
    IF(ndbg28==1) THEN
       CALL parsestr('<<"after sourceGS in equila";call separatrix_interface')
       CALL debugger
    END IF
    crjr=t_crj;psir=t_psi
    CALL gs_psiscl

    ! IF T_NSYM/=0, SET PLASMA SHAPE
    IF( t_nsym/=0 ) CALL gs_plbdry
    !----move rbd points normal to surface(nearly)
    IF(t_ncallsf==1) THEN
       raxx=t_raxis
       zaxx=t_zaxis
       zvert=t_wvert
       DO i=1,t_nbd
          IF(t_whtz(i)/=0) THEN
             t_psiwfc(i)=sqrt((t_rbd(i)-raxx)**2+(t_zbd(i)-zaxx)**2/zvert**2)/&
                  t_whtz(i)
             t_tbd(i)=atan2((t_zbd(i)-zaxx)/zvert,t_rbd(i)-raxx)
          END IF
       END DO
    END IF
    DO i=1,t_nbd
       IF(t_whtz(i)>0) THEN  ! destroys rbd IF t_raxis @ncallsf=1 bad
          t_rbd(i)=t_raxis+t_whtz(i)*t_psiwfc(i)*cos(t_tbd(i))
          t_zbd(i)=t_zaxis+t_whtz(i)*t_psiwfc(i)*sin(t_tbd(i))*zvert
       ELSEIF(t_whtz(i)<0) THEN
          t_zbd(i)=zaxx+zvert*(t_rbd(i)-raxx)*tan(t_tbd(i))
       END IF
    END DO
    IF(t_int_flag<=0) CALL gs_intcls
    CALL gs_clcalc
    CALL gs_bndpsi(1) ! ldp's change 23/10/95
    gamm   = t_gammac
    t_alpcoil=t_alpcoilc
    t_alpsph =t_alpsphc
    t_alpha  =t_alphac
    t_sigma  =t_sigmac
    ! SOLVE EQUILIBRIUM PROBLEM...
    IF(t_jbdcir==0) THEN
       i=0
       CALL gs_curcal(i)
       t_lcal=-1
    END IF
    CALL gs_equilb(t_nl)

    t_sigma = 0.0
    t_alpha = 0.0
    t_alpcoil= 0.0
    t_alpsph = 0.0
    t_nitr  = 2000
    t_ixp = t_ixpt
    ! COMPUTE DIAGNOSTIC QUANTITIES, OUTPUT...
    IF(t_ipj<3) prsxx=t_prsx
    t_dpsi0=t_psil-t_psix
    IF(t_ipf==-7) THEN ! Spheromak
       IF(t_lamdagun>0) THEN
          WHERE(t_crj<0)t_bt=-t_bt
       ELSE
          WHERE(t_crj>0)t_bt=-t_bt
       END IF
    END IF
    IF(t_ipj==1 .AND. t_inv_eq==0) THEN ! must rescale to be consistent
       IF(t_prsx01==0) t_prsx01=t_prsx
       t_jtsave=t_jtsave*t_prsx/t_prsx01
       t_psave=t_psave*t_prsx/t_prsx01
    END IF
    CALL gs_separatrix
    t_dpsi0=t_psil-t_psix ! ldp 11/2/96
    IF(ndbg20==0) THEN
       IF(t_inv_eq==0) THEN
          CALL s_source(t_psibar,t_prsrf,t_pdsrf,0)
          CALL s_source(t_psibar,t_frsrf,t_fpsrf,1)
          CALL diag
       ELSE
          CALL diaginv
       END IF
       ! CALL trap_to_pass
    END IF
  END SUBROUTINE gs_equila

  SUBROUTINE gs_equilb(nll)
    CHARACTER(len=2) aa
    CHARACTER(len=6) bb
    CHARACTER(len =128) mes
    INTEGER nll,ib
    REAL(rq) pp
    include "debug.i"

    t_alpha=t_alphac
    t_sigma=t_sigmac
    t_alpcoil=t_alpcoilc
    t_alpsph =t_alpsphc
    DO ib=1,nll
       IF(t_dt .NE. 0) CALL parsestr("mov_lim")
       CALL gs_equilc
       CALL gs_psiscl
       CALL gs_bndpsi(1)
       aa=" "
       IF( s_limiterd == 0) aa=" *"
       IF(t_ipj==5 .AND. t_inv_p==-1) THEN
          bb=" dps ="
          pp=t_dpsi0
       ELSEIF(t_ipj==5) THEN
          bb=" plc= "
          pp=t_plc*1.e-5_rq
       ELSEIF(t_ipscl<=0) THEN
          bb=" plc= "
          pp=t_plc*1.e-5_rq
       ELSEIF(t_ipscl==1) THEN
          bb=" dps ="
          pp=t_dpsi0
       ELSEIF(t_ipscl==2) THEN
          bb=" fgn ="
          pp=t_fgun
       ELSEIF(t_ipscl==3) THEN
          bb=" psl ="
          pp=t_psil
       ELSEIF(t_ipscl==4) THEN
          bb=" psr = "
          pp=t_psires
       END IF
       IF(t_nprt59==1) THEN
          IF(s_nxps/=0) THEN
             aa=" -"
             IF(s_kxpt==s_kxpu) aa=" +"
             WRITE(STDOUT,2000)t_nitt,t_residj,s_jxpt,s_kxpt,t_rxpt,t_zxpt,&
                  bb,pp,aa
             WRITE(t_logunit,2000)t_nitt,t_residj,s_jxpt,s_kxpt,t_rxpt,&
                  t_zxpt,bb,pp,aa
          ELSE
             WRITE(STDOUT,4000)t_nitt,t_residj,s_jx,s_kx,t_raxis,t_zaxis,bb,pp
             WRITE(t_logunit,4000)t_nitt,t_residj,s_jx,s_kx,t_raxis,t_zaxis,&
                  bb,pp
          END IF
       END IF
       IF(t_resb<=t_epsb .AND. t_residj<=t_epsj) EXIT
    END DO
    
    IF(ib>nll .AND. nll>30) THEN
       write(mes,'(a,i4,a,1pe8.1,a,1pe8.1,a)')&
            " direct solver failed to converge, nl = ",t_nl, &
            " residj =",t_residj," epsj =",t_epsj
       CALL errdetec(mes,-1)
    END IF
    IF(ib<=nll .AND. t_nprt59==0 .AND. nll>5) THEN
       WRITE(STDOUT,3000)ib,t_nitr,s_jx,s_kx,t_raxis,t_zaxis,s_jxpt,s_kxpt,&
            t_rxpt,t_zxpt,aa
       WRITE(t_logunit,3000)ib,t_nitr,s_jx,s_kx,t_raxis,t_zaxis,s_jxpt,s_kxpt,&
            t_rxpt,t_zxpt,aa
    ELSEIF(t_nprt59==2 .OR. (t_nprt59==0 .AND. ib>nll)) THEN
       WRITE(STDOUT,2000)t_nitt,t_residj,s_jxpt,s_kxpt,t_rxpt,t_zxpt,bb,pp,aa
       WRITE(t_logunit,2000)t_nitt,t_residj,s_jxpt,s_kxpt,t_rxpt,t_zxpt,bb,&
            pp,aa
    END IF
 1000 format(i3,' res=',1pe10.3,1pe10.3,' plc= ',1pe10.3,&
           ' theta= ',1pe9.3,' psil= ',1pe10.3)
 2000 format(' res(',i3,')= ',1pe10.3,'  xpt(',i2,',',i3,')= ',1pe10.3,',',&
           1pe10.3,a,1pe10.3,a)
 3000 format(i3,i3,' axis(',i2,',',i3,')= ',1pe9.3,',',1pe10.3,&
           ' xpt(',i2,',',i3,')= ',1pe9.3,',',1pe10.3,a)
 4000 format(' res(',i3,')= ',1pe10.3,' axis(',i2,',',i3,')= ',1pe10.3,&
           ',',1pe10.3,a,1pe10.3)
  END SUBROUTINE gs_equilb

  SUBROUTINE gs_equilc
    include "debug.i"
    INTEGER jedge,ncal,imth,nn,iter,nitt_,n
    REAL(rq) dtold,tp,p_
    SAVE dtold
    DATA imth/11/

    !
    !     SOLVE THE GRAD-SHAFRANOV EQUATION FOR GIVEN BOUNDARY VALUES
    !     OF T_PSI AND GIVEN EXTERNAL FLUX T_PSIW ON THE 2D MESH
    !
    !     CHECK FOR CTRL-EI INTERRUPT FROM BASIS:
    CALL RUTHERE
    
    ncal=0
    IF(t_jbdcir/=t_ncircuit .OR. t_nitt==0) ncal=1
    t_rlimm=t_rlim(0);t_zlimm=t_zlim(0)
    DO nn=1, abs(t_ni)
       IF((ndbg4>0 .AND. ndbg4>t_nitt) .OR. t_dt/=dtold .OR. ncal==1) THEN
          t_lcal=1
          dtold=t_dt
       END IF
       t_nitr=nn
       t_nitt=t_nitt+1
       IF(t_nitr/=1) CALL gs_psiscl
       CALL gs_pdesol
       t_ixp = t_ixpt
       i_cps(:,1,1)=t_psi
       CALL bispline_interp(t_r,t_z,i_cps,imth,t_n4)
       IF(t_nsym/=0) THEN
          CALL gs_curcal(t_lcal)
       END IF
       CALL gs_separatrix
       CALL t_stretch(t_lsrf,t_psil,t_psix)
       IF(t_ipj/=0 .AND. t_ipj<3 .AND. t_inv_eq==0) &
            CALL s_xohmic(nter_interp,iter)
       IF(t_ipj==3 .OR. t_ipj==4 .OR. t_ipj==5) THEN ! 4and 5 are from qsave 
                                                     ! except 5 never scales
          CALL s_adiabat ! forces qsrf or jparsrf and prsrf 
                         ! from qsave,jparsave,psave
       ELSEIF(t_inv_eq==1) THEN
          nitt_=t_nitt
          IF(t_nitt==1) t_inv_eq=0
          t_fix_bound=.false.
          CALL teq_inv(t_inv_k,t_inv_p)
          t_nitt=nitt_
          CALL s_source_inv
       END IF
       IF(t_ipj==0 .AND. t_inv_eq==0) THEN
       END IF
       if(ndbg28==-2) CALL parsestr("debug_equilc")
       jedge=t_kedge
       IF(t_kedge==2) t_kedge=-1
       IF(t_inv_eq==0 .OR. (t_ipf==999 .AND. iabs(t_ipp)==999)) THEN
          t_clj=t_psi     ! t_clj,crje calculated later, ok here
          IF(t_ipf/=-1 .AND. t_ipf/=-8) THEN ! No outside region
             WHERE(s_lxpt<0) s_lxpt=1
          END IF
          CALL s_sourceGS(t_clj,t_rm,t_crj,t_pvec)
          t_bt=t_clj/t_rm
          t_kedge=jedge
          IF(t_kedge==2) THEN
             CALL shift
             CALL s_sourceGS(psish,rmsh,t_clj,crje)
          END IF
       END IF
       t_kedge=jedge
       IF(ndbg28==1) THEN
       CALL parsestr('<<"after sourceGS in equilc";call separatrix_interface')
          CALL debugger
       END IF
       CALL gs_clcalc
       CALL gs_errors
       IF((t_limw/=0 .AND. t_dt==0) .OR. (t_limw/=0 .AND. t_nitt<=t_limw)) THEN
          CALL gs_getlimtr(t_psil,t_rlim(0),t_zlim(0),t_dlim(0))
          t_rlimm=t_rlim(0);t_zlimm=t_zlim(0)
       END IF
       IF(t_residj<=t_epsj) EXIT
    END DO
  END SUBROUTINE gs_equilc

  SUBROUTINE gs_getlimtr(psis,t_rlim,t_zlim,t_dlim)
    REAL(rq) :: psis,t_rlim,t_zlim,t_dlim,y1,plim_(t_lmax,1)
    REAL(rq), DIMENSION(t_lmax) :: c0_,c1_,c2_,d0_,d1_,d2_
    REAL(rq) :: pmax,dpl,dmi,pp,pm,pmp,pmpp,tmax,rmax,zmax,amin,amax
    INTEGER :: ier,isw,ipm,jmin,jmax
    include "debug.i"

    ier=1
    isw=0
    y1=-666
    IF(t_nsym==1) y1=t_splbdry
    ! reset limiter coordinate system
    t_tlimw=atan2((t_zlimw-t_zaxis)/t_wvert,t_rlimw-t_raxis) 
    WHERE(t_tlimw<0)
       t_tlimw=t_tlimw+TWOPI
    END WHERE
    CALL boxm_interp(t_rlimw,t_zlimw,plim_,i_r,i_z,i_cps,isw,ier,t_n4)
    CALL interp_interp(t_tswpts,t_rls,y1,y1,t_tlimw,c0_,c1_)
    CALL interp_interp(t_tswpts,t_zls,y1,y1,t_tlimw,d0_,d1_)

    d1_=sqrt((c0_-t_raxis)**2+(d0_-t_zaxis)**2/t_wvert**2)
    d2_=sqrt((t_rlimw-t_raxis)**2+(t_zlimw-t_zaxis)**2/t_wvert**2)
    d0_=d1_-d2_

    pmax=xmaxaf(d0_,1,t_lmax,1,ipm)
    IF(ipm==1) ipm=2
    IF(ipm==t_lmax) ipm=t_lmax-1

    !    Refine distances      

    IF(ndbg13==1) THEN
       dpl=t_tlimw(ipm+1)-t_tlimw(ipm)
       dmi=t_tlimw(ipm-1)-t_tlimw(ipm)
       pp=(d0_(ipm+1)-pmax)/dpl
       pm=(d0_(ipm-1)-pmax)/dmi
       pmp=(pm*dpl-pp*dmi)/(dpl-dmi)
       pmpp=2*(pp-pm)/(dpl-dmi)
       tmax=-pmp/pmpp
       !  Maximum distance between (including sign)  boundary - limiter
       pmax=pmax-0.5_rq*pmp**2/pmpp
       rmax=t_rlimw(ipm)
       pp=(t_rlimw(ipm+1)-rmax)/dpl
       pm=(t_rlimw(ipm-1)-rmax)/dmi
       !  T_R position on limiter on ray thru maximum
       rmax=rmax+(pm*dpl-pp*dmi)/(dpl-dmi)*tmax+(pp-pm)/(dpl-dmi)*tmax**2
       zmax=t_zlimw(ipm)
       pp=(t_zlimw(ipm+1)-zmax)/dpl
       pm=(t_zlimw(ipm-1)-zmax)/dmi
       !  T_Z position on limiter on ray thru maximum
       zmax=zmax+(pm*dpl-pp*dmi)/(dpl-dmi)*tmax+(pp-pm)/(dpl-dmi)*tmax**2
       !  Angle on limiter on ray thru maximum
       tmax=t_tlimw(ipm)+tmax

    ELSE
       d1_=t_tlimw
       CALL spline_interp(d1_,d0_,t_splbdry,t_splbdry,c1_,c2_,c0_,noint)
       tmax=1-2*c0_(ipm)*c1_(ipm)/c2_(ipm)**2
       tmax=-2*c1_(ipm)/c2_(ipm)/(1+sqrt(abs(tmax)))
       IF(tmax>t_tlimw(ipm+1)-t_tlimw(ipm)) THEN
          ipm=ipm+1
          tmax=1-2*c0_(ipm)*c1_(ipm)/c2_(ipm)**2
          tmax=-2*c1_(ipm)/c2_(ipm)/(1+sqrt(abs(tmax)))
       ELSEIF(tmax<t_tlimw(ipm-1)-t_tlimw(ipm)) THEN
          ipm=ipm-1  
          tmax=1-2*c0_(ipm)*c1_(ipm)/c2_(ipm)**2
          tmax=-2*c1_(ipm)/c2_(ipm)/(1+sqrt(abs(tmax)))
       END IF

       !  Maximum distance between (including sign)  boundary - limiter
       pmax=d0_(ipm)+tmax*(c1_(ipm)+0.5_rq*tmax*(c2_(ipm)+tmax*c0_(ipm)/3))
       CALL spline_interp(t_tlimw,t_rlimw,t_splbdry,t_splbdry,c1_,c2_,c0_,&
            noint)
       !  T_R position on limiter on ray thru maximum
       rmax=t_rlimw(ipm)+tmax*(c1_(ipm)+0.5_rq*tmax*(c2_(ipm)+tmax*c0_(ipm)/3))
       CALL spline_interp(t_tlimw,t_zlimw,t_splbdry,t_splbdry,c1_,c2_,c0_,&
            noint)
       !  T_R position on limiter on ray thru maximum
       zmax=t_zlimw(ipm)+tmax*(c1_(ipm)+0.5_rq*tmax*(c2_(ipm)+tmax*c0_(ipm)/3))
    END IF
    !  Angle on limiter on ray thru maximum
    tmax=t_tlimw(ipm)+tmax
    t_rlim=rmax
    t_zlim=zmax
    t_dlim=pmax
    !    End refine

    CALL xminmax(t_tlimw,1,t_lmax,1,amin,amax,jmin,jmax)
    IF(tmax<amin) THEN
       t_rlim=t_rlimw(jmin)
       t_zlim=t_zlimw(jmin)
    ELSEIF(tmax>amax) THEN
       t_rlim=t_rlimw(jmax)
       t_zlim=t_zlimw(jmax)
    END IF
  END SUBROUTINE gs_getlimtr

  SUBROUTINE gs_pdesol
    REAL(rq)  wvec(npdesol)
    REAL(rq) ::  raa,rbb,zdd,zd,alpx,btax,pertrb
    INTEGER :: iorder,nr,nz,idmn,ierror
    INTERFACE
       SUBROUTINE cofx(x,afun,bfun,cfun)
         USE sep_utils
         REAL(rq) ::  x,afun,bfun,cfun
       END SUBROUTINE cofx
    END INTERFACE
    wvec(1)=npdesol
    iorder = 2
    raa    = t_r(1)
    rbb    = t_r(t_jm)
    zdd    = t_z(1)
    zd     = t_z(t_km)
    nr     = t_jm - 1
    nz     = t_km - 1
    idmn   = t_jm
    !

    IF(t_int_flag<=0) THEN
       wk(:,1)=t_crj + t_clj
       psiv=RESHAPE(t_psi,(/t_jm,t_km/))
    ELSE
       wk(:,1)=t_crj
       psiv=RESHAPE(t_psi,(/t_jm,t_km/))-RESHAPE(t_psiw,(/t_jm,t_km/))
    END IF
    !
    alpx = 0.0  ! not used
    btax = 0.0  ! not used

    CALL sepx4( iorder,raa,rbb,nr,1,bda,alpx,bdb,btax,zdd,zd,nz,1,bdc,bdd,&
         cofx,wk,psiv,idmn,wvec,pertrb,ierror )
    npdesol=wvec(1)
    !
    IF(t_int_flag<=0) THEN
       t_psi = RESHAPE(psiv,(/t_jmkm/))
    ELSE
       t_psi = RESHAPE(psiv,(/t_jmkm/)) + t_psiw
    END IF
    !
  END SUBROUTINE gs_pdesol

  SUBROUTINE gs_psiext
    REAL(rq) p_si(t_jm,t_km)
    INTEGER ::  nn,l1,kl,i,l2,j,k,l,neu,nel,n
    IF( t_kgreenc==1) THEN   !   USE STORED VALUES
       !
       nn=0
       l1=1
       p_si=0
       IF( t_nsym==1 ) THEN   !   SYMMETRIC CONFIGURATION...
          kl=t_km/2+1
          DO i=1,t_nc/2
             l2=t_loop0(i)
             IF(t_iferro(i)==1) THEN
                DO l=l1,l2
                   nn=nn+1
                   p_si(:,:kl)=p_si(:t_jm,:kl)+1.0e+5_rq*t_gc(:,:kl,nn)*&
                        t_ccf(l)
                END DO
             ELSE
                nn=nn+1
                p_si(:,:kl)=p_si(:,:kl)+1.0e+5_rq*t_gc(:,:kl,nn)*t_cc(i)
             END IF
             l1=l2+1
          END DO
          DO k=kl+1,t_km
             p_si(:,k)=p_si(:,t_km+1-k)
          END DO
          t_psiw=RESHAPE(p_si,(/t_jmkm/))
          ! 
       ELSEIF( t_nsym==2 ) THEN  !   NON-SYMMETRIC CONFIGURATION...
          !
          DO i=1,t_nc
             l2=t_loop0(i)
             IF(t_iferro(i)==1) THEN
                DO l=l1,l2
                   nn=nn+1
                   p_si=p_si+1.0e+5_rq*t_gc(:,:,nn)*t_ccf(l)
                END DO
             ELSE
                nn=nn+1
                p_si=p_si+1.0e+5_rq*t_gc(:,:,nn)*t_cc(i)
             END IF
             l1=l2+1
          END DO
       END IF
       t_psiw=RESHAPE(p_si,(/t_jmkm/))
       ! 
    ELSEIF ( t_kgreenc == 0 ) THEN
       ! 
       IF( t_nsym==1 ) THEN   !  CALCULATE SYMMETRIC CONFIGURATION...
          ! 
          kl = t_km/2 + 1
          DO k=kl,t_km
             DO j=1,t_jm
                neu = ( k - 1 )*t_jm + j
                t_psiw(neu) = g_flxc(t_r(j),t_z(k))
                IF( k/=kl ) THEN
                   nel       = ( t_km - k )*t_jm + j
                   t_psiw(nel) = t_psiw(neu)
                END IF
             END DO
          END DO
          !
       ELSEIF( t_nsym==2 ) THEN  !  NON-SYMMETRIC CONFIGURATION...
          ! 
          DO k=1,t_km
             DO j=1,t_jm
                n   = ( k - 1 )*t_jm + j
                t_psiw(n) = g_flxc(t_r(j),t_z(k))
             END DO
          END DO
          ! 
       END IF
       ! 
    ELSE
       CALL errdetec(" psiext: ~ 0 <= t_kgreenc <= 1.",1)
    END IF
  END SUBROUTINE gs_psiext

  SUBROUTINE gs_psiscl
    include "debug.i"
    !
    !Scale equilibrium quantities to: fix poloidal flux IF ipscl >0
    !                            fix plasma current IF ipscl=0
    !                            doesn't scale IF ipscl=-1
    !                            fixes F(msrf)=fwall IF ipscl=-2
    REAL(rq) ::  plc_gun,vlt_
    IF(t_ipj==6 .OR. t_ipj==8 .OR. t_ipj==5) THEN
       t_scl=1
       RETURN
    END IF
    IF(t_ipscl==0) THEN
       t_scl=1._rq+t_delta*(t_plcm*1.0e+05_rq/t_plc-1.)
    ELSEIF(t_ipscl==-2) THEN
       t_scl=1._rq+t_delta*(t_fwall/t_frsrf(t_msrf)-1.)
    ELSEIF(t_ipscl==-1) THEN  !  could RETURN, but might want ifscl
       t_scl=1.0_rq
    ELSEIF(t_ipscl==1) THEN
       IF(t_mdpsi>0) THEN !  enforce dpsi00 at middle of mesh when diverted
          t_scl=1._rq+t_delta*(t_dpsi00/(t_psrf(t_mdpsi)-t_psix)-1.)
       ELSE
          t_scl=1._rq+t_delta*(t_dpsi00/(t_psil-t_psix)-1.)
       END IF
    ELSEIF(t_ipscl==2) THEN
       plc_gun=0.5_rq*t_fgun
       t_scl=1._rq+t_delta*(t_plcm_gun*1.0e+05_rq/plc_gun-1)
    ELSEIF(t_ipscl==3) THEN
       t_scl=1.0_rq+t_delta*(t_psilm/t_psil-1)
    ELSEIF(t_ipscl==4) THEN
       CALL vltsec(vlt_,2)
       t_scl=1._rq+t_delta*(t_psires0/t_psires-1.)
    END IF
    IF(ndbg11>=4 .OR. (t_ipj>2 .AND. ndbg11==0)) THEN 
       !these are not scale transformations
       ! prsx=..should have no affect on adiabat (IF bet=0 or 
       ! t_ipj=5, ndbg17=1->Oh-oh )
       ! but will screw up CALL to source in diag: needs prsx& w's 
       ! in synch.

       IF(t_ipj<3) THEN
          t_prsx=t_prsx*t_scl
       END IF
       t_crj=t_crj*t_scl
       RETURN
    END IF
    IF(t_nitr==0) THEN  !  CALL from equila (why special?)
       t_crj=t_crj*t_scl
       t_prsx=t_prsx*t_scl**2
       RETURN
    END IF
    t_prsx=t_prsx*t_scl**2
    ! need to scale prsx (to be determined); t_crj (bndpsi follows psiscl); 
    ! t_psi (resb) others for safety, but watch out
    ! psil=psil*t_scl  !  curcal options use psil, between here and psilms
    ! psix=psix*t_scl  !  any affect?
    ! t_pxpt=t_pxpt*t_scl  !  curcal checks t_pxpt-pxpu,l  scale all or none
    t_crj=t_crj*t_scl
    t_psi=t_psi*t_scl     !  affects resb CALL in bndpsi
    i_cps=i_cps*t_scl     !  any affect?
    !      DO i=1,nfsq  !  source option, now trashed
    !         cfsq(i)=cfsq(i)*t_scl**2
    !      END DO
    !      DO i=1,nprs
    !         cprs(i)=cprs(i)*t_scl**2
    !      END DO
  END SUBROUTINE gs_psiscl

  SUBROUTINE gs_errors
    REAL(rq) ::  dzrsq,resid1,pnrm,rjnrm,dnrm,delpsi
    INTEGER j,n,jbeg,jend,k
    dzrsq=(t_dz/t_dr)**2
    DO j=1,t_jm
       rlo(j)=dzrsq/(1.-.5_rq*t_dr/t_r(j))
       rup(j)=dzrsq/(1.+.5_rq*t_dr/t_r(j))
       rdi(j)=2._rq+rup(j)+rlo(j)
    END DO
    !
    ! calculate resid = del-star t_psi - rhs
    n=1
    t_resid=0.
    resid1=0.
    dnrm=0.0
    jbeg=2
    jend=t_km-1
    DO k=2,t_km-1
       IF(t_ierr1==1) THEN ! test on plasma current only
          jbeg=s_jbl(k)
          jend=s_jbu(k)
          n=t_jm*(k-1)+jbeg-1
       END IF
       DO j=jbeg,jend
          n=n+1
          delpsi=(t_psi(n-t_jm)+rlo(j)*t_psi(n-1)-rdi(j)*t_psi(n)+rup(j)*&
               t_psi(n+1)+t_psi(n+t_jm))/t_dz**2
          dnrm=dnrm+abs(delpsi)
          resid1=resid1+abs(delpsi-t_crj(n)-t_clj(n))
          t_resid=t_resid+abs(delpsi-crjr(n))
       END DO
    END DO
    IF(t_ierr1==0) t_resid=resid1
    t_resid=t_resid/dnrm
    !
    ! calculate error = t_psi - psiold
    t_error=0.
    pnrm=0.0
    t_error=SUM(abs(t_psi-psir))/SUM(abs(t_psi))
    ! calculate residj = j - jold
    IF(t_nitr/=0) THEN
       t_residj=sum(abs(t_crj-crjr))/sum(abs(t_crj))
    END IF
    psir=t_psi
    crjr=t_crj
  END SUBROUTINE gs_errors

  SUBROUTINE gs_intcls
    INTEGER ::  j,k,n
    DO  n=1,t_ncf
       t_intc(n) = 0
       IF(t_rcf(n)>=t_rn .AND. t_rcf(n)<=t_rx .AND. t_zcf(n)>=t_zn .AND.&
            t_zcf(n)<=t_zx) THEN
          t_intc(n) = 1
          DO j=1,t_jm
             IF(t_r(j)>=t_rcf(n)) EXIT
             t_jnt(n) = j
          END DO
          DO  k=1,t_km
             IF(t_z(k)>=t_zcf(n)) EXIT
             t_knt(n) = k
          END DO
       END IF
    END DO
  END SUBROUTINE gs_intcls

  SUBROUTINE gs_plbdry
    REAL(rq) ::  dth,th,dthu,dthl
    INTEGER i,n,nuu,nll
    IF(t_nbd==0) RETURN
    !
    IF(t_ibdry==0) THEN
       DO  i=1,t_nbd
          IF( t_zbd(i)<0 .AND. t_nsym<2 )&
               CALL errdetec("Plbdry error: symmetric case with zbd < 0",1)
       END DO
    ELSEIF( t_ibdry==1 ) THEN
       dth=Pi/t_nbd
       IF(t_nsym==2) dth=2*dth
       DO n=1,t_nbd
          th=(n-1)*dth + t_dtofst
          t_tbd(n)=th
          IF(th<=Pi) THEN
             t_rbd(n)=t_ro+t_rfix*cos(th+t_dbdu*sin(th)+t_queu*sin(2*th))&
                  +t_bbdu*t_rfix*cos(2*th)-t_rfix*t_bbdu
             t_zbd(n)=t_rfix*t_ebdu*sin(th)
          ELSE
             t_rbd(n)=t_ro+t_rfix*cos(th+t_dbdl*sin(th)+t_quel*sin(2*th))+&
                  t_bbdl*t_rfix*cos(2*th)-t_rfix*t_bbdl
             t_zbd(n)=t_rfix*t_ebdl*sin(th)
          END IF
       END DO
    ELSE
       IF( t_nsym/=2 ) CALL errdetec(&
            "plbdry: found t_nsym/=2 with asymmetric plbdry points.",1)
       dthu=Pi/t_nbdu
       dthl=Pi/t_nbdl
       n=0
       th=0.0
       DO nuu=1,t_nbdu
          n=n+1
          th=th+dthu
          t_rbd(n)=t_ro+t_rfix*cos(th+t_dbdu*sin(th)+t_queu*sin(2._rq*th))+&
               t_bbdu*t_rfix*cos(2._rq*th)-t_rfix*t_bbdu
          t_zbd(n)=t_rfix*t_ebdu*sin(th)
       END DO
       DO  nll=1,t_nbdl
          n=n+1
          th=th+dthl
          t_rbd(n)=t_ro+t_rfix*cos(th+t_dbdl*sin(th)+t_quel*sin(2._rq*th))+&
               t_bbdl*t_rfix*cos(2._rq*th)-t_rfix*t_bbdl
          t_zbd(n)=t_rfix*t_ebdl*sin(th)
       END DO
       IF( t_nbd/=n ) CALL errdetec("plbdry: t_nsym=2, t_nbd ne n",1)
    END IF
  END SUBROUTINE gs_plbdry

  SUBROUTINE gs_curmag
    include "debug.i"
    !
    ! Compute magnetization current in ferromagnetic coils.
    ! (Recalculation of Green functions can be forced by changing ngp
    ! or setting ncfo=0.)
    !
    ! n.b.: coils that are one filament "high" and > one filament
    ! "wide" [nzc(n)==1& nrc(n)>1] are not done correctly.
    !

    INTEGER :: i,j,jk,jkl,k,kl,l,n,nhi,nhim,nlo,nlom,loom,loop
    INTEGER :: kk,jj,ll,mm,nn,k1,k2,l1,l2,ir,iz
    REAL(rq) ::  bcmag,bmr,bmz,mag,brr,bzz
    
    nlo=1 
    nlom=1 
    mm=0
    DO k=1,t_ncf
       t_ccmf(k)=0.
    END DO
    DO n=1,t_ncplot/(3-t_nsymc)
       nhi=t_loop0(n)
       nhim=t_loopm(n)
       IF(t_iferro(n) == 1) THEN
          ! Compute b_r, b_z from plasma at center of "filament" faces 
          kl=t_km
          IF (t_nsym <= 1) kl=t_km/2+1
          jkl=t_jm*kl
          loop=mm
          DO kk=nlo,nhi
             mm=mm+1
             brr=0.
             bzz=0.
             DO jk=1,jkl ! contribution from plasma current
                brr=brr - t_gfbr(jk,1,mm)*t_crj(jk)
                bzz=bzz - t_gfbz(jk,1,mm)*t_crj(jk)
             END DO
             t_br0p(mm)=1.0e-04_rq*brr*t_dr*t_dz/FOURPI ! MKS
             t_bz0p(mm)=1.0e-04_rq*bzz*t_dr*t_dz/FOURPI
          END DO
          ! Now we get field at center of faces and store in bzgp etc.
          ! loom=nlom-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)=0.5_rq*(t_br0p(loop)+t_br0p(loop+1))
                t_bzgp(loom)=0.5_rq*(t_bz0p(loop)+t_bz0p(loop+1))
                IF(ir/=t_nrc(n)) THEN
                   ! Stores fields at right inside face in t_bz0p, etc
                   t_br0p(loop)=0.5_rq*(t_br0p(loop)+t_br0p(loop+t_nzc(n)+2))
                   t_bz0p(loop)=0.5_rq*(t_bz0p(loop)+t_bz0p(loop+t_nzc(n)+2))
                END IF
             END DO
             loop=loop+1
             ! Store field on top, overwrites incorrect value
             t_brgp(loom)=t_br0p(loop)
             t_bzgp(loom)=t_bz0p(loop)
             IF(ir/=t_nrc(n)) loop=loop-t_nzc(n)-1 !  reset count  
          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 move to t_bzgp etc
          DO l=nlom,nhim
             bmr=t_brgp(l) ! plasma contribution
             bmz=t_brgp(l) 
             nn=0
             l1=1
             DO k=1,t_nc/(3-t_nsymc)   ! contribution from coil currents
                IF(t_iferro(k)==1) THEN
                   DO ll=l1,t_loop0(k)
                      nn=nn+1
                      bmr=bmr+t_gsbr(nn,l)*t_ccf(ll)  
                      bmz=bmz+t_gsbz(nn,l)*t_ccf(ll)
                   END DO
                ELSE
                   nn=nn+1
                   bmr=bmr+t_gsbr(nn,l)*t_cc(k)  
                   bmz=bmz+t_gsbz(nn,l)*t_cc(k)
                END IF
                l1=t_loop0(k)+1
             END DO
             t_brgp(l)=bmr ! total poloidal field at faces
             t_bzgp(l)=bmz
          END DO
          DO l=nlom,nhim
             bcmag=sqrt(t_brgp(l)**2+t_bzgp(l)**2)
             mag=t_magfac*tanh(bcmag/t_bsat)/bcmag
             t_bzgp(l)=mag*t_dzc(n)/t_nzc(n)*t_bzgp(l) ! for line integeral
             t_brgp(l)=mag*t_drc(n)/t_nrc(n)*t_brgp(l)
          END DO
          ! compute t_ccmf, the magnetization current
          IF(ndbg3==0) THEN
             loop=nlo-1
             loom=nlom-1
             DO iz=1,t_nzc(n)
                loop=loop+1
                loom=loom+1
                t_ccmf(loop)=-t_bzgp(loom)
             END DO
             DO ir=1,t_nrc(n)
                IF(ir/=1) loom=loom+t_nzc(n)
                loop=loop+1
                t_ccmf(loop)=t_brgp(loom+1)
                DO iz=1,t_nzc(n)
                   loop=loop+1
                   loom=loom+1
                   t_ccmf(loop)=-t_brgp(loom)+t_brgp(loom+1)-t_bzgp(loom+&
                        t_nzc(n)+1)+t_bzgp(loom-t_nzc(n))
                END DO
                loop=loop+1
                loom=loom+1
                t_ccmf(loop)=-t_brgp(loom)
             END DO
             DO iz=1,t_nzc(n)
                loop=loop+1
                loom=loom+1
                t_ccmf(loop)=t_bzgp(loom)
             END DO
          ELSE ! kaiser's
             nn=t_nzc(n)    ! internal filaments
             l=nlom-2  
             k=nlo+nn-2
             DO i=1,t_nrc(n)
                k=k+2
                l=l+nn+1
                DO j=1,nn
                   k=k+1
                   l=l+1
                   t_ccmf(k)=t_bzgp(l-nn)-t_bzgp(l+nn+1)+t_brgp(l+1)-t_brgp(l)
                END DO
             END DO
             k1=nlo-1    ! surface filaments
             k2=nhi+1    ! vertical edges:
             l1=nlom-1
             l2=nhim+1
             DO j=1,nn
                t_ccmf(k1+j)=-t_bzgp(l1+j)  ! left
                t_ccmf(k2-j)= t_bzgp(l2-j)  ! right
             END DO
             k1=nlo+nn   ! horizontal edges:
             k2=k1+nn+1
             l1=nlom+nn
             l2=l1+nn
             DO i=1,t_nrc(n)
                t_ccmf(k1)= t_brgp(l1)   ! bottom
                t_ccmf(k2)=-t_brgp(l2)   ! top
                k1=k1+nn+2
                k2=k2+nn+2
                l1=l1+2*nn+1
                l2=l2+2*nn+1
             END DO
          END IF             
       ELSE
          mm=mm+1
       END IF  ! t_iferro(n)=1
       nlo=nhi+1
       nlom=nhim+1
    END DO   ! n=1,t_ncplot/(3-t_nsymc)
    IF(t_nsymc == 1)THEN  ! set lower-half mag current IF up/down symmetric
       DO k=t_ncf/2+1,t_ncf
          t_ccmf(k)=t_ccmf(k-t_ncf/2)
       ENDDO
    END IF  ! t_nsymc=1
  END SUBROUTINE gs_curmag

  SUBROUTINE gs_separatrix
    CALL separatrix_separatrix(t_r,t_z,t_psi,t_rxpr,t_zxpr,t_rlimm,t_zlimm,&
         i_tswpts,t_rls,t_zls,t_psix,t_raxis,t_zaxis,t_psil,t_pxpt,t_rxpt,&
         t_zxpt,t_ixp,t_nsym,t_wvert,t_theta,t_n4)
    CALL boundary_separatrix(t_ipf,t_jwl,t_jwu,s_lxpt)
    t_br= -i_cps(:,1,2)/t_rm
    t_bz=  i_cps(:,2,1)/t_rm
    t_bp=  sqrt(t_br**2+t_bz**2)
    t_bmod=sqrt(t_bt**2+t_bp**2)
END SUBROUTINE gs_separatrix
  
  SUBROUTINE initsi
    REAL(rq) ::  rclplas(4),zclplas(4),fl(t_jmkm),flr(t_jmkm),flz(t_jmkm),&
         zbsq,tloc,delps,psisl,psisu,expt2,zksq,pis
    INTEGER :: j,k,n,m4
    !
    !     initialize the solution (psi)
    !

    IF(t_initflx==0 ) THEN
       !   Strickler i.c.
       n=1
       DO k=1,t_km
          zksq=(t_z(k)/(t_r(1)-t_ro)/t_elx)**2
          DO j=1,t_jm
             t_psi(n)=t_psix*(1.-zksq-((t_r(j)-t_ro)/(t_r(1)-t_ro))**2)
             n=n+1
          END DO
       END DO
    ELSEIF(t_initflx==1) THEN
       !   models plasma as filament
       tloc = .5_rq*(t_r(t_jm/2+1) + t_r(t_jm/2+2))
       rclplas(1) = tloc+t_dr
       rclplas(2) = tloc-t_dr
       rclplas(3) = tloc
       rclplas(4) = tloc
       zclplas(1) = 0.
       zclplas(2) = 0.
       zclplas(3) = t_ebdu*t_dr
       zclplas(4) = -t_ebdu*t_dr          ! dipole current not in yet
       m4=4
       IF(t_ebdu==1.0) m4=1
       pis=0
       DO j = 1,m4
          CALL mutual_utils(t_rm,t_zm,rclplas(j),zclplas(j),fl,flr,flz,1)
          t_psi=t_psi+fl/m4
       END DO
       !   smooth at axis or large psi causes trouble
       DO  k = t_km/2-1,t_km/2+3
          psisl=t_psi(t_jm*(k-1)+t_jm/2-1)
          psisu=t_psi(t_jm*(k+3)+t_jm/2+3)
          DO j = t_jm/2-1,t_jm/2+3
             n = (k-1)*t_jm + j
             delps=.25_rq*(psisu-psisl)*(j-t_jm/2+1)
             t_psi(n)=psisl+delps
          END DO
       END DO
       tloc = t_psi((t_km/2)*t_jm+1)
       CALL gs_psiext
       t_psi=-20*(t_psi-tloc)/t_plcm+t_psiw
    ELSEIF(t_initflx==2) THEN
       !   has symmetric x-points, elongation t_ebdu at psi-psi_axis=psil-psix,
       !   no triangularity; psil encloses finit2*(pxpt-paxis)
       expt2 = t_ebdu**2*t_finit2/(1-SQRT(1-t_finit2))
       DO k=1,t_km
          zksq = t_finit2/(t_rb*expt2)**2*(t_z(k)**2-expt2*t_rb**2/t_finit2)**2
          DO j=1,t_jm
             t_psi((k-1)*t_jm+j) = (t_r(j)-t_ro)**2 - zksq
          END DO
       END DO
       tloc = t_psi((t_km/2)*t_jm+1)
       t_psi=(t_psi-tloc)*(t_psil-t_psix)/t_rb**2
    ELSEIF(t_initflx==3) THEN
       !   asymmetric, single x-point, enclosing psil-psix
       IF(t_nsym/=2) CALL errdetec("initsi: t_nsym/=2, flux t_ic asymmetric",1)
       tloc = t_rb*(t_ebdu+t_ebdl)/2
       DO k=1,t_km
          zksq = 27._rq/32._rq*(t_z(k)-tloc)*(t_z(k)**2-tloc**2)/tloc**3
          DO j=1,t_jm
             t_psi((k-1)*t_jm+j) = (t_r(j)-t_ro)**2/t_rb**2 - zksq
          END DO
       END DO
       tloc = t_psi((t_km/2)*t_jm+1)
       t_psi=(t_psi-tloc)*(t_psil-t_psix)
    ELSEIF(t_initflx==4) THEN
       IF(t_keqic==3) THEN
          t_psi=t_psi01
       ELSE
          t_psi=t_psi00
       END IF
    ELSE
       CALL errdetec("Bad value of t_initflx in initsi",1)
    END IF
  END SUBROUTINE initsi

  SUBROUTINE setpfc
    REAL(rq) :: geom,sumr,sumz,sumg
    INTEGER :: icm,n,i,ii,j,jj,ll,m,l1,nn,ncu,kk,nnn,i1,mm,j1,j2,i2,k

    ! IF anything important has changed, set the flags (lgrn=0) to
    ! update the Greens functions...

    geom=SUM(t_rc+SQRT(t_zc**2)+t_drc+t_dzc+t_ac**2+t_ac2**2)
    IF (abs(geom-t_geomo) > 100*errt_rq*geom .AND. t_geomo/=-999) THEN
       t_lgrn=t_kgreenc
       t_ncfo=0
    END IF
    t_geomo= geom

    ! Enforce up/down symmetry, IF requested...

    IF (t_nsymc == 1) THEN
       ncu= t_nc/(3 - t_nsymc)
       DO n=1,ncu
          m=ncu+n
          IF (t_pfid(m) == ' ') t_pfid(m)= t_pfid(n)
          t_rc(m)=    t_rc(n)
          t_zc(m)=   -t_zc(n)
          t_drc(m)=   t_drc(n)
          t_dzc(m)=   t_dzc(n)
          t_ac(m)=   -t_ac(n)
          t_ac2(m)=  -t_ac2(n)
          t_cc(m)=    t_cc(n)
          t_nrc(m)=   t_nrc(n)
          t_nzc(m)=   t_nzc(n)
          t_ic(m)=    t_ic(n)
          t_icc(m)=   t_icc(n)
          t_ix(m)=    t_ix(n)
          t_svec(m)=  t_svec(n)
          t_iferro(m)=t_iferro(n)
          t_icn(m)=   t_icn(n)
          t_pfps0(m)= t_pfps0(n)
          DO i=1,6 ! beware this is hard wired for now
             t_gdc(m,i)= t_gdc(n,i)
          END DO
       END DO
    END IF

    ! Sets up 100*t_rc etc for gradsh.m
    DO n=1,t_nc
       t_rxc(n)=TWOPI*1.e+6*t_rhc(n)*t_rc(n)/t_drc(n)/t_dzc(n)+t_rextc(n)
    END DO

    ! Set the search length for the critical coil...

    IF (t_nfjx > t_nc/(3-t_nsymc)) t_nfjx= t_nc/(3-t_nsymc)

    ! Discretize the coils into unIFormly distributed filaments...

    CALL t_corners(t_rc,t_zc,t_drc,t_dzc,t_ac,t_ac2,t_rc4,t_zc4)
    CALL fe_quad
    !
    !      get coil-to-coil Greens functions for solid coils
    !
    IF(t_ngp/=0 .AND. t_ngp/=t_ngpo) THEN

       DO n=1,t_nc0p*t_nbs
          t_gsbr(n,1)=0
          t_gsbz(n,1)=0
       END DO
       t_ngpo=t_ngp
       DO j=1,t_nbs
          CALL bcoil(t_ncf,t_rcmf,t_zcmf,t_drcf,t_dzcf,t_ccf,t_dfac,t_rgp(j),&
               t_zgp(j),t_rcs,t_zcs)
           l1=1
          nn=0
          DO i=1,t_nc/(3-t_nsymc)
             sumr=0
             sumz=0
             IF(t_iferro(i)==1) THEN
                DO ll=l1,t_loop0(i)
                   nn=nn+1
                   IF(t_nsymc==2) THEN
                      t_gsbr(nn,j)=t_rcs(ll)/t_ccf(ll)
                      t_gsbz(nn,j)=t_zcs(ll)/t_ccf(ll)
                   ELSE
                      kk=ll+t_ncf/2
                      t_gsbr(nn,j)=t_rcs(ll)/t_ccf(ll)+t_rcs(kk)/t_ccf(kk)
                      t_gsbz(nn,j)=t_zcs(ll)/t_ccf(ll)+t_zcs(kk)/t_ccf(kk)
                   END IF
                END DO
             ELSE
                nn=nn+1
                DO ll=l1,t_loop0(i)
                   IF(t_nsymc==2) THEN
                      sumr=sumr+t_rcs(ll)
                      sumz=sumz+t_zcs(ll)
                   ELSE
                      kk=ll+t_ncf/2
                      sumr=sumr+t_rcs(ll)+t_rcs(kk)
                      sumz=sumz+t_zcs(ll)+t_zcs(kk)
                   END IF
                END DO
                t_gsbr(nn,j)=sumr/t_cc(i)
                t_gsbz(nn,j)=sumz/t_cc(i)
             END IF
             l1=t_loop0(i)+1
          END DO
       END DO
       nnn=0
       i1=1
       DO i=1,t_nc/(3-t_nsymc)
          mm=0
          j1=1
          DO j=1,t_nc/(3-t_nsymc)
             sumg=0
             j2=1
             IF(t_iferro(j)==1) j2=t_loop0(j)-j1+1
             DO jj=1,j2
                mm=mm+1
                i2=1
                IF(t_iferro(i)==1) i2=t_loop0(i)-i1+1
                nn=nnn
                DO ii=i1,i2
                   nn=nn+1
                   sumg=sumg+SUM(t_gsbr(nn,:)*t_gsbr(mm,:)+t_gsbz(nn,:)*&
                        t_gsbz(mm,:))
                END DO ! ii loop
             END DO ! jj loop
             t_pbim(i,j)=sumg/(t_nbs*i2*j2)
          END DO ! j loop
          nnn=nn
       END DO
    END IF
    !
    ! get grid to filament Greens functions
    !
    IF(t_kgreenc==1 .AND. t_lgrn==t_kgreenc) THEN !  get Greens functions
       CALL teqGS_interface
       CALL grnfcnst
       t_lgrn=0
    END IF
    IF(t_magfac /= 0.)THEN  ! add magnetization current IF necessary
       icm=1
       DO k=1,t_ncf
          IF(t_ccmf(k) /= 0.)THEN
             icm=0.
             EXIT
          END IF  ! t_ccmf(k)/=0
       END DO
       IF(icm == 1)CALL gs_curmag
       DO k=1,t_ncf
          t_ccf(k)=t_ccf(k)+t_ccmf(k)
       END DO
    END IF  ! t_magfac/=0
  END SUBROUTINE setpfc

  SUBROUTINE setcls
    REAL(rq) :: thl,thh
    INTEGER :: nch,n
    t_cnorm=0.5*ABS(t_plcm)
    !
    !     initialize coil locations, currents if t_ncf=0
    !
    IF(t_ncf/=0) return
    t_ncf=t_ncoil
    IF(t_rocoil<=0.0) t_rocoil=t_ro
    IF(t_rbcoil<=0.0) t_rbcoil=t_rb+0.4_rq*t_rn
    IF(t_elcoil<=0.0) t_elcoil=0.8_rq*t_el
    thl=0.25_rq*TWOPI
    thh=0.35_rq*TWOPI
    nch=t_ncf/2
    t_ncf=nch*2
    t_ncs=t_ncf
    CALL cpts(0.0_rq,TWOPI)
    DO n=1,t_ncf
       t_rcf(n)=t_rcs(n)
       t_zcf(n)=t_zcs(n)+t_zocoil
       t_ccf(n)=20.0*t_ccoil/abs(t_plcm)
       IF(t_ths(n)>=thl .AND. t_ths(n)<thh) t_ccf(n)=-t_ccf(n)
       IF(t_ths(n)>=TWOPI-thh .AND. t_ths(n)<TWOPI-thl) t_ccf(n)=-t_ccf(n)
       t_icf(n)=n
       IF(t_nsym==1 .AND. n>nch) t_icf(n)=t_ncf-n+1
    END DO
  END SUBROUTINE setcls

  SUBROUTINE t_corners(x,y,dx,dy,a,a2,x4,y4)
    REAL(rq), DIMENSION(:), INTENT(IN) ::  x,y,dx,dy,a,a2
    REAL(rq), DIMENSION(:,:), INTENT(OUT) :: x4,y4

    !     Derived from splitc2.for to translate EFIT type parallelogram
    !     (or rectangular) coil sections into corner coordinates for
    !     subsequent discretization by fe_quad.
    !     Jim Leuer, General Atomics, 10-11-94 <leuer@gav.gat.com>
    REAL(rq) :: tana(SIZE(x))
    INTEGER :: n
    n=SIZE(x)
    x4(1,:n)= x(:n) - 0.5_rq*dx(:n)
    x4(2,:n)= x(:n) + 0.5_rq*dx(:n)
    x4(3,:n)= x4(2,:n)
    x4(4,:n)= x4(1,:n)
    y4(1,:n)= y(:n) - 0.5_rq*dy(:n)
    y4(2,:n)= y4(1,:n)
    y4(3,:n)= y(:n) + 0.5_rq*dy(:n)
    y4(4,:n)= y4(3,:n)
    WHERE(a(:n)/=0)   ! Type 1 parallelogram
       tana(:n)= tan(a(:n))
       y4(1,:n)= y(:n) - 0.5_rq*dx(:n)*tana(:n) - 0.5_rq*dy(:n)
       y4(2,:n)= y(:n) + 0.5_rq*dx(:n)*tana(:n) - 0.5_rq*dy(:n)
       y4(3,:n)= y4(2,:n) + dy(:n)
       y4(4,:n)= y4(1,:n) + dy(:n)
    END WHERE
    WHERE(a2(:n)/= 0) ! Type 2 parallelogram
       tana(:n)= tan(a2(:n))
       x4(1,:n)= x(:n) - 0.5_rq*dy(:n)/tana(:n) - 0.5_rq*dx(:n)
       x4(4,:n)= x(:n) + 0.5_rq*dy(:n)/tana(:n) - 0.5_rq*dx(:n)
       x4(2,:n)= x4(1,:n) + dx(:n)
       x4(3,:n)= x4(4,:n) + dx(:n)
    END WHERE
  END SUBROUTINE t_corners

  SUBROUTINE fe_quad

!     Computes the centers of a regular sub-grid within a linear
!     quadrilateral (4 sided) finite element.  The routine takes the
!     coordinates of the 4 corners of the quadrilateral (rc4,t_zc4)
!     and splits the region into a nrc by nzc sub-grid. The grid is
!     uniform and the center is located halfway between grids.  The
!     routine locates the center of each sub-grid and loads the
!     centers into t_rcf,zcf.  Its structure is such that it can be
!     easily increased to higher order quadrilateral elements.
!     Jim Leuer, General Atomics, 10-11-94, <leuer@gav.gat.com>

    REAL(rq), SAVE ::  dsurfo
    INTEGER :: n,loop,j,k,l
    REAL(rq) :: dsur,ddr,ddz,fdx,fdy,fcc,rcin,rcout,zcbot,zctop,xm,xp,x12,&
         x34,y12,y34,ddc,ym,yp,fcx,fcy

    IF(t_dsurf/=dsurfo) then ! surface magnetization storage fix
       t_ngpo=0
       dsurfo=t_dsurf
    END IF
    loop=0
    dsur=.01_rq*t_dsurf !  MKS 
    DO n=1,t_nc
       ddr= t_drc(n)/t_nrc(n)
       ddz= t_dzc(n)/t_nzc(n)
       fdx= 2.0_rq/t_nrc(n)
       fdy= 2.0_rq/t_nzc(n)
       fcc= 1.0_rq/t_nrc(n)/t_nzc(n)
       IF(t_iferro(n)==1) THEN
          rcin= t_rc(n)-0.5_rq*(t_drc(n)+dsur)
          rcout=t_rc(n)+0.5_rq*(t_drc(n)+dsur)
          zcbot= t_zc(n)-0.5_rq*(t_dzc(n)+dsur)
          zctop=t_zc(n)+0.5_rq*(t_dzc(n)+dsur)
          DO k=1,t_nzc(n)
             loop=loop+1
             t_drcf(loop)= dsur
             t_dzcf(loop)= ddz
             t_ccf(loop)=  errt_rq
             t_rcmf(loop)=  rcin
             t_zcmf(loop)=  t_zc(n)-0.5*t_dzc(n)+ddz*(k-0.5)
             t_rcf(loop)= 100*t_rcmf(loop)
             t_zcf(loop)= 100*t_zcmf(loop)
          END DO
       END IF
       DO j=1,t_nrc(n)
          fcx= fdx*(j - 0.5_rq) - 1.0_rq
          xm=  1.0_rq - fcx
          xp=  1.0_rq + fcx
          x12= t_rc4(1,n)*xm + t_rc4(2,n)*xp
          x34= t_rc4(3,n)*xp + t_rc4(4,n)*xm
          y12= t_zc4(1,n)*xm + t_zc4(2,n)*xp
          y34= t_zc4(3,n)*xp + t_zc4(4,n)*xm
          ddc=1.0;IF(j<7) ddc=(1.0 + t_gdc(n,j))
          IF(t_iferro(n)==1) THEN
             loop=       loop+1
             t_drcf(loop)= ddr
             t_dzcf(loop)= dsur
             t_ccf(loop)=  errt_rq
             t_rcmf(loop)=  t_rc(n)-0.5_rq*t_drc(n)+ddr*(j-0.5_rq)
             t_zcmf(loop)=  zcbot
             t_zcf(loop)= 100*t_zcmf(loop)
             t_rcf(loop)= 100*t_rcmf(loop)
          END IF
          DO k=1,t_nzc(n)
             loop=       loop + 1
             fcy=        fdy*(k - 0.5_rq) - 1
             ym=         1 - fcy
             yp=         1 + fcy
             t_rcmf(loop)= 0.25_rq*(ym*x12 + yp*x34)
             t_zcmf(loop)= 0.25_rq*(ym*y12 + yp*y34)
             t_rcf(loop)=  100*t_rcmf(loop)
             t_zcf(loop)=  100*t_zcmf(loop)
             t_drcf(loop)= ddr
             t_dzcf(loop)= ddz
             t_ccf(loop)=  fcc*t_cc(n)*ddc
             t_icf(loop)=  t_ic(n)
             t_icnf(loop)= n
          END DO
          IF(t_iferro(n)==1) THEN
             loop=loop+1
             t_drcf(loop)= ddr
             t_dzcf(loop)= dsur
             t_ccf(loop)=  errt_rq
             t_rcmf(loop)=  t_rc(n)-0.5_rq*t_drc(n)+ddr*(j-0.5_rq)
             t_zcmf(loop)=  zctop
             t_zcf(loop)= 100*t_zcmf(loop)
             t_rcf(loop)= 100*t_rcmf(loop)
          END IF
       END DO
       IF(t_iferro(n)==1) THEN
          DO k=1,t_nzc(n)
             loop=loop+1
             t_drcf(loop)= dsur
             t_dzcf(loop)= ddz
             t_ccf(loop)=  errt_rq
             t_rcmf(loop)=  rcout
             t_zcmf(loop)=  t_zc(n)-0.5_rq*t_dzc(n)+ddz*(k-0.5_rq)
             t_rcf(loop)= 100*t_rcmf(loop)
             t_zcf(loop)= 100*t_zcmf(loop)
          END DO
       END IF
       t_loop0(n)= loop
    END DO
    !   symmetrize if t_nsymc=1
    IF(t_nsymc==1) THEN
       loop=t_ncf/2 
       DO l=1,loop
          t_drcf(l+loop)= t_drcf(l)
          t_dzcf(l+loop)= t_dzcf(l)
          t_rcf(l+loop) = t_rcf(l)
          t_zcf(l+loop) =-t_zcf(l)
          t_rcmf(l+loop)= t_rcmf(l)
          t_zcmf(l+loop)=-t_zcmf(l)
          t_ccf(l+loop) = t_ccf(l)
       END DO
       DO n=1,t_nc/2
          t_loop0(n+t_nc/2)=loop+t_loop0(n)
       END DO
    END IF
  END SUBROUTINE fe_quad

  SUBROUTINE cpts(thmin,thmax)
    REAL(rq), EXTERNAL ::  zeroin_c,qfun,zfun2
    REAL(rq) :: thmin,thmax,abserr,flag,alt,errest,dalt
    INTEGER :: nofun,n
    abserr=0.0
    x_l=t_rocoil
    a_ll=t_rbcoil
    s_l=t_elcoil
    d_l=t_dcoil
    q_l=t_qcoil
    call quanc8(qfun,thmin,thmax,abserr,errt_rq,alt,errest,nofun,flag)
    a_lmax=alt
    dalt=a_lmax/t_ncs
    a_ln=0.5*dalt
    DO n=1,t_ncs
       t_ths(n)=zeroin_c(thmin,thmax,zfun2,errt_rq)
       t_rcs(n)=x_l+a_ll*cos(t_ths(n)+d_l*sin(t_ths(n))+q_l*sin(2.0*t_ths(n)))
       t_zcs(n)=a_ll*s_l*sin(t_ths(n))
       a_ln=a_ln+dalt
    END DO
  END SUBROUTINE cpts

  FUNCTION sumxpy(x,y,n) RESULT(z)
    INTEGER, INTENT(IN) :: n
    REAL(rq),DIMENSION(n), INTENT(IN) :: x,y
    REAL(rq) :: z
    z=SUM(x(:n)*y(:n))
  END FUNCTION sumxpy
END MODULE gradsh_mod

SUBROUTINE cofx(x,afun,bfun,cfun)
  USE sep_utils
  REAL(rq) ::  x,afun,bfun,cfun
  afun=1.0
  bfun=-1.0/x
  cfun=0.0
END SUBROUTINE cofx

FUNCTION qfun(x) RESULT(qfu)
  USE gradsh_mod
  IMPLICIT NONE
  REAL(rq), INTENT(IN) :: x
  REAL(rq) :: drs,dzs,qfu
  drs=-a_ll*(1.0+d_l*cos(x)+2.0*q_l*cos(2.0*x))*sin(x+d_l*sin(x)+q_l*&
       sin(2.0*x))
  dzs=a_ll*s_l*cos(x)
  qfu=SQRT(drs**2+dzs**2)
END FUNCTION qfun

FUNCTION zfun2(x) RESULT(zfu)
  USE gradsh_mod
  IMPLICIT NONE
  REAL(rq), INTENT(IN) :: x
  REAL(rq), EXTERNAL :: qfun
  REAL(rq) :: zfu,abserr,errest,flag,thmin,alx
  INTEGER :: nofun
  abserr=0.0
  thmin = 0.0
  CALL quanc8(qfun,thmin,x,abserr,errt_rq,alx,errest,nofun,flag)
  zfu=alx-a_ln
END FUNCTION zfun2
