subroutine SHRotateTapers(tapersrot, tapers, taper_order, lmax, nrot, x, dj, &
                          exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will rotate a set of real spherical cap tapers (originally
!   centered at the North pole) corresponding to the angles listed in the
!   input array X. Only the first NROT tapers are rotated, each of which is
!   returned in a column of the output matrix TAPERSROT with spherical harmonic
!   coefficients ordered according to SHCilmToVector.
!
!   The rotation of a coordinate system or body can be viewed in two
!   complementary ways involving three successive rotations. Both methods have
!   the same initial and final configurations, and the angles listed in both
!   schemes are the same.
!
!   Scheme A:   (I) Rotation about the z axis by alpha.
!               (II) Rotation about the new y axis by beta.
!               (III) Rotation about the new z axis by gamma.
!
!   Scheme B:   (I) Rotation about the z axis by gamma.
!               (II) Rotation about the initial y axis by beta.
!               (III) Rotation about the initial z axis by alpha.
!
!   The rotations can further be viewed either as either a rotation of the
!   coordinate system or the physical body.
!
!   1. Rotation of the coordinate system without rotation of the physical body,
!       use x(alpha, beta, gamma).
!
!   2. Rotation of the physical body without rotation of the coordinate system,
!       use x(-gamma, -beta, -alpha).
!
!   To perform the inverse trasform of x(alpha, beta, gamma), use
!   x(-gamma, -beta, -alpha).
!
!   This routine uses the "y-convention" were rotations are about the y-axis
!   instead of the x-axis.
!
!   Calling Parameters
!
!       IN
!           tapers          An (lmax+1) by nrot array containing
!                           all the eigenfunctions of the spherical cap
!                           concentration problem obtained from SHReturnTapers.
!                           The functions are listed by columns, ordered from
!                           best to worst concentrated.
!           taper_order     A vector of dimension (lmax+1)**2 denoting which
!                           order m corresponds to the column of tapers and
!                           eigenvalues.
!           lmax            Maximum spherical harmonic degree of the tapers.
!           nrot            Number of tapers to rotate.
!           x               Array or rotation angles in radians.
!           dj              Rotation matrix with dimension (lmax+1, lmax+1,
!                                                           lmax+1).
!
!       OUT
!           tapersrot       Rotated real "geodesy" normalized spherical
!                           harmonic coefficients with dimension (lmax+1)**2
!                           by nrot.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Note: Before using this routine, please verify that the input Euler
!   angles and signs give the expected results. Some people define the angle
!   beta as a rotation with respect to the x axis.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use SHTOOLS, only: SHrtoc, SHctor, SHcilmtocindex, SHcindextocilm, &
                       SHRotateCoef, SHCilmToVector, CSPHASE_DEFAULT
    use ftypes

    implicit none

    real(dp), intent(in) :: tapers(:,:), x(:), dj(:,:,:)
    real(dp), intent(out) :: tapersrot(:,:)
    integer, intent(in) :: taper_order(:), lmax, nrot
    integer, intent(out), optional :: exitstatus
    integer :: astat(5), i
    real(dp), allocatable :: ccilm(:,:,:), cilm(:,:,:), cof(:,:), rcof(:,:), &
                             vec(:)

    if (present(exitstatus)) exitstatus = 0

    if (size(tapers(:,1)) < (lmax+1) .or. size(tapers(1,:)) < nrot) then
        print*, "Error --- SHRotateTapers"
        print*, "TAPERS must be dimensioned as ( LMAX+1, NROT ) " // &
                "where LMAX = ", lmax, "and NROT = ", nrot
        print*, "Input array is dimensioned as ", size(tapers(:,1)), &
                size(tapers(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(taper_order) < nrot) then
        print*, "Error --- SHRotateTapers"
        print*, "TAPER_ORDER must be dimensioned as NROT " // &
                "where NROT = ", nrot
        print*, "Input array is dimensioned as ", size(taper_order)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(tapersrot(:,1)) < (lmax+1)**2 .or. &
        size(tapersrot(1,:)) < nrot) then
        print*, "Error --- SHRotateTapers"
        print*, "TAPERSROT must be dimensioned as ( (LMAX+1)**2, " // &
                "NROT ), where LMAX = ", lmax, "and NROT = ", nrot
        print*, "Input array is dimensioned as ", size(tapersrot(:,1)), &
                size(tapersrot(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(dj(:,1,1)) < lmax+1 .or. size(dj(1,:,1)) < lmax+1 &
            .or. size(dj(1,1,:)) < lmax+1) then
        print*, "Error --- SHRotateTapers"
        print*, "DJ must be dimensioned as (LMAX+1, LMAX+1, LMAX+1) " // &
                "where LMAX = ", lmax
        print*, "Input array is dimensioned ", size(dj(:,1,1)), &
                size(dj(1,:,1)), size(dj(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(x) < 3) then
        print*, "Error --- SHRotateTapers"
        print*, "X must be dimensioned as (3)"
        print*, "Input array is dimensioned ", size(x)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    allocate (ccilm(2,lmax+1,lmax+1), stat = astat(1))
    allocate (cilm(2,lmax+1,lmax+1), stat = astat(2))
    allocate (cof(2,((lmax+1)*(lmax+2))/2), stat = astat(3))
    allocate (rcof(2,((lmax+1)*(lmax+2))/2), stat = astat(4))
    allocate (vec((lmax+1)**2), stat = astat(5))

    if (sum(astat(1:5)) /= 0) then
        print*, "Error --- SHRotateTapers"
        print*, "Problem allocating arrays CCILM, CILM, COF, RCOF and VEC", &
            astat(1), astat(2), astat(3), astat(4), astat(5)
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    do i=1, nrot, 1

        cilm = 0.0_dp
        if (taper_order(i) >= 0) then
            cilm(1, 1:lmax+1, taper_order(i)+1) = tapers(1:lmax+1, i)
        else
            cilm(2, 1:lmax+1, abs(taper_order(i))+1) = tapers(1:lmax+1, i)
        end if

        if (CSPHASE_DEFAULT == 1) then
            ! Convert geodesy coefficients to Varshalovich et al. complex form
            if (present(exitstatus)) then
                call SHrtoc(cilm, ccilm, degmax=lmax, convention=2, &
                            switchcs=1, exitstatus=exitstatus)
                if (exitstatus /= 0) return
            else
                call SHrtoc(cilm, ccilm, degmax=lmax, convention=2, switchcs=1)
            end if

        else
            if (present(exitstatus)) then
                call SHrtoc(cilm, ccilm, degmax=lmax, convention=2, &
                            switchcs=0, exitstatus=exitstatus)
                if (exitstatus /= 0) return
            else
                call SHrtoc(cilm, ccilm, degmax=lmax, convention=2, switchcs=0)
            end if

        end if

        if (present(exitstatus)) then
            ! Re-order complex coefficients to form a 2D vector
            call SHcilmtocindex(ccilm, cof, lmax, exitstatus=exitstatus)
            if (exitstatus /= 0) return

            ! Rotate complex re-ordered coefficients
            call SHRotateCoef(x, cof, rcof, dj, lmax, exitstatus=exitstatus)
            if (exitstatus /= 0) return

            ! Convert ordered complex coefficients back to a 3D array
            call SHcindextocilm(rcof, ccilm, lmax, exitstatus=exitstatus)
            if (exitstatus /= 0) return

        else
            ! Re-order complex coefficients to form a 2D vector
            call SHcilmtocindex(ccilm, cof, lmax)

            ! Rotate complex re-ordered coefficients
            call SHRotateCoef(x, cof, rcof, dj, lmax)

            ! Convert ordered complex coefficients back to a 3D array
            call SHcindextocilm(rcof, ccilm, lmax)

        end if

        if (CSPHASE_DEFAULT == 1) then
            ! Convert Varshalovich et al complex coefficients back to 4pi
            ! geodesy form
            if (present(exitstatus)) then
                call SHctor(ccilm, cilm, degmax=lmax, convention=2, &
                            switchcs=1, exitstatus=exitstatus)
                if (exitstatus /= 0) return
            else
                call SHctor(ccilm, cilm, degmax=lmax, convention=2, &
                            switchcs=1)

            end if

        else
            if (present(exitstatus)) then
                call SHctor(ccilm, cilm, degmax=lmax, convention=2, &
                            switchcs=0, exitstatus=exitstatus)
                if (exitstatus /= 0) return
            else
                call SHctor(ccilm, cilm, degmax=lmax, convention=2, &
                            switchcs=0)
            end if

        end if

        if (present(exitstatus)) then
            ! Re-order real coefficients to form a 1-D vector
            call SHCilmToVector(cilm, vec, lmax, exitstatus=exitstatus)
            if (exitstatus /= 0) return

        else
            ! Re-order real coefficients to form a 1-D vector
            call SHCilmToVector(cilm, vec, lmax)

        end if

        tapersrot(1:(lmax+1)**2, i) = vec(1:(lmax+1)**2)

    end do

    deallocate (ccilm)
    deallocate (cof)
    deallocate (rcof)
    deallocate (cilm)
    deallocate (vec)

end subroutine SHRotateTapers


      SUBROUTINE INITIAL
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!  set up for 2D lattices
!!!!  K.Travis 07/06/12 Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      USE header_file
      IMPLICIT NONE

      REAL(kind = double), DIMENSION(N) :: ATEMP,BTEMP,CTEMP
      REAL(kind = double), DIMENSION(4) :: XTEMP,YTEMP,ZTEMP
      REAL(kind = double) :: VX0,VY0,VZ0,DEGTORAD
      REAL(kind = double) :: RA,RB,RC,RXX,RYY,RZZ,SPACING
      REAL(kind = double) :: XSUM,YSUM,ZSUM,PSQSUM,TSFAC,T0
      REAL(kind = double) :: FACT,VAR,R1,R2,RANDNUM
      INTEGER             :: IX,IY,IZ,I,J,K,NX,NY,NZ,MM,M,IA,IB,IC,INTX,INTY

      DEGTORAD = PI/180.0D0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! we'll set this up for an fcc lattice for now, but it should be easy
!! to change to any type of crystal provided a unit cell is read in
!! along with lattice parameters and angles. Can also use asymmetric unit
!! if we create a new subroutine that applies the symmetry operators
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      NX = NINT((DBLE(N/4))**(1.0d0/3.0d0))   ! atoms along each row/column

      ALEN = (DBLE(N)/DENSITY)**(1.0d0/3.0d0)
      BLEN = ALEN
      CLEN = ALEN
      ALPHA = 90.0*DEGTORAD
      BETA  = 90.0*DEGTORAD
      GAMMA = 90.0*DEGTORAD

      INTX = 0
      INTY = 0
      XYZ_FILE_STAT = 'REPLACE'

      CALL CELLVECT
      WRITE(*,*) 'Calculated density = ',N/(EFC(1,1)*EFC(2,2)*EFC(3,3))

      WRITE(*,*) 'Building fcc lattice with NX = ',NX

!!! unit cell fractional coordinates
!!! includes an offset so that atoms are not alinged along a cell boundary

      XTEMP(1) = 0.25D0
      XTEMP(2) = 0.25D0 + 0.5d0
      XTEMP(3) = 0.25D0
      XTEMP(4) = 0.25D0 + 0.5d0

      YTEMP(1) = 0.25D0
      YTEMP(2) = 0.25D0 + 0.5d0
      YTEMP(3) = 0.25D0 + 0.5d0
      YTEMP(4) = 0.25D0

      ZTEMP(1) = 0.25D0
      ZTEMP(2) = 0.25D0
      ZTEMP(3) = 0.25D0 + 0.5d0
      ZTEMP(4) = 0.25D0 + 0.5d0

!!!  apply translational operator to construct the supercell

      M = 0
      DO I = 1,NX
        DO J = 1,NX
          DO K = 1,NX
            DO MM = 1,4
              ATEMP(MM + M) = (XTEMP(MM) + (K - 1))/DBLE(NX)
              BTEMP(MM + M) = (YTEMP(MM) + (J - 1))/DBLE(NX)
              CTEMP(MM + M) = (ZTEMP(MM) + (I - 1))/DBLE(NX)
            END DO
            M = M + 4
          END DO
        END DO
      END DO

!!  now need to change them to cartesian coordinates

     DO I = 1,N
       RA = ATEMP(I)
       RB = BTEMP(I)
       RC = CTEMP(I)
       CALL FRACCART(RA,RB,RC,RXX,RYY,RZZ)
       X(I) = RXX
       Y(I) = RYY
       Z(I) = RZZ
     END DO

!!!  assign velocities from a maxwell-boltzmann distribution
      DO I = 1,N
        MASS(I) = 1.0D00   !! assumes unit mass (can easily relax this)
        CALL MAXWELL(VX0,VY0,VZ0,TREQ,INTX,INTY)
        PX(I) = MASS(I)*VX0
        PY(I) = MASS(I)*VY0
        PZ(I) = MASS(I)*VZ0
      END DO

!!!   zero the total linear momentum
      XSUM = 0.0D0
      YSUM = 0.0D0
      ZSUM = 0.0D0
      DO I = 1,N
        XSUM = XSUM + PX(I)
        YSUM = YSUM + PY(I)
        ZSUM = ZSUM + PZ(I)
      END DO
      WRITE(*,*) 'X-compt momentum at start = ',XSUM/N
      WRITE(*,*) 'Y-compt momentum at start = ',YSUM/N
      WRITE(*,*) 'Z-compt momentum at start = ',ZSUM/N
      PSQSUM = 0.0d0
      DO I = 1,N
        PX(I) = PX(I) - XSUM/N
        PY(I) = PY(I) - YSUM/N
        PZ(I) = PZ(I) - ZSUM/N
        PSQSUM = PSQSUM + (PX(I)**2 + PY(I)**2 + PZ(I)**2)/MASS(I)
      END DO
      IF(ITHERM == 0) THEN
        DEGFREE = 3.0D0*N - 3.0d0
      ELSE
        DEGFREE = 3.0D0*N - 4.0d0
      END IF
      T0 = PSQSUM/DEGFREE
      WRITE(*,*) 'Initial temperature = ',T0

!!!  rescale the temperature
      TSFAC = SQRT(TREQ/T0)
      DO I = 1,N
        PX(I) = PX(I)*TSFAC
        PY(I) = PY(I)*TSFAC
        PZ(I) = PZ(I)*TSFAC
      END DO

      END SUBROUTINE


!*****************************************************************************************
!> author: Jacob Williams
!  date: 8/23/2015
!
!  Test program for the CW-equation propagator.
!
!  Propagate a relative state with an RK method and also using the CW equations.
!  Note that this test requires [pyplot-fortran](https://github.com/jacobwilliams/pyplot-fortran).
!
!# See also
!   * [[gravity_test]]

    program cw_test

    use fortran_astrodynamics_toolkit
    use pyplot_module

    implicit none

    type,extends(rk8_10_class) :: spacecraft
        !! spacecraft propagation type:
        !! extend the rk class to include data used in the deriv routine
        type(geopotential_model_mueller) :: grav   !! central body geopotential model
        logical :: first = .true.  !! first point is being exported
        logical :: use_geopotential = .true. !! if true, use the geopotential model.
                                             !! if false, use pointmass.
    end type spacecraft

    integer,parameter               :: n             = 6                        !! number of state variables
    real(wp),parameter              :: mu_earth      = 398600.4418_wp           !! grav. param of earth [km3/s2]
    real(wp),parameter              :: orbit_inc     = 45.0_wp*deg2rad          !! orbit inclination [rad]
    real(wp),parameter              :: orbit_sma     = 6778.0_wp                !! orbit semimajor axis [km]
    character(len=*),parameter      :: gravfile      = '../grav/GGM03C.GEO'     !! grav coefficient file
    integer,parameter               :: grav_n        = 10                       !! max degree
    integer,parameter               :: grav_m        = 10                       !! max order
    real(wp),dimension(3),parameter :: r_chaser_lvlh = [1.0_wp,1.0_wp,1.0_wp]   !! chaser r relative to target (LVLH)
    real(wp),dimension(3),parameter :: v_chaser_lvlh = [0.001_wp,0.001_wp,0.001_wp] !! chaser v relative to target (LVLH)

    real(wp),dimension(:),allocatable :: x_lvlh_int, y_lvlh_int, z_lvlh_int
    real(wp),dimension(:),allocatable :: x_lvlh_int_pm, y_lvlh_int_pm, z_lvlh_int_pm
    real(wp),dimension(:),allocatable :: x_lvlh_cw, y_lvlh_cw, z_lvlh_cw
    real(wp),dimension(n)   :: rv_target_eci_t0, rv_target_eci_tf
    real(wp),dimension(n)   :: rv_chaser_rsw_t0, rv_chaser_rsw_tf
    real(wp),dimension(n)   :: rv_chaser_eci_t0, rv_chaser_eci_tf
    real(wp),dimension(n+n) :: x0               !! initial [target, chaser] states
    real(wp),dimension(n+n) :: xf               !! final [target, chaser] states
    type(pyplot)            :: plt              !! for making the plot
    real(wp)                :: mean_motion      !! [1/sec]
    type(spacecraft)        :: s
    real(wp)                :: t0,tf,dt
    logical                 :: status_ok
    integer                 :: iunit,istat,iunit_cw,iunit_pm
    logical                 :: cw_header_written
    integer                 :: icase

    cw_header_written = .false.

    !open output files:
    open(newunit=iunit,file   ='cw_test_integration_geopot.txt',   status='REPLACE',iostat=istat)
    open(newunit=iunit_cw,file='cw_test_cw_prop.txt',              status='REPLACE',iostat=istat)
    open(newunit=iunit_pm,file='cw_test_integration_pointmass.txt',status='REPLACE',iostat=istat)

    !constructors:
    call s%initialize(n=n+n,f=deriv,report=integrator_report) ! integrating target and chaser
    call s%grav%initialize(gravfile,grav_n,grav_m,status_ok)  ! gravitational field
    if (.not. status_ok) stop 'Error'

    !get an initial cartesian state vector:
    ! [circular, 45 deg inclination, radius of 6778 km]
    call els3pv(mu_earth,[mu_earth/orbit_sma,orbit_sma,orbit_inc,zero,zero,zero],rv_target_eci_t0)
    mean_motion = sqrt(mu_earth / orbit_sma**3) ! mean motion of target orbit

    !convert chaser state to eci frame (for integration):
    call from_lvlh_to_ijk(rt_ijk  = rv_target_eci_t0(1:3),&
                          vt_ijk  = rv_target_eci_t0(4:6),&
                          dr_lvlh = r_chaser_lvlh,&
                          dv_lvlh = v_chaser_lvlh,&
                          r_ijk   = rv_chaser_eci_t0(1:3),&  ! chaser in eci-Earth frame.
                          v_ijk   = rv_chaser_eci_t0(4:6))   !

    !also convert chaser state to RST (for CW propagation)
    call from_lvlh_to_rsw(r_chaser_lvlh,v_chaser_lvlh,rv_chaser_rsw_t0(1:3),rv_chaser_rsw_t0(4:6))

    write(*,*) ''
    write(*,'(A/,*(E30.16/))') 'rv_target_eci_t0:',rv_target_eci_t0
    write(*,'(A/,*(E30.16/))') 'rv_chaser_rsw_t0:',rv_chaser_rsw_t0
    write(*,'(A/,*(E30.16/))') 'rv_chaser_eci_t0:',rv_chaser_eci_t0
    write(*,'(A/,*(E30.16/))') 'r_chaser_lvlh_t0:',r_chaser_lvlh,v_chaser_lvlh
    write(*,*) ''

    do icase=1,2

        !initial conditions:
        t0 = zero           !initial ephemeris time (sec) -> this is 1/1/2000 12:00:00
        dt = 10.0_wp        !time step (sec)
        tf = 4.0_wp*hr2sec  !final time (sec)

        !integrate (both states):

        s%first = .true.
        s%use_geopotential = icase==1

        x0 = [rv_target_eci_t0,rv_chaser_eci_t0]
        call s%integrate(t0,x0,dt,tf,xf)
        rv_target_eci_tf = xf(1:6)
        rv_chaser_eci_tf = xf(7:12)

        if (s%use_geopotential) then
            write(*,'(A/,*(E30.16/))') 'rv_target_eci_tf (integrated, GEOPOT):',rv_target_eci_tf
        else
            write(*,'(A/,*(E30.16/))') 'rv_target_eci_tf (integrated, POINTMASS):',rv_target_eci_tf
        end if

    end do

    !also propagate with the CW equations:
    call cw_propagator(t0,rv_chaser_rsw_t0,dt,mean_motion,tf,rv_chaser_rsw_tf,cw_report)
    write(*,'(A/,*(E30.16/))') 'rv_chaser_eci_tf (integrated):',rv_chaser_eci_tf

    !plot both trajectories:

    write(*,*) 'generate plots...'

    call plt%initialize(grid=.true.,xlabel='LVLH x [km]',ylabel='LVLH y [km]',&
                            title='Integration vs CW Propagation',legend=.true.,figsize=[10,5])
    call plt%add_plot([zero],[zero],label='Target', &
                            linestyle='bo',markersize=5,istat=istat)
    call plt%add_plot(x_lvlh_int,y_lvlh_int, &
                            label='Integrated (10x10 gravity)', &
                            linestyle='b-',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(x_lvlh_int_pm,y_lvlh_int_pm, &
                            label='Integrated (pointmass gravity)', &
                            linestyle='g-',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(x_lvlh_cw,y_lvlh_cw, &
                            label='CW Equations', linestyle='r-',markersize=5,linewidth=2,istat=istat)
    call plt%savefig('cw_test_xy.png',istat=istat)
    call plt%destroy()

    call plt%initialize(grid=.true.,xlabel='LVLH x [km]',ylabel='LVLH z [km]',&
                            title='Integration vs CW Propagation',legend=.true.,figsize=[10,5])
    call plt%add_plot([zero],[zero],label='Target',linestyle='bo',markersize=5,istat=istat)
    call plt%add_plot(x_lvlh_int,z_lvlh_int, &
                            label='Integrated (10x10 gravity)', &
                            linestyle='b-',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(x_lvlh_int_pm,z_lvlh_int_pm, &
                            label='Integrated (pointmass gravity)', &
                            linestyle='g-',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(x_lvlh_cw,z_lvlh_cw, &
                            label='CW Equations', &
                            linestyle='r-',markersize=5,linewidth=2,istat=istat)
    call plt%savefig('cw_test_xz.png',istat=istat)
    call plt%destroy()

    call plt%initialize(grid=.true.,xlabel='LVLH y [km]',ylabel='LVLH z [km]',&
                            title='Integration vs CW Propagation',legend=.true.,figsize=[10,5])
    call plt%add_plot([zero],[zero],label='Target',linestyle='bo',markersize=5,istat=istat)
    call plt%add_plot(y_lvlh_int,z_lvlh_int, &
                            label='Integrated (10x10 gravity)', &
                            linestyle='b-',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(y_lvlh_int_pm,z_lvlh_int_pm,&
                            label='Integrated (pointmass gravity)', &
                            linestyle='g-',markersize=5,linewidth=2,istat=istat)
    call plt%add_plot(y_lvlh_cw,z_lvlh_cw, &
                            label='CW Equations', &
                            linestyle='r-',markersize=5,linewidth=2,istat=istat)
    call plt%savefig('cw_test_yz.png',istat=istat)
    call plt%destroy()

    ! 3d plot:
    call plt%initialize(grid=.true.,xlabel='LVLH x [km]',ylabel='LVLH y [km]',zlabel='LVLH z[km]',&
                            title='Integration vs CW Propagation',legend=.true.,mplot3d=.true.,figsize=[10,5])
    call plt%add_3d_plot([zero],[zero],[zero],&
                            label='Target',linestyle='bo',markersize=5,istat=istat)
    call plt%add_3d_plot(x_lvlh_int,y_lvlh_int,z_lvlh_int,&
                            label='Integrated (10x10 gravity)', &
                            linestyle='b-',markersize=5,linewidth=2,istat=istat)
    call plt%add_3d_plot(x_lvlh_int_pm,y_lvlh_int_pm,z_lvlh_int_pm,&
                            label='Integrated (pointmass gravity)', &
                            linestyle='g-',markersize=5,linewidth=2,istat=istat)
    call plt%add_3d_plot(x_lvlh_cw,y_lvlh_cw,z_lvlh_cw, &
                            label='CW Equations', &
                            linestyle='r-',markersize=5,linewidth=2,istat=istat)
    call plt%savefig('cw_test_xyz.png',istat=istat)
    call plt%destroy()

    !cleanup:
    call s%grav%destroy()
    close(iunit,   iostat=istat)
    close(iunit_cw,iostat=istat)
    close(iunit_pm,iostat=istat)

    contains
!*****************************************************************************************

    !*********************************************************
        subroutine deriv(me,et,x,xdot)

        !! derivative routine for target + chaser
        !!
        !! For the spherical harmonic mode, the gravity frame is
        !! assumed to be the IAU_EARTH frame.

        implicit none

        class(rk_class),intent(inout)         :: me
        real(wp),intent(in)                   :: et    !! ephemeris time [sec]
        real(wp),dimension(me%n),intent(in)   :: x     !! [target,chaser] state vectors
        real(wp),dimension(me%n),intent(out)  :: xdot  !! [target,chaser] state dot vectors

        real(wp),dimension(3)   :: r,rb,v,a_grav
        real(wp),dimension(3,3) :: rotmat
        real(wp) :: rmag
        integer :: i

        select type (me)
        class is (spacecraft)

            !rotation matrix from inertial to body-fixed:
            rotmat = icrf_to_iau_earth(et)

            do i=1,2

                !get state:
                select case (i)
                case(1)    !target
                    r = x(1:3)
                    v = x(4:6)
                case(2) !chaser
                    r = x(7:9)
                    v = x(10:12)
                end select

                if (me%use_geopotential) then  !! spherical harmonics

                    !input state is inertial frame, have to convert
                    ! to body-fixed Earth frame:
                    rb = matmul(rotmat,r)    !r in body-fixed frame

                    !get the acceleration due to the geopotential:
                    call me%grav%get_acc(rb,grav_n,grav_m,a_grav)

                    !convert acceleration back to inertial frame:
                    a_grav = matmul(transpose(rotmat),a_grav)

                else

                    rmag = norm2(r)
                    a_grav = -mu_earth/rmag**3 * r ! pointmass gravity

                end if

                !derivative vector:
                 select case (i)
                case(1)    !target
                    xdot(1:3) = v
                    xdot(4:6) = a_grav
                case(2) !chaser
                    xdot(7:9) = v
                    xdot(10:12) = a_grav
                end select

            end do

        end select

        end subroutine deriv
    !*********************************************************

    !*********************************************************
        subroutine integrator_report(me,t,x)

        !! report function for the integrator

        implicit none

        class(rk_class),intent(inout)        :: me
        real(wp),intent(in)                  :: t  !! time [sec]
        real(wp),dimension(me%n),intent(in)  :: x  !! [target,chaser] state vectors

        real(wp),dimension(6) :: rv_chaser_lvlh  !! chaser [r,v] state vector in LVLH relative to target
        integer :: iu

        select type (me)
        class is (spacecraft)

            if (me%use_geopotential) then
                iu = iunit     ! geopotential model output file
            else
                iu = iunit_pm  ! pointmass model output file
            end if

            if (me%first) then  !print header
                write(iu,*) ''
                write(iu,'(*(A25,1X))')  't (sec)',&
                                         'x_TARGET_ECI (km)',    'y_TARGET_ECI (km)',    'z_TARGET_ECI (km)',   &
                                         'vx_TARGET_ECI (km/s)', 'vy_TARGET_ECI (km/s)', 'vz_TARGET_ECI (km/s)',&
                                         'x_CHASER_ECI (km)',    'y_CHASER_ECI (km)',    'z_CHASER_ECI (km)',   &
                                         'vx_CHASER_ECI (km/s)', 'vy_CHASER_ECI (km/s)', 'vz_CHASER_ECI (km/s)',&
                                         'x_CHASER_LVLH (km)',   'y_CHASER_LVLH (km)',   'z_CHASER_LVLH (km)',  &
                                         'vx_CHASER_LVLH (km/s)','vy_CHASER_LVLH (km/s)','vz_CHASER_LVLH (km/s)'
                me%first = .false.
            end if

            !chaser in LVLH relative to target:

            call from_ijk_to_lvlh(rt_ijk  = x(1:3),&
                                  vt_ijk  = x(4:6),&
                                  r_ijk   = x(7:9),&
                                  v_ijk   = x(10:12),&
                                  dr_lvlh = rv_chaser_lvlh(1:3),&
                                  dv_lvlh = rv_chaser_lvlh(4:6) )

            !output states:
            write(iu,'(*(F25.6,1X))') t,x,rv_chaser_lvlh

            !also accumulate the LVLH vectors for plotting:
            if (me%use_geopotential) then
                if (allocated(x_lvlh_int)) then
                    x_lvlh_int = [x_lvlh_int, rv_chaser_lvlh(1)]
                    y_lvlh_int = [y_lvlh_int, rv_chaser_lvlh(2)]
                    z_lvlh_int = [z_lvlh_int, rv_chaser_lvlh(3)]
                else
                    x_lvlh_int = [rv_chaser_lvlh(1)]
                    y_lvlh_int = [rv_chaser_lvlh(2)]
                    z_lvlh_int = [rv_chaser_lvlh(3)]
                end if
            else
                if (allocated(x_lvlh_int_pm)) then
                    x_lvlh_int_pm = [x_lvlh_int_pm, rv_chaser_lvlh(1)]
                    y_lvlh_int_pm = [y_lvlh_int_pm, rv_chaser_lvlh(2)]
                    z_lvlh_int_pm = [z_lvlh_int_pm, rv_chaser_lvlh(3)]
                else
                    x_lvlh_int_pm = [rv_chaser_lvlh(1)]
                    y_lvlh_int_pm = [rv_chaser_lvlh(2)]
                    z_lvlh_int_pm = [rv_chaser_lvlh(3)]
                end if
            end if
        end select

        end subroutine integrator_report
    !*********************************************************

    !*********************************************************
        subroutine cw_report(t,x)

        !! report function for the CW propagator.

        implicit none

        real(wp),intent(in)               :: t   !! time [sec]
        real(wp),dimension(6),intent(in)  :: x   !! chaser RSW state vector [km,km/s]

        real(wp),dimension(6) :: rv_chaser_lvlh  !! chaser [r,v] state vector in LVLH relative to target

        if (.not. cw_header_written) then  !print header
            write(iunit_cw,*) ''
            write(iunit_cw,'(*(A25,1X))') 't (sec)',&
                                          'x_CHASER_LVLH (km)',   'y_CHASER_LVLH (km)',   'z_CHASER_LVLH (km)',  &
                                          'vx_CHASER_LVLH (km/s)','vy_CHASER_LVLH (km/s)','vz_CHASER_LVLH (km/s)'
            cw_header_written = .true.
        end if

        !convert state to LVLH:
        call from_rsw_to_lvlh(x(1:3),x(4:6),rv_chaser_lvlh(1:3),rv_chaser_lvlh(4:6))

        !output states:
        write(iunit_cw,'(*(F25.6,1X))') t,rv_chaser_lvlh

        !also accumulate the LVLH vectors for plotting:
        if (allocated(x_lvlh_cw)) then
            x_lvlh_cw = [x_lvlh_cw, rv_chaser_lvlh(1)]
            y_lvlh_cw = [y_lvlh_cw, rv_chaser_lvlh(2)]
            z_lvlh_cw = [z_lvlh_cw, rv_chaser_lvlh(3)]
        else
            x_lvlh_cw = [rv_chaser_lvlh(1)]
            y_lvlh_cw = [rv_chaser_lvlh(2)]
            z_lvlh_cw = [rv_chaser_lvlh(3)]
        end if

        end subroutine cw_report
    !*********************************************************

    end program cw_test
!*****************************************************************************************


PROGRAM HomologousCollapse1D

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE GravityProblemsInitializationModule, ONLY: &
    InitializeHomologousCollapse
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK
  USE GravitySolutionModule, ONLY: &
    SolveGravity

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
            = 'HomologousCollapse1D', &
           nX_Option &
             = [ 128, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 10, 0, 0 ], &
           xL_Option &
             = [ 0.000_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 3.315_DP, Pi,     4.0_DP ], &
           zoomX_Option &
             = [ 1.0_DP, 1.0_DP, 1.0_DP ], &
           nNodes_Option &
             = 2, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           EquationOfState_Option &
             = 'IDEAL', &
           Gamma_IDEAL_Option &
             = 4.0_DP / 3.0_DP, &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d0, &
           BetaTVD_Option &
             = 1.8d0, &
           ApplyPositivityLimiter_Option &
             = .TRUE., &
           EvolveGravity_Option &
             = .TRUE., &
           GravitySolver_Option &
             = 'Newtonian_Poseidon', &
           nStages_SSP_RK_Option &
             = 2 )

  CALL InitializeHomologousCollapse

  CALL SolveGravity

  CALL EvolveFields &
         ( t_begin  = 0.0_DP, &
           t_end    = 1.0d-1, &
           dt_write = 1.0d-2, &
           UpdateFields = SSP_RK )

  CALL FinalizeProgram

END PROGRAM HomologousCollapse1D


SUBROUTINE fc2d_geoclaw_flag2refine(blockno, meqn,maux,qvec, auxvec, dx,dy, &
    xc,yc,t,level, maxlevel, init_flag, is_coarsening)

    USE geoclaw_module, ONLY : dry_tolerance, sea_level
    USE refinement_module, only : wave_tolerance, speed_tolerance

    IMPLICIT NONE

    INTEGER :: blockno, init_flag,level, meqn, maux, maxlevel
    DOUBLE PRECISION :: qvec(meqn),auxvec(maux), xc,yc,dx,dy,t
    logical :: is_coarsening

    INTEGER :: flag_patch, m, max_num_speeds
    DOUBLE PRECISION :: eta, th_factor, speed
    LOGICAL :: allowflag

    !! Don't coarsen on initial refinement
    if (init_flag .ne. 0 .and. is_coarsening) then
        flag_patch = 0
        return
    endif

    if (.not. allowflag(xc,yc,t,level)) then
        !! It isn't clear what this means;  do we not refine the entire patch
        !! if a single cell cannot be refined?
        flag_patch = -1
        return
    endif

    max_num_speeds = min(size(speed_tolerance),maxlevel)

    th_factor = 1
    if (is_coarsening) then
        !! Coarsening factor should be 0.5 refinement factor.
        th_factor = 0.5
    endif

    flag_patch = 0
    if (qvec(1) > dry_tolerance) then

        !! Check wave height criteria
        eta = qvec(1) + auxvec(1)
        if (abs(eta - sea_level) > th_factor*wave_tolerance) then
            flag_patch = 1
            return
        endif

        !! Check speed criteria
        speed = sqrt(qvec(2)**2 + qvec(3)**2) / qvec(1)
        DO m = 1,max_num_speeds
            IF (speed > th_factor*speed_tolerance(m) .AND. level <= m) THEN
                flag_patch = 1
                RETURN
            ENDIF
        ENDDO
    ENDIF

end subroutine fc2d_geoclaw_flag2refine


module zgrid

  implicit none

  public :: init_zgrid, finish_zgrid
  public :: nzed, nzgrid, nperiod, ntubes
  public :: nztot, nz2pi
  public :: zed
  public :: delzed
  public :: zed_equal_arc
  public :: get_total_arc_length
  public :: get_arc_length_grid
  public :: shat_zero
  public :: boundary_option_switch
  public :: boundary_option_zero
  public :: boundary_option_self_periodic
  public :: boundary_option_linked

  private

  integer :: nzed, nzgrid, nztot, nz2pi
  integer :: nperiod, ntubes
  logical :: zed_equal_arc
  real :: shat_zero
  real, dimension (:), allocatable :: zed, delzed

  integer :: boundary_option_switch
  integer, parameter :: boundary_option_zero = 1, &
       boundary_option_self_periodic = 2, &
       boundary_option_linked = 3

  logical :: zgridinit = .false.

contains

  subroutine init_zgrid

    use mp, only: proc0
    use constants, only: pi

    implicit none

    integer :: i

    if (zgridinit) return
    zgridinit = .true.

    if (proc0) then
       call read_parameters
    end if
    call broadcast_parameters

    if (.not.allocated(zed)) allocate (zed(-nzgrid:nzgrid))
    if (.not.allocated(delzed)) allocate (delzed(-nzgrid:nzgrid))

    zed = (/ (i*pi/real(nzed/2), i=-nzgrid, nzgrid ) /)
    delzed(:nzgrid-1) = zed(-nzgrid+1:) - zed(:nzgrid-1)
    delzed(nzgrid) = delzed(-nzgrid)

    nztot = 2*nzgrid+1
    ! number of zed in a 2*pi segment, including points at +/- pi
    nz2pi = 2*(nzed/2)+1

  end subroutine init_zgrid

  subroutine read_parameters

    use file_utils, only: input_unit_exist, error_unit
    use text_options, only: text_option, get_option_value
    use physics_flags, only: full_flux_surface

    implicit none

    integer :: in_file, ierr
    logical :: exist

    type (text_option), dimension (6), parameter :: boundaryopts = &
         (/ text_option('default', boundary_option_zero), &
            text_option('zero', boundary_option_zero), &
            text_option('unconnected', boundary_option_zero), &
            text_option('self-periodic', boundary_option_self_periodic), &
            text_option('periodic', boundary_option_self_periodic), &
            text_option('linked', boundary_option_linked) /)
    character(20) :: boundary_option

    namelist /zgrid_parameters/ nzed, nperiod, ntubes, &
         shat_zero, boundary_option, zed_equal_arc

    nzed = 24
    nperiod = 1
    ntubes = 1
    boundary_option = 'default'
    ! if zed_equal_arc = T, then zed is chosen to be arc length
    ! if zed_equal_arc = F, then zed is poloidal (axisymmetric)
    ! or zeta (toroidal) angle
    zed_equal_arc = .false.
    ! set minimum shat value below which we assume
    ! periodic BC
    shat_zero = 1.e-5

    in_file = input_unit_exist("zgrid_parameters", exist)
    if (exist) read (unit=in_file, nml=zgrid_parameters)

    ierr = error_unit()
    call get_option_value &
         (boundary_option, boundaryopts, boundary_option_switch, &
         ierr, "boundary_option in dist_fn_knobs")

    ! note that boundary_option may be changed to self-periodic later
    ! if magnetic shear is smaller than shat_zero
    ! cannot do this here as magnetic shear has yet to be input

    nzgrid = nzed/2 + (nperiod-1)*nzed

    ! force use of equal arc grid to ensure gradpar alpha-independent
    ! necessary to obtain efficient numerical solution of parallel streaming
    if (full_flux_surface) zed_equal_arc = .true.

  end subroutine read_parameters

  subroutine broadcast_parameters

    use mp, only: broadcast

    implicit none

    call broadcast (nzed)
    call broadcast (nzgrid)
    call broadcast (nperiod)
    call broadcast (ntubes)
    call broadcast (zed_equal_arc)
    call broadcast (shat_zero)
    call broadcast (boundary_option_switch)

  end subroutine broadcast_parameters

  subroutine finish_zgrid

    implicit none

    if (allocated(zed)) deallocate (zed)
    if (allocated(delzed)) deallocate (delzed)

    zgridinit = .false.

  end subroutine finish_zgrid

  subroutine get_total_arc_length (nz, gp, dz, length)

    implicit none

    integer, intent (in) :: nz
    real, dimension (-nz:), intent (in) :: gp
    real, intent (in) :: dz
    real, intent (out) :: length

    call integrate_zed (nz, dz, 1./gp, length)

  end subroutine get_total_arc_length

  subroutine get_arc_length_grid (nz_max, nzext_max, zboundary, gp, dz, zarc)

    implicit none

    integer, intent (in) :: nz_max, nzext_max
    real, intent (in) :: zboundary
    real, dimension (-nzext_max:), intent (in) :: gp
    real, intent (in) :: dz
    real, dimension (-nzext_max:), intent (out) :: zarc

    integer :: iz

    zarc(-nz_max) = zboundary
    if (nz_max /= nzext_max) then
       do iz = -nzext_max, -nz_max-1
          call integrate_zed (nzext_max, dz, 1./gp(iz:-nz_max), zarc(iz))
          zarc(iz) = zarc(-nz_max) - zarc(iz)
       end do
    end if
    do iz = -nz_max+1, nzext_max
       call integrate_zed (nz_max, dz, 1./gp(-nz_max:iz), zarc(iz))
       zarc(iz) = zarc(-nz_max) + zarc(iz)
    end do

  end subroutine get_arc_length_grid

  ! trapezoidal rule to integrate in zed
  subroutine integrate_zed (nz, dz, f, intf)

    implicit none

    integer, intent (in) :: nz
    real, intent (in) :: dz
    real, dimension (-nz:), intent (in) :: f
    real, intent (out) :: intf

    integer :: iz, iz_max

    iz_max = -nz + size(f) - 1
    intf = 0.
    do iz = -nz+1, iz_max
       intf = intf + dz*(f(iz-1)+f(iz))
    end do
    intf = 0.5*intf

  end subroutine integrate_zed

end module zgrid


           program demo_atanh
           implicit none
           real, dimension(3) :: x = [ -1.0, 0.0, 1.0 ]
              write (*,*) atanh(x)
           end program demo_atanh


      FUNCTION ZJ ( ARG )
C
C     ZERO ORDER BESSEL FUNCTION OF FIRST KIND
C
      DBSLJ = 1.0E-10
      A  =  - ( ARG / 2.0 ) ** 2
      ZJ  =  1.0
      PF  =  1.0
      AN  =  1.0
      DO   200   I = 1 , 20
      AN  =  AN * A / PF ** 2
      PF  =  PF + 1.0
      IF ( ABS ( AN ) .LE. DBSLJ )   RETURN
      ZJ  =  ZJ + AN
 200  CONTINUE
      RETURN
      END


c
c compute Bessel function Jn(z) for n=0,1,2
c
      subroutine besselFn(z, aj0, aj1, aj2)
        real z, aj0, aj1, aj2
#ifdef  __GNUC__
	aj0 = BesJ0(z)
	aj1 = BesJ1(z)
	aj2 = BesJN(2,z)
#else
c#warning "no intrinsic Bessel functions found, use Numerical Recipes"
	aj0 = bessj0(z)
	aj1 = bessj1(z)
	aj2 = bessj(2,z)
#endif
        return
      end
c
c   Bessel Function from Numerical Recipes
c
      FUNCTION bessj0(x)
      REAL bessj0,x
      REAL ax,xx,z
      DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
     *s1,s2,s3,s4,s5,s6,y
      SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
     *s5,s6
      DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4,
     *-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1,
     *.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
      DATA r1,r2,r3,r4,r5,r6/57568490574.d0,-13362590354.d0,
     *651619640.7d0,-11214424.18d0,77392.33017d0,-184.9052456d0/,s1,s2,
     *s3,s4,s5,s6/57568490411.d0,1029532985.d0,9494680.718d0,
     *59272.64853d0,267.8532712d0,1.d0/
      if(abs(x).lt.8.)then
        y=x**2
        bessj0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*
     *(s4+y*(s5+y*s6)))))

      else
        ax=abs(x)
        z=8./ax
        y=z**2
        xx=ax-.785398164
        bessj0=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
     *p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
      endif
      return
      END
C
      FUNCTION bessj1(x)
      REAL bessj1,x
      REAL ax,xx,z
      DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
     *s1,s2,s3,s4,s5,s6,y
      SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
     *s5,s6
      DATA r1,r2,r3,r4,r5,r6/72362614232.d0,-7895059235.d0,
     *242396853.1d0,-2972611.439d0,15704.48260d0,-30.16036606d0/,s1,s2,
     *s3,s4,s5,s6/144725228442.d0,2300535178.d0,18583304.74d0,
     *99447.43394d0,376.9991397d0,1.d0/
      DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4,
     *.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0,
     *-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/
      if(abs(x).lt.8.)then
        y=x**2
        bessj1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+
     *y*(s4+y*(s5+y*s6)))))

      else
        ax=abs(x)
        z=8./ax
        y=z**2
        xx=ax-2.356194491
        bessj1=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
     *p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))*sign(1.,x)
      endif
      return
      END
C
      FUNCTION bessj(n,x)
      INTEGER n,IACC
      REAL bessj,x,BIGNO,BIGNI
      PARAMETER (IACC=40,BIGNO=1.e10,BIGNI=1.e-10)
CU    USES bessj0,bessj1
      INTEGER j,jsum,m
      REAL ax,bj,bjm,bjp,sum,tox,bessj0,bessj1
      if(n.lt.2)pause 'bad argument n in bessj'
      ax=abs(x)
      if(ax.eq.0.)then
        bessj=0.
      else if(ax.gt.float(n))then
        tox=2./ax
        bjm=bessj0(ax)
        bj=bessj1(ax)
        do 11 j=1,n-1
          bjp=j*tox*bj-bjm
          bjm=bj
          bj=bjp
11      continue
        bessj=bj

      else
        tox=2./ax
        m=2*((n+int(sqrt(float(IACC*n))))/2)
        bessj=0.
        jsum=0
        sum=0.
        bjp=0.
        bj=1.
        do 12 j=m,1,-1
          bjm=j*tox*bj-bjp
          bjp=bj
          bj=bjm
          if(abs(bj).gt.BIGNO)then
            bj=bj*BIGNI
            bjp=bjp*BIGNI
            bessj=bessj*BIGNI
            sum=sum*BIGNI
          endif
          if(jsum.ne.0)sum=sum+bj
          jsum=1-jsum
          if(j.eq.n)bessj=bjp

12      continue
        sum=2.*sum-bj
        bessj=bessj/sum
      endif
      if(x.lt.0..and.mod(n,2).eq.1)bessj=-bessj
      return
      END


subroutine unfold_nofk(gvecs, nkm, mats, rgvecs, nkm1, filled, ndim, nk, nkr, ns)
  integer, intent(in) :: gvecs(nk, ndim), rgvecs(nkr, ndim)
  integer, intent(in) :: mats(ns, ndim, ndim)
  double precision, intent(in) :: nkm(nk)
  double precision, intent(out) :: nkm1(nkr)
  logical, intent(out) :: filled(nkr)

  integer :: gmin(ndim), gmax(ndim), ng(ndim)
  integer :: gvec1(ndim), idx3d(ndim)
  integer idx1d
  logical outside

  gmin = minval(rgvecs, dim=1)
  gmax = maxval(rgvecs, dim=1)
  ng = gmax-gmin+1
  ! checked gmin, gmax, ng against chc.get_regular_grid_dimensions

  filled(:) = .false.
  do ig=1,nk
    do is=1,ns
      ! apply symmetry operation to gvec -> gvec1
      do j=1,ndim
        gvec1(j) = 0.0
        do i=1,ndim
          gvec1(j) = gvec1(j) + gvecs(ig, i)*mats(is, j, i)
        enddo
      enddo
      outside = .false.
      do i=1,ndim
        if ((gvec1(j).lt.gmin(j)).or.(gvec1(j).gt.gmax(j))) outside=.true.
      enddo
      if (outside) cycle

      idx3d = gvec1-gmin
      idx1d = idx3d(3) + idx3d(2)*ng(3) + idx3d(1)*ng(3)*ng(2) + 1
      if (filled(idx1d)) then
        cycle
      endif
      nkm1(idx1d) = nkm(ig)
      filled(idx1d) = .true.
    enddo
  enddo
end subroutine unfold_nofk


program Main

        implicit none
        integer :: i,j,N,k,count
        double precision :: temp

        N=1000

        do count = 1, 100

        !$omp parallel do private(k,temp) shared(N) default(none)
        do k = 1,100

                temp = 0d0

                !$OMP target teams distribute parallel do private(i,j) shared(N) collapse(2) reduction(+:temp) default(none)
                do j=1,N
                        do i=1,N
                                temp = temp + 1d-5
                        enddo
                enddo
                !$OMP end target teams distribute parallel do

                print *, "k:", k, "; temp = ", temp

        enddo
        !$omp end parallel do

        print *, "--------------"

        enddo
end program Main


program p1

  implicit none
  real :: F,C

  print *,'Please input a emperature in F'
  read *,F
  open(unit=20,file='output.dat')

  C=(F-32)*5./9
  print *,C
  write (20,*) F,' F',achar(10),C,' C'
  close(20)

end program


!>
! Runs a linear advection diffusion equation with increasing resolution and checks that the observed
! convergence orders match the order of the involved discretizations.
! Additionally, the same test is run N times by N threads and it is checked that all threads compute the same results.
!
PROGRAM advection_diffusion_test

USE Timestepper, only : Euler, RK3Ssp, InitializeTimestepper, FinalizeTimestepper
IMPLICIT NONE

INCLUDE 'mpif.h'

DOUBLE PRECISION, PARAMETER :: pi = 3.1415926535897932_8 ! underscore indicates rounding to real(8) precision
INTEGER, PARAMETER, DIMENSION(5) :: N_v = (/ 20, 30, 40, 50, 60 /)

DOUBLE PRECISION, PARAMETER :: Tend = 0.05

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q

DOUBLE PRECISION :: dx, dy, dz, x, y, z, dt, T0, T1, nu, max_err
INTEGER :: method, i, j, k, Nx, Ny, Nz, nt, nn, order_adv, order_diff, Nsteps, Nthreads, mpi_thread_provided, ierr

CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, mpi_thread_provided, ierr)

DO method=1,3,2

        IF  (method==1) THEN
            order_adv  = 1
            order_diff = 2
        ELSE IF (method==3) THEN
            order_adv  = 5
            order_diff = 4
        END IF

        DO nn=1,SIZE(N_v)

            Nx = N_v(nn)-3
            Ny = N_v(nn)+1
            Nz = N_v(nn)+3

            dx = 1.0/DBLE(Nx)
            dy = 1.0/DBLE(Ny)
            dz = 1.0/DBLE(Nz)

            nu = 0.0025
            dt = 0.5*(dz*dz)/nu
            Nsteps = CEILING(Tend/dt)
            dt     = Tend/DBLE(Nsteps)

           DO Nthreads=1,8

                ALLOCATE(Q(   -2:Nx+3, -2:Ny+3, -2:Nz+3, 0:Nthreads-1))

                CALL InitializeTimestepper(nu, Nx, Ny, Nz, Nthreads)

                ! Compute initial and analytic solution
                DO k=-2,Nz+3
                    DO j=-2,Ny+3
                        DO i=-2,Nx+3

                        x = 0.5*dx + DBLE(i - 1)*dx
                        y = 0.5*dy + DBLE(j - 1)*dy
                        z = 0.5*dz + DBLE(k - 1)*dz

                        Q(i,j,k,:)    = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)

                        END DO
                    END DO
                END DO

                T0 = MPI_WTIME()
                !$OMP PARALLEL DO schedule(static)
                DO nt=0,Nthreads-1

                    IF (method==1) THEN
                        CALL Euler( Q(:,:,:,nt), DBLE(0.0), Tend, Nsteps, dx, dy, dz, order_adv, order_diff)
                    ELSE IF (method==3) THEN
                        CALL Rk3Ssp(Q(:,:,:,nt), DBLE(0.0), Tend, Nsteps, dx, dy, dz, order_adv, order_diff)
                    END IF

                END DO
                !$OMP END PARALLEL DO
                T1 = MPI_WTIME()

                DO nt=1,Nthreads-1
                     max_err = MAXVAL(ABS(Q(:,:,:,nt)-Q(:,:,:,nt-1)))
                     IF (max_err>1e-14) THEN
                        WRITE(*,'(A, I1, A, I2, A)') 'ERROR: For method=', method, ' and Nthreads = ', Nthreads, ' not all threads computed the same result, this should not have happened. Now exiting...'
                        STOP
                    END IF
                END DO

                CALL FinalizeTimestepper

                DEALLOCATE(Q)

            END DO ! Nthreads
        END DO ! N_v

END DO ! method

CALL MPI_FINALIZE(ierr)

PRINT *,'\x1B[32m[0] -- Successful: Both Euler and Rk3Ssp on multiple threads on identical input yields identical output. \x1B[0m'

END PROGRAM advection_diffusion_test


program INTP2D

use mod_ctpin
use mod_sttrans
use mod_starea
use mod_trans
use mod_inp2dp
use mod_intdep

implicit none

integer :: nsource, icheck, ls, lsource, lsd, ipl
real(8) :: ala, alg, x, y, z, x1, y1
character(LEN=24) :: flf, fcof, fctp

call getarg(1,fctp)

open(9,file=fctp)

CALL SETA2D(nsource)

print *, "NSOURCE =", nsource
print *, "ENTER SOURCE NUMBER"
read *, ls

icheck = 0

do lsource = 1, nsource
	lsd = lsource
	CALL SETFC2D(lsd, flf, fcof, ipl)
	if(lsd == ls) then
		icheck = 1
		exit
	end if
end do

if(icheck == 0) stop
if(ipl == 1) stop

CALL STTRANS
CALL STAREA

open(31,file = fcof,status='old')
	CALL INP2DP(31)
close(31)

do
	print *, ' ENTER POSITION(LAT. LON.)'
	print *, ' TO EXIT, ENTER (0.0, 0.0)'
	print *, ' '
	read *, ala, alg

	if(ala == 0.d0 .and. alg == 0.d0) exit

	CALL PLTXY(ala, alg, x, y, 0)
	CALL TRANS(x, y, x1, y1, 1, 1)
	CALL INTDEP(x1, y1, z)

	print '(1X,2(F12.4,1X),1X,3(F10.4,1X))', ala, alg, x, y, z

end do

close(9)

stop
end


      double precision function dentfa (dr,dz,ch)
c     analitical approximation of potential is created for electrons in
c     thomas-fermi model for atom or free ion. dr distance from nucleus
c     with charge dz
c     ch=ionicity = number of electrons-dz-1
      implicit double precision (a-h,o-z)

      dentfa=0.0d 00
      if ((dz+ch).lt.1.0d-04) return
      w=dr*(dz+ch)**(1./3.)
      w=sqrt(w/0.8853)
      t=w*(0.60112*w+1.81061)+1.
      w=w*(w*(w*(w*(0.04793*w+0.21465)+0.77112)+1.39515)+1.81061)+1
      dentfa=(dz+ch)*(1.0d 00-(t/w)**2)/dr
      return
      end


      SUBROUTINE GWAVE (ERV,EZV,ERH,EZH,EPH)
C
C     GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A
C     CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON
C     (PROC. IRE, SEPT., 1937, PP.1203,1236.)
C
      COMPLEX FJ,TPJ,U2,U,RK1,RK2,T1,T2,T3,T4,P1,RV,OMR,W,F,Q1,RH,V,G,XR
     11,XR2,X1,X2,X3,X4,X5,X6,X7,EZV,ERV,EZH,ERH,EPH,XX1,XX2,ECON,FBAR
      COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH
      DIMENSION FJX(2), TPJX(2), ECONX(2)
      EQUIVALENCE (FJ,FJX), (TPJ,TPJX), (ECON,ECONX)
      DATA PI/3.141592654/,FJX/0.,1./,TPJX/0.,6.283185308/
      DATA ECONX/0.,-188.367/
      SPPP=ZMH/R1
      SPPP2=SPPP*SPPP
      CPPP2=1.-SPPP2
      IF (CPPP2.LT.1.E-20) CPPP2=1.E-20
      CPPP=SQRT(CPPP2)
      SPP=ZPH/R2
      SPP2=SPP*SPP
      CPP2=1.-SPP2
      IF (CPP2.LT.1.E-20) CPP2=1.E-20
      CPP=SQRT(CPP2)
      RK1=-TPJ*R1
      RK2=-TPJ*R2
      T1=1.-U2*CPP2
      T2=CSQRT(T1)
      T3=(1.-1./RK1)/RK1
      T4=(1.-1./RK2)/RK2
      P1=RK2*U2*T1/(2.*CPP2)
      RV=(SPP-U*T2)/(SPP+U*T2)
      OMR=1.-RV
      W=1./OMR
      W=(4.,0.)*P1*W*W
      F=FBAR(W)
      Q1=RK2*T1/(2.*U2*CPP2)
      RH=(T2-U*SPP)/(T2+U*SPP)
      V=1./(1.+RH)
      V=(4.,0.)*Q1*V*V
      G=FBAR(V)
      XR1=XX1/R1
      XR2=XX2/R2
      X1=CPPP2*XR1
      X2=RV*CPP2*XR2
      X3=OMR*CPP2*F*XR2
      X4=U*T2*SPP*2.*XR2/RK2
      X5=XR1*T3*(1.-3.*SPPP2)
      X6=XR2*T4*(1.-3.*SPP2)
      EZV=(X1+X2+X3-X4-X5-X6)*ECON
      X1=SPPP*CPPP*XR1
      X2=RV*SPP*CPP*XR2
      X3=CPP*OMR*U*T2*F*XR2
      X4=SPP*CPP*OMR*XR2/RK2
      X5=3.*SPPP*CPPP*T3*XR1
      X6=CPP*U*T2*OMR*XR2/RK2*.5
      X7=3.*SPP*CPP*T4*XR2
      ERV=-(X1+X2-X3+X4-X5+X6-X7)*ECON
      EZH=-(X1-X2+X3-X4-X5-X6+X7)*ECON
      X1=SPPP2*XR1
      X2=RV*SPP2*XR2
      X4=U2*T1*OMR*F*XR2
      X5=T3*(1.-3.*CPPP2)*XR1
      X6=T4*(1.-3.*CPP2)*(1.-U2*(1.+RV)-U2*OMR*F)*XR2
      X7=U2*CPP2*OMR*(1.-1./RK2)*(F*(U2*T1-SPP2-1./RK2)+1./RK2)*XR2
      ERH=(X1-X2-X4-X5+X6+X7)*ECON
      X1=XR1
      X2=RH*XR2
      X3=(RH+1.)*G*XR2
      X4=T3*XR1
      X5=T4*(1.-U2*(1.+RV)-U2*OMR*F)*XR2
      X6=.5*U2*OMR*(F*(U2*T1-SPP2-1./RK2)+1./RK2)*XR2/RK2
      EPH=-(X1-X2+X3-X4+X5+X6)*ECON
      RETURN
      END


      SUBROUTINE SINFT(Y,N)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION Y(N)
      THETA=3.14159265358979D0/DBLE(N)
      WR=1.0D0
      WI=0.0D0
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      Y(1)=0.0
      M=N/2
      DO 11 J=1,M
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
        Y1=WI*(Y(J+1)+Y(N-J+1))
        Y2=0.5*(Y(J+1)-Y(N-J+1))
        Y(J+1)=Y1+Y2
        Y(N-J+1)=Y1-Y2
11    CONTINUE
      CALL REALFT(Y,M,+1)
      SUM=0.0
      Y(1)=0.5*Y(1)
      Y(2)=0.0
      DO 12 J=1,N-1,2
        SUM=SUM+Y(J)
        Y(J)=Y(J+1)
        Y(J+1)=SUM
12    CONTINUE
      RETURN
      END


	program parabola
c
c	debyel is actually sqrt(3 kT / m)
c		for kt = 12 eV, debyel = 8.4 e-3
	debyel = 8.4 e-3
	fact = 45.
	npt = 100
	do n = 0,npt
	  waven = fact*(2.*n - npt)/npt
	  f1 = sqrt(1. + 3.*(debyel*waven)**2)
	  f2 = sqrt(1. + waven**2)
	  write(45,*) debyel*waven,f1,f2
	  print*, debyel*waven,f1,f2
	enddo
	stop
	end


      SUBROUTINE ACNVRT(IDATE,SECOND)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     ACNVRT CONVERTS A SIX DIGIT INTEGER (YYMMDD) AND SECONDS TO
C     SECONDS FROM START OF THE YEAR
C     NO TAPES AND NO SUBROUTINES ARE REQUIRED
      DIMENSION JULDAY(12)
C
      DATA JULDAY/ 0,31,59,90,120,151,181,212,243,273,304,334/
      IY=IDATE/10000
      IM=(IDATE - IY*10000)/100
      IDAY=MOD(IDATE,100)-1
      IF(MOD(IY,4).EQ.0.AND.IM.GT.2) IDAY=IDAY + 1
      JDAY=JULDAY(IM) + IDAY
      SECOND=DFLOAT(JDAY)*8.64D4 + SECOND
      RETURN
      END


      REAL FUNCTION TG01B*4(IX,N,U,S,D,X)
C###### 04/08/70LAST LIBRARY UPDATE
C
C	--------------------------------------------------------
C
C
C
C      TG01B -  FUNCTION ROUTINE TO EVALUATE A CUBIC SPLINE GIVEN SPLINE
C     VALUES AND FIRST DERIVATIVE VALUES AT THE GIVEN KNOTS.
C
C     THE SPLINE VALUE IS DEFINED AS ZERO OUTSIDE THE KNOT RANGE,WHICH
C     IS EXTENDED BY A ROUNDING ERROR FOR THE PURPOSE.
C
C                  F = TG01B(IX,N,U,S,D,X)
C
C       IX    ALLOWS CALLER TO TAKE ADVANTAGE OF SPLINE PARAMETERS SET
C             ON A PREVIOUS CALL IN CASES WHEN X POINT FOLLOWS PREVIOUS
C             X POINT. IF IX < 0 THE WHOLE RANGE IS SEARCHED FOR KNOT
C             INTERVAL; IF IX > 0 IT IS ASSUMED THAT X IS GREATER THAN
C             THE X OF THE PREVIOUS CALL AND SEARCH STARTED FROM THERE.
C       N     THE NUMBER OF KNOTS.
C       U     THE KNOTS.
C       S     THE SPLINE VALUES.
C       D     THE FIRST DERIVATIVE VALUES OF THE SPLINE AT THE KNOTS.
C       X     THE POINT AT WHICH THE SPLINE VALUE IS REQUIRED.
C       F     THE VALUE OF THE SPLINE AT THE POINT X.
C
C                                      MODIFIED JULY 1970
C
C**********************************************************************
C
C     ALLOWABLE ROUNDING ERROR ON POINTS AT EXTREAMS OF KNOT RANGE
C     IS 2**IEPS*MAX(!U(1)!,!U(N)!).
      INTEGER*4 IFLG,IEPS
      DIMENSION U(1),S(1),D(1)
      DATA IFLG/0/,IEPS/-19/
C
C       TEST WETHER POINT IN RANGE.
      IF(X.LT.U(1)) GO TO 990
      IF(X.GT.U(N)) GO TO 991
C
C       JUMP IF KNOT INTERVAL REQUIRES RANDOM SEARCH.
      IF(IX.LT.0.OR.IFLG.EQ.0) GO TO 12
C       JUMP IF KNOT INTERVAL SAME AS LAST TIME.
      IF(X.LE.U(J+1)) GO TO 8
C       LOOP TILL INTERVAL FOUND.
    1 J=J+1
   11 IF(X.GT.U(J+1)) GO TO 1
      GO TO 7
C
C       ESTIMATE KNOT INTERVAL BY ASSUMING EQUALLY SPACED KNOTS.
   12 J=ABS(X-U(1))/(U(N)-U(1))*(N-1)+1
C       ENSURE CASE X=U(N) GIVES J=N-1.
      J=MIN0(J,N-1)
C       INDICATE THAT KNOT INTERVAL INSIDE RANGE HAS BEEN USED.
      IFLG=1
C       SEARCH FOR KNOT INTERVAL CONTAINING X.
      IF(X.GE.U(J)) GO TO 11
    2 J=J-1
      IF(X.LT.U(J)) GO TO 2
C
C       CALCULATE SPLINE PARAMETERS FOR JTH INTERVAL.
    7 H=U(J+1)-U(J)
      Q1=H*D(J)
      Q2=H*D(J+1)
      SS=S(J+1)-S(J)
      B=3.0*SS-2.0*Q1-Q2
      A=Q1+Q2-2.0*SS
C
C       CALCULATE SPLINE VALUE.
    8 Z=(X-U(J))/H
      TG01B=((A*Z+B)*Z+Q1)*Z+S(J)
      RETURN
C       TEST IF X WITHIN ROUNDING ERROR OF U(1).
  990 IF(X.LE.U(1)-2.0**IEPS*AMAX1(ABS(U(1)),ABS(U(N)))) GO TO 99
      J=1
      GO TO 7
C       TEST IF X WITHIN ROUNDING ERROR OF U(N).
  991 IF(X.GE.U(N)+2.0**IEPS*AMAX1(ABS(U(1)),ABS(U(N)))) GO TO 99
      J=N-1
      GO TO 7
   99 IFLG=0
C       FUNCTION VALUE SET TO ZERO FOR POINTS OUTSIDE THE RANGE.
      TG01B=0.0
      RETURN
      END


************************************************************************
*
*     Function ZSCORE                       Called by: AMLSTAT
*
*     calculate ZSCORE, the Z-Score for a given area (AREA) under the
*     standard normal curve.  Uses approximation given in Section
*     26.2.23 of Abramowitz and Stegun (1964, p. 933).  The error in
*     the approximation is less than 4.5e-4.
*
*     This routine assumes:
*
*          0 < AREA < 1
*
*     which is always the case when ZSCORE is called from AMLSTAT.
*
*     local vars
*     ----------
*     AREA2    used to preserve the value of AREA when AREA > 0.5
*     C0       constant used in approximation
*     C1       constant used in approximation
*     C2       constant used in approximation
*     D1       constant used in approximation
*     D2       constant used in approximation
*     D3       constant used in approximation
*     T        calculated value used in approximation
*
************************************************************************
      DOUBLE PRECISION FUNCTION ZSCORE(AREA)
*
*     subroutine args
*
      DOUBLE PRECISION AREA
*
*     local vars
*
      DOUBLE PRECISION AREA2,C0,C1,C2,D1,D2,D3,T
      PARAMETER (C0=2.515517D0,C1=0.802853D0,C2=0.010328D0)
      PARAMETER (D1=1.432788D0,D2=0.189269D0,D3=0.001308D0)

      IF (AREA .LE. 0.5D0) THEN
         T = DSQRT(DLOG(1.D0/(AREA**2)))
         ZSCORE = -(T-((C0+T*(C1+T*C2))/(1.D0+(T*(D1+T*(D2+T*D3))))))
      ELSE
         AREA2 = 1.D0 - AREA
         T = DSQRT(DLOG(1.D0/(AREA2*AREA2)))
         ZSCORE = T-((C0+T*(C1+T*C2))/(1.D0+(T*(D1+T*(D2+T*D3)))))
      ENDIF

      RETURN
      END


! { dg-do compile }
!
! PR 44649: [OOP] F2008: storage_size intrinsic
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

use iso_c_binding, only: c_int, c_sizeof

type, bind(c) :: t
  integer(c_int) :: j
end type

integer(4) :: i1
integer(c_int) :: i2
type(t) :: x

print *,c_sizeof(i1)
print *,c_sizeof(i2)
print *,c_sizeof(x)
print *, c_sizeof(ran())

print *,storage_size(1.0,4)
print *,storage_size(1.0,3.2)       ! { dg-error "must be INTEGER" }
print *,storage_size(1.0,(/1,2/))   ! { dg-error "must be a scalar" }
print *,storage_size(1.0,irand())   ! { dg-error "must be a constant" }

end


! 9x9 multiplication table in Fortran90
! CC0, Wei-Lun Chao <bluebat@member.fsf.org>, 2018.
! gfortran mt9x9.f90 -o mt9x9 && ./mt9x9

program mt9x9
    implicit none
    integer :: i, j, k
    character(len=24) :: format
    do i = 1, 9, 3
    format = "(3(i1, a, i1, a, i2, a))"
    write(*,format) ((k, 'x', j, '=', k*j, char(9), k = i, i+2), j = 1, 9)
    write(*,*)
    end do
end program mt9x9


        subroutine idd_findrank(lra,eps,m,n,matvect,p1,p2,p3,p4,
     1                          krank,ra,ier,w)
c
c       estimates the numerical rank krank of a matrix a to precision
c       eps, where the routine matvect applies the transpose of a
c       to an arbitrary vector. This routine applies the transpose of a
c       to krank random vectors, and returns the resulting vectors
c       as the columns of ra.
c
c       input:
c       lra -- maximum usable length (in real*8 elements) of array ra
c       eps -- precision defining the numerical rank
c       m -- first dimension of a
c       n -- second dimension of a
c       matvect -- routine which applies the transpose
c                  of the matrix whose rank is to be estimated
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvect(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvect
c       p2 -- parameter to be passed to routine matvect
c       p3 -- parameter to be passed to routine matvect
c       p4 -- parameter to be passed to routine matvect
c
c       output:
c       krank -- estimate of the numerical rank of a
c       ra -- product of the transpose of a and a matrix whose entries
c             are pseudorandom realizations of i.i.d. random numbers,
c             uniformly distributed on [0,1];
c             ra must be at least 2*n*krank real*8 elements long
c       ier -- 0 when the routine terminates successfully;
c              -1000 when lra is too small
c
c       work:
c       w -- must be at least m+2*n+1 real*8 elements long
c
c       _N.B._: ra must be at least 2*n*krank real*8 elements long.
c               Also, the algorithm used by this routine is randomized.
c
        implicit none
        integer m,n,lw,krank,ix,lx,iy,ly,iscal,lscal,lra,ier
        real*8 eps,p1,p2,p3,p4,ra(n,*),w(m+2*n+1)
        external matvect
c
c
        lw = 0
c
        ix = lw+1
        lx = m
        lw = lw+lx
c
        iy = lw+1
        ly = n
        lw = lw+ly
c
        iscal = lw+1
        lscal = n+1
        lw = lw+lscal
c
c
        call idd_findrank0(lra,eps,m,n,matvect,p1,p2,p3,p4,
     1                     krank,ra,ier,w(ix),w(iy),w(iscal))
c
c
        return
        end
c
c
c
c


PROGRAM large_small
IMPLICIT NONE
  INTEGER, PARAMETER :: ARR_SIZE = 100
  REAL, DIMENSION(ARR_SIZE) :: input_vals
  REAL :: largest = 0, smallest = 0
  INTEGER :: index, num_vals

  WRITE(*, *) "How many numbers will be entered?"
  READ(*, *) num_vals

  DO index = 1, num_vals
    WRITE(*, *) "Enter a number:"
    READ(*, *) input_vals(index)
  END DO

  DO index = 1, num_vals
    IF (input_vals(index) > largest) THEN
      largest = input_vals(index)
    ELSE IF (input_vals(index) < smallest) THEN
      smallest = input_vals(index)
    END IF
  END DO

  DO index = 1, num_vals
    IF (input_vals(index) == largest) THEN
      WRITE(*, 100) input_vals(index), "LARGEST"
    ELSE IF (input_vals(index) == smallest) THEN
      WRITE(*, 100) input_vals(index), "SMALLEST"
    ELSE
      WRITE(*, 100) input_vals(index)
    END IF
    100 FORMAT (2X, F11.4, 2X, A8)
  END DO

END PROGRAM large_small


!> @file
!!  Define routne FFT 2D
!! @author
!!  Copyright (C) Stefan Goedecker, Lausanne, Switzerland, August 1, 1991
!!  Copyright (C) Stefan Goedecker, Cornell University, Ithaca, USA, 1994
!!  Copyright (C) Stefan Goedecker, MPI Stuttgart, Germany, 1999
!!  Copyright (C) Stefan Goedecker, CEA Grenoble, 2002
!!  Copyright (C) 2002-2009 BigDFT group
!!  This file is distributed under the terms of the
!!  GNU General Public License, see ~/COPYING file
!!  or http://www.gnu.org/copyleft/gpl.txt .
!!  For the list of contributors, see ~/AUTHORS

!> CALCULATES THE DISCRETE FOURIER TRANSFORM F(I1,I2)=
!!    S_(j1,j2) EXP(isign*i*2*pi*(j1*i1/n1+j2*i2/n2)) R(j1,j2)
!!    INPUT:
!!        n1,n2:physical dimension of the transform. It must be a
!!          product of the prime factors 2,3,5, but greater than 3.
!!                 If two ni's are equal it is recommended to place them
!!                 behind each other.
!!        nd1,nd2:memory dimension of Z. ndi must always be greater or
!!            equal than ni. It is recomended to chose ndi=ni
!!            if ni is odd and ndi=ni+1 if ni is even to obtain
!!                   optimal execution speed. For small ni it can however
!!                   sometimes be advantageous to set ndi=ni
!!           inzee=1: first part of Z is data array, second part work array
!!           inzee=2: first part of Z is work array, second part data array
!!        Z(1,i1,i2,inzee)=real(R(i1,i2))
!!        Z(2,i1,i2,inzee)=imag(R(i1,i2))
!!    OUTPUT:
!!           inzee=1: first part of Z is data array, second part work array
!!           inzee=2: first part of Z is work array, second part data array
!!        real(F(i1,i2))=Z(1,i1,i2,inzee)
!!        imag(F(i1,i2))=Z(2,i1,i2,inzee)
!!            inzee on output is in general different from inzee on input
!!    THE ARRAYELEMENTS Z( , , , ,3-inzee) ARE USED AS WORKING SPACE
!!       On a RISC machine with cache, it is very important to find the optimal
!!       value of NCACHE. NCACHE determines the size of the work array zw, that
!!       has to fit into cache. It has therefore to be chosen to equal roughly
!!    half the size of the physical cache in units of real*8 numbers.
!!       The optimal value of ncache can easily be determined by numerical
!!       experimentation. A too large value of ncache leads to a dramatic
!!       and sudden decrease of performance, a too small value to a to a
!!       slow and less dramatic decrease of performance. If NCACHE is set
!!       to a value so small, that not even a single one dimensional transform
!!       can be done in the workarray zw, the program stops with an error message.
!!    On a vector machine ncache has to be put to 0
!!
subroutine FFT2d(n1,n2,nd1,nd2,z,isign,inzee,zw,ncache)

   implicit none
   !Arguments
   integer, intent(in) :: n1,n2,nd1,nd2,isign,ncache
   integer, intent(inout) :: inzee
   integer, dimension(20) :: after,before,now
   real(kind=8), dimension(2,nd1*nd2,2) :: z
   real(kind=8), dimension(2,ncache/4,2) :: zw
   !Local variables
   integer, parameter :: nmax = 1024
   real(kind=8), dimension(2,nmax) :: trig
   integer :: ntrig,nn,nfft,n,mm,mb,ma,j,m,lot,jp,jj,jb,ja,inzeep
   integer :: ic,i

   if (max(n1,n2).gt.nmax) stop '1024'
   ntrig=nmax
   ! vector computer with memory banks:
   if (ncache.eq.0) then

      ! TRANSFORM ALONG Y AXIS
      call ctrig_sg(n2,ntrig,trig,after,before,now,isign,ic)
      nfft=n1
      mm=nd1
      do i=1,ic-1
         call fftstp_sg(mm,nfft,nd2,mm,nd2,z(1,1,inzee),z(1,1,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)
         inzee=3-inzee
      end do
      i=ic
      call fftrot_sg(mm,nfft,nd2,mm,nd2,z(1,1,inzee),z(1,1,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)
      inzee=3-inzee

      ! TRANSFORM ALONG X AXIS
      if (n1.ne.n2) call ctrig_sg(n1,ntrig,trig,after,before,now,isign,ic)
      nfft=n2
      mm=nd2
      do i=1,ic-1
         call fftstp_sg(mm,nfft,nd1,mm,nd1,z(1,1,inzee),z(1,1,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)
         inzee=3-inzee
      end do
      i=ic
      call fftrot_sg(mm,nfft,nd1,mm,nd1,z(1,1,inzee),z(1,1,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)
      inzee=3-inzee

      ! RISC machine with cache:
   else

      ! TRANSFORM ALONG Y AXIS
      mm=nd1
      m=nd2
      lot=max(1,ncache/(4*n2))
      !    print*,'lot',lot
      nn=lot
      n=n2
      if (2*n*lot*2.gt.ncache) stop 'enlarge ncache :2'
      call ctrig_sg(n2,ntrig,trig,after,before,now,isign,ic)

      ja=1
      jb=n1

      if (ic.eq.1) then
         i=ic
         jj=ja*nd2-nd2+1
         nfft=jb-ja+1
         call fftrot_sg(mm,nfft,m,mm,m,z(1,ja,inzee),z(1,jj,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)

      else

         do j=ja,jb,lot
            ma=j
            mb=min(j+(lot-1),jb)
            nfft=mb-ma+1
            jj=j*nd2-nd2+1

            i=1
            inzeep=2
            call fftstp_sg(mm,nfft,m,nn,n,z(1,j,inzee),zw(1,1,3-inzeep),ntrig,trig,after(i),now(i),before(i),isign)
            inzeep=1

            do i=2,ic-1
               call fftstp_sg(nn,nfft,n,nn,n,zw(1,1,inzeep),zw(1,1,3-inzeep),ntrig,trig,after(i),now(i),before(i),isign)
               inzeep=3-inzeep
            end do

            i=ic
            call fftrot_sg(nn,nfft,n,mm,m,zw(1,1,inzeep),z(1,jj,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)
         end do
      endif
      inzee=3-inzee

      ! TRANSFORM ALONG X AXIS
      mm=nd2
      m=nd1
      lot=max(1,ncache/(4*n1))
      !    print*,'lot',lot
      nn=lot
      n=n1
      if (2*n*lot*2.gt.ncache) stop 'enlarge ncache :1'
      if (n1.ne.n2) call ctrig_sg(n1,ntrig,trig,after,before,now,isign,ic)

      if (ic.eq.1) then
         i=ic
         j=1
         jp=nd2
         jj=j*nd1-nd1+1
         nfft=jp-j+1
         call fftrot_sg(mm,nfft,m,mm,m,z(1,j,inzee),z(1,jj,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)

      else

         do j=1,n2,lot
            ma=j
            mb=min(j+(lot-1),n2)
            nfft=mb-ma+1
            jj=j*nd1-nd1+1

            i=1
            inzeep=2
            call fftstp_sg(mm,nfft,m,nn,n,z(1,j,inzee),zw(1,1,3-inzeep),ntrig,trig,after(i),now(i),before(i),isign)
            inzeep=1

            do i=2,ic-1
               call fftstp_sg(nn,nfft,n,nn,n,zw(1,1,inzeep),zw(1,1,3-inzeep),ntrig,trig,after(i),now(i),before(i),isign)
               inzeep=3-inzeep
            end do
            i=ic
            call fftrot_sg(nn,nfft,n,mm,m,zw(1,1,inzeep),z(1,jj,3-inzee),ntrig,trig,after(i),now(i),before(i),isign)
         end do
      endif
      inzee=3-inzee

   endif

END SUBROUTINE fft2d


      subroutine evolve_dgx(ctfmp,n_A,n_Axx,n_alpha,n_beta,n_divbeta,np1
     &_A,np1_Axx,np1_alpha,np1_beta,np1_divbeta,x,Nx,ht,hx,myzero,vee,ze
     &psdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 vee
      real*8 zepsdis
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Axx(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 np1_A(Nx)
      real*8 np1_Axx(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_divbeta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1D1 - 0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = np1_A(i) - 0.32D2 / (0.7D1 * zepsdis * hx + 0.64D2 * ht) * hx
     # * ht * (-0.5000000000000000D0 * (0.3D1 * np1_A(i - 1) - 0.4D1 * n
     #p1_A(i) + np1_A(i + 1)) / hx + 0.3125000000000000D-1 * zepsdis / h
     #t * (0.7D1 * np1_A(i) + np1_A(i + 2) - 0.4D1 * np1_A(i + 1) - 0.4D
     #1 * np1_A(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1
     #* n_A(i) + n_A(i + 2) - 0.4D1 * n_A(i + 1) - 0.4D1 * n_A(i - 1)))
      res(i)=qb
      end do
      endif
      do i=3, Nx-2, 1
      qb = np1_A(i) - 0.48D2 / (0.16D2 * vee * np1_divbeta(i) * ht * ctf
     #mp(i) * hx + 0.9D1 * zepsdis * ctfmp(i) * hx + 0.24D2 * ht * np1_b
     #eta(i - 1) - 0.24D2 * ht * np1_beta(i + 1) + 0.48D2 * hx * ctfmp(i
     #)) * ht * ctfmp(i) * hx * (-0.1D1 * (n_A(i) - 0.1D1 * np1_A(i)) /
     #ht + np1_Axx(i) * np1_alpha(i) + 0.3333333333333333D0 * np1_A(i) *
     # vee * np1_divbeta(i) - 0.5000000000000000D0 * ((-0.1D1 * np1_beta
     #(i - 1) + np1_beta(i + 1)) * np1_A(i) + 0.5000000000000000D0 * np1
     #_beta(i) * (-0.1D1 * np1_A(i - 1) + np1_A(i + 1))) / ctfmp(i) / hx
     # + n_Axx(i) * n_alpha(i) + 0.3333333333333333D0 * n_A(i) * vee * n
     #_divbeta(i) - 0.5000000000000000D0 * ((-0.1D1 * n_beta(i - 1) + n_
     #beta(i + 1)) * n_A(i) + 0.5000000000000000D0 * n_beta(i) * (-0.1D1
     # * n_A(i - 1) + n_A(i + 1))) / ctfmp(i) / hx + 0.3125000000000000D
     #-1 * zepsdis / ht * (0.6D1 * np1_A(i) + np1_A(i + 2) + np1_A(i - 2
     #) - 0.4D1 * np1_A(i + 1) - 0.4D1 * np1_A(i - 1)) + 0.3125000000000
     #000D-1 * zepsdis / ht * (0.6D1 * n_A(i) + n_A(i + 2) + n_A(i - 2)
     #- 0.4D1 * n_A(i + 1) - 0.4D1 * n_A(i - 1)))
      res(i)=qb
      end do
      do i=Nx-1, Nx-1, 1
      qb = np1_A(i) - 0.6D1 / (0.2D1 * vee * np1_divbeta(i) * ht * ctfmp
     #(i) * hx + 0.3D1 * ht * np1_beta(i - 1) - 0.3D1 * ht * np1_beta(i
     #+ 1) + 0.6D1 * hx * ctfmp(i)) * ht * ctfmp(i) * hx * (-0.1D1 * (n_
     #A(i) - 0.1D1 * np1_A(i)) / ht + np1_Axx(i) * np1_alpha(i) + 0.3333
     #333333333333D0 * np1_A(i) * vee * np1_divbeta(i) - 0.5000000000000
     #000D0 * ((-0.1D1 * np1_beta(i - 1) + np1_beta(i + 1)) * np1_A(i) +
     # 0.5000000000000000D0 * np1_beta(i) * (-0.1D1 * np1_A(i - 1) + np1
     #_A(i + 1))) / ctfmp(i) / hx + n_Axx(i) * n_alpha(i) + 0.3333333333
     #333333D0 * n_A(i) * vee * n_divbeta(i) - 0.5000000000000000D0 * ((
     #-0.1D1 * n_beta(i - 1) + n_beta(i + 1)) * n_A(i) + 0.5000000000000
     #000D0 * n_beta(i) * (-0.1D1 * n_A(i - 1) + n_A(i + 1))) / ctfmp(i)
     # / hx)
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_A(i) - 0.1D1 * ht * (-0.1D1 * (n_A(i) - 0.1D1 * np1_A(i))
     # / ht - 0.1D1 * myzero * x(i))
      res(i)=qb
      end do
      endif
      END


C$PROCEDURE         DCOKE

	SUBROUTINE  DCOKE (FM, DF, DE)

C$   PURPOSE
C%
C%           This subroutine computes the values of the complete elliptic
C%      integrals, which are defined as follows:
C%
C%                  pi/2
C%                  (            2  -1/2
C%      (1)  K(x) = / ( 1 - x sin t )   dt
C%                  )
C%                  0
C%
C%                  pi/2
C%                  (            2   1/2
C%      (2)  E(x) = / ( 1 - x sin t )   dt.
C%                  )
C%                  0
C%
C$   INPUT_ARGUMENTS
C%
C%      FM          The value of x.  Double precision.
C%
C$   OUTPUT_ARGUMENTS
C%
C%      DF          Computed value of K(x).  Real.
C%
C%      DE          Computed value of E(x).  Real.
C%
C$   COMMON_BLOCKS
C%
C%      None.
C%
C$   METHOD
C%
C%           Cody's polynomial Chebyshev approximations are used (cf. Math.
C%      of Comp. Vol. 19, pp. 105-112, 1965).  These approximations take the
C%      form
C%
C%          P (1-x) - ln(1-x) Q (1-x).
C%           n                 n
C%
C%      where P  and Q  are different polynomials for K and E and n is the
C%             n      n
C%      degree of the polynomials, n = 9.
C%
C%           Testing indicated the following upper bounds for the relative
C%      error:
C%
C%                DF      1.8E-16
C%                DE      1.0E-16.
C%
C$   SUBROUTINES_CALLED
C%
C%           None.
C%
C$   RESTRICTIONS
C%
C%           For |1-x| < 5.E-8, F is set to zero and E to 1, and the message,
C%      "MODULUS TOO CLOSE TO ONE, F BECOMES INFINITE, E(1) = 1" is printed.
C%      For x > 1.0 + 5.E-8, F and E are set equal to zero and the message
C%      "MODULUS GREATER THAN ONE" is issued.
C%
C$   EXAMPLE
C%
C%      This demonstration driver for DCOKE verifies Legendre's relation:
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C                                                                     C
C%      C       DEMONSTRATION DRIVER FOR MODULE DCOKE                         C
C%      C                                                                     C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%
C%
C%              DOUBLE PRECISION  A
C%              DOUBLE PRECISION  FK,FE,FKP,FEP
C%              DOUBLE PRECISION  TWODPI
C%              DOUBLE PRECISION  RTX
C%              DOUBLE PRECISION  X
C%
C%              INTEGER  J
C%
C%
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%      C       TWODPI = 2/PI = 0.63661 97723 67581 34308 ...                 C
C%      CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C%              DATA TWODPI/0.636619772E0/
C%
C%              WRITE(6,1000)
C%      1000    FORMAT(////' EXAMPLE OUTPUT FOR DEMOCOKE '//)
C%
C%              DO  100 J = 1, 10
C%
C%                      X = DBLE(UNIFRM(DUMM1)*10.D-8) + DBLE(UNIFRM(DUMM2))
C%                      RTX  =  1.D0 - X
C%
C%                      CALL  DCOKE (X, FK, FE)
C%                      CALL  DCOKE (RTX, FKP, FEP)
C%                      A = ( FK*FEP + FKP*FE - FK*FKP ) * TWODPI
C%                      WRITE(6,50)  J, X, RTX, A
C%
C%      100     CONTINUE
C%
C%      50      FORMAT(I4,3D20.8)
C%
C%
C%              CALL EXIT
C%              END
C%
C%
C%
C%
C%      EXAMPLE OUTPUT FOR DEMOCOKE:
C%
C%        1      0.80157138D+00      0.19842862D+00      0.10000000D+01
C%        2      0.84421894D+00      0.15578106D+00      0.10000000D+01
C%        3      0.35852941D+00      0.64147059D+00      0.10000000D+01
C%        4      0.81605473D+00      0.18394527D+00      0.10000000D+01
C%        5      0.78092570D+00      0.21907430D+00      0.10000000D+01
C%        6      0.84188371D+00      0.15811629D+00      0.10000000D+01
C%        7      0.68244006D+00      0.31755994D+00      0.10000000D+01
C%        8      0.93685377D+00      0.63146227D-01      0.10000000D+01
C%        9      0.65833194D+00      0.34166806D+00      0.10000000D+01
C%       10      0.57335630D+00      0.42664370D+00      0.10000000D+01
C%
C-&

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	E. W. NG, SEPTEMBER 1974, J. P. L.                                    C
C	F. A. MCCREARY, JANUARY 1985, J. P. L.                                C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	IMPLICIT  NONE

	DOUBLE PRECISION  A(9)
	DOUBLE PRECISION  B(9)
	DOUBLE PRECISION  C(9)
	DOUBLE PRECISION  D(9),DF,DE
	DOUBLE PRECISION  FM,FX,FY,FMP,FIN,FUDGE
	DOUBLE PRECISION  S1,S2,S3,S4
	DOUBLE PRECISION  VL

	INTEGER  J

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	DATA BLOCKS                                                           C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	DATA  A/ 3.00725199036864838D-4, 3.96847090209897819D-3,
     *           1.07959904905916349D-2, 1.05899536209893585D-2,
     *           7.51938672180838102D-3, 8.92664629455646620D-3,
     *           1.49420291422820783D-2, 3.08851730018997099D-2,
     *           9.65735903017425285D-2 /

	DATA  B / 6.66317524646073151D-5, 1.72161470979865212D-3,
     *            9.28116038296860419D-3, 2.06902400051008404D-2,
     *            2.95037293486887130D-2, 3.73355466822860296D-2,
     *            4.88271550481180099D-2, 7.03124954595466082D-2,
     *            1.24999999997640658D-1 /

	DATA  C / 3.25192015506390418D-4, 4.30253777479311659D-3,
     *            1.17858410087339355D-2, 1.18419259955012494D-2,
     *            9.03552773754088184D-3, 1.17167669446577228D-2,
     *            2.18361314054868967D-2, 5.68052233293082895D-2,
     *            4.43147180583368137D-1 /

	DATA  D / 7.20316963457154599D-5, 1.86453791840633632D-3,
     *            1.00879584943751004D-2, 2.26603098916041221D-2,
     *            3.28110691727210618D-2, 4.26725101265917523D-2,
     *            5.85927071842652739D-2, 9.37499951163670673D-2,
     *            2.49999999997461423D-1 /

	DATA  FX,FY / 0.9999999999999995D0, 1.0000000000000005D0 /

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C	VL=NATURAL LOG OF 4 ,FX=MAX VALUE OF FM				      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	DATA  VL / 1.38629436111989062D0 /

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	ARE VALUES OUT OF BOUNDS?                                             C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	IF (FM .GE. FY) THEN
		WRITE (6,108)
		RETURN
	ENDIF
108	FORMAT (25H MODULUS GREATER THAN ONE)

	IF (FM .GT. FX) THEN
		WRITE (6,101)
		RETURN
	ENDIF
101	FORMAT (51H MODULUS TOO CLOSE TO 1,F BECOMES INFINITE, E(1)=1.)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	VALUE WITHIN BOUNDS                                                   C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

102	FMP = 1.D0 - FM

	S1 = FMP * A(1)
	S2 = FMP * B(1)
	S3 = FMP * C(1)
	S4 = FMP * D(1)

	DO  103 J = 2, 9
		S1 = (S1+A(J)) * FMP
		S2 = (S2+B(J)) * FMP
		S3 = (S3+C(J)) * FMP
 		S4 = (S4+D(J)) * FMP
103	CONTINUE

	FIN = 1.D0 / FMP
	DF = VL + S1 + DLOG(FIN)*(0.5D0+S2)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                             C
C	THIS IS TO ADD A FUDGE FACTOR FOR THE I/O CONVERSION LOSS	      C
C                                                                             C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	FUDGE = 1.D0 + 3.D-16

	DF = DF * FUDGE
	DE = 1.D0 + S3 + DLOG(FIN)*S4

	RETURN
	END


      SUBROUTINE SAXIF1 (IOPT)
C
C     THIS ROUTINE GENERATES MATRICES WHICH RELATE PRESSURE TO VELOCITY
C     IN A FLUID. IOPT DETERMINES THE ELEMENT TYPE
C
C        IOPT     TYPE
C         0      CAXIF2
C         1      CAXIF3
C         2      CAXIF4
C
      INTEGER         NEST(100),SIL
      DIMENSION       A(9)
      COMMON /SDR2X5/ EST(100),NID,SIL(4),SV(95)
      COMMON /SDR2X6/ HM(9),R(4),Z(4),AM(9),COEF,EN,EL,RBAR,ZBAR,
     1                R1N,R2N,RBN1,DR,DZ,I1,I2,I3,IRET,IJ,IK,KJ
      EQUIVALENCE     (EST(1),NEST(1)),(AM(1),A(1))
C
      DO 10 I = 1,44
   10 SV(I) = 0.0
      NID = NEST(1)
      IF (IOPT-1) 20,50,70
C
C     CAXIF2 ELEMENTS
C
   20 IF (NEST(6) .GE. 1) GO TO 30
      COEF = EST(4)*(EST(13)-EST(9))
      IF (COEF .EQ. 0.0) RETURN
      SV(3) = 1.0/COEF
      SV(4) = -SV(3)
      GO TO 40
   30 IF (NEST(6) .GT. 1) GO TO 40
      COEF  = EST(4)*(EST(8)+EST(12))
      IF (COEF .EQ. 0.0) RETURN
      SV(1) = -1.0/COEF
      SV(2) =  SV(1)
   40 CONTINUE
      EN    = FLOAT(NEST(6))
      RBAR  = (EST(8)+EST(12))/2.0
      ZBAR  = (EST(9)+EST(13))/2.0
      DR    = EST(12) - EST(8)
      DZ    = EST(13) - EST(9)
      R1N   = EST( 8)**NEST(6)
      R2N   = EST(12)**NEST(6)
      RBN1  = RBAR**(NEST(6)-1)
      HM(1) = EST(13)/(R1N*DZ)
      HM(2) =-EST( 9)/(R2N*DZ)
      HM(3) =-1.0/(R1N*DZ)
      HM(4) = 1.0/(R2N*DZ)
      EL    = SQRT(DZ**2 +DR**2)
      COEF  = RBN1/(EST(4)*EL)
      AM(1) = EN*DR*COEF
      AM(2) = (EN*DR*ZBAR + RBAR*DZ)*COEF
      AM(3) = EN*EL*COEF
      AM(4) = EN*ZBAR*EL*COEF
      SV(5) = AM(1)*HM(1) + AM(2)*HM(3)
      SV(6) = AM(1)*HM(2) + AM(2)*HM(4)
      SV(7) = AM(3)*HM(1) + AM(4)*HM(3)
      SV(8) = AM(3)*HM(2) + AM(4)*HM(4)
      SIL(1)= NEST(2)
      SIL(2)= NEST(3)
      RETURN
C
C     CAXIF3 ELEMENT
C
   50 N    = NEST(7)
      EN   = FLOAT(N)
      RHO  = EST(5)
      DO 60 I = 1,3
      SIL(I) = NEST(I+1)
      IR   = 4*(I-1) + 9
      R(I) = EST(IR  )
      Z(I) = EST(IR+1)
   60 CONTINUE
      I1   = 1
      I2   = 2
      I3   = 3
      RBAR = (R(I1)+R(I2)+R(I3))/3.0
      ZBAR = (Z(I1)+Z(I2)+Z(I3))/3.0
      IRET = 4
      GO TO 120
C
C     CAXIF4 ELEMENT
C
   70 N    = NEST(8)
      EN   = FLOAT(N)
      RHO  = EST(6)*4.0
      DO 80 I = 1,4
      SIL(I) = NEST(I+1)
      IR   = 4*(I-1) + 10
      R(I) = EST(IR  )
      Z(I) = EST(IR+1)
   80 CONTINUE
      RBAR = (R(1)+R(2)+R(3)+R(4))/4.0
      ZBAR = (Z(1)+Z(2)+Z(3)+Z(4))/4.0
      I1   = 1
      I2   = 2
      I3   = 3
      IRET = 1
      GO TO  120
   90 I3   = 4
      IRET = 2
      GO TO  120
  100 I2   = 3
      IRET = 3
      GO TO  120
  110 I1   = 2
      IRET = 4
C
C     ACTUAL SUBTRIANGLE CALCULATION
C
  120 IF (RHO .EQ. 0.0) RETURN
      A(1) = 0.0
      A(2) =-1.0/RHO
      A(3) = 0.0
      A(5) = A(2)*EN
      A(4) = A(5)/RBAR
      A(6) = A(4)*ZBAR
      A(7) = 0.0
      A(8) = 0.0
      A(9) = A(2)
C
      COEF = (R(I2)-R(I1))*(Z(I3)-Z(I1)) - (R(I3)-R(I1))*(Z(I2)-Z(I1))
      IF (COEF .EQ. 0.0) RETURN
      HM(1) = (R(I2)*Z(I3)-R(I3)*Z(I2))/COEF
      HM(2) = (R(I3)*Z(I1)-R(I1)*Z(I3))/COEF
      HM(3) = (R(I1)*Z(I2)-R(I2)*Z(I1))/COEF
      HM(4) = (Z(I2)-Z(I3))            /COEF
      HM(5) = (Z(I3)-Z(I1))            /COEF
      HM(6) = (Z(I1)-Z(I2))            /COEF
      HM(7) = (R(I3)-R(I2))            /COEF
      HM(8) = (R(I1)-R(I3))            /COEF
      HM(9) = (R(I2)-R(I1))            /COEF
      DO 150 J = 1,3
      JCOL  = I1
      IF (J .EQ. 2) JCOL = I2
      IF (J .EQ. 3) JCOL = I3
      DO 150 I = 1,3
      IJ = (2+IOPT)*(I-1) + JCOL
      DO 140 K = 1,3
      IK = 3*(I-1) + K
      KJ = 3*(K-1) + J
      SV(IJ) = SV(IJ) + A(IK)*HM(KJ)
  140 CONTINUE
  150 CONTINUE
      GO TO (90,100,110,160 ), IRET
C
C     THE CENTROID  CALCULATIONS ARE COMPLETE.
C
  160 NSTA = 3*(IOPT+2)
      NCOL = IOPT + 2
      IF (IOPT .EQ. 2) RHO = EST(6)
      DO 170 I = 1,NCOL
      J = I + 1
      IF (J .GT.NCOL) J = J - NCOL
      EL = SQRT((R(J)-R(I))**2  + (Z(J)-Z(I))**2)*RHO
C
      IK = NSTA + 2*NCOL*(I-1) + I
      IJ = IK + J - I
      SV(IK) = -1.0/EL
      SV(IJ) = -SV(IK)
      COEF   = -EN/((R(I)+R(J))*RHO)
      IK     = IK + NCOL
      IJ     = IJ + NCOL
      SV(IK) = COEF
      SV(IJ) = COEF
  170 CONTINUE
      RETURN
      END