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

MODULE ioTeq_mod

  USE runTeq_mod
  USE teqSubs_mod, only : t_stretch

  IMPLICIT NONE

  REAL(rq), DIMENSION(:,:), ALLOCATABLE :: bri,bzi,psiv
  REAL(rq), DIMENSION(:), ALLOCATABLE :: psg,prg,pdg,ffpg,fg,fpg,rpx
  INTEGER, PARAMETER :: OK=0, ERR=-1

  EXTERNAL giveupus,basclose,kaboom,freeus,teq_interface

CONTAINS

  SUBROUTINE wreqdskf(type,filename,suffix,tunits)

    ! Subroutine wreqdskf writes EQDSK files in the EFIT a- and g-file formats
    ! formats (http://web.gat.com/efit/) and three TEQ-specific formats. This
    ! routine takes up to four optional arguments, all character strings.
    ! Optional values are given in square brackets, below.
    !
    ! Calling sequence:
    !
    !   CALL wreqdskf(type,filename,suffix,tunits)
    !
    ! where the arguments are:
    !
    !   type     : file format character code (see below) ["g"]
    !   filename : EQDSK file name [default constructed from shot info]
    !   suffix   : EQDSK file suffix ["_teq"]
    !   tunits   : Time units, one of "s", "ms", "µs" (or "us") ["ms"]
    !
    ! The follwing EQDSK file types are available:
    !
    !   Type  Equilibrium      Description
    !     a   direct or inv.   auxiliary EQDSK file (EFIT a-file)
    !     d   direct           for input to Glasser's DCON
    !     g   direct or inv.   primay EQDSK file (EFIT g-file)
    !     i   inverse          for input to Glasser's DCON
    !     t   inverse          for input to Turnbull's GATO
    !
    ! If argument filename is not specified, a name will be constructed from
    ! the file type-code, user-variables shotName and shotTime and the suffix
    ! argument in the following format:
    !
    !             <type>shotName.<time_string><suffix>
    !
    ! If shotName is blank, the string "eqdsk" will be used. The value of
    ! time_string is a five character integer representation of the time
    ! in the specified units.


    CHARACTER(len=*), OPTIONAL, INTENT(IN) :: type,filename,suffix,tunits
    CHARACTER(len=1) :: eqdsk_type
    CHARACTER(len=8) :: eqdsk_suffix
    CHARACTER(len=256) :: eqdsk_file
    CHARACTER(len=2) :: eqdsk_tunits
    CHARACTER(len=5) :: tstr

    INTEGER, PARAMETER :: UNKNOWN=0,MCO2R=1,MCO2V=3,NSILOP=41,NFCOIL=18,&
         NESUM=6,MAGPRI=73,ERR=-1
        CHARACTER(len=3) :: limloc, qmflag, fit_type
    CHARACTER(len=42) :: header
    REAL(rq), PARAMETER :: pt01=.01_rq,pt1=.1_rq,pow7=1.e7_rq,&
         pow_4=1.e-4_rq,pow_6=1.e-6_rq,pow_8=1.e-8_rq
    REAL(rq) :: rseps(2), zseps(2)

    !     These quantites are unknown, but some applications need entries
    !     in a-files so they are written as vectors of zeros
    REAL(rq) :: rco2v(MCO2V), dco2v(MCO2V), rco2r(MCO2R), dco2r(MCO2R)
    REAL(rq) ::  csilop(NSILOP), cmpr2(MAGPRI), ccbrsp(NFCOIL), eccurt(NESUM)
    INTEGER :: i,j,idum,nbbs,limitr,kvtor,m,k,ktime1,nmass,nbbbs,jflag,&
         lflag,jmp,kmp
    REAL(rq) :: tsaisq,rcencm,bcentr,pasmat,cpasma,rout,zout,aout,axpt,&
         eout,doutu,doutl,vout,rcurrt,zcurrt,qsta,betatx,betapx,ali,oleft,&
         oright,otop,obott,qpsib,vertn,shearb,bpolav,s1,s2,s3,qout,olefs,&
         orighs,otops,sibdry,areao,wplasm,terror,elongm,qqmagx,cdflux,&
         alpha_,rttt,psiref,xndnt,sepexp,obots,btaxp,btaxv,alim,taudia,&
         aaq1,aaq2,aaq3,seplim,rmagx,zmagx,simagx,taumhd,betapd,betatd,&
         wplasmd,fluxx,vloopt,taurci,tavem,timex,delrmax2,qmerci,pbinj,&
         rvsin,zvsin,wpdot,rvsout,zvsout,vsurfa,wbdot,slantu,slantl,pp95,&
         zuperts,chipre,cjor95,ssep,yyy2,xnnx,xprof,oring,cjor0,fexpan,&
         qqmin,chigamt,cjor99,cj1ave,rmidin,rmidout,psurfa,xdum,dpsi,xnnc,&
         cprof,ssi01,fexpvs,sepnose,ssi95,rqqmin,xdim,zdim,rzero,rgrid1,&
         zmid,rmaxis,zmaxis,ssimag,ssibry,dnnorm,rvtor
    INTEGER :: jinc,kinc ! Must connect data base
    DATA jinc /1/, kinc /1/
    DATA delrmax2 /40/
    ALLOCATE(bri(t_mls,t_msrf),bzi(t_mls,t_msrf),psiv(t_jm,t_km))
    ALLOCATE(psg(t_jm),prg(t_jm),pdg(t_jm),ffpg(t_jm),fg(t_jm),fpg(t_jm),&
         rpx(t_jm))

    ! Non-blank shotName mandatory
    IF (t_shotName == "") t_shotName="eqdsk"

    ! EQDSK file type code
    IF (PRESENT(type)) THEN
       eqdsk_type=type
    ELSE
       eqdsk_type="g"
    END IF

    ! EQDSK filename suffix
    IF (PRESENT(suffix)) THEN
       eqdsk_suffix=suffix
    ELSE
       eqdsk_suffix="_teq"
    END IF

    ! EQDSK (a,g) file time units
    IF (PRESENT(tunits)) THEN
       eqdsk_tunits=tunits
    ELSE
       eqdsk_tunits="ms"
    END IF

    ! Construct time string
    IF (eqdsk_tunits == "s") THEN
       WRITE(tstr,'(I5.5)') INT(t_shotTime+0.5)
    ELSE IF (eqdsk_tunits == "µs" .OR. eqdsk_tunits == "us") THEN
       WRITE(tstr,'(I5.5)') INT(1000000*t_shotTime+0.5)
    ELSE
       WRITE(tstr,'(I5.5)') INT(1000*t_shotTime+0.5)
    END IF

    ! EQDSK file name
    IF (PRESENT(filename)) THEN
       eqdsk_file=filename
    ELSE
       eqdsk_file=eqdsk_type//TRIM(t_shotName)//"."//tstr//TRIM(eqdsk_suffix)
    END IF
    IF (LEN_TRIM(t_shotName) > 6) THEN ! Use C-Mod convention (uppercase)
       DO i=1,LEN_TRIM(eqdsk_file)
          IF (LGE(eqdsk_file(i:i),'a') .AND. LLE(eqdsk_file(i:i),'z')) THEN
             eqdsk_file(i:i)=ACHAR(IACHAR(eqdsk_file(i:i))-32)
          END IF
       END DO
    END IF

    ! Set the EQDSK a- & g-file headers
    CALL set_headers(eqdsk_tunits)

    CALL teq_interface ! Too avoid HP character pointer disassociate bug.
    IF (eqdsk_type == "d" .OR. eqdsk_type == "i") THEN ! binary file
       IF (iopen(ioun7,eqdsk_file) == ERR) THEN
          CALL giveupus(ioun7)
          CALL basclose(ioun7)
          RETURN
       END IF
    ELSE
       IF (icreate(ioun7,eqdsk_file) == ERR) THEN ! text file
          CALL giveupus(ioun7)
          CALL basclose(ioun7)
          RETURN
       END IF
    END IF

    IF (jinc <= 0) jinc = 1
    IF (kinc <= 0) kinc = 1
    jmp = (t_jm - 1)/jinc + 1
    kmp = (t_km - 1)/jinc + 1

    !     PART I: PREPARE DATA...
    IF (eqdsk_type == "a") THEN ! Map to EFIT variable names
       !         uday.. ~ aheader
       !         ishot  ~ shotName
       IF (eqdsk_tunits == "s") THEN
          timex  = t_shotTime
       ELSE IF (eqdsk_tunits == "µs" .OR. eqdsk_tunits == "us") THEN
          timex  = t_shotTime*1.0e+06_rq
       ELSE
          timex  = t_shotTime*1.0e+03_rq
       END IF
       ktime1 = 1
       jflag  = 1
       lflag  = 0
       limloc = "UNK"
       IF (s_limiterd /= 0) THEN
          alim = atan2((t_zlim(0) - t_zaxis),(t_rlim(0) - t_raxis))
          IF (alim < 0) alim = alim + TWOPI
          IF (alim >= 7*Pi/4 .OR. alim < Pi/4) THEN
             limloc = "OUT"
          ELSEIF (alim >= Pi/4 .AND. alim < 3*Pi/4) THEN
             limloc = "TOP"
          ELSEIF (alim >= 3*Pi/4 .AND. alim < 5*Pi/4) THEN
             limloc = "IN"
          ELSE
             limloc = "BOT"
          END IF
       ELSE
          IF (abs((s_pxpu - s_pxpl) / t_dpsi0) < t_dn_criterion) THEN
             limloc = "DN"
          ELSE
             axpt = atan2((t_zxpt - t_zaxis),(t_rxpt - t_raxis))
             IF (axpt < 0) axpt = axpt + TWOPI
             IF (axpt >= 7*Pi/4 .OR. axpt < Pi/4) THEN
                limloc = "SNO"
             ELSEIF (axpt >= Pi/4 .AND. axpt < 3*Pi/4) THEN
                limloc = "SNT"
             ELSEIF (axpt >= 3*Pi/4 .AND. axpt < 5*Pi/4) THEN
                limloc = "SNI"
             ELSE
                limloc = "SNB"
             END IF
          END IF
       END IF
       qmflag   = "CLC"
       tsaisq   = UNKNOWN
       rcencm   = t_ro
       bcentr   = t_btor*1.0e-04_rq
       pasmat   = UNKNOWN
       cpasma   = t_placur
       rout     = s_rcntr
       zout     = UNKNOWN
       aout     = s_rbore
       eout     = t_elongn
       doutu    = t_trianu
       doutl    = t_trianl
       vout     = t_volume
       rcurrt   = UNKNOWN
       zcurrt   = UNKNOWN
       qsta     = t_qstar
       betatx   = t_betae*1.0e+02_rq
       betapx   = t_betap(1)
       ali      = t_li(1)
       oleft    = UNKNOWN
       oright   = UNKNOWN
       otop     = UNKNOWN
       obott    = UNKNOWN
       qpsib    = t_q95
       vertn    = UNKNOWN
       rco2v    = UNKNOWN
       dco2v    = UNKNOWN
       rco2r    = UNKNOWN
       dco2r    = UNKNOWN
       shearb   = UNKNOWN
       bpolav   = UNKNOWN
       s1       = UNKNOWN
       s2       = UNKNOWN
       s3       = UNKNOWN
       qout     = t_qsrf(t_msrf)
       olefs    = UNKNOWN
       orighs   = UNKNOWN
       otops    = UNKNOWN
       sibdry   = t_psil*1.0e-08_rq
       areao    = t_surf
       wplasm   = UNKNOWN
       terror   = UNKNOWN
       elongm   = t_esrf(1)
       qqmagx   = t_qsrf(1)
       cdflux   = UNKNOWN
       alpha_   = UNKNOWN
       rttt     = UNKNOWN
       psiref   = UNKNOWN
       xndnt    = UNKNOWN
       IF (s_limiterd /= 0) THEN
          rseps=-999
          zseps=-999
       ELSE
          rseps(1) = s_rxpl
          zseps(1) = s_zxpl
          rseps(2) = s_rxpu
          zseps(2) = s_zxpu
       END IF
       sepexp   = UNKNOWN
       obots    = UNKNOWN
       btaxp    = UNKNOWN
       btaxv    = (t_fwall/t_raxis)*1.0e-04_rq
       aaq1     = UNKNOWN
       aaq2     = UNKNOWN
       aaq3     = UNKNOWN
       seplim   = UNKNOWN
       rmagx    = t_raxis
       zmagx    = t_zaxis
       simagx   = t_psix*1.0e-08_rq
       taumhd   = UNKNOWN
       betapd   = UNKNOWN
       betatd   = UNKNOWN
       wplasmd  = UNKNOWN
       fluxx    = UNKNOWN
       vloopt   = UNKNOWN
       taudia   = UNKNOWN
       qmerci   = UNKNOWN
       tavem    = UNKNOWN
       csilop   = UNKNOWN
       cmpr2    = UNKNOWN
       ccbrsp   = UNKNOWN
       eccurt   = UNKNOWN
       pbinj    = UNKNOWN
       IF (t_nspt < 2) THEN
          rvsin  = 0.0
          zvsin  = 0.0
       wpdot    = UNKNOWN
          rvsout = 0.0
          zvsout = 0.0
       ELSEIF (t_nspt < 4) THEN
          rvsin   = t_rspt(1)
          zvsin   = t_zspt(1)
          rvsout  = t_rspt(2)
          zvsout  = t_zspt(2)
       ELSE
          rvsin   = t_rspt(3)
          zvsin   = t_zspt(3)
          rvsout  = t_rspt(4)
          zvsout  = t_zspt(4)
       END IF
       vsurfa   = UNKNOWN
       wpdot    = UNKNOWN
       wbdot    = UNKNOWN
       slantu   = UNKNOWN
       slantl   = UNKNOWN
       zuperts  = UNKNOWN
       chipre   = UNKNOWN
       cjor95   = UNKNOWN
       pp95     = UNKNOWN
       ssep     = 0.0
       IF (limloc == "SNB") THEN
          IF (s_dsep /= 0) THEN
             ssep = -s_dsep
          ELSE
             ssep = -delrmax2
          END IF
       ELSEIF (limloc == "SNT") THEN
          IF (s_dsep /= 0) THEN
             ssep = s_dsep
          ELSE
             ssep = delrmax2
          END IF
       END IF
       yyy2     = UNKNOWN
       xnnc     = UNKNOWN
       cprof    = UNKNOWN
       oring    = UNKNOWN
       cjor0    = UNKNOWN
       fexpan   = UNKNOWN
       qqmin    = t_qmin
       chigamt  = UNKNOWN
       ssi01    = UNKNOWN
       fexpvs   = UNKNOWN
       sepnose  = UNKNOWN
       ssi95    = UNKNOWN
       rqqmin   = t_rhomin
       cjor99   = UNKNOWN
       cj1ave   = UNKNOWN
       rmidin   = UNKNOWN
       rmidout  = UNKNOWN
       psurfa   = UNKNOWN
       xdum     = 0.0
       fit_type = "TEQ"
       header   = " "

    ELSEIF (eqdsk_type == "g") THEN ! Map to EFIT variable names
       psiv = RESHAPE(t_psi,(/t_jm,t_km/))*1.0e-8_rq
       dpsi = (t_psil - t_psix)/(t_jm - 1)
       psg=(/(j,j=0,t_jm-1)/)*dpsi+t_psix
       CALL interp_interp(t_psrf,t_qsrf ,t_splbdry,t_splbdry,psg,rpx, fg)
       CALL interp_interp(t_psrf,t_frsrf,t_splbdry,t_splbdry,psg,fg ,fpg)
       CALL interp_interp(t_psrf,t_prsrf,t_splbdry,t_splbdry,psg,prg,pdg)
       rpx(t_jm) = t_qsrf(t_msrf)
       prg  = prg*1.0e-01_rq
       pdg  = pdg*1.0e+07_rq
       WHERE(prg<9.e-99_rq)
          prg=0
       END WHERE
       WHERE(ABS(pdg)<9.e-99_rq)
          pdg=0
       END WHERE
       ffpg = fg*fpg*1.0e-04_rq
       fg   = fg*1.0e-06_rq
       psg  = psg*1.0e-08_rq
       fpg = ffpg/(fg + errt_rq)

       !         Map to EFIT variable names
       !         case   ~ gheader (set by user)
       idum   = 3
       xdim   = (t_r(t_jm) - t_r(1))*1.0e-02_rq
       zdim   = (t_z(t_km) - t_z(1))*1.0e-02_rq
       rzero  = (t_r(1) + t_r(t_jm))*5.0e-03_rq
       rgrid1 = t_r(1)*1.0e-02_rq
       zmid   = 0.5*(t_z(1) + t_z(t_km))*1.0e-02_rq
       rmaxis = t_raxis*1.0e-02_rq
       zmaxis = t_zaxis*1.0e-02_rq
       ssimag = t_psix*1.0e-08_rq
       ssibry = t_psil*1.0e-8_rq
       bcentr = t_btor*1.0e-04_rq
       cpasma = t_placur
       xdum   = 0.0
       !         fpol   = fg
       !         pres   = prg
       !         ffprim = ffpg
       !         pprime = pdg
       !         psirz  = psiv
       !         qpsi   = rpx
       nbbbs  = s_mlse
       limitr = t_nplates + 1
       !         rbbbs  = 0.01*rlse
       !         zbbbs  = 0.01*zlse
       !         xlim   ~ 0.01*rplate [assumes r,zplate form plasma-enclosing contour]
       !         ylim   ~ 0.01*zplate
       kvtor  = UNKNOWN
       rvtor  = UNKNOWN
       nmass  = UNKNOWN

       !         Sign convention for g-files
       IF (cpasma > 0) THEN
          ssimag = -ssimag
          ssibry = -ssibry
          ffpg=-ffpg
          pdg=-pdg
          psiv = -RESHAPE(t_psi,(/t_jm,t_km/))*1.0e-8_rq
       END IF
       IF (bcentr < 0 .AND. fg(t_jm) > 0) fg=-fg

    ELSEIF (eqdsk_type == "t") THEN ! Evaluate Bpoloidal on inverse mesh
       bri(:,1)=0
       bzi(:,1)=0
       bri(:,2:) = -s_pin*t_rlsd(:,2:,2)/t_zlsd(:,2:,4)
       bzi(:,2:) = -s_pin*t_zlsd(:,2:,2)/t_zlsd(:,2:,4)

    END IF ! PART I

    !     PART II: WRITE DATA...
    IF (eqdsk_type == "a") THEN ! write a-file
       write(ioun7,1055) t_aheader
       write(ioun7,1053) t_shotName, ktime1
       write(ioun7,1040) timex
       write(ioun7,1060) timex, jflag, lflag, limloc, MCO2V, MCO2R, qmflag
       write(ioun7,1040) tsaisq, rcencm, bcentr, pasmat
       write(ioun7,1040) cpasma, rout, zout, aout
       write(ioun7,1040) eout, doutu, doutl, vout
       write(ioun7,1040) rcurrt, zcurrt, qsta, betatx
       write(ioun7,1040) betapx, ali, oleft, oright
       write(ioun7,1040) otop, obott, qpsib, vertn
       IF (mco2v > 0) THEN
          write(ioun7,1040) (rco2v(k), k=1,mco2v)
          write(ioun7,1040) (dco2v(k), k=1,mco2v)
       END IF
       IF (mco2r > 0) THEN
          write(ioun7,1040) (rco2r(k), k=1,mco2r)
          write(ioun7,1040) (dco2r(k), k=1,mco2r)
       END IF
       write(ioun7,1040) shearb, bpolav, s1, s2
       write(ioun7,1040) s3, qout, olefs, orighs
       write(ioun7,1040) otops, sibdry, areao, wplasm
       write(ioun7,1040) terror, elongm, qqmagx, cdflux
       write(ioun7,1040) alpha_, rttt, psiref, xndnt
       write(ioun7,1040) rseps(1), zseps(1), rseps(2), zseps(2)
       write(ioun7,1040) sepexp, obots, btaxp, btaxv
       write(ioun7,1040) aaq1, aaq2, aaq3, seplim
       write(ioun7,1040) rmagx, zmagx, simagx, taumhd
       write(ioun7,1040) betapd, betatd, wplasmd, fluxx
       write(ioun7,1040) vloopt, taudia, qmerci, tavem
       write(ioun7,1041) nsilop, magpri, nfcoil, nesum
       IF (nsilop*magpri > 0) THEN
          write(ioun7,1040) (csilop(k), k=1,nsilop), (cmpr2(k), k=1,magpri)
       END IF
       IF (nfcoil > 0) THEN
          write(ioun7,1040) (ccbrsp(k), k=1,nfcoil)
       END IF
       IF (nesum > 0) THEN
          write(ioun7,1040) (eccurt(k), k=1,nesum)
       END IF
       write(ioun7,1040) pbinj, rvsin, zvsin, rvsout
       write(ioun7,1040) zvsout, vsurfa, wpdot, wbdot
       write(ioun7,1040) slantu, slantl, zuperts, chipre
       write(ioun7,1040) cjor95, pp95, ssep, yyy2
       write(ioun7,1040) xnnc, cprof, oring, cjor0
       write(ioun7,1040) fexpan, qqmin, chigamt, ssi01
       write(ioun7,1040) fexpvs, sepnose, ssi95, rqqmin
       write(ioun7,1040) cjor99, cj1ave, rmidin, rmidout
       write(ioun7,1040) psurfa, xdum, xdum, xdum
       write(ioun7,1042) header, fit_type
    ELSEIF (eqdsk_type == "d") THEN ! write d-file (---> DCON)
       psiv = t_psil - RESHAPE(t_psi,(/t_jm,t_km/))*pow_8
       write(ioun7) jmp, kmp, t_msrf
       write(ioun7) pt01*t_r(1), pt01*t_r(t_jm), pt01*t_z(1), pt01*t_z (t_km)

       write(ioun7) ((psiv(j,k), j=1,t_jm,jinc), k=1,t_km,kinc)
       write(ioun7) ((t_psrf(m) - t_psil), m=1,t_msrf)
       write(ioun7) (t_frsrf(m)*pow_6, m=1,t_msrf)
       write(ioun7) (t_prsrf(m)*pt1, m=1,t_msrf)
       write(ioun7) (t_qsrf(m), m=1,t_msrf)
       write(ioun7) (t_pdsrf(m)*pow7, m=1,t_msrf)

    ELSEIF (eqdsk_type == "g") THEN ! write g-file
       write(ioun7,2000) t_gheader, idum, jmp, kmp
       write(ioun7,2020) xdim, zdim, rzero, rgrid1, zmid
       write(ioun7,2020) rmaxis, zmaxis, ssimag, ssibry, bcentr
       write(ioun7,2020) cpasma, ssimag, xdum, rmaxis, xdum
       write(ioun7,2020) zmaxis, xdum, ssibry, xdum, xdum
       write(ioun7,2020) (fg(j), j=1,t_jm,jinc)
       write(ioun7,2020) (prg(j), j=1,t_jm,jinc)	
       write(ioun7,2020) (ffpg(j), j=1,t_jm,jinc)	
       write(ioun7,2020) (pdg(j), j=1,t_jm,jinc)	
       write(ioun7,2020) ((psiv(j,k), j=1,t_jm,jinc), k=1,t_km,kinc)
       write(ioun7,2020) (rpx(j), j=1,t_jm,jinc)
       IF (t_inv_eq == 1) THEN
          write(ioun7,2022) t_mls, t_nplates+1
          write(ioun7,2020) (pt01*t_rls(i), pt01*t_zls(i), i=1,t_mls)
       ELSE
          write(ioun7,2022) s_mlse, t_nplates+1
          write(ioun7,2020) (pt01*s_rlse(i), pt01*s_zlse(i), i=1,s_mlse)
       END IF
       IF(t_nplates/=0) THEN
          write(ioun7,2020) (pt01*t_rplate(i,1), pt01*t_zplate(i,1),&
               i=1,t_nplates),pt01*t_rplate(t_nplates,2), pt01*t_zplate(t_nplates,2)
       END IF
       write(ioun7,2024) kvtor, rvtor, nmass
    ELSEIF (eqdsk_type == "i") then ! write i-file (inv --> Glasser's DCON)
       write(ioun7) t_msrf, t_mls
       write(ioun7) ((t_psrf(m) - t_psil)*pow_8, m=1,t_msrf)
       write(ioun7) (t_frsrf(m)*pow_6, m=1,t_msrf)
       write(ioun7) (t_prsrf(m)*pt1, m=1,t_msrf)
       write(ioun7) (t_qsrf(m), m=1,t_msrf)
       write(ioun7) ((pt01*t_rlsd(i,m,1), i=1,t_mls), m=1,t_msrf)
       write(ioun7) ((pt01*t_zlsd(i,m,1), i=1,t_mls), m=1,t_msrf)
    ELSEIF (eqdsk_type == "t") then ! write t-file (inv --> Turnbull's GATO)
       dnnorm = 1
       write(ioun7,3000) t_rundate
       write(ioun7,3001) t_theader
       write(ioun7,3002) t_msrf, t_lmax, (2-t_nsym)
       write(ioun7,3003) pt01*t_ro, pt01*t_raxis, pt01*t_zaxis, t_btor*pow_4
       write(ioun7,3003) t_placur, t_esrf(1), dnnorm
       write(ioun7,3003) ( t_psrf(m)*pow_8, m=1,t_msrf)
       write(ioun7,3003) (t_frsrf(m)*pow_6, m=1,t_msrf)
       write(ioun7,3003) (t_frsrf(m)*t_fpsrf(m)*pow_4, m=1,t_msrf)
       write(ioun7,3003) (t_prsrf(m)*pt1, m=1,t_msrf)
       write(ioun7,3003) (t_pdsrf(m)*pow7, m=1,t_msrf)
       write(ioun7,3003) ( t_qsrf(m), m=1,t_msrf)
       write(ioun7,3003) (t_vpsrf(m), m=1,t_msrf)
       write(ioun7,3003) (t_pdls(i,2)*0.0, i=1,t_lmax)
       write(ioun7,3003) (t_pdls(i,3)*0.0, i=1,t_lmax)
       write(ioun7,3003) ((t_rlsd(i,m,1)*pt01, m=1,t_msrf), i=1,t_lmax)
       write(ioun7,3003) ((t_zlsd(i,m,1)*pt01, m=1,t_msrf), i=1,t_lmax)
       write(ioun7,3003) ((bri(i,m)*pow_4, m=1,t_msrf), i=1,t_lmax)
       write(ioun7,3003) ((bzi(i,m)*pow_4, m=1,t_msrf), i=1,t_lmax)

    END IF ! PART II

    CALL giveupus(ioun7)
    CALL basclose(ioun7)
    ! Restore shotName
    IF (t_shotName == "eqdsk") t_shotName=""


    DEALLOCATE(psg,prg,pdg,ffpg,fg,fpg,rpx,bri,bzi,psiv)

1040 format(1x,4e16.9)
1041 format(1x,4i5)
1042 format(1x,a42,1x,a3)
1053 format(1x,a16,1x,i5)
1055 format(1x,a)
1060 format(1h*,f7.2,10x,i5,11x,i5,1x,a3,1x,i3,1x,i3,1x,a3,1x,2i5)

2000 format(a48,3i4)
2020 format(5e16.9)
2022 format(2i5)
2024 format(i5,e16.9,i5)

3000 format(a8)
3001 format(a)
3002 format(3i5)
3003 format(4(1PE19.12))

  END SUBROUTINE wreqdskf
  SUBROUTINE set_headers(tunits)
    
    ! Set header strings for EQDSK a- and g-files.

    CHARACTER(len=*) :: tunits
    CHARACTER(len=8) :: date
    CHARACTER(len=10) :: time
    CHARACTER(len=5) :: zone
    CHARACTER(len=7) :: time_str
    CHARACTER(len=3), DIMENSION(12) :: mn= &
         (/'Jan','Feb','Mar','Apr','May','Jun', &
           'Jul','Aug','Sep','Oct','Nov','Dec'/)
    INTEGER, DIMENSION(8) :: values

    ! Construct time string
    IF (tunits == "s") THEN
       WRITE(time_str,'(I5,"s ")') INT(t_shotTime+0.5)
    ELSE IF (tunits == "µs" .OR. tunits == "us") THEN
       WRITE(time_str,'(I5,"µs")') INT(1000000*t_shotTime+0.5)
    ELSE ! Assume ms
       WRITE(time_str,'(I5,"ms")') INT(1000*t_shotTime+0.5)
    ENDIF
   
    ! Construct header for a-file
    CALL DATE_AND_TIME(date,time,zone,values)
    t_aheader=date(7:8)//"-"//mn(values(2))//"-"//date(3:4)//" "//t_codedate

    ! Construct header for g-file
    IF (LEN_TRIM(t_shotName) <= 6) THEN ! Standard header
       t_gheader="  TEQ g    "//date(5:6)//"/"//date(7:8)//"/"//date(1:4)
       t_gheader=TRIM(t_gheader)//"    #"//t_shotName(1:6)//" "//time_str
    ELSE ! C-Mod style header
       t_gheader="  TEQ G      "//date(5:6)//"/"//date(7:8)//"  /"//date(1:4)
       t_gheader=TRIM(t_gheader)//"     "//t_shotName(1:10)//" "//time_str
    END IF

  END SUBROUTINE set_headers

  SUBROUTINE fopen_c(ioun,ioname)
    INTEGER, INTENT(INOUT) :: ioun
    CHARACTER*(*),INTENT(IN) ::  ioname
    CHARACTER(len=3) :: fmt
    INTEGER len
    DATA fmt/'old'/,len/0/
    CALL freeus(ioun)
    IF(ioun>0) THEN
       OPEN(unit=ioun,file=ioname,status=fmt,err=99999)
       RETURN
    ELSE
       WRITE(STDOUT,10001) 
       WRITE(t_logunit,10001) 
       CALL kaboom(0)
    END IF
99999 CONTINUE
       WRITE(STDOUT,10002) ioname 
       WRITE(t_logunit,10002) ioname
       CALL kaboom(0)
10001 format("ceq: No free io units available for ioun")
10002 format("Error opening disk file ",a)
  END SUBROUTINE fopen_c

  FUNCTION iopen(ioun,ioname) RESULT(iiopen)
    INTEGER, INTENT(INOUT) :: ioun
    INTEGER ::  iiopen
    CHARACTER*(*),INTENT(IN) ::  ioname
    CHARACTER(len=11) :: fmt
    INTEGER len
    DATA fmt/'unformatted'/,len/0/
    CALL freeus(ioun)
    IF(ioun>0) THEN
       OPEN(unit=ioun,file=ioname,form=fmt,err=99999)
       iiopen = OK
       RETURN
    ELSE
       WRITE(STDOUT,10001) 
       WRITE(t_logunit,10001) 
    END IF
99999 cONTINUE
    WRITE(STDOUT,10002) ioname 
    WRITE(t_logunit,10002) ioname
    iiopen = ERR
10001 format("ceq: No free io units available for ioun")
10002 format("Error opening disk file ",a)
  END FUNCTION iopen

  FUNCTION icreate(ioun,ioname) RESULT(iicreate)
    INTEGER, INTENT(INOUT) :: ioun
    INTEGER :: iicreate
    CHARACTER*(*),INTENT(IN) ::  ioname
    CHARACTER(len=9) :: fmt
    DATA fmt/'formatted'/
    CALL freeus(ioun)
    IF(ioun>0) THEN
       OPEN(unit=ioun,file=ioname,form=fmt,err=99999)
       iicreate = OK
       RETURN
    ELSE
       WRITE(STDOUT,10001) 
       WRITE(t_logunit,10001) 
    END IF
99999 CONTINUE
    WRITE(STDOUT,10002) ioname 
    WRITE(t_logunit,10002) ioname
    iicreate = ERR
10001 format("ceq: No free io units available for ioun")
10002 format("Error creating disk file ",a)
  END FUNCTION icreate

  SUBROUTINE io_close
    IF(ioun12 > 0 .AND. ioun12 /= STDOUT) THEN
       REWIND(ioun12)
       CALL giveupus(ioun12)
       CALL basclose(ioun12)
    END IF
  END SUBROUTINE io_close

  SUBROUTINE read_ext(geqdsk)
    CHARACTER*(*), INTENT(IN) :: geqdsk
    CALL fopen_c(ioun12,geqdsk)
    READ(ioun12,'(52x,2i4)')t_jm,t_km
    t_inv_eq=0
    t_msrf=t_jm
    IF(t_map==0) t_map=64
    t_jmkm=t_jm*t_km
    CALL genTeq
    CALL cont_read_ext
  END SUBROUTINE read_ext

  SUBROUTINE cont_read_ext
    REAL(rq) ::  xdim,zdi,rzero,rgrid,zmid,rmaxis,zmaxis,ssimag1,ssibry1,&
         bcentr,ssimag2,ssibry2,xdum,zdim
    integer i,ios,k,n
    read(ioun12,'(5e16.9)')xdim,zdim,rzero,rgrid,zmid
    read(ioun12,'(5e16.9)')rmaxis,zmaxis,ssimag1,ssibry1,bcentr
    read(ioun12,'(5e16.9)')t_plcm,ssimag2,xdum,rmaxis,xdum
    read(ioun12,'(5e16.9)')zmaxis,xdum,ssibry2,xdum,xdum
    read(ioun12,'(5e16.9)')(t_vpsrf(i),i=1,t_msrf)
    read(ioun12,'(5e16.9)')(t_jtsrf(i),i=1,t_msrf)
    read(ioun12,'(5e16.9)')(t_jparsrf(i),i=1,t_msrf)
    read(ioun12,'(5e16.9)')(t_jparsrf(i),i=1,t_msrf)
    read(ioun12,'(5e16.9)')(t_psi(i),i=1,t_jmkm)
    read(ioun12,'(5e16.9)',iostat=ios)(t_jparsrf(i),i=1,t_msrf)
    CALL io_close
    t_psi=t_psi*1.0e+08
    t_dr=xdim/(t_jm-1)
    t_dz=zdim/(t_km-1)
    t_psix=ssimag1*1.0e+08_rq
    t_psil=ssibry1*1.0e+08_rq
    t_plcm=t_plcm*1.0e-06_rq
    t_dpsi0=t_psil-t_psix
    s_psilim=t_psil
    s_pin=sign(1.0_rq,t_dpsi0)
    t_phibar=(/(i,i=0,t_msrf-1)/)/(t_msrf-1.0_rq)
    t_vpsrf=ABS(t_vpsrf)*1.0e+06_rq
    t_jtsrf=ABS(t_jtsrf)*10
    t_rn=xdim*100
    t_rx=t_rn+rgrid*100
    t_zx=zdim*50
    t_ro=0.5_rq*(t_rx+t_rn)
    CALL setgeo(t_rm,t_zm)
    i_cps(:,1,1)=t_psi
    CALL t_stretch(t_lsrf,t_psil,t_psix)
    CALL interp_interp(t_phibar,t_vpsrf,t_splbdry,t_splbdry,t_psibar,t_frsrf,&
         t_fpsrf)
    CALL interp_interp(t_phibar,t_jtsrf,t_splbdry,t_splbdry,t_psibar,t_prsrf,&
         t_pdsrf)
    CALL interp_interp(t_phibar,t_jparsrf,t_splbdry,t_splbdry,t_psibar,t_qsrf,&
         t_vpsrf)
    t_fpsrf=t_fpsrf/t_dpsi0
    t_pdsrf=t_pdsrf/t_dpsi0
    t_qsave=t_qsrf
    t_fsave=t_frsrf
    t_fwall=t_frsrf(t_msrf)
    t_btor=t_fwall/t_ro
  END SUBROUTINE cont_read_ext

  SUBROUTINE geqdsk__flux(geqdsk)
    !     FLUX COORDINATES etc. FROM geqdsk FILE
    CHARACTER*(*) geqdsk
    !     Needs rlimm and zlimm the limiter; may need need rxpr and zxpr
    CALL read_ext(geqdsk)
    CALL flux_geom
  END SUBROUTINE geqdsk__flux

  SUBROUTINE flux_geom
    !  ROUTINE WHICH COMPUTES FLUX GEOMETRY
    REAL(rq) ::  rho(t_mls),psil_
    integer imth,l
    data imth /11/

    IF(ALLOCATED(i_rhosq)) DEALLOCATE(i_rhosq)
    IF(t_n6==6) THEN
       ALLOCATE(i_rhosq(t_msrf*t_mls,2,3))
       i_rhosq=0
    ELSE
       ALLOCATE(i_rhosq(t_msrf*t_mls,4,4))
       i_rhosq=0
    END IF
    CALL i_t(i_rhosq)

    t_ixp=2
    psil_=s_psilim
    t_theta=(t_pxpt-psil_)/(t_pxpt-t_psix)
    IF(t_theta<0) t_theta=0
    IF(t_thetac/=0) t_theta=t_thetac
    CALL gs_separatrix
    t_dpsi0=t_psil-t_psix
    t_dpsi00=t_dpsi0
    t_brwpts=cos(t_tswpts)
    t_bzwpts=sin(t_tswpts)
    CALL surfaces_separatrix(t_psibar,t_rlsd,t_zlsd)
    t_rhosq(:,:,1)=transpose((t_rlsd(:,:,1)-t_raxis)**2+&
         ((t_zlsd(:,:,1)+t_zaxis)/t_wvert)**2)
    CALL get_rhosq
    DO l=1,t_msrf
       rho=sqrt(t_rhosq(l,:,1))+errt_rq
       t_rlsd(:,l,2)=(0.5*t_rhosq(l,:,3)/rho*t_brwpts-rho*t_bzwpts)
       t_zlsd(:,l,2)=(0.5*t_rhosq(l,:,3)/rho*t_bzwpts+rho*t_brwpts)*t_wvert
       t_rlsd(:,l,3)=0.5*t_rhosq(l,:,2)/rho*t_brwpts/t_dpsi0
       t_zlsd(:,l,3)=0.5*t_rhosq(l,:,2)/rho*t_bzwpts*t_wvert/t_dpsi0
       t_zlsd(:,l,4)=0.5*t_wvert*t_rhosq(l,:,2)*t_rlsd(:,l,1)/t_dpsi0
       ! Jacobian
       t_rlsd(:,l,4)=sqrt(t_rlsd(:,l,2)**2+t_zlsd(:,l,2)**2)&
            /abs(t_zlsd(:,l,4))
       ! Bpol
    END DO
    t_rlsd(:,1,4)=errt_rq ! To avoid zero divides
    CALL get_surfint
  END SUBROUTINE flux_geom

END MODULE ioTeq_mod
