c------------------------------------------------------------------
      subroutine trxpl_ufiles(tokdev,zdate,scvals,sclabs,numsc)
c
c  Ufile write interface
c
c  can write profiles as Ufiles.  All Ufiles will incorporate all scalars.
c  can either write f(rho) 1d Ufiles or 2d Ufiles f(R,Z) if the profile
c  has been extended to the (R,Z) space.
c
c  ** caution ** Ufiles are single precision.  Precision will be lost.
c
c  inputs:  passed arguments
c  outputs:  Ufiles.
c
c  scalars:
c
      implicit NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
c
      character*4 tokdev                ! tokamak id
      character*10 zdate                ! shot date
c
      integer numsc                     ! number of scalars
      real*8 scvals(numsc)              ! scalar values
      character*10 sclabs(3,numsc)      ! scalar names, labels, units.
c
c------------------------------------------------
c  profile information (to be fetched from trxplib routines)
c
      integer, parameter :: maxpr = 1000
      integer numpr                     ! number of profiles
      integer idlist(maxpr)             ! xplasma id # for each profile
      character*10 prlabel(3,maxpr)     ! profiles labels, units
      integer pr_magdim(maxpr)          ! presence code:  f(rho,...)
      integer pr_magord(maxpr)          ! spline ordering
      integer pr_rzdim(maxpr)           ! presence code:  f(R,Z,...)
      integer pr_rzord(maxpr)           ! spline ordering
c
c  pr_magdim(j)=0 if its f(R,Z) only
c  pr_rzdim(j)=0 if no f(R,Z) is available.
c
c----------------------------------------------------------
      integer i,j,k,inc,ierr,ilz,idim,ityp
      integer inumR,inumZ,inumrho,inumth,inumphi,istat,iwarn
      integer iBR,iBZ,iBphi,ishot,ixid
      logical default
c
      real*8 Rmin,Rmax,Zmin,Zmax,rhomin,rhomax,thmin,thmax
c
      real*8, dimension(:), allocatable :: rhoarr,tharr,Rarr,Zarr,data1
      real*8, dimension(:,:), allocatable :: data2
      real*8, dimension(:), allocatable :: wk
c
      integer lnout
      logical lxout,lchar,lyes
      character*70 zline
      character*10 zanswer
      character*10 zdate2,zshot,zdigs
      character*20 zuflbl
c
      character*10 rholab(3),thlab(3),Rlab(3),Zlab(3)
      character*4 jlbl
c
c
      save inumR,inumZ,inumrho,inumth,inumphi
      data default/.TRUE./
      data zdigs/'0123456789'/
c
c----------------------------------------------------------
c
      rholab(1)='rho'
      rholab(2)=' '
      rholab(3)=' '
c
      thmin=0.0_R8
      thmax=2.0_R8*acos(-1.0_R8)
c
      thlab(1)='theta'
      thlab(2)=' '
      thlab(3)='radians'
c
      Rlab(1)='R'
      Rlab(2)=' '
      Rlab(3)='m'
c
      Zlab(1)='Z'
      Zlab(2)=' '
      Zlab(3)='m'
c
      jlbl(1:4)='ZLHS'
c
c  how many digits in shot no.?
c
      j=10
      do i=1,10
         if(index(zdigs,sclabs(3,1)(i:i)).eq.0) then
            j=i-1
            exit
         endif
      enddo
c
      if(j.gt.6) then
         if((sclabs(3,1)(1:1).eq.'7').or.
     >      (sclabs(3,1)(1:1).eq.'8').or.
     >      (sclabs(3,1)(1:1).eq.'9')) then
            zdate2='19'//sclabs(3,1)(1:2)
         else
            zdate2='20'//sclabs(3,1)(1:2)
         endif
         read(sclabs(3,1)(j-5:j),'(I6)') ishot
      else
         if((zdate(1:1).eq.'7').or.
     >      (zdate(1:1).eq.'8').or.
     >      (zdate(1:1).eq.'9')) then
            zdate2='19'//zdate(1:2)
         else
            zdate2='20'//zdate(1:2)
         endif
         zshot=' '
         zshot(6-j+1:6)=sclabs(3,1)(1:j) ! right justify
         read(zshot(1:6),'(I6)') ishot
      endif
c
      numpr=0
c
      k=0
      call trx_uget_next(k)
c
      iBR=0
      iBZ=0
      iBphi=0
c
      do while(k.gt.0)
c
c  get the profile information
c
         numpr=numpr+1
         idlist(numpr)=k
         if(numpr.gt.maxpr) then
            call errmsg_exit(' ?? trxpl_ufiles:  too many profiles.')
         else
            call trx_uget(k,ixid,prlabel(1,numpr),prlabel(3,numpr),
     >         istat,ierr)
            if(prlabel(1,numpr).eq.'BR') iBR=k
            if(prlabel(1,numpr).eq.'BZ') iBZ=k
            if(prlabel(1,numpr).eq.'BPHI') iBphi=k
            if(ierr.ne.0) then
               write(lnout(0),*) ' ?? trxpl_ufiles:  trx_uget error.'
               numpr=numpr-1
            else
               if(istat.gt.0) then
                  write(lnout(0),*) ' %caution:  may not be MKS:  ',
     >               prlabel(1,numpr),prlabel(3,numpr)
               endif
               prlabel(2,numpr)='(trxpl)'
               call eq_fun(k,pr_magdim(numpr),pr_magord(numpr),
     >            pr_rzdim(numpr),pr_rzord(numpr),iwarn,ierr)
               if((iwarn.gt.0).or.(ierr.gt.0)) then
                  write(lnout(0),*)
     >               ' %eq_fun error on:  ',prlabel(1,numpr)
                  numpr=numpr-1
               else
c  kluge for Bmod
                  if(prlabel(1,numpr).eq.'BMOD') then
                     pr_rzord(numpr)=1
                     pr_rzdim(numpr)=2
                  endif
               endif
            endif
         endif
         call trx_uget_next(k)
      enddo
c
      if(lxout(0)) then
         write(lnout(0),*) ' '
         write(lnout(0),*) ' trxpl_ufiles:  available profiles:'
         write(lnout(0),*) '   S=Spline  H=Hermite  L=Linear Pieces'
         write(lnout(0),*) ' name       units      f(rho)',
     >      ' f(rho,theta) f(R,Z)'
         write(lnout(0),*) ' '
         do i=1,numpr
            zline=' '//prlabel(1,i)//' '//prlabel(3,i)
            j=pr_magord(i)+2
            if(pr_magdim(i).eq.1) zline(26:26)=jlbl(j:j)
            if(pr_magdim(i).eq.2) zline(36:36)=jlbl(j:j)
            j=pr_rzord(i)+2
            if(pr_rzdim(i).eq.2) zline(46:46)=jlbl(j:j)
            write(lnout(0),*) zline
         enddo
         write(lnout(0),*) ' '
      endif
c
      if(default) call eq_ngrids(inumrho,inumth,inumphi,inumR,inumZ)
c
      call eq_rzlims(Rmin,Rmax,Zmin,Zmax,ierr)
      if(ierr.ne.0) return
      call eq_rholim(rhomin,rhomax)
c
 10   continue
      if(lxout(0)) then
         write(lnout(0),1000) 'flux grid (x)',inumrho,rhomin,rhomax
         write(lnout(0),1000) 'theta grid (th)',inumth,thmin,thmax
         write(lnout(0),1000) 'major rad (R)',inumR,Rmin,Rmax
         write(lnout(0),1000) 'elevation (Z)',inumZ,Zmin,Zmax
 1000    format(1x,a,' npts = ',i4,' min = ',1pd11.4,' max = ',1pd11.4)
         write(lnout(0),1001)
 1001    format(/
     >      ' enter a profile name for Ufile write options, or...'/
     >      ' enter "N" to reset grid sizes, or...'/
     >      ' enter "Q!" for Q profile'/
     >      ' enter "Q" to quit.')
      endif
c
      call ureadw('trxpl_ufiles:  enter option:$',zanswer)
c
      if(zanswer.eq.'Q') then
c
c  quit
c
         return
c
      else if(zanswer.eq.'N') then
c
c  set grid sizes
c
         call uread(' enter "Y" to select default sizes:$')
         if(lyes(0)) then
            default=.TRUE.
            call eq_ngrids(inumrho,inumth,inumphi,inumR,inumZ)
         else
            default=.FALSE.
            call ureadi(' no. of x pts (min 4):$',inumrho)
            inumrho=max(4,inumrho)
            call ureadi(' no. of th pts (min 4):$',inumth)
            inumrho=max(4,inumth)
            call ureadi(' no. of R pts (min 4):$',inumR)
            inumR=max(4,inumR)
            call ureadi(' no. of Z pts (min 4):$',inumZ)
            inumZ=max(4,inumZ)
         endif
c
      else
         if(zanswer.eq.'Q!') zanswer='Q'
         k=0
         do i=1,numpr
            if(zanswer.eq.prlabel(1,i)) k=i
         enddo
         if(k.eq.0) then
            call uermsg('?unrecognized profile name: ',zanswer,0)
         else
            ilz=len_trim(zanswer)
            if(pr_magdim(k).eq.0) then
               ityp=3
               idim=2
               zuflbl=zanswer(1:ilz)//' f(R,Z)'
            else if(pr_rzdim(k).eq.0) then
               if(pr_magdim(k).eq.1) then
                  ityp=1
                  idim=1
                  zuflbl=zanswer(1:ilz)//' f(rho)'
               else
                  ityp=2
                  idim=2
                  zuflbl=zanswer(1:ilz)//' f(rho,theta)'
               endif
            else
               call uread(
     >            ' enter "1" for mag coords., "2" for f(R,Z) Ufile:$')
               if(lchar('1')) then
                  if(pr_magdim(k).eq.1) then
                     ityp=1
                     idim=1
                     zuflbl=zanswer(1:ilz)//' f(rho)'
                  else
                     ityp=2
                     idim=2
                     zuflbl=zanswer(1:ilz)//' f(rho,theta)'
                  endif
               else if(lchar('2')) then
                  ityp=3
                  idim=2
                  zuflbl=zanswer(1:ilz)//' f(R,Z)'
               else
                  call uermsg(' must answer "1" or "2".',' ',0)
                  go to 10
               endif
            endif
c
            if(lxout(0)) then
               write(lnout(0),*) ' Ufile:  ',zuflbl,
     >            ' on evenly spaced grid.'
            endif
            call uread(' enter "Y" to verify:$')
            if(lyes(0)) then
c
               call ureadi(' shot number for naming Ufile:$',ishot)
               if(ityp.eq.1) then
c
c  1d Ufile
c
                  allocate(rhoarr(inumrho))
                  allocate(data1(inumrho))
                  do i=1,inumrho
                     rhoarr(i)=rhomin+(i-1)*(rhomax-rhomin)/(inumrho-1)
                  enddo
c
c  interpolation
c
                  call eq_rgetf(inumrho,rhoarr,idlist(k),0,data1,ierr)
                  if(ierr.eq.0) then
c
c  get filename, open, write, close
c
                     call ufnter(99,zuflbl)
                     call ufopwr(99,ishot,ierr)
                     if(ierr.eq.0) then
                        call r8_uf1dwr(99,tokdev,zdate2,
     >                     rhoarr,data1,inumrho,0,
     >                     rholab,prlabel(1,k),numsc,scvals,sclabs,ierr)
                     endif
                     call ufclos(99)
                  endif
c
                  deallocate(rhoarr)
                  deallocate(data1)
c
               else if(ityp.eq.2) then
c
c  2d Ufile f(rho,theta)
c
                  allocate(rhoarr(inumrho))
                  allocate(data1(inumrho))
 
                  do i=1,inumrho
                     rhoarr(i)=rhomin+(i-1)*(rhomax-rhomin)/(inumrho-1)
                  enddo
 
                  allocate(tharr(inumth))
                  do i=1,inumth
                     tharr(i)=thmin+(i-1)*(thmax-thmin)/(inumth-1)
                  enddo
 
                  allocate(data2(inumrho,inumth))
 
                  do j=1,inumth
                     data1=tharr(j)
c
c  for each theta value get all rho values
c
                     call eq_frhochi(inumrho,rhoarr,data1,1,idlist(k),
     >                  inumrho,data2(1,j),ierr)
                     if(ierr.ne.0) exit
                  enddo
c
c  get filename, open, write, close
c
                  if(ierr.eq.0) then
                     call ufnter(99,zuflbl)
                     call ufopwr(99,ishot,ierr)
                     if(ierr.eq.0) then
                        call r8_uf2dwr(99,tokdev,zdate2,
     >                     data2,inumrho,rhoarr,inumrho,tharr,inumth,0,
     >                     prlabel(1,k),rholab,thlab,
     >                     numsc,scvals,sclabs,ierr)
                     endif
                     call ufclos(99)
                  endif
c
                  deallocate(rhoarr)
                  deallocate(tharr)
                  deallocate(data1)
                  deallocate(data2)
c
               else if(ityp.eq.3) then
c
c  2d Ufile f(R,Z)
c
                  allocate(Rarr(inumR))
                  allocate(Zarr(inumZ))
                  allocate(data1(inumR))
                  allocate(data2(inumR,inumZ))
                  if(prlabel(1,k).eq.'BMOD') allocate(wk(inumR))
c
                  do i=1,inumR
                     Rarr(i)=Rmin+(i-1)*(Rmax-Rmin)/(inumR-1)
                  enddo
c
                  do i=1,inumZ
                     Zarr(i)=Zmin+(i-1)*(Zmax-Zmin)/(inumZ-1)
                  enddo
c
                  do j=1,inumZ
                     data1=Zarr(j)
c
c  for each Z interpolate to all R values
c
                     if(prlabel(1,k).ne.'BMOD') then
                        call eq_frz(inumR,Rarr,data1,1,idlist(k),inumR,
     >                     data2(1,j),ierr)
                     else
                        call eq_frz(inumR,Rarr,data1,1,iBR,inumR,
     >                     wk,ierr)
                        if(ierr.ne.0) exit
                        data2(1:inumR,j)=wk**2
                        call eq_frz(inumR,Rarr,data1,1,iBZ,inumR,
     >                     wk,ierr)
                        if(ierr.ne.0) exit
                        data2(1:inumR,j)=data2(1:inumR,j)+wk**2
                        call eq_frz(inumR,Rarr,data1,1,iBphi,inumR,
     >                     wk,ierr)
                        data2(1:inumR,j)=data2(1:inumR,j)+wk**2
                        data2(1:inumR,j)=sqrt(data2(1:inumR,j))
                     endif
                     if(ierr.ne.0) exit
                  enddo
                  if(ierr.eq.0) then
c
c  get filename, open, write, close
c
                     call ufnter(99,zuflbl)
                     call ufopwr(99,ishot,ierr)
                     if(ierr.eq.0) then
                        call r8_uf2dwr(99,tokdev,zdate2,
     >                     data2,inumR,Rarr,inumR,Zarr,inumZ,0,
     >                     prlabel(1,k),Rlab,Zlab,
     >                     numsc,scvals,sclabs,ierr)
                     endif
                     call ufclos(99)
                  endif
c
                  deallocate(Rarr)
                  deallocate(Zarr)
                  deallocate(data1)
                  deallocate(data2)
                  if(prlabel(1,k).eq.'BMOD') deallocate(wk)
               endif
            endif                       ! Ufile write request verified.
c
         endif                          ! profile name verified.
      endif                             ! option select.
c
      go to 10
      end
