module dlg

contains
    subroutine dlg_check ( status )
        use netcdf
        integer, intent ( in) :: status

        if(status /= nf90_noerr) then
            print *, trim(nf90_strerror(status))
            stop "Stopped"
        end if

    end subroutine dlg_check

    function dlg_pDeriv ( array, dir, dS ) result ( dArray )
        implicit none

        real, dimension (:,:), allocatable :: dArray
        integer :: nX, nY, i, j
        integer, intent(IN) :: dir
        real, intent(IN) :: array (:,:), dS

        nX  = size ( array, 1 )
        nY  = size ( array, 2 )

        allocate ( dArray ( nX, nY ) )

        if ( dir == 2 ) then

            do i=1,nX
                do j=1,nY

                    if ( j > 1 .AND. j < nY ) &
                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( array(i,j+1) - array(i,j-1) )

                    if ( j > 2 .AND. j < nY-1 ) &
                        dArray(i,j) = 1.0 / ( 12.0 * dS ) * &
                            ( array(i,j-2) - 8.0 * array(i,j-1) &
                                + 8.0 * array(i,j+1) - array(i,j+2) )

                    if ( j == 1 ) &
                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            -3.0 * array(i,j) + 4.0 * array(i,j+1) &
                            - array(i,j+2) )

                    if ( j == 1 ) &
                        dArray(i,j) = 1.0 / ( 12.0 * dS ) * &
                            ( &
                            -25.0 * array(i,j) + 48.0 * array(i,j+1) &
                            -36.0 * array(i,j+2) + 16.0 * array(i,j+3) &
                            -3.0 * array(i,j+4) )

                    if ( j == nY ) &
                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            3.0 * array(i,j) - 4.0 * array(i,j-1) &
                            + array(i,j-2) )

                end do
            end do

        else if ( dir == 1 ) then

            do i=1,nX
                do j=1,nY

                    if ( i > 1 .AND. i < nX ) &
                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( array(i+1,j) - array(i-1,j) )

                    if ( i > 2 .AND. i < nX-1 ) &
                        dArray(i,j) = 1.0 / ( 12.0 * dS ) * &
                            ( &
                            array(i-2,j) - 8.0 * array(i-1,j) &
                            + 8.0 * array(i+1,j) - array(i+2,j) )

                    if ( i == 1 ) &
                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            -3.0 * array(i,j) + 4.0 * array(i+1,j) &
                            - array(i+2,j) )

                    if ( i == 0 ) &
                        dArray(i,j) = 1.0 / ( 12.0 * dS ) * &
                            ( &
                            -25.0 * array(i,j) + 48.0 * array(i+1,j) &
                            -36.0 * array(i+2,j) + 16.0 * array(i+3,j) &
                            -3.0 * array(i+4,j) )

                    if ( i == nX ) &
                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            3.0 * array(i,j) - 4.0 * array(i-1,j) &
                            + array(i-1,j) )

                end do
            end do

        end if

    end function dlg_pDeriv

end module dlg


      FUNCTION piota (x)
      USE stel_kinds
      USE vmec_input, ONLY: ai, ipiota
C-----------------------------------------------
      INTEGER     :: i
      REAL(rprec) :: x, piota
      REAL(rprec), parameter :: pi=3.141592653589793238462643d0
C-----------------------------------------------
      piota = 0

      SELECT CASE(ipiota)
      CASE(0)
       DO i = UBOUND(ai,1), LBOUND(ai,1), -1
        piota = x*piota + ai(i)
       END DO
      CASE(1)
       piota = ai(0)+ai(1)*(2/pi)*atan(ai(2)*x**ai(3)/(1-x)**ai(4))
     >             + ai(5)*(2/pi)*atan(ai(6)*x**ai(7)/(1-x)**ai(8))
      CASE DEFAULT
       stop 'Invalid mass profile selected'
      END SELECT

      END FUNCTION piota


      subroutine mapc2m_torus(blockno,xc,yc,xp,yp,zp,alpha)
      implicit none

      integer blockno
      double precision xc,yc,xp,yp,zp
      double precision alpha, r

      double precision pi

      common /compi/ pi

      r = 1 + alpha*cos(2*pi*yc)

      xp = r*cos(2*pi*xc)
      yp = r*sin(2*pi*xc)
      zp = alpha*sin(2*pi*yc)

      end


PROGRAM WallDemo

IMPLICIT NONE

INTEGER i
REAL    u_pow, u_log, D, z
REAL    A_pow, B_pow,  &
        A_log, B_log,  &
        A_dam

A_pow = 8.3
B_pow = 1.0/7.0

A_log = 1.0/0.41
B_log = 5.2

A_dam = 25.0

do i=0,1000
  z = 1.0 * i

  D = 1.0 - exp( -z / A_dam )

  if(z <= 11.81) then
    u_pow = z
    u_log = z
  else
    u_pow = A_pow * z**B_pow
    u_log = A_log * log(z) + 5.5
  end if

  write(*,'(4F12.6)') z, u_pow, u_log, D

end do

END PROGRAM WallDemo


*DECK HWSSSP
      SUBROUTINE HWSSSP (TS, TF, M, MBDCND, BDTS, BDTF, PS, PF, N,
     +   NBDCND, BDPS, BDPF, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HWSSSP
C***PURPOSE  Solve a finite difference approximation to the Helmholtz
C            equation in spherical coordinates and on the surface of the
C            unit sphere (radius of 1).
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HWSSSP-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine HWSSSP solves a finite difference approximation to the
C     Helmholtz equation in spherical coordinates and on the surface of
C     the unit sphere (radius of 1):
C
C          (1/SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA))
C
C             + (1/SIN(THETA)**2)(d/dPHI)(dU/dPHI)
C
C             + LAMBDA*U = F(THETA,PHI)
C
C     Where THETA is colatitude and PHI is longitude.
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C     TS,TF
C       The range of THETA (colatitude), i.e., TS .LE. THETA .LE. TF.
C       TS must be less than TF.  TS and TF are in radians.  A TS of
C       zero corresponds to the north pole and a TF of PI corresponds to
C       the south pole.
C
C     * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * *
C
C     If TF is equal to PI then it must be computed using the statement
C     TF = PIMACH(DUM). This insures that TF in the users program is
C     equal to PI in this program which permits several tests of the
C     input parameters that otherwise would not be possible.
C
C
C     M
C       The number of panels into which the interval (TS,TF) is
C       subdivided.  Hence, there will be M+1 grid points in the
C       THETA-direction given by THETA(I) = (I-1)DTHETA+TS for
C       I = 1,2,...,M+1, where DTHETA = (TF-TS)/M is the panel width.
C       M must be greater than 5.
C
C     MBDCND
C       Indicates the type of boundary condition at THETA = TS and
C       THETA = TF.
C
C       = 1  If the solution is specified at THETA = TS and THETA = TF.
C       = 2  If the solution is specified at THETA = TS and the
C            derivative of the solution with respect to THETA is
C            specified at THETA = TF (see note 2 below).
C       = 3  If the derivative of the solution with respect to THETA is
C            specified at THETA = TS and THETA = TF (see notes 1,2
C            below).
C       = 4  If the derivative of the solution with respect to THETA is
C            specified at THETA = TS (see note 1 below) and the
C            solution is specified at THETA = TF.
C       = 5  If the solution is unspecified at THETA = TS = 0 and the
C            solution is specified at THETA = TF.
C       = 6  If the solution is unspecified at THETA = TS = 0 and the
C            derivative of the solution with respect to THETA is
C            specified at THETA = TF (see note 2 below).
C       = 7  If the solution is specified at THETA = TS and the
C            solution is unspecified at THETA = TF = PI.
C       = 8  If the derivative of the solution with respect to THETA is
C            specified at THETA = TS (see note 1 below) and the
C            solution is unspecified at THETA = TF = PI.
C       = 9  If the solution is unspecified at THETA = TS = 0 and
C            THETA = TF = PI.
C
C       NOTES:  1.  If TS = 0, do not use MBDCND = 3,4, or 8, but
C                   instead use MBDCND = 5,6, or 9  .
C               2.  If TF = PI, do not use MBDCND = 2,3, or 6, but
C                   instead use MBDCND = 7,8, or 9  .
C
C     BDTS
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to THETA at
C       THETA = TS.  When MBDCND = 3,4, or 8,
C
C            BDTS(J) = (d/dTHETA)U(TS,PHI(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDTS is a dummy variable.
C
C     BDTF
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to THETA at
C       THETA = TF.  When MBDCND = 2,3, or 6,
C
C            BDTF(J) = (d/dTHETA)U(TF,PHI(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDTF is a dummy variable.
C
C     PS,PF
C       The range of PHI (longitude), i.e., PS .LE. PHI .LE. PF.  PS
C       must be less than PF.  PS and PF are in radians.  If PS = 0 and
C       PF = 2*PI, periodic boundary conditions are usually prescribed.
C
C     * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * *
C
C     If PF is equal to 2*PI then it must be computed using the
C     statement PF = 2.*PIMACH(DUM). This insures that PF in the users
C     program is equal to 2*PI in this program which permits tests of
C     the input parameters that otherwise would not be possible.
C
C
C     N
C       The number of panels into which the interval (PS,PF) is
C       subdivided.  Hence, there will be N+1 grid points in the
C       PHI-direction given by PHI(J) = (J-1)DPHI+PS  for
C       J = 1,2,...,N+1, where DPHI = (PF-PS)/N is the panel width.
C       N must be greater than 4.
C
C     NBDCND
C       Indicates the type of boundary condition at PHI = PS and
C       PHI = PF.
C
C       = 0  If the solution is periodic in PHI, i.e.,
C            U(I,J) = U(I,N+J).
C       = 1  If the solution is specified at PHI = PS and PHI = PF
C            (see note below).
C       = 2  If the solution is specified at PHI = PS (see note below)
C            and the derivative of the solution with respect to PHI is
C            specified at PHI = PF.
C       = 3  If the derivative of the solution with respect to PHI is
C            specified at PHI = PS and PHI = PF.
C       = 4  If the derivative of the solution with respect to PHI is
C            specified at PS and the solution is specified at PHI = PF
C            (see note below).
C
C       NOTE:  NBDCND = 1,2, or 4 cannot be used with
C              MBDCND = 5,6,7,8, or 9 (the former indicates that the
C                       solution is specified at a pole, the latter
C                       indicates that the solution is unspecified).
C                       Use instead
C              MBDCND = 1 or 2  .
C
C     BDPS
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to PHI at
C       PHI = PS.  When NBDCND = 3 or 4,
C
C            BDPS(I) = (d/dPHI)U(THETA(I),PS), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDPS is a dummy variable.
C
C     BDPF
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to PHI at
C       PHI = PF.  When NBDCND = 2 or 3,
C
C            BDPF(I) = (d/dPHI)U(THETA(I),PF), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDPF is a dummy variable.
C
C     ELMBDA
C       The constant LAMBDA in the Helmholtz equation.  If
C       LAMBDA .GT. 0, a solution may not exist.  However, HWSSSP will
C       attempt to find a solution.
C
C     F
C       A two-dimensional array that specifies the value of the right
C       side of the Helmholtz equation and boundary values (if any).
C       For I = 2,3,...,M  and  J = 2,3,...,N
C
C            F(I,J) = F(THETA(I),PHI(J)).
C
C       On the boundaries F is defined by
C
C            MBDCND   F(1,J)            F(M+1,J)
C            ------   ------------      ------------
C
C              1      U(TS,PHI(J))      U(TF,PHI(J))
C              2      U(TS,PHI(J))      F(TF,PHI(J))
C              3      F(TS,PHI(J))      F(TF,PHI(J))
C              4      F(TS,PHI(J))      U(TF,PHI(J))
C              5      F(0,PS)           U(TF,PHI(J))   J = 1,2,...,N+1
C              6      F(0,PS)           F(TF,PHI(J))
C              7      U(TS,PHI(J))      F(PI,PS)
C              8      F(TS,PHI(J))      F(PI,PS)
C              9      F(0,PS)           F(PI,PS)
C
C            NBDCND   F(I,1)            F(I,N+1)
C            ------   --------------    --------------
C
C              0      F(THETA(I),PS)    F(THETA(I),PS)
C              1      U(THETA(I),PS)    U(THETA(I),PF)
C              2      U(THETA(I),PS)    F(THETA(I),PF)   I = 1,2,...,M+1
C              3      F(THETA(I),PS)    F(THETA(I),PF)
C              4      F(THETA(I),PS)    U(THETA(I),PF)
C
C       F must be dimensioned at least (M+1)*(N+1).
C
C      *NOTE*
C
C       If the table calls for both the solution U and the right side F
C       at a corner then the solution must be specified.
C
C
C     IDIMF
C       The row (or first) dimension of the array F as it appears in the
C       program calling HWSSSP.  This parameter is used to specify the
C       variable dimension of F.  IDIMF must be at least M+1  .
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space. W may require up to 4*(N+1)+(16+INT(log2(N+1)))(M+1)
C       locations. The actual number of locations used is computed by
C       HWSSSP and is output in location W(1). INT( ) denotes the
C       FORTRAN integer function.
C
C
C     * * * * * * * * * *     On Output     * * * * * * * * * *
C
C     F
C       Contains the solution U(I,J) of the finite difference
C       approximation for the grid point (THETA(I),PHI(J)),
C       I = 1,2,...,M+1,   J = 1,2,...,N+1  .
C
C     PERTRB
C       If one specifies a combination of periodic, derivative or
C       unspecified boundary conditions for a Poisson equation
C       (LAMBDA = 0), a solution may not exist.  PERTRB is a constant,
C       calculated and subtracted from F, which ensures that a solution
C       exists.  HWSSSP then computes this solution, which is a least
C       squares solution to the original approximation.  This solution
C       is not unique and is unnormalized. The value of PERTRB should
C       be small compared to the right side F. Otherwise , a solution
C       is obtained to an essentially different problem. This comparison
C       should always be made to insure that a meaningful solution has
C       been obtained.
C
C     IERROR
C       An error flag that indicates invalid input parameters.  Except
C       for numbers 0 and 8, a solution is not attempted.
C
C       = 0  No error
C       = 1  TS.LT.0 or TF.GT.PI
C       = 2  TS.GE.TF
C       = 3  MBDCND.LT.1 or MBDCND.GT.9
C       = 4  PS.LT.0 or PS.GT.PI+PI
C       = 5  PS.GE.PF
C       = 6  N.LT.5
C       = 7  M.LT.5
C       = 8  NBDCND.LT.0 or NBDCND.GT.4
C       = 9  ELMBDA.GT.0
C       = 10 IDIMF.LT.M+1
C       = 11 NBDCND equals 1,2 or 4 and MBDCND.GE.5
C       = 12 TS.EQ.0 and MBDCND equals 3,4 or 8
C       = 13 TF.EQ.PI and MBDCND equals 2,3 or 6
C       = 14 MBDCND equals 5,6 or 9 and TS.NE.0
C       = 15 MBDCND.GE.7 and TF.NE.PI
C
C       Since this is the only means of indicating a possibly incorrect
C       call to HWSSSP, the user should test IERROR after a call.
C
C     W
C       Contains intermediate values that must not be destroyed if
C       HWSSSP will be called again with INTL = 1. W(1) contains the
C       required length of W .
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDTS(N+1),BDTF(N+1),BDPS(M+1),BDPF(M+1),
C     Arguments      F(IDIMF,N+1),W(see argument list)
C
C     Latest         January 1978
C     Revision
C
C
C     Subprograms    HWSSSP,HWSSS1,GENBUN,POISD2,POISN2,POISP2,COSGEN,ME
C     Required       TRIX,TRI3,PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Paul Swarztrauber
C
C     Language       FORTRAN
C
C     History        Version 1 - September 1973
C                    Version 2 - April     1976
C                    Version 3 - January   1978
C
C     Algorithm      The routine defines the finite difference
C                    equations, incorporates boundary data, and adjusts
C                    the right side of singular systems and then calls
C                    GENBUN to solve the system.
C
C     Space
C     Required       CONTROL DATA 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HWSSSP is roughly proportional
C                    to M*N*log2(N), but also depends on the input
C                    parameters NBDCND and MBDCND.  Some typical values
C                    are listed in the table below.
C                       The solution process employed results in a loss
C                    of no more than three significant digits for N and
C                    M as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine GENBUN which is the routine that
C                    solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32        0         0          31
C                        32        1         1          23
C                        32        3         3          36
C                        64        0         0         128
C                        64        1         1          96
C                        64        3         3         142
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       SIN,COS
C     Resident
C     Routines
C
C     References     P. N. Swarztrauber,'The Direct Solution Of The
C                    Discrete Poisson Equation On The Surface Of a
C                    Sphere, SIAM J. Numer. Anal.,15(1974), pp 212-215
C
C                    Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN
C                    Subprograms for The Solution of Elliptic Equations'
C                    NCAR TN/IA-109, July, 1975, 138 pp.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C               P. N. Swarztrauber, The direct solution of the discrete
C                 Poisson equation on the surface of a sphere, SIAM
C                 Journal on Numerical Analysis 15 (1974), pp. 212-215.
C***ROUTINES CALLED  HWSSS1, PIMACH
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HWSSSP
C
      DIMENSION       F(IDIMF,*) ,BDTS(*)    ,BDTF(*)    ,BDPS(*)    ,
     1                BDPF(*)    ,W(*)
C***FIRST EXECUTABLE STATEMENT  HWSSSP
      PI = PIMACH(DUM)
      TPI = 2.*PI
      IERROR = 0
      IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1
      IF (TS .GE. TF) IERROR = 2
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3
      IF (PS.LT.0. .OR. PF.GT.TPI) IERROR = 4
      IF (PS .GE. PF) IERROR = 5
      IF (N .LT. 5) IERROR = 6
      IF (M .LT. 5) IERROR = 7
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 8
      IF (ELMBDA .GT. 0.) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF ((NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4) .AND.
     1    MBDCND.GE.5) IERROR = 11
      IF (TS.EQ.0. .AND.
     1    (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8)) IERROR = 12
      IF (TF.EQ.PI .AND.
     1    (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 13
      IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND.
     1    TS.NE.0.) IERROR = 14
      IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 15
      IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN
      CALL HWSSS1 (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF,
     1             ELMBDA,F,IDIMF,PERTRB,W,W(M+2),W(2*M+3),W(3*M+4),
     2             W(4*M+5),W(5*M+6),W(6*M+7))
      W(1) = W(6*M+7)+6*(M+1)
      RETURN
      END


C subroutine to return 2 normally distributed numbers, GAUSS1 and GAUSS2
       SUBROUTINE DIST(GAUSS1,GAUSS2)
       INTEGER SEED
       DATA SEED/39249187/
       DATA PI/3.1415926/

       TWOU=-2.*LOG(1.-RAN(SEED))
       RADIUS=SQRT(TWOU)
       THETA=2*PI*RAN(SEED)
       GAUSS1=RADIUS*COS(THETA)
       GAUSS2=RADIUS*SIN(THETA)

       RETURN
       END


program test_complex_matrix
use definitions
implicit none

complex*16, allocatable :: entries(:,:)
integer*4:: ii, jj, NN
real*8 :: re, im
type(complex_matrix) :: input_mat, adj_mat

write(*,*) "Enter N"
read(*,*) NN

allocate(entries(1:NN,1:NN))

do ii = 1, NN
    do jj = 1, NN
        write(*,*) "type in entry ", ii, jj
        read(*,*) re, im
        entries(ii,jj) = complex(re,im)
    end do
end do

input_mat = enter_mat(entries)

write(*,*) "Input matrix"
do ii = 1, NN
    write(*,'(*(F0.8,SP,F0.8,"i",", "))') input_mat%entries(ii,:)
end do

adj_mat = mat_adj(input_mat%entries)

write(*,*) "Adjoint matrix"
do ii = 1, NN
    write(*,'(*(F0.8,SP,F0.8,"i",", "))') adj_mat%entries(ii,:)
end do

write(*,fmt = '(A)',advance='no') "Matrix trace: "
write(*,'(F0.8,SP,F0.8,"i")') input_mat%trace
write(*,*) "Matrix dimensions: ", input_mat%dimensions

call write_mat(input_mat, "matrix.dat")

end program test_complex_matrix


program TestSHRotate
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will read in a spherical harmonic file, then rotate
!	the body by the three euler angles.
!
!	Written by Mark Wieczorek (August 2003)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS

	implicit none
	integer, parameter ::	degmax = 100, max2dgrid = 181
	real*8 ::		cilm1(2, degmax+1, degmax+1), cilm2(2, degmax+1, degmax+1), &
				dj(degmax+1, degmax+1, degmax+1), header(8), &
				x(3), pi, interval, grid(max2dgrid, 2*max2dgrid), &
				alpha, beta, gamma
	character*80 ::		outsh, outgrid, infile
	integer ::		lmax, nlat, nlong, i, j, l, m, bodycoord

	pi = acos(-1.0d0)

	infile = "../ExampleDataFiles/Mars2000.shape"
	print*, "Input file = ", infile
	call SHRead(infile, cilm1, lmax, header=header(1:8))
	print*, "Lmax of input file = ", lmax
	print*, "Maximum degree to be used with rotations > "
	read(*,*) lmax

	print*, "Input Euler Angles"
	print*, "Alpha (deg) = "
	read(*,*) alpha
	print*, "Beta (deg) = "
	read(*,*) beta
	print*, "Gamma (deg) = "
	read(*,*) gamma

	print*, "Do these correspond to "
	print*, "(1) Rotation of the coordinate system without rotation of the physical body, or"
	print*, "(2) Rotation of the physical body without rotation of the coordinate system."
	read(*,*) bodycoord

	if (bodycoord ==1) then
		x(1) = alpha ; x(2) = beta ; x(3) = gamma
	elseif (bodycoord ==2) then
		x(1) = -gamma ; x(2) = -beta ; x(3) = -alpha
	else
		print*, "Must enter 1 or 2"
		stop
	endif

	x = x * pi/180.0d0

	print*, "Output file name of rotated spherical harmonics > "
	read(*,*) outsh

	open(12,file=outsh)

	print*, "Grid spacing for output grid (deg) > "
	read(*,*) interval
	print*, "File name of gridded rotated field > "
	read(*,*) outgrid

	open(13, file=outgrid)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Rotate coefficients to a specific coordinate
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Computing rotation matrix"
	call djpi2(dj, lmax)	! Create rotation matrix used in the rotation routine.

	print*, "Rotating spherical harmonics"
	call SHRotateRealCoef(cilm2, cilm1, lmax, x, dj)

	print*, "Making 2D grid"
	call MakeGrid2d(grid, cilm2, lmax, interval, nlat, nlong)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Output data to disk
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do l=0, lmax
		do m=0, l
			write(12,*) l, m, cilm2(1,l+1,m+1), cilm2(2,l+1,m+1)
		enddo
	enddo

	close(12)

	write(13,*) nlat, nlong

	do i=1, nlat
		do j=1, nlong
			write(13,*) grid(i,j)
		enddo
	enddo

	close(13)

end program TestSHRotate


program test_horner

  implicit none

  write (*, '(f5.1)') horner ((/-19.0, 7.0, -4.0, 6.0/), 3.0)

contains

  function horner (coeffs, x) result (res)

    implicit none
    real, dimension (:), intent (in) :: coeffs
    real, intent (in) :: x
    real :: res
    integer :: i

    res = 0.0
    do i = size (coeffs), 1, -1
      res = res * x + coeffs (i)
    end do

  end function horner

end program test_horner


implicit none
double precision :: g, x, xold
integer :: counter

counter = 0
x = 4.0
xold = 123.3      ! nonsense value

do while (xold /= x)
  xold = x
  x = g(x)
  counter = counter + 1
  print*, counter, x, abs(x - xold)
end do
stop
end

real function g(x)
  implicit none
  real :: x

  g = 2.0*x/3.0 + 10.0/(3.0*x)

  return
end

4670 Numerical Analysis/Class Examples/fixeddp.f90


MODULE procs
CONTAINS
   REAL FUNCTION calc ( first, second, third )
   IMPLICIT NONE
   REAL, INTENT(IN) :: first, second, third
   calc = ( first - second ) / third
   END FUNCTION calc
END MODULE procs

PROGRAM test_keywords

USE procs
IMPLICIT NONE

WRITE (*,*) calc ( 3., 1., 2. )
WRITE (*,*) calc ( first=3., second=1., third=2. )
WRITE (*,*) calc ( second=1., third=2., first=3. )
WRITE (*,*) calc ( 3., third=2., second=1.)

END PROGRAM test_keywords


program select_test
    use :: iso_fortran_env, only : error_unit
    implicit none
    integer :: a, b
    character(len=40) :: buffer
    character(len=1) :: operator

    if (command_argument_count() /= 3) then
        write (unit=error_unit, fmt='(A)') &
                '# error: 3 arguments expected'
        stop 1
    end if

    call get_command_argument(1, buffer)
    read (buffer, '(I3)') a
    call get_command_argument(2, buffer)
    operator = trim(buffer)
    call get_command_argument(3, buffer)
    read (buffer, '(I3)') b

    select case (operator)
        case ('+')
            print "(I0, ' ', A, ' ', I0, ' = ', I0)", a, operator, b, a + b
        case ('*')
            print "(I0, ' ', A, ' ', I0, ' = ', I0)", a, operator, b, a * b
        case default
            write (unit=error_unit, fmt='(3A)')  &
                    '# error: unknown operand ''', operator, ''''
            stop 2
    end select

end program select_test


      subroutine SSBASI(K, N, T, X1, X2, J1, J2, BASI)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SSBASI Krogh  Changes to use M77CON
c>> 1993-01-12 SSBASI CLL  Using SSBASD in place of _SBAS.
c>> 1992-11-12 C. L. Lawson, JPL Made J1 & J2 inout.  Were out.
c>> 1992-11-02 C. L. Lawson, JPL
c>> 1988-04-01 C. L. Lawson, JPL
C
C   This subroutine computes the integral over [X1,X2] of each of the N
c   members of a Kth order family of B-spline basis functions defined
c   over the knot set T().  The values of these integrals will be
c   returned in BASI(j), j = 1, ..., N.  The indices J1 and J2 will be
c   set to indicate the subset of these that might be nonzero.  Thus
c   BASI(j), j = J1, ..., J2 might be nonzero, whereas the other
c   elements of BASI() will be zero.
c   Orders K as high as 20 are permitted.
c   Permits X1 .le. X2 or X1 gt. X2.  In the former case all returned
c   values will be .ge. 0, while in the latter case all will be .le. 0.
C      The "proper interpolation interval" is from T(K) to T(N+1).
c      For most reliable results, X1 and X2 should lie in this
c      interval, however this subr will give a result even if this
c      is not the case by use of extrapolation.
C      This subr applies a 2, 6, or 10 point Gauss formula on
c      subintervals of [X1,X2] which are formed by the included
c      (distinct) knots.
c     ------------------------------------------------------------------
C                           ARGUMENTS
c
C  K      [in] ORDER OF B-SPLINE, 2 .le. K .le. 20
c               Note that the polynomial degree of the segments of
c               the spline are one less than the order.
C  N      [in] LENGTH OF COEFFICIENT ARRAY
C  T()    [in] KNOT ARRAY OF LENGTH N+K
C  X1,X2  [in] END POINTS OF QUADRATURE INTERVAL.
C               Permit X1 .le. X2 or X1 .gt. X2.
c
c  J1, J2  [inout integers] On entry must contain integer values.
c     Will be passed to SSFIND for lookup.  Any integer values
c     are ok but previous returned values may aid efficiency.
c     On return will satisfy 1 .le. J1 .le. J2 .le. N.
c     Indicates that only the output values BASI(j), j = J1,...,J2
c     might be nonzero.
C  BASI()  [out, floating pt]  Array in which the N integrals will be
c           stored.
C
C     ERROR CONDITIONS: None
c     ------------------------------------------------------------------
C     Based on spline quadrature subroutines called BQUAD or BSQUAD
c     written by D. E. Amos,  Sandia, June, 1979.  Documented in
c     SAND79-1825.
c     Uses the (T, BCOEF, N, K) representation of a B-spline as
c     presented in A PRACTICAL GUIDE TO SPLINES by Carl De Boor,
c     Springer-Verlag, 1978.
c     Current version by C. L. Lawson, JPL, March 1988.
c     ------------------------------------------------------------------
C--S replaces "?": ?SBASI, ?SFIND, ?SBASD
c     ------------------------------------------------------------------
c     GPTS(), GWTS()  Index 1 selects 2-point Gaussian formula.
c                     Indices 2-4 select 6-point Gaussian formula.
c                     Indices 5-9 select 10-point Gaussian formula.
c     ------------------------------------------------------------------
      integer KMAX
      parameter(KMAX = 20)
      integer IK, IL1, IL2, J, J1, J2, JF, K, LEFT, M, MF, MODE, N
      real             A, AA, B, BASI(N), BB
      real             BMA, BPA, BVAL1(KMAX), BVAL2(KMAX), C1
      real             FAC, GPTS(9), GWTS(9), HALF
      real             T(N+K), TA, TB, X1, X2, ZERO
      parameter(HALF = 0.50E0, ZERO = 0.0E0)
C
*     DATA GPTS            / 5.77350269189626E-01, 2.38619186083197E-01,
*    1 6.61209386466265E-01, 9.32469514203152E-01, 1.48874338981631E-01,
*    2 4.33395394129247E-01, 6.79409568299024E-01, 8.65063366688985E-01,
*    3 9.73906528517172E-01/
C
*     DATA GWTS            / 1.00000000000000E+00, 4.67913934572691E-01,
*    1 3.60761573048139E-01, 1.71324492379170E-01, 2.95524224714753E-01,
*    2 2.69266719309996E-01, 2.19086362515982E-01, 1.49451349150581E-01,
*    3 6.66713443086880E-02/
c
c     Gaussian quadrature abcissae and weights to 40 decimal digits.
      data GPTS / 0.5773502691896257645091487805019574556476e0,
     2            0.2386191860831969086305017216807119354186e0,
     3            0.6612093864662645136613995950199053470064e0,
     4            0.9324695142031520278123015544939946091348e0,
     5            0.1488743389816312108848260011297199846176e0,
     6            0.4333953941292471907992659431657841622001e0,
     7            0.6794095682990244062343273651148735757693e0,
     8            0.8650633666889845107320966884234930485275e0,
     9            0.9739065285171717200779640120844520534283e0/
c
      data GWTS / 1.0e0,
     2            0.4679139345726910473898703439895509948120e0,
     3            0.3607615730481386075698335138377161116612e0,
     4            0.1713244923791703450402961421727328935273e0,
     5            0.2955242247147528701738929946513383294210e0,
     6            0.2692667193099963550912269215694693528586e0,
     7            0.2190863625159820439955349342281631924634e0,
     8            0.1494513491505805931457763396576973323908e0,
     9            0.06667134430868813759356880989333179285686e0/
c     ------------------------------------------------------------------
      if(K .gt. KMAX) then
         call IERM1('SSBASI',1,2,'Require KORDER .le. KMAX.',
     *   'KORDER',K,',')
         call IERV1('KMAX',KMAX,'.')
         return
      endif
C
      AA= min(X1,X2)
      BB= max(X1,X2)
C
      IL1 = J1+K-1
      IL2 = J2
      call SSFIND(T,K, N+1,AA,IL1,MODE)
      call SSFIND(T,K, N+1,BB,IL2,MODE)
c
      if(BB .eq. T(IL2) .and. IL2 .gt. K .and. IL2 .gt. IL1)
     *    IL2 = IL2 -1
      J1 = IL1+1-K
      J2 = IL2
      do 15 J=1,N
         BASI(J) = ZERO
   15 continue
      if(AA .eq. BB) return
c
C                  Selection of Gaussian quadrature formula:
c                  KORDER .le. 4          =>   2 point formula
c                  5 .le. KORDER .le. 12  =>  6 point formula
c                  KORDER .ge. 13         =>  10 point formula
c
      if(K .le. 4) then
         JF=0
         MF=1
      elseif(K .le. 12) then
         JF=1
         MF=3
      else
         JF=4
         MF=5
      endif
c
      do 40 LEFT=IL1,IL2
         TA=T(LEFT)
         TB=T(LEFT+1)
         if(TA .ne. TB) then
            if(LEFT .eq. K) then
               A = AA
            else
               A= max(AA,TA)
            endif
            if(LEFT .eq. N) then
               B = BB
            else
               B= min(BB,TB)
            endif
            BMA= HALF *(B-A)
            BPA= HALF *(B+A)
            DO 30 M=1,MF
               C1=BMA*GPTS(JF+M)
               FAC = GWTS(JF+M)*BMA
               call SSBASD(K, LEFT, T, BPA+C1, 0, BVAL1)
               call SSBASD(K, LEFT, T, BPA-C1, 0, BVAL2)
               J = LEFT-K
               do 20 IK = 1,K
                  J = J+1
                  BASI(J) = BASI(J)+FAC*(BVAL1(IK)+BVAL2(IK))
   20          continue
   30       continue
         endif
   40 continue
      if(X1 .gt. X2) then
         do 50 J=J1, J2
            BASI(J) = -BASI(J)
   50    continue
      endif
      return
      end


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlsep2                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.51
!  Written by Gordon A. Fenton, Sept. 1989
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points in a 2-D process having
!           a separable Markovian covariance function
!
!  This function returns the covariance between two points, separated by lag
!  vector {X,Y}, in a 2-D random field having separable Markovian covariance
!  function. The covariance function for this field is given by
!
!      B(X,Y) = var * exp{ -(2|X|/dthx) } * exp{ - (2|Y|/dthy) }
!
!  where var is the point variance, and dthx and dthy are the scales of
!  fluctuation in the x- and y-directions, respectively.
!  NOTE: this function is NOT isotropic even if dthx = dthy.
!  The parameters var, dthx, and dthy are brought in via the
!  common block /dparam/.
!
!  If var < 0, then this function returns the variance of a local average
!  of the process, |var|*V(X,Y), averaged over the domain X x Y.
!  For a separable covariance function, the variance function is also
!  separable and can be written as the product of two 1-D variance
!  functions corresponding to the exponential correlation function
!
!         V(X,Y) = V(X)*V(Y)
!
!  where individual functions are based on the 1-D analytical model
!
!                     dthx^2
!         V(X) = 2 * ------- [(2|X|/dthx) + exp{-2|X|/dthx} - 1]
!                     4*X^2
!
!  The variance of the local average is then given by var*V(X,Y). See page
!  186 of "Random Fields" by E. Vanmarcke and G.A. Fenton's thesis for more
!  details.
!
!  The arguments to this routine, X and Y, are just the components of the
!  lag vector separating the two points (or the size of the averaging
!  domain, if var < 0).
!
!  The data value `eund' is designed to avoid underflow errors arising from
!  exp(-a) for a > eund. We quite happily accept a zero in this case.
!
!  REVISION HISTORY:
!  1.2	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (May 1/00)
!  1.3	eliminated lvarfn -- now return covariances only if var < 0 (Mar 27/01)
!  1.4	properly handled sign on var for covariances (Apr 5/01)
!  1.5	reversed default - now return covariances if var > 0. (Apr 11/01)
!  1.51	revised above documentation to reflect revision 1.5 (May 9/01)
!---------------------------------------------------------------------------
      real*8 function dlsep2( X, Y )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, dpb, dthx, dthy, dthz
      data zero/0.d0/, half/0.5d0/, one/1.d0/, two/2.d0/, four/4.d0/
      data eund/300.d0/
      exp(s) = dexp(s)
      abs(s) = dabs(s)

      if( var .lt. zero ) then			! return variance function
!							x-direction var func
         a = two*abs(X)/dthx
         if( X .eq. zero ) then
            dsepa = half
         elseif( a .lt. eund ) then
            dsepa = (a + exp(-a) - one)/(a*a)
         else
            dsepa = (a - one)/(a*a)
         endif
!							y-direction var func
         b = two*abs(Y)/dthy
         if( Y .eq. zero ) then
            dsepb = half
         elseif( b .lt. eund ) then
            dsepb = (b + exp(-b) - one)/(b*b)
         else
            dsepb = (b - one)/(b*b)
         endif

         dlsep2 = -four*var*dsepa*dsepb
      else					! var > 0, return covariance
         if( dthx .eq. zero ) then
            if( X .eq. zero ) then
               a = zero
            else
               dlsep2 = zero
               return
            endif
         else
            a = two*abs(X)/dthx
         endif
         if( dthy .eq. zero ) then
            if( Y .eq. zero ) then
               b = zero
            else
               dlsep2 = zero
               return
            endif
         else
            b = two*abs(Y)/dthy
         endif
         ab = a + b
         if( ab .ge. eund ) then
            dlsep2 = zero
         else
            dlsep2 = var*exp(-ab)
         endif
      endif

      return
      end


!================================================!
! calculate the coeffs. of the quartic line      !
! search equation from three energy points and   !
! two gradient points                            !
!================================================!
subroutine omm_fit_quartic(x,y,g,c)
  use omm_params, only : dp

  implicit none

  !**** INPUT ***********************************!

  real(dp), intent(in) :: x(1:3) ! three x-points {x_i}
  real(dp), intent(in) :: y(1:3) ! y(x_i) at the three points
  real(dp), intent(in) :: g(1:2) ! (dy/dx)|x_i at the first two points

  !**** OUTPUT **********************************!

  real(dp), intent(out) :: c(0:4) ! coeffs. of the quartic equation

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

  ! the following expressions for the coeffs. were produced automatically using Maple 12
  c(4)=(x(3)**3*x(2)*g(1)-3*x(1)*x(2)**2*y(1)+3*y(3)*x(1)*x(2)**2+x(1)**2*x(2)**2*g(1)+x(3)*x(2)**3*&
       g(1)+2*x(1)**2*x(3)**2*g(2)-3*x(2)*x(3)**2*y(1)+3*y(2)*x(1)**2*x(2)-x(3)**3*x(1)*g(1)+x(3)**3*&
       x(2)*g(2)-x(2)**2*x(3)**2*g(2)-x(1)**2*x(2)**2*g(2)-2*x(2)**2*x(3)**2*g(1)+3*x(2)*x(3)**2*&
       y(2)+x(1)**2*x(3)**2*g(1)-x(1)*x(2)**3*g(1)-3*x(1)*x(3)**2*y(1)-x(3)**3*x(1)*g(2)+3*x(1)*&
       x(3)**2*y(2)+x(2)*g(2)*x(1)**3-3*y(3)*x(1)**2*x(2)-x(3)*g(2)*x(1)**3+6*x(1)*x(3)*x(2)*y(1)+2*&
       x(1)*x(3)*x(2)**2*g(2)+x(1)*x(3)**2*x(2)*g(1)-x(1)*x(3)**2*x(2)*g(2)-2*x(1)**2*x(3)*x(2)*g(1)-&
       x(1)**2*x(3)*x(2)*g(2)+x(1)*x(3)*x(2)**2*g(1)-6*x(1)*x(3)*x(2)*y(2)+2*x(3)**3*y(1)-2*x(3)**3*&
       y(2)+x(2)**3*y(1)+y(3)*x(1)**3-y(3)*x(2)**3-y(2)*x(1)**3)/(-2*x(3)**3*x(1)**4+x(3)**4*x(1)**3-&
       x(1)**2*x(2)**5-x(3)**4*x(2)**3-x(2)**5*x(3)**2-3*x(1)**4*x(2)**3+2*x(3)**3*x(2)**4+x(1)**5*&
       x(3)**2+3*x(2)**4*x(1)**3+4*x(3)**3*x(2)*x(1)**3-4*x(3)**3*x(1)*x(2)**3+2*x(1)*x(3)*x(2)**5+4*&
       x(1)**4*x(3)*x(2)**2+8*x(1)**2*x(3)**2*x(2)**3+x(1)**4*x(3)**2*x(2)-x(1)*x(3)**2*x(2)**4-2*&
       x(1)**5*x(3)*x(2)-4*x(1)**2*x(3)*x(2)**4+x(1)**5*x(2)**2-8*x(2)**2*x(3)**2*x(1)**3-3*x(3)**4*&
       x(1)**2*x(2)+3*x(3)**4*x(1)*x(2)**2)

  c(3)=-(-x(1)*g(1)+2*c(4)*x(1)**4-x(1)*g(2)+4*x(1)*c(4)*x(2)**3+x(2)*g(1)-4*x(2)*c(4)*x(1)**3+x(2)*&
       g(2)-2*c(4)*x(2)**4+2*y(1)-2*y(2))/(x(1)**3+3*x(1)*x(2)**2-3*x(2)*x(1)**2-x(2)**3)

  c(2)=-(-y(2)+c(4)*x(2)**4+c(3)*x(2)**3+x(2)*g(1)-4*x(2)*c(4)*x(1)**3-3*x(2)*c(3)*x(1)**2+y(1)+3*&
       c(4)*x(1)**4+2*c(3)*x(1)**3-x(1)*g(1))/(x(1)**2-2*x(1)*x(2)+x(2)**2)

  c(1)=g(1)-4*c(4)*x(1)**3-3*c(3)*x(1)**2-2*c(2)*x(1)

  c(0)=y(1)-c(4)*x(1)**4-c(3)*x(1)**3-c(2)*x(1)**2-c(1)*x(1)

  !if (Node==0) print*, 'f(x)=',c(4),'*x**4+',c(3),'*x**3+',c(2),'*x**2+',c(1),'*x+',c(0)

end subroutine omm_fit_quartic

!================================================!
! find the minimum for the quartic line search   !
! equation                                       !
!================================================!
subroutine omm_solve_quartic(c,x_min,fail)
  use omm_params, only : dp, Pi

  implicit none

  !**** INPUT ***********************************!

  real(dp), intent(in) :: c(0:4) ! coeffs. of the quartic equation

  !**** OUTPUT **********************************!

  logical, intent(out) :: fail ! did we fail to find a minimum?

  real(dp), intent(out) :: x_min ! position of minimum

  !**** LOCAL ***********************************!

  integer :: x_order(1:3)

  real(dp) :: t(1:3)
  real(dp) :: z(1:3)
  real(dp) :: a
  real(dp) :: b
  real(dp) :: d
  real(dp) :: Q
  real(dp) :: R
  real(dp) :: theta
  real(dp) :: S
  real(dp) :: U

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

  fail=.false.

  ! in order to find the minimum of the quartic equation, we have to solve a cubic equation; the
  ! following method is taken from Numerical Recipes
  a=3.0_dp*c(3)/(4.0_dp*c(4))
  b=2.0_dp*c(2)/(4.0_dp*c(4))
  if ((abs(b)>=1.0d11) .or. (abs(c(4))<=1.0d-11)) then
    x_min=-0.5_dp*c(1)/c(2)
    return
  end if
  d=c(1)/(4.0_dp*c(4))

  Q=(a**2-3.0_dp*b)/9.0_dp
  R=(2.0_dp*a**3-9.0_dp*a*b+27.0_dp*d)/54.0_dp
  if (R**2<Q**3) then
    theta=acos(R/sqrt(Q**3))
    t(1)=-2.0_dp*sqrt(Q)*cos(theta/3.0_dp)-a/3.0_dp
    t(2)=-2.0_dp*sqrt(Q)*cos((theta+2.0_dp*Pi)/3.0_dp)-a/3.0_dp
    t(3)=-2.0_dp*sqrt(Q)*cos((theta-2.0_dp*Pi)/3.0_dp)-a/3.0_dp
    z(1:3)=c(4)*t(1:3)**4+c(3)*t(1:3)**3+c(2)*t(1:3)**2+c(1)*t(1:3)+c(0)
    if (c(4)>0.0_dp) then
      if (all(z(1)>=z(2:3))) then
        x_order(1:3)=(/1,2,3/)
      else if (z(2)>z(3)) then
        x_order(1:3)=(/2,3,1/)
      else
        x_order(1:3)=(/3,1,2/)
      end if
      if ((0.0_dp<=t(x_order(1))) .and. (t(x_order(2))<=t(x_order(1)))) then
        x_min=t(x_order(2))
      else
        x_min=t(x_order(3))
      end if
    else
      if (all(z(1)<=z(2:3))) then
        x_min=t(1)
      else if (z(2)<z(3)) then
        x_min=t(2)
      else
        x_min=t(3)
      end if
    end if
  else
    S=-sign(1.0_dp,R)*(abs(R)+sqrt(R**2-Q**3))**(1.0_dp/3.0_dp)
    if (S==0.0_dp) then
      U=0.0_dp
    else
      U=Q/S
    end if
    x_min=(S+U)-(a/3.0_dp)
    if (c(4)<0.0_dp) fail=.true.
  end if

end subroutine omm_solve_quartic


!!!! Derived from interp_2p5min.f from http://earth-info.nga.mil/GandG/wgs84/gravitymod/egm2008/interp_2p5min.f
!!!! Modified for ISCE by Piyush Agram

      FUNCTION IFRAC(R)
        implicit none
        double precision :: R
        integer :: IFRAC

        IFRAC=R
        IF (R.GE.0) RETURN
        IF (R.EQ.IFRAC) RETURN
        IFRAC = IFRAC - 1
       END FUNCTION IFRAC

      SUBROUTINE INITSPLINE(Y, N, R, Q)

          implicit none
          integer :: N,K
          double precision, dimension(N) :: Y,R,Q
          double precision :: P
          Q(1) = 0.0
          R(1) = 0.0
          DO  K = 2, N-1
            P = Q(K-1)/2+2
            Q(K) = -0.5/P
            R(K) = (3*(Y(K+1)-2*Y(K)+Y(K-1)) - R(K-1)/2)/P
          ENDDO

          R(N) = 0.0
          DO K = N-1, 2, -1
            R(K) = Q(K)*R(K+1)+R(K)
          END DO
      END SUBROUTINE INITSPLINE

      FUNCTION SPLINE(X, Y, N, R)

          implicit none
          integer :: N,J
          integer :: IFRAC
          double precision, dimension(N) :: Y,R
          double precision :: X, XX
          double precision :: SPLINE

          IF (X.LT.1) THEN
            SPLINE = Y(1) + (X-1)*(Y(2)-Y(1)-R(2)/6)
          ELSEIF (X.GT.N) THEN
            SPLINE = Y(N) + (X-N)*(Y(N)-Y(N-1)+R(N-1)/6)
          ELSE
            J = IFRAC(X)
            XX = X - J
            SPLINE = Y(J) + XX * ((Y(J+1)-Y(J)-R(J)/3-R(J+1)/6) + XX * (R(J)/2 + XX * (R(J+1)-R(J))/6))
          ENDIF
      END FUNCTION SPLINE

      function interp2DSpline(order,nx,ny,z,x,y)

        implicit none

        integer :: order
        integer :: nx,ny
        real*4, dimension(ny,nx) :: z
        double precision :: x, y
        real*4:: interp2DSpline
        double precision :: SPLINE

        integer :: MINORDER, MAXORDER
        parameter(MINORDER=3, MAXORDER=20)
        double precision, dimension(MAXORDER) :: A, R, Q, HC
        integer :: I,J,I0, J0, II, JJ,INDI,INDJ
        double precision :: temp,inx,iny

        LOGICAL LODD

        if ((order.lt.MINORDER).or.(order.gt.MAXORDER)) then
          print *, 'Spline order must be between ', MINORDER, ' and ', MAXORDER
          stop
        endif

        LODD=(order/2)*2.NE.order
        IF(LODD) THEN
            I0=y-0.5
            J0=x-0.5
        ELSE
            I0=y
            J0=x
        ENDIF

        I0=I0-order/2+1
        J0=J0-order/2+1
        II=I0+order-1
        JJ=J0+order-1

!!      print *, 'Y: ', y, I0, II, Z(100,100)
!!      print *, 'X: ', x, J0, JJ, Z(200,200)

      DO I=1,order
          INDI = min( max(I0+I,1), ny)
          DO J=1,order
            INDJ = min( max(J0+J,1), nx)
!!            print *, 'IND: ', INDI, INDJ, Z(1200,1200), Z(INDI,INDJ)
            A(J)=Z(INDI,INDJ)
          ENDDO

!!          print *, 'I: ', i, x-J0+1.
          CALL INITSPLINE(A,order,R,Q)
          HC(I) = SPLINE(x-J0,A,order,R)
      ENDDO

!!      print *, 'J: ', j, y-I0+1.
      CALL INITSPLINE(HC,order,R,Q)
      temp = SPLINE(y-I0,HC,order,R)
      interp2DSpline = sngl(temp)
      RETURN
      END FUNCTION interp2Dspline


      SUBROUTINE COSTI (N,WSAVE)
      IMPLICIT NONE
      INTEGER :: N, K, KC, NM1, NP1, NS2
      REAL :: WSAVE(*), DT, FK, PI
      DATA PI /3.14159265358979/
      IF (N .LE. 3) RETURN
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      DT = PI/FLOAT(NM1)
      FK = 0.
      DO 101 K=2,NS2
         KC = NP1-K
         FK = FK+1.
         WSAVE(K) = 2.*SIN(FK*DT)
         WSAVE(KC) = 2.*COS(FK*DT)
  101 CONTINUE
      CALL RFFTI (NM1,WSAVE(N+1))
      RETURN
      END


program mandel

  use imageout

  implicit none

  double precision :: xmax, xmin, ymax, ymin, rmax, x0, y0, x, y, xt
  integer :: xres, yres, max_iter, iter, px, py
  integer, dimension(:,:), allocatable :: pixels

  xmax = 2.0
  xmin = -2.0

  ymax = 2.0
  ymin = -2.0

  xres = 128
  yres = 128

  max_iter = 256

  rmax = 2.0

  allocate(pixels(xres,yres))

  do px = 1, xres
    x0 = ((dble(px)/dble(xres)) * dble(xmax - xmin)) + xmin

    do py = 1, yres
      y0 = ((dble(py)/dble(yres)) * dble(ymax - ymin)) + ymin
      iter = 0
      x = 0.0
      y = 0.0

      do while (((x*x + y*y) .lt. (rmax * rmax)) .and. (iter .lt. max_iter))
        xt = (x*x) - (y*y) + x0
        y = 2.0 * x * y + y0
        x = xt
        iter = iter + 1
      end do
      pixels(px,py) = max_iter - iter
    end do

  end do

  open(unit=24, file="mandel.pbm")
  call writepbm(pixels, xres, yres, 1, 24)
  close(24)
  deallocate(pixels)
end program mandel


	subroutine xex2(ni,nj,psi,evx,evy)
	implicit none
	integer*4 i,j,ni,nj
	real*8 :: xmin,ymin,xmax,ymax,dx,dy,x,y,wx,wy
c	integer*4,parameter :: mn=256
	complex*16 :: psi(ni,nj)
	real*8,intent(out) ::evx,evy
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
	common /para1/ wx,wy
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c	xav=0d0
c	yav=0d0
c        xx=0d0
c        yy=0d0
c        prob=0d0
	evx=0d0
	evy=0d0

c 	calculate the average value of x,y
	do j=1,nj
	y=ymin+(j-1)*dy
	do i=1,ni
	x=xmin+(i-1)*dx
c	xav=xav+abs(psi(i,j))**2*dx*dy*x
c        xx=xx+abs(psi(i,j))**2*dx*dy*x**2
c	yav=yav+abs(psi(i,j))**2*dx*dy*y
c        yy=yy+abs(psi(i,j))**2*dx*dy*y**2
	evx=evx+abs(psi(i,j))**2*dx*dy*(wx**2)*(x**2)/2d0
	evy=evy+abs(psi(i,j))**2*dx*dy*(wy**2)*(y**2)/2d0
c        if ( x.lt.-5d0) then
c        prob=abs(psi(i,j))**2*dx*dy+prob
c        endif
	enddo
	enddo

	end subroutine


      SUBROUTINE cisi(x,ci,si)
      INTEGER MAXIT
      REAL ci,si,x,EPS,EULER,PIBY2,FPMIN,TMIN
      PARAMETER (EPS=6.e-8,EULER=.57721566,MAXIT=100,PIBY2=1.5707963,
     *FPMIN=1.e-30,TMIN=2.)
      INTEGER i,k
      REAL a,err,fact,sign,sum,sumc,sums,t,term,absc
      COMPLEX h,b,c,d,del
      LOGICAL odd
      absc(h)=abs(real(h))+abs(aimag(h))
      t=abs(x)
      if(t.eq.0.)then
        si=0.
        ci=-1./FPMIN
        return
      endif
      if(t.gt.TMIN)then
        b=cmplx(1.,t)
        c=1./FPMIN
        d=1./b
        h=d
        do 11 i=2,MAXIT
          a=-(i-1)**2
          b=b+2.
          d=1./(a*d+b)
          c=b+a/c
          del=c*d
          h=h*del
          if(absc(del-1.).lt.EPS)goto 1
11      continue
        pause 'cf failed in cisi'
1       continue
        h=cmplx(cos(t),-sin(t))*h
        ci=-real(h)
        si=PIBY2+aimag(h)
      else
        if(t.lt.sqrt(FPMIN))then
          sumc=0.
          sums=t
        else
          sum=0.
          sums=0.
          sumc=0.
          sign=1.
          fact=1.
          odd=.true.
          do 12 k=1,MAXIT
            fact=fact*t/k
            term=fact/k
            sum=sum+sign*term
            err=term/abs(sum)
            if(odd)then
              sign=-sign
              sums=sum
              sum=sumc
            else
              sumc=sum
              sum=sums
            endif
            if(err.lt.EPS)goto 2
            odd=.not.odd
12        continue
          pause 'maxits exceeded in cisi'
        endif
2       si=sums
        ci=sumc+log(t)+EULER
      endif
      if(x.lt.0.)si=-si
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/cisi.for


! Write 2 matrices of random real numbers to 2 separate files.
! The matrices must be compatible for matrix multiplication.
PROGRAM create_matrix_files
IMPLICIT NONE
  INTEGER, DIMENSION(8) :: time
  INTEGER :: rows, cols, i, j
  CHARACTER(LEN=3) :: col_str, row_str
  CHARACTER(LEN=9) :: col_fmt, row_fmt
  REAL, PARAMETER :: VAL_MAX = 199.9

  WRITE(*, *) "Enter dimensions of first matrix."
  READ(*, *) rows, cols
  WRITE(*, *) "Creating two matrices."
  WRITE(*, '("Matrix A:",I6,1X,"x",I6)') rows, cols
  WRITE(*, '("Matrix B:",I6,1X,"x",I6)') cols, rows

  CALL DATE_AND_TIME(VALUES=time)
  CALL SRAND(time(8))

  WRITE(col_str, '(I3)') cols
  col_str = TRIM(col_str)
  col_fmt = '(' // col_str // 'F8.1)'
  WRITE(row_str, '(I3)') rows
  row_str = TRIM(row_str)
  row_fmt = '(' // row_str // 'F8.1)'

  OPEN (1, FILE='matrixA.dat', STATUS='UNKNOWN', ACTION='WRITE')
  WRITE (1, col_fmt) ((RAND() * VAL_MAX - (VAL_MAX / 2.), j=1,cols), i=1,rows)
  OPEN (2, FILE='matrixB.dat', STATUS='UNKNOWN', ACTION='WRITE')
  WRITE (2, row_fmt) ((RAND() * VAL_MAX - (VAL_MAX / 2.), j=1,rows), i=1,cols)
  CLOSE(1)
  CLOSE(2)

END PROGRAM create_matrix_files


MODULE Diffusionlimitedevaporationmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_diffusionlimitedevaporation(deficitOnTopLayers, &
        soilDiffusionConstant, &
        diffusionLimitedEvaporation)
        IMPLICIT NONE
        REAL, INTENT(IN) :: deficitOnTopLayers
        REAL, INTENT(IN) :: soilDiffusionConstant
        REAL, INTENT(OUT) :: diffusionLimitedEvaporation
        !- Name: DiffusionLimitedEvaporation -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: DiffusionLimitedEvaporation Model
    !            * Author: Pierre Martre
    !            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            * Institution: INRA Montpellier
    !            * ExtendedDescription: the evaporation from the diffusion limited soil
    !            * ShortDescription: It calculates the diffusion limited evaropration
    !
        !- inputs:
    !            * name: deficitOnTopLayers
    !                          ** description : deficit On TopLayers
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 5341
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: soilDiffusionConstant
    !                          ** description : soil Diffusion Constant
    !                          ** parametercategory : soil
    !                          ** datatype : DOUBLE
    !                          ** default : 4.2
    !                          ** min : 0
    !                          ** max : 10
    !                          ** unit :
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
        !- outputs:
    !            * name: diffusionLimitedEvaporation
    !                          ** description : the evaporation from the diffusion limited soil
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 5000
    !                          ** unit : g m-2 d-1
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        IF(deficitOnTopLayers / 1000.0 .LE. 0.0) THEN
            diffusionLimitedEvaporation = 8.3 * 1000.0
        ELSE
            IF(deficitOnTopLayers / 1000.0 .LT. 25.0) THEN
                diffusionLimitedEvaporation = 2.0 * soilDiffusionConstant *  &
                        soilDiffusionConstant / (deficitOnTopLayers / 1000.0) * 1000.0
            ELSE
                diffusionLimitedEvaporation = 0.0
            END IF
        END IF
    END SUBROUTINE model_diffusionlimitedevaporation

END MODULE


module grid

    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    elemental function space_linear(i,n,h) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: h
        real(r64) :: f,x
        x = real(i - 1, r64) / real(n - 1, r64)
        f = x * h
    end function

    elemental function space_linear_r(i,n,h) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: h
        real(r64) :: f,x
        x = real(n - i, r64) / real(n - 1, r64)
        f = x * h
    end function

    elemental function space_linlog(i,n,h) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: h
        real(r64) :: f,x
        x = real(i - 1, r64) / real(n - 1, r64)
        f = (1 + h) ** x - 1
    end function

    elemental function space_linlog_r(i,n,h) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: h
        real(r64) :: f,x
        x = real(n - i, r64) / real(n - 1, r64)
        f = (1 + h) ** x - 1
    end function

    elemental function space_asinh(i,n,h) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: h
        real(r64) :: f,x
        x = real(i - 1, r64) / real(n - 1, r64)
        f = sinh( x * asinh(h) )
    end function

    elemental function space_asinh_r(i,n,h) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: h
        real(r64) :: f,x
        x = real(n - i, r64) / real(n - 1, r64)
        f = sinh( x * asinh(h) )
    end function

    elemental function space_pow2(i,n,k) result(f)
        integer, intent(in) :: i,n
        real(r64), intent(in) :: k
        real(r64) :: f,t
        t = real(i - 1, r64) / real(n - 1, r64)
        f = (2 * t + (k - 1) * t**2) / (k + 1)
    end function

end module


module syminvf90
  use cholf90
contains
  subroutine syminv ( a, n, c, w, nullty, ifault )
    !*****************************************************************************80
    !
    !! SYMINV computes the inverse of a symmetric matrix.
    !
    !  Modified:
    !
    !    11 February 2008
    !
    !  Author:
    !
    !    FORTRAN77 version by Michael Healy
    !    FORTRAN90 version by John Burkardt
    !
    !  Reference:
    !
    !    Michael Healy,
    !    Algorithm AS 7:
    !    Inversion of a Positive Semi-Definite Symmetric Matrix,
    !    Applied Statistics,
    !    Volume 17, Number 2, 1968, pages 198-199.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) A((N*(N+1))/2), a positive definite matrix stored
    !    by rows in lower triangular form as a one dimensional array, in the sequence
    !    A(1,1),
    !    A(2,1), A(2,2),
    !    A(3,1), A(3,2), A(3,3), and so on.
    !
    !    Input, integer ( kind = 4 ) N, the order of A.
    !
    !    Output, real ( kind = 8 ) C((N*(N+1))/2), the inverse of A, or generalized
    !    inverse if A is singular, stored using the same storage scheme employed
    !    for A.  The program is written in such a way that A and U can share storage.
    !
    !    Workspace, real ( kind = 8 ) W(N).
    !
    !    Output, integer ( kind = 4 ) NULLTY, the rank deficiency of A.  If NULLTY is zero,
    !    the matrix is judged to have full rank.
    !
    !    Output, integer ( kind = 4 ) IFAULT, error indicator.
    !    0, no error detected.
    !    1, N < 1.
    !    2, A is not positive semi-definite.
    !
    implicit none

    integer ( kind = 4 ), intent(in) :: n

    real    ( kind = 8 ), intent(in)  :: a((n*(n+1))/2)
    real    ( kind = 8 ), intent(out) :: c((n*(n+1))/2)
    integer ( kind = 4 ) i
    integer ( kind = 4 ) icol
    integer ( kind = 4 ), intent(out) :: ifault
    integer ( kind = 4 ) irow
    integer ( kind = 4 ) j
    integer ( kind = 4 ) jcol
    integer ( kind = 4 ) k
    integer ( kind = 4 ) l
    integer ( kind = 4 ) mdiag
    integer ( kind = 4 ) ndiag
    integer ( kind = 4 ) nn
    integer ( kind = 4 ) nrow
    integer ( kind = 4 ), intent(out) :: nullty
    real    ( kind = 8 ) w(n)
    real    ( kind = 8 ) x

    ifault = 0

    if ( n <= 0 ) then
       ifault = 1
       return
    end if

    nrow = n
    !
    !  Compute the Cholesky factorization of A.
    !  The result is stored in C.
    !
    nn = ( n * ( n + 1 ) ) / 2

    call cholesky ( a, n, nn, c, nullty, ifault )

    if ( ifault /= 0 ) then
       return
    end if
    !
    !  Invert C and form the product (Cinv)' * Cinv, where Cinv is the inverse
    !  of C, row by row starting with the last row.
    !  IROW = the row number,
    !  NDIAG = location of last element in the row.
    !
    irow = nrow
    ndiag = nn

    do
       !
       !  Special case, zero diagonal element.
       !
       if ( c(ndiag) == 0.0D+00 ) then

          l = ndiag
          do j = irow, nrow
             c(l) = 0.0D+00
             l = l + j
          end do

       else

          l = ndiag
          do i = irow, nrow
             w(i) = c(l)
             l = l + i
          end do

          icol = nrow
          jcol = nn
          mdiag = nn

          do

             l = jcol

             if ( icol == irow ) then
                x = 1.0D+00 / w(irow)
             else
                x = 0.0D+00
             end if

             k = nrow

             do while ( irow < k )

                x = x - w(k) * c(l)
                k = k - 1
                l = l - 1

                if ( mdiag < l ) then
                   l = l - k + 1
                end if

             end do

             c(l) = x / w(irow)

             if ( icol <= irow ) then
                exit
             end if

             mdiag = mdiag - icol
             icol = icol - 1
             jcol = jcol - 1

          end do

       end if

       ndiag = ndiag - irow
       irow = irow - 1

       if ( irow <= 0 ) then
          exit
       end if

    end do

    return
  end subroutine syminv
end module syminvf90


C$Procedure      DRDSPH ( Derivative of rectangular w.r.t. spherical )

      SUBROUTINE DRDSPH ( R, COLAT, LONG, JACOBI )
      IMPLICIT NONE

C$ Abstract
C
C     This routine computes the Jacobian of the transformation from
C     spherical to rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     COORDINATES
C     DERIVATIVES
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION      R
      DOUBLE PRECISION      COLAT
      DOUBLE PRECISION      LONG
      DOUBLE PRECISION      JACOBI ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     R          I   Distance of a point from the origin.
C     COLAT      I   Angle of the point from the positive Z-axis.
C     LONG       I   Angle of the point from the XY plane.
C     JACOBI     O   Matrix of partial derivatives.
C
C$ Detailed_Input
C
C     R          Distance of a point from the origin.
C
C     COLAT      Angle between the point and the positive z-axis, in
C                radians.
C
C     LONG       Angle of the point from the XZ plane in radians.
C                The angle increases in the counterclockwise sense
C                about the +Z axis.
C
C$ Detailed_Output
C
C     JACOBI     is the matrix of partial derivatives of the conversion
C                between spherical and rectangular coordinates,
C                evaluated at the input coordinates.  This matrix has
C                the form
C
C                    .-                                   -.
C                    |  DX/DR     DX/DCOLAT     DX/DLONG   |
C                    |                                     |
C                    |  DY/DR     DY/DCOLAT     DY/DLONG   |
C                    |                                     |
C                    |  DZ/DR     DZ/DCOLAT     DZ/DLONG   |
C                    `-                                   -'
C
C               evaluated at the input values of R, LONG and LAT.
C               Here X, Y, and Z are given by the familiar formulae
C
C                   X = R*COS(LONG)*SIN(COLAT)
C                   Y = R*SIN(LONG)*SIN(COLAT)
C                   Z = R*COS(COLAT)
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     It is often convenient to describe the motion of an object in
C     the spherical coordinate system.  However, when performing
C     vector computations its hard to beat rectangular coordinates.
C
C     To transform states given with respect to spherical coordinates
C     to states with respect to rectangular coordinates, one makes use
C     of the Jacobian of the transformation between the two systems.
C
C     Given a state in spherical coordinates
C
C          ( r, colat, long, dr, dcolat, dlong )
C
C     the velocity in rectangular coordinates is given by the matrix
C     equation:
C                    t          |                                    t
C        (dx, dy, dz)   = JACOBI|              * (dr, dcolat, dlong )
C                               |(r,colat,long)
C
C     This routine computes the matrix
C
C              |
C        JACOBI|
C              |(r,colat,long)
C
C$ Examples
C
C     Suppose that one has a model that gives the radius, colatitude
C     and longitude as a function of time (r(t), colat(t), long(t)),
C     for which the derivatives ( dr/dt, dcolat/dt, dlong/dt ) are
C     computable.
C
C     To find the velocity of the object in bodyfixed rectangular
C     coordinates, one simply multiplies the Jacobian of the
C     transformation from spherical to rectangular coordinates
C     (evaluated at r(t), colat(t), long(t) ) by the vector of
C     derivatives of the spherical coordinates.
C
C     In code this looks like:
C
C        C
C        C     Load the derivatives of r, colat, and long into the
C        C     spherical velocity vector SPHV.
C        C
C              SPHV(1) = DR_DT     ( T )
C              SPHV(2) = DCOLAT_DT ( T )
C              SPHV(3) = DLONG_DT  ( T )
C
C        C
C        C     Determine the Jacobian of the transformation from
C        C     spherical to rectangular coordinates at the given
C        C     spherical coordinates at time T.
C        C
C              CALL DRDSPH ( R(T), COLAT(T), LONG(T), JACOBI )
C
C        C
C        C     Multiply the Jacobian on the left times the spherical
C        C     velocity to obtain the rectangular velocity RECV.
C        C
C              CALL MXV ( JACOBI, SPHV, RECV )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 20-JUL-2001 (WLT) (IMU)
C
C-&

C$ Index_Entries
C
C     Jacobian of rectangular w.r.t. spherical coordinates
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     Local parameters
C
      INTEGER               DX
      PARAMETER           ( DX     = 1 )

      INTEGER               DY
      PARAMETER           ( DY     = 2 )

      INTEGER               DZ
      PARAMETER           ( DZ     = 3 )

      INTEGER               DR
      PARAMETER           ( DR     = 1 )

      INTEGER               DCOLAT
      PARAMETER           ( DCOLAT = 2 )

      INTEGER               DLON
      PARAMETER           ( DLON   = 3 )

C
C     Local variables
C
      DOUBLE PRECISION      CCOLAT
      DOUBLE PRECISION      CLONG
      DOUBLE PRECISION      SCOLAT
      DOUBLE PRECISION      SLONG

      CCOLAT = DCOS( COLAT )
      SCOLAT = DSIN( COLAT )

      CLONG  = DCOS( LONG  )
      SLONG  = DSIN( LONG  )

      JACOBI (DX,DR)     =      CLONG * SCOLAT
      JACOBI (DY,DR)     =      SLONG * SCOLAT
      JACOBI (DZ,DR)     =              CCOLAT

      JACOBI (DX,DCOLAT) =  R * CLONG * CCOLAT
      JACOBI (DY,DCOLAT) =  R * SLONG * CCOLAT
      JACOBI (DZ,DCOLAT) = -R *         SCOLAT

      JACOBI (DX,DLON)   = -R * SLONG * SCOLAT
      JACOBI (DY,DLON)   =  R * CLONG * SCOLAT
      JACOBI (DZ,DLON)   =  0.0D0

      RETURN
      END


!-----------------------------------------------------------------------
!
! RAdS Jan12.
! Copyright (C) 2011-2014 by Rodrigo Alvares de Souza.
! Mail: <rsouza01@gmail.com>. Web: "http://www.astro.iag.usp.br/~rsouza/".
! This program may be copied and/or distributed freely. See the
! _ terms and conditions in the files in the doc/ subdirectory.
!
!
! MODULE: util
!
!> @author
!> Rodrigo Souza
!
! DESCRIPTION:
!> Utility routines
!
!-----------------------------------------------------------------------
module util
use global_constants

    implicit none

    contains

    !> \brief Evaluates the logarithm of 'argument' to the given 'base', calculated as log(x)/log(base).
    !!
    !! \param argument
    !! \param base
    !! \return the logarithm
    !!
    double precision function log_n(argument, base)
    implicit none
        double precision :: argument
        double precision :: base

        log_n = log(argument)/log(base)
    end function

end module util


! =================================================
!   TDMA algorithm
! =================================================

subroutine TDMA(n, a, b, c, d, x)

    implicit none

    integer*4, intent(in)  :: n
    real*8,    intent(in)  :: a(n)
    real*8,    intent(in)  :: b(n)
    real*8,    intent(in)  :: c(n)
    real*8,    intent(in)  :: d(n)
    real*8,    intent(out) :: x(n)

    real*8    :: P(n)
    real*8    :: Q(n)
    real*8    :: R(n)
    integer*4 :: I

    P(1) = -c(1)/b(1)
    Q(1) =  d(1)/b(1)
    do I = 2, n
        R(I) =  a(I)*P(I-1) + b(I)
        P(I) = -c(I)/R(I)
        Q(I) = (d(I) - a(I)*Q(I-1))/R(I)
    end do

    x(N) = Q(N)
    do I = N - 1, 1, -1
        x(I) = P(I)*x(I+1) + Q(I)
    end do

end subroutine


!*********************************************************
!>
! A number of constants used in math and physics
!

module constants
  implicit none

  private :: dp
  integer, parameter :: dp = kind(0.d0)

  ! Math constants

  ! pi
  real(dp), parameter :: pi_ = 2.d0*acos(0.d0)

  ! eulers number
  real(dp), parameter :: e_ = exp(1.d0)

  ! euler-mascheroni constant
  real(dp), parameter :: em_ = 0.57721566490153286d0

  ! complex i
  complex(dp), parameter :: i_ = (0,1)

  ! Physics constants

  ! speed of light in m/s
  real(dp), parameter :: c_ = 2.99792458d8
  ! speed of light in cm/s (cgs units)
  real(dp), parameter :: c_cgs_ = 2.99792458d10

  ! planck constant in J*s
  real(dp), parameter :: h_ = 6.626070040d-34
  ! reduced planck constant, h/2*pi, in J*s
  real(dp), parameter :: hbar_ = 1.054571800d-34
  ! planck constant in eV*s
  real(dp), parameter :: h_eV_ = 4.135667662d-15
  ! reduced planck constant, \(h/2\pi\), in \(eV\) \(s\)
  real(dp), parameter :: hbar_eV_ = 6.582119514d-16
  ! planck constant in \(erg\) \(s\) (cgs units)
  real(dp), parameter :: h_cgs_ = 6.626070040d-27
  ! reduced planck constant, \(h/2\pi\), in \(erg\) \(s\) (cgs units)
  real(dp), parameter :: hbar_cgs_ = 1.054571800d-27
  ! reduced planck constant, \(hc/2\pi\), in \(MeV\) \(fm\)
  real(dp), parameter :: hbarc_ = 197.3269788d0

  ! gravitational constant in m^3 kg^-1 s^-2
  real(dp), parameter :: G_ = 6.6743d-11
  ! gravitational constant in cm^3 g^-1 s^-2 (dyne cm^2 g^-2) (cgs units)
  real(dp), parameter :: G_cgs_ = 6.6743d-8

  ! mass of electron in g (cgs units)
  real(dp), parameter :: me_ = 9.10938356d-28
  ! mass of proton in g (cgs units)
  real(dp), parameter :: mp_ = 1.672621898d-24
  ! mass of neutron in g (cgs units)
  real(dp), parameter :: mn_ = 1.674927471d-24
  ! mass of alpha particle in g (cgs units)
  real(dp), parameter :: malpha_ = 6.644657230d-24
  ! atomic mass unit in g (cgs units)
  real(dp), parameter :: amu_ = 1.660539d-24

  ! Bohr radius in cm (cgs units)
  real(dp), parameter :: bohrr_ = 5.2917721067d-9
  ! fine-structure constant
  real(dp), parameter :: alpha_ = 7.2973525664d-3
  ! hartree energy in J
  real(dp), parameter :: eHartree_ = 4.359744650d-18
  ! hartree energy in eV
  real(dp), parameter :: eHartree_eV_ = 27.21138602d0

  ! Avagadro's number
  real(dp), parameter :: na_ = 6.0221367d23
  ! Boltzmann constant in J K^-1
  real(dp), parameter :: k_ = 1.38064852d-23
  ! Faraday constant in C mol^-1
  real(dp), parameter :: F_ = 96485.33289d0
  ! Rydberg constant in m^-1
  real(dp), parameter :: ryd_ = 10973731.568508d0
  ! Stefan-Boltzmann constant in W m^-2 K^-4
  real(dp), parameter :: stefboltz_ = 5.670367d-8

  ! electric charge in C
  real(dp), parameter :: ec_ = 1.6021766208d-19
  ! electric charge in cm^{3/2} g^{1/2} s^-1 (cgs units)
  real(dp), parameter :: ec_cgs_ = 4.8032d-10
  ! electron volt in J
  real(dp), parameter :: ev_ = 1.6021766208d-19
  ! electron volt in erg (cgs units)
  real(dp), parameter :: ev_cgs_ = 1.60217733d-12

  ! electric constant (vacuum permittivity) in F m^-1
  real(dp), parameter :: epsilon0_ = 8.854187817d-12
  ! magnetic constant (vacuum permeability) in N A^-2
  real(dp), parameter :: mu0_ = 1.2566370614d-6

  ! solar mass in g
  real(dp), parameter :: msolar_ = 1.988435d33
  ! solar radius in cm
  real(dp), parameter :: rsolar_ = 6.955d10
  ! solar luminosity in erg s^-1
  real(dp), parameter :: lumsolar_ = 3.839d33

end module


SUBROUTINE stencil(ain1, ain2, ain3, aout)
      IMPLICIT NONE
      real(kind=8) :: ain1(258,258,258)
      real(kind=8) :: ain2(258,258,258)
      real(kind=8) :: ain3(258,258,258)
      real(kind=8) :: aout(258,258,258)

      integer :: i,j,k

      do i=2,258-1
        do j=2,258-1
          do k=2,258-1
            aout(i,j,k) = ain1(i,j,k) + (1.0_8/6.0_8) * ( ain1(i+1,j,k) + &
                                         ain1(i-1,j,k) ) + &
                                       (2.0_8/6.0_8) * ( ain2(j+1,j,k) + &
                                         ain2(j-1,j,k) ) + &
                                       (3.0_8/6.0_8) * ( ain3(k+1,j,k) + &
                                         ain3(k-1,j,k) )
          enddo
        enddo
      enddo

END SUBROUTINE


***********************************************************************
c	                  ORBEL_SCHGET.F
***********************************************************************
*     PURPOSE:  Given an angle, efficiently compute sinh and cosh.
*
*        Input:
*             angle ==> angle in radians (real scalar)
*
*        Output:
*             shx    ==>  sinh(angle)  (real scalar)
*             chx    ==>  cosh(angle)  (real scalar)
*
*     ALGORITHM: Obvious from the code
*     REMARKS: Based on the routine SCGET for sine's and cosine's.
*       We use the sqrt rather than cosh (it's faster)
*       BE SURE THE ANGLE IS IN RADIANS AND IT CAN'T BE LARGER THAN 300
*       OR OVERFLOWS WILL OCCUR!
*     AUTHOR:  M. Duncan.
*     DATE WRITTEN:  May 6, 1992.
*     REVISIONS:
***********************************************************************

	subroutine orbel_schget(angle,shx,chx)

      include '../swift.inc'

c...  Inputs Only:
        real*8 angle

c...  Output:
	real*8 shx,chx

c----
c...  Executable code

	shx = sinh(angle)
	chx= sqrt(1.d0 + shx*shx)

	return
	end   ! orbel_schget
c---------------------------------------------------------------------


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
module global_variables
  implicit none

! Mathematical parameters
!  real(8),parameter :: pi=3.14159265358979323846d0
  real(8),parameter :: pi=4d0*atan(1d0)
  complex(8),parameter :: zI=(0d0,1d0)

! Physical constant
  real(8),parameter :: a_B=0.529177d0,Ry=13.6058d0
  real(8),parameter :: clight = 137.03953250d0

! FDTD grid
  integer :: Nx_L,NX_R, Mx, Nt
  real(8) :: Hx, dt
  real(8),allocatable :: xn(:)

! electric field
  real(8),allocatable :: Ez(:),Ez_new(:),Ez_old(:),LapEz(:)

! material properties
  real(8) :: eps0,sigma0
  real(8),allocatable :: eps(:),sigma(:)

! Laser parameters
  real(8) :: E0_1,omega_1,tpulse_1,omega_ev_1,tpulse_fs_1,Iwcm2_1
  real(8) :: E0_2,omega_2,tpulse_2,omega_ev_2,tpulse_fs_2,Iwcm2_2
  real(8) :: Tdelay_fs,Tdelay

end module global_variables


subroutine evolve(u, u_previous, nx, ny, a, dt, dx2, dy2)

   implicit none

   real*8, intent(inout) :: u(nx,ny), u_previous(nx, ny)
   !f2py intent(in, out) :: u, u_previous
   integer :: nx, ny
   real*8 :: a, dt, dx2, dy2

   integer :: i,j

   do j = 2, ny-1
     do i = 2, nx-1
        u(i,j) = u_previous(i,j) + a * dt * (  &
                 (u_previous(i-1, j) - 2*u_previous(i,j) +  &
                     u_previous(i+1, j)) / dx2 + &
                 (u_previous(i, j-1) - 2*u_previous(i,j) +  &
                     u_previous(i, j+1)) / dy2 )
     end do
   end do
   u_previous(:,:) = u(:,:)

end subroutine


PROGRAM A9Q1
!--
! Converts an int value to an array of characters.
!--
IMPLICIT NONE
CHARACTER(80) :: C
INTEGER :: i, r

PRINT *, "This program take an integer input and returns the number of decimal digits in the integer"
DO
	PRINT *, "Please enter the value of i (0 to stop)"
    READ *, i
    IF (i .eq. 0) STOP
    r = Convert(i, C, 80)
    PRINT *, "The number of decimal digits:", r
END DO

CONTAINS
INTEGER FUNCTION Convert(n,t,m)
INTEGER, INTENT(IN) :: n,m
CHARACTER(m), INTENT(INOUT) :: t
INTEGER :: i, j, s, rprev, r, f

	!- find the number of decimal digits
	j = 1
    i = 0
    DO WHILE (n/j .gt. 0)
		i = i + 1
        j = j * 10
    END DO
    Convert = i
	!- If its too large the string becomes a string of '*'
	IF (m .lt. i) THEN
		t = '*'
        RETURN
    END IF
	!- isolate each decimal digit
    rprev = 0
    r = 0
    i = 1
	DO WHILE (j .gt. 1)
    	r = n /(j/10)
    	j = j / 10
        f = r - rprev
        !- CHAR requires an ASCII value, digits are 48-57 so add 48 to f
        t(i:i) = CHAR(48 + f)
        rprev = r * 10
        i = i + 1
    END DO
    PRINT *, "The String:  ", t(1:Convert)

END FUNCTION Convert
END PROGRAM A9Q1


program test_sin
use lfortran_intrinsic_math, only: sin
implicit none
real :: x
x = sin(1.5)
if (abs(x - 0.997494996) > 1e-5) error stop
end program


program test_invert
  use inv
  implicit none

  integer, parameter :: N=4

  real(DP), dimension(N,N) :: A,M
  real(DP), dimension(N) :: x,y,z,f
  real(DP) :: tt0,tt1,tt2,tt3,tt4,tt5
  integer :: i,j,irun,nrun=500000

  M=0
  do i=1,N
     do j=1,N
        M(i,j)=i/j
     end do
  end do

  call cpu_time(tt0)
  do irun=1,nrun
     A=M; x=0; f=1
     call invert(A,f,x,N,0)
     call invert(A,f,x,N,1)
  end do
  call cpu_time(tt1)

  call cpu_time(tt2)
  do irun=1,nrun
     A=M; y=0; f=1
     call invert(A,f,y,N,2)
  end do
  call cpu_time(tt3)

  call cpu_time(tt4)
  do irun=1,nrun
     A=M; z=0; f=1
     call invertold(A,f,z,0)
     call invertold(A,f,z,1)
  end do
  call cpu_time(tt5)

  print *, sqrt(sum(abs(x-y)**2))
  print *, sqrt(sum(abs(x-z)**2))
  print *, sqrt(sum(abs(y-z)**2))

  print *, "CPU F90            ",tt1-tt0
  print *, "CPU LAPACK/explicit",tt3-tt2
  print *, "CPU F77            ",tt5-tt4

end program test_invert


Module dielectric
	Use nrtype
	Use phys_consts
	Implicit None

contains

	!-------------------------------------------------------------------------------------
	!-------------------------------------------------------------------------------------
	Function G1(rho, mu2, sigBH)
		Use g_mvt,      Only : g_atContact
		Use Laguerre,   Only : Laguerre_fast

		Implicit None

		Real(DP)     :: rho, mu2, sigBH
		Real(DP)     :: G1

		Real(DP)     :: g_eff
		Real(DP)     :: r
		Real(DP)     :: m23, eta, mu23, sigBH6
		Integer(I4B) :: IFl

		Intent(IN)   :: rho, mu2, sigBH

		IFl    =  2     ! denoting a Sutherland potential
		r      =  NINE  ! range of the Sutherland potential is 9. Corresponds to a dd interaction cubed

		eta    =  rho * (PI/SIX) * sigBH*sigBH*sigBH
		g_eff  =  g_atContact(eta, IFl, r)

		mu23   =  mu2*mu2*mu2 ! dimensionless mu squared to the third
		sigBH6 =  sigBH * sigBH * sigBH * sigBH * sigBH * sigBH

	 	G1     =  (EIGHT/75.D0) * rho * (PI/SIX) * g_eff * mu23 * (1/sigBH6)
	 	!print*, k_B, temp, ONE, (ONE/(k_B*temp))
	 	!print*, aux, mu**2, sigma**3, mu**2 /sigma**3, (ONE/k_B*temp), (ONE/perm0x4pi)

	 	if (G1 < ZERO) STOP "ERROR - Function G1 : This value cant be less than zero"
	End Function G1

	!-------------------------------------------------------------------------------------
	!-------------------------------------------------------------------------------------
	Function dielectric_const(rho, mu2, sigBH, scale)
		Implicit None
		Real(DP)     :: rho, mu2, sigBH, scale
		Real(DP)     :: dielectric_const
		Real(DP)     :: g_kirkwood, y, aux
		Real(DP)     :: d_tmp, eta
		Intent(IN)   :: rho, mu2, sigBH
		OPTIONAL     :: scale

		if (.NOT. PRESENT(scale)) scale = 1.0

		g_kirkwood       = 1 + G1(rho, mu2, sigBH)
		y                = FOUR*PI * rho * mu2 * scale
		aux              = ONE + y*g_kirkwood
		dielectric_const = QUARTER *(aux + SQRT(aux*aux+8))
		d_tmp            = QUARTER *(aux - SQRT(aux*aux+8))

                !write( *,111) (sqrt(mu*mu*1.45)), g_kirkwood-1, y/9.D0, aux, dielectric_const
	    !111 FORMAT ( F10.2, 2X, E10.4, 2X, F9.3, 2X, F14.6, 2X, F10.4)

		if (dielectric_const < ONE) then
			print*, 'ERROR - Function dielectric_const : This value cant be less than one', dielectric_const
			STOP
		endif
	End Function dielectric_const
End Module dielectric


!mm
      subroutine matrix_multiplication(A, B, n, C)

      implicit none

      real, intent(in) :: A(n, n)
      real, intent(in) :: B(n, n)
      real, intent(out) :: C(n, n)
      integer, intent(in) :: n

      integer :: i, j

      !$OMP PARALLEL DO
      do i = 1, n
          do j = 1, n
              C(j,i) = sum(A(:,j) * B(i,:))
          enddo
      enddo
      !$OMP END PARALLEL DO

      end subroutine matrix_multiplication


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
C
C
C ... file testrssph.f
c
c     this file contains a test program for subroutine trssph
c
c ... author
c
c     John C Adams (1996, NCAR)
c
c ... required files
c
c     subroutine trssph and the entire spherepack library
c
c ... description (see documentation in file trssph.f)
c
c     Subroutine trssph is used to demonstrate data transfer between a coarse
c     ten degree equally spaced grid and a higher resolution T64 Global Spectral
c     Gaussian grid.  The equally spaced data is stored in a 19 X 36 colatitude-
c     longitude array DATAE which runs north to south with increasing subscript
c     values.  The Gaussian grid data is stored in a 192 X 94 longitude-latitude
c     array DATAG which runs south to north with increasing latitude subscript.
c     First trssph is used to transfer DATAE to DATAG.  Then trssph is used to
c     transfer DATAG back to DATAE.
c
c     For testing purposes, DATAE is set equal the analytic function
c
c                       x*y*z
c           f(x,y,z) = e
c
c     in Cartesian coordinates x,y,z restricted to the surface of the sphere.
c     The same function is used to compute error in DATAG after the data transfer
c     with trssph.  Finally this is used to compute error in DATAE after the transfer
c     back with trssph.  Output from executing the test program on machines with
c     32 bit and 64 bit arithmetic is listed below.  The minimum required saved
c     and unsaved work space lengths were predetermined by an earlier call to
c     trssph with nlone=36,nlate=19,nlong=192,nlatg=94,lsave=1,lwork=1 and printout
c     of lsvmin and lwkmin.
c
c
c **********************************************************************
c
c     OUTPUT FROM EXECUTING CODE IN THIS FILE
C
c **********************************************************************
c
c     EQUALLY SPACED TO GAUSSIAN GRID TRANSFER
c
c     trssph input parameters:
c     intl =  0
c     igride(1) = -1   igride(2) =  1
c     nlone =  36   nlate =  19
c     igridg(1) =  2   igridg(2) =  0
c     nlong = 194   nlatg =  92
c     lsave =   22213  lwork =   53347
c
c     trssph output:
c     ier =  0  lsvmin =   22213  lwkmin =   53347
c     *** 32 BIT ARITHMETIC
c     least squares error =  0.201E-06
c     *** 64 BIT ARITHMETIC
c     least squares error =  0.763E-11
c
c
c     GAUSSIAN TO EQUALLY SPACED GRID TRANSFER
c
c     trssph input parameters:
c     intl =  0
c     igridg(1) =  2   igridg(2) =  0
c     nlong = 194   nlatg =  92
c     igride(1) = -1   igride(2) =  1
c     nlone =  36   nlate =  19
c     lsave =   22213  lwork =   53347
c
c     trssph output:
c     ier =  0  lsvmin =   22213  lwkmin =   53347
c     *** 32 BIT ARITHMETIC
c     least squares error =  0.618E-06
c     *** 64 BIT ARITHMETIC
c     least squares error =  0.547E-11
c
C **********************************************************************
c
c     END OF OUTPUT ... CODE FOLLOWS
c
c **********************************************************************
C
      program testrssph
      implicit none
c
c     set grid sizes with parameter statements
c
      integer nnlatg,nnlong,nnlate,nnlone,llwork,llsave,lldwork
      parameter (nnlatg=92, nnlong=194, nnlate=19,nnlone=36)
c
c     set predetermined minimum saved and unsaved work space lengths
c
      parameter (llwork = 53347, llsave = 22213)
c
c     set double precision work space lengt (see shagci.f documentation)
c
      parameter (lldwork = nnlatg*(nnlatg+4))
c
c     dimension and type data arrays and grid vectors and internal variables
c
      real DATAE(nnlate,nnlone), DATAG(nnlong,nnlatg)
      real work(llwork),wsave(llsave),thetag(nnlatg)
      double precision dwork(lldwork)
      double precision dtheta(nnlatg),dwts(nnlatg)
      integer igride(2),igridg(2)
      integer nlatg,nlong,nlate,nlone,lwork,lsave,ldwork
      real pi,dlate,dlone,dlong,cp,sp,ct,st,xyz,err2,t,p,dif
      integer i,j,intl,ier,lsvmin,lwkmin
c
c     set grid sizes and dimensions from parameter statements
c
      nlatg = nnlatg
      nlong = nnlong
      nlate = nnlate
      nlone = nnlone
      lwork = llwork
      ldwork = lldwork
      lsave = llsave
c
c     set equally spaced grid increments
c
      pi = 4.0*atan(1.0)
      dlate = pi/(nlate-1)
      dlone = (pi+pi)/nlone
      dlong = (pi+pi)/nlong
c
c     set given data in DATAE from f(x,y,z)= exp(x*y*z) restricted
c     to nlate by nlone equally spaced grid on the sphere
c
      do  j=1,nlone
	p = (j-1)*dlone
	cp = cos(p)
	sp = sin(p)
	do i=1,nlate
c
c     set north to south oriented colatitude point
c
	  t = (i-1)*dlate
	  ct = cos(t)
	  st = sin(t)
	  xyz = (st*(st*ct*sp*cp))
	  DATAE(i,j) = exp(xyz)
	end do
      end do
c
c     set initial call flag
c
      intl = 0
c
c     flag DATAE grid as north to south equally spaced
c
      igride(1) = -1
c
c     flag DATAE grid as colatitude by longitude
c
      igride(2) = 1
c
c     flag DATAG grid as south to north Gaussian
c
      igridg(1) = 2
c
c     flag DATAG grid as longitude by latitude
c
      igridg(2) = 0
c
c     print trssph input parameters
c
      write(*,100) intl,igride(1),igride(2),nlone,nlate,
     +igridg(1),igridg(2),nlong,nlatg,lsave,lwork,ldwork
  100 format(//' EQUALLY SPACED TO GAUSSIAN GRID TRANSFER ' ,
     +/' trssph input arguments: ' ,
     +/' intl = ',i2,
     +/' igride(1) = ',i2,2x,' igride(2) = ',i2,
     +/' nlone = ',i3,2x,' nlate = ',i3,
     +/' igridg(1) = ',i2,2x,' igridg(2) = ',i2,
     +/' nlong = ',i3,2x,' nlatg = ',i3,
     +/' lsave = ',i7,2x,' lwork = ',i7,2x,' ldwork = ',i5)
c
c     transfer data from DATAE to DATAG
c
      call trssph(intl,igride,nlone,nlate,datae,igridg,nlong,
     +nlatg,datag,wsave,lsave,lsvmin,work,lwork,lwkmin,dwork,
     +ldwork,ier)
c
c     print output parameters
c
      write (*,200) ier, lsvmin, lwkmin
  200 format(//' trssph output: '
     +/ ' ier = ', i2,2x, 'lsvmin = ',i7, 2x,'lwkmin = ',i7)
      if (ier .eq. 0) then
c
c     compute nlatg gaussian colatitude points using spherepack routine "gaqd"
c     and set in single precision vector thetag with south to north orientation
c     for computing error in DATAG
c
      call gaqd(nlatg,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlatg
	thetag(i) = pi-dtheta(i)
      end do
c
c     compute the least squares error in DATAG
c
      err2 = 0.0
      do j=1,nlong
	p = (j-1)*dlong
	cp = cos(p)
	sp = sin(p)
	do i=1,nlatg
	  t = thetag(i)
	  ct = cos(t)
	  st = sin(t)
	  xyz = (st*(st*ct*sp*cp))
	  dif = abs(DATAG(j,i)-exp(xyz))
	  err2 = err2+dif*dif
	end do
      end do
      err2 = sqrt(err2/(nlong*nlatg))
      write (6,300) err2
  300 format(' least squares error = ',e10.3)
      end if
c
c     set DATAE to zero
c
      do j=1,nlone
	do i=1,nlate
	  DATAE(i,j) = 0.0
	end do
      end do

      write(*,400) intl,igridg(1),igridg(2),nlong,nlatg,igride(1),
     +             igride(2),nlone,nlate,lsave,lwork,ldwork
  400 format(/' GAUSSIAN TO EQUALLY SPACED GRID TRANSFER ' ,
     +/' trssph input arguments: ' ,
     +/' intl = ',i2,
     +/' igridg(1) = ',i2,2x,' igridg(2) = ',i2,
     +/' nlong = ',i3,2x,' nlatg = ',i3,
     +/' igride(1) = ',i2,2x,' igride(2) = ',i2,
     +/' nlone = ',i3,2x,' nlate = ',i3,
     +/' lsave = ',i7,2x,'lwork = ',i7, 2x, 'ldwork = ',i7)
c
c     transfer DATAG back to DATAE
c
      CALL TRSSPH(INTL,IGRIDG,NLONG,NLATG,datag,IGRIDE,NLONE,
     +NLATE,datae,WSAVE,LSAVE,LSVMIN,WORK,LWORK,LWKMIN,DWORK,
     +ldwork,ier)
c
c     print output parameters
c
      write (*,200) ier, lsvmin, lwkmin
      if (ier .eq. 0) then
c
c     compute the least squares error in DATAE
c
      err2 = 0.0
      do j=1,nlone
	p = (j-1)*dlone
	cp = cos(p)
	sp = sin(p)
	do i=1,nlate
	  t = (i-1)*dlate
	  ct = cos(t)
	  st = sin(t)
	  xyz = (st*(st*ct*sp*cp))
	  dif = abs(DATAE(i,j)-exp(xyz))
	  err2 = err2+dif*dif
	end do
      end do
      err2 = sqrt(err2/(nlate*nlone))
      write (6,300) err2
      end if
      end


!##############################################################################
! PROGRAM golden
!
! ## Golden search for finding the minimum of a function
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program golden

    implicit none
    real*8, parameter :: p(2) = (/1d0, 2d0/)
    real*8, parameter :: W = 1d0
    real*8 :: a, b, x1, x2, f1, f2
    integer :: iter

    ! initial interval and function values
    a = 0d0
    b = (W-p(1)*0.01d0)/p(2)

    ! start iteration process
    do iter = 1, 200

        ! calculate x1 and x2 and function values
        x1 = a + (3d0-sqrt(5d0))/2d0*(b-a)
        x2 = a + (sqrt(5d0)-1d0)/2d0*(b-a)
        f1 = -(((W-p(2)*x1)/p(1))**0.4d0 + (1d0+x1)**0.5d0)
        f2 = -(((W-p(2)*x2)/p(1))**0.4d0 + (1d0+x2)**0.5d0)

        write(*,'(i4,f12.7)')iter, abs(b-a)

        ! check for convergence
        if(abs(b-a) < 1d-6)then
            write(*,'(/a,f12.7)')' x_1 = ',(W-p(2)*x1)/p(1)
            write(*,'(a,f12.7)')' x_2 = ',x1
            write(*,'(a,f12.7)')' u   = ',-f1
            stop
        endif

        ! get new values
        if(f1 < f2)then
            b = x2
        else
            a = x1
        endif
    enddo

end program


C$Procedure      XPOSE ( Transpose a matrix, 3x3 )

      SUBROUTINE XPOSE ( M1, MOUT )

C$ Abstract
C
C     Transpose a 3x3 matrix.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION  M1   ( 3,3 )
      DOUBLE PRECISION  MOUT ( 3,3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     M1        I     Matrix to be transposed.
C     MOUT      O    Transposed matrix (M1)**T.
C
C$ Detailed_Input
C
C     M1      This variable may contain any double precision 3x3
C             matrix.
C
C$ Detailed_Output
C
C     MOUT    This variable is a double precision, 3x3 matrix which
C             contains the transpose of M1.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     XPOSE first copies the diagonal elements of M1 to MOUT.  Then
C     the off-diagonal elements are transposed using a temporary
C     variable in the following order: (1,2) <---> (2,1),
C     (1,3) <---> (3,1) and finally (2,3) <---> (3,2).
C
C$ Examples
C
C     Given below is one example of a matrix M1 with the output matrix
C     MOUT which is implied by M1.
C
C           | 1  2  3 |                | 1  0  0 |
C      M1 = | 0  4  5 |   then  MOUT = | 2  4  6 |
C           | 0  6  0 |                | 3  5  0 |
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     transpose a 3x3_matrix
C
C-&

      DOUBLE PRECISION TEMP
C
C  Move the three diagonal elements from M1 to MOUT
C
      MOUT(1,1) = M1(1,1)
      MOUT(2,2) = M1(2,2)
      MOUT(3,3) = M1(3,3)
C
C  Switch the three pairs of off-diagonal elements
C
      TEMP = M1(1,2)
      MOUT(1,2) = M1(2,1)
      MOUT(2,1) = TEMP
C
      TEMP = M1(1,3)
      MOUT(1,3) = M1(3,1)
      MOUT(3,1) = TEMP
C
      TEMP = M1(2,3)
      MOUT(2,3) = M1(3,2)
      MOUT(3,2) = TEMP
C
      RETURN
      END


!> solves choose(n,k) % p; attributed to Daniel Fischer: http://stackoverflow.com/a/10862881
integer(int64) function choosemod(n, k, p)
   integer(int64), intent(in) :: n, k, p
   if (k < 0 .or. n < k) then
      choosemod = 0
      return
   else if (k==0 .or. k==n) then
      choosemod = 1
      return
   end if
   Integer exp_np = factor_exponent(n,p)
   Integer exp_kp = factor_exponent(k,p)
   Integer exp_nk = factor_exponent(n-k,p)
   if (exp_np > exp_kp + exp_nk) then
      choosemod = 0
      return
   end if

   choosemod = choosemod_one(n, k, p)

contains
   !> returns the power to which p is raised in factoring n!
   integer(int64) factor_exponent(n, p) result(e)
      integer(int64), intent(in) :: n, p
      Integer(int64) :: e, m
      e = 0
      m = n
      do while (m>0)
         m = m/p
         e = e+m
      end do
      return
   end function factor_exponent

   !> returns the number k modulo prime p
   integer(int64) function invmod(k, p)
      integer(int64), intent(in) :: k, p
      integer(int64) :: p1, k1, q, r, m1, tmp
      logical :: neg
      if (p==0) then
         invmod = merge(k, 0, abs(k)==1)
         return
      end if
      if (p < 0) p = -p
      k = mod(k,p)
      if (k < 0) k = k+p
      neg = .true.
      p1 = 1; p2 = 0
      k1 = k; m1 = p
      do while (k1>0)
         q = m1/k1; r = mod(m1,k1)
         tmp = q*p1 + p2
         p2 = p1
         p1 = tmp
         m1 = k1
         k1 = r
         neg = not(neg)
      end do
      invmod = merge(p-p2, p2, neg)
   end function invmod

   !> first helperfunction for choosemod
   integer(int64) function choosemod_one(n, k, p)
      integer(int64), intent(in) :: n, k, p
      integer(int64) :: choose, qn, rn, qk, rk
      if (k < p) then
         choosemod_one = choosemod_two(n, k, p)
         return
      end if
      qn = n/p; rn = mod(n,p)
      qk = k/p; rk = mod(k,p)
      choose = choosemod_two(rn, rk, p)
      choose = choose * choosemod_two(qn, qk, p)
      choosemod_one = mod(choose, p)
      return
   end function choosemod_one

   !> second helperfunction for choosemod
   integer(int64) function choosemod_two(nn, kk, p)
      integer(int64), intent(in) :: nn, kk, p
      integer(int64) :: n, k, den, num, i
      n = nn; k = kk; den = 1; num = n
      n = mod(n,p)
      if (n < k) then
         choosemod_two = 0
         return
      else if (n==0 .or. k==0) then
         choosemod_two = 1
         return
      end if
      if (2*k > n) k = n - k
      n = n-1
      do while(k>1)
         num = mod(num*n, p)
         den = mod(den*k, p)
         n = n-1; k = k-1
      end do
      den = invmod(den, p)
      choosemod_two = mod(num*den, p)
   end function choosemod_two

end function choosemod