! =====================================================================
! NAME
!
!    GPECN1DTDPBC - GPE = Gross-Pitaevskii Equation;
!                   CN = Crank-Nicolson Method
!                   1D = One-Dimensional
!                   TD = Time-dependent
!                   PBC = Periodic Boundary Conditions
!
! DESCRIPTION
!
!    GPECN1DTDPBC is a Fortran-based program that solves the
!    time-dependent Gross-Pitevsekii equation (GPE) in a uniformly
!    rotating reference frame for a single component Bose-Einstein
!    condensate (BEC) in one-dimension using the Crank-Nicolson finite
!    difference scheme.
!
!    This implementation of the Crank-Nicolson scheme attempts to
!    properly account for the time-dependence of the external and
!    mean-field potentials of the condensate by deriving the scheme using
!    the integral form of the unitary time-evolution operator for a
!    time-dependent Hamiltonian. An iterative approach is then used to
!    determine the unknown mean-field potential at each time step.
!
!    In addition, the program assumes an S1 configuration space for the
!    system (i.e., the condesate is propagating in a one-dimensional,
!    cicular ring) and therefore implements periodic boundary conditions
!    using the Sherman-Morrison algorithm.
!
! USAGE
!
!    make
!    ./gpecn1Dtdpbc.sh
!
! DEPENDENCIES
!
!    GPECN1DTDPBC depends on the ZGTSV and XERBLA subroutines from LAPACK
!    version 3.1.0. The source code for these subroutines as well as
!    the LAPACK LICENSE file are distributed with GPECN1DTDPBC and may be
!    found in libraries/lapack subdirectory.
!
! CITATION
!
!    To cite the use of this work in a scientific publication, please use
!    the following reference:
!
!    @unpublished{kandesmc:2011a,
!        author = "Kandes, M. C.",
!        title = "Sagnac Interferometry with Bose-Einstein Condensates in
!                 a Uniformly Rotating Ring Trap",
!        school = "Claremont Graduate University \& San Diego State
!                 University",
!        note = "Ph.D. Qualifying Exam",
!        year = "2011",
!    }
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Friday, March 31st, 2017
!
! ----------------------------------------------------------------------
      PROGRAM GPECN1DTDPBC
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028842E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: NUMBER_OF_TIME_STEPS
      INTEGER :: NUMBER_OF_TIME_STEPS_BEFORE_WRITE
      INTEGER :: NUMBER_OF_ITERATIONS_PER_TIME_STEP
      INTEGER :: IMAGINARY_TIME_SWITCH

      REAL :: RADIUS
      REAL :: ROTATION_RATE
      REAL :: GAMMA_FACTOR

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: EXTERNAL_POTENTIAL
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: NONLINEAR_COUPLING

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_TIME_STEP
      INTEGER :: CURRENT_ITERATION
      INTEGER :: CURRENT_FILE
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE

      REAL :: L2NORM

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: TEMPORARY_STORAGE
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: RIGHT_HAND_SIDE
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: UPPER_DIAGONAL
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: MAIN_DIAGONAL
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: LOWER_DIAGONAL
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: W
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: Z

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS_BEFORE_WRITE

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_ITERATIONS_PER_TIME_STEP

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) IMAGINARY_TIME_SWITCH

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(7,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ROTATION_RATE

      CALL GET_COMMAND_ARGUMENT(8,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAMMA_FACTOR

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))
      ALLOCATE(EXTERNAL_POTENTIAL(NUMBER_OF_GRID_POINTS))
      ALLOCATE(NONLINEAR_COUPLING(NUMBER_OF_GRID_POINTS))
      ALLOCATE(TEMPORARY_STORAGE(NUMBER_OF_GRID_POINTS))
      ALLOCATE(RIGHT_HAND_SIDE(NUMBER_OF_GRID_POINTS))
      ALLOCATE(UPPER_DIAGONAL(NUMBER_OF_GRID_POINTS-1))
      ALLOCATE(MAIN_DIAGONAL(NUMBER_OF_GRID_POINTS))
      ALLOCATE(LOWER_DIAGONAL(NUMBER_OF_GRID_POINTS-1))
      ALLOCATE(W(NUMBER_OF_GRID_POINTS))
      ALLOCATE(Z(NUMBER_OF_GRID_POINTS))

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)
      TIME_STEP_SIZE = (RADIUS*ANGULAR_GRID_SPACING_SIZE)**2/(2.0E0*GAMMA_FACTOR)

!     Read Input Arrays from File:
!     ----------------------------
      OPEN(UNIT=1000,ACTION='READ',FORM='UNFORMATTED',STATUS='OLD')
      READ(UNIT=1000) WAVEFUNCTION
      CLOSE(UNIT=1000,STATUS='KEEP')

      OPEN(UNIT=999,ACTION='READ',FORM='UNFORMATTED',STATUS='OLD')
      READ(UNIT=999) EXTERNAL_POTENTIAL
      CLOSE(UNIT=999,STATUS='KEEP')

      OPEN(UNIT=998,ACTION='READ',FORM='UNFORMATTED',STATUS='OLD')
      READ(UNIT=998) NONLINEAR_COUPLING
      CLOSE(UNIT=998,STATUS='KEEP')

!     Initializations:
!     ----------------
      CURRENT_FILE = 1001

!     Main Program Loop:
!     ------------------
      DO CURRENT_TIME_STEP = 1, NUMBER_OF_TIME_STEPS
         TEMPORARY_STORAGE = WAVEFUNCTION
         DO CURRENT_ITERATION = 1, NUMBER_OF_ITERATIONS_PER_TIME_STEP
            UPPER_DIAGONAL = CMPLX((ROTATION_RATE*TIME_STEP_SIZE)/(4.0E0*ANGULAR_GRID_SPACING_SIZE),TIME_STEP_SIZE/(4.0E0*RADIUS**2*ANGULAR_GRID_SPACING_SIZE**2))
            MAIN_DIAGONAL = CMPLX(1.0E0,0.0E0)-CMPLX(0.0E0,TIME_STEP_SIZE/4.0E0)*(CMPLX(2.0E0/(RADIUS**2*ANGULAR_GRID_SPACING_SIZE**2),0.0E0)+CMPLX(2.0E0,0.0E0)*EXTERNAL_POTENTIAL+NONLINEAR_COUPLING*CMPLX(ABS(WAVEFUNCTION)**2+ABS(TEMPORARY_STORAGE)**2,0.0E0))
            LOWER_DIAGONAL = -CONJG(UPPER_DIAGONAL)
            RIGHT_HAND_SIDE(1) = UPPER_DIAGONAL(1)*TEMPORARY_STORAGE(2)+MAIN_DIAGONAL(1)*TEMPORARY_STORAGE(1)+LOWER_DIAGONAL(1)*TEMPORARY_STORAGE(NUMBER_OF_GRID_POINTS)
            DO CURRENT_GRID_POINT = 2, NUMBER_OF_GRID_POINTS-1
               RIGHT_HAND_SIDE(CURRENT_GRID_POINT) = UPPER_DIAGONAL(CURRENT_GRID_POINT)*TEMPORARY_STORAGE(CURRENT_GRID_POINT+1)+MAIN_DIAGONAL(CURRENT_GRID_POINT)*TEMPORARY_STORAGE(CURRENT_GRID_POINT)+LOWER_DIAGONAL(CURRENT_GRID_POINT-1)*TEMPORARY_STORAGE(CURRENT_GRID_POINT-1)
            ENDDO
            RIGHT_HAND_SIDE(NUMBER_OF_GRID_POINTS) = UPPER_DIAGONAL(NUMBER_OF_GRID_POINTS-1)*TEMPORARY_STORAGE(1)+MAIN_DIAGONAL(NUMBER_OF_GRID_POINTS)*TEMPORARY_STORAGE(NUMBER_OF_GRID_POINTS)+LOWER_DIAGONAL(NUMBER_OF_GRID_POINTS-1)*TEMPORARY_STORAGE(NUMBER_OF_GRID_POINTS-1)
            UPPER_DIAGONAL = -UPPER_DIAGONAL
            MAIN_DIAGONAL = CONJG(MAIN_DIAGONAL)
            LOWER_DIAGONAL = -LOWER_DIAGONAL
            W = CMPLX(0.0E0,0.0E0)
            Z = CMPLX(0.0E0,0.0E0)
            W(1) = CMPLX(1.0E0,0.0E0)
            W(NUMBER_OF_GRID_POINTS) = CMPLX(1.0E0,0.0E0)
            Z(1) = -UPPER_DIAGONAL(1)
            Z(NUMBER_OF_GRID_POINTS) = -LOWER_DIAGONAL(1)
            MAIN_DIAGONAL(1) = MAIN_DIAGONAL(1)+W(1)*Z(1)
            MAIN_DIAGONAL(NUMBER_OF_GRID_POINTS) = MAIN_DIAGONAL(NUMBER_OF_GRID_POINTS)+W(NUMBER_OF_GRID_POINTS)*Z(NUMBER_OF_GRID_POINTS)
            CALL ZGTSV(NUMBER_OF_GRID_POINTS,1,LOWER_DIAGONAL,MAIN_DIAGONAL,UPPER_DIAGONAL,RIGHT_HAND_SIDE,NUMBER_OF_GRID_POINTS,INFO)
            UPPER_DIAGONAL = -CMPLX((ROTATION_RATE*TIME_STEP_SIZE)/(4.0E0*ANGULAR_GRID_SPACING_SIZE),TIME_STEP_SIZE/(4.0E0*RADIUS**2*ANGULAR_GRID_SPACING_SIZE**2))
            MAIN_DIAGONAL = CMPLX(1.0E0,0.0E0)+CMPLX(0.0E0,TIME_STEP_SIZE/4.0E0)*(CMPLX(2.0E0/(RADIUS**2*ANGULAR_GRID_SPACING_SIZE**2),0.0E0)+CMPLX(2.0E0,0.0E0)*EXTERNAL_POTENTIAL+NONLINEAR_COUPLING*CMPLX(ABS(WAVEFUNCTION)**2+ABS(TEMPORARY_STORAGE)**2,0.0E0))
            LOWER_DIAGONAL = -CONJG(UPPER_DIAGONAL)
            MAIN_DIAGONAL(1) = MAIN_DIAGONAL(1)+W(1)*Z(1)
            MAIN_DIAGONAL(NUMBER_OF_GRID_POINTS) = MAIN_DIAGONAL(NUMBER_OF_GRID_POINTS)+W(NUMBER_OF_GRID_POINTS)*Z(NUMBER_OF_GRID_POINTS)
            CALL ZGTSV(NUMBER_OF_GRID_POINTS,1,LOWER_DIAGONAL,MAIN_DIAGONAL,UPPER_DIAGONAL,W,NUMBER_OF_GRID_POINTS,INFO)
            WAVEFUNCTION = RIGHT_HAND_SIDE+(SUM(Z*RIGHT_HAND_SIDE)/(CMPLX(1.0E0,0.0E0)-SUM(Z*W)))*W
         ENDDO
         IF (MODULO(CURRENT_TIME_STEP,NUMBER_OF_TIME_STEPS_BEFORE_WRITE).EQ.0) THEN
            OPEN(UNIT=CURRENT_FILE,ACTION='WRITE',FORM='UNFORMATTED')
            WRITE(UNIT=CURRENT_FILE) WAVEFUNCTION
            CLOSE(UNIT=CURRENT_FILE)
            CURRENT_FILE = CURRENT_FILE + 1
         ENDIF
      ENDDO

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)
      DEALLOCATE(EXTERNAL_POTENTIAL)
      DEALLOCATE(NONLINEAR_COUPLING)
      DEALLOCATE(TEMPORARY_STORAGE)
      DEALLOCATE(RIGHT_HAND_SIDE)
      DEALLOCATE(UPPER_DIAGONAL)
      DEALLOCATE(MAIN_DIAGONAL)
      DEALLOCATE(LOWER_DIAGONAL)
      DEALLOCATE(W)
      DEALLOCATE(Z)

      STOP

      ENDPROGRAM GPECN1DTDPBC
! ======================================================================


! **********************************************************************************
! *            ROUTINES FOR COMPUTING THE INCIDENT FIELD COEFFICIENTS              *
! *    ------------------------------------------------------------------------    *
! *    Partial list of subroutines:                                                *
! *      PWcoefficients_ab,                    PWcoefficients_CircPolab(UNUSED),   *
! *      PWcoefficients_Polab,                 PWcoefficients_ab_m,                *
! *      PWcoefficients_CircPolab_m(UNUSED),   PWcoefficients_Polab_m,             *
! *      PWcoefficientsPARTSUB,                PWcoefficientsPARTSUBrefl,          *
! *      PWcoefficientsPARTSUBtrans,           Kcor,                               *
! *      Fresnel_aer_sub,                      Fresnel_sub_aer,                    *
! *      GBcoefficients_ab,                    GBcoefficients_ab_m,                *
! *      product_rotcoefficients,              GBcoefficients_ab_local             *
! **********************************************************************************
subroutine PWcoefficients_ab (thetaGI, phiGI, alpha, beta, gamma, alphap, Mrank,   &
           Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a linearly polarized plane    !
! wave for the azimuthal modes m = 0,1,...,Mrank.                                  !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax
  real(O)    :: thetaGI, phiGI, alpha, beta, gamma, alphap
  complex(O) :: c(2*Nmax)
!
  integer    :: k, m, n, N0, ml, l
  real(O)    :: nm, thetaLI, phiLI, e0eT, e0eP, mlr, arg
  complex(O) :: fact, factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call T_spherical_global_local (thetaGI, phiGI, alpha, beta, gamma, thetaLI, phiLI)
  call parameters_coefficients_ab (thetaGI, phiGI, thetaLI, phiLI, alpha, beta,     &
       gamma, alphap, e0eT, e0eP)
  do m = 0, Mrank
    call leg_normalized (thetaLI, m, Nrank, Pnm, dPnm, pinm, taunm)
    if (m == 0) then
      do k = 1, Nrank
        n     = k
        nm    = real(2 * n * (n + 1),O)
        nm    = 1._O / sqrt(nm)
        fact  = 4._O * im**n * nm
        factt = fact * taunm(n)
        c(k)      = - factt * e0eP
        c(Nmax+k) = - im * factt * e0eT
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      ml = m
      do l = 1, 2
        mlr  = real(ml,O)
        arg  = mlr * phiLI
        fact = exp(- im * arg)
        do k = 1, Nrank - m + 1
          n     = m + k - 1
          nm    = real(2 * n * (n + 1),O)
          nm    = 1._O / sqrt(nm)
          factc = 4._O * im**n * fact * nm
          factp = factc * im * mlr * pinm(n)
          factt = factc * taunm(n)
          c(N0+k)      = - factp * e0eT - factt * e0eP
          c(Nmax+N0+k) = - im * (factt * e0eT - factp * e0eP)
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
    end if
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficients_ab
! **********************************************************************************
subroutine PWcoefficients_CircPolab (thetaGI, phiGI, alpha, beta, gamma, right,     &
           Mrank, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a circularly polarized        !
! plane wave for the azimuthal modes m = 0,1,...,Mrank.                            !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax
  real(O)    :: thetaGI, phiGI, alpha, beta, gamma
  complex(O) :: c(2*Nmax)
  logical    :: right
!
  integer    :: k, m, n, N0, ml, l
  real(O)    :: norm, nm, thetaLI, phiLI, mlr, arg
  complex(O) :: epol_theta, epol_phi, e0eT, e0eP, fact, factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  norm = sqrt(2._O) / 2._O
  if (right) then
    epol_theta = norm * one
    epol_phi   = norm * im
  else
    epol_theta =   norm * one
    epol_phi   = - norm * im
  end if
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call T_spherical_global_local (thetaGI, phiGI, alpha, beta, gamma, thetaLI, phiLI)
  call parameters_coefficients_Polab (thetaGI, phiGI, thetaLI, phiLI, alpha, beta,  &
       gamma, epol_theta, epol_phi, e0eT, e0eP)
  do m = 0, Mrank
    call leg_normalized (thetaLI, m, Nrank, Pnm, dPnm, pinm, taunm)
    if (m == 0) then
      do k = 1, Nrank
        n     = k
        nm    = real(2 * n * (n + 1),O)
        nm    = 1._O / sqrt(nm)
        fact  = 4._O * im**n * nm
        factt = fact * taunm(n)
        c(k)      = - factt * e0eP
        c(Nmax+k) = - im * factt * e0eT
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      ml = m
      do l = 1, 2
        mlr  = real(ml,O)
        arg  = mlr * phiLI
        fact = exp(- im * arg)
        do k = 1, Nrank - m + 1
          n     = m + k - 1
          nm    = real(2 * n * (n + 1),O)
          nm    = 1._O / sqrt(nm)
          factc = 4._O * im**n * fact * nm
          factp = factc * im * mlr * pinm(n)
          factt = factc * taunm(n)
          c(N0+k)      = - factp * e0eT - factt * e0eP
          c(Nmax+N0+k) = - im * (factt * e0eT - factp * e0eP)
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
    end if
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficients_CircPolab
! **********************************************************************************
subroutine PWcoefficients_Polab (thetaGI, phiGI, alpha, beta, gamma, epol_theta,    &
           epol_phi, Mrank, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of an arbitrarily polarized      !
! plane wave for the azimuthal modes m = 0,1,...,Mrank.                            !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax
  real(O)    :: thetaGI, phiGI, alpha, beta, gamma
  complex(O) :: epol_theta, epol_phi, c(2*Nmax)
!
  integer    :: k, m, n, N0, ml, l
  real(O)    :: nm, thetaLI, phiLI, mlr, arg
  complex(O) :: e0eT, e0eP, fact, factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call T_spherical_global_local (thetaGI, phiGI, alpha, beta, gamma, thetaLI, phiLI)
  call parameters_coefficients_Polab (thetaGI, phiGI, thetaLI, phiLI, alpha, beta,  &
       gamma, epol_theta, epol_phi, e0eT, e0eP)
  do m = 0, Mrank
    call leg_normalized (thetaLI, m, Nrank, Pnm, dPnm, pinm, taunm)
    if (m == 0) then
      do k = 1, Nrank
        n     = k
        nm    = real(2 * n * (n + 1),O)
        nm    = 1._O / sqrt(nm)
        fact  = 4._O * im**n * nm
        factt = fact * taunm(n)
        c(k)      = - factt * e0eP
        c(Nmax+k) = - im * factt * e0eT
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      ml = m
      do l = 1, 2
        mlr  = real(ml,O)
        arg  = mlr * phiLI
        fact = exp(- im * arg)
        do k = 1, Nrank - m + 1
          n     = m + k - 1
          nm    = real(2 * n * (n + 1),O)
          nm    = 1._O / sqrt(nm)
          factc = 4._O * im**n * fact * nm
          factp = factc * im * mlr * pinm(n)
          factt = factc * taunm(n)
          c(N0+k)      = - factp * e0eT - factt * e0eP
          c(Nmax+N0+k) = - im * (factt * e0eT - factp * e0eP)
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
    end if
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficients_Polab
! **********************************************************************************
subroutine PWcoefficients_ab_m (thetaGI, phiGI, alpha, beta, gamma, alphap, m,      &
           Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a linearly polarized plane    !
! wave for the azimuthal mode m.                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: thetaGI, phiGI, alpha, beta, gamma, alphap
  complex(O) :: c(2*Nmax)
!
  integer    :: k, n
  real(O)    :: nm, thetaLI, phiLI, e0eT, e0eP, mr, arg
  complex(O) :: fact, factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call T_spherical_global_local (thetaGI, phiGI, alpha, beta, gamma, thetaLI, phiLI)
  call parameters_coefficients_ab (thetaGI, phiGI, thetaLI, phiLI, alpha, beta,     &
       gamma, alphap, e0eT, e0eP)
  call leg_normalized (thetaLI, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr   = real(m,O)
  arg  = mr * phiLI
  fact = exp(- im * arg)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = 4._O * im**n * fact * nm
    factp = factc * im * mr * pinm(n)
    factt = factc * taunm(n)
    c(k)      = - factp * e0eT - factt * e0eP
    c(Nmax+k) = - im * (factt * e0eT - factp * e0eP)
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficients_ab_m
! **********************************************************************************
subroutine PWcoefficients_CircPolab_m (thetaGI, phiGI, alpha, beta, gamma, right,   &
           m, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a circularly polarized        !
! plane wave for the azimuthal mode m.                                             !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: thetaGI, phiGI, alpha, beta, gamma
  complex(O) :: c(2*Nmax)
  logical    :: right
!
  integer    :: k, n
  real(O)    :: norm, nm, thetaLI, phiLI, mr, arg
  complex(O) :: epol_theta, epol_phi, e0eT, e0eP, fact, factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  norm = sqrt(2._O) / 2._O
  if (right) then
    epol_theta = norm * one
    epol_phi   = norm * im
  else
    epol_theta =   norm * one
    epol_phi   = - norm * im
  end if
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call T_spherical_global_local (thetaGI, phiGI, alpha, beta, gamma, thetaLI, phiLI)
  call parameters_coefficients_Polab (thetaGI, phiGI, thetaLI, phiLI, alpha, beta,  &
       gamma, epol_theta, epol_phi, e0eT, e0eP)
  call leg_normalized (thetaLI, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr   = real(m,O)
  arg  = mr * phiLI
  fact = exp(- im * arg)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = 4._O * im**n * fact * nm
    factp = factc * im * mr * pinm(n)
    factt = factc * taunm(n)
    c(k)      = - factp * e0eT - factt * e0eP
    c(Nmax+k) = - im * (factt * e0eT - factp * e0eP)
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficients_CircPolab_m
! **********************************************************************************
subroutine PWcoefficients_Polab_m (thetaGI, phiGI, alpha, beta, gamma, epol_theta,  &
           epol_phi, m, Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of an arbitrarily polarized      !
! plane wave for the azimuthal mode m.                                             !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: thetaGI, phiGI, alpha, beta, gamma
  complex(O) :: epol_theta, epol_phi, c(2*Nmax)
!
  integer    :: k, n
  real(O)    :: nm, thetaLI, phiLI, mr, arg
  complex(O) :: e0eT, e0eP, fact, factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call T_spherical_global_local (thetaGI, phiGI, alpha, beta, gamma, thetaLI, phiLI)
  call parameters_coefficients_Polab (thetaGI, phiGI, thetaLI, phiLI, alpha, beta,  &
       gamma, epol_theta, epol_phi, e0eT, e0eP)
  call leg_normalized (thetaLI, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr   = real(m,O)
  arg  = mr * phiLI
  fact = exp(- im * arg)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = 4._O * im**n * fact * nm
    factp = factc * im * mr * pinm(n)
    factt = factc * taunm(n)
    c(k)      = - factp * e0eT - factt * e0eP
    c(Nmax+k) = - im * (factt * e0eT - factp * e0eP)
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficients_Polab_m
! **********************************************************************************
subroutine PWcoefficientsPARTSUB (beta0, alphap, m, Nrank, Nmax, c)
!------------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a plane wave (traveling in     !
! the Oxz plane) for the azimuthal mode m.                                          !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: beta0, alphap
  complex(O) :: c(2*Nmax)
!
  integer    :: k, n
  real(O)    :: nm, mr, ca, sa
  complex(O) :: factc, factp, factt
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call leg_normalized (beta0, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr = real(m,O)
  ca = cos(alphap)
  sa = sin(alphap)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = 4._O * im**n * nm * cos(mr * Pi)
    factp = factc * im * mr * pinm(n)
    factt = factc * taunm(n)
    c(k)      = - factp * ca - factt * sa
    c(Nmax+k) = - im * (factt * ca - factp * sa)
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficientsPARTSUB
! **********************************************************************************
subroutine PWcoefficientsPARTSUBrefl (beta0, alphap, z0, wavenumber, ind_ref, m,    &
           Nrank, Nmax, c)
!-----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of the reflected plane wave      !
! (traveling in the Oxz plane) for the azimuthal mode m.                           !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: beta0, alphap, z0, wavenumber
  complex(O) :: c(2*Nmax), ind_ref
!
  integer    :: k, n
  real(O)    :: nm, betaM0, mr
  complex(O) :: Rpar, Rperp, Tpar, Tperp, et, ep, cosb, sinb, cosb0, factc,         &
                factp, factt, phase
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  cosb0 = cmplx(cos(beta0),0._O)
  call Fresnel_aer_sub (cosb0, ind_ref, Rpar, Rperp, Tpar, Tperp, cosb, sinb)
  phase  = exp(2._O * im * wavenumber * cosb0 * z0)
  et     = cos(alphap) * Rpar * phase
  ep     = sin(alphap) * Rperp * phase
  betaM0 = Pi - beta0
  call leg_normalized (betaM0, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr = real(m,O)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = 4._O * im**n * nm * cos(mr * Pi)
    factp = factc * im * mr * pinm(n)
    factt = factc * taunm(n)
    c(k)      = - factp * et - factt * ep
    c(Nmax+k) = - im * (factt * et - factp * ep)
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficientsPARTSUBrefl
! **********************************************************************************
subroutine PWcoefficientsPARTSUBtrans (beta, alphap, z0, wavenumber, ind_ref, m,    &
           Nrank, Nmax, c)
!----------------------------------------------------------------------------------
! The routine computes the expansion coefficients of the transmitted plane wave   !
! (traveling in the Oxz plane) for the azimuthal mode m.                          !
! ---------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: beta, alphap, z0, wavenumber
  complex(O) :: c(2*Nmax), ind_ref
!
  integer    :: k, n
  real(O)    :: nm, mr
  complex(O) :: Rpar, Rperp, Tpar, Tperp, et, ep, cosb, sinb0, cosb0, factc, factp, &
                factt, phase
  complex(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  cosb = cmplx(cos(beta),0._O)
  call Fresnel_sub_aer (cosb, ind_ref, Rpar, Rperp, Tpar, Tperp, cosb0, sinb0)
  phase = exp(im * wavenumber * (cosb0 - ind_ref * cosb) * z0)
  et    = cos(alphap) * Tpar * phase
  ep    = sin(alphap) * Tperp * phase
  cosb0 = - cosb0
  call Leg_normalized_complex (sinb0, cosb0, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr = real(m,O)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = 4._O * im**n * nm
    factp = factc * im * mr * pinm(n)
    factt = factc * taunm(n)
    c(k)      = - factp * et - factt * ep
    c(Nmax+k) = - im * (factt * et - factp * ep)
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine PWcoefficientsPARTSUBtrans
! **********************************************************************************
subroutine Fresnel_aer_sub (cosb0, m, Rpar, Rperp, Tpar, Tperp, cosb, sinb)
  use parameters
  use derived_parameters
  implicit none
  complex(O) :: cosb0, sinb0, m, Rpar, Rperp, Tpar, Tperp, cosb, sinb
!
  sinb0 = sqrt(1._O - cosb0**2)
  sinb  = sinb0 / m
  cosb  = sqrt(1._O - sinb**2)
  if (aimag(m * cosb) < 0._O) cosb = - cosb
  if (abs(m * cosb0 + cosb) < MachEps) then
    print "(/,2x,'Warning in subroutine Fresnel_aer_sub in module IncCoeff:')"
    print "(  2x,'the denominator in the expression of the Fresnel reflection')"
    print "(  2x,'coefficients is smaller than the machine precision;')"
  end if
  if (abs(m * cosb0 - cosb) < MachEps) then      ! redundant
    Rpar = zero
    Tpar = 1._O / m
  else
    Rpar = (m * cosb0 - cosb) / (m * cosb0 + cosb)
    Tpar = 2._O * cosb0 / (m * cosb0 + cosb)
  end if
  if (abs(cosb0 - m * cosb) < MachEps) then      ! redundant
    Rperp = zero
    Tperp = one
  else
    Rperp = (cosb0 - m * cosb) / (cosb0 + m * cosb)
    Tperp = 2._O * cosb0 / (cosb0 + m * cosb)
  end if
end subroutine Fresnel_aer_sub
! **********************************************************************************
subroutine Fresnel_sub_aer (cosb, m, Rpar, Rperp, Tpar, Tperp, cosb0, sinb0)
  use parameters
  use derived_parameters
  implicit none
  complex(O) :: cosb, m, Rpar, Rperp, Tpar, Tperp, sinb0, cosb0, sinb
!
  sinb  = sqrt(1._O - cosb**2)
  sinb0 = m * sinb
  cosb0 = sqrt(1._O - sinb0**2)
  if (aimag(cosb0) < 0._O) cosb0 = - cosb0
  if (abs(m * cosb0 + cosb) < MachEps) then
    print "(/,2x,'Warning in subroutine Fresnel_sub_aer in module IncCoeff:')"
    print "(  2x,'the denominator in the expression of the Fresnel transmission')"
    print "(  2x,'coefficients is smaller than the machine precision;')"
  end if
  if (abs(cosb - m * cosb0) < MachEps) then      ! redundant
    Rpar = zero
    Tpar = m
  else
    Rpar = (cosb - m * cosb0) / (m * cosb0 + cosb)
    Tpar = 2._O * m * cosb / (m * cosb0 + cosb)
  end if
  if (abs(m * cosb - cosb0) < MachEps) then      ! redundant
    Rperp = zero
    Tperp = one
  else
    Rperp = (m * cosb - cosb0) / (cosb0 + m * cosb)
    Tperp = 2._O * m * cosb / (cosb0 + m * cosb)
  end if
end subroutine Fresnel_sub_aer
! **********************************************************************************
subroutine GBcoefficients_ab (wavenumber, x0, y0, z0, w0, thetaGI, phiGI, alpha,    &
           beta, gamma, alphap, Mrank, Nrank, Nmax, c)
!------------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a Gaussian beam for the        !
! azimuthal modes m = 0,1,...,Mrank.  Note that x0, y0, z0 are the coordinates of   !
! the beam focal point with respect to a global coordinate system (having the same  !
! origin as the particle coordinate system).                                        !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax
  real(O)    :: wavenumber, x0, y0, z0, w0, thetaGI, phiGI, alpha, beta, gamma,     &
                alphap
  complex(O) :: c(2*Nmax)
!
  integer    :: m, Nmaxl, k, N0, l, ml
  complex(O),allocatable :: cl(:)
!
  do m = 0, Mrank
    if (m == 0) then
      Nmaxl = Nrank
      allocate (cl(2*Nmaxl))
      call GBcoefficients_ab_m (wavenumber, x0, y0, z0, w0, thetaGI, phiGI, alpha,  &
           beta, gamma, alphap, m, Nmaxl, cl)
      do k = 1, Nmaxl
        c(k)      = cl(k)
        c(Nmax+k) = cl(k+Nmaxl)
      end do
      deallocate (cl)
    else
      N0    = Nrank + (m - 1) * (2 * Nrank - m + 2)
      Nmaxl = Nrank - m + 1
      allocate (cl(2*Nmaxl))
      ml = m
      do l = 1, 2
        call GBcoefficients_ab_m (wavenumber, x0, y0, z0, w0, thetaGI, phiGI,       &
             alpha, beta, gamma, alphap, ml, Nmaxl, cl)
        do k = 1, Nmaxl
          c(N0+k)      = cl(k)
          c(Nmax+N0+k) = cl(k+Nmaxl)
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
      deallocate (cl)
    end if
  end do
end subroutine GBcoefficients_ab
! **********************************************************************************
subroutine GBcoefficients_ab_m (wavenumber, x0, y0, z0, w0, thetaGI, phiGI, alpha,  &
           beta, gamma, alphap, m, Nmax, c)
!------------------------------------------------------------------------------------
! The routine computes the expansion coefficients of a Gaussian beam for the        !
! azimuthal mode m. Note that x0, y0, z0 are the coordinates of the beam focal point!
! with respect to a global coordinate system (having the same origin as the         !
! particle coordinate system).                                                      !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nmax
  real(O)    :: wavenumber, x0, y0, z0, w0, thetaGI, phiGI, alpha, beta, gamma,     &
                alphap
  complex(O) :: c(2*Nmax)
!
  integer    :: k, n, m1, p
  real(O)    :: xpG, ypG, zpG, xpL, ypL, zpL
  complex(O) :: suma, sumb
  complex(O),allocatable :: a(:), b(:), d(:)
!
  xpG = - x0
  ypG = - y0
  zpG = - z0
  call T_cartesian_global_local (xpG, ypG, zpG, phiGI, thetaGI, alphap, xpL, ypL, zpL)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    allocate (a(2*n+1), b(2*n+1), d(2*n+1))
    call GBcoefficients_ab_local (wavenumber, xpL, ypL, zpL, w0, n, a, b)
    call product_rotcoefficients (thetaGI, phiGI, alpha, beta, gamma, alphap, m, n, d)
    suma = zero
    sumb = zero
    do m1 = 0, n
      if (m1 == 0) then
        suma = suma + a(1) * d(1)
        sumb = sumb + b(1) * d(1)
      else
        p    = 2 * m1
        suma = suma + a(p) * d(p) + a(p+1) * d(p+1)
        sumb = sumb + b(p) * d(p) + b(p+1) * d(p+1)
      end if
    end do
    c(k)     = suma
    c(k+Nmax)= sumb
    deallocate (a, b, d)
  end do
end subroutine GBcoefficients_ab_m
! **********************************************************************************
subroutine product_rotcoefficients (thetaGI, phiGI, alpha, beta, gamma, alphap,     &
           m, n, d)
  use parameters
  implicit none
  integer     :: m, n
  real(O)     :: thetaGI, phiGI, alpha, beta, gamma, alphap
  complex(O)  :: d(2*n+1)
!
  integer     :: m1, m2, k
  complex(O)  :: sum, Dnm1m2, Dnm2m, coef_rotation
!
  do m1 = 0, n
    if (m1 == 0) then
      sum = zero
      do m2 = - n, n
        Dnm1m2 = coef_rotation (- alphap, - thetaGI, - phiGI, n, m1, m2)
        Dnm2m  = coef_rotation (  alpha, beta, gamma, n, m2, m)
        sum    = sum + Dnm1m2 * Dnm2m
      end do
      d(1) = sum
    else
      k = 2 * m1
!     --- m1 > 0 ---
      sum = zero
      do m2 =  - n, n
        Dnm1m2 = coef_rotation (- alphap, - thetaGI, - phiGI, n, m1, m2)
        Dnm2m  = coef_rotation ( alpha, beta, gamma, n, m2, m)
        sum    = sum + Dnm1m2 * Dnm2m
      end do
      d(k) = sum
!     --- m1 < 0 ---
      sum = zero
      do m2 = - n, n
        Dnm1m2 = coef_rotation (- alphap, - thetaGI, - phiGI, n, - m1, m2)
        Dnm2m  = coef_rotation ( alpha, beta, gamma, n, m2, m)
        sum    = sum + Dnm1m2 * Dnm2m
      end do
      d(k+1) = sum
    end if
  end do
end subroutine product_rotcoefficients
! **********************************************************************************
subroutine GBcoefficients_ab_local (wavenumber, x0, y0, z0, w0, n, a, b)
  use parameters
  use derived_parameters
  implicit none
  integer     :: n
  real(O)     :: wavenumber, x0, y0, z0, w0
  complex(O)  :: a(2*n+1), b(2*n+1)
!
  integer     :: m, k
  real(O)     :: l, ro0, phi0, ron, argz, argpm, argpp, sig, w02, dz
  complex(O)  :: Q, PSI, arg, fact, Kcor, factz, factm, factp, imQ, dzc
  complex(O),allocatable :: Jbes(:)
!
  if (abs(w0) < MachEps) then
    print "(/,2x,'Warning in subroutine GBcoefficients_ab_local in module IncCoeff:')"
    print "(  2x,'the waist radius of the Gaussian beam is smaller than the machine')"
    print "(  2x,'precision;')"
  end if
  l   = wavenumber * w0 * w0
  dz  = 2._O * z0 / l
  dzc = cmplx(dz,0.0,O)
  Q   = 1._O / (im - dzc)
  ro0 = sqrt(x0 * x0 + y0 * y0)
  if (ro0 < MachEps) then
    phi0 = 0._O
  else
    phi0 = atan2(y0,x0)
    if (phi0 < 0._O) phi0 = 2._O * Pi + phi0
  end if
  ron = (real(n,O) + 0.5_O) / wavenumber
  w02 = w0 * w0
  imQ = im * Q
  PSI = imQ * exp(-imQ * (ro0 * ro0 + ron * ron) / w02)
  arg = 2._O * Q * ro0 * ron / w02
  allocate (Jbes(0:n+1))
  call bes_J (arg, n + 1, Jbes)
  argz  = wavenumber * z0
  factz = exp(im * argz)
  do m = 0, n
    if (m == 0) then
      fact =   2._O * factz * Jbes(1) * Kcor(m,n) * PSI
      a(1) = - cos(phi0) * fact
      b(1) =   im * sin(phi0) * fact
    else
      k     = 2 * m
      argpm = real(m - 1,O) * phi0
      argpp = real(m + 1,O) * phi0
      fact  = factz * Kcor(m,n) * PSI
!     --- m > 0 ---
      factm = exp(im * argpm) * Jbes(m-1)
      factp = exp(im * argpp) * Jbes(m+1)
      a(k)  = fact * (factm - factp)
      b(k)  = fact * (factm + factp)
!     --- m < 0 ---
      sig    = (- 1._O)**(m - 1)
      factm  = sig * exp(- im * argpm) * Jbes(m-1)
      factp  = sig * exp(- im * argpp) * Jbes(m+1)
      a(k+1) = fact * (factp - factm)
      b(k+1) = fact * (factp + factm)
    end if
  end do
  deallocate (Jbes)
end subroutine GBcoefficients_ab_local
! **********************************************************************************
function Kcor (m, n) result (K)
  use parameters
  implicit none
  integer      :: m, n
  complex(O)   :: K
!
  integer      :: p
  real(O)      :: fact, sum, lnx
!
  if (m == 0) then
    fact = 2._O * sqrt(real(n * (n + 1),O) / real(2 * n + 1,O))
    K    = im**n * fact
  else
    sum = 0._O
    do p = 1, 2 * abs(m)
      sum = sum + log(real(n - abs(m) + p,O))
    end do
    lnx = real(abs(m) - 1,O) * log(2._O / real(2 * n + 1,O))
    lnx = lnx + 0.5_O * (log(real(2 * n + 1,O)) - log(real(n * (n + 1),O)) + sum)
    K   = im**(n + abs(m)) * (-1._O)**abs(m) * exp(lnx)
  end if
end function Kcor


      program z2zi
      real z(9999),zi(0:9999)
c
c     convert z-points to z-cells
c
c     z  on stdin
c     zi on stdout
c
      do k= 1,9999
        read(5,*,end=100) z(k)
      enddo
  100 continue
      kz = k-1
c
c     assume that cell thickness increases with depth,
c     and that we would like z to be at the center of the zi's.
c
      zi(0) =      0.0
      zi(2) =      0.5*(z(2)+z(3))
      zi(1) = max( 0.5*(z(1)+z(2)),
     &             2.0* z(2)-zi(2) )
      do k= 3,kz-1
        zi(k) = min( 2.0* z(k)-zi(k-1),
     &               0.5*(z(k)+z(k+1)) )
      enddo
      zi(kz) = z(kz) + (z(kz) - zi(kz-1))
c
      write(6,"(f12.4)") zi(0)
      do k= 1,kz
        write(6,"(3f12.4)") zi(k),z(k),0.5*(zi(k)+zi(k-1))
      enddo
      end


SUBROUTINE random_wave_coefficients(i_spec, nt, beta0, dt, dx, Tp, Hs, depth, &
     grav, inc_wave_file, kh_max, seed, seed2, eta0, beta, s0, &
     n_cut,gamma_jonswap)
  !-----------------------------------------------------------------------
  !
  ! Build the coefficients for a pseudo-random 3D wave with direction BETA0 to the
  ! x-axis, over NT time steps at tim-step DT.  The water depth at the wavemaker
  ! is DEPTH.  The wave can be based on a long-crested P-M (i_spec=30) or
  ! JONSWAP (ispec=31) spectrum at angle BETA0 to the x-axis, or it can be
  ! a JONSWAP with NORMAL directional spreading about the angle BETA0 (i_spec=33).
  ! The coefficients are returned in ETA0 ready to be moved around in space and
  ! FFT'ed by the subroutine random_wave_signal_3D.f90.
  !
  ! When i_spec=-30, a mono-chromatic wave is generated with period Tp,
  ! height Hs and angle BETA0; so nothing is done here.
  !
  !----------------------------------------------------------------------
  IMPLICIT none
  CHARACTER(len=30) inc_wave_file, header
  integer, parameter :: long=selected_real_kind(12,99)
  integer i, i_spec, seed, seed2, nt, n_cut
  real(kind=long) :: Tp, Hs, dt, depth, grav, kh_max, dx, s0, gamma_jonswap
  real(kind=long) :: eta0(nt), beta(nt)

  ! Local variables
  integer :: ndat
  real(kind=long) :: factor, domega, beta0, spec, zero=0._long,  one=1._long, &
       two=2._long, pi, twopi, dt_inc
  !
  ! Some parameters
  !
  pi=acos(-one)
  twopi=two*pi
  !
  !
  ! Generate the random wave.
  !
  ! The FT factor.
  !
  factor = two/nt
  !
  ! The Fourier coefficients are built based on SI dimensional numbers.  Omega is
  ! radian frequency.
  !
  domega = twopi / (nt * dt)
  !
  !
  ! Generate the Fourier components of the wave elevation at the wavemaker.
  ! Note that the same spectral and time parameters, and SEED values always give
  ! the same coefficients.
  !
  ! Initialize the heading angle vector
  beta=beta0
  !
  IF(i_spec==0 .or. i_spec==30)THEN
     ! A long-crested P-M spectrum
     CALL build_coeff(eta0, nt, Hs, Tp, dt, seed, seed2, 0)
  ELSEIf(i_spec==1 .or. i_spec==31 .or. i_spec==3)THEN
     ! A long-crested JONSWAP spectrum
     CALL build_coeff(eta0, nt, Hs, Tp, dt, seed, seed2, 1,gamma_jonswap)
  ELSEIF(i_spec==33)THEN
     ! A JONSWAP spectrum with a normal spreading
     CALL build_coeff_3D(eta0, beta, nt, Hs, Tp, dt, seed, seed2, beta0, gamma_jonswap)
  ELSEIF(i_spec==34)THEN
     ! A JONSWAP spectrum with a cos^s spreading
     CALL build_coeff_3D_Cos(eta0, beta, nt, Hs, Tp, dt, seed, seed2, beta0, s0, gamma_jonswap)
  ELSEIF(i_spec == 2) THEN
     open(21,file=inc_wave_file,status='old')
     READ(21,'(A)',err=15)header
     READ(21,*)dt_inc
     IF(ABS(dt-dt_inc)>1.e-6)THEN
        print *, 'random_wave_signal.f90: The .inp and .iwf time steps do not agree.'
        print *, header
        print *, dt,dt_inc
        stop
     END IF
     do i=1,nt
        READ(21,*,end=13)eta0(i)
     end do
     go to 14
13   ndat=i-1
     print *, ' Found ',ndat,' data points in the incident wave file.  Padding with zeros up to ',nt
     do i=ndat+1,nt
        eta0(i)=zero
     end do
     go to 14
15   print *, 'random_wave_signal.f90: No header line in the .iwf'
     stop
14   CLOSE(21)
     CALL drealft (eta0, nt, 1)
     !
     ! Scale the FFT
     !
     eta0=eta0*factor

  ELSEIF(i_spec<0)THEN
     ! Mono-chromatic waves, nothing to do here.
     RETURN
  END IF
  !
  ! We truncate the spectrum at k_max.
  !
  n_cut=nint(sqrt(grav*kh_max/depth*tanh(kh_max))/domega)+1
  Print *, 'Truncating the spectrum at T=',twopi/((n_cut-1)*domega), &
       ' which corresponds to kh=',kh_max
  print *, 'The deep water resolution of this wave is ',2*pi*depth/(kh_max*dx)+one, &
       ' points per wavelength.'
  Print *, ' '
  eta0(2*n_cut-1:nt)=zero
  !
  !Print out the wave maker elevation.
  !
  CALL drealft (eta0, nt, -1)

  open(21,file='eta0_irregular',status='unknown')
  IF(i_spec==30)THEN
     write(21,32)Hs,Tp,twopi/((n_cut-1)*domega),kh_max,beta0
31   format('% P-M spectrum H_s=',e12.4,' T_p=',e12.4,' truncated at T=',e12.4,&
          ' which is kh=',e12.4,'.  Heading angle is ,',f10.2)
  ELSEIF(i_spec==31)THEN
     write(21,32)Hs,Tp,twopi/((n_cut-1)*domega),kh_max,beta0
32   format('% JONSWAP spectrum H_s=',e12.4,' T_p=',e12.4,' truncated at T=',e12.4,&
          ' which is kh=',e12.4,'.  Heading angle is ,',f10.2)
  ELSEIF(i_spec==33)THEN
     write(21,33)Hs,Tp,twopi/((n_cut-1)*domega),kh_max,beta0
33   format('% JONSWAP with NORMAL spreading H_s=',e12.4,' T_p=',e12.4, &
          ' truncated at T=',e12.4,&
          ' which is kh=',e12.4,'.  Heading angle is ,',f10.2)
  END IF
  do i=1,nt
     write(21,*)(i-1)*dt,eta0(i)
  end do
  close(21)
  !
  ! FFT back to the coefficients and print them out
  !
  CALL drealft (eta0, nt, 1)
  eta0=eta0*factor
  open(21,file='eta0_coeffs',status='unknown')
  write(21,34)
34 format('# f [Hz], mag(c), c_r, c_i')
  write(21,35)zero,eta0(1),eta0(1),eta0(2)
35 format(4e16.5)
  do i=3,nt-1,2
     write(21,35) (i-1)/2 * domega/twopi, sqrt(eta0(i)**2+eta0(i+1)**2),eta0(i),eta0(i+1)
  end do
  close(21)

RETURN
END SUBROUTINE random_wave_coefficients


      REAL FUNCTION MODSEP (PERIOD, A, B)

C  Given a period and two values, a and b, modsep calculates the
C  absolute value of the smallest "distance" between the values,
C  treating them as points on a circle with circumference of size =
C  period.  For example, if period=360, as for degree-measure,
C  modsep of 5 and 15 would of course be 10, but so would modsep of
C  5 and 355, or 0 and 710, or 0 and 730.

      REAL PERIOD, A, B, AM,BM, ABDIF

      IF (PERIOD .EQ. 0.0) THEN
         MODSEP = 0.0
         RETURN
      ENDIF

C get normalized mod-values - correct for loopy way Fortran
C mods negative numbers.
      AM = MOD (A,PERIOD)
      IF (A.LT.0) AM = AM+PERIOD
      BM = MOD (B,PERIOD)
      IF (B.LT.0) BM = BM+PERIOD
C now:   0 .le. am,bm  .lt. period

      ABDIF = ABS(AM-BM)
      MODSEP = MIN (ABDIF, PERIOD-ABDIF)

      END


REAL Nsr, Nolr, clearSkySolarRadiation, averageT, surfaceEmissivity, cloudCoverFactor
Nsr = (1 - albedoCoefficient) * solarRadiation
clearSkySolarRadiation = (0.75 + 2 * (10**-5) * elevation) * extraSolarRadiation
averageT = ((maxTair + 273.16)**4) + ((minTair + 273.16)**4)) / 2
surfaceEmissivity = (0.34 - 0.14 * SQRT(vaporPressure / 10))
cloudCoverFactor = (1.35 * (solarRadiation / clearSkySolarRadiation) - 0.35)
Nolr = stefanBoltzman * averageT * surfaceEmissivity * cloudCoverFactor
netRadiation = Nsr - Nolr
netOutGoingLongWaveRadiation = Nolr
netRadiationEquivalentEvaporation = netRadiation / lambdaV * 1000;


module coordinates
  !!********************************************************
  !*
  !*    DESCRIPTION: ! This module contains functions to transform betwen llh, xyz, and sch
  !*
  !*    FUNCTION LIST: radar_to_xyz, rdir, reast, rnorth, latlon
  !*            convert_sch_to_xyz
  !*
  !!*********************************************************
  use linalg
  use fortranUtils
  implicit none

  ! declare data types
  type :: ellipsoid
     real*8 r_a         ! semi-major axis
     real*8 r_e2                ! eccentricity-squared of earth ellipsoid
  end type ellipsoid

  type :: pegpoint
     real*8 r_lat               ! peg latitude
     real*8 r_lon               ! peg longitude
     real*8 r_hdg               ! peg heading
  end type pegpoint

  type :: pegtrans
     real*8 r_mat(3,3)  !transformation matrix SCH->XYZ
     real*8 r_matinv(3,3)       !transformation matrix XYZ->SCH
     real*8 r_ov(3)     !Offset vector SCH->XYZ
     real*8 r_radcur    !peg radius of curvature
  end type pegtrans

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !! SUBROUTINES & FUNCTIONS
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains
  subroutine radar_to_xyz(elp,peg,ptm,height)
    !c****************************************************************
    !c**
    !c**        FILE NAME: radar_to_xyz.f
    !c**
    !c**     DATE WRITTEN:1/15/93
    !c**
    !c**     PROGRAMMER:Scott Hensley
    !c**
    !c**        FUNCTIONAL DESCRIPTION: This routine computes the transformation
    !c**     matrix and translation vector needed to get between radar (s,c,h)
    !c**     coordinates and (x,y,z) WGS-84 coordinates.
    !c**
    !c**     ROUTINES CALLED: latlon,rdir
    !c**
    !c**     NOTES: none
    !c**
    !c**     UPDATE LOG:
    !c**
    !c*****************************************************************

    ! input/output variables
    type(ellipsoid), intent(in) :: elp
    type(pegpoint), intent(in) :: peg
    type(pegtrans), intent(out) :: ptm

    real*8, intent(in), optional :: height

    ! local variables
    integer i,j,i_type
    real*8 r_radcur,r_llh(3),r_p(3),r_slt,r_clt,r_clo,r_slo,r_up(3)
    real*8 r_chg,r_shg
    real*8 r_height

    ! processing steps
    !Check if the height is given
    if (present(height)) then
        r_height = height
    else
        r_height = 0.0d0
    endif

    ! first determine the rotation matrix
    r_clt = cos(peg%r_lat)
    r_slt = sin(peg%r_lat)
    r_clo = cos(peg%r_lon)
    r_slo = sin(peg%r_lon)
    r_chg = cos(peg%r_hdg)
    r_shg = sin(peg%r_hdg)

    ptm%r_mat(1,1) = r_clt*r_clo
    ptm%r_mat(1,2) = -r_shg*r_slo - r_slt*r_clo*r_chg
    ptm%r_mat(1,3) = r_slo*r_chg - r_slt*r_clo*r_shg
    ptm%r_mat(2,1) = r_clt*r_slo
    ptm%r_mat(2,2) = r_clo*r_shg - r_slt*r_slo*r_chg
    ptm%r_mat(2,3) = -r_clo*r_chg - r_slt*r_slo*r_shg
    ptm%r_mat(3,1) = r_slt
    ptm%r_mat(3,2) = r_clt*r_chg
    ptm%r_mat(3,3) = r_clt*r_shg

    do i=1,3
       do j=1,3
          ptm%r_matinv(i,j) = ptm%r_mat(j,i)
       enddo
    enddo

    ! find the translation vector
    ptm%r_radcur = rdir(elp%r_a,elp%r_e2,peg%r_hdg,peg%r_lat) + r_height

    i_type = 1
    r_llh(1) = peg%r_lat
    r_llh(2) = peg%r_lon
    r_llh(3) = r_height
    call latlon(elp,r_p,r_llh,i_type)

    r_clt = cos(peg%r_lat)
    r_slt = sin(peg%r_lat)
    r_clo = cos(peg%r_lon)
    r_slo = sin(peg%r_lon)
    r_up(1) = r_clt*r_clo
    r_up(2) = r_clt*r_slo
    r_up(3) = r_slt

    do i=1,3
       ptm%r_ov(i) = r_p(i) - ptm%r_radcur*r_up(i)
    enddo
  end subroutine radar_to_xyz

  !c****************************************************************
  !c       Various curvature functions
  !c****************************************************************
  !c**
  !c**  FILE NAME: curvature.f
  !c**
  !c**     DATE WRITTEN: 12/02/93
  !c**
  !c**     PROGRAMMER:Scott Hensley
  !c**
  !c**  FUNCTIONAL DESCRIPTION: This routine computes the curvature for
  !c**     of various types required for ellipsoidal or spherical earth
  !c**     calculations.
  !c**
  !c**     ROUTINES CALLED: none
  !c**
  !c**     NOTES: none
  !c**
  !c**     UPDATE LOG:
  !c**
  !c*****************************************************************
  real*8 function rdir(r_a,r_e2,r_hdg,r_lat)
    real*8, intent(in) :: r_a,r_e2,r_lat,r_hdg
    real*8 :: r_re, r_rn
    r_re = reast(r_a,r_e2,r_lat)
    r_rn = rnorth(r_a,r_e2,r_lat)
    rdir = (r_re*r_rn)/(r_re*cos(r_hdg)**2 + r_rn*sin(r_hdg)**2)
  end function rdir

  real*8 function reast(r_a,r_e2,r_lat)
    real*8, intent(in) ::  r_a,r_e2,r_lat
    reast = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2)
  end function reast

  real*8 function rnorth(r_a,r_e2,r_lat)
    real*8, intent(in) ::  r_a,r_e2,r_lat
    rnorth = (r_a*(1.d0 - r_e2))/(1.d0 - r_e2*sin(r_lat)**2)**(1.5d0)
  end function rnorth

  subroutine latlon(elp,r_v,r_llh,i_type)
    !c****************************************************************
    !c**
    !c**   FILE NAME: latlon.f
    !c**
    !c**   DATE WRITTEN:7/22/93
    !c**
    !c**   PROGRAMMER:Scott Hensley
    !c**
    !c**   FUNCTIONAL DESCRIPTION:This program converts a vector to
    !c**   lat,lon and height above the reference ellipsoid or given a
    !c**   lat,lon and height produces a geocentric vector.
    !c**
    !c**   ROUTINES CALLED:none
    !c**
    !c**   NOTES: none
    !c**
    !c**   UPDATE LOG:
    !c**
    !c****************************************************************

    ! input/output variables
    integer, intent(in) :: i_type          !1=lat,lon to vector,2= vector to lat,lon
    type(ellipsoid), intent(in) :: elp
    real*8, intent(inout), dimension(3) :: r_v      !geocentric vector (meters)
    real*8, intent(inout), dimension(3) :: r_llh    !latitude (deg -90 to 90),
    !longitude (deg -180 to 180),height

    ! local variables
    integer i_ft
    real*8 r_re,r_q2,r_q3,r_b,r_q
    real*8 r_p,r_tant,r_theta,r_a,r_e2
    real*8  pi, r_dtor

    pi = getPi()
    r_dtor = pi/180.d0

    ! processing steps
    r_a = elp%r_a
    r_e2 = elp%r_e2

    if(i_type .eq. 1)then  !convert lat,lon to vector
       r_re = r_a/sqrt(1.d0 - r_e2*sin(r_llh(1))**2)
       r_v(1) = (r_re + r_llh(3))*cos(r_llh(1))*cos(r_llh(2))
       r_v(2) = (r_re + r_llh(3))*cos(r_llh(1))*sin(r_llh(2))
       r_v(3) = (r_re*(1.d0-r_e2) + r_llh(3))*sin(r_llh(1))

    elseif(i_type .eq. 2)then  !convert vector to lat,lon
       r_q2 = 1.d0/(1.d0 - r_e2)
       r_q = sqrt(r_q2)
       r_q3 = r_q2 - 1.d0
       r_b = r_a*sqrt(1.d0 - r_e2)
       r_llh(2) = atan2(r_v(2),r_v(1))
       r_p = sqrt(r_v(1)**2 + r_v(2)**2)
       r_tant = (r_v(3)/r_p)*r_q
       r_theta = atan(r_tant)
       r_tant = (r_v(3) + r_q3*r_b*sin(r_theta)**3)/(r_p - r_e2*r_a*cos(r_theta)**3)
       r_llh(1) =  atan(r_tant)
       r_re = r_a/sqrt(1.d0 - r_e2*sin(r_llh(1))**2)
       r_llh(3) = r_p/cos(r_llh(1)) - r_re
    endif
  end subroutine latlon

  subroutine convert_sch_to_xyz(ptm,r_schv,r_xyzv,i_type)
    !c****************************************************************
    !c**
    !c**        FILE NAME: convert_sch_to_xyz.for
    !c**
    !c**     DATE WRITTEN:1/15/93
    !c**
    !c**     PROGRAMMER:Scott Hensley
    !c**
    !c**        FUNCTIONAL DESCRIPTION: This routine applies the affine matrix
    !c**     provided to convert the sch coordinates xyz WGS-84 coordintes or
    !c**     the inverse transformation.
    !c**
    !c**     ROUTINES CALLED: latlon,matvec,lincomb
    !c**
    !c**     NOTES: none
    !c**
    !c**     UPDATE LOG:
    !c**
    !c*****************************************************************

    ! input/output variables
    type(pegtrans), intent(in) :: ptm
    real*8, intent(inout) :: r_schv(3)              !sch coordinates of a point
    real*8, intent(inout) ::  r_xyzv(3)              !WGS-84 coordinates of a point
    integer, intent(in) :: i_type       !i_type = 0 sch => xyz ;
    !i_type = 1 xyz => sch

    ! local variables
    integer i_t
    real*8 r_schvt(3),r_llh(3)
    type(ellipsoid) :: sph

    ! processing steps

    ! compute the linear portion of the transformation
    sph%r_a = ptm%r_radcur
    sph%r_e2 = 0.0d0

    if(i_type .eq. 0) then
       r_llh(1) = r_schv(2)/ptm%r_radcur
       r_llh(2) = r_schv(1)/ptm%r_radcur
       r_llh(3) = r_schv(3)
       i_t = 1
       call latlon(sph,r_schvt,r_llh,i_t)
       call matvec(ptm%r_mat,r_schvt,r_xyzv)
       call lincomb(1.d0,r_xyzv,1.d0,ptm%r_ov,r_xyzv)
    elseif(i_type .eq. 1)then
       call lincomb(1.d0,r_xyzv,-1.d0,ptm%r_ov,r_schvt)
       call matvec(ptm%r_matinv,r_schvt,r_schv)
       i_t = 2
       call latlon(sph,r_schv,r_llh,i_t)
       r_schv(1) = ptm%r_radcur*r_llh(2)
       r_schv(2) = ptm%r_radcur*r_llh(1)
       r_schv(3) = r_llh(3)
    end if
  end subroutine convert_sch_to_xyz

end module coordinates


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                mnconc : concur test program                        cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(62),w(31),u(31),t(50),c(100),wrk(1400),xx(62),db(6),de(6),
     * cp(24),dd(12),sp(62)
      integer iwrk(50)
      real ai,atan,del,fp,pi,s,sigma,ww
      integer i,ib,idim,ie,ier,iopt,is,i1,i2,j,j1,k,kk,k1,l,lwrk,l1,l2,
     * m,mx,n,nb,nc,ndd,ne,nest,nk1,np
c  the data absciss values
      data x(1),x(3),x(5),x(7),x(9),x(11),x(13),x(15),x(17),x(19),x(21),
     * x(23),x(25),x(27),x(29),x(31),x(33),x(35),x(37),x(39),x(41),
     * x(43),x(45),x(47),x(49),x(51),x(53),x(55),x(57),x(59),x(61)/
     * -3.109,-2.188,-1.351,-0.605,0.093,0.451,0.652,0.701,0.518,0.277,
     * 0.008,-0.291,-0.562,-0.679,-0.637,-0.425,-0.049,0.575,1.334,
     * 2.167,3.206,4.099,4.872,5.710,6.330,6.741,6.928,6.965,6.842,
     * 6.593,6.269/
c  the data ordinate values
      data x(2),x(4),x(6),x(8),x(10),x(12),x(14),x(16),x(18),x(20),
     * x(22),x(24),x(26),x(28),x(30),x(32),x(34),x(36),x(38),x(40),
     * x(42),x(44),x(46),x(48),x(50),x(52),x(54),x(56),x(58),x(60),
     * x(62)/3.040,2.876,2.634,2.183,1.586,1.010,0.382,-0.218,-0.632,
     * -0.879,-0.981,-0.886,-0.642,-0.195,0.373,1.070,1.607,2.165,2.618,
     * 2.905,2.991,2.897,2.615,2.164,1.617,0.977,0.383,-0.194,-0.665,
     * -0.901,-1.010/
c  m denotes the number of data points
      m = 31
c  set up the parameter values for the data points
      pi = atan(1.0)*4.0
      del =pi*0.1
      do 10 i=1,m
         ai = i-11
         u(i) = ai*del
  10  continue
c  the weights are taken as 1/sigma with sigma an estimate of the
c  standard deviation of the data points.
      sigma = 0.04
      ww = 1./sigma
      do 20 i=1,m
        w(i) = ww
  20  continue
c  accordingly, the smoothing factor is chosen as s = m
      s = m
c  we have a planar curve  x = sx(u) , y = sy(u)
      idim = 2
c  begin point derivatives of the curve
      db(1) = -pi
      db(2) = 3.0
      db(3) = 3.0
      db(4) = 0.
      db(5) = 0.
      db(6) = -2.0
c  end point derivatives of the curve
      de(1) = pi*2.0
      de(2) = -1.0
      de(3) = -1.0
      de(4) = 0.
      de(5) = 0.
      de(6) = 2.0
c  we set up the dimension information.
      ndd = 12
      np = 24
      nb = 6
      ne = 6
      nest = 50
      lwrk = 1400
      nc = 100
      mx = 62
c  for the first approximations we will use cubic splines.
      k = 3
c  loop for the different spline curves
      do 500 is=1,7
         go to (110,120,130,140,150,160,170), is
c  no derivative constraints
 110     iopt = 0
         ib = 0
         ie = 0
         go to 200
c  fixed end points.
 120     iopt = 0
         ib = 1
         ie = 1
         go to 200
c  first derivative constraint at the end point
 130     iopt = 0
         ib = 2
         ie = 1
         go to 200
c  first derivative constraints at begin and end point.
 140     iopt = 0
         ib = 2
         ie = 2
         go to 200
c  we choose quintic splines with second derivative constraints.
 150     iopt = 0
         k = 5
         ib = 3
         ie = 3
         go to 200
c  we choose another s-value and continue with the set of knots found at
c  the last call of concur.
 160     iopt = 1
         s = 26.
         go to 200
c  finally we also calculate a least-squares curve with specified knots
 170     iopt = -1
         j = k+2
         do 180 l=1,5
            ai = l-2
            t(j) = ai*pi*0.5
            j = j+1
 180     continue
         n = 7+2*k
c  determination of the spline curve.
 200     call concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,
     *    nest,n,t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier)
c  printing of the results.
         if(iopt.ge.0) go to 210
         write(6,910) k
         go to 220
 210     write(6,915) k
         write(6,920) s
 220     write(6,925) ib,ie
         write(6,930) fp,ier
         write(6,935) n
         write(6,940)
         write(6,945) (t(i),i=1,n)
         nk1 = n-k-1
         write(6,950)
         write(6,945) (c(l),l=1,nk1)
         write(6,955)
         i1 = n+1
         i2 = n+nk1
         write(6,945) (c(l),l=i1,i2)
c  calculate derivatives at the begin point.
         k1 = k+1
         kk = k1/2
         call cualde(idim,t,n,c,nc,k1,u(1),dd,ndd,ier)
         write(6,960)
         do 300 i=1,kk
            l = i-1
            l1 = l*idim+1
            l2 = l1+1
            write(6,970) l,dd(l1),dd(l2)
 300     continue
c  calculate derivatives at the end point.
         call cualde(idim,t,n,c,nc,k1,u(m),dd,ndd,ier)
         write(6,965)
         do 350 i=1,kk
            l = i-1
            l1 = l*idim+1
            l2 = l1+1
            write(6,970) l,dd(l1),dd(l2)
 350     continue
c  we evaluate the spline curve
         call curev(idim,t,n,c,nc,k,u,m,sp,mx,ier)
         write(6,975)
         do 400 i=1,5
           l = (i-1)*12+3
           l1 = l+1
           j = l+6
           j1 = j+1
           write(6,980) x(l),x(l1),sp(l),sp(l1),x(j),x(j1),sp(j),sp(j1)
 400     continue
 500  continue
      stop
 910  format(31h0least-squares curve of degree ,i1)
 915  format(27h0smoothing curve of degree ,i1)
 920  format(20h smoothing factor s=,f5.0)
 925  format(37h number of derivative constraints ib=,i2,5x,3hie=,i2)
 930  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i2)
 935  format(1x,24htotal number of knots n=,i3)
 940  format(1x,22hposition of the knots )
 945  format(5x,8f8.4)
 950  format(1x,30hb-spline coefficients of sx(u))
 955  format(1x,30hb-spline coefficients of sy(u))
 960  format(1x,30hderivatives at the begin point)
 965  format(1x,28hderivatives at the end point)
 970  format(5x,6horder=,i2,2f9.4)
 975  format(1h0,2(4x,2hxi,7x,2hyi,6x,6hsx(ui),3x,6hsy(ui)))
 980  format(1h ,8f9.4)
      end


!
!
!
!
 SUBROUTINE HARMO_Y_L (LMAX, LON, LAT, Y_L)
 USE SHTOOLS
 IMPLICIT NONE
 INTEGER, PARAMETER :: LLMAX=512, JJMAX=(LLMAX+1)*(LLMAX+2)/2
 INTEGER J, MJ, J_INDEX, LMAX
 COMPLEX*16, PARAMETER :: I = CMPLX(0.,1.)
 COMPLEX*16 Y_L(*)
 REAL*8 LON, LAT
 REAL*8, ALLOCATABLE :: PLM(:)
 REAL*8 COSDD, SINDD
 INTEGER :: JMAX
!
!
! Given longitude LON and latitude LAT  - in degrees - this routine computes
! the lambda-component of the gradient of *all* the 4-pi normalized complex
! harmonics $\cal Y_{lm}(\theta,\lambda)$, with \theta=colatitude and \lambda=
! longitude, to degree LMAX given. Uses the (modified) SHTOOLS Legendre
! functions by PlmBar (see Sbr PLMBAR_MOD_D1). - Created by GS August 8, 2008 -
!
! - Modified by GS Apr 2020 -- dynamically allocate PLM
!
!*********************************************************************
!   Modified GS on MAy 1, 2020
!
!   The routine computes "y_l = (1/sin theta)(d/dlambda) y"
!*********************************************************************
!
!
! ---- Tests the longitude and latitude bounds
  If(abs(lat)>90.) then
 	        Write(* ,*) "Error in Sbr. GRAD_LAMBDA_HARMO: Latitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 1
  elseif (lon<0.or.lon>360.) then
 	        Write(* ,*) "Error in Sbr. GRAD_LAMBDA_HARMO: Longitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 2
  Endif
!
!
! ---- Allocate temporary arrays
!
   JMAX=(LMAX+1)*(LMAX+2)/2
   ALLOCATE( PLM(JMAX) )
!
! ---- Builds the SHTOOLS Legendre functions, with Condon-Shortley phase
!
   CALL PLMBAR_MOD (LMAX, LAT, PLM)
!
!
! ---- Computes the 4-pi normalized Spherical Harmonics up to degree LMAX
!
    		do j=1, j_index(lmax,lmax)
!
       			y_l(j) = &
	                         PLM(j)*I*mj(j)* &
	                         cmplx(cosdd(float(mj(j))*lon),sindd(float(mj(j))*lon))/ &
	                         sindd(90.-lat)
!
    		enddo
!
!
! ---- Release memory
!
    DEALLOCATE( PLM )
!
END SUBROUTINE  HARMO_Y_L
!
!
!


MODULE vectors
!
!  Purpose:
!    To define a derived data type called vector, and the
!    operations which can be performed on it.  The module
!    defines 8 operations which can be performed on vectors:
!
!                  Operation                     Operator
!                  =========                     ========
!      1.  Creation from a real array               =
!      2.  Conversion to real array                 =
!      3.  Vector addition                          +
!      4.  Vector subtraction                       -
!      5.  Vector-scalar multiplication (4 cases)   *
!      6.  Vector-scalar division (2 cases)         /
!      7.  Dot product                            .DOT.
!      8.  Cross product                            *
!
!    It contains a total of 12 procedures to implement those
!    operations:  array_to_vector, vector_to_array, vector_add,
!    vector_subtract, vector_times_real, real_times_vector,
!    vector_times_int, int_times_vector, vector_div_real,
!    vector_div_int, dot_product, and cross_product.  These
!    procedures are private to the module; they can only be
!    accessed from the outside via the defined operators.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/15/06    S. J. Chapman        Original code
! 1.  12/16/06    S. J. Chapman        Modified to hide non-
!                                        essential items.
!
IMPLICIT NONE

! Declare all items to be private except for type vector and
! the operators defined for it.
PRIVATE
PUBLIC :: vector, assignment(=), operator(+), operator(-), &
          operator(*), operator(/), operator(.DOT.)

! Declare vector data type:
TYPE :: vector
   REAL :: x
   REAL :: y
   REAL :: z
END TYPE

! Declare interface operators
INTERFACE ASSIGNMENT (=)
   MODULE PROCEDURE array_to_vector
   MODULE PROCEDURE vector_to_array
END INTERFACE

INTERFACE OPERATOR (+)
   MODULE PROCEDURE vector_add
END INTERFACE

INTERFACE OPERATOR (-)
   MODULE PROCEDURE vector_subtract
END INTERFACE

INTERFACE OPERATOR (*)
   MODULE PROCEDURE vector_times_real
   MODULE PROCEDURE real_times_vector
   MODULE PROCEDURE vector_times_int
   MODULE PROCEDURE int_times_vector
   MODULE PROCEDURE cross_product
END INTERFACE

INTERFACE OPERATOR (/)
   MODULE PROCEDURE vector_div_real
   MODULE PROCEDURE vector_div_int
END INTERFACE

INTERFACE OPERATOR (.DOT.)
   MODULE PROCEDURE dot_product
END INTERFACE

! Now define the implementing functions.
CONTAINS
   SUBROUTINE array_to_vector(vec_result, array)
      TYPE (vector), INTENT(OUT) :: vec_result
      REAL, DIMENSION(3), INTENT(IN) :: array
      vec_result%x = array(1)
      vec_result%y = array(2)
      vec_result%z = array(3)
   END SUBROUTINE array_to_vector

   SUBROUTINE vector_to_array(array_result, vec_1)
      REAL, DIMENSION(3), INTENT(OUT) :: array_result
      TYPE (vector), INTENT(IN) :: vec_1
      array_result(1) = vec_1%x
      array_result(2) = vec_1%y
      array_result(3) = vec_1%z
   END SUBROUTINE vector_to_array

   FUNCTION vector_add(vec_1, vec_2)
      TYPE (vector) :: vector_add
      TYPE (vector), INTENT(IN) :: vec_1, vec_2
      vector_add%x = vec_1%x + vec_2%x
      vector_add%y = vec_1%y + vec_2%y
      vector_add%z = vec_1%z + vec_2%z
   END FUNCTION vector_add

   FUNCTION vector_subtract(vec_1, vec_2)
      TYPE (vector) :: vector_subtract
      TYPE (vector), INTENT(IN) :: vec_1, vec_2
      vector_subtract%x = vec_1%x - vec_2%x
      vector_subtract%y = vec_1%y - vec_2%y
      vector_subtract%z = vec_1%z - vec_2%z
   END FUNCTION vector_subtract

   FUNCTION vector_times_real(vec_1, real_2)
      TYPE (vector) :: vector_times_real
      TYPE (vector), INTENT(IN) :: vec_1
      REAL, INTENT(IN) :: real_2
      vector_times_real%x = vec_1%x * real_2
      vector_times_real%y = vec_1%y * real_2
      vector_times_real%z = vec_1%z * real_2
   END FUNCTION vector_times_real

   FUNCTION real_times_vector(real_1, vec_2)
      TYPE (vector) :: real_times_vector
      REAL, INTENT(IN) :: real_1
      TYPE (vector), INTENT(IN) :: vec_2
      real_times_vector%x = real_1 * vec_2%x
      real_times_vector%y = real_1 * vec_2%y
      real_times_vector%z = real_1 * vec_2%z
   END FUNCTION real_times_vector

   FUNCTION vector_times_int(vec_1, int_2)
      TYPE (vector) :: vector_times_int
      TYPE (vector), INTENT(IN) :: vec_1
      INTEGER, INTENT(IN) :: int_2
      vector_times_int%x = vec_1%x * REAL(int_2)
      vector_times_int%y = vec_1%y * REAL(int_2)
      vector_times_int%z = vec_1%z * REAL(int_2)
   END FUNCTION vector_times_int

   FUNCTION int_times_vector(int_1, vec_2)
      TYPE (vector) :: int_times_vector
      INTEGER, INTENT(IN) :: int_1
      TYPE (vector), INTENT(IN) :: vec_2
      int_times_vector%x = REAL(int_1) * vec_2%x
      int_times_vector%y = REAL(int_1) * vec_2%y
      int_times_vector%z = REAL(int_1) * vec_2%z
   END FUNCTION int_times_vector

   FUNCTION vector_div_real(vec_1, real_2)
      TYPE (vector) :: vector_div_real
      TYPE (vector), INTENT(IN) :: vec_1
      REAL, INTENT(IN) :: real_2
      vector_div_real%x = vec_1%x / real_2
      vector_div_real%y = vec_1%y / real_2
      vector_div_real%z = vec_1%z / real_2
   END FUNCTION vector_div_real

   FUNCTION vector_div_int(vec_1, int_2)
      TYPE (vector) :: vector_div_int
      TYPE (vector), INTENT(IN) :: vec_1
      INTEGER, INTENT(IN) :: int_2
      vector_div_int%x = vec_1%x / REAL(int_2)
      vector_div_int%y = vec_1%y / REAL(int_2)
      vector_div_int%z = vec_1%z / REAL(int_2)
   END FUNCTION vector_div_int

   FUNCTION dot_product(vec_1, vec_2)
      REAL :: dot_product
      TYPE (vector), INTENT(IN) :: vec_1, vec_2
      dot_product = vec_1%x*vec_2%x + vec_1%y*vec_2%y &
                  + vec_1%z*vec_2%z
   END FUNCTION dot_product

   FUNCTION cross_product(vec_1, vec_2)
      TYPE (vector) :: cross_product
      TYPE (vector), INTENT(IN) :: vec_1, vec_2
      cross_product%x = vec_1%y*vec_2%z - vec_1%z*vec_2%y
      cross_product%y = vec_1%z*vec_2%x - vec_1%x*vec_2%z
      cross_product%z = vec_1%x*vec_2%y - vec_1%y*vec_2%x
   END FUNCTION cross_product

END MODULE vectors


! -*- mode: F90; mode: font-lock; column-number-mode: true; vc-back-end: CVS -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module numbers
! ------------------------------------------------------------------------------
! Code area 9: general
! ------------------------------------------------------------------------------

!!****h* Conquest/numbers
!!  NAME
!!   numbers
!!  PURPOSE
!!   Defines various numerical constants
!!  USES
!!   datatypes
!!  AUTHOR
!!   C.M.Goringe/E.H.Hernandez/I.J.Bush/D.R.Bowler
!!  CREATION DATE
!!   Sometime between 1995 and 1999
!!  MODIFICATION HISTORY
!!   30/05/2001 dave
!!    Added ROBODoc header
!!   31/05/2001 dave
!!    Added minus_i and RCS Id tag
!!   18/03/2002 dave
!!    Added static RCS id and more to header
!!   04/07/2002 mike
!!    Added fifteen, sixteen, three_quarters and three_halves
!!   22/03/2011 L.Tong
!!    Added third
!!   2011/09/19 L.Tong
!!    Added minus_two
!!   2011/11/13 L.Tong
!!    Added eight and twelve
!!   2012/02/26 L.Tong
!!    Added minus_one, nine and ten
!!   2012/05/27 L.Tong
!!    Added RD_ERR, a tiny number that if any number N with abs(N) <
!!    RD_ERR, then N is regarded as zero.
!!   2014/08/29 L.Truflandier
!!    Added fourpi
!!  SOURCE
!!
module numbers

  use datatypes

  implicit none

  ! RCS tag for object file identification
  character(len=80), save, private :: &
       RCSid = "$Id$"

  real(double), parameter :: zero = 0.0_double
  real(double), parameter :: one = 1.0_double
  real(double), parameter :: two = 2.0_double
  real(double), parameter :: three = 3.0_double
  real(double), parameter :: four = 4.0_double
  real(double), parameter :: five = 5.0_double
  real(double), parameter :: six = 6.0_double
  real(double), parameter :: seven = 7.0_double
  real(double), parameter :: eight = 8.0_double
  real(double), parameter :: nine = 9.0_double
  real(double), parameter :: ten = 10.0_double
  real(double), parameter :: eleven = 11.0_double
  real(double), parameter :: twelve = 12.0_double
  real(double), parameter :: fifteen = 15.0_double
  real(double), parameter :: sixteen = 16.0_double
  real(double), parameter :: eighteen = 18.0_double
  real(double), parameter :: minus_one = -1.0_double
  real(double), parameter :: minus_two = -2.0_double
  real(double), parameter :: minus_four = -4.0_double
  real(double), parameter :: quarter = 0.25_double
  real(double), parameter :: half = 0.5_double
  real(double), parameter :: third = 0.33333333333333333333_double
  real(double), parameter :: three_quarters = 0.75_double
  real(double), parameter :: nine_quarters = 2.25_double
  real(double), parameter :: three_halves = 1.5_double
  real(double), parameter :: one_third = 1.0_double/3.0_double
  real(double), parameter :: two_thirds = 2.0_double/3.0_double
  real(double), parameter :: four_thirds = 4.0_double/3.0_double
  real(double), parameter :: one_sixth = 1.0_double/6.0_double
  real(double), parameter :: five_sixths = 5.0_double/6.0_double
  real(double), parameter :: seven_sixths = 7.0_double/6.0_double
  real(double), parameter :: one_ninth = 1.0_double/9.0_double
  real(double), parameter :: seven_thirtysixths = 7.0_double/36.0_double
  real(double), parameter :: pi = 3.14159265358979323846_double
  real(double), parameter :: twopi = 6.28318530717958647692_double
  real(double), parameter :: fourpi = 6.28318530717958647692_double*2.0_double
  real(double), parameter :: sqrt_pi = 1.77245385090551588192_double
  real(double), parameter :: very_small = 1.0e-8_double
  real(double), parameter :: BIG = 1.0e12_double
  ! if a abs(number) is smaller than RD_ERR then it is considered to be zero
  real(double), parameter :: RD_ERR = 1.0e-8_double

  complex(double_cplx), parameter :: minus_i = (0.0_double_cplx, -1.0_double_cplx)

end module numbers
!!***


! testprogram using Wolfer’s sunspot data (Anderson 1971)
! calculating periodogram
! find best parameter for linear reservoir of logarithmic
! periodogram

PROGRAM sunspot_test

  USE mo_kind,   only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_specan, only: periodogram, linres

  IMPLICIT NONE

  INTEGER(i4) :: i

  REAL(dp), DIMENSION(176)     :: sunspot
  REAL(dp), DIMENSION(176)     :: time
  ! REAL(dp), DIMENSION(176)     :: sun_trans
  REAL(dp), DIMENSION(176/2,2) :: output
  REAL(dp), DIMENSION(2)       :: bestpara

  logical :: isgood

  isgood = .true.

  sunspot = (/809.0_dp, 834.0_dp, 477.0_dp, 478.0_dp, 307.0_dp, 122.0_dp, 96.0_dp, &
       102.0_dp, 324.0_dp, 476.0_dp, 540.0_dp, 629.0_dp, 859.0_dp, 612.0_dp,       &
       451.0_dp, 364.0_dp, 209.0_dp, 114.0_dp, 378.0_dp, 698.0_dp, 1061.0_dp,      &
       1008.0_dp, 816.0_dp, 665.0_dp, 348.0_dp, 306.0_dp, 70.0_dp, 198.0_dp,       &
       925.0_dp, 1544.0_dp, 1259.0_dp, 848.0_dp, 681.0_dp, 385.0_dp, 228.0_dp,     &
       102.0_dp, 241.0_dp, 829.0_dp, 1320.0_dp, 1309.0_dp, 1181.0_dp, 899.0_dp,    &
       666.0_dp, 600.0_dp, 469.0_dp, 410.0_dp, 213.0_dp, 160.0_dp, 64.0_dp,        &
       41.0_dp, 68.0_dp, 145.0_dp, 340.0_dp, 450.0_dp, 431.0_dp, 475.0_dp,         &
       422.0_dp, 281.0_dp, 101.0_dp, 81.0_dp, 25.0_dp, 0.0_dp, 14.0_dp,            &
       50.0_dp, 122.0_dp, 139.0_dp, 354.0_dp, 458.0_dp, 411.0_dp, 304.0_dp,        &
       239.0_dp, 157.0_dp, 66.0_dp, 40.0_dp, 18.0_dp, 85.0_dp, 166.0_dp,           &
       363.0_dp, 497.0_dp, 625.0_dp, 670.0_dp, 710.0_dp, 478.0_dp, 275.0_dp,       &
       85.0_dp, 132.0_dp, 569.0_dp, 1215.0_dp, 1383.0_dp, 1032.0_dp, 858.0_dp,     &
       632.0_dp, 368.0_dp, 242.0_dp, 107.0_dp, 150.0_dp, 401.0_dp, 615.0_dp,       &
       985.0_dp, 1243.0_dp, 959.0_dp, 665.0_dp, 645.0_dp, 542.0_dp, 390.0_dp,      &
       206.0_dp, 67.0_dp, 43.0_dp, 228.0_dp, 548.0_dp, 938.0_dp, 957.0_dp,         &
       772.0_dp, 591.0_dp, 440.0_dp, 470.0_dp, 305.0_dp, 163.0_dp, 73.0_dp,        &
       373.0_dp, 739.0_dp, 1391.0_dp, 1112.0_dp, 1017.0_dp, 663.0_dp, 447.0_dp,    &
       171.0_dp, 113.0_dp, 123.0_dp, 34.0_dp, 60.0_dp, 323.0_dp, 543.0_dp,         &
       597.0_dp, 637.0_dp, 635.0_dp, 522.0_dp, 254.0_dp, 131.0_dp, 68.0_dp,        &
       63.0_dp, 71.0_dp, 356.0_dp, 730.0_dp, 849.0_dp, 780.0_dp, 640.0_dp,         &
       418.0_dp, 262.0_dp, 267.0_dp, 121.0_dp, 95.0_dp, 27.0_dp, 50.0_dp,          &
       244.0_dp, 420.0_dp, 635.0_dp, 538.0_dp, 620.0_dp, 485.0_dp, 439.0_dp,       &
       186.0_dp, 57.0_dp, 36.0_dp, 14.0_dp, 96.0_dp, 474.0_dp, 571.0_dp,           &
       1039.0_dp, 806.0_dp, 636.0_dp, 376.0_dp, 261.0_dp, 142.0_dp, 58.0_dp,       &
       167.0_dp/)

  time(1)=1749.0_dp

  do i = 2, 176
     time(i) = time(i-1) + 1.0_dp
  end do

  call periodogram(sunspot,output)

  write(*,*) 'printing first five values of periodogram:'

  do i = 1, 5
     write(*,*) output(i,:)
  end do

  call linres( &
       output(:,2),   & ! data(:)        Time series
       0.00000005_dp, & ! a_min          minimum of first parameter
       0.1_dp,        & ! a_max          maximum of first parameter
       0._dp,         & ! tc_min         minimum of second parameter
       100._dp,       & ! tc_max         maximum of second parameter
       0.0000005_dp,  & ! initial_a      first initial parameter
       50._dp,        & ! initial_tc     second initial parameter
       bestpara )       ! best parameter set

  write(*,*) 'best parameter found:'
  write(*,*) '   alpha:', bestpara(1)
  write(*,*) '   tc:   ', bestpara(2)

  ! check if program was running properly
  isgood = isgood .and. ( 35268373_i4 .eq. int(output(1,2),i4) )
  isgood = isgood .and. ( 1589_i4     .eq. int(output(2,2),i4) )
  isgood = isgood .and. ( 1217716_i4  .eq. int(output(3,2),i4) )
  isgood = isgood .and. ( 538747_i4   .eq. int(output(4,2),i4) )
  isgood = isgood .and. ( 245925_i4   .eq. int(output(5,2),i4) )

  isgood = isgood .and. ( 6368_i4   .eq. int(bestpara(1)*10000000.0_dp,i4) )
  isgood = isgood .and. ( 376437_i4 .eq. int(bestpara(2)*10000.0_dp,i4) )

  write(*,*) ''
  if (isgood) then
     write(*,*) 'mo_specan: ', color('o.k.', c_green)
  else
     write(*,*) 'mo_specan: ', color('failed', c_red)
  end if

END PROGRAM sunspot_test


program main
use iso_fortran_env, only: input_unit,output_unit
implicit none
integer :: n
print*,"enter an integer"
read (input_unit,*) n ! equivalent to next line
! read (*,*) n
print "(i0,'^2 = ',i0)",n,n**2 ! prints to screen
open (unit=output_unit,file="temp.txt",action="write")
! causes each line below to write to temp.txt
print "(i0,'^3 = ',i0)", n,n**3
write (*,"(i0,'^4 = ',i0)") n,n**4
write (output_unit,"(i0,'^5 = ',i0)") n,n**5
end program main
! sample run, compiling with gfortran, flang, g95,
! or ifort -standard-semantics:
!  enter an integer
! 10
! 10^2 = 100
! contents of temp.txt:
! 10^3 = 1000
! 10^4 = 10000
! 10^5 = 100000


      	program exptest
c-------------------------------------------------------------------
c
c Test program for exponential propagator using Arnoldi approach
c This main program is a very simple test using diagonal matrices
c (Krylov subspace methods are blind to the structure of the matrix
c except for symmetry). This provides a good way of testing the
c accuracy of the method as well as the error estimates.
c
c-------------------------------------------------------------------
        implicit real*8 (a-h,o-z)
        parameter (nmax = 400, ih0=60, ndmx=20,nzmax = 7*nmax)
        real*8 a(nzmax), u(ih0*nmax), w(nmax),w1(nmax),x(nmax),y(nmax)
	integer ioff(10)
	data iout/6/, a0/0.0/, b0/1.0/, epsmac/1.d-10/, eps /1.d-10/
c
c set dimension of matrix
c
	n = 100
c--------------------------- define matrix -----------------------------
c A is a single diagonal matrix (ndiag = 1 and ioff(1) = 0 )
c-----------------------------------------------------------------------
        ndiag = 1
	ioff(1) = 0
c
c-------- entries in the diagonal are uniformly distributed.
c
	h = 1.0d0 / real(n+1)
        do 1 j=1, n
	a(j) = real(j+1)* h
 1	continue
c--------
        write (6,'(10hEnter tn: ,$)')
	read (5,*) tn
c
        write (6,'(36hEpsilon (desired relative accuracy): ,$)')
	read (5,*)  eps
c-------
        write (6,'(36h m (= dimension of Krylov subspace): ,$)')
	read (5,*)  m
c-------
c define initial conditions: chosen so that solution = (1,1,1,1..1)^T
c-------
	do 2 j=1,n
	w(j) = dexp(a(j)*tn)
 2	w1(j) = w(j)
c
         call expprod (n, m, eps, tn, u, w, x, y, a, ioff, ndiag)
c
        print *, ' final answer '
        print *, (w(k),k=1,20)
c
	do 4 k=1,n
 4	w1(k) = dexp(-a(k)*tn) * w1(k)
        print *, ' exact solution '
        print *, (w1(k),k=1,20)
c
c---------- computing actual 2-norm of error ------------------
c
	t = 0.0d0
	do 47 k=1,n
 47	t = t+ (w1(k)-w(k))**2
        t = dsqrt(t / ddot(n, w,1,w,1) )
c
        write (6,*) ' final error', t
c--------------------------------------------------------------
	stop
	end
c-------
	subroutine oped(n,x,y,diag,ioff,ndiag)
c======================================================
c this kernel performs a matrix by vector multiplication
c for a diagonally structured  matrix stored in diagonal
c format
c======================================================
	implicit real*8 (a-h,o-z)
	real*8 x(n), y(n), diag(n,ndiag)
	common nope, nmvec
	integer j, n, ioff(ndiag)
CDIR$ IVDEP
	do 1 j=1, n
		y(j) = 0.00
 1	continue
c
	do 10 j=1,ndiag
	io = ioff(j)
	i1=max0(1,1-io)
	i2=min0(n,n-io)
CDIR$ IVDEP
	do 9 k=i1,i2
	y(k) = y(k)+diag(k,j)*x(k+io)
 9	continue
 10	continue
	nmvec  = nmvec + 1
	nope = nope + 2*ndiag*n
	return
	end
c


      program circle
      real PI, a, r
      parameter (PI = 3.141592)

*     This program reads a real number r and prints
*     the area of a circle with radius r

      write(*,*) "Enter the radius of your circle "
      read(*,*) r
      a = r * r * PI
      write(*,100) "Area = ", a
 100  format(A,E8.3)
      stop
      end


!
!     file thstssp.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_hstssp

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    !-----------------------------------------------
    ! Local variables
    !-----------------------------------------------
    integer(ip), parameter :: M = 18
    integer(ip), parameter :: N = 72
    integer(ip), parameter :: IDIMF = M
    integer(ip)            :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)               :: f(IDIMF,N), sint(M)
    real(wp), dimension(1) :: bda, bdc, bdd
    real(wp), dimension(N) :: sinp, bdb
    real(wp)               :: a, b, c, d, elmbda, dtheta, dphi
    real(wp)               :: pertrb
    real(wp), parameter    :: ZERO = 0.0_wp, HALF = 0.5_wp
    real(wp), parameter    :: TWO = 2.0_wp
    !-----------------------------------------------

    ! Set domain
    a = ZERO
    b = HALF_PI
    c = ZERO
    d = TWO_PI

    ! Set boundary conditions
    nbdcnd = 0
    mbdcnd = 6

    ! Set helmholtz constant
    elmbda = ZERO

    ! Set mesh sizes
    dtheta = (b - a)/M
    dphi = (d - c)/N

    ! Generate sines for use in subsequent computations
    do i = 1, M
        sint(i) = sin((real(i, kind=wp) - HALF) * dtheta)
    end do

    do j = 1, N
        sinp(j) = sin((real(j, kind=wp) - HALF) * dphi)
    end do

    ! Compute right hand side of equation and store in f
    block
        real(wp), parameter :: SIX = 6.0_wp
        do j = 1, N
            f(:, j) = TWO - SIX * (sint * sinp(j))**2
        end do
    end block
    !
    ! Set boundary data; store derivative data at the equator
    ! In our example, bda, bdc, and bdd are 1-dimensional dummy variables.
    bdb = ZERO

    ! Solve 2D Helmholtz in spherical coordinates on staggered grid
    call hstssp(a, b, M, mbdcnd, bda, bdb, c, d, N, nbdcnd, bdc, bdd, &
        elmbda, f, IDIMF, pertrb, ierror)

    ! Compute discretization error. since problem is singular, the
    ! solution must be normalized.
    block
        real(wp), parameter :: KNOWN_PERTRB = 0.635830001454109e-3_wp
        real(wp), parameter :: KNOWN_ERROR = 0.337523232257420e-2_wp
        real(wp)            :: discretization_error
        real(wp)            :: exact_solution(M,N)

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = (sint(i) * sinp(j))**2 + f(1, 1)
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:M,:N)))

        call check_output('hstssp', &
            ierror, KNOWN_ERROR, discretization_error, KNOWN_PERTRB, pertrb)
    end block

end program test_hstssp


program contacto
	implicit double	precision (a,h,l,m,o-z)

	parameter (phi=0.2d+00,per=9e-12)
	parameter (cr=1.0e-10,cf=1.0e-7)
	parameter (po=1000.0d+00,h=1.0d+00)
	parameter (nx=5,ny=5,nimax=1000,njmax=1000)

	call mesh(l,h,nx,ny,nimax,njmax)
	open (unit=10,file="prueba.txt",status="replace",action="write")
	write(unit=10)
!c	write(*,*)"phi=",phi
write(*,*)"phi=",phi
!c	write(*,*)"per=",per
write(*,*)"per=",per
!c	write(*,*)"cr=",cr
write(*,*)"cr=",cr
!c	write(*,*)"po=",po
write(*,*)"po=",po

close (unit=10)
	end
!c !comienza area de subroutines!

	subroutine mesh(l,h,nx,ny,nimax,njmax)
	implicit double precision (a,h,l,m,o-z)
	dimension x(nimax),y(njmax)

  	x(1)=0.0d+00
	x(nx)=l
	dx=l/dfloat(nx)

	do 1 i=2,nx
	x(i)=x(i)+dx
    1	continue

    y(1)=0.0d+00
	y(ny)=h
	dy=h/dfloat(ny)

	do 2 j=2,ny
	y(j)=y(j)+dy
    2	continue
    do i=1,nx
	write (*,*)"x",i,"=",x(i)
	end do

	do j=1,ny
	write (*,*)"y",j,"=",y(j)
	end do

return
end


C     FACTOR.F                                                          1
C     COPYRIGHT (C) 2020 HUGH COLEMAN                                   2
C                                                                       3
C     THIS FILE IS PART OF HUGHCOLEMAN/FORTRAN, AN ATTEMPT TO           4
C     INVESTIGATE THE FORTRAN PROGRAMMING LANGUAGE AND LEARN ABOUT THE  5
C     EARLY DAYS OF COMPUTING. IT IS RELEASED UNDER THE MIT LICENSE (SEE6
C     LICENSE.)                                                         7
                                                                        8
C     THIS IMPLEMENTS A BASIC ITERATIVE ALGORITHM TO FIND THE PRIME     9
C     FACTORS OF A GIVEN INTEGER N.                                     10
                                                                        11
 10   FORMAT ( 1I5 )                                                    12
 11   FORMAT ( 24H PRIME FACTORIZATION OF 1I5 )                         13
 12   FORMAT ( 1H 1I5 )                                                 14
                                                                        15
C     GET THE QUERIED INTEGER FROM STANDARD INPUT, IF IT IS ONE OR LESS 16
C     EXIT THE PROGRAM.                                                 17
 20   READ 10, N                                                        18
      IF (N - 1) 9999, 9999, 21                                         19
 21   PRINT 11, N                                                       20
                                                                        21
C     DIVIDE OUT AS MANY FACTORS OF TWO AS POSSIBLE                     22
      IFAC = 2                                                          23
 30   IF (XMODF(N, IFAC)) 9999, 31, 40                                  24
 31   N = N / 2                                                         25
      PRINT 12, IFAC                                                    26
      GOTO 30                                                           27
                                                                        28
C     DIVIDE OUT ODD INTEGERS FROM 3 TO SQRT(N).                        29
 40   DO 50 IFAC = 3, 32767, 2                                          30
C         CHECK IF IFAC SQUARED EXCEEDS N                               31
          IF (IFAC**2 - N) 41, 41, 60                                   32
 41       IF (XMODF(N, IFAC)) 9999, 42, 50                              33
 42       N = N / IFAC                                                  34
          PRINT 12, IFAC                                                35
          GOTO 41                                                       36
 50   CONTINUE                                                          37
                                                                        38
C     IF N IS STILL GREATER THAN ONE, THEN N IS ALSO A PRIME FACTOR.    39
 60   IF (N-1) 70, 70, 61                                               40
 61   PRINT 12, N                                                       41
                                                                        42
 70   GOTO 20                                                           43
                                                                        44
 9999 STOP                                                              45


subroutine UpdateCVM(OldCVM, Oldmean, n, par, newmean, NewCVM)
Use Interface_MOD, only: NPar, PriorCVM
implicit none
real, intent(in)   :: OldCVM(NPar*(NPar+1)/2)
real, intent(in)   :: Oldmean(NPar)
real, intent(in)   :: n  !current step as a weight
real, intent(in)   :: par(NPar)
real, intent(out)  :: newmean(NPar)
real, intent(out)  :: NewCVM(NPar*(NPar+1)/2)

integer            :: row,col

IF (n .GE. 2d0) THEN
   ! Update the mean params

   newmean = ((n-1d0)*Oldmean + par)/n

   ! Update the correlation covariance matrix (but not Pcvm):
   do row = 1, NPar
      do col = 1, row
        NewCVM(row*(row-1)/2 +col) =                  &
            ((n-1d0)/n)*OldCvm(row*(row-1)/2 +col)    &
          + (1d0/(n-1d0))                             &
          * (par(row)-newmean(row))                   &
          * (par(col)-newmean(col))
      enddo
   enddo
ELSE
   newmean   = par
   NewCVM(:) = PriorCvm(:)
ENDIF
End subroutine