      module constants
!DK constants
!***********************************************************************
!! holds constants from mathematics and physics
!***********************************************************************
      integer, parameter :: rprec = selected_real_kind(12,100)

      real(rprec), parameter ::      pi = 3.14159265358979312
      real(rprec), parameter ::   twopi = 6.28318530717958623
      real(rprec), parameter ::  onerad = 1.74532925199432955E-02
      real(rprec), parameter ::     muo = 1.25663706143591729E-06
      real(rprec), parameter :: sqrtmuo = 1.12099824327958572E-03
      save
      end module constants

      module diagno_input
!***********************************************************************
!! This module contains the input for diagno generated by nemec
!! Does only read ascii input files, to avoid library dependencies.
      use constants
      implicit none

!!mf=number of pol. Fourier coefficients, m=0, ... , mf
!!nf=number of tor. Fourier coefficients  n=-nf, ... , nf
!!np=number of field periods
      integer :: mf,nf,np

!!pot=array holding potential
!!cr =Fourier coefficients for R
!!cz =Fourier coefficients for z
      real(rprec), dimension(:,:), allocatable :: pot,cr,cz

!!raxfc,zaxfc = Fourier coefficients of axis filament carrying
!!              the plasma current in case of vmec200
      real(rprec), dimension(:), allocatable :: raxfc,zaxfc

!----------- could be made dynamic ---------------
!     integer, parameter :: nc=4        !w7as
!     integer, parameter :: nc=5        !w7as_cc
!     integer, parameter :: nc=7        !w7x
!!number of coils
      integer :: nc     !number of coils

!!allocatable array to hold coil currents
      real(rprec), dimension(:), allocatable :: current

!-----------
      integer :: ivertb
      real(rprec) :: phiedge, tor_cur, deltbz

      integer :: nu,nv,nuv,nvp,nuvp

!! string identifying the calculation
      character(60) :: id_string
!! string identifying the machine: W7-AS, W7-X
      character(50) :: machine_string
!! string identifying the input format: nemec93, vmec2000
      character(50) :: input_form
!! filenames for database files for fluxloops and seg.Rogowski coils
      character(256) :: fdb_fluxloops, fdb_SegRogCoils
!! filenames for coils files
      character(256) :: diagno_coils_file, vert_field_file
!! filenames for barrow parameter file
      character(256) :: barrow_param_file
!! filenames for calculation of diagnostics
      character(256) :: flux_diag_file, bprobes_file, mir1_file, &
     &                 seg_rog_file, bfield_points_file

      logical :: lwrpl_surf, ltrace_progress, lcomp_dia, lflux_comb
      integer :: old_input_form, old_cnv_form
      real(rprec), dimension(100) :: flux_turns, dia_comp_coefs,  &
     &                               seg_rog_turns, flux_comb_coefs

      namelist /diagno_in/ nu, nv, input_form, diagno_coils_file,  &
     &  machine_string, vert_field_file, old_input_form, old_cnv_form, &
     &  flux_diag_file, bprobes_file, mir1_file, seg_rog_file,  &
     &  bfield_points_file, barrow_param_file,  &
     &  fdb_fluxloops, fdb_SegRogCoils, lwrpl_surf,ltrace_progress,  &
     &  flux_turns, lcomp_dia, dia_comp_coefs, seg_rog_turns,  &
     &  lflux_comb, flux_comb_coefs

!!   the specification of a file in the namelist enables the corresponding
!!   computation and output

!! For input_form == 'nemec93', old_input_form specifies format of input file
!!   0 -->   unformatted input (old way)
!!   1 -->     formatted input (old way)
!!   2 -->           xdr input (old way)
!!   3 -->   unformatted input
!!   4 -->     formatted input
!!   5 -->           xdr input
!! and old_cnv_form specifies format for conversion format
!!   no conversion if idiag(1) == idiag(2)
!!   0 -->   unformatted output
!!   1 -->     formatted output
!!   2 -->           xdr output
!!

!! -------------------------------------------------------------
!!    flags for enabling/controlling different analysis types
!!
!!   Historically set values:
!!   index    meaning
!!    1       set to old_input_form
!!    2       set to old_cnv_form
!!    3       =1 => make barrow plot
!!    4       =1 invoke bthdiag for bprobes
!!    5       =1 invoke bthdaig for seg_rog
!!    51      =1 and (5)=1, write to database fdb_SegRogCoils
!!    6       =1 invoke fluxdiag
!!    60      =1 compute and add compensated diamagnetic flux the fluxdiag output
!!    61      =1 and (6)=1, write to database fdb_fluxloops
!!    62      =1 compute and add to output linear combination of flux signals
!!    7       =1 invoke bthdiag for bfield_points
!!    8       =1 invoke write_plasma_surface (from write_pl_surf)
!!    9       =1 invoke bthdiag for mir1
!!
      integer, parameter :: maxdiag = 100
      integer, dimension(maxdiag) :: idiag = 0

      save

      contains

!------------- module subroutine -----------------
!! reads control data file holding above namelist, including
!! machine string and grid resolution data
      subroutine read_control_input
      implicit none

      character(80) :: text
      integer :: istat

!
!  initialize the input data
!
      lwrpl_surf = .false.
      ltrace_progress = .false.
      lcomp_dia = .false.
      lflux_comb = .false.

      nu = 100
      nv = 250

      input_form = 'vmec2000'
      old_input_form = 0
      old_cnv_form = 0

      diagno_coils_file = ''
      machine_string = 'W7-AS_cc'
      vert_field_file = ''

      flux_diag_file = ''
      flux_turns = 1
      dia_comp_coefs = 0
      flux_comb_coefs = 0

      bprobes_file = ''
      mir1_file = ''
      seg_rog_file = ''
      seg_rog_turns = 1
      bfield_points_file = ''

      barrow_param_file = ''

      fdb_fluxloops = ''
      fdb_SegRogCoils = ''

      idiag = 0

!
!  Read the control input data
!
      open(unit=20,file='diagno.control',status='old' &
     &    ,action='read', iostat=istat)
      if( istat /= 0) then
         stop 'Cant open diagno.control file'
      endif

      read (20, nml=diagno_in, iostat=istat)
      if( istat /= 0) then
         stop 'Cant open read diagno.control file'
      endif
      close(unit=20)

!
!    validate the input
!
      select case (input_form)
      case ("nemec93")
        if( ltrace_progress) write(6,*)'Old input form!  ',input_form
        idiag(1) = old_input_form
        idiag(2) = old_cnv_form
      case ("vmec2000")
        if( ltrace_progress) write(6,*)'New input form!  ',input_form
      case default
        write(6,*)'Unknown input form!'
        stop 'Check diagno_control.data for input_form!'
      end select

      select case (machine_string)
      case ("W7-AS")
        continue
      case ("W7-AS_cc")
        continue
      case ("W7-AS_ttf")
        continue
      case ("W7-X")
        continue
      case default
        write(6,*)'Unknown machine : ',machine_string
        stop 'Check diagno_control.data for machine_string!'
      end select
      if( ltrace_progress) write(6,*)'Machine to be handled: ',machine_string

      if( trim(diagno_coils_file).eq. '') &
     &    stop 'No coils file specified !!'

      if( machine_string(1:4) .eq. 'W7-AS' .and. &
     &    trim(vert_field_file) .eq. '') &
     &    stop 'W7-AS needs verical-field file input'

!      if( trim(barrow_param_file) .ne. '') idiag(3) = 1
      if( trim(bprobes_file) .ne. '') idiag(4) = 1
      if( trim(seg_rog_file) .ne. '') idiag(5) = 1
      if( trim(flux_diag_file) .ne. '') idiag(6) = 1
      if( lcomp_dia ) idiag(60) = 1
      if( lflux_comb ) idiag(62) = 1
      if( trim(bfield_points_file) .ne. '') idiag(7) = 1
      if( lwrpl_surf ) idiag(8) = 1
      if( trim(mir1_file) .ne. '') idiag(9) = 1

      if( trim(fdb_fluxloops) .ne. '' ) idiag(51) = idiag(5)
      if( trim(fdb_SegRogCoils) .ne. '') idiag(61) = idiag(6)

      end subroutine read_control_input
!--------- end module subroutine -----------------

!------------- module subroutine -----------------
!! reads input generated by nemec
      subroutine read_input
      implicit none

      if(input_form.eq."nemec93")then
        select case (machine_string)
        case ("W7-AS")
          if( ltrace_progress) write(6,*)'Coils for ',machine_string
          nc = 4
          call allocate_current
          call read_input_w7as
        case ("W7-AS_cc")
          if( ltrace_progress) write(6,*)'Coils for ',machine_string
          nc = 5
          call allocate_current
          call read_input_w7as_cc
        case ("W7-X")
          if( ltrace_progress) write(6,*)'Coils for ',machine_string
          nc = 7
          call allocate_current
          call read_input_w7x
        case default
          write(6,*)'Unknown machine : ',machine_string
          stop 'Check input for machine_string!'
        end select
      elseif(input_form.eq."vmec2000")then
        call read_input_vmec2000
      else
        stop "read_input: unknown input_form!"
      endif

      nuv = nu*nv
      nvp = nv*np
      nuvp = nuv*np
      if( ltrace_progress) then
         write(6,'(a38)')'    nu     nv      nuv     nvp    nuvp'
         write(6,'(5i8)') nu,nv,nuv,nvp,nuvp
      endif

      end subroutine read_input
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! allocates coil current array
      subroutine allocate_current
      implicit none
      integer :: i_alloc

      allocate(current(nc), stat = i_alloc)
      if(i_alloc /= 0) &
     &    stop 'Allocation of array current in read_input failed!'

      end subroutine allocate_current
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! reads input for W7-AS calculation without control coils
      subroutine read_input_w7as

      use constants

      implicit none
      integer :: lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,neuman
      real(rprec) :: curtor,curpol,bz0,totcur, &
     &        curmod,curson,curaux,curcoils,curivert,c_scale,m_scale
      integer :: i_alloc,i,j,ms,ns, i_show, isc_c, isc_m
      character(60) :: filename,outfilename
      character(15) :: action

!******************************
      i_show = 0
      if( ltrace_progress) i_show = 1 !0=noshow 1=show currents 2=curr+Four.coeff
      isc_c = 1     !scale currents by 1/sqrtmuo
      isc_m = 1     !scale dimensions from cm to m
      c_scale = 1
      m_scale = 1
      if(isc_c == 1) c_scale = 1/sqrtmuo
      if(isc_m == 1) m_scale = 0.01_rprec
      filename = 'diagno.input_data'
      outfilename = 'diagno.input_data.new'

      write(6,*) 'Enter mf,nf:'
      read(5,*)  mf,nf
      if( ltrace_progress) write(6,*)'mf = ',mf,'nf = ',nf
      allocate(pot(0:mf,-nf:nf),cr(0:mf,-nf:nf),cz(0:mf,-nf:nf),&
     &     stat = i_alloc)
      if(i_alloc /= 0) stop 'Allocation of arrays dread failed!'

      select case(idiag(1))
      case (0)
        rewind(15)
        read(15)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        read(15) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        read(15) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        read(15) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        read(15) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb
        if( ltrace_progress) write(6,*) &
     &      'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb

      case (1)
!       write(6,*)'Not yet implemented!'
        open(unit=15,file='diagno.input_data_ascii' &
     &      ,status='unknown',action='read')
        read(15,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        read(15,*) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        read(15,*) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        read(15,*) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        read(15,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb
        close(unit=15)

      case (2)
        write(6,*) &
     &    'Not active in diagno_input_simple.'
      case (3)
        write(6,*)'Not yet implemented!'
      case (4)
        write(6,*)'Not yet implemented!'
      case default
        write(6,*)'Unknown case in dread/module diagno_input: ' &
     &            ,idiag(1)
        stop ' Check diag.data!'
      end select

      if(idiag(1) /= idiag(2)) &
     &  call write_input_w7as(lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,&
     &     cr,cz,mf,nf,ms,ns,neuman,pot,curtor,curpol,bz0,totcur,  &
     &     phiedge,curmod,curson,curaux,curcoils,deltbz,curivert,  &
     &     ivertb)

      current(1) = curmod
      current(2) = curson
      current(3) = curaux
      current(4) = curivert
      current = c_scale*current
!     current(1) = 0
!     current(2) = 0
!     current(3) = 0
!     current(4) = 1000
!     curtor = 0
      tor_cur = c_scale*curtor
      cr(0:mf,0)=2*cr(0:mf,0)
      cz(0:mf,0)=2*cz(0:mf,0)
      cr = m_scale*cr
      cz = m_scale*cz
      pot = pot/c_scale
      phiedge = phiedge/c_scale*m_scale
      deltbz = deltbz/c_scale/m_scale
      np = lnvp/lnv
      if(i_show >= 1)then
        write(6,*)'lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu'
        write(6,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        write(6,*)'Number of field periods:',np
        write(6,*)'Coil currents ',machine_string,':'
        write(6,*)'      Im/A        I5/A      It/A         Iv/A'
        write(6,'(1p,9e12.4)')(current(i),i=1,nc)
        write(6,*)'      Bz/T'
        write(6,'(1p,e12.4)')deltbz
        write(6,*)'  tor.curr/A'
        write(6,'(1p,e12.4)')tor_cur
        if(i_show == 2)then
          do j=-nf,nf
            do i=0,mf
              write(6,'(2i4,1p2e14.5)')i,j,cr(i,j),cz(i,j)
            enddo
          enddo
        endif
      endif

      end subroutine read_input_w7as
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! reads input for W7-AS calculation with control coils
      subroutine read_input_w7as_cc

      use constants

      implicit none
      integer :: lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,neuman
      real(rprec):: curtor,curpol,bz0,totcur, &
     &        curmod,curson,curaux,curcoils,curivert, &
     &        curcor,c_scale,m_scale
      integer :: i_alloc,i,j,ms,ns, i_show, isc_c, isc_m, istat
      character(60) :: filename,outfilename
      character(15) :: action

!******************************
      i_show = 0
      if( ltrace_progress) i_show = 1 !0=noshow 1=show currents 2=curr+Four.coeff
      isc_c = 1     !scale currents by 1/sqrtmuo
      isc_m = 1     !scale dimensions from cm to m
      c_scale = 1
      m_scale = 1
      if(isc_c == 1) c_scale = 1/sqrtmuo
      if(isc_m == 1) m_scale = 0.01_rprec
      filename = 'diagno.input_data'
      outfilename = 'diagno.input_data.new'

      write(6,*) 'Enter mf,nf:'
      read(5,*)  mf,nf
      write(6,*)'mf = ',mf,'nf = ',nf
      allocate(pot(0:mf,-nf:nf),cr(0:mf,-nf:nf),cz(0:mf,-nf:nf),&
     &     stat = i_alloc)
      if(i_alloc /= 0) stop 'Allocation of arrays dread failed!'

      select case(idiag(1))
      case (0)
        rewind(15)
        read(15)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        read(15) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        read(15) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        read(15) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        read(15) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb

      case (1)
!       write(6,*)'Not yet implemented!'
        open(unit=15,file='diagno.input_data_ascii' &
     &      ,status='old', iostat=istat, action='read')
        if (istat .ne. 0) stop 'problem opening input_data_ascii'
        read(15,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        read(15,*) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        read(15,*) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        read(15,*) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        read(15,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb
        close(unit=15)

      case (2)
        write(6,*) &
     &    'Not active in diagno_input_simple.'
      case (3)
        write(6,*)'Not yet implemented!'
      case (4)
        write(6,*)'Not yet implemented!'
      case default
        write(6,*)'Unknown case in dread/module diagno_input: ' &
     &            ,idiag(1)
        stop ' Check diag.data!'
      end select

      if(idiag(1) /= idiag(2)) &
     &  call write_input_w7as_cc(lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,&
     &     cr,cz,mf,nf,ms,ns,neuman,pot,curtor,curpol,bz0,totcur,  &
     &     phiedge,curmod,curson,curaux,curcoils,deltbz,curivert,  &
     &     curcor,ivertb)

      current(1) = curmod
      current(2) = curson
      current(3) = curaux
      current(4) = curivert
      current(5) = curcor
      current = c_scale*current
!     current(1) = 0
!     current(2) = 0
!     current(3) = 0
!     current(4) = 1000
!     current(5) = 0
!     curtor = 0
      tor_cur = c_scale*curtor
      cr(0:mf,0)=2*cr(0:mf,0)
      cz(0:mf,0)=2*cz(0:mf,0)
      cr = m_scale*cr
      cz = m_scale*cz
      pot = pot/c_scale
      phiedge = phiedge/c_scale*m_scale
      deltbz = deltbz/c_scale/m_scale
      np = lnvp/lnv
      if(i_show >= 1)then
        write(6,*)'lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu'
        write(6,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        write(6,*)'Number of field periods:',np
        write(6,*)'Coil currents ',machine_string,':'
        write(6,*)'      Im/A        I5/A      It/A         Iv/A'&
     &           ,'     Icc/A'
        write(6,'(1p,9e12.4)')(current(i),i=1,nc)
        write(6,*)'      Bz/T'
        write(6,'(1p,e12.4)')deltbz
        write(6,*)'  tor.curr/A'
        write(6,'(1p,e12.4)')tor_cur
        write(6,*)'  phiedge/Wb'
        write(6,'(1p,e12.4)')phiedge
        if(i_show == 2)then
          do j=-nf,nf
            do i=0,mf
              write(6,'(2i4,1p3e14.5)')i,j,cr(i,j),cz(i,j),pot(i,j)
            enddo
          enddo
        endif
      endif

      end subroutine read_input_w7as_cc
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! writes different diagno input format corresponding to
!! read_input_w7as
      subroutine write_input_w7as &
     &    (lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,&
     &     cr,cz,mf,nf,ms,ns,neuman,pot,curtor,curpol,bz0,totcur, &
     &     phiedge,curmod,curson,curaux,curcoils,deltbz,curivert, &
     &     ivertb)

      use constants

      implicit none
      integer,intent(in) :: lnu,lnv,lnuv,lnvp,ivacfin, &
     &                      ms,ns,mf,nf,icon,isteu,neuman,ivertb
      real(rprec),intent(in) :: curtor,curpol,bz0,totcur,phiedge, &
     &        curmod,curson,curaux,curcoils,deltbz,curivert
      real(rprec), dimension(0:mf,-nf:nf), intent(in) :: cr,cz,pot
      integer :: i,j
      character(60) :: filename
      character(15) :: action

!******************************

      select case(idiag(2))
      case (0)
        rewind(15)
        write(15)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        write(15) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        write(15) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        write(15) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        write(15) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb

      case (1)
!       write(6,*)'Not yet implemented!'
        open(unit=15,file='diagno.input_data.new_ascii' &
     &      ,status='unknown',action='write')
        write(15,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        write(15,*) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        write(15,*) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        write(15,*) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        write(15,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,ivertb
        close(unit=15)

      case (2)
        write(6,*) &
     &    'Not active in diagno_input_simple.'
      case (3)
        write(6,*)'Not yet implemented!'
      case (4)
        write(6,*)'Not yet implemented!'
      case default
        write(6,*)'Unknown case in write_input_w7as/module',&
     &            ' diagno_input: ',idiag(2)
        stop ' Check diag.data!'
      end select

      end subroutine write_input_w7as
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! writes different diagno input format corresponding to
!! read_input_w7as_cc
      subroutine write_input_w7as_cc &
     &    (lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,&
     &     cr,cz,mf,nf,ms,ns,neuman,pot,curtor,curpol,bz0,totcur, &
     &     phiedge,curmod,curson,curaux,curcoils,deltbz,curivert, &
     &     curcor,ivertb)

      use constants

      implicit none
      integer,intent(in) :: lnu,lnv,lnuv,lnvp,ivacfin, &
     &                      ms,ns,mf,nf,icon,isteu,neuman,ivertb
      real(rprec),intent(in) :: curtor,curpol,bz0,totcur,phiedge, &
     &        curmod,curson,curaux,curcoils,deltbz,curivert,curcor
      real(rprec), dimension(0:mf,-nf:nf), intent(in) :: cr,cz,pot
      integer :: i,j
      character(60) :: filename
      character(15) :: action

!******************************

      select case(idiag(2))
      case (0)
        rewind(15)
        write(15)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been written.'
        write(15) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been written.'
        write(15) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been written.'
        write(15) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        write(15) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been written.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb

      case (1)
!       write(6,*)'Not yet implemented!'
        open(unit=15,file='diagno.input_data.new_ascii' &
     &      ,status='unknown',action='write')
        write(15,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been written.'
        write(15,*) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been written.'
        write(15,*) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been written.'
        write(15,*) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been written.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        write(15,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb
        if( ltrace_progress) write(6,*)'common block coilcurrents has been written.'
        if( ltrace_progress) write(6,*) &
     &     curmod,curson,curaux,curcoils,deltbz,curivert,curcor,ivertb
        close(unit=15)

      case (2)
        write(6,*) &
     &    'Not active in diagno_input_simple.'
      case (3)
        write(6,*)'Not yet implemented!'
      case (4)
        write(6,*)'Not yet implemented!'
      case default
        write(6,*)'Unknown case in write_input_w7as_cc/module',&
     &            ' diagno_input: ',idiag(2)
        stop ' Check diag.data!'
      end select

      end subroutine write_input_w7as_cc
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! reads input for W7-X calculation
      subroutine read_input_w7x

      use constants

      implicit none
      integer :: lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,neuman
      real(rprec) :: curtor,curpol,bz0,totcur, &
     &        cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils, &
     &        c_scale,m_scale
      integer :: i_alloc,i,j,ms,ns, i_show, isc_c, isc_m
      character(60) :: filename,outfilename
      character(15) :: action

!******************************
      i_show = 0
      if( ltrace_progress) i_show = 1    !0=noshow 1=show currents 2=curr+Four.coeff
      isc_c = 1     !scale currents by 1/sqrtmuo
      isc_m = 1     !scale dimensions from cm to m
      c_scale = 1
      m_scale = 1
      if(isc_c == 1) c_scale = 1/sqrtmuo
      if(isc_m == 1) m_scale = 0.01_rprec
      filename = 'diagno.input_data'
      outfilename = 'diagno.input_data.new'

      write(6,*) 'Enter mf,nf:'
      read(5,*)  mf,nf
      write(6,*)'mf = ',mf,'nf = ',nf
      allocate(pot(0:mf,-nf:nf),cr(0:mf,-nf:nf),cz(0:mf,-nf:nf),&
     &     stat = i_alloc)
      if(i_alloc /= 0) stop 'Allocation of arrays dread failed!'

      select case(idiag(1))
      case (0)
        rewind(15)
        read(15)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        read(15) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        read(15) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        read(15) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        read(15) &
     &        cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &        cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils

      case (1)
!       write(6,*)'Not yet implemented!'
        rewind(15)
        read(15,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        if( ltrace_progress) write(6,*)'common block vacgrid has been read.'
        read(15,*) ((cr(i,j),i=0,mf),j=-nf,nf), &
     &          ((cz(i,j),i=0,mf),j=-nf,nf),ms,ns,neuman
        if((mf /= ms).or.(nf /= ns)) &
     &    stop 'Restart with different values of mf and nf'

        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of boundary have been read.'
        read(15,*) ((pot(i,j),i=0,mf),j=-nf,nf)
        if( ltrace_progress) write(6,*) &
     &    'fourier coefficients of potential have been read.'
        read(15,*) curtor,curpol,bz0,totcur,phiedge
        if( ltrace_progress) write(6,*)'common block vbfield has been read.'
        if( ltrace_progress) write(6,*) curtor,curpol,bz0,totcur,phiedge
        read(15,*) &
     &        cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils
        if( ltrace_progress) write(6,*)'common block coilcurrents has been read.'
        if( ltrace_progress) write(6,*) &
     &        cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils

      case (2)
        write(6,*) &
     &    'Not active in diagno_input_simple.'
      case (3)
        write(6,*)'Not yet implemented!'
      case (4)
        write(6,*)'Not yet implemented!'
      case default
        write(6,*)'Unknown case in dread/module diagno_input: ' &
     &            ,idiag(1)
        stop ' Check diag.data!'
      end select

      if(idiag(1) /= idiag(2)) &
     &  call write_input_w7x(lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,&
     &     cr,cz,mf,nf,ms,ns,neuman,pot,curtor,curpol,bz0,totcur,  &
     &     phiedge,cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils)

      current(1) = cur1
      current(2) = cur2
      current(3) = cur3
      current(4) = cur4
      current(5) = cur5
      current(6) = curA
      current(7) = curB
      current = c_scale*current
!     current(1) = 0
!     current(2) = 0
!     current(3) = 0
!     current(4) = 1000
!     current(5) = 0
!     current(6) = 0
!     current(7) = 0
!     curtor = 0
      tor_cur = c_scale*curtor
      cr(0:mf,0)=2*cr(0:mf,0)
      cz(0:mf,0)=2*cz(0:mf,0)
      cr = m_scale*cr
      cz = m_scale*cz
      pot = pot/c_scale
      phiedge = phiedge/c_scale*m_scale
      np = lnvp/lnv
      if(i_show >= 1)then
        write(6,*)'lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu'
        write(6,*)  lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu
        write(6,*)'Number of field periods:',np
        write(6,*)'Coil currents ',machine_string,':'
        write(6,'(7a12)')'      I1/A  ','      I2/A  ','      I3/A  ', &
     &    '      I4/A  ','      I5/A  ','     I_A/A  ','     I_B/A  '
        write(6,'(1p,9e12.4)')(current(i),i=1,nc)
        write(6,*)'  tor.curr/A'
        write(6,'(1p,e12.4)')tor_cur
        if(i_show == 2)then
          do j=-nf,nf
            do i=0,mf
              write(6,'(2i4,1p2e14.5)')i,j,cr(i,j),cz(i,j)
            enddo
          enddo
        endif
      endif
      end subroutine read_input_w7x
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
!! Writes input for W7-X calculation corresponding
!! to read_input_w7x
      subroutine write_input_w7x(lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu,&
     &     cr,cz,mf,nf,ms,ns,neuman,pot,curtor,curpol,bz0,totcur,  &
     &     phiedge,cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils)

      implicit none
      integer :: lnu,lnv,lnuv,lnvp,ivacfin,icon,isteu, &
     &           mf,nf,ms,ns,neuman
      real(rprec), dimension(0:mf,-nf:nf) :: cr,cz,pot
      real(rprec) :: curtor,curpol,bz0,totcur,phiedge, &
     &        cur1,cur2,cur3,cur4,cur5,curA,curB,curcoils

      stop 'Sorry, implementation has just been started!'

      end subroutine write_input_w7x
!--------- end module subroutine -----------------
!------------- module subroutine -----------------
      subroutine read_input_vmec2000
      implicit none
      character(15) :: tline1
      integer :: mf1,mf2,m,n,nmin,i_alloc,i_show
      real(rprec) :: rdum

      open(unit=15,file='diagno_in.'//trim(id_string) &
     &      ,status='unknown',action='read')

      i_show = 0
      if( ltrace_progress) i_show = 1    !0=noshow 1=show currents 2=curr+Four.coeff
      read(15,*) tline1
      read(15,*) tline1
      read(15,*) np,mf1,nf
      mf = mf1+1    !vmec2000 uses m=0,...,mpol+1 for potvac
      mf2= mf1-1    !vmec2000 uses m=0,...,mpol-1 for r and z
      allocate(pot(0:mf,-nf:nf),cr(0:mf,-nf:nf),cz(0:mf,-nf:nf),&
     &     raxfc(0:nf), zaxfc(0:nf),&
     &     stat = i_alloc)
      if(i_alloc /= 0) stop 'Allocation of arrays dread failed!'
      pot = 0 ; cr = 0 ; cz = 0
      read(15,*) tline1
      do m=0,mf2
        nmin = -nf
        if(m == 0) nmin=0
        do n=nmin,nf
          read(15,*) cr(m,-n)   !vmec2000 uses cos(mu-nv) and
        enddo                   !diagno uses cos(mu+nv)
      enddo
      read(15,*) tline1
      do m=0,mf2
        nmin = -nf
        if(m == 0) nmin=0
        do n=nmin,nf
          read(15,*) cz(m,-n)   !vmec2000 uses cos(mu-nv) and
        enddo                   !diagno uses cos(mu+nv)
      enddo
      read(15,*) tline1
      do n=-nf,nf
        do m=0,mf
          read(15,*) pot(m,-n)  !vmec2000 uses (mu-nv) and
        enddo                   !diagno uses (mu+nv)
      enddo
      do n=1,nf
        pot(0, n) = -pot(0,-n)  !diagno assumes that also
      enddo                     !the other part is there.
      pot = -pot / 2            !sin goes to -sin
                                !factor 0.5 from old vacuum
      read(15,*) tline1
      read(15,*) phiedge
      read(15,*) tline1
      read(15,*) nc
!the number of external coils has to be redefined in the case
!of W7-AS because vmec2000 treats currently the vertical field
!system as 3 coils and diagno as 1 coil system, therefore
! nc(vmec2000) - 2 = nc(diagno)
      select case (machine_string)
      case ("W7-AS")
        if(nc /= 6) then
          write(6,*)'machine_string and number of ext.currents',&
     &              ' not consistent!'
          stop 'Check input data!'
        endif
        nc = nc-2
        call allocate_current
        read(15,*) tline1
        read(15,*) current
        current(1)=current(1)/8
        current(2)=current(2)/20
        current(3)=current(3)/12
        current(4)=current(4)*5/232.0_rprec
        ivertb = 1
        deltbz = 0
      case ("W7-AS_cc")
        if(nc /= 7) then
          write(6,*)'machine_string and number of ext.currents',&
     &              ' not consistent!'
          stop 'Check input data!'
        endif
        nc = nc-2
        call allocate_current
        read(15,*) tline1
        read(15,*) current
        current(1)=current(1)/8
        current(2)=current(2)/20
        current(3)=current(3)/12
        current(4)=current(4)/8
        current(5)=current(5)*5/232.0_rprec
        rdum = current(4)       !save Icor
        current(4) = - current(5) !put Ivert on position 4
        current(5) = rdum       !put Icor  on position 5
        ivertb = 1
        deltbz = 0
      case ("W7-X")
        if(nc /= 7) then
          write(6,*)'machine_string and number of ext.currents',&
     &              ' not consistent!'
          stop 'Check input data!'
        endif
        call allocate_current
        read(15,*) tline1
        read(15,*) current
      case default
        write(6,*)'Unknown machine : ',machine_string
        stop 'Check input for machine_string!'
      end select
      read(15,*) tline1
      read(15,*) tor_cur
      read(15,*) tline1
      read(15,*) raxfc
      read(15,*) tline1
      read(15,*) zaxfc
      zaxfc = -zaxfc  ! due to sin(-n v) = -sin( n v)
      if(i_show >= 1)then
        write(6,*)'Number of field periods:',np
        write(6,*)'Coil currents ',machine_string,':'
        write(6,'(5a12)')'      Im/A  ','      Is/A  ','      It/A  ', &
     &    '      Iv/A  ','      Ic/A  '
        write(6,'(1p,9e12.4)')(current(n),n=1,nc)
        write(6,*)'  tor.curr/A'
        write(6,'(1p,e12.4)')tor_cur
        if(i_show == 2)then
          do n=-nf,nf
            do m=0,mf
              write(6,'(2i4,1p3e14.5)')m,n,cr(m,n),cz(m,n),pot(m,n)
            enddo
          enddo
        endif
      endif

      end subroutine read_input_vmec2000
!--------- end module subroutine -----------------

      end module diagno_input

      module coilsystem
!! contains information about coil systems used, i.e. coil geometry
!! and the subroutines to read it

      use constants
      use diagno_input

      implicit none

      integer :: nall,ntopo
      real(rprec), dimension(:), allocatable :: xw,yw,zw,curre
      integer :: nc_vert
      real(rprec), dimension(:), allocatable :: r_v,z_v,f_v

      save

      contains

!-------------------------------------------------
      subroutine readcoil(machine_string)

      implicit none

      character(10), intent(in) :: machine_string

      select case (machine_string)

      case ("W7-AS")
        if( ltrace_progress) write(6,*)'Coils of ',machine_string,' requested!'
        call readcoil_w7as
        call readvert_w7as
      case ("W7-AS_ttf")  !with tilted tor.field coils
        if( ltrace_progress) write(6,*)'Coils of ',machine_string,' requested!'
        call readcoil_w7as_ttf
        call readvert_w7as
      case ("W7-AS_cc")  !with tilted tor.field coils and corr. coils
        if( ltrace_progress) write(6,*)'Coils of ',machine_string,' requested!'
        call readcoil_w7as_cc
        call readvert_w7as
      case ("W7-X")
        if( ltrace_progress) write(6,*)'Coils of ',machine_string,' requested!'
        call readcoil_w7x
      case default
        if( ltrace_progress) write(6,*)'Unknown machine : ',machine_string
        stop 'Check input for machine_string!'

      end select

      end subroutine readcoil
!-------------------------------------------------

!-------------------------------------------------
      subroutine readcoil_w7as

      use constants
      implicit none

      integer, parameter :: nspul= 1300
      integer :: nw,nw1,nwk,l,i_alloc,npol,k
      real(rprec) :: alp, co, si, r, r0, dr, dtheta

      ntopo = nspul*np
      allocate(xw(ntopo),yw(ntopo),zw(ntopo),curre(ntopo), &
     &      stat = i_alloc)
      if(i_alloc /= 0) &
     &        stop 'Allocation of arrays readcoil_w7as failed!'

      print *,'coils file:',diagno_coils_file
      open(unit=88,file=trim(diagno_coils_file),status='old' &
     &    ,action='read', iostat=i_alloc)
      if (i_alloc .ne. 0) then
         print *,'error opening w7as.coils file ',  &
     &            diagno_coils_file
         stop
       endif
!      rewind(88)
      read(88, *  ) nw
      if( ltrace_progress) write(6,'(a4,i3)') ' nw=',nw
      if( ltrace_progress) write(6,'(a6,i5)') 'ntopo=',ntopo
      if(nw>=nspul)then
        write(6,*)'nw >= nspul=',nspul
        stop 'Increase nspul'
      endif
      do l=1,nw
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      read(88,  * ) nw1
      if( ltrace_progress) write(6,'(a4,i3)') 'nw1=',nw1
      if(nw+nw1>nspul)then
        write(6,*)'nw > nspul=',nspul
        stop 'Increase nspul'
      endif
      do l=nw+1,nw+nw1
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      close(88)
!*************************************************
! conversion from [cm] to [m]
!*************************************************
      xw = xw/100
      yw = yw/100
      zw = zw/100

      curre = 0
      curre(1:49*8)      = 8*current(1)         !modular coils
      curre(490+1:49*18) = 8*current(1)         !modular coils
      curre(8*49+1:490)  = 20*current(2)        !special coils
      curre(18*49+1:20*49) = 12*current(3)      !tor.field coils
      curre(49:nw+nw1:49) = 0     !termination of single coil

!*************************************************
! symmetrisize coils !
!*************************************************
      l=0
      do k=1,8
        do npol=1,49
          xw(882-l) =  xw(l+1)
          yw(882-l) = -yw(l+1)
          zw(882-l) = -zw(l+1)
          l = l+1
        enddo
      enddo
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      l=1          ! First Sonder Coil filament
      do npol=1,23
        xw(441-l) =  xw(l+393)*co + yw(l+393)*si
        yw(441-l) =  xw(l+393)*si - yw(l+393)*co
        zw(441-l) = -zw(l+393)
        l = l+1
      enddo
      alp    = twopi/float(2*np)
      co     = cos(alp)
      si     = sin(alp)
      r =  sqrt(xw(393)**2 + yw(393)**2)
      xw(393) =  r*co
      yw(393) =  r*si
      zw(393) = 0
      r =  sqrt(xw(417)**2 + yw(417)**2)
      xw(417) =  r*co
      yw(417) =  r*si
      zw(417) = 0
      xw(441) =  xw(393)
      yw(441) =  yw(393)
      zw(441) = 0
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      l=1          ! Second Sonder Coil filament
      do npol=1,23
        xw(490-l) =  xw(l+442)*co + yw(l+442)*si
        yw(490-l) =  xw(l+442)*si - yw(l+442)*co
        zw(490-l) = -zw(l+442)
        l = l+1
      enddo
      alp    = twopi/float(2*np)
      co     = cos(alp)
      si     = sin(alp)
      r =  sqrt(xw(442)**2 + yw(442)**2)
      xw(442) =  r*co
      yw(442) =  r*si
      zw(442) = 0
      r =  sqrt(xw(466)**2 + yw(466)**2)
      xw(466) =  r*co
      yw(466) =  r*si
      zw(466) = 0
      xw(490) =  xw(442)
      yw(490) =  yw(442)
      zw(490) = 0
!*************************************************
! Calculate toroidal field coils
!*************************************************
      r0 = 2
      dr = 0.88_rprec
      alp = 13.5_rprec*onerad
      co     = cos(alp)
      si     = sin(alp)
      l=1
      do npol=1,23           ! upper half first coil
        dtheta = twopi/48
        xw(nw+1+l) = (r0+dr*cos(l*dtheta))*co
        yw(nw+1+l) = (r0+dr*cos(l*dtheta))*si
        zw(nw+1+l) =     dr*sin(l*dtheta)
        l = l+1
      enddo
      l=1
      do npol=1,23           ! lower half first coil
        dtheta = twopi/48
        xw(nw+49-l) =  xw(nw+1+l)
        yw(nw+49-l) =  yw(nw+1+l)
        zw(nw+49-l) = -zw(nw+1+l)
        l = l+1
      enddo
      xw(nw+1)  =  (r0+dr)*co
      yw(nw+1)  =  (r0+dr)*si
      zw(nw+1)  =  0
      xw(nw+25) =  (r0-dr)*co
      yw(nw+25) =  (r0-dr)*si
      zw(nw+25) =  0
      xw(nw+49) = xw(nw+1)
      yw(nw+49) = yw(nw+1)
      zw(nw+49) = 0
      l=0
      do npol=1,49           ! Second toroidal field coils
        xw(980-l) =  xw(l+883)
        yw(980-l) = -yw(l+883)
        zw(980-l) = -zw(l+883)
        l = l+1
      enddo
!-----------------------------
      nw     = nw + nw1                   ! do all in any case.
      nall   = nw*np
      alp    = twopi/float (np)
      co     = cos(alp)
      si     = sin(alp)
      do k=1,np-1
        nwk    = nw*k
        xw(nwk+1:nwk+nw) = xw(nwk-nw+1:nwk)*co - yw(nwk-nw+1:nwk)*si
        yw(nwk+1:nwk+nw) = xw(nwk-nw+1:nwk)*si + yw(nwk-nw+1:nwk)*co
        zw(nwk+1:nwk+nw) = zw(nwk-nw+1:nwk)
        curre(nwk+1:nwk+nw) = curre(1:nw)
      enddo
!     do k=1,nall
!       write(3,'(1p,4e14.5)')xw(k),yw(k),zw(k),curre(k)
!     enddo
!     stop

      end subroutine readcoil_w7as
!-------------------------------------------------
      subroutine readcoil_w7as_ttf
!- with tilted toroidal field coils ----

      use constants
      implicit none

      integer, parameter :: nspul= 1000
      integer :: nw,nw1,nwk,l,i_alloc,npol,k
      real(rprec) :: alp, co, si, r, r0, dr, dtheta
      real(rprec) :: th0, co2, si2

      ntopo = nspul*np
      allocate(xw(ntopo),yw(ntopo),zw(ntopo),curre(ntopo), &
     &      stat = i_alloc)
      if(i_alloc /= 0) &
     &        stop 'Allocation of arrays readcoil_w7as failed!'

      open(unit=88,file=trim(diagno_coils_file),status='old' &
     &    ,action='read', iostat=i_alloc)
      if (i_alloc .ne. 0) stop 'error opening w7as.coils file'
!      rewind(88)
      read(88, *  ) nw
      if( ltrace_progress) write(6,'(a4,i3)') ' nw=',nw
      if( ltrace_progress) write(6,'(a6,i5)') 'ntopo=',ntopo
      if(nw>=nspul)then
        write(6,*)'nw >= nspul=',nspul
        stop 'Increase nspul'
      endif
      do l=1,nw
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      read(88,  * ) nw1
      if( ltrace_progress) write(6,'(a4,i3)') 'nw1=',nw1
      if(nw+nw1>nspul)then
        write(6,*)'nw > nspul=',nspul
        stop 'Increase nspul'
      endif
      do l=nw+1,nw+nw1
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      close(88)
!*************************************************
! conversion from [cm] to [m]
!*************************************************
      xw = xw/100
      yw = yw/100
      zw = zw/100

      curre = 0
      curre(1:49*8)      = 8*current(1)         !modular coils
      curre(490+1:49*18) = 8*current(1)         !modular coils
      curre(8*49+1:490)  = 20*current(2)        !special coils
      curre(18*49+1:20*49) = 12*current(3)      !tor.field coils
      curre(49:nw+nw1:49) = 0     !termination of single coil

!*************************************************
! symmetrisize coils !
!*************************************************
      l=0
      do k=1,8
        do npol=1,49
          xw(882-l) =  xw(l+1)
          yw(882-l) = -yw(l+1)
          zw(882-l) = -zw(l+1)
          l = l+1
        enddo
      enddo
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      l=1          ! First Sonder Coil filament
      do npol=1,23
        xw(441-l) =  xw(l+393)*co + yw(l+393)*si
        yw(441-l) =  xw(l+393)*si - yw(l+393)*co
        zw(441-l) = -zw(l+393)
        l = l+1
      enddo
      alp    = twopi/float(2*np)
      co     = cos(alp)
      si     = sin(alp)
      r =  sqrt(xw(393)**2 + yw(393)**2)
      xw(393) =  r*co
      yw(393) =  r*si
      zw(393) = 0
      r =  sqrt(xw(417)**2 + yw(417)**2)
      xw(417) =  r*co
      yw(417) =  r*si
      zw(417) = 0
      xw(441) =  xw(393)
      yw(441) =  yw(393)
      zw(441) = 0
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      l=1          ! Second Sonder Coil filament
      do npol=1,23
        xw(490-l) =  xw(l+442)*co + yw(l+442)*si
        yw(490-l) =  xw(l+442)*si - yw(l+442)*co
        zw(490-l) = -zw(l+442)
        l = l+1
      enddo
      alp    = twopi/float(2*np)
      co     = cos(alp)
      si     = sin(alp)
      r =  sqrt(xw(442)**2 + yw(442)**2)
      xw(442) =  r*co
      yw(442) =  r*si
      zw(442) = 0
      r =  sqrt(xw(466)**2 + yw(466)**2)
      xw(466) =  r*co
      yw(466) =  r*si
      zw(466) = 0
      xw(490) =  xw(442)
      yw(490) =  yw(442)
      zw(490) = 0
!*************************************************
! Calculate toroidal field coils
!*************************************************
      r0 = 2
      dr = 0.88_rprec
      alp = 13.5_rprec*onerad
      co     = cos(alp)
      si     = sin(alp)
      l=1
      th0 =-0.149_rprec*twopi/360
      co2    = cos(th0)
      si2    = sin(th0)
      l=1
      do l=0,48             ! do all
        dtheta = twopi/48
        xw(nw+l+1) = (r0+dr*cos(l*dtheta))*co + dr*sin(l*dtheta)*si2*si
        yw(nw+l+1) = (r0+dr*cos(l*dtheta))*si - dr*sin(l*dtheta)*si2*co
        zw(nw+l+1) =     dr*sin(l*dtheta)*co2
      enddo
      do l=1,23
        zw(nw+49-l) = -zw(nw+1+l)
      enddo
      xw(nw+1)  = (r0+dr)*co
      yw(nw+1)  = (r0+dr)*si
      zw(nw+1)  = 0
      xw(nw+25) = (r0-dr)*co
      yw(nw+25) = (r0-dr)*si
      zw(nw+25) = 0
      xw(nw+49) = xw(nw+1)
      yw(nw+49) = yw(nw+1)
      zw(nw+49) = 0
      l=0
      do npol=1,49           ! Second toroidal field coils
        xw(980-l) =  xw(l+883)
        yw(980-l) = -yw(l+883)
        zw(980-l) = -zw(l+883)
        l = l+1
      enddo
!-----------------------------
      nw     = nw + nw1                   ! do all in any case.
      nall   = nw*np
      alp    = twopi/float (np)
      co     = cos(alp)
      si     = sin(alp)
      do k=1,np-1
        nwk    = nw*k
        xw(nwk+1:nwk+nw) = xw(nwk-nw+1:nwk)*co - yw(nwk-nw+1:nwk)*si
        yw(nwk+1:nwk+nw) = xw(nwk-nw+1:nwk)*si + yw(nwk-nw+1:nwk)*co
        zw(nwk+1:nwk+nw) = zw(nwk-nw+1:nwk)
        curre(nwk+1:nwk+nw) = curre(1:nw)
      enddo
!     do k=1,nall
!       write(3,'(1p,4e14.5)')xw(k),yw(k),zw(k),curre(k)
!     enddo
!     stop
      end subroutine readcoil_w7as_ttf
!-------------------------------------------------
      subroutine readcoil_w7as_cc
!- with tilted toroidal field coils ----

      use constants
      implicit none

      integer, parameter :: nspul= 1000
      integer :: nw,nw1,nw2,nwk,l,i_alloc,npol,k
      real(rprec) :: alp, co, si, r, r0, dr, dtheta
      real(rprec) :: th0, co2, si2

      ntopo = nspul*np
      allocate(xw(ntopo),yw(ntopo),zw(ntopo),curre(ntopo), &
     &      stat = i_alloc)
      if(i_alloc /= 0) &
     &        stop 'Allocation of arrays readcoil_w7as failed!'

      open(unit=88,file=trim(diagno_coils_file),status='old' &
     &    ,action='read', iostat=i_alloc)
      if (i_alloc .ne. 0) then
         print *,'error opening w7as.coils file',diagno_coils_file
         stop
      endif
!      rewind(88)
      read(88, *  ) nw
      if( ltrace_progress) write(6,'(a4,i3)') ' nw=',nw
      if( ltrace_progress) write(6,'(a6,i5)') 'ntopo=',ntopo
      if(nw>=nspul)then
        write(6,*)'nw >= nspul=',nspul
        write(6,*)'Already ',nw, 'requested per period!'
        stop 'Increase nspul'
      endif
      do l=1,nw
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      read(88,  * ) nw1
      if( ltrace_progress) write(6,'(a4,i3)') 'nw1=',nw1
      if(nw+nw1>nspul)then
        write(6,*)'nw > nspul=',nspul
        write(6,*)'Already ',nw+nw1, 'requested per period!'
        stop 'Increase nspul'
      endif
      do l=nw+1,nw+nw1
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      read(88,  * ) nw2
      if( ltrace_progress) write(6,'(a4,i3)') 'nw2=',nw2
      if(nw+nw1+nw2>nspul)then
        write(6,*)'nw > nspul=',nspul
        write(6,*)nw+nw1+nw2, 'requested per period!'
        stop 'Increase nspul'
      endif
      do l=nw+nw1+1,nw+nw1+nw2
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      close(88)
!*************************************************
! conversion from [cm] to [m]
!*************************************************
      xw = xw/100
      yw = yw/100
      zw = zw/100

      curre = 0
      curre(1:49*8)      = 8*current(1)         !modular coils
      curre(490+1:49*18) = 8*current(1)         !modular coils
      curre(8*49+1:490)  = 20*current(2)        !special coils
      curre(18*49+1:20*49) = 12*current(3)      !tor.field coils
      curre(nw+nw1+ 1:nw+nw1+ 8) = 8*current(5) !corr. coils
      curre(nw+nw1+10:nw+nw1+17) = 8*current(5) !corr. coils
      curre(49:nw+nw1:49) = 0     !termination of single coil

!*************************************************
! symmetrisize coils !
!*************************************************
      l=0
      do k=1,8
        do npol=1,49
          xw(882-l) =  xw(l+1)
          yw(882-l) = -yw(l+1)
          zw(882-l) = -zw(l+1)
          l = l+1
        enddo
      enddo
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      l=1          ! First Sonder Coil filament
      do npol=1,23
        xw(441-l) =  xw(l+393)*co + yw(l+393)*si
        yw(441-l) =  xw(l+393)*si - yw(l+393)*co
        zw(441-l) = -zw(l+393)
        l = l+1
      enddo
      alp    = twopi/float(2*np)
      co     = cos(alp)
      si     = sin(alp)
      r =  sqrt(xw(393)**2 + yw(393)**2)
      xw(393) =  r*co
      yw(393) =  r*si
      zw(393) = 0
      r =  sqrt(xw(417)**2 + yw(417)**2)
      xw(417) =  r*co
      yw(417) =  r*si
      zw(417) = 0
      xw(441) =  xw(393)
      yw(441) =  yw(393)
      zw(441) = 0
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      l=1          ! Second Sonder Coil filament
      do npol=1,23
        xw(490-l) =  xw(l+442)*co + yw(l+442)*si
        yw(490-l) =  xw(l+442)*si - yw(l+442)*co
        zw(490-l) = -zw(l+442)
        l = l+1
      enddo
      alp    = twopi/float(2*np)
      co     = cos(alp)
      si     = sin(alp)
      r =  sqrt(xw(442)**2 + yw(442)**2)
      xw(442) =  r*co
      yw(442) =  r*si
      zw(442) = 0
      r =  sqrt(xw(466)**2 + yw(466)**2)
      xw(466) =  r*co
      yw(466) =  r*si
      zw(466) = 0
      xw(490) =  xw(442)
      yw(490) =  yw(442)
      zw(490) = 0
!*************************************************
! Calculate toroidal field coils
!*************************************************
      r0 = 2
      dr = 0.88_rprec
      alp = 13.5_rprec*onerad
      co     = cos(alp)
      si     = sin(alp)
      l=1
      th0 =-0.149_rprec*twopi/360
      co2    = cos(th0)
      si2    = sin(th0)
      l=1
      do l=0,48             ! do all
        dtheta = twopi/48
        xw(nw+l+1) = (r0+dr*cos(l*dtheta))*co + dr*sin(l*dtheta)*si2*si
        yw(nw+l+1) = (r0+dr*cos(l*dtheta))*si - dr*sin(l*dtheta)*si2*co
        zw(nw+l+1) =     dr*sin(l*dtheta)*co2
      enddo
      do l=1,23
        zw(nw+49-l) = -zw(nw+1+l)
      enddo
      xw(nw+1)  = (r0+dr)*co
      yw(nw+1)  = (r0+dr)*si
      zw(nw+1)  = 0
      xw(nw+25) = (r0-dr)*co
      yw(nw+25) = (r0-dr)*si
      zw(nw+25) = 0
      xw(nw+49) = xw(nw+1)
      yw(nw+49) = yw(nw+1)
      zw(nw+49) = 0
      l=0
      do npol=1,49           ! Second toroidal field coils
        xw(980-l) =  xw(l+883)
        yw(980-l) = -yw(l+883)
        zw(980-l) = -zw(l+883)
        l = l+1
      enddo
      l=0
      do npol=1,9               ! Second correction coil to get
        xw(998-l) =  xw(l+981)  ! a stellarator symmetric
        yw(998-l) = -yw(l+981)  ! second current since the
        zw(998-l) = -zw(l+981)  ! the currents are of equal sign
        l = l+1
      enddo
!-----------------------------
      nw     = nw + nw1 + nw2             ! do all in any case.
      nall   = nw*np
      alp    = twopi/float (np)
      co     = cos(alp)
      si     = sin(alp)
      do k=1,np-1
        nwk    = nw*k
        xw(nwk+1:nwk+nw) = xw(nwk-nw+1:nwk)*co - yw(nwk-nw+1:nwk)*si
        yw(nwk+1:nwk+nw) = xw(nwk-nw+1:nwk)*si + yw(nwk-nw+1:nwk)*co
        zw(nwk+1:nwk+nw) = zw(nwk-nw+1:nwk)
        curre(nwk+1:nwk+nw) = curre(1:nw)
      enddo
!     do k=1,nall
!       write(3,'(1p,4e14.5)')xw(k),yw(k),zw(k),curre(k)
!     enddo
!     stop

      end subroutine readcoil_w7as_cc
!-------------------------------------------------
      subroutine readvert_w7as
      use constants
      implicit none
      integer :: n,i_alloc

      open(unit=20,file=trim(vert_field_file),status='old' &
     &    ,action='read')

      read(20,*)nc_vert
      allocate(r_v(nc_vert),z_v(nc_vert),f_v(nc_vert), &
     &    stat = i_alloc)
      if(i_alloc /= 0) &
     &        stop 'Allocation of arrays readvert_w7as failed!'
      if( ltrace_progress) then
         write(6,*)'#Vertical field calculation using ',nc_vert,' Coils'
         write(6,*)'#Coil positions and number of filaments:'
         write(6,*)'#  R/m         z/m       #filaments'
      endif
      do n=1,nc_vert
        read(20,*) r_v(n),z_v(n),f_v(n)
        if( ltrace_progress) write(6,'(1p,3e12.4)') r_v(n),z_v(n),f_v(n)
      enddo
      close(unit=20)

      end subroutine readvert_w7as

      subroutine readcoil_w7x
! ----------------------------------------------------------------------
!
! Reads in the coordinates of a coilsystem. Indexcur marks the
! different parts of the coilsystem. Its value corresponds to
! the number of windings the conductor represents.
!
! ----------------------------------------------------------------------

      use constants
      implicit none

      integer, parameter :: nspul= 1300
      integer :: i,nw,nw1,nwk,l,i_alloc,npol,k
      real(rprec) :: alp, co, si

      ntopo = nspul*np
      allocate(xw(ntopo),yw(ntopo),zw(ntopo),curre(ntopo), &
     &      stat = i_alloc)
      if(i_alloc /= 0) &
     &        stop 'Allocation of arrays readcoil_w7x failed!'

      open(unit=88,file=trim(diagno_coils_file),status='old' &
     &    ,action='read', iostat=i_alloc)
      if (i_alloc .ne. 0) stop 'error opening w7x.coils file'
!      rewind(88)
!*************************************************
! Modular coils
!*************************************************
      read(88, *  ) nw
      if( ltrace_progress) write(6,'(i4)') nw
      do l=1,nw
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
        if(l.lt.10 .and. ltrace_progress) &
     &     write(6,'(1p,4e14.4)') xw(l),yw(l),zw(l),curre(l)
      enddo
!*************************************************
! Additional coils
!*************************************************
      read(88,  * ) nw1
      if( ltrace_progress) write(6,'(i4)') nw1
      if((nw+nw1).gt.nspul) then
        write(6,*)nw+nw1,' points for all coils!'
        write(6,*)nspul,' available! ==> Adjust nspul!'
        stop 'Emergency stop!'
      endif
      do l=nw+1,nw+nw1
        read(88,*   ) xw(l),yw(l),zw(l),curre(l)
      enddo

      close(88)
!*************************************************
! fix currents
! up to 13.Feb.2003 the winding number contained the old
!number of 120 windings instead of the new 108!
!*************************************************
      curre = 0
      curre(     1:   97) = 108*current(1)           !cur1
      curre(97*9+1:10*97) = 108*current(1)           !cur1
      curre(  97+1: 2*97) = 108*current(2)           !cur2
      curre(97*8+1: 9*97) = 108*current(2)           !cur2
      curre(2*97+1: 3*97) = 108*current(3)           !cur3
      curre(97*7+1: 8*97) = 108*current(3)           !cur3
      curre(3*97+1: 4*97) = 108*current(4)           !cur4
      curre(97*6+1: 7*97) = 108*current(4)           !cur4
      curre(4*97+1: 5*97) = 108*current(5)           !cur5
      curre(97*5+1: 6*97) = 108*current(5)           !cur5
      curre(nw+     1: nw+1*65) = 36*current(6)      !curA
      curre(nw+3*65+1: nw+4*65) = 36*current(6)      !curA
      curre(nw+1*65+1: nw+2*65) = 36*current(7)      !curB
      curre(nw+2*65+1: nw+3*65) = 36*current(7)      !curB
      curre(   97:nw    :97) = 0     !termination of single coil
      curre(nw+65:nw+nw1:65) = 0     !termination of single coil

!*************************************************
! symmetrisize coils !
!*************************************************
      i=0                ! Modular Coils
      do k=1,5
        do npol=1,97
          xw(970-i) =  xw(i+1)
          yw(970-i) = -yw(i+1)
          zw(970-i) = -zw(i+1)
          i = i+1
        enddo
      enddo
      i=0                ! Additional Coils
      do k=1,2
        do npol=1,65
          xw(1230-i) =  xw(i+971)
          yw(1230-i) = -yw(i+971)
          zw(1230-i) = -zw(i+971)
          i = i+1
        enddo
      enddo
!*************************************************
      nw     = nw + nw1                   ! Do all in any case.
      nall   = nw*np
      alp    = twopi/float(np)
      co     = cos(alp)
      si     = sin(alp)
      do k=1,np-1
        nwk    = nw*(k-1)
        xw   (1+nwk+nw:nw+nwk+nw) = xw(1+nwk:nw+nwk)*co - &
     &                              yw(1+nwk:nw+nwk)*si
        yw   (1+nwk+nw:nw+nwk+nw) = xw(1+nwk:nw+nwk)*si + &
     &                              yw(1+nwk:nw+nwk)*co
        zw   (1+nwk+nw:nw+nwk+nw) = zw(1+nwk:nw+nwk)
        curre(1+nwk+nw:nw+nwk+nw) = curre(1+nwk:nw+nwk)
      enddo
!     do i=1,nall
!       write(12,'(1p,4e14.4,7i4)')xw(i),yw(i),zw(i),curre(i)
!     enddo
!     stop

      return
      end subroutine readcoil_w7x
      end module coilsystem

      module surface_values
!! holds the arrays containing the function values for the surface
!! integrals. Contains the initializing function.
      use constants
      implicit none

!     interface
!       subroutine belicu (xp,yp,zp,bx,by,bz)

!       implicit none

!       real(rprec), intent(in)  :: xp,yp,zp
!       real(rprec), intent(out) :: bx,by,bz
!       end subroutine belicu
!     end interface
!     interface
!       subroutine becoil (x ,y ,z ,bx,by,bz)

!       implicit none

!       real(rprec),intent(in)  :: x ,y ,z   !cartesian coordinates
!       real(rprec),intent(out) :: bx,by,bz  !cartesian components of B
!       end subroutine becoil
!     end interface

      real(rprec), dimension(:), allocatable :: bexn,snx,sny,snz &
     &                                  ,xg,yg,zg &
     &                                  ,rg,rgu,zgu &
     &                                  ,atopx,atopy,atopz

!in case of input_form vmec2000 the axis is needed in tolicu
      real(rprec), dimension(:), allocatable :: rax, xax, yax, zax

      real(rprec) :: rav, z00max, zmidmax               !geom.of boundary
      real(rprec) :: r00min, r00max, rmidmin, rmidmax   !geom.of boundary

      contains

      subroutine initialize_surface_values
!-------------------------------------------------
! Initializes arrays for surface integrations
! based on surfaced written by H.Gardner
! ----------------------------------------------------------------------
!
!     purpose:  returns
!                    bexn = b0 dot df (the outward normal with the
!                           magnitude of the surface element) over the
!                           plasma boundary
!                    snx,sny,snz = cartesian coordinates of
!                        phi times df on the boundary
!                    xx,yy,z,xxbig,yybig,zzbig
!                          = cartesian coordinates of boundary
!                    r,ru,rv,z,zu,zv = cylindrical coordinates r,z
!                        and their derivatives w.r.t. u and v
!                    atopx,atopy,atopz = numerator in the expression
!                        for the vector potential due to the plasma
!                        currents
!
!
! ----------------------------------------------------------------------

      use constants
      use diagno_input

      implicit none

      integer :: i_alloc,i,k,ku,kv,m,n,ii1,ii2
      real(rprec) :: alp,alu,alv,alvp
      real(rprec) :: sw,cw,cop,sip
      real(rprec) :: bx,by,bz,br,bphi,xvdb0,xudb0,bxt,byt,bzt

! probably thought to be automatic arrays which won't work like that
!     real(rprec), dimension(nuv) :: bigphi,phiu,phiv,temp1, &
!    &         temp2,aax,aay,aaz,xxbig,yybig,zzbig
!     real(rprec), dimension(nuv) :: rgv,zgv    !rg,rgu,zgu already declared
!                                        !for use in barrow.
!     real, dimension(nv) :: sih,coh
!     real(rprec), dimension(0:mf,nuv) :: conu,sinu
!     real(rprec), dimension(-nf:nf,nuv) :: conv,sinv
      real(rprec), dimension(:), allocatable :: bigphi,phiu,phiv,temp1, &
     &         temp2,aax,aay,aaz,xxbig,yybig,zzbig
      real(rprec), dimension(:), allocatable :: rgv,zgv    !rg,rgu,zgu already declared
                                         !for use in barrow.
      real(rprec), dimension(:), allocatable :: sih,coh
      real(rprec), dimension(:,:), allocatable :: conu,sinu
      real(rprec), dimension(:,:), allocatable :: conv,sinv
!
!-- define constants --
!
      alp    = twopi / float(np)
      alu    = twopi / float(nu)
      alv    = twopi / float(nv)
      alvp   = twopi / float(nvp)
! allocations of locally used arrays
      allocate(bigphi(nuv),phiu(nuv),phiv(nuv),temp1(nuv), &
     &         temp2(nuv),aax(nuv),aay(nuv),aaz(nuv), &
     &         xxbig(nuv),yybig(nuv),zzbig(nuv), &
     &         rgv(nuv),zgv(nuv),sih(nv),coh(nv), &
     &         conu(0:mf,nuv),sinu(0:mf,nuv), &
     &         conv(-nf:nf,nuv),sinv(-nf:nf,nuv), &
     &         stat = i_alloc)
      if(i_alloc /= 0) &
     &  stop 'Allocation of temporary surface arrays in &
     &initialize_surface_values failed!'
!
! allocations
      allocate(bexn(nuvp),snx(nuvp),sny(nuvp),snz(nuvp) &
     &        ,xg(nuvp),yg(nuvp),zg(nuvp),rg(nuv),rgu(nuv),zgu(nuv) &
     &        ,atopx(nuvp),atopy(nuvp),atopz(nuvp) &
     &        ,stat = i_alloc)
      if(i_alloc /= 0) &
     &  stop 'Allocation of surface arrays in &
     &initialize_surface_values failed!'
!
! -- zero arrays --
!
      bigphi=0
      phiu = 0
      phiv = 0
      zg=0
      zgu=0
      zgv=0
      rg=0
      rgu=0
      rgv=0
!
! -- calculate trigonometric functions
!    (nb: nu,nv may be different here from in vacuumf) --
!
      conu(0,1:nuv) = 1
      sinu(0,1:nuv) = 0
      do m=1,mf
        do ku = 1,nu
          temp1(ku)=cos(alu*m*(ku-1))
          temp2(ku)= sin(alu*m*(ku-1))
        enddo
        do kv=1,nv
          ii1 = (kv-1)*nu+1
          ii2   = ii1+nu-1
          conu(m,ii1:ii2) = temp1(1:nu)
          sinu(m,ii1:ii2) = temp2(1:nu)
        enddo
      enddo
      conv(0,1:nuv) = 1
      sinv(0,1:nuv) = 0
      do n=1,nf
        i = 0
        do kv = 1,nv
          temp1(kv) = cos(alv*n*(kv-1))
          temp2(kv) = sin(alv*n*(kv-1))
        enddo
        do kv= 1,nv    !keep same order of nuv part w.r.to ku and kv
          ii1 = (kv-1)*nu+1
          ii2   = ii1+nu-1
          conv(n,ii1:ii2) = temp1(kv)
          sinv(n,ii1:ii2) = temp2(kv)
        enddo
        sinv(-n,1:nuv) = -sinv(n,1:nuv)
        conv(-n,1:nuv) =  conv(n,1:nuv)
      enddo
      do kv = 1,nv
        sih(kv)  = sin(alvp * (kv-1))
        coh(kv)  = cos(alvp * (kv-1))
      enddo
!-----------------------------------------------------------------------
! /* calculate the potential, phi, in real space
!                   (m=mf)  (n=nf)
!         phi = -2*   sum    sum   phi    * sin(twopi*(m*u+n*v))
!                    (m=0)  (n=-nf)   m,n
!
!         phi     = pot(m,n)   m.ge.1
!            m,n
!                 = 0.5*pot(m,n) m.eq.0
!
!   (mf,nf) are fourier coefficient ranges for the potential field */
!                           and
!  /*   calculate cylindrical coordinates and their derivatives
!
!   (ms,ns) are orig. fourier coefficient ranges for the plasma surface
!           which could be  (ms.le.mf  and ns.le.nf)    */
!   Up to now ms==mf and ns==nf had been used without problems!
!-----------------------------------------------------------------------
      do n=-nf,nf
        bigphi(1:nuv) = bigphi(1:nuv) -         pot(0,n)*sinv(n,1:nuv)
        phiv(1:nuv)   =   phiv(1:nuv) - twopi*n*pot(0,n)*conv(n,1:nuv)
        rg(1:nuv) =rg (1:nuv) +         cr(0,n)*conv(n,1:nuv)
        rgv(1:nuv)=rgv(1:nuv) - twopi*n*cr(0,n)*sinv(n,1:nuv)
        zg(1:nuv) =zg (1:nuv) +         cz(0,n)*sinv(n,1:nuv)
        zgv(1:nuv)=zgv(1:nuv) + twopi*n*cz(0,n)*conv(n,1:nuv)
        do m=1,mf
          do i = 1,nuv
            sw = sinu(m,i)*conv(n,i) &
     &                      + conu(m,i)*sinv(n,i)
            cw  = conu(m,i)*conv(n,i) &
     &                       - sinu(m,i)*sinv(n,i)
            bigphi(i) = bigphi(i) - 2*pot(m,n)*sw
            phiu(i) = phiu(i) - 2*twopi*m*pot(m,n)*cw
            phiv(i) = phiv(i) - 2*twopi*n*pot(m,n)*cw
            rg(i)  = rg (i) +         cr(m,n)*cw
            rgu(i) = rgu(i) - twopi*m*cr(m,n)*sw
            rgv(i) = rgv(i) - twopi*n*cr(m,n)*sw
            zg(i)  = zg (i) +         cz(m,n)*sw
            zgu(i) = zgu(i) + twopi*m*cz(m,n)*cw
            zgv(i) = zgv(i) + twopi*n*cz(m,n)*cw
          enddo
        enddo
      enddo
      do kv=1,nv
        do ku =1,nu
          i  = ku + nu*(kv-1)
          xg(i) = rg(i)*coh(kv)       !store cart.coord.
          yg(i) = rg(i)*sih(kv)       !store cart.coord.
        enddo
      enddo
      do k=2,np         !complete cart.coord. for belicu
        sip = sin((k-1)*alp)
        cop = cos((k-1)*alp)
        ii1 = (k-1)*nuv+1
        ii2 = k*nuv
        xg(ii1:ii2) = xg(1:nuv)*cop - yg(1:nuv)*sip
        yg(ii1:ii2) = yg(1:nuv)*cop + xg(1:nuv)*sip
        zg(ii1:ii2) = zg(1:nuv)
      enddo

!vmec2000 puts the net plasma current on the axis
      if(input_form .eq. "vmec2000")then
        allocate(rax(nvp+1),xax(nvp+1),yax(nvp+1),zax(nvp+1)&
     &          , stat=i_alloc)
        if(i_alloc /= 0) &
     &    stop 'Allocation of axis arrays in &
     &        initialize_surface_values failed!'
        rax = 0 ; xax = 0 ; yax = 0 ; zax = 0
        do kv=1,nv
          do n=0,nf
            rax(kv) = rax(kv)+raxfc(n)*conv(n,(kv-1)*nu+1)
            zax(kv) = zax(kv)+zaxfc(n)*sinv(n,(kv-1)*nu+1)
          enddo
          xax(kv) = rax(kv)*coh(kv)       !store cart.coord.
          yax(kv) = rax(kv)*sih(kv)       !store cart.coord.
        enddo
        do k=2,np         !complete cart.coord. for tolicu
          sip = sin((k-1)*alp)
          cop = cos((k-1)*alp)
          ii1 = (k-1)*nv+1
          ii2 = k*nv
          xax(ii1:ii2) = xax(1:nv)*cop - yax(1:nv)*sip
          yax(ii1:ii2) = yax(1:nv)*cop + xax(1:nv)*sip
          zax(ii1:ii2) = zax(1:nv)
        enddo
        xax(nvp+1)=xax(1)
        yax(nvp+1)=yax(1)
        zax(nvp+1)=zax(1)
      endif

      call average_radius_and_else
!
!  /* calculate components of outward normal (magnitude df) */
!
      if( ltrace_progress) write(6,*)'Calculating components of outward normal'
      temp1(1:nuv) = rgv(1:nuv)*zgu(1:nuv)-rgu(1:nuv)*zgv(1:nuv)
      temp2(1:nuv) = zgu(1:nuv)*rg(1:nuv)*alp
      snz(1:nuv) = -rgu(1:nuv) * rg(1:nuv) * alp
      do kv = 1 , nv
        ii1 = nu*(kv-1)+1
        ii2 = ii1+nu-1
        snx(ii1:ii2)= temp1(ii1:ii2)*sih(kv)+temp2(ii1:ii2)*coh(kv)
        sny(ii1:ii2)=-temp1(ii1:ii2)*coh(kv)+temp2(ii1:ii2)*sih(kv)
      enddo
!
!    /* calculate atopx,atopy,atopz : the cartesian components of the
!        numerator in expression for the vector potential due to
!        the plasma currents.
!        also calculate the components of b0 dot df. */
!           (allowing for net longitudinal current)
!
      if( ltrace_progress) write(6,*)'Calculating components of expr. in vec.pot. cal.'
      if( ltrace_progress) write(6,*)'Calling becoil quite often!'
      temp1(1:nuv) = rgu(1:nuv)*phiv(1:nuv) - rgv(1:nuv)*phiu(1:nuv)
      temp2(1:nuv) = -rg(1:nuv)*alp*phiu(1:nuv)
      aaz(1:nuv) = zgu(1:nuv)*phiv(1:nuv) - zgv(1:nuv)*phiu(1:nuv)
      if( ltrace_progress) write(6,'(3a28)')'phi=0: x           y        ' &
     &                ,'     z             Bx       ' &
     &                ,'     By            Bz       '
      do i =1,nu,nu/10
        call becoil(xg(i),yg(i),zg(i),bx,by,bz)
        if( ltrace_progress) write(6,'(1p,6e14.5)')xg(i),yg(i),zg(i),bx,by,bz
      enddo
      do kv=1,nv
        do ku =1,nu
          i  = ku + nu*(kv-1)
          call becoil(xg(i),yg(i),zg(i),bx,by,bz)
!         call belicu(xg(i),yg(i),zg(i),bxt,byt,bzt)
          bxt = tor_cur*bxt
          byt = tor_cur*byt
          bzt = tor_cur*bzt
          bx     = bx + bxt
          by     = by + byt
          bz     = bz + bzt
          br = bx*coh(kv) + by*sih(kv)
          bphi = -bx*sih(kv) + by*coh(kv)
          bexn(i) = snx(i)*bx + sny(i)*by + snz(i)*bz
          xvdb0 = rgv(i)*br + rg(i)*alp*bphi + zgv(i)*bz
          xudb0 = rgu(i)*br + zgu(i)*bz
          temp1(i) = temp1(i) + xvdb0*rgu(i) - xudb0*rgv(i)
          temp2(i) = temp2(i)               - xudb0*rg(i)*alp
          aaz(i) = aaz(i) + xvdb0*zgu(i) - xudb0*zgv(i)
        enddo
      enddo
      do kv = 1,nv
        ii1 = nu*(kv -1) + 1
        ii2 = ii1+nu-1
        aax(ii1:ii2)=temp1(ii1:ii2)*coh(kv)-temp2(ii1:ii2)*sih(kv)
        aay(ii1:ii2)=temp1(ii1:ii2)*sih(kv)+temp2(ii1:ii2)*coh(kv)
      enddo
!      /* multiply components of the normal by the potential
!         (for use in bpoly)  */
      snx(1:nuv) = snx(1:nuv) * bigphi(1:nuv)
      sny(1:nuv) = sny(1:nuv) * bigphi(1:nuv)
      snz(1:nuv) = snz(1:nuv) * bigphi(1:nuv)
!
!     /* complete calculation of atopx,y,z over the entire plasma */
!        as well as xg,yg,zg and snx,sny,snz and bexn.
!
      if( ltrace_progress) write(6,*)'Finishing calculation and extending over whole',&
     & ' plasma boundary!'
      do k=1,np
         sip = sin((k-1)*alp)
         cop = cos((k-1)*alp)
         ii1 = (k-1)*nuv+1
         ii2 = k*nuv
         atopx(ii1:ii2) = aax(1:nuv)*cop - aay(1:nuv)*sip
         atopy(ii1:ii2) = aay(1:nuv)*cop + aax(1:nuv)*sip
         atopz(ii1:ii2) = aaz(1:nuv)
      enddo
      do k=2,np
         sip = sin((k-1)*alp)
         cop = cos((k-1)*alp)
         ii1 = (k-1)*nuv+1
         ii2 = k*nuv
         snx(ii1:ii2) = snx(1:nuv)*cop - sny(1:nuv)*sip
         sny(ii1:ii2) = sny(1:nuv)*cop + snx(1:nuv)*sip
         snz(ii1:ii2) = snz(1:nuv)
         xg(ii1:ii2) = xg(1:nuv)*cop - yg(1:nuv)*sip
         yg(ii1:ii2) = yg(1:nuv)*cop + xg(1:nuv)*sip
         zg(ii1:ii2) = zg(1:nuv)
         bexn(ii1:ii2) = bexn(1:nuv)
      enddo

      if( ltrace_progress) write(6,*)'Freeing local allocations in surface values!'
      deallocate(bigphi,phiu,phiv,temp1, &
     &         temp2,aax,aay,aaz, &
     &         xxbig,yybig,zzbig, &
     &         rgv,rgu,sih,coh, &
     &         conu,sinu, &
     &         conv,sinv, &
     &         stat = i_alloc)
      if(idiag(8) ==1) call write_plasma_surface

      if( ltrace_progress) write(6,*)'Initializing surface values finished!'

      end subroutine initialize_surface_values
!-------------------------------------------------
      subroutine write_plasma_surface

      use constants
      use diagno_input

      implicit none

      integer :: i,j,k,is

      open(unit=11,file='plasma_surface.geom',status='unknown' &
     &    ,action='write')

!     do k=1,np
      do k=1,1
        do j=1,nv
          do i=1,nu
            is=(k-1)*nuv +(j-1)*nu+i
            write(11,'(3i4,1p,10e14.5)')k,j,i,xg(is),yg(is),zg(is)&
     &              ,snx(is),sny(is),snz(is),bexn(is) &
     &              ,atopx(is),atopy(is),atopz(is)
            if(is > nuvp)then
              write(6,*)'k,j,i,is:',k,j,i,is
              stop 'Alert is>nuvp!'
            endif
          enddo
          write(11,'(3a)') '###'
        enddo
      enddo

      close(unit=11)

      if(input_form .eq. "vmec2000")then
        open(unit=11,file='plasma_axis.geom',status='unknown' &
     &    ,action='write')

        do j=1,nvp+1
          write(11,'(i4,1p,3e14.5)')j,xax(j),yax(j),zax(j)
        enddo

        close(unit=11)
      endif
      stop 'Stop in write_plasma_surface'
      end subroutine write_plasma_surface
!-------------------------------------------------
      subroutine average_radius_and_else

      use constants
      use diagno_input

      implicit none

      integer :: ii1, ii2, j, k, m
!
!     /* find max. and min. r value at phi =  0 degrees  */
!
      ii1= 1
      ii2= nu
      if(ii2 > nuvp) stop 'Emergency stop : ii2 > nuv!!!'
      r00max = maxval(rg(ii1:ii2))
      r00min = minval(rg(ii1:ii2))
      if( ltrace_progress) then
         write(6,'(a25,1pe12.4)') ' rmin at phi= 0 degrees= ',r00min
         write(6,'(a25,1pe12.4)') ' rmax at phi= 0 degrees= ',r00max
      endif
      write(3,'(a25,1pe12.4)') ' rmin at phi= 0 degrees= ',r00min
      write(3,'(a25,1pe12.4)') ' rmax at phi= 0 degrees= ',r00max
!
!     /* find maximum z value at phi =  0 degrees  */
!
      ii1= 1
      ii2= nu
      if(ii2 > nuvp) stop 'Emergency stop : ii2 > nuv!!!'
      z00max = maxval(zg(ii1:ii2))
      if( ltrace_progress) write(6,'(a25,1pe12.4)') ' zmax at phi= 0 degrees= ',z00max
      write(3,'(a25,1pe12.4)') ' zmax at phi= 0 degrees= ',z00max
!
!     /* find max. and min. r value at phi = 36 degrees  */
!
      ii1= nv/2*nu + 1
      ii2= (nv/2 + 1)*nu
      if(ii2 > nuvp) stop 'Emergency stop : ii2 > nuv!!!'
      rmidmax = maxval(rg(ii1:ii2))
      rmidmin = minval(rg(ii1:ii2))
      if( ltrace_progress) then
         write(6,'(a25,1pe12.4)') ' rmin at phi=36 degrees= ',rmidmin
         write(6,'(a25,1pe12.4)') ' rmax at phi=36 degrees= ',rmidmax
      endif

      write(3,'(a25,1pe12.4)') ' rmin at phi=36 degrees= ',rmidmin
      write(3,'(a25,1pe12.4)') ' rmax at phi=36 degrees= ',rmidmax
!
!     /* find maximum z value at phi = 36 degrees (midplane) */
!
      ii1=nv/2*nu + 1
      ii2= (nv/2 + 1)*nu
      if(ii2 > nuvp) stop 'Emergency stop : ii2 > nuv!!!'
      zmidmax = maxval(zg(ii1:ii2))
      if( ltrace_progress) write(6,'(a25,1pe12.4)') ' zmax at phi=36 degrees= ',zmidmax
      write(3,'(a25,1pe12.4)') ' zmax at phi=36 degrees= ',zmidmax
!
!  calculate average minor radius using the Fourier coefficients
!
      rav = 0
      do m = 1,mf
        do j = -nf,nf
          do k = -nf,nf
            rav=rav+m*cr(m,k)*cz(m,j)*(1+(-1)**(k-j))
          enddo
        enddo
      enddo
      rav = sqrt(rav/2)
      write(3,'(a6,1p,e12.5,a1)') ' rav= ',rav,'m'
      if( ltrace_progress) write(6,'(a6,1p,e12.5,a1)') ' rav= ',rav,'m'
      return
      end subroutine average_radius_and_else
!-------------------------------------------------

      end module surface_values


 SUBROUTINE trarot (ecdis,ircon)
!
!  this routines controls Rigid body translation and rotation
!  of elements sets as strategy
!
 USE param_db,ONLY: mnam,mich
 USE ctrl_db, ONLY: ndime, npoin,neulr,nstra,text
 USE meshmo_db, ONLY : nodset,numpo,strnam
 USE nsets_db
 USE c_input
 USE npo_db, ONLY : label,coora,coorc,euler
 USE gvar_db, ONLY : actchk

 IMPLICIT NONE
 ! dummy arguments
   INTEGER  (kind=4), INTENT(IN) ::     ecdis     ! control DOF for output
   INTEGER  (kind=4), INTENT(IN OUT) :: ircon     ! counter of restart files
 ! Local variables
 LOGICAL :: found
 INTEGER (kind=4) :: chnode,i,k,rnod
 REAL (kind=8) :: tvec(ndime),rvec(ndime),rang,rpoi(ndime),q(ndime),r(ndime), &
                  lb(ndime,ndime),eul(9)
 TYPE (nset), POINTER :: ns
 CHARACTER (len=mnam) :: sname
 !Functions
 CHARACTER(len=mich):: inttoch   !Puts an integer into a string

 INTERFACE
   INCLUDE 'elemnt.h'
   INCLUDE 'outdyn.h'
 END INTERFACE

 WRITE(*,"(/,5X,'***  BEGIN STAGE ',A,': ',A,/)") TRIM(inttoch(nstra,0)),text
 WRITE(55,"(/,5X,'***  BEGIN STAGE ',A,': ',A,/)",ERR=9999) TRIM(inttoch(nstra,0)),text
 CALL timing(11,1)              !mesh modifications

 WRITE (*, 1002        )        !send a message to screen
 WRITE (lures,1002,ERR=9999)     !write a message to output file
 1002 FORMAT (4x, '--- T R A N S L A T I N G   &   R O T A T I N G--',//)

 IF( .NOT.actchk )THEN   ! write initial data for post-processing
   CALL wrtpos(0)
 END IF

 DO                                     !loop over element_sets to modify
   CALL listen ('TRAROT')               !read a line
   IF(exists('ENDSTR'))EXIT             !exit loop
   !          read translation vector
   IF ( exists('TRAVEC',i)) THEN        !if key-word exists
     DO k=1,ndime
       tvec(k) = param(i)
       i = i+1
     END DO
   ELSE                                 !no translation vector
     tvec = 0d0
   END IF
   !          read rotation vector (axis)
   rpoi = 0d0
   IF( ndime == 3 )THEN                 !for 3-D problems
     IF ( exists('ROTVEC',i)) THEN      !if key word exists
       DO k=1,ndime
         rvec(k) = param(i)
         i = i+1
       END DO
       CALL vecuni(ndime,rvec,rang)     !unit vector and rotation angle
       IF( rang /= 0d0 ) THEN           !if rotation vector is not null
         IF( exists('ROTANG',i)) rang = param(i)  !read rotation angle
         IF( exists('ROTPOI',i))THEN    !read coordinates of fixed point
           DO k=1,ndime
             rpoi(k) = param(i)
             i = i+1
           END DO
           rnod = 0
         ELSE IF( exists('ROTNOD',i) )THEN  !or read fixed node label
           rnod = INT(param(i))
           rnod = chnode(rnod)
           rpoi = coora(:,rnod)
         ELSE
           CALL runend('TRAROT: a fixed point must be defined')
         END IF
       END IF
     ELSE
       rvec = 0d0
     END IF
   ELSE         !for 2-D problems (rvec = Z)
     rang = 0d0
     IF( exists('ROTANG',i)) rang = param(i)
     IF( exists('ROTPOI',i))THEN    !read coordinates of the fixed point
       DO k=1,ndime
         rpoi(k) = param(i)
         i = i+1
       END DO
       rnod = 0
     ELSE IF( exists('ROTNOD',i))THEN !or read the fixed node label
       rnod = INT(param(i))
       rnod = chnode(rnod)
       rpoi = coora(:,rnod)
     ELSE IF( rang /= 0 )THEN                         !check
       CALL runend('TRAROT: a fixed point must be defined')
     END IF

   END IF
   rang = rang*ATAN(1d0)/45d0              !angle from degrees to radians
   IF( ndime == 3 )rvec = rvec*rang        !rotation vector

   ! compute rotation matrix
   IF( ndime == 3 )THEN
     CALL expot8(rvec(1),lb(1,1))
   ELSE
     lb = RESHAPE((/ COS(rang), -SIN(rang), SIN(rang), COS(rang) /), &
                  (/ ndime,ndime /))
   END IF
                          !modify associated sets
   coorc = coora          !initializes
   DO
     CALL listen('TRAROT')              !read a line
     IF(exists('ENDSET'))EXIT           !exit
     IF ( exists('ELMSET',k)) THEN      !an element set
       sname = get_name(posin=k,stype='ESET')        !Element set name
       WRITE(lures,"(/'element set name to translate and rotate: ',A)",ERR=9999) TRIM(sname)
       ! node set definition based on an element set
       CALL elemnt ('NODSET', name=sname, flag2=found) !get nodes in ELM_SET
       IF (.NOT.found) CALL runend('TRAROT:ELEMENT SET NOT FOUND       ')

     ELSE IF (exists('SET   ',k)) THEN  !a node set
       sname = get_name(posin=k,stype='NSET')         !node set name
       WRITE(lures,"(/'nodes set name to translate and rotate: ',A)",ERR=9999) TRIM(sname)
       ! node set definition based on an node set
       CALL nsdb_search (sname, found, ns)          !search in list of sets
       IF (found) THEN                      !set exists, position is NS
         numpo = get_length (ns)            !number of nodes in the set
         ALLOCATE (nodset(numpo))           !get memory
         CALL ns_head (ns)                  !go to top of list
         DO i =1, numpo                     !for each node in the list
           nodset(i) = get_label(ns)        !get node label
           CALL ns_next (ns)                !go to next node
         END DO
       ELSE                                 !else SET name not found => error
         CALL runend('TRAROT: NODE  SET NOT FOUND       ')
       END IF
     ELSE
       CALL runend ('trarot: ELM_SET or SET name expected.')
     END IF

     IF( actchk ) CYCLE !do not modify coordinates
     ! modify coordinates
     DO i=1,numpo                        !for each node in the set
       k = chnode(nodset(i))                     !global node
       q = coora(:,k) - rpoi             !vector from fixed point
       r = MATMUL(lb,q)                  !rotated vector
       coorc(:,k) = rpoi + tvec + r      !new coordinates
     END DO

     IF( neulr > 0 )THEN                 !if Euler angles exists
       IF( ndime == 3 )  CALL expot8(rvec(1),lb(1,1))    !rotation matrix

       DO i=1,numpo                     !for each node in the set
         k = chnode(nodset(i))                  !global node
         IF(ndime == 3) THEN            !for 3-D problems
           eul = euler(:,k)
           CALL proma1(euler(1,k),lb(1,1),eul(1),3,3,3)
         ELSE                           !for 2-D problems
           euler(1,k) = euler(1,k) + rang
         END IF
       END DO
     END IF

     DEALLOCATE (nodset)         !release memory
   END DO
   coora = coorc                       !same actual and previous coordinates
 END DO
 IF( .NOT.actchk )THEN
   ! write data and results for post-processing
   CALL outdyn(.FALSE.,.TRUE., ecdis)
   CALL dumpin(ircon,.TRUE.,.FALSE.,.FALSE.)
 END IF
 CALL timing(11,2)              !mesh modifications

 WRITE(*,"(5X,'***  END OF STAGE ',A,': ',A,/)") TRIM(inttoch(nstra,0)),text
 WRITE(55,"(5X,'***  END OF STAGE ',A,': ',A,/)",ERR=9999) TRIM(inttoch(nstra,0)),text

 RETURN
 9999 CALL runen2('')
 END SUBROUTINE trarot


      SUBROUTINE rpxy( lhdr, ihdr, setback )
!****  Given the source (x,y) and the range from the segy header,
!****  Remove the setback from the source x,y and rewrite 19 & 20 and
!****  compute the receiver (x,y) and write it in header 21 & 22
!
!  mod 24 Sep 09 - Compute the angle differently
!  mod 15 Mar 13 - make more variables REAL*8, treat first differently
!  mod 20 Mar 13 - Make wbaldwin changes for quadrant.
!
      INTEGER*4 lhdr(60), shotno1, shotno2
      INTEGER*2 ihdr(120)
      REAL*8 d19, d20, d21, d22, dtemp, ddlat, x1_deg, y1_deg, x2_deg,
     &   y2_deg, ddlong, angle, x1_m, y1_m, x2_m, y2_m, dx, dy
      DATA x1_deg/-99999./, x2_deg/-99999./, angle/-999./
      DATA pi/3.14159265358979/, rad/57.2957795131/, deg/.0174532925199/
      SAVE
!
      IF( ihdr(45) .NE. 2 ) THEN
          PRINT *,' ***  WARNING  *** SETBACK  not applied.  Nav must be
     & in arcseconds.'
          RETURN
      ENDIF
!      print *,' lhdr=',lhdr(19),lhdr(20)
      IF( x2_deg .EQ. -99999. ) THEN     ! is it the first shot?
          shotno1 = -1
          shotno2 = lhdr(3)
          d19 = DFLOAT(lhdr(19))
          d20 = DFLOAT(lhdr(20))
          IF( ihdr(36) .NE. 0 ) THEN
              dtemp = DFLOAT(ihdr(36))
              IF( ihdr(36) .LT. 0 ) dtemp = -1. / dtemp
              d19 = d19 * dtemp
              d20 = d20 * dtemp
          ENDIF
          d19 = d19 / (60.D0 * 60.D0 )    ! convert arcseconds to degrees
          d20 = d20 / (60.D0 * 60.D0 )
          CALL dlendeg( d20,ddlat,ddlong)
          x2_deg = d19
          y2_deg = d20
          x1_deg = d19
          y1_deg = d20
          x1_m = x1_deg * ddlong  ! 1 is the same as 2
          y1_m = y1_deg * ddlat
          x2_m = d19 * ddlong
          y2_m = d20 * ddlat
      ENDIF
      IF( shotno2 .NE. lhdr(3) ) THEN
!**** Use the existing angle if the same shot as before
          shotno1 = shotno2
          shotno2 = lhdr(3)
          d19 = DFLOAT(lhdr(19))
          d20 = DFLOAT(lhdr(20))
          IF( ihdr(36) .NE. 0 ) THEN
              dtemp = DFLOAT(ihdr(36))
              IF( ihdr(36) .LT. 0 ) dtemp = -1. / dtemp
              d19 = d19 * dtemp
              d20 = d20 * dtemp
          ENDIF
          d19 = d19 / (60.D0 * 60.D0 )
          d20 = d20 / (60.D0 * 60.D0 )
          x1_deg = x2_deg
          y1_deg = y2_deg
          x2_deg = d19
          y2_deg = d20
          CALL dlendeg( d20, ddlat, ddlong )
          x1_m = x1_deg * ddlong
          y1_m = y1_deg * ddlat
          x2_m = d19 * ddlong
          y2_m = d20 * ddlat
          angle = DATAN2((y2_m-y1_m),(x2_m-x1_m)) * rad
!       print *,' heading=',angle
          IF( (x2_m-x1_m) .LT. 0 .AND. (y2_m-y1_m) .GE. 0 ) THEN
              angle = 450.D0 - angle
          ELSE
              angle = 90.D0 - angle
          ENDIF
!       print *,' angle=',angle
         IF (angle .GT. 0 .AND. angle .LE. 180) THEN
              angle = angle + 180
          ELSE IF (angle .GT. 180 .AND. angle .LE. 360) THEN
              angle = angle - 180
          ENDIF
      ENDIF
      IF( shotno1 .LT. 0 ) RETURN
!	print *,' 1_m=',x1_m,y1_m,' 2=',x2_m,y2_m,' inverse_angle=',angle
!****
!****   Do the source coordinates
!****
      dtemp = setback
      dx = dtemp * DSIN(angle/rad)
      dy = dtemp * DCOS(angle/rad)
!	 print *,' dx=',dx,' dy=',dy,' dtemp=',dtemp,x2_m,y2_m
      d19 = x2_m + dx
      d20 = y2_m + dy
!	 print *,' d19=',d19,' d20=',d20, ihdr(36)
      d19 = d19 / ddlong * 60.D0 * 60.D0
      d20 = d20 / ddlat * 60.D0 * 60.D0
!	 print *,' d19=',d19,' d20=',d20, ihdr(36)
      IF( ihdr(36) .NE. 0 ) THEN
          dtemp = DFLOAT(ihdr(36))
          IF( ihdr(36) .LT. 0 ) dtemp = -1. * dtemp
          d19 = d19 * dtemp
          d20 = d20 * dtemp
!	print *,' d19=',d19,' d20=',d20,' dtemp=',dtemp
      ENDIF
      lhdr(19) = NINT(d19)
      lhdr(20) = NINT(d20)
!****
!****   Do the receiver coordinates
!****
      dtemp = DFLOAT(IABS(lhdr(10))) + setback
      dx = dtemp * DSIN(angle/rad)
      dy = dtemp * DCOS(angle/rad)
      d21 = x2_m + dx
      d22 = y2_m + dy
      d21 = d21 / ddlong * 60.D0 * 60.D0
      d22 = d22 / ddlat * 60.D0 * 60.D0
      IF( ihdr(36) .NE. 0 ) THEN
          dtemp = DFLOAT(ihdr(36))
          IF( ihdr(36) .LT. 0 ) dtemp = -1. * dtemp
          d21 = d21 * dtemp
          d22 = d22 * dtemp
      ENDIF
      lhdr(21) = NINT(d21)
      lhdr(22) = NINT(d22)
!	 print *,' lhdr=',lhdr(19),lhdr(20),lhdr(21),lhdr(22)
!****
!****
      RETURN
      END