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

Module setTeq_mod

  USE gradsh_mod
  USE teqSubs_mod, only : t_stretch

  IMPLICIT NONE

  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE :: psave_,fsave_,psibar_,&
       qsave_,jtsave_,jpsave_,w_,v_,r_,z_,ssave_
  INTEGER, PRIVATE :: nsvd
  DATA nsvd/0/

CONTAINS

  SUBROUTINE getstrg(kstr)
    INTEGER, INTENT(IN) :: kstr
    INTEGER, SAVE :: msrfo,lsrfo,npolyo,jmo,kmo,mlso,nsolo,nprio,lmaxo,limlo,&
         nspho,nfbdo,ngroupo,jqmo,ncpp,nbevmo,nco,n4o,n6o,nloopo
    REAL(rq), SAVE :: hsrfo,elo, rbo, roo, rno, rxo, zxo
    DATA msrfo/1/,lsrfo/-111/,npolyo/0/,jmo/0/,kmo/0/,mlso/0/,hsrfo/-1/,&
         nsolo/0/,nprio/0/,lmaxo/0/,nspho/0/,ngroupo/0/,nco/-1/,elo/0./,&
         rbo/0./,roo/-1234./,rno/-1234./,rxo/-1234./,n4o/6/,n6o/6/,     &
         zxo/-1234./,jqmo/0/,nloopo/0/,ncpp/0/
    INTEGER imth,l1,l2,i,nn,newcellsz,msrfx
    data imth /0/ ! extrapolates 1st derivative
    REAL(rq) :: psilor(t_msrf-1),yy
    REAL(rq), DIMENSION(t_msrf) :: c1
    integer :: sz

    c1=0
    IF(kstr==1) THEN
       ! For rezone: needed here and at the end of kstr=1
       IF(msrfo==t_msrf) THEN
          IF(SIZE(psave_)/=msrfo) THEN
             IF(ALLOCATED(psave_)) DEALLOCATE(psave_,fsave_,qsave_,&
                  jtsave_,jpsave_,psibar_,w_,v_,ssave_)
             ALLOCATE(psave_(msrfo),fsave_(msrfo),qsave_(msrfo),&
                  jtsave_(msrfo),jpsave_(msrfo),psibar_(msrfo),w_(msrfo),&
                  v_(msrfo),ssave_(msrfo))
          END IF
          psave_=t_psave(:msrfo)
          fsave_=t_fsave(:msrfo)
          qsave_=t_qsave(:msrfo)
          jtsave_=t_jtsave(:msrfo)
          jpsave_=t_jparsave(:msrfo)
          jtsave_=t_jtsave(:msrfo)
          psibar_=t_psibar(:msrfo)
          ssave_= t_ssave(:msrfo)
          w_=t_w(:msrfo)
          v_=t_v(:msrfo)
        END IF
       !
       IF(t_map==0) t_map=64
       t_lmax=2*t_map-1
       t_mls=2*t_map-1
       IF(t_nsym==1) t_lmax=t_map
       IF(t_msrf/=msrfo .OR. t_lsrf/=lsrfo .OR. t_hsrf/=hsrfo) THEN
          CALL teq_interface
          CALL t_stretch(t_lsrf,t_psil,t_psix)
          IF(t_ifluxcord==-1) THEN
             CALL fdInt(1.0/t_qsave,t_phibar,t_msrf,t_qh)
             t_psibar=t_qh/t_qh(t_msrf)
             t_dphi00=t_dpsi0/t_qh(t_msrf)
          END IF
          i_psibar=>t_psibar
          psilor=t_psiinv(2:)
          CALL polymatrix(t_psibar,t_dpoly,t_spoly,t_mpoly)
          CALL polymatrix(psilor,t_dpoli,t_spoli,t_mpoli)
          npolyo=t_npoly
          IF(msrfo/=1) THEN
             yy=t_splbdry
             CALL interp_interp(psibar_,psave_,yy,yy,t_psibar,t_psave,c1)
             CALL interp_interp(psibar_,fsave_,yy,yy,t_psibar,t_fsave,c1)
             CALL interp_interp(psibar_,qsave_,yy,yy,t_psibar,t_qsave,c1)
             CALL interp_interp(psibar_,jtsave_,yy,yy,t_psibar,t_jtsave,c1)
             CALL interp_interp(psibar_,jpsave_,yy,yy,t_psibar,t_jparsave,c1)
             CALL interp_interp(psibar_,ssave_,yy,yy,t_psibar,t_ssave,c1)
             IF(t_ipp==999) THEN
                CALL interp_interp(psibar_,v_,yy,yy,t_psibar,t_v,c1)
             END IF
             IF(t_ipf==999) THEN
                CALL interp_interp(psibar_,w_,yy,yy,t_psibar,t_w,c1)
             END IF
             t_qsrf=t_qsave
             t_frsrf=t_fsave
             t_prsrf=t_psave
          ELSEIF(t_frsrf(1)==0) THEN
             t_frsrf=t_fsave
          END IF
          msrfo=t_msrf
          msrfx=t_msrf+1
       END IF
       IF(t_npoly/=npolyo) THEN
          CALL teq_interface
          psilor=t_psiinv(2:)
          CALL polymatrix(t_psibar,t_dpoly,t_spoly,t_mpoly)
          CALL polymatrix(psilor,t_dpoli,t_spoli,t_mpoli)
          npolyo=t_npoly
       END IF
       t_jqd=2*(t_jm+t_km)
       IF(t_jqm<t_jqd) t_jqm=t_jqd
       IF(t_jqm<2*t_map-1) t_jqm=2*t_map-1
       IF(t_lmax/=lmaxo .OR. t_npri/=nprio .OR. t_nsol/=nsolo)  THEN
          t_nsep=t_mls
          IF(t_npri==0) t_npri=t_nsol
          CALL teq_interface
          CALL teqGS_interface
          i_tswpts=>t_tswpts
          jqmo=t_jqm
          lmaxo=t_lmax
          nprio=t_npri
          nsolo=t_nsol
       END IF
       IF(t_ntet/=0) THEN
          IF(t_mls/=t_ntet .OR. t_msrf/=t_npo .OR. t_lsrf/=lsrfo .OR. &
               t_hsrf/=hsrfo) THEN
             IF(t_inv_eq>0) CALL regrdinv
             n6o=t_n6
             t_ntet=t_mls
             t_npo=t_msrf
             IF(ALLOCATED(i_rhosq)) DEALLOCATE(i_rhosq)
             IF(t_n6==6) THEN
                ALLOCATE(i_rhosq(t_npo*t_ntet,2,3))
             ELSE
                ALLOCATE(i_rhosq(t_npo*t_ntet,4,4))
             END IF
             i_rhosq=0
             CALL teq_interface
             IF(t_inv_eq>0) CALL start_inv(t_inv_k,t_inv_p)
          ELSEIF(t_n6/=n6o) THEN
             IF(ALLOCATED(i_rhosq)) DEALLOCATE(i_rhosq)
             IF(t_n6==6) THEN
                ALLOCATE(i_rhosq(t_npo*t_ntet,2,3))
             ELSE
                ALLOCATE(i_rhosq(t_npo*t_ntet,4,4))
             END IF
             i_rhosq=0
             CALL teq_interface
             n6o=t_n6
          END IF
       END IF
       hsrfo=t_hsrf
       lsrfo=t_lsrf
       IF(msrfo==t_msrf) THEN
          sz = 0; if (allocated(psave_)) sz = size(psave_)
          IF(sz/=msrfo) THEN
             IF(ALLOCATED(psave_)) DEALLOCATE(psave_,fsave_,qsave_,&
                  jtsave_,jpsave_,psibar_,w_,v_,ssave_)
             ALLOCATE(psave_(msrfo),fsave_(msrfo),qsave_(msrfo),&
                  jtsave_(msrfo),jpsave_(msrfo),psibar_(msrfo),w_(msrfo),&
                  v_(msrfo),ssave_(msrfo))
             psave_=t_psave(:msrfo)
             fsave_=t_fsave(:msrfo)
             qsave_=t_qsave(:msrfo)
             jtsave_=t_jtsave(:msrfo)
             jpsave_=t_jparsave(:msrfo)
             psibar_=t_psibar(:msrfo)
             ssave_ =t_ssave(:msrfo)
             w_=t_w(:msrfo)
             v_=t_v(:msrfo)
          END IF
       END IF

       newcellsz = 0
       IF((t_liml /= limlo) .OR. (t_liml==-1 .AND. ((t_zx/=zxo) .OR. &
            (t_rx/=rxo) .OR. (t_rn/=rno))) .OR. (t_liml/=-1 .AND. &
            ((t_el/=elo) .OR. (t_rb/=rbo) .OR. (t_ro/=roo)))) newcellsz = 1
       IF(kmo/=0) THEN
          IF(t_jm==jmo .AND. t_km==kmo .AND. newcellsz==0 .AND. &
               t_nsym==t_nsymo) RETURN
          IF((t_keqic==1 .OR. t_keqic==3) .AND. t_initflx==4) CALL errdetec(&
               "can't change dimension and use saved psi's",1)
          !     now interpolate for psi on new mesh
          t_jqd=2*(t_jm+t_km)
          IF(t_jqm<t_jqd) t_jqm=t_jqd
          IF(t_jqm<2*t_map-1) t_jqm=2*t_map-1
          t_jmkm=t_jm*t_km
          CALL regrid(jmo,kmo,r_,z_)
          t_lgrn=t_kgreenc     ! compute gp etc.
          t_nsymo=t_nsym
       ELSE
          t_jmkm=t_jm*t_km
          n4o=t_n4
          t_jqd=2*(t_jm+t_km)
          IF(t_jqm<t_jqd) t_jqm=t_jqd
          IF(t_jqm<2*t_map-1) t_jqm=2*t_map-1
       END IF
       sz = 0; if (allocated(i_cps)) sz = size(i_cps, 1)
       IF(sz/=t_jm*t_km) THEN
          IF(ALLOCATED(i_cps)) DEALLOCATE(i_cps,s_jbl,s_jbu,s_lxpt)
          t_jmkm=t_jm*t_km
          IF(t_n4==6) THEN
             ALLOCATE(i_cps(t_jmkm,2,3))
          ELSE
             ALLOCATE(i_cps(t_jmkm,4,4))
          END IF
          ALLOCATE(s_jbl(t_km),s_jbu(t_km),s_lxpt(t_jmkm))
       ELSEIF(t_n4/=n4o) THEN
          IF(ALLOCATED(i_cps)) DEALLOCATE(i_cps)
          IF(t_n4==6) THEN
             ALLOCATE(i_cps(t_jmkm,2,3))
          ELSE
             ALLOCATE(i_cps(t_jmkm,4,4))
          END IF
       END IF
!       CALL teq_interface
       CALL setgeo(t_rm,t_zm)
       kmo=t_km
       jmo=t_jm
       n4o=t_n4
       limlo=t_liml
       If(t_liml==-1) THEN
          zxo = t_zx
          rxo = t_rx
          rno = t_rn
       ELSE
          elo = t_el
          rbo = t_rb
          roo = t_ro
       END IF
       t_nsymo=t_nsymc

       ! Setup for rezoning.
       IF(jmo==t_jm .AND. kmo==t_km) THEN
          sz = 0; if (allocated(r_)) sz = size(r_)
          IF(sz/=jmo) THEN
             IF(ALLOCATED(r_)) DEALLOCATE(r_)
             ALLOCATE(r_(jmo))
             r_=t_r
          END IF
          sz = 0; if (allocated(z_)) sz = size(z_)
          IF(sz/=kmo) THEN
             IF(ALLOCATED(z_)) DEALLOCATE(z_)
             ALLOCATE(z_(kmo))
             z_=t_z
          END IF
       END IF

       ! End setup for rezoning.

       RETURN
    ELSE
       IF(t_kgreenc==0) THEN
          t_nc0p=1
          t_nc0b=1
          t_jm0p=1
          t_km0p=1
          t_nc0p=0
       ELSE
          t_nc0b=t_nsymc*(t_jm+t_km-t_nsymc)
          IF(t_nc0p/=t_nc/(3-t_nsymc) .OR. t_km0p/=(t_km-1)/(3-t_nsymc)+1 &
               .OR. t_jm0p/=t_jm .OR. (kmo/=0 .AND. (t_nsymc/=t_nsymco .OR. &
               t_ncfo/=t_ncf))) THEN
             t_km0p=(t_km-1)/(3-t_nsymc)+1
             t_nc0p=t_nc/(3-t_nsymc)
             t_jm0p=t_jm
             t_lgrn=t_kgreenc
          END IF
          l1=1
          nn=t_nc0p
          DO i=1,nn
             l2=t_loop0(i)
             IF(t_iferro(i)==1) t_nc0p=t_nc0p+l2-l1
             l1=l2+1
          END DO
       END IF

       ncpp=t_nc
       IF(t_nsymc==1) ncpp=t_nc/2
       t_ncsym=t_nc/(3-t_nsymc)
       nn=ncpp
       l1=1
       DO i=1,nn
          l2=t_loop0(i)
          IF(t_iferro(i)==1) ncpp=ncpp+l2-l1
          l1=l2+1
       END DO
       IF(t_ncf/=t_ncfo .OR. t_ngp/=t_ngpo .OR. t_nsymc/=t_nsymco .OR. &
            t_ngroup/=ngroupo .OR. t_nloop/=nloopo .OR. t_nloop/=t_nloop0p &
            .OR. ncpp/=t_nc0p .OR. t_nfbd/=nfbdo  .OR. t_nsph/=nspho) THEN
          ngroupo=t_ngroup
          nfbdo=t_nfbd
          nloopo=t_nloop
          t_lcal=1
          IF((t_nloop0p/=t_nloop .OR. t_nsph/=nspho)) THEN
             ! will make Green's functions for loops
             t_nloop0p=t_nloop
             nspho=t_nsph
             t_ncfo=0
             t_lgrn=0
          END IF
          IF(t_ncf/=t_ncfo .OR. t_nsymc/=t_nsymco .OR. ncpp/=t_nc0p .OR. &
               t_nloop/=nloopo) THEN
             nloopo=t_nloop
             ! compute gp, Greens function grid and boundary and grid and loops
             t_ngpo=0 ! compute gsbr, gsbz, pbim IF ngp/=0
          END IF
          t_nsymco=t_nsymc
          CALL teqGS_interface
       END IF
    END IF
  END SUBROUTINE getstrg

  SUBROUTINE pfcfils
    INTEGER :: nbc,nb,n,nr,nz,ir,iz
    REAL(rq) :: drg,dzg,rg0,zg0,rg1
    nbc=0
    nb=t_nc
    IF(t_ngp /= 1)nb   = t_ncplot/(3-t_nsymc)  
    DO n=1,nb
       rg0   = t_rc(n) - 0.5_rq*t_drc(n)
       zg0   = t_zc(n) - 0.5_rq*t_dzc(n)
       rg1   = t_rc(n) + 0.5_rq*t_drc(n)
       IF(t_ngp==1) THEN
          nr = t_nrc(n)
          nz = t_nzc(n)
          drg=t_drc(n)/t_nrc(n)
          dzg=t_dzc(n)/t_nzc(n)
       ELSE
          nr    = ( t_drc(n)/t_delc ) + 1
          nz    = ( t_dzc(n)/t_delc ) + 1
          drg   = t_drc(n)/( nr - 1 )
          dzg   = t_dzc(n)/( nz - 1 )
       END IF
       IF(t_ngp==1) THEN
          DO ir=1, nr
             DO iz=1, nz
                nbc=nbc+1
                t_rgp(nbc)=   rg0+(ir-1)*drg
                t_rgp(nbc+nz)=rg0+(ir-0.5_rq)*drg
                t_zgp(nbc)=   zg0+(iz-0.5_rq)*dzg
                t_zgp(nbc+nz)=zg0+(iz-1)*dzg
             END DO
             nbc=nbc+nz+1
             t_rgp(nbc)=t_rgp(nbc-1)
             t_zgp(nbc)=t_zgp(nbc-1)+dzg
          END DO
          DO iz=1, nz
             nbc=nbc+1
             t_rgp(nbc)=rg1
             t_zgp(nbc)=zg0+(iz-0.5_rq)*dzg
          END DO
       ELSE
          DO iz = 1, nz
             DO ir = 1, nr
                nbc      = nbc + 1
                t_zgp(nbc) = zg0 + dzg*(iz - 1)
                t_rgp(nbc) = rg0 + drg*(ir - 1)
             END DO
          END DO
       END IF
       t_loopm(n)=nbc  !  "t_loop0"  for field points
    END DO
  END SUBROUTINE pfcfils


  SUBROUTINE pfcmem
    INTEGER :: i,j,n,idummy,jdummy,ncu,nb,nr,nz
    REAL(rq) :: spco,deltar,deltaz,hmin,smin,wmin,spc,deltaf
    SAVE spco
    INTEGER, SAVE :: ngro,ncro,ircwto,nbso,ncppo
    DATA nbso/0/,spco/0.0/,ncppo/0/, ngro/0/, ncro/0/, ircwto/0/

    ! t_nc is the total number of coils, whether symmetric (nsym==1) or
    ! asymmetric (nsym==2)
    CALL teqGS_interface
    ncu= t_nc/(3 - t_nsymc)
    IF (t_ncplot == 0) t_ncplot= t_nc
    ! IF coil geometry or number of filaments (t_nrc,t_nzc) has changed,
    ! set flag to update Greens functions...

    spc= 0
    DO n=1,ncu
       spc=spc+t_nrc(n)*t_nzc(n)+t_drc(n)*t_dzc(n)+t_ac(n)**2+t_ac2(n)**2+&
            t_rc(n)+t_zc(n)**2
   END DO
    IF (spc /= spco .AND. t_nc0p==ncppo) THEN
       spco=spc
       ncppo=t_nc0p
       t_ngpo=0
       t_ncfo=0
    END IF

    ! Set the cell-size for discretization to be used IF t_nrc,t_nzc==0...

    IF (t_nfil <= 0) t_nfil= 1
    deltar= xminaf(t_drc,1,ncu,1,jdummy)
    deltaz= xminaf(t_dzc,1,ncu,1,jdummy)
    deltaf= min(deltar,deltaz)/t_nfil

    ! Determine the number of filaments to be used for the coil-to-plasma
    ! Greens functions...
    DO n=1,ncu
       IF (t_nrc(n) == 0 .AND. t_nzc(n) == 0) THEN
          IF (t_drc(n) < t_dzc(n)) THEN
             t_nrc(n)= t_drc(n)/deltaf + 0.49_rq
             IF (t_nrc(n) <= 0) t_nrc(n)= t_nfil
          ELSE
             t_nzc(n)= t_dzc(n)/deltaf + 0.49_rq
             IF (t_nzc(n) <= 0) t_nzc(n)= t_nfil
          END IF
       END IF
       IF (t_nzc(n) == 0) t_nzc(n)= t_nrc(n)*t_dzc(n)/t_drc(n) + 0.49_rq
       IF (t_nrc(n) == 0) t_nrc(n)= t_nzc(n)*t_drc(n)/t_dzc(n) + 0.49_rq
    END DO
    t_ncf=0
    DO n=1,ncu
       t_ncf=t_ncf+t_nrc(n)*t_nzc(n)
       t_loop0(n)=t_ncf
       IF(t_nrc(n)>t_ncrmx) t_ncrmx=t_nrc(n)
       IF(t_nzc(n)>t_nczmx) t_nczmx=t_nzc(n)
       IF(t_iferro(n)==1) t_ncf=t_ncf+2*(t_nrc(n)+t_nzc(n))
       t_loop0(n)=t_ncf
    END DO
    IF(t_nsymc==1) t_ncf=2*t_ncf

    ! Determine the number of grid points for coil B-field calculation...
    ! The smallest coil cross-section determines the resolution of the
    ! grid (t_delc) used in *all* coils.

    t_nbs= 0
    IF(t_magfac/=0) t_ngp=1
    IF (t_ngp > 0) THEN
       nb=   t_ncplot/(3-t_nsymc)
       IF (t_ngp==1) THEN  ! grid points at filament-sides
          DO n=1,nb
             t_nbs=t_nbs+2*t_nrc(n)*t_nzc(n)+t_nrc(n)+t_nzc(n)
          END DO
          IF(t_nsymc == 1)t_nbs=2*t_nbs
       ELSE
          wmin= xminaf(t_drc,1,nb,1,jdummy)
          hmin= xminaf(t_dzc,1,nb,1,jdummy)
          smin= min(wmin,hmin)
          t_delc= smin/(t_ngp-1)
          DO n=1,nb
             nr=  t_drc(n)/t_delc + 1
             nz=  t_dzc(n)/t_delc + 1
             t_nbs= t_nbs + nr*nz
          END DO
       END IF
    END IF

    ! Check static memory limit...

    IF (t_nsymc == 1) THEN
       IF (t_nc > T_NC) THEN
          CALL errdetec('*** PFCMEMS: t_nc exceeds array lengths ***',1)
       END IF
    END IF
    IF (t_nbs /= nbso) THEN
       nbso= t_nbs
       t_ngpo= 0
    END IF

    t_icc=0
    t_ncircuit=0
    t_ngroup=0

    DO j=1,t_nc/(3-t_nsymc)
       IF(t_ic(j)/=0) THEN
          IF(t_ic(j)>t_ngroup) t_ngroup=t_ic(j)
          IF(t_ix(j)/=0) THEN
             IF(t_ix(j)>t_ncircuit) t_ncircuit=t_ix(j)
          ELSE
             t_icc(t_ic(j))=1
          END IF
       END IF
    END DO
    IF(t_nsymc==1) THEN
       DO j=1,t_nc/2
          t_ic(j+t_nc/2)=t_ic(j)
          t_ix(j+t_nc/2)=t_ix(j)
          t_svec(j+t_nc/2)=t_svec(j)
       END DO
    END IF

    IF(t_almim==0 .AND. (t_ircwt==9 .OR. (t_ncircuit/=0 .AND. t_ircwt==-1)))&
         THEN
       t_ngroup=t_ngroup+t_nsph+iabs(t_lsph) ! nloops etc
       IF(t_lsph==-1) t_ncircuit=t_ncircuit+1
       nsvd=t_ngroup+t_ncircuit
    END IF
    ! Compute new gmat's in curcal

    IF(t_ncircuit/=ncro .OR. t_ngroup/=ngro .OR. t_ircwt/=ircwto) t_lcal=1
    ncro=t_ncircuit
    ngro=t_ngroup
    ircwto=t_ircwt
    ! Allocate storage for coil filaments and coil grids...

    CALL getstrg(2)
    ! DO the coil gridding, IF requested...

    IF (t_nbs > 0) CALL pfcfils
    IF(t_ngroup==0) RETURN

    t_pfpc0=0
    t_ccls=0
    t_rcg=0
    t_zcg=0

    DO i=1,t_nc/(3-t_nsymc)
       t_pfpc0(t_ic(i))=t_pfpc0(t_ic(i))+t_pfps0(i)*t_cc(i)
       t_zcg(t_ic(i))=t_zcg(t_ic(i))+t_zc(i)*t_cc(i)
       t_rcg(t_ic(i))=t_rcg(t_ic(i))+t_rc(i)*t_cc(i)
       IF(t_ict(j)==0) THEN
          t_ccls(t_ic(i))=t_ccls(t_ic(i))+t_cc(i) ! parallel
       ELSE
          t_ccls(t_ic(i))=t_cc(i) ! series
       END IF
    END DO
    DO i=1,t_ngroup
       t_pfpc0(i)=t_pfpc0(i)/t_ccls(i)
       t_rcg(i)=t_rcg(i)/t_ccls(i)
       t_zcg(i)=t_zcg(i)/t_ccls(i)
    END DO

  END SUBROUTINE pfcmem

  SUBROUTINE regrdinv
    REAL(rq) :: cq0(t_mls),psw(t_mls,1)
    INTEGER :: isw,ier,ls,l

    isw=1
    t_tswpts=(/(ls,ls=0,t_mls-1)/)*TWOPI/(t_mls-1)
    t_brwpts=cos(t_tswpts)
    t_bzwpts=sin(t_tswpts)
    t_rlsd(:,1,1)=t_raxis
    t_zlsd(:,1,1)=t_zaxis

    DO l=2,t_msrf
       cq0=t_psibar(l)
       ier=1
       CALL boxm_interp(cq0,t_tswpts,psw,pst,tst,i_rhosq,isw,ier,t_n6)
       t_rlsd(:,l,1)=t_raxis+SQRT(psw(:,1))*t_brwpts
       t_zlsd(:,l,1)=t_zaxis+SQRT(psw(:,1))*t_bzwpts*t_wvert
    END DO
    t_rls=t_rlsd(:,t_msrf,1)
    t_zls=t_zlsd(:,t_msrf,1)
  END SUBROUTINE regrdinv

  SUBROUTINE regrid(jmo,kmo,r_,z_)
    INTEGER, INTENT(IN) :: jmo,kmo
    REAL(rq),INTENT(IN) ::  r_(jmo),z_(kmo)
    REAL(rq) :: psi_(t_jmkm,1)
    INTEGER :: ier,isw
    CALL teq_interface
    CALL setgeo(t_rm,t_zm)
    isw=0
    ier=1
    CALL boxm_interp(t_rm,t_zm,psi_,r_,z_,i_cps,isw,ier,t_n4)
    t_psi(:t_jmkm)=psi_(:t_jmkm,1)
  END SUBROUTINE regrid

  SUBROUTINE setgeo(rr,zz)
    REAL(rq), DIMENSION(t_jm,t_km) :: rr,zz
    INTEGER :: jc,i,j,k
    !
    !     set up mesh
    !
    jc=t_jm/2+1
    IF(t_liml==-1) THEN
       t_zn=-t_zx
       t_dr=(t_rx-t_rn)/(t_jm-1)
       t_dz=(t_zx-t_zn)/(t_km-1)
       t_ro=0.5_rq*(t_rn+t_rx)
       t_el=(t_zx-t_zn)/(t_rx+t_rn)
    ELSE
       t_dr=1.0017469212_rq*t_rb/(jc-t_liml)+sqrt(errt_rq)
       ! avoid contact with grid
       t_rn=t_ro-(jc-1)*t_dr
       t_rx=t_ro+(jc-1)*t_dr
       t_zx=(jc-1)*t_dr*t_el
       t_zn=-t_zx
    END IF
    t_dz=(t_zx-t_zn)/(t_km-1)
    t_r=(/(i,i=0,t_jm-1)/)*t_dr+t_rn
    t_z=(/(i,i=0,t_km-1)/)*t_dz+t_zn
    DO k=1,t_km
       rr(:,k)=t_r
    END DO
    DO j=1,t_jm
       zz(j,:)=t_z
    END DO
    i_r=>t_r
    i_z=>t_z
  END SUBROUTINE setgeo

  SUBROUTINE time_date
    CHARACTER(len=8) :: date1
    CHARACTER(len=10) :: time1
    INTEGER, save :: l
    DATA l /0/
    IF(l==0) THEN
       CALL glbtmdat(t_codetime,t_codedate)
       CALL DATE_AND_TIME(date1,time1)
       t_runtime=time1(1:2)//":"//time1(3:4)//":"//time1(5:6)
       t_rundate=date1(5:6)//"/"//date1(7:8)//"/"//date1(3:4)
       l=1
    END IF
  END SUBROUTINE time_date

END Module setTeq_mod
