!=======================================================================
   FUNCTION bvalu2(t, bcoef, ns, ks, x, jderiv)
!=======================================================================
!
!   This routine is a modification of de Boor's bvalue routine, modified
!   to return the value at right endpoint continuous from the left,
!   instead of 0. It assumes the usual knot multiplicity ks at the right
!   endpoint.
!
!   It calculates the value at  x of the jderiv-th derivative of spline
!   from b-repr. The spline is taken to be continuous from the right.
!
!   SUBROUTINES contained:
!       interv
!
!-----------------------------------------------------------------------
!
!   on entry
!   --------
!
!       t      knot sequence, of length  ns+ks, assumed nondecreasing.
!       bcoef  coefficient sequence, of length  ns .
!       ns     length of  bcoef, assumed positive.
!       ks     order of the spline .
!
!             . . . W A R N I N G . . .
!       The restriction  ks <= kmax (=15)  is imposed
!       arbitrarily by the parameter statement defining dimensions
!       for aj, dm, dp  below, but is  NEVER CHECKED.
!
!       x      the point at which to evaluate the spline.
!       jderiv integer giving the order of the derivative to be evaluated
!              ASSUMED to be zero or positive.
!
!   on exit
!   -------
!   bvalu2 - the value of the (jderiv)-th derivative of  f  at  x .
!
!   method
!   ------
!     the nontrivial knot interval  (t(i),t(i+1))  containing  x  is lo-
!   cated with the aid of  INTERV. the  ks  b-coeffs of  f  relevant for
!   this interval are then obtained from  bcoef (or taken to be zero if
!   not explicitly available) and are then differenced  jderiv  times to
!   obtain the b-coeffs of  (d**jderiv)f  relevant for that interval.
!   precisely, with  j = jderiv, we have from x.(12) of the text that
!
!           (d**j)f  =  sum ( bcoef(.,j)*b(.,ks-j,t) )
!
!   where
!                  / bcoef(.),                     ,  j = 0
!                  /
!   bcoef(.,j)  =  / bcoef(.,j-1) - bcoef(.-1,j-1)
!                  / ----------------------------- ,  j > 0
!                  /    (t(.+ks-j) - t(.))/(ks-j)
!
!   then, we use repeatedly the fact that
!
!     sum ( a(.)*b(.,m,t)(x) )  =  sum ( a(.,x)*b(.,m-1,t)(x) )
!   with
!                  (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1)
!     a(.,x)  =    ---------------------------------------
!                  (x - t(.))      + (t(.+m-1) - x)
!
!   to write  (d**j)f(x)  eventually as a linear combination of b-splines
!   of order  1 , and the coefficient for  b(i,1,t)(x)  must then
!   be the desired number  (d**j)f(x). (see x.(17)-(19) of text).
!
!   current fortran standard makes it impossible to specify the length
!   of t  precisely without the introduction of otherwise superfluous
!   additional arguments.
!
!-----------------------------------------------------------------------

      IMPLICIT NONE
      REAL(KIND=8) :: bvalu2
      INTEGER, INTENT(IN) :: ns, ks, jderiv
      REAL(KIND=8), INTENT(IN) :: x
      REAL(KIND=8), DIMENSION(ns), INTENT(IN) :: bcoef
      REAL(KIND=8), DIMENSION(ns + ks), INTENT(IN) :: t

      ! ..  local variable

      REAL(KIND=8), DIMENSION(ks) :: aj, dm, dp
      REAL(KIND=8) :: fkmj
      INTEGER :: i, mflag, km1, jcmin, imk, nmi, jcmax, jc
      INTEGER :: j, jj, kmj, ilo

      bvalu2 = 0.d0
      IF (jderiv >= ks) RETURN

      ! .. find  i  such that 1 <= i < ns+ks  and  t(i) < t(i+1) and
      ! t(i) <= x < t(i+1) . if no such i can be found,  x  lies
      ! outside the support of  the spline  f  and  bvalu2 = 0.
      ! (the asymmetry in this choice of i makes f rightcontinuous)

      IF (x /= t(ns + 1) .OR. t(ns + 1) /= t(ns + ks)) THEN
         CALL interv(x, i, mflag)
         IF (mflag /= 0) RETURN
      ELSE
         i = ns
      END IF

      ! .. if ks = 1 (and jderiv = 0), bvalu2 = bcoef(i).

      km1 = ks - 1
      IF (km1 <= 0) THEN
         bvalu2 = bcoef(i)
         RETURN
      END IF

      ! .. store the ks b-spline coefficients relevant for the knot interval
      ! (t(i),t(i+1)) in aj(1),...,aj(ks); compute dm(j) = x - t(i+1-j),
      ! dp(j) = t(i+j) - x, j=1,...,ks-1. Set any of the aj not obtainable
      ! from input to zero. set any t.s not obtainable equal to t(1) or
      ! to t(ns+ks) appropriately.

      jcmin = 1
      imk = i - ks
      IF (imk < 0) THEN
         jcmin = 1 - imk
         do j = 1, i
            dm(j) = x - t(i + 1 - j)
         end do
         do j = i, km1
            aj(ks - j) = 0.
            dm(j) = dm(i)
         end do
      ELSE
         do j = 1, km1
            dm(j) = x - t(i + 1 - j)
         end do
      END IF

      jcmax = ks
      nmi = ns - i
      IF (nmi < 0) THEN
         jcmax = ks + nmi
         do j = 1, jcmax
            dp(j) = t(i + j) - x
         end do
         do j = jcmax, km1
            aj(j + 1) = 0.
            dp(j) = dp(jcmax)
         end do
      ELSE
         do j = 1, km1
            dp(j) = t(i + j) - x
         end do
      END IF
      do jc = jcmin, jcmax
         aj(jc) = bcoef(imk + jc)
      end do

      ! .. difference the coefficients  jderiv  times.

      IF (jderiv /= 0) THEN
         DO j = 1, jderiv
            kmj = ks - j
            fkmj = kmj
            ilo = kmj
            DO jj = 1, kmj
               aj(jj) = ((aj(jj + 1) - aj(jj))/(dm(ilo) + dp(jj)))*fkmj
               ilo = ilo - 1
            END DO
         END DO
      END IF

      ! .. compute value at  x  in (t(i),t(i+1)) of jderiv-th derivative,
      ! given its relevant b-spline coeffs in aj(1),...,aj(ks-jderiv).

      IF (jderiv /= km1) THEN
         DO j = jderiv + 1, km1
            kmj = ks - j
            ilo = kmj
            DO jj = 1, kmj
               aj(jj) = (aj(jj + 1)*dm(ilo) + aj(jj)*dp(jj))/(dm(ilo) + dp(jj))
               ilo = ilo - 1
            END DO
         END DO
      END IF
      bvalu2 = aj(1)

   CONTAINS

      !=======================================================================
      SUBROUTINE interv(x, left, mflag)
         !=======================================================================
         !
         !   Computes  left = max( i ; 1 <= i <= ns+ks  .and.  t(i) <= x )
         !   which is the interval containing x .
         !
         !   A reformatted version of the de Boor routine
         !
         !-----------------------------------------------------------------------
         !
         !   on entry
         !   --------
         !
         !       x   the point whose location with respect to the sequence t is
         !           to be determined.
         !
         !   on exit
         !   -------
         !       left, mflag   integers, whose values are
         !          1     -1   if               x <  t(1)
         !          i      0   if      t(i)  <= x < t(i+1)
         !      ns+ks      1   if   t(ns+ks) <= x
         !
         !   In particular,  mflag = 0 is the 'usual' case.  mflag /= 0
         !   indicates that  x  lies outside the halfopen interval
         !   t(1) <= y < t(ns+ks). the asymmetric treatment of the
         !   interval is due to the decision to make all pp functions cont-
         !   inuous from the right.
         !
         !   ...  m e t h o d  ...
         !   The program is designed to be efficient in the common situation where
         !   it is called repeatedly, with  x  taken from an increasing or decrea-
         !   sing sequence. this will happen, e.g., when a pp function is to be
         !   graphed. the first guess for  left  is therefore taken to be the val-
         !   ue returned at the previous call and stored in the  l o c a l  varia-
         !   ble  ilo . a first check ascertains that  ilo < ns+ks (this is nec-
         !   essary since the present call may have nothing to do with the previ-
         !   ous call). then, if  t(ilo) <= x < t(ilo+1), we set  left = ilo
         !   and are done after just three comparisons.
         !   otherwise, we repeatedly double the difference  istep = ihi - ilo
         !   while also moving  ilo  and  ihi  in the direction of  x , until
         !                      t(ilo) <= x < t(ihi) ,
         !   after which we use bisection to get, in addition, ilo+1 = ihi .
         !   left = ilo  is then returned.
         !
         !------------------------------------------------------------------------
         !
         IMPLICIT NONE
         REAL(KIND=8), INTENT(IN) :: x
         INTEGER, INTENT(OUT) :: left, mflag

         ! .. local variables

         INTEGER:: lxt, ihi, istep, middle
         INTEGER:: ilo = 1

         lxt = ns + ks
         ihi = ilo + 1
         IF (ihi >= lxt) THEN
            IF (x >= t(lxt)) THEN
               mflag = 1
               left = lxt
               RETURN
            END IF

            IF (lxt <= 1) THEN
               mflag = -1
               left = 1
               RETURN
            END IF
            ilo = lxt - 1
            ihi = lxt
         END IF

         IF (x < t(ihi)) THEN
            IF (x >= t(ilo)) THEN
               mflag = 0
               left = ilo
               RETURN
            END IF

            ! .. now x < t(ilo), decrease  ilo  to capture  x.

            istep = 1
            DO
               ihi = ilo
               ilo = ihi - istep
               IF (ilo <= 1) EXIT
               IF (x >= t(ilo)) EXIT
               istep = istep*2
            END DO

            IF (ilo <= 1) THEN
               ilo = 1
               IF (x < t(1)) THEN
                  mflag = -1
                  left = 1
                  RETURN
               END IF
            END IF
         ELSE

            ! .. now x >= t(ihi), increase ihi to capture x.

            istep = 1
            DO
               ilo = ihi
               ihi = ilo + istep
               IF (ihi >= lxt) EXIT
               IF (x < t(ihi)) EXIT
               istep = istep*2
            END DO

            IF (ihi >= lxt) THEN
               IF (x >= t(lxt)) THEN
                  mflag = 1
                  left = lxt
                  RETURN
               END IF
               ihi = lxt
            END IF
         END IF

         ! .. now t(ilo) <= x < t(ihi), narrow the interval.

         DO
            middle = (ilo + ihi)/2
            IF (middle == ilo) THEN
               mflag = 0
               left = ilo
               EXIT
            END IF

            ! .. note: it is assumed that middle = ilo in case ihi = ilo+1

            IF (x >= t(middle)) THEN
               ilo = middle
            ELSE
               ihi = middle
            END IF
         END DO
      END SUBROUTINE interv

   END FUNCTION bvalu2


module fsvd_mod
    use env_precision
    implicit none
    private
    public fsvd_mod_dgesvd, print_extmod

    contains

    subroutine print_extmod()
        write(6, *) "r16k = ", r16k
    end subroutine print_extmod

    subroutine fsvd_mod_dgesvd(A, k, nrow, ncol, U, S, VT)
        implicit none
        external :: dgesvd
        integer, intent(in)   :: nrow, ncol, k
        real(r8k), intent(in)  :: A(nrow, ncol)
        real(r8k), intent(out) :: U(nrow, k), S(k), VT(k, ncol)
!       local variables
        integer(i4k) :: ldmax, lwork, info, i, j
        real(r8k), allocatable :: work(:)
        real(r8k) :: Acopy(nrow, ncol)

        do j = 1, ncol
            do i = 1, nrow
                Acopy(i, j) = A(i, j)
            end do
        end do

        ldmax = max(nrow, ncol)
        lwork = max(1, 3 * k + ldmax, 5 * k)
        allocate(work(lwork))
        call dgesvd('S', 'S', nrow, ncol, Acopy, nrow, S, U, nrow, VT, k, work, lwork, info)

        end subroutine fsvd_mod_dgesvd

end module fsvd_mod


      double precision function DRLOG (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c  File drlog contains user callable procedures drlog & drlog1, and
c               lower level procedure drlog2.
c  drlog(x)  computes x - 1 - ln(x).
c  drlog1(x) computes x - ln(1 + x).
c>> 1996-03-30 DRLOG  Krogh  Added external statements.
C>> 1994-11-09 CLL Edited to avoid ENTRY statement.
C>> 1994-10-20 DRLOG Krogh  Changes to use M77CON
C>> 1994-05-23 DRLOG WVS JPL Combine DRLOG and DRLOG1
C>> 1994-05-23 DRLOG WVS JPL Make SP and DP alike using CHGTYP
C>> 1993-05-06 DRLOG WVS JPL Conversion from NSWC to Math 77
C ----------------------------------------------------------------------
c--D replaces "?": ?RLOG, ?RLOG1, ?RLOG2
C     ==================================================================
C             EVALUATION OF THE FUNCTION X - 1 - LN(X)
C     ------------------------------------------------------------------
      external drlog2
      double precision drlog2, r, x
C     ------------------------------------------------------------------
      R = (X - 0.5D0) - 0.5D0
      IF (X .LT. 0.61D0 .OR. X .GT. 1.57D0) THEN
         DRLOG = R - LOG(X)
      else
         DRLOG = DRLOG2(R)
      endif
      end
c     ==================================================================
      double precision function DRLOG1 (X)
C             EVALUATION OF THE FUNCTION X - LN(1 + X)
C     ------------------------------------------------------------------
      external drlog2
      double precision drlog2, r, x
C     ------------------------------------------------------------------
      IF (X .LT. -0.39D0 .OR. X .GT. 0.57D0) THEN
         R = (X + 0.5D0) + 0.5D0
         DRLOG1 = X - LOG(R)
      else
         DRLOG1 = DRLOG2(X)
      endif
      end
c     ==================================================================
      double precision function DRLOG2(RIN)
C            Complete computation started by DRLOG or DRLOG1.
C     ------------------------------------------------------------------
      external D1MACH
      double precision D1MACH
      DOUBLE PRECISION A, B, R, RIN, ROUND, T, U, UP2, W, Z
      SAVE ROUND
      DOUBLE PRECISION C1, C2, C3, C4, C5
      DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4
      DOUBLE PRECISION R0, R1, R2, S1, S2
c ------------------------
C     CI = 1/(2I + 1)
c ------------------------
      PARAMETER (C1 = 1.0D0 / 3.0D0)
      PARAMETER (C2 = 1.0D0 / 5.0D0)
      PARAMETER (C3 = 1.0D0 / 7.0D0)
      PARAMETER (C4 = 1.0D0 / 9.0D0)
      PARAMETER (C5 = 1.0D0 / 11.0D0)
c ------------------------
C     A = DRLOG (0.7)
C     B = DRLOG (4/3)
c ------------------------
      DATA A /.566749439387323789126387112411845D-01/
      DATA B /.456512608815524058941143273395059D-01/
c ------------------------
      DATA P0 / .7692307692307692307680D-01/,
     *     P1 /-.1505958055914600184836D+00/,
     *     P2 / .9302355725278521726994D-01/,
     *     P3 /-.1787900022182327735804D-01/
      DATA Q1 /-.2824412139355646910683D+01/,
     *     Q2 / .2892424216041495392509D+01/,
     *     Q3 /-.1263560605948009364422D+01/,
     *     Q4 / .1966769435894561313526D+00/
c ------------------------
      DATA R0/ .333333333333333D+00/, R1/-.224696413112536D+00/,
     *     R2/ .620886815375787D-02/
      DATA S1/-.127408923933623D+01/, S2/ .354508718369557D+00/
c ------------------------
      DATA ROUND /-1.0D0/
C     ------------------------------------------------------------------
C
C                 ARGUMENT REDUCTION
C
      R = RIN
      IF (R .LT. -0.18D0) THEN
         U = (10.0D0*R + 3.0D0)/7.0D0
         UP2 = U + 2.0D0
         W = A - U*0.3D0
      ELSE IF (R .GT. 0.18D0) THEN
         T = 0.75D0*R
         U = T - 0.25D0
         UP2 = T + 1.75D0
         W = B + U/3.0D0
      ELSE
         U = R
         UP2 = U + 2.0D0
         W = 0.0D0
      END IF
      IF (ROUND .LT. 0.0D0) ROUND = D1MACH(4)
C
C                  SERIES EXPANSION
C
      R = U/UP2
      T = R*R
      IF (ROUND .GT. 5.0D-14) THEN
         Z = ((R2*T + R1)*T + R0)/((S2*T + S1)*T + 1.0D0)
      ELSE
C
C        Z IS (AT FIRST) A MINIMAX APPROXIMATION OF THE SERIES
C
C               C6 + C7*R**2 + C8*R**4 + ...
C
C        FOR THE INTERVAL (0.0, 0.375). THE APPROXIMATION IS ACCURATE
C        TO WITHIN 1.6 UNITS OF THE 21-ST SIGNIFICANT DIGIT.
C
         Z = (((P3*T + P2)*T + P1)*T + P0)/
     *       ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.0D0)
C
         Z = ((((Z*T + C5)*T + C4)*T + C3)*T + C2)*T + C1
      END IF
      DRLOG2 = R*(U - 2.0D0*T*Z) + W
      END


program test_surf_cell
use libatoms_module
implicit none

type(Atoms) :: at_prim, at_surf, at_slab, at_slab_cut

real(dp) :: surf_v(3), tol
logical :: third_vec_normal
integer :: max_n

integer :: i
integer :: surf_i(3,3)
type(Dictionary) :: cli_params
real(dp) :: F(3,3), old_axes(3,3), old_axes_inv(3,3), new_axes(3,3), z_min, z_max, z_vacuum
integer :: n3_min, n3_max
character(len=STRING_LENGTH) :: comment, Z_order
character(len=STRING_LENGTH) :: verbosity

call system_initialise(verbosity=PRINT_SILENT)

call initialise(cli_params)
call param_register(cli_params, "surf_v", PARAM_MANDATORY, surf_v, help_string="vector normal to surface in Cartesian coords")
call param_register(cli_params, "z_min", PARAM_MANDATORY, z_min, help_string="minimum Z position to include in slab")
call param_register(cli_params, "z_max", PARAM_MANDATORY, z_max, help_string="maximum Z position to include in slab")
call param_register(cli_params, "z_vacuum", PARAM_MANDATORY, z_vacuum, help_string="amount of vacuum to create")
call param_register(cli_params, "third_vec_normal", "T", third_vec_normal, help_string="if true force the third vector to be normal to the surface")
call param_register(cli_params, "tol", "1.0e-6", tol, help_string="tolerance for various normal/parallel tests")
call param_register(cli_params, "max_n", "4", max_n, help_string="maximum supercell component to search for matching vectors")
call param_register(cli_params, "verbosity", "NORMAL", verbosity, help_string="verbosity level.  VERBOSE for more output about surface cell")
if (.not. param_read_args(cli_params)) then
   call param_print_help(cli_params)
   call system_abort("Error reading params from command line")
endif
call finalise(cli_params)

call verbosity_push(verbosity_of_str(trim(verbosity)))

call read_vasp(at_prim, "stdin")

call print("at_prim", verbosity=PRINT_VERBOSE)
if (current_verbosity() >= PRINT_VERBOSE) call write(at_prim, "stdout")

call print("surface unit cell for lattice", verbosity=PRINT_VERBOSE)
call print(at_prim%lattice, verbosity=PRINT_VERBOSE)
call print ("normal to "//surf_v, verbosity=PRINT_VERBOSE)

! create the surface unit cell lattice
call surface_unit_cell(surf_i, surf_v, at_prim%lattice, third_vec_normal=third_vec_normal, tol=tol, max_n=max_n)

call print("", verbosity=PRINT_VERBOSE)
call print("in lattice coordinates", verbosity=PRINT_VERBOSE)
call print(surf_i, verbosity=PRINT_VERBOSE)
call print("in cartesian coordinates", verbosity=PRINT_VERBOSE)
call print(matmul(at_prim%lattice,surf_i), verbosity=PRINT_VERBOSE)

! create the actual surface unit cell with atoms
call arbitrary_supercell(at_surf, at_prim, surf_i)

! rotate to desired axes (surface normal to z)
old_axes(:,1) = at_surf%lattice(:,1) ! map to x
old_axes(:,2) = at_surf%lattice(:,1) .cross. at_surf%lattice(:,2) ! surf_v, map to z
old_axes(:,3) = at_surf%lattice(:,1) .cross. (at_surf%lattice(:,1) .cross. at_surf%lattice(:,2)) ! map to y
old_axes(:,1) = old_axes(:,1) / norm(old_axes(:,1))
old_axes(:,2) = old_axes(:,2) / norm(old_axes(:,2))
old_axes(:,3) = old_axes(:,3) / norm(old_axes(:,3))
new_axes(:,1) = (/ 1, 0, 0 /)
new_axes(:,2) = (/ 0, 0, 1 /)
new_axes(:,3) = (/ 0, 1, 0 /)

call print("old_axes", verbosity=PRINT_VERBOSE)
call print(old_axes, verbosity=PRINT_VERBOSE)
call print("new_axes", verbosity=PRINT_VERBOSE)
call print(new_axes, verbosity=PRINT_VERBOSE)

call matrix3x3_inverse(old_axes, old_axes_inv)
F = matmul(new_axes, old_axes_inv)
new_axes = matmul(F, at_surf%lattice)
if (new_axes(3,3) < 0.0_dp) then
   F(3,:) = -F(3,:)
endif

call print("F", verbosity=PRINT_VERBOSE)
call print(F, verbosity=PRINT_VERBOSE)

call print("F.old_axes", verbosity=PRINT_VERBOSE)
call print(matmul(F, old_axes), verbosity=PRINT_VERBOSE)

call set_lattice(at_surf, matmul(F, at_surf%lattice), .true.)

n3_min = floor((z_min-minval(at_surf%pos(3,:)))/at_surf%lattice(3,3))-1
n3_max = floor((z_max-maxval(at_surf%pos(3,:)))/at_surf%lattice(3,3))+2
call print("n3 min max "//n3_min//" "//n3_max, verbosity=PRINT_VERBOSE)
call supercell(at_slab, at_surf, 1, 1, n3_max-n3_min+1)
do i=1, at_slab%N
   at_slab%pos(:,i) = at_slab%pos(:,i) + n3_min*at_surf%lattice(:,3)
end do

call print("at_slab", verbosity=PRINT_VERBOSE)
if (current_verbosity() >= PRINT_VERBOSE) call write(at_slab, "stdout")

call select(at_slab_cut, at_slab, mask=(at_slab%pos(3,:) >= z_min .and. at_slab%pos(3,:) <= z_max))

old_axes = at_slab_cut%lattice
old_axes(:,3) = old_axes(:,3)/norm(old_axes(:,3)) * (z_max-z_min + z_vacuum)
call set_lattice(at_slab_cut, old_axes, .false.)

! print out final slab

call get_param_value(at_prim, "VASP_Comment", comment)
comment = trim(comment)//" surf_v "//surf_v
call set_param_value(at_slab_cut, "VASP_Comment", comment)

call get_param_value(at_prim, "VASP_Z_order", Z_order)
call set_param_value(at_slab_cut, "VASP_Z_order", Z_order)

call print("at_slab_cut", verbosity=PRINT_VERBOSE)
if (current_verbosity() >= PRINT_VERBOSE) call write(at_slab_cut, "stdout")

call write_vasp(at_slab_cut, "stdout", fix_order=.true., cartesian=.false.)

call verbosity_pop()
call system_finalise()

contains

subroutine write_vasp(at, filename, fix_order, cartesian)
   type(Atoms), intent(in) :: at
   character(*), intent(in) :: filename
   logical, intent(in) :: fix_order, cartesian

   type(inoutput) :: io
   integer :: sorted_Zs(at%N)
   integer, allocatable :: uniq_Zs(:)
   integer :: i, j
   character(len=STRING_LENGTH) :: comment, Z_order
   integer :: n_species, i_species, Ns(100)
   real(dp) :: new_lattice(3,3), new_lattice_inv(3,3)

   call initialise(io, filename)
   call get_param_value(at, "VASP_Comment", comment)

   if (.not. get_value(at%params, 'VASP_Z_order', Z_order)) then
      Z_order = ''
   endif

   call print(trim(comment), file=io, verbosity=PRINT_ALWAYS)

   call print(1.0_dp, file=io, verbosity=PRINT_ALWAYS)
   if (scalar_triple_product(at%lattice(:,1), at%lattice(:,2), at%lattice(:,3)) < 0.0_dp) then
      new_lattice(:,1) = at%lattice(:,2)
      new_lattice(:,2) = at%lattice(:,1)
      new_lattice(:,3) = at%lattice(:,3)
      call matrix3x3_inverse (new_lattice, new_lattice_inv)
   else
      new_lattice = at%lattice
      new_lattice_inv = at%g
   endif
   call print(new_lattice(:,1), file=io, verbosity=PRINT_ALWAYS)
   call print(new_lattice(:,2), file=io, verbosity=PRINT_ALWAYS)
   call print(new_lattice(:,3), file=io, verbosity=PRINT_ALWAYS)

   if (fix_order) then
      sorted_Zs = at%Z
      call sort_array(sorted_Zs)
      call uniq(sorted_Zs, uniq_Zs)
      if (len_trim(Z_order) > 0) then
	 read(unit=Z_order, fmt=*) line, uniq_Zs
      endif

      line = ""
      do i=1, size(uniq_Zs)
	 line=trim(line)//" "//ElementName(uniq_Zs(i))
      end do
      call print(trim(line), file=io, verbosity=PRINT_ALWAYS)

      line = ""
      do i=1, size(uniq_Zs)
	 line=trim(line)//" "//count(at%Z == uniq_Zs(i))
      end do

      call print(trim(line), file=io, verbosity=PRINT_ALWAYS)

      if (cartesian) then
	 call print("Cartesian")
	 do i=1, size(uniq_Zs)
	    do j=1, at%N
	       if (at%Z(j) == uniq_Zs(i)) call print(at%pos(:,j), file=io, verbosity=PRINT_ALWAYS)
	    end do
	 end do
      else
	 call print("Direct")
	 do i=1, size(uniq_Zs)
	    do j=1, at%N
	       if (at%Z(j) == uniq_Zs(i)) call print(matmul(new_lattice_inv,at%pos(:,j)), file=io, verbosity=PRINT_ALWAYS)
	    end do
	 end do
      endif

      deallocate(uniq_Zs)
   else
      line=ElementName(at%Z(1))
      n_species = 1
      do i=2, at%N
	 if (at%Z(i) /= at%Z(i-1)) then
	    line=trim(line)//" "//ElementName(at%Z(i))
	    n_species = n_species + 1
	 endif
      end do
      call print(trim(line), file=io, verbosity=PRINT_ALWAYS)

      line=""//at%Z(1)
      i_species = 1
      Ns(i_species) = 1
      do i=2, at%N
	 if (at%Z(i) /= at%Z(i-1)) then
	    i_species = i_species + 1
	 endif
	 Ns(i_species) = Ns(i_species) + 1
      end do
      call print(Ns(1:n_species), file=io, verbosity=PRINT_ALWAYS)

      if (cartesian) then
	 call print("Cartesian")
	 do i=1, at%N
	    call print(at%pos(:,i), file=io, verbosity=PRINT_ALWAYS)
	 end do
      else
	 call print("Direct")
	 do i=1, at%N
	    call print(matmul(new_lattice_inv,at%pos(:,i)), file=io, verbosity=PRINT_ALWAYS)
	 end do
      endif
   end if

   call finalise(io)

end subroutine write_vasp

subroutine read_vasp(at, filename)
   type(Atoms), intent(inout) :: at
   character(*), intent(in) :: filename

   type(Inoutput) :: io
   character(len=STRING_LENGTH) :: comment, Z_order
   character(len=10) :: species(100)
   integer :: n_species, i, j, N_tot
   integer :: Ns(100), species_Zs(100)
   real(dp) :: lattice(3,3)
   real(dp) :: lattice_scale
   logical :: cartesian
   integer :: status

   call initialise(io, filename)
   line=read_line(io); comment=trim(line)
   line=read_line(io); read (unit=line, fmt=*) lattice_scale
   line=read_line(io); read (unit=line, fmt=*) lattice(:,1)
   line=read_line(io); read (unit=line, fmt=*) lattice(:,2)
   line=read_line(io); read (unit=line, fmt=*) lattice(:,3)
   lattice = lattice * lattice_scale
   ! species line is optional
   line=read_line(io)
   call split_string_simple(line, species, n_species, " 	")
   read(unit=species(1), fmt=*, iostat=status) Ns(1)
   if (status == 0) then ! it's a number
      read(unit=line, fmt=*) Ns(1:n_species)
      do i=1, n_species
	 species_Zs(i) = i
      end do
   else ! actually species
      line=read_line(io)
      read(unit=line, fmt=*) Ns(1:n_species)
      do i=1, n_species
	 species_Zs(i) = atomic_number(species(i))
      end do
   endif
   Z_order='S '//species_Zs(1:n_species)
   line=read_line(io)
   if (line(1:1) == 'S') line=read_line(io)
   if (line(1:1) == 'c' .or. line(1:1) == 'C') then
      cartesian = .true.
   else if (line(1:1) == 'd' .or. line(1:1) == 'D') then
      cartesian = .false.
   else
      call system_abort ("confused by cartesian/direct line of '"//trim(line)//"'")
   endif

   call initialise(at, sum(Ns(1:n_species)), lattice)
   N_tot = 0
   do i=1, n_species
   do j=1, Ns(i)
      line=read_line(io)
      N_tot = N_tot + 1
      read (unit=line, fmt=*) at%pos(:,N_tot)
      at%Z(N_tot) = species_Zs(i)
   end do
   end do

   call set_atoms(at, at%Z)

   if (cartesian) then
      at%pos = at%pos * lattice_scale
   else
      at%pos = matmul(at%lattice, at%pos)
   endif

   if (len_trim(comment) == 0) then
      call set_param_value(at, "VASP_Comment", "none")
   else
      call set_param_value(at, "VASP_Comment", trim(comment))
   endif

   call set_param_value(at, "VASP_Z_order", trim(Z_order))

   call finalise(io)

end subroutine read_vasp

end program


      SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the descriptor system pair (C,A-lambda E) to the
C     RQ-coordinate form by computing an orthogonal transformation
C     matrix Z such that the transformed descriptor system pair
C     (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper
C     trapezoidal form.
C     The right orthogonal transformations performed to reduce E can
C     be optionally accumulated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix A*Z.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix E*Z in upper trapezoidal form,
C             i.e.
C
C                      ( E11 )
C                E*Z = (     ) ,  if L >= N ,
C                      (  R  )
C             or
C
C                E*Z = ( 0  R ),  if L < N ,
C
C             where R is an MIN(L,N)-by-MIN(L,N) upper triangular
C             matrix.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N':  Z is not referenced.
C             If COMPZ = 'I':  on entry, Z need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Z,
C                              which is the product of Householder
C                              transformations applied to A, E, and C
C                              on the right.
C             If COMPZ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Z1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)).
C             For optimum performance
C             LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB),
C             where NB is the optimal blocksize.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine computes the RQ factorization of E to reduce it
C     the upper trapezoidal form.
C
C     The transformations are also applied to the rest of system
C     matrices
C
C         A <- A * Z,  C <- C * Z.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( L*N*N )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSRQ.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Descriptor system, matrix algebra, matrix operations,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   E( LDE, * ), Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            ILZ
      INTEGER            ICOMPZ, LN, WRKOPT
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DGERQF, DLASET, DORMRQ, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input parameters.
C
      INFO = 0
      WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) )
      IF( ICOMPZ.EQ.0 ) THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -6
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -12
      ELSE IF( LDWORK.LT.WRKOPT ) THEN
         INFO = -14
      END IF
      IF( INFO .NE. 0 ) THEN
         CALL XERBLA( 'TG01DD', -INFO )
         RETURN
      END IF
C
C     Initialize Q if necessary.
C
      IF( ICOMPZ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      LN = MIN( L, N )
C
C     Compute the RQ decomposition of E, E = R*Z.
C
C     Workspace: need   MIN(L,N) + L;
C                prefer MIN(L,N) + L*NB.
C
      CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
C
C     Apply transformation on the rest of matrices.
C
C     A <--  A * Z'.
C     Workspace: need   MIN(L,N) + L;
C                prefer MIN(L,N) + L*NB.
C
      CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE,
     $              DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
C
C     C <-- C * Z'.
C     Workspace: need   MIN(L,N) + P;
C                prefer MIN(L,N) + P*NB.
C
      CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE,
     $              DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
C
C     Z <-- Z1 * Z'.
C     Workspace: need   MIN(L,N) + N;
C                prefer MIN(L,N) + N*NB.
C
      IF( ILZ ) THEN
         CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ),
     $                LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN,
     $                INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
      END IF
C
C     Set lower triangle of E to zero.
C
      IF( L.LT.N ) THEN
         CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE )
         IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO,
     $                             E( 2, N-L+1 ), LDE )
      ELSE
         IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO,
     $                             E( L-N+2, 1 ), LDE )
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TG01DD ***
      END


module short_ch
use variables
implicit none
contains

! *********************************************************
! *********************************************************
! SHORT-CHARACTERISTICS FORMAL SOLUTION ROUTINES
! *********************************************************
! *********************************************************

! ---------------------------------------------------------
! Solves RTE using short-characteristics. Source function is supposed to vary parabolically
! between points M, O and P and RTE is integrated analitically, resulting in
!            I(O)=I(M)*exp(-tau(MO))+psi(M)*S(M)+psi(O)*S(O)+psi(P)*S(P)
! where psi are functions of the optical distance tau(MO) and tau(OP)
! It returns the value of the three psi coefficients
! ---------------------------------------------------------
   subroutine par_sc(dtm, dtp, psim, psi0, psip)
   real*8, INTENT(IN) :: dtm, dtp
   real*8, INTENT(INOUT) :: psim, psi0, psip
   real*8 :: exu, u0, u1 ,u2, d2, d3, d4
         if (dtm.ge.trick) then
            exu=dexp(-dtm)
            u0=1.d0-exu
            u1=dtm-1.d0+exu
            u2=dtm**2-2.d0*dtm+2.d0-2.d0*exu
         else
            d2=dtm**2
            d3=dtm**3
            d4=dtm**4
            u0=dtm-(d2/2.d0)
            u1=(d2/2.d0)-(d3/6.d0)
            u2=(d3/3.d0)-(d4/12.d0)
        endif

        if (dtm * dtp /= 0.d0 .and. dtm**2 /= 0.d0 .and. dtp**2 /= 0.d0) then
			  psim=(u2-u1*(dtp+2.d0*dtm))/(dtm*(dtm+dtp))+u0
      	  psi0=(u1*(dtm+dtp)-u2)/(dtm*dtp)
      	  psip=(u2-dtm*u1)/(dtp*(dtm+dtp))
	 	  else
		  	  psim = 0.d0
			  psi0 = 0.d0
			  psip = 0.d0
		  endif

   end subroutine par_sc

! ---------------------------------------------------------
! Solves RTE using short-characteristics. Source function is supposed to vary linearly
! between points M and O and RTE is integrated analitically, resulting in
!            I(O)=I(M)*exp(-tau(MO))+psi(M)*S(M)+psi(O)*S(O)
! where psi are functions of the optical distance tau(MO)
! It returns the value of the two psi coefficients
! ---------------------------------------------------------
   subroutine lin_sc(dtm, psim, psi0)
   real*8, INTENT(IN) :: dtm
	real*8, INTENT(INOUT) :: psim, psi0
   real*8 :: exu, u0, u1, c0, cm, d2

      if (dtm.ge.trick) then
         exu=dexp(-dtm)
         u0=1.d0-exu
         u1=dtm-1.d0+exu

         c0=u1/dtm
         cm=u0-c0
      else
         d2=dtm**2.d0
         c0=(dtm/2.d0)-(d2/6.d0)
         cm=(dtm/2.d0)-(d2/3.d0)
      endif
		psi0 = c0
		psim = cm

   end subroutine lin_sc

end module short_ch


! Monin-Obukhov Similarity
! Coded by Marat Khairoutdinov (C) 2003

subroutine landflx(p0, th, ts, qh, qs, uh, vh, h, z0, shf, lhf, taux, tauy, xlmo)

use params, only: epsv
implicit none

! Input:

real p0   ! surface pressure, mb
real th   ! pot. temperature at height h
real ts   ! pot. Temperature at z0
real qh   ! vapor at height h
real qs   ! vapor at z0
real uh   ! zonal wind at height h
real vh   ! merid wind at height h
real h    ! height h
real z0   ! friction height

! Output:

real shf   ! sensible heat flux (K m/s)
real lhf   ! latent heat flux (m/s)
real taux  ! zonal surface stress (N/m2)
real tauy  ! merid surface stress (N/m2)
real xlmo  ! Monin-Obukhov length

real r, x, pii, zody, vel
real a, b, c, d, ustar, tstar
real xm, xh, xsi, xsi1, xsi2, dxsi, fm, fh
integer iter
real gm1, gh1, fm1, fh1

gm1(x)=(1.-15.*x)**0.25
gh1(x)=sqrt(1.-9.*x)/0.74
fm1(x)=2.*alog((1.+x)/2.)+alog((1.+x*x)/2.)-2.*atan(x)+pii
fh1(x)=2.*alog((1.+0.74*x)/2.)

pii=acos(-1.)/2.
zody=alog(h/z0)

vel = sqrt(max(0.5,uh**2+vh**2))
r=min(0.25,9.81/ts*(th*(1+epsv*qh)-ts*(1.+epsv*qs))*h/vel**2)
iter=0

if(r.lt.0.) then

        xsi=0.
	iter=iter+1
 	xm=gm1(xsi)
	xh=gh1(xsi)
	fm=zody-fm1(xm)
	fh=0.74*(zody-fh1(xh))
	xsi1=r/fh*fm**2
	dxsi=xsi-xsi1
	xsi=xsi1

        xsi=-abs(xsi)
	iter=iter+1
 	xm=gm1(xsi)
	xh=gh1(xsi)
	fm=zody-fm1(xm)
	fh=0.74*(zody-fh1(xh))
	xsi1=r/fh*fm**2
	dxsi=xsi-xsi1
	xsi=xsi1

        xsi=-abs(xsi)
	iter=iter+1
 	xm=gm1(xsi)
	xh=gh1(xsi)
	fm=zody-fm1(xm)
	fh=0.74*(zody-fh1(xh))
	xsi1=r/fh*fm**2
	dxsi=xsi-xsi1
	xsi=xsi1

else
  	a=4.8*4.8*r-1.00*6.35
	b=(2.*r*4.8-1.00)*zody
	c=r*zody**2
	d=sqrt(b*b-4*a*c)
	xsi1=(-b+d)/a/2.
	xsi2=(-b-d)/a/2.
	xsi=amax1(xsi1,xsi2)
	fm=zody+4.8*xsi
	fh=1.00*(zody+7.8*xsi)
!  	a=4.7*4.7*r-0.74*6.35
!	b=(2.*r*4.7-0.74)*zody
!	c=r*zody**2
!	d=sqrt(b*b-4*a*c)
!	xsi1=(-b+d)/a/2.
!	xsi2=(-b-d)/a/2.
!	xsi=amax1(xsi1,xsi2)
!	fm=zody+4.7*xsi
!	fh=0.74*(zody+6.35*xsi)
end if

shf=0.4**2/fm/fh*vel*(ts-th)
lhf=0.4**2/fm/fh*vel*(qs-qh)
taux=-0.4**2/fm/fm*vel*uh*(p0*100./287./ts)
tauy=-0.4**2/fm/fm*vel*vh*(p0*100./287./ts)

ustar = 0.4/fm*vel
tstar = 0.4/fh*(th-ts)
if(xsi.ge.0.) then
   xsi = max(1.e-5,xsi)
else
   xsi = min(-1.e-5,xsi)
end if
xlmo = h/xsi

return
end


      real function smooth ( x, y, dy, npoint, s, v, a )
c  from  * a practical guide to splines *  by c. de boor
calls  setupq, chol1d
c
c  constructs the cubic smoothing spline  f  to given data  (x(i),y(i)),
c  i=1,...,npoint, which has as small a second derivative as possible
c  while
c  s(f) = sum( ((y(i)-f(x(i)))/dy(i))**2 , i=1,...,npoint ) .le. s .
c
c******  i n p u t  ******
c  x(1),...,x(npoint)	data abscissae,  a s s u m e d	to be strictly
c	 increasing .
c  y(1),...,y(npoint)	  corresponding data ordinates .
c  dy(1),...,dy(npoint)     estimate of uncertainty in data,  a s s u m-
c	 e d  to be positive .
c  npoint.....number of data points,  a s s u m e d  .gt. 1
c  s.....upper bound on the discrete weighted mean square distance of
c	 the approximation  f  from the data .
c
c******  w o r k  a r r a y s  *****
c  v.....of size (npoint,7)
c  a.....of size (npoint,4)
c
c*****	o u t p u t  *****
c  a(.,1).....contains the sequence of smoothed ordinates .
c  a(i,j) = d**(j-1)f(x(i)), j=2,3,4, i=1,...,npoint-1 ,  i.e., the
c	 first three derivatives of the smoothing spline  f  at the
c	 left end of each of the data intervals .
c     w a r n i n g . . .   a  would have to be transposed before it
c	 could be used in  ppvalu .
c
c******  m e t h o d  ******
c     the matrices  q-transp*d	and  q-transp*d**2*q  are constructed in
c   s e t u p q  from  x  and  dy , as is the vector  qty = q-transp*y .
c  then, for given  p , the vector  u  is determined in  c h o l 1 d  as
c  the solution of the linear system
c		(6(1-p)q-transp*d**2*q + p*r)u	= qty  .
c  from  u , the smoothing spline  f  (for this choice of smoothing par-
c  ameter  p ) is obtained in the sense that
c			 f(x(.))  =  y - 6(1-p)d**2*q*u        and
c		   (d**2)f(x(.))  =  6*p*u			.
c     the smoothing parameter  p  is found (if possible) so that
c		 sf(p)	=  s ,
c  with  sf(p) = s(f) , where  f  is the smoothing spline as it depends
c  on  p .  if	s = 0, then p = 1 . if	sf(0) .le. s , then p = 0 .
c  otherwise, the secant method is used to locate an appropriate  p  in
c  the open interval  (0,1) . specifically,
c		 p(0) = 0,  p(1) = (s - sf(0))/dsf
c  with  dsf = -24*u-transp*r*u  a good approximation to  d(sf(0)) = dsf
c  + 60*(d*q*u)-transp*(d*q*u) , and  u  as obtained for  p = 0 .
c  after that, for n=1,2,...  until sf(p(n)) .le. 1.01*s, do....
c     determine  p(n+1)  as the point at which the secant to  sf  at the
c     points  p(n)  and  p(n-1)  takes on the value  s .
c     if  p(n+1) .ge. 1 , choose instead  p(n+1)  as the point at which
c     the parabola  sf(p(n))*((1-.)/(1-p(n)))**2  takes on the value  s.
c     note that, in exact arithmetic, always  p(n+1) .lt. p(n) , hence
c     sf(p(n+1)) .lt. sf(p(n)) . therefore, also stop the iteration,
c     with final  p = 1 , in case  sf(p(n+1)) .ge. sf(p(n)) .
c
      integer npoint,	i,npm1
      real a(npoint,4),dy(npoint),s,v(npoint,7),x(npoint),y(npoint)
     *	   ,change,p,prevsf,prevp,sfp,sixp,six1mp,utru
      call setupq(x,dy,y,npoint,v,a(1,4))
      if (s .gt. 0.)			go to 20
   10 p = 1.
      call chol1d(p,v,a(1,4),npoint,1,a(1,3),a(1,1))
      sfp = 0.
					go to 60
   20 p = 0.
      call chol1d(p,v,a(1,4),npoint,1,a(1,3),a(1,1))
      sfp = 0.
      do 21 i=1,npoint
   21	 sfp = sfp + (a(i,1)*dy(i))**2
      sfp = sfp*36.
      if (sfp .le. s)			go to 60
      prevp = 0.
      prevsf = sfp
      utru = 0.
      do 25 i=2,npoint
   25	 utru = utru + v(i-1,4)*(a(i-1,3)*(a(i-1,3)+a(i,3))+a(i,3)**2)
      p = (sfp-s)/(24.*utru)
c  secant iteration for the determination of p starts here.
   30 call chol1d(p,v,a(1,4),npoint,1,a(1,3),a(1,1))
      sfp = 0.
      do 35 i=1,npoint
   35	 sfp = sfp+ (a(i,1)*dy(i))**2
      sfp = sfp*36.*(1.-p)**2
      if (sfp .le. 1.01*s)		go to 60
      if (sfp .ge. prevsf)		go to 10
      change = (p-prevp)/(sfp-prevsf)*(sfp-s)
      prevp = p
      p = p - change
      prevsf = sfp
      if (p .lt. 1.)			go to 30
      p = 1. - sqrt(s/prevsf)*(1.-prevp)
					go to 30
correct value of p has been found.
compute pol.coefficients from  q*u (in a(.,1)).
   60 smooth = sfp
      six1mp = 6.*(1.-p)
      do 61 i=1,npoint
   61	 a(i,1) = y(i) - six1mp*dy(i)**2*a(i,1)
      sixp = 6.*p
      do 62 i=1,npoint
   62	 a(i,3) = a(i,3)*sixp
      npm1 = npoint - 1
      do 63 i=1,npm1
	 a(i,4) = (a(i+1,3)-a(i,3))/v(i,4)
   63	 a(i,2) = (a(i+1,1)-a(i,1))/v(i,4)
     *			    - (a(i,3)+a(i,4)/3.*v(i,4))/2.*v(i,4)
					return
      end


!======================================================================
      SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
      INTEGER LDA,N,IPVT(n),JOB
      DOUBLE PRECISION A(LDA,n),DET(2),WORK(n)
C
C     DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        WORK    DOUBLE PRECISION(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     DOUBLE PRECISION(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DABS(DET(1)) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,DSWAP
C     FORTRAN DABS,MOD
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      DOUBLE PRECISION TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
C
C     COMPUTE DETERMINANT
C
      IF(JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         TEN = 10.0D0
         DO 50 I = 1, N
            IF(IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
C        ...EXIT
            IF(DET(1) .EQ. 0.0D0) GO TO 60
   10       IF(DABS(DET(1)) .GE. 1.0D0) GO TO 20
               DET(1) = TEN*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF(DABS(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/TEN
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF(MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF(N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF(NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = 0.0D0
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL DAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF(L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END


C simply compile using f77 test.f
C then ./a.out
      program main
C        print *, test_sum(1.1, 2.2)
         print *, pi_mc()
         pi = 0.0
         call mc_pi_r(pi)
         print *, pi
      end

C not ideal,
C suppose to be in separate files,
C oh bother, test anyway
      function test_sum(a, b)
        real a, b
        test_sum = a + b
        return
      end function test_sum

      subroutine test_sum_r(a, b, answer)
        double precision a, b, answer
        answer = a + b
      end subroutine test_sum_r

C ya know why it is not named mc_pi
      function pi_mc()
        do 10 i=1,1000000
          x = rand()
          y = rand()
          if(x**2 + y**2 .lt. 1) k=k+1
10      continue
        pi_mc = real(k) / 1000000 * 4
      end function pi_mc

      subroutine mc_pi_r(pi)
        real pi
        k = 0
        do 20 i=1,1000000
          x = rand()
          y = rand()
          if(x**2 + y**2 .lt. 1) k=k+1
20        continue
        pi = real(k) / 1000000 * 4
      end subroutine mc_pi_r


! space_time_predictor.f90
! author: sunder

!-----------------------------------------------------------------------
! Apply ADER-DG method to the reconstruction
!-----------------------------------------------------------------------

subroutine ader_space_time_predictor(lqhi, lqbnd, lFbnd, luh)

    use ader_weno
    implicit none
    ! Argument list
    double precision, intent(in)  :: luh(nVar,nDOF)                ! spatial degrees of freedom
    double precision, intent(out) :: lqhi(nVar,nDOF)               ! time-averaged space-time degrees of freedom
    double precision, intent(out) :: lqbnd(nVar,2), lFbnd(nVar,2)  ! time-averaged space-time degrees of freedom
    ! Local variables
    integer :: i,l,iVar, iter
    double precision    :: lFhi(nVar,nDOF)            ! time-averaged nonlinear flux tensor in each space-time DOF
    double precision    :: rhs0(nVar,nDOF,nDOF)       ! contribution of the initial condition to the known right hand side
    double precision    :: rhs(nVar,nDOF,nDOF)        ! known right hand side
    double precision    :: lqh(nVar,nDOF, nDOF)       ! space-time degrees of freedom
    double precision    :: lFh(nVar,nDOF,nDOF)        ! nonlinear flux tensor in each space-time DOF
    double precision    :: lqhold(nVar,nDOF,nDOF)     ! old space-time degrees of freedom

    do i = 1, nDOF
        ! Trivial initial guess (can be significantly improved)
        do iVar = 1, nVar
            lqh(iVar,i,:) = luh(iVar,i)
        end do
        ! Compute the contribution of the initial condition uh to the time update.
        do iVar = 1, nVar
            rhs0(iVar,i,:) = wGP(i)*F0(:)*luh(iVar,i)
        end do
    end do

    ! Discrete Picard iterations.

    do iter = 1, N+1

        lqhold = lqh ! Save old space-time DOF

        do l = 1, nDOF ! loop over DOF in time

            ! Compute the fluxes (once these fluxes are available, the subsequent operations are independent from each other)

            do i = 1, nDOF
                call PDEFlux(lFh(:,i,l),lqh(:,i,l))
            end do

            ! Compute the "derivatives" (contributions of the stiffness matrix)

            rhs(:,:,l) = rhs0(:,:,l) - wGP(l)*(dt/dx)*MATMUL( lFh(:,:,l), Kxi )

        end do ! end loop over time DOF

        ! Multiply with (K1)^(-1) to get the discrete time integral of the discrete Picard iteration

        do i = 1, nDOF
             lqh(:,i,:) = 1.0d0/(wGP(i))*MATMUL( rhs(:,i,:), TRANSPOSE(iK1) )
        end do

    end do

    ! Immediately compute the time-averaged space-time polynomials

    do i = 1, nDOF
        lqhi(:,i) = matmul( lqh(:,i,:), wGP )
        lFhi(:,i) = matmul( lFh(:,i,:), wGP )
    end do

    ! Compute the bounday-extrapolated values for Q and F

    lqbnd(:,1) = matmul( lqhi(:,:), phiL )   ! left Q
    lqbnd(:,2) = matmul( lqhi(:,:), phiR )   ! right Q
    lFbnd(:,1) = matmul( lFhi(:,:), phiL )   ! left F
    lFbnd(:,2) = matmul( lFhi(:,:), phiR )   ! right F

end subroutine ader_space_time_predictor


      subroutine  res_sym_to_cons
c
c     nonconservative residuals dw changed to conservative residuals
c
      use dims
c
c     ******************************************************************
c
      use solv_var
c
c     ******************************************************************
c
      use flo_var
c
c     ******************************************************************
c
      use psm_var
c
c     ******************************************************************
c
      use flo_param
c
c     ******************************************************************
c
      implicit none
      integer  :: i,j
      real     :: gm1
      real     :: r1,r2,r3,r4
      real     :: ua,va,ha,qq,cc,c
c
c     ******************************************************************
c
      gm1   = gamma-1.

      do j=2,jl
      do i=2,il

        r1     = rs(i,j,1)
        r2     = rs(i,j,2)
        r3     = rs(i,j,3)
        r4     = rs(i,j,4)

        ua     = w(i,j,2)/w(i,j,1)
        va     = w(i,j,3)/w(i,j,1)
        ha     = (w(i,j,4)  +p(i,j))/w(i,j,1)
        qq     =.5*(ua*ua  +va*va)
        cc     = gamma*p(i,j)/w(i,j,1)
        c      = sqrt(cc)

        dw(i,j,1) = r1  +r4
        dw(i,j,2) = ua*(r1  +r4)  +c*r2
        dw(i,j,3) = va*(r1  +r4)  +c*r3
        dw(i,j,4) = ha*r1  +c*(ua*r2  +va*r3) +qq*r4

      end do
      end do

      return

      end


      FUNCTION IYMDJL (IYR,IMON,IDAY)
C
C     CONVERT FROM INTEGER IYR IMON IDAY DATE TO DAY COUNT
C
C     ASSUME AT LEAST 20 BIT INTEGER
C     USE BASE AS  1900 (01 JAN 1900 IS DAY 1)
C
C     This code includes conversion of a abbrievated 2 digit year
C     to a 4 digit year
C
      COMMON /UNDEF_TIME/ ITIME_UNDEF
      INTEGER ITIME_UNDEF
C
      INTEGER IBASE, IYMDJL
      INTEGER NDAY(12)
C
      DATA NDAY /0,31,59,90,120,151,181,212,243,273,304,334/
      DATA IBASE /693960/
C
      NYR=IYR
C
C     Fix up months, if off
      JMON = IMON
      IF (JMON.GT.12) THEN
      NYR = NYR + 1
      JMON = JMON - 12
      ENDIF
      IF (JMON.LT.1) THEN
      NYR = NYR - 1
      JMON = JMON + 12
      ENDIF
C
C     Is this an abbrievated year?  Add the century if so.
      IF (NYR.LT.100) CALL ADDCENTURY (NYR)
C
      JYR=NYR-1
      NLEAP=JYR/4+JYR/400-JYR/100
C
      MLEAP=0
      IF (JMON.GE.3) THEN
      IF (MOD(NYR,4).EQ.0 .AND. (MOD(NYR,100).NE.0 .OR. (MOD(NYR,100)
     .    .EQ.0 .AND. MOD(NYR,400).EQ.0))) MLEAP=1
      ENDIF
      IF ((JMON.LE.0).OR.(JMON.GE.13)) THEN
      IYMDJL = ITIME_UNDEF
      ELSE
      IYMDJL=NYR*365+NLEAP+NDAY(JMON)+IDAY+MLEAP-IBASE
      ENDIF
C
      RETURN
      END


      subroutine genmesh
c----------------------------------------------------------------------
c     A simple polar mesh is generated.
c----------------------------------------------------------------------
      include 'params.inc'
      include 'geomz.inc'
      include 'globals.inc'

      double precision m
c--------------------initialize variables
      pi      = 3.141592653589793238d0
      ng_incr(1) = 1
      ng_incr(2) = -naxl
      ng_incr(3) = -1
      ng_incr(4) = naxl

      if (irr .ne. 0) then
c--------------------assign cell importances (or weight limits) for rr

cc.....Seems that impl decreases geometrically with radius....MJC
         if (irr .eq. 1) then

            g_ximpl(1) = 1.0d0
            do 221 i = 2,nradl
               g_ximpl(i) = xmult * g_ximpl(i-1)
 221        continue

c...fill a polar array with these values, equal azumuthally MJC
            do 222 i = 1,nradl
               do 223 k = 1,naxl
                  iz       = k + (i-1)*naxl
                  g_ximp(iz) = g_ximpl(i)
 223           continue
 222        continue

         else
            wmin = wcut
            wmax= 1.0d0 / wcut
         endif

      endif

c..The number above implies that the center node is #1 and that the next
c..layer of nodes around is is numbered increasingly either clockwise or
c..counter clockwise. MJC

c--------------------assign cell numbers and cell coordinates

      nzones = nradl * naxl
      hr     = radl  / nradl
      ha     = (axl*pi)/(naxl*180.0d0)
      naxpls = naxl + 1
      do 1 iang = 1,naxpls
         ang = (iang-1)*ha
         cs  = cos(ang)
         sn  = sin(ang)
         do 2 ird=1,nradl
            r = (ird*hr)*sn
            z = (ird*hr)*cs

            if (iang .le. 1) goto 50
            jc       = ird*naxl - iang + 2
            g_zz(jc,4) = z
            g_rr(jc,4) = r

            if (ird .ge. nradl) goto 50
            jc       = jc+naxl
            g_zz(jc,3) = z
            g_rr(jc,3) = r

 50         continue

            if (iang .ge. naxpls) goto 51
            jc       = ird*naxl - iang + 1
            g_zz(jc,1) = z
            g_rr(jc,1) = r
            if (ird .ge. nradl) goto 51
            jc       = jc+naxl
            g_zz(jc,2) = z
            g_rr(jc,2) = r

 51         continue

 2       continue
 1    continue

      do 3 ii = 1,nzones
         do 8 ij = 1,4
            if (abs(g_zz(ii,ij)) .lt. 1.0e-9) g_zz(ii,ij) = 0.0d0
            if (abs(g_rr(ii,ij)) .lt. 1.0e-9) g_rr(ii,ij) = 0.0d0
 8       continue
         g_zz(ii,5) = g_zz(ii,1)
         g_rr(ii,5) = g_rr(ii,1)
 3    continue

c------------------------------compute SLOPE and INTERCEPT of cell sides,
c     and categorize special cases:
c     1 = normal cell,
c     2 = cell on z-axis,
c     3 = horizontal side,
c     4 = vertical side

      do 60 i = 1,nzones
         do 61 ks = 1,4
            rdif = g_rr(i,ks+1) - g_rr(i,ks)
            zdif = g_zz(i,ks+1) - g_zz(i,ks)

            if ((g_rr(i,ks).eq.0.0d0).and.(g_rr(i,ks+1).eq.0.0d0)) then
               ng_itype(i,ks) = 2
            else if (abs(rdif) .lt. 1.0d-9) then
               ng_itype(i,ks) = 3
            else if (abs(zdif) .lt. 1.0d-9) then
               ng_itype(i,ks) = 4
            else
               ng_itype(i,ks) = 1
            end if

            if (ng_itype(i,ks) .eq. 1) then

               if ((ks .eq. 1) .or. (ks .eq. 3)) then
                  m = rdif/zdif
                  b = 0.0d0
                  g_sqm(i,ks) = m*m
                  g_bom(i,ks) = 0.0d0

               else
                  b = (g_rr(i,ks)*g_zz(i,ks+1)
     &                 -g_rr(i,ks+1)*g_zz(i,ks))/zdif
                  m = rdif/zdif
                  g_sqm(i,ks) = m*m
                  g_bom(i,ks) = b/m
               endif

            endif
 61      continue
 60   continue

      CALL zonevols

      return
      end


program tst
use constants
implicit none
integer, parameter :: dp = selected_real_kind(15,307)
! program to calculate tst rate
real (dp) :: deltag,rate,temp,deg
! read deltag (in kcal/mol) and temperature (in K)
read(*,*) deltag,temp,deg
rate=deg*boltz*temp/planck*exp(-deltag/r/temp)
! rate in s-1
print*, rate

end program tst


      SUBROUTINE HWSSSP (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,
     1                   BDPF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
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       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
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                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REQUIRED       SIN,COS
C     RESIDENT
C     ROUTINES
C
C     REPERENCES     P. N. SWARZTRAUBER,THE DIRECT SOLUTION OF THE
C                    DISCRETE POISSON EQUATION ON THE SURFACE OF A
C                    SPHERE,S.I.A.M. 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
      DIMENSION       F(IDIMF,1) ,BDTS(1)    ,BDTF(1)    ,BDPS(1)    ,
     1                BDPF(1)    ,W(1)
      NBR = NBDCND+1
      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)+FLOAT(6*(M+1))
      RETURN
      END


      PROGRAM TESTPCG
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   SOLVER : PCG
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     -- Déclarations ---------------------------------------
      IMPLICIT REAL*8(A-H,O-Z)

      INTEGER N, IA, JA, NELEM, ierr,it_max,iwk,iflag
      parameter(N = 100, NELEM = 3500,iwk=10000)

      DIMENSION A(NELEM), IA(N+1), JA(NELEM),
     #          ALU(iwk),JLU(iwk),JU(N+1),
     #          b(N), x(N), z(N),
     #          r(N), w(N), p(N),DR(N),JI(N),xref(N)
      LOGICAL JT(N)

C     -- Chargement de la matrice A et du vecteur b ---------
      CALL loadmat(A,IA,JA,b,xref,ierr)

C     -- Initialisation du vecteur x à 0.0d0 ----------------
      CALL vectinit(N,x)

C     -- Paramètres du GMRES --------------------------------
      epsilon = 1.0D-8
      it_max  = 1000

C     -- Création du préconditionneur -----------------------
      WRITE(*,*)' 1 : IC0'
      WRITE(*,*)' 2 : IC0  + M réduc. = RIC0'
      WRITE(*,*)' 3 : MIC0'
      WRITE(*,*)' 4 : MIC0 + M réduc. = RMIC0'
      WRITE(*,*)'precond ? (0 = non)'
      READ(*,*)iflag
      ierr= 0
C
      if (iflag.eq.1) then
         CALL IC0 (N,A,IA,JA,ALU,JU,JLU,JT,JI,DR,iwk,
     $             ierr)
      else if (iflag.eq.2) then
         CALL RIC0 (N,A,IA,JA,ALU,JU,JLU,JT,JI,DR,iwk,
     $             ierr)
      else if (iflag.eq.3) then
         WRITE(*,*)'alpha ?'
         READ(*,*)alpha
         CALL MIC0 (N,A,IA,JA,ALU,JU,JLU,JT,JI,DR,iwk,
     $             ierr,alpha)
      else if (iflag.eq.4) then
         WRITE(*,*)'alpha ?'
         READ(*,*)alpha
         CALL RMIC0 (N,A,IA,JA,ALU,JU,JLU,JT,JI,DR,iwk,
     $               ierr,alpha)
      endif
C     -- Appel de la sous-routine CG ---------------------

      CALL pcg(N, x, b, A, IA, JA, ALU,JU,JLU, epsilon,
     #         it_max,r, w, p, z, iflag)

C     -- Sauvegarde du résultat vers MATLAB ----------------

      OPEN (UNIT = 1, FILE = 's_gmres.m', STATUS='unknown')
      DO 100 i = 1, N
         WRITE(1,*)'x(',i,')=',x(i),';'
100   CONTINUE
      CLOSE (UNIT = 1)

C     -- Visualisation de la solution ----------------------

      WRITE(*,*)
      WRITE(*,*)' <ENTER> pour voir la solution'
      READ(*,*)
      CALL VectAff2(N, x, xref)

      END


module module_functions
   ! Define functions.
   use, intrinsic :: iso_fortran_env, only : R8P=>real64
   implicit none
   private
   public :: my_function
   public :: my_cos
   public :: my_sin
   public :: my_exp
   public :: my_comply

   abstract interface
      ! Define the function prototype. Define as many interfaces as you need.
      function my_function(x) result(my_result)
         ! Define the interface of my function prototype.
         import :: R8P
         real(R8P), intent(in) :: x         ! The independent abscissa.
         real(R8P)             :: my_result ! The result of my function.
      endfunction my_function
   endinterface

   contains
      function my_cos(x) result(my_result)
         ! Just a function of mine: this could be complicated as you want.
         real(R8P), intent(in) :: x         ! The independent abscissa.
         real(R8P)             :: my_result ! The result of my function.

         my_result = cos(x)
      endfunction my_cos

      function my_sin(x) result(my_result)
         ! Just a function of mine: this could be complicated as you want.
         real(R8P), intent(in) :: x         ! The independent abscissa.
         real(R8P)             :: my_result ! The result of my function.

         my_result = sin(x)
      endfunction my_sin

      function my_exp(x) result(my_result)
         ! Just a function of mine: this could be complicated as you want.
         real(R8P), intent(in) :: x         ! The independent abscissa.
         real(R8P)             :: my_result ! The result of my function.

         my_result = exp(x)
      endfunction my_exp

      function my_comply(x) result(my_result)
         ! Just a complicated function handled by external preprocessor.
         real(R8P), intent(in) :: x         ! The independent abscissa.
         real(R8P)             :: my_result ! The result of my function.

         include 'comply_expression.inc'
      endfunction my_comply
endmodule module_functions

module module_worker
   ! Define worker.
   use, intrinsic :: iso_fortran_env, only : R8P=>real64
   use module_functions
   implicit none
   private
   public :: worker

   contains
      subroutine worker(selection, x, work, function_a, function_b, function_c)
         ! Work dispatcher. This is unnecessary complicated, only to show some features.
         character(len=*),       intent(in)  :: selection  ! User selection.
         real(R8P),              intent(in)  :: x          ! The independent abscissa.
         real(R8P),              intent(out) :: work       ! Work result.
         procedure(my_function), optional    :: function_a ! Function "a".
         procedure(my_function), optional    :: function_b ! Function "b".
         procedure(my_function), optional    :: function_c ! Function "c".

         select case(trim(adjustl(selection)))
         case('a')
            if (present(function_a)) then
               work = function_a(x=x)
            else
               error stop 'error: "function_a" has been selected but not passed'
            endif
         case('b')
            if (present(function_b)) then
               work = function_b(x=x)
            else
               error stop 'error: "function_b" has been selected but not passed'
            endif
         case('c')
            if (present(function_c)) then
               work = function_c(x=x)
            else
               error stop 'error: "function_c" has been selected but not passed'
            endif
         case default
            ! use the first passed function
            if (present(function_a)) then
               work = function_a(x=x)
            elseif (present(function_b)) then
               work = function_b(x=x)
            elseif (present(function_c)) then
               work = function_c(x=x)
            else
               error stop 'error: no selection neither function have been passed'
            endif
         endselect
      endsubroutine worker
endmodule module_worker

program dispatcher
   ! Test work dispatcher.
   use, intrinsic :: iso_fortran_env, only : R8P=>real64
   use module_functions
   use module_worker
   implicit none

   real(R8P) :: work

   call worker(selection='a', function_a=my_sin, function_c=my_cos, x=0._R8P, work=work)
   print*, 'sin(0) = ', work

   call worker(selection='c', function_a=my_sin, function_c=my_cos, x=0._R8P, work=work)
   print*, 'cos(0) = ', work

   call worker(selection='exp', function_b=my_exp, x=0._R8P, work=work)
   print*, 'exp(0) = ', work

   call worker(selection='a', function_a=my_comply, x=0._R8P, work=work)
   print*, 'comply(0) = ', work

endprogram dispatcher


!** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!** See https://llvm.org/LICENSE.txt for license information.
!** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!* Tests for runtime library MATMUL routines

program p

  parameter(NbrTests=18)

  complex*16, dimension(4,3) :: arr1
  complex*16, dimension(4) :: arr2
  complex*16, dimension(3) :: arr3

  data arr1 /(0,1),(1,2),(2,3),(3,4), &
             (4,3),(5,4),(6,5),(7,6), &
             (8,8),(9,9),(10,10),(11,11)/
  data arr2 /(0,4),(1,3),(2,2),(3,1)/
  data arr3 /(0,2),(1,3),(2,1)/

  complex*16 :: expect(NbrTests)
  complex*16 :: results(NbrTests)

  data expect / &
   !test 1,6
     (-6.0,30.0), (-2.0,82.0), (-28.0,152.0), &
   !test 7,12
     (-2.0,30.0), (10.0,66.0), (4.0,120.0), &
   !test 13,18
     (-11.0,15.0), (-17.0,57.0), (-50.0,108.0), &
   !test 19,24
     (-2.0,18.0), (10.0,54.0), (4.0,108.0), &
   !test 25,30
     (-2.0,30.0), (10.0,66.0), (0.0,0.0), &
   !test 43,36
     (0.0,0.0), (-2.0,82.0), (-28.0,152.0)/

  results = -1

  ! tests 1-6
  arr3=0
  arr3 = matmul(transpose(arr1),arr2)
  call assign_result(1,3,arr3,results)
  !print *,"test 1,6"
  !print *,arr3

  ! tests 7-12
  arr3=0
  arr3 = matmul(transpose(arr1(2:4,:)),arr2(2:4))
  call assign_result(4,6,arr3,results)
  !print *,"test 7,12"
  !print *,arr3

  ! tests 13-18
  arr3=0
  arr3 = matmul(transpose(arr1(1:3,:)),arr2(1:3))
  call assign_result(7,9,arr3,results)
  !print *,"test 13,18"
  !print *,arr3

  !tests 19-24
  arr3=0
  arr3 = matmul(transpose(arr1(1:3,:)),arr2(2:4))
  call assign_result(10,12,arr3,results)
  !print *,"test 19,24"
  !print *,arr3

  !tests 25-30
  arr3=0
  arr3(1:2) = matmul(transpose(arr1(2:4,1:2)),arr2(2:4))
  call assign_result(13,15,arr3,results)
  !print *,"test 25,30"
  !print *,arr3

  !tests 31-36
  arr3=0
  arr3(2:3) = matmul(transpose(arr1(:,2:3)),arr2)
  call assign_result(16,18,arr3,results)
  !print *,"test 31,36"
  !print *,arr3

  call checkd(results, expect, NbrTests*2)

end program

subroutine assign_result(s_idx, e_idx , arr, rslt)
  complex*16, dimension(1:e_idx-s_idx+1) :: arr
  complex*16, dimension(e_idx) :: rslt
  integer:: s_idx, e_idx

  rslt(s_idx:e_idx) = arr

end subroutine


           program demo_sec2days
           use M_time, only : sec2days
           implicit none
              write(*,*)sec2days(129860)
              write(*,*)sec2days(80000.0d0)
              write(*,*)sec2days(80000.0,crop=.true.)
              write(*,*)sec2days('1 day 2.0hr 100 min 300.0seconds')
           end program demo_sec2days


#include "../defines.inc"
module umbrella
   use precision, only: dp

   implicit none
contains

! ------------------
!  Umbrella sample is of the form:
!
!   E = spring_k * ( rxn_coordinate - x_0 )**2
!   E = spring_k * rxn_coordinate**2  -  spring_k * x_0 * rxn_coordinate
!   E = UmbrellaQuardaticCof * rxn_coordinate**2 + UmbrellaCof * rxn_coordinate
!
! --------------------
   function setUmbrellaCof(s) result(cof)
      use params, only: wlc_numProcesses
      implicit none
      real(dp) cof, s
      real(dp) Delta_rxn_coord, spring_k, x_0
      Delta_rxn_coord = (WLC_P__MAX_RXN_COORD - WLC_P__MIN_RXN_COORD)/(wlc_numProcesses - 1.0_dp)
      spring_k = 2.0/(Delta_rxn_coord**2) ! for good mixing
      x_0 = WLC_P__MAX_RXN_COORD*s + WLC_P__MIN_RXN_COORD*(1.0_dp - s)
      cof = -spring_k*x_0
   end function
   function setUmbrellaQuadraticCof(s) result(cof)
      use params, only: wlc_numProcesses
      implicit none
      real(dp) cof, s
      real(dp) Delta_rxn_coord, spring_k
      Delta_rxn_coord = (WLC_P__MAX_RXN_COORD - WLC_P__MIN_RXN_COORD)/(wlc_numProcesses - 1.0_dp)
      spring_k = 2.0/(Delta_rxn_coord**2) ! for good mixing
      cof = spring_k
   end function

   function boundary_weight(x) result(output)
      implicit none
      real(dp) x, output
      if (x < 1.0_dp) then
         output = 1.0_dp
      else if (x < 17.0_dp) then
         output = (17.0_dp - x)/16.0_dp
      else
         output = 0.0_dp
      endif
   end function
   subroutine umbrella_energy_from_scratch()
      use params, only: wlc_R
      use energies, only: energyOf, umbrella_, umbrellaQuadratic_
      implicit none
      real(dp) rxn_coordinate
      integer ii
      ! -------- Calculate rxn coordinate from scratch --------
      rxn_coordinate = 0.0_dp
      do ii = 1, WLC_P__NT
         rxn_coordinate = rxn_coordinate + boundary_weight(wlc_R(1, ii))
      enddo
      rxn_coordinate = rxn_coordinate/WLC_P__NT
      ! -------- End caluclate rxn coordinate from scratch ---
      energyOf(umbrella_)%dx = rxn_coordinate
      energyOf(umbrellaQuadratic_)%dx = rxn_coordinate**2
   end subroutine
   subroutine umbrella_energy()
      use energies, only: energyOf, umbrella_, umbrellaQuadratic_
      use params, only: wlc_R, wlc_RP, wlc_nPointsMoved, wlc_pointsMoved
      implicit none
      real(dp) drxn_coordinate
      integer ii
      ! --------- Calculate change in rxn coordinate ---------
      drxn_coordinate = 0.0_dp
      do ii = 1, wlc_nPointsMoved
         drxn_coordinate = drxn_coordinate - boundary_weight(wlc_R(1, wlc_pointsMoved(ii)))
         drxn_coordinate = drxn_coordinate + boundary_weight(wlc_RP(1, wlc_pointsMoved(ii)))
      enddo
      drxn_coordinate = drxn_coordinate/WLC_P__NT
      ! --------- End calculate change in rxn coordinate ----
      energyOf(umbrella_)%dx = drxn_coordinate
      ! d(x^2) = dx^2 + 2*x*dx
      energyOf(umbrellaQuadratic_)%dx = drxn_coordinate**2 + 2.0_dp*energyOf(umbrella_)%x*drxn_coordinate
   end subroutine

end module umbrella


subroutine calc_orbit_from_vector
! Calculate the orbital parameters of all the bodies
! Also compute energy and angular momentum for error tracking

use embryodata
use eosdata, only: twopi,udist

implicit none

integer :: ibody,iembryo,ix
real :: gravparam
real :: rdotV, ndotR,ndotV,edotn,edotR, nmag
real,dimension(3) :: nplane
real,dimension(3,nbodies) :: eccvector
real,dimension(nbodies) :: vdotr,rmag,vmag

gravparam = totalmass

rmag(:) =sqrt(pos(1,:)*pos(1,:) + pos(2,:)*pos(2,:) + pos(3,:)*pos(3,:))
vmag(:) = sqrt(vel(1,:)*vel(1,:) + vel(2,:)*vel(2,:) + vel(3,:)*vel(3,:))

! Calculate orbital parameters - a,e,i

do ibody=2,nbodies

iembryo = ibody-1

if(embryo(iembryo)%finished==1) cycle

embryo(iembryo)%rmag = rmag(ibody)*udist

! Eccentricity first - calculate eccentricity (Laplace-Runge-Lenz) Vector
vdotr(:) = 0.0
do ix=1,3
   vdotr(:) = vdotr(:) + pos(ix,:)*vel(ix,:)
enddo

do ix=1,3
   eccvector(ix,:) = (vmag(:)*vmag(:)*pos(ix,:) -vdotr(:)*vel(ix,:))/gravparam - pos(ix,:)/rmag(:)
enddo

embryo(iembryo)%ecc = sqrt(eccvector(1,ibody)*eccvector(1,ibody) + &
    eccvector(2,ibody)*eccvector(2,ibody) + &
    eccvector(3,ibody)*eccvector(3,ibody))

! Semimajor axis
embryo(iembryo)%semimaj = angmag(ibody)*angmag(ibody)/&
    (gravparam*(1.0- embryo(iembryo)%ecc*embryo(iembryo)%ecc))

if(embryo(iembryo)%semimaj < 0.0) embryo(iembryo)%semimaj = abs(embryo(iembryo)%semimaj)

embryo(iembryo)%a = embryo(iembryo)%semimaj*udist

embryo(iembryo)%inc = 0.0

! Calculate the orbit's angles

   ! Inclination

   if(angmag(ibody)<small) cycle
   embryo(iembryo)%inc = acos(angmom(3,ibody)/ angmag(ibody))

   ! Longitude of the Ascending Node

   if (embryo(iembryo)%inc <small) then
      embryo(iembryo)%longascend = 0.0

      nplane(1) = angmag(ibody)
      nplane(2) = 0.0
      nplane(3) = 0.0
      nmag = angmag(ibody)

   else

      nplane(1) = -angmom(2,ibody)
      nplane(2) = angmom(1,ibody);
      nplane(3) = 0.0;

      nmag = sqrt(nplane(1)*nplane(1) + nplane(2)*nplane(2) + nplane(3)*nplane(3));

      if(nmag>small) then
         embryo(iembryo)%longascend = acos(nplane(1) / nmag);
      else
         embryo(iembryo)%longascend = 0.0
      endif

      if (nplane(2) < 0.0) embryo(iembryo)%longascend = twopi - embryo(iembryo)%longascend

   endif

   ! Calculate true anomaly

   !If orbit circular, no inclination, then use the position vector itself

   if (embryo(iembryo)%ecc < small .and. abs(embryo(iembryo)%inc) < small) then

      embryo(iembryo)%trueanom = acos(pos(1,ibody) / rmag(ibody));
      if (vel(1,ibody) < 0.0) embryo(iembryo)%trueanom = twopi - embryo(iembryo)%trueanom

      ! If orbit circular and inclination non-zero, then use the orbital plane vector
   else if (embryo(iembryo)%ecc < small) then

      ndotR = nplane(1)*pos(1,ibody) + nplane(2)*pos(2,ibody) + nplane(3)*pos(3,ibody)
      ndotR = ndotR / (rmag(ibody) * nmag);

      ndotV = nplane(1)*vel(1,ibody) + nplane(2)*vel(2,ibody) + nplane(3)*vel(3,ibody)

      embryo(iembryo)%trueanom = acos(ndotR);

      if (ndotV > 0.0) embryo(iembryo)%trueanom = twopi - embryo(iembryo)%trueanom

      ! For non-circular orbits use the eccentricity vector
   else

      edotR = eccvector(1,ibody)*pos(1,ibody) + eccvector(2,ibody)*pos(2,ibody) + eccvector(3,ibody)*pos(3,ibody)
      edotR = edotR / (rmag(ibody) * embryo(iembryo)%ecc);

      rdotV = vel(1,ibody)*pos(1,ibody) + vel(2,ibody)*pos(2,ibody) + vel(3,ibody)*pos(3,ibody)

     embryo(iembryo)%trueanom = acos(edotR);

      if (rdotV < 0.0)embryo(iembryo)%trueanom = twopi - embryo(iembryo)%trueanom
   endif

   ! Finally, calculate the longitude of periapsis - first calculate the argument of periapsis

   if (embryo(iembryo)%ecc > small) then

      edotn = eccvector(1,ibody)*nplane(1) + &
              eccvector(2,ibody)*nplane(2) + &
              eccvector(3,ibody)*nplane(3);

      edotn = edotn / (nmag * embryo(iembryo)%ecc);

      embryo(iembryo)%argper = acos(edotn);
      if (eccvector(3,ibody) < 0.0) embryo(iembryo)%argper = twopi - embryo(iembryo)%argper

   else

      embryo(iembryo)%argper = 0.0

   endif

enddo

end subroutine calc_orbit_from_vector

subroutine calc_vector_from_orbit
! Calculates body's position and velocity from orbital data

use embryodata
use eosdata, only: twopi, udist

implicit none

integer :: ibody,iembryo
real :: gravparam, semilatusrectum
!real :: a,e,i,long,om,nu
real,dimension(nbodies) :: rmag,vmag

real,dimension(nbodies) :: a,e,i,long,om,nu

a(:) = 0.0
e(:) = 0.0
i(:) = 0.0
long(:) = 0.0
om(:) = 0.0
nu(:) = 0.0

do ibody=2,nbodies
    iembryo=ibody-1

    a(ibody) = embryo(iembryo)%semimaj ! semimaj is in AU
    e(ibody) = embryo(iembryo)%ecc
    i(ibody) = embryo(iembryo)%inc
    long(ibody) = embryo(iembryo)%longascend
    om(ibody) = embryo(iembryo)%argper
    nu(ibody) = embryo(iembryo)%trueanom

    rmag(ibody) = embryo(iembryo)%semimaj * (1.0 - e(ibody) * e(ibody)) / (1.0 &
+ e(ibody) * cos(nu(ibody)))

! 2. Calculate position vector in orbital plane */

pos(1,ibody) = rmag(ibody)*cos(nu(ibody));
pos(2,ibody) = rmag(ibody) * sin(nu(ibody));
pos(3,ibody) = 0.0;

! 3. Calculate velocity vector in orbital plane */
semilatusrectum = abs(a(ibody) * (1.0 - e(ibody) * e(ibody)))
gravparam = totalmass

if (semilatusrectum > small) then

vmag(ibody) = sqrt(gravparam / semilatusrectum);

else

vmag(ibody) = 0.0;
endif

vel(1,ibody) = -vmag(ibody) * sin(nu(ibody));
vel(2,ibody) = vmag(ibody) * (cos(nu(ibody)) + e(ibody));
vel(3,ibody) = 0.0;

! 4. Begin rotations to correctly align the orbit
! Firstly, Rotation around z axis by -argument of Periapsis */

call rotate_Z(pos, nbodies, -1 * om);
call rotate_Z(vel, nbodies, -1 * om);

! Secondly, Rotate around x by -inclination */

call rotate_X(pos, nbodies, -1 * i);
call rotate_X(vel, nbodies, -1 * i);

! Lastly, Rotate around z by longitudeAscendingNode */

call rotate_Z(pos,nbodies,-1 * long);
call rotate_Z(vel,nbodies,-1 * long);

enddo

end subroutine calc_vector_from_orbit

subroutine rotate_X(vector,nrows,angle)
! Rotates 3 x nrows vector of particle data around x-axis by angle

implicit none
integer, intent(in)::nrows
real,intent(in),dimension(nrows) :: angle
real,intent(inout),dimension(3,nrows) :: vector

real, dimension(3,nrows) :: newvector

newvector(:,:) = vector(:,:)
where(abs(angle)>1.0e-20)
newvector(1,:) = vector(1,:)
newvector(2,:) = vector(2,:)*cos(angle(:)) - vector(3,:)*sin(angle(:));
newvector(3,:) = vector(2,:)*sin(angle(:)) + vector(3,:)*cos(angle(:));
endwhere

vector(:,:) = newvector(:,:)

end subroutine rotate_X

subroutine rotate_Y(vector,nrows,angle)
! Rotates 3 x nrows vector of particle data around x-axis by angle

implicit none
integer, intent(in)::nrows
real,intent(in),dimension(nrows) :: angle
real,intent(inout),dimension(3,nrows) :: vector

real, dimension(3,nrows) :: newvector

newvector(:,:) = vector(:,:)
where(abs(angle)>1.0e-20)

newvector(1,:) = vector(1,:)*cos(angle(:)) + vector(3,:)*sin(angle(:));
newvector(2,:) = vector(2,:)
newvector(3,:) = -vector(1,:)*sin(angle(:)) + vector(3,:)*cos(angle(:));

endwhere

vector(:,:) = newvector(:,:)

end subroutine rotate_Y

subroutine rotate_Z(vector,nrows,angle)
! Rotates 3 x nrows vector of particle data around x-axis by angle

implicit none
integer, intent(in)::nrows
real,intent(in),dimension(nrows) :: angle
real,intent(inout),dimension(3,nrows) :: vector

real, dimension(3,nrows) :: newvector

newvector(:,:) = vector(:,:)

where(abs(angle)>1.0e-20)
newvector(1,:) = vector(1,:)*cos(angle(:)) - vector(2,:)*sin(angle(:));
newvector(2,:) = vector(1,:)*sin(angle(:)) + vector(2,:)*cos(angle(:));
newvector(3,:) = vector(3,:)
endwhere

vector(:,:) = newvector(:,:)

end subroutine rotate_Z