Module extrapolate

implicit none

contains

SUBROUTINE fill(i1,i2,j1,j2,tx,critx,cor,mxs,za,nx,ny)

    ! ** This routine originates from the USA.
    ! ** It was delivered (by 3.5" diskette)
    ! ** to DNMI in nov. 1990.

    ! ***** Re-edited at DNMI in January '91 by H.Engedahl.
    ! ***** Again re-edited at DNMI in March '92 by H.Engedahl to fit the
    ! ***** ECOM3D output configuration.
    ! ***** DNMI/FoU 25.08.1993 A.Foss : Recoded for speedup.

    !// Solves Laplace's equation with Neumann boundary conditions
    !// (dA/dn = 0) in RECTANGULAR coordinates by an iterative method to
    !// fill in reasonable values at gridpoints containing values like
    !// "undef".

    !// NOTE: It is impossibel to make a really parallel (MPP) version of this
    !//       routine. One MPP node should work on a complete field.
    !//       Parallelization is done on a 'higher' level.  (A.Foss '98)

    !-----------------------------------------------------------------------
    !//     nx   = Array x dimension
    !//     ny   = Array y dimension
    !//   i1,i2  = Subarea in x direction to be filled
    !//   j1,j2  = Subarea in y direction to be filled
    !//     za   = Array to be filled (REAL)
    !//     tx   = All values in array A GREATER than Tx are filled (REAL)
    !//    critx = Criteria for relaxation, DEL**2 = CRIT
    !//            (Usually 4 orders of magnitude DOWN from data in A)
    !//     cor  = Coef. of overrelaxation, between +1.2 and +2.0
    !//     mxs  = Max. allowed no. of scans in relaxation procedure.
    !//   rmask  = Work array
    !//   error  = Array containing the errors in the relaxation procedure.
    !//   nvalue = No. of gridpoints with value (possibly 0) ... output
    !-----------------------------------------------------------------------
    !
    ! Converted to use as Python module with F2PY
    ! by Trond Kristiansen, 31.05.2012. Notice that the indexes (j,i) are
    ! flipped compared to original Fortran version.
    !
    ! f2py --verbose --fcompiler=intelem -c -m extrapolate fill.f90

    IMPLICIT NONE

    INTEGER  :: nx, ny, i1, i2, j1, j2, mxs
    REAL     :: tx,critx,cor

    REAL, dimension(ny,nx):: rmask, error, za

    INTEGER :: nvalue
    INTEGER              :: n, j, i, i1p1, i2m1, j1p1, j2m1, nnn, nbad
    REAL                 :: suma, asuma, crit, crtest

!f2py intent(in,out,overwrite)  za
!f2py intent(in) nx, ny, i1, i2, j1, j2, tx, critx, cor, mxs, nvalue

    n = 0
    suma = 0.

    DO j=j1,j2
    DO i=i1,i2
      IF (za(j,i) < tx) THEN
        suma = suma + za(j,i)
        n = n+1
      END IF
    END DO
    END DO

    nvalue = n

    IF (n < 1) THEN
  !    PRINT *
  !    PRINT *,"******************  WARNING  *******************"
  !    PRINT *,"SUBROUTINE FILL : NO USEFUL DATA IN THE FIELD"
  !    PRINT *,"ALL DATA IN THE INTERIOR (SUBAREA) WERE > ",tx
  !    PRINT *,"******************  WARNING  *******************"
  !    PRINT *
      RETURN
    END IF

    suma = suma/n
    asuma = 0.

    DO j=j1,j2
    DO i=i1,i2
      IF (za(j,i) < tx) THEN
        asuma = asuma + ABS(za(j,i)-suma)
        rmask(j,i) = 0.
      ELSE
        za(j,i) = suma
        rmask(j,i) = 1.
      END IF
    END DO
    END DO

    asuma = asuma/n

    crit = critx*asuma  ! af:  Using asuma not suma

    !// The value of suma ( i.e. the MEAN value of the array A ) is filled in
    !// the array A at all points with an initial value >= t.
    !// za(j,i) = suma may be regarded as the "first guess" in the iterative
    !// method.

    i1p1 = i1 + 1
    i2m1 = i2 - 1
    j1p1 = j1 + 1
    j2m1 = j2 - 1

    DO j=j1p1,j2m1
    DO i=i1p1,i2m1
      rmask(j,i) = cor*rmask(j,i)
    END DO
    END DO

    DO nnn=1,mxs

      DO j=j1p1,j2m1
        DO i=i1p1,i2m1
          error(j,i) = (za(j,i+1)+za(j+1,i)+za(j-1,i))*0.25-za(j,i)
        END DO
        DO i=i1p1,i2m1
          error(j,i) = error(j,i) + za(j,i-1)*0.25
          za(j,i) = za(j,i) + error(j,i)*rmask(j,i)
        END DO
      END DO

      !// Test convergence now and then (slow test loop)
      IF (nnn < mxs-5 .AND. MOD(nnn,10) == 0) THEN
        crtest = crit*cor
        nbad = 0
        j = j1
        DO WHILE (nbad == 0 .AND. j < j2m1)
          j=j+1
          DO i=i1p1,i2m1
            IF (ABS(error(j,i))*rmask(j,i) > crtest) nbad = 1
          END DO
        END DO
        IF (nbad == 0) GOTO 300
      END IF

      DO j=j1p1,j2m1
        za(j,i1) = za(j,i1) + (za(j,i1p1)-za(j,i1))*rmask(j,i1)
        za(j,i2) = za(j,i2) + (za(j,i2m1)-za(j,i2))*rmask(j,i2)
      END DO
      DO i=i1,i2
         za(j1,i) = za(j1,i) + (za(j1p1,i)-za(j1,i))*rmask(j1,i)
         za(j2,i) = za(j2,i) + (za(j2m1,i)-za(j2,i))*rmask(j2,i)
      END DO

    ENDDO

    300 CONTINUE

    RETURN

END SUBROUTINE

END MODULE


module LongMoltiplication
  implicit none

  type longnum
     integer, dimension(:), pointer :: num
  end type longnum

  interface operator (*)
     module procedure longmolt_ll
  end interface

contains

  subroutine longmolt_s2l(istring, num)
    character(len=*), intent(in) :: istring
    type(longnum), intent(out) :: num

    integer :: i, l

    l = len(istring)

    allocate(num%num(l))

    forall(i=1:l) num%num(l-i+1) = iachar(istring(i:i)) - 48

  end subroutine longmolt_s2l

  ! this one performs the moltiplication
  function longmolt_ll(a, b) result(c)
    type(longnum) :: c
    type(longnum), intent(in) :: a, b

    integer, dimension(:,:), allocatable :: t
    integer :: ntlen, i, j

    ntlen = size(a%num) + size(b%num) + 1
    allocate(c%num(ntlen))
    c%num = 0

    allocate(t(size(b%num), ntlen))

    t = 0
    forall(i=1:size(b%num), j=1:size(a%num)) t(i, j+i-1) = b%num(i) * a%num(j)

    do j=2, ntlen
       forall(i=1:size(b%num)) t(i, j) = t(i, j) + t(i, j-1)/10
    end do

    forall(j=1:ntlen) c%num(j) = sum(mod(t(:,j), 10))

    do j=2, ntlen
       c%num(j) = c%num(j) + c%num(j-1)/10
    end do

    c%num = mod(c%num, 10)

    deallocate(t)
  end function longmolt_ll

  subroutine longmolt_print(num)
    type(longnum), intent(in) :: num

    integer :: i, j

    do j=size(num%num), 2, -1
       if ( num%num(j) /= 0 ) exit
    end do

    do i=j, 1, -1
       write(*,"(I1)", advance="no") num%num(i)
    end do
  end subroutine longmolt_print

end module LongMoltiplication


      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      program sc_it

      ! Demonstration of discrete Lehmann representation for imaginary
      ! time Green's function with semi-circular density of states,
      ! rho(omega) = sqrt(1-omega^2), using imaginary time sampling.
      !
      ! The DLR expansion is formed from samples at the DLR imaginary
      ! time nodes, and then evaluated both in imaginary time and
      ! Matsubara frequency domains, where its accuracy is measured.
      !
      ! The Green's function is sampled by evaluating the Green's
      ! function using the Lehmann representation with the known
      ! spectral density. The integral in the Lehmann representation is
      ! computed by high-order numerical integration. This reference
      ! Green's function is also used to test the accuracy of the DLR
      ! expansion.

      implicit none
      integer ntst_it,ntst_mf
      real *8 lambda,eps,beta

      ! Input parameters

      lambda = 1000.0d0 ! DLR high energy cutoff
      eps = 1.0d-14     ! DLR error tolerance

      beta = 1000.0d0   ! Inverse temperature

      ntst_it = 2000    ! # imaginary time test points
      ntst_mf = 2000    ! Matsubara frequency test point cutoff

      ! Main subroutine

      call sc_it_main(lambda,eps,ntst_it,ntst_mf,beta)

      end program sc_it

      subroutine sc_it_main(lambda,eps,ntst_it,ntst_mf,beta)

      implicit none
      integer ntst_it,ntst_mf
      real *8 lambda,eps,beta

      integer npg,npo,pg,i,j,r
      integer, allocatable :: it2cfp(:),mf_tst(:)
      real *8 one
      real *8, allocatable :: it2cf(:,:),dlrit(:),dlrrf(:),g(:),gc(:)
      real *8, allocatable :: xgl(:),wgl(:),xgj(:),wgj(:),pbpg(:)
      real *8, allocatable :: it_tst(:),gtst_it(:),gtrue_it(:)
      complex *16, allocatable :: gtst_mf(:),gtrue_mf(:)

      one = 1.0d0

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

      allocate(dlrrf(r),dlrit(r))

      call dlr_it_build(lambda,eps,r,dlrrf,dlrit)

      ! Get imaginary time values -> DLR coefficients matrix (LU form)

      allocate(it2cf(r,r),it2cfp(r))

      call dlr_it2cf_init(r,dlrrf,dlrit,it2cf,it2cfp)

      ! Initialize reference Green's function evaluator (note: this is
      ! not a DLR-related operation; rather, we are initializing a
      ! special-purpose subroutine to evaluate the Green's function with
      ! a semi-circular spectral density. The initialization and
      ! evaluation subroutines are defined at the bottom of this file.)

      pg = 24
      npg = max(ceiling(log(lambda)/log(2.0d0)),1)

      allocate(xgl(pg),wgl(pg),xgj(pg),wgj(pg),pbpg(2*npg+1))

      call gfun_init(pg,npg,pbpg,xgl,wgl,xgj,wgj)

      ! Sample G at imaginary time nodes

      allocate(g(r))

      do i=1,r

        call gfun_it(pg,npg,pbpg,xgl,wgl,xgj,wgj,beta,dlrit(i),&
          g(i))

      enddo

      ! Get DLR coefficients of G

      allocate(gc(r))

      call dlr_it2cf(r,1,it2cf,it2cfp,g,gc)

      ! Get imaginary time test points in relative format

      allocate(it_tst(ntst_it))

      call eqpts_rel(ntst_it,it_tst)

      ! Evaluate DLR on imaginary time test grid

      allocate(gtst_it(ntst_it))

      do i=1,ntst_it

        call dlr_it_eval(r,1,dlrrf,gc,it_tst(i),gtst_it(i))

      enddo

      ! Get Matsubara frequency test points

      allocate(mf_tst(2*ntst_mf+1))

      do i=1,2*ntst_mf+1
        mf_tst(i) = -ntst_mf+i-1
      enddo

      ! Evaluate DLR on Matsubara frequency test grid

      allocate(gtst_mf(2*ntst_mf+1))

      do i=1,2*ntst_mf+1

        call dlr_mf_eval(r,1,dlrrf,-1,gc,mf_tst(i),gtst_mf(i))

      enddo

      ! Evaluate true Green's function on imaginary time test grid

      allocate(gtrue_it(ntst_it))

      do i=1,ntst_it

        call gfun_it(pg,npg,pbpg,xgl,wgl,xgj,wgj,beta,it_tst(i),&
          gtrue_it(i))

      enddo

      ! Evaluate true Green's function on Matsubara frequency test grid

      allocate(gtrue_mf(2*ntst_mf+1))

      do i=1,2*ntst_mf+1

        call gfun_mf(pg,npg,pbpg,xgl,wgl,xgj,wgj,beta,mf_tst(i),&
          gtrue_mf(i))

      enddo

      ! Output errors

      write(6,*) ''
      write(6,*) 'lambda = ',lambda
      write(6,*) 'epsilon = ',eps
      write(6,*) 'beta = ',beta
      write(6,*) ''
      write(6,*) 'DLR rank = ',r
      write(6,*) ''
      write(6,*) 'Imag time max error = ',maxval(abs(gtst_it-gtrue_it))
      write(6,*) 'Mats freq max error = ',maxval(abs(gtst_mf-gtrue_mf))
      write(6,*) ''

      end subroutine sc_it_main

      subroutine gfun_init(n,np,pbp,xgl,wgl,xgj,wgj)

      ! Initialize subroutines gfun_it and gfun_mf, which evaluate
      ! Green's function with semi-circular density at a imaginary time
      ! and Matsubara frequency points, respectively

      implicit none
      integer n,np
      real *8 pbp(2*np+1),xgl(n),wgl(n),xgj(n),wgj(n)

      integer i
      real *8 one

      one = 1.0d0

      ! Gauss-Legendre and Gauss-Jacobi quadrature nodes and weights

      call cdgqf(n,1,0.0d0,0.0d0,xgl,wgl)
      call cdgqf(n,4,0.5d0,0.0d0,xgj,wgj)

      ! Panel endpoints for composite quadrature rule

      pbp(np+1) = 0*one
      do i=1,np
        pbp(np+i+1) = one/2**(np-i)
      enddo
      pbp(1:np) = -pbp(2*np+1:np+2:-1)

      end subroutine gfun_init

      subroutine gfun_it(n,np,pbp,xgl,wgl,xgj,wgj,beta,t,val)

      ! Evaluate Green's function with semi-circular density at an
      ! imaginary time point using the Lehmann representation. Integral
      ! is computed by high-order composite Gauss-Legendre quadrature,
      ! with Gauss-Jacobi quadrature at endpoint panels to treat square
      ! root singularities.

      implicit none
      integer n,np
      real *8 pbp(2*np+1),xgl(n),wgl(n),xgj(n),wgj(n),beta,t,val

      integer ii,jj
      real *8 one,a,b,x,tt
      real *8, external :: kfunf

      one = 1.0d0

      ! Treat 0.5<tau<1, stored in relative format, by symmetry

      tt = abs(t)

      ! Composite Gauss quadrature

      val = 0.0d0
      do ii=2,2*np-1
        a = pbp(ii)
        b = pbp(ii+1)
        do jj=1,n
          x = a+(b-a)*(xgl(jj)+one)/2
          val = val + (b-a)/2*wgl(jj)*kfunf(tt,beta*x)*&
            sqrt(one-x**2)
        enddo
      enddo

      a = one/2
      b = one
      do jj=1,n
        x = a+(b-a)*(xgj(jj)+one)/2
        val = val + ((b-a)/2)**(1.5d0)*wgj(jj)*&
          kfunf(tt,beta*x)*sqrt(one+x)
      enddo

      a = -one
      b = -one/2
      do jj=1,n
        x = a+(b-a)*(-xgj(n-jj+1)+one)/2
        val = val + ((b-a)/2)**(1.5d0)*wgj(n-jj+1)*&
          kfunf(tt,beta*x)*sqrt(one-x)
      enddo

      end subroutine gfun_it

      subroutine gfun_mf(n,np,pbp,xgl,wgl,xgj,wgj,beta,m,val)

      ! Evaluate Green's function with semi-circular density at a
      ! Matsubara frequency point using the Lehmann representation. Integral
      ! is computed by high-order composite Gauss-Legendre quadrature,
      ! with Gauss-Jacobi quadrature at endpoint panels to treat square
      ! root singularities.

      implicit none
      integer n,np,m
      real *8 pbp(2*np+1),xgl(n),wgl(n),xgj(n),wgj(n),beta
      complex *16 val

      integer ii,jj
      real *8 one,a,b,x
      complex *16, external :: kfunmf

      one = 1.0d0

      val = 0.0d0
      do ii=2,2*np-1
        a = pbp(ii)
        b = pbp(ii+1)
        do jj=1,n
          x = a+(b-a)*(xgl(jj)+one)/2
          val = val + (b-a)/2*wgl(jj)*kfunmf(2*m+1,beta*x)*&
            sqrt(one-x**2)
        enddo
      enddo

      a = one/2
      b = one
      do jj=1,n
        x = a+(b-a)*(xgj(jj)+one)/2
        val = val + ((b-a)/2)**(1.5d0)*wgj(jj)*&
          kfunmf(2*m+1,beta*x)*sqrt(one+x)
      enddo

      a = -one
      b = -one/2
      do jj=1,n
        x = a+(b-a)*(-xgj(n-jj+1)+one)/2
        val = val + ((b-a)/2)**(1.5d0)*wgj(n-jj+1)*&
          kfunmf(2*m+1,beta*x)*sqrt(one-x)
      enddo

      end subroutine gfun_mf


module physical_constants

  use amrex_fort_module, only: rt => amrex_real

  implicit none

  real(rt), parameter :: pi = 3.141592653589793238462643383279502884197d0
  real(rt), parameter :: cm_per_fm = 1.0d-13

  ! From 2014 CODATA recommended values
  real(rt), parameter :: clight  = 299792458d2  ! cm/s

  real(rt), parameter :: N_avo = 6.022140857d23 ! 1/mol

  real(rt), parameter :: gram_per_amu = 1660539.040d-30

  real(rt), parameter :: erg_per_eV  = 1.6021766208d-12
  real(rt), parameter :: erg_per_MeV = erg_per_eV*1.0d6
  real(rt), parameter :: gram_per_MeV = erg_per_MeV/CLIGHT**2

end module physical_constants


SUBROUTINE SSBEVX_F95( A, W, UPLO, Z, VL, VU, IL, IU, &
                       M, IFAIL, Q,  ABSTOL, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: LAMCH_F77 => SLAMCH
   USE F77_LAPACK, ONLY: SBEVX_F77 => LA_SBEVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
   INTEGER, INTENT(IN), OPTIONAL :: IL, IU
   INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
   REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
!  .. ARRAY ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IFAIL(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:), Q(:,:)
   REAL(WP), INTENT(INOUT) :: A(:,:)
   REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_SBEVX / LA_HBEVX compute selected eigenvalues and, optionally,
! the corresponding eigenvectors of a real symmetric/complex Hermitian
! band matrix A. Eigenvalues and eigenvectors can be selected by
! specifying either a range of values or a range of indices for the
! desired eigenvalues.
!
! =========
!
!        SUBROUTINE LA_SBEVX / LA_HBEVX( AB, W, UPLO=uplo, Z=z, &
!                 VL=vl, VU=vu, IL=il, IU=iu, M=m, IFAIL=ifail, &
!                 Q=q, ABSTOL=abstol, INFO=info )
!            <type>(<wp>), INTENT(INOUT) :: AB(:,:)
!            REAL(<wp>), INTENT(OUT) :: W(:)
!            CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!            <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!            REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
!            INTEGER, INTENT(IN), OPTIONAL :: IL, IU
!            INTEGER, INTENT(OUT), OPTIONAL :: M
!            INTEGER, INTENT(OUT), OPTIONAL :: IFAIL(:)
!            <type>(<wp>), INTENT(OUT), OPTIONAL :: Q(:,:)
!            REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
!            INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!            <type> ::= REAL j COMPLEX
!            <wp> ::= KIND(1.0) j KIND(1.0D0)
!
! Arguments
! =========
!
! AB     (input/output) REAL or COMPLEX array, shape (:,:) with
!        size(AB,1) = kd + 1 and size(AB,2) = n, where kd is the number
!        of subdiagonals or superdiagonals in the band and n is the order
!        of A.
!        On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
!        triangle of matrix A in band storage. The kd + 1 diagonals of A
!        are stored in the rows of AB so that the j-th column of A is
!        stored in the j-th column of AB as follows:
!        if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j
!                                                   1<=j<=n
!        if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd)
!                                                   1<=j<=n.
!        On exit, AB is overwritten by values generated during the
!        reduction of A to a tridiagonal matrix T . If UPLO = 'U' the
!        first superdiagonal and the diagonal of T are returned in rows
!        kd and kd + 1 of AB. If UPLO = 'L', the diagonal and first
!        subdiagonal of T are returned in the first two rows of AB.
! W      (output) REAL array, shape (:) with size(W) = n.
!        The first M elements contain the selected eigenvalues in
!        ascending order.
! UPLO   Optional (input) CHARACTER(LEN=1).
!        = 'U' : Upper triangle of A is stored;
!        = 'L' : Lower triangle of A is stored.
!        Default value: 'U'.
! Z      Optional (output) REAL or COMPLEX array, shape (:,:) with
!        size(Z,1) = n and size(Z,2) = M.
!        The first M columns of Z contain the orthonormal eigenvectors of
!        the matrix A corresponding to the selected eigenvalues, with the
!        i-th column of Z containing the eigenvector associated with the
!        eigenvalue in W(i). If an eigenvector fails to converge, then
!        that column of Z contains the latest approximation to the
!        eigenvector, and the index of the eigenvector is returned in
!        IFAIL.
!        Note: The user must ensure that at least M columns are supplied
!        in the array Z. When the exact value of M is not known in
!        advance, an upper bound must be used. In all cases M<=n.
! VL,VU  Optional (input) REAL.
!        The lower and upper bounds of the interval to be searched for
!        eigenvalues. VL < VU.
!        Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
!        <wp> ::= KIND(1.0) | KIND(1.0D0).
!        Note: Neither VL nor VU may be present if IL and/or IU is
!        present.
! IL,IU  Optional (input) INTEGER.
!        The indices of the smallest and largest eigenvalues to be
!        returned. The IL-th through IU-th eigenvalues will be found.
!        1<=IL<=IU<=size(A,1).
!        Default values: IL = 1 and IU = size(A,1).
!        Note: Neither IL nor IU may be present if VL and/or VU is
!        present.
!        Note: All eigenvalues are calculated if none of the arguments
!        VL, VU, IL and IU are present.
! M      Optional (output) INTEGER.
!        The total number of eigenvalues found. 0<=M<=size(A,1).
!        Note: If IL and IU are present then M = IU - IL + 1.
! IFAIL  Optional (output) INTEGER array, shape (:) with size(IFAIL) = n.
!        If INFO = 0, the first M elements of IFAIL are zero.
!        If INFO > 0, then IFAIL contains the indices of the eigenvectors
!        that failed to converge.
!        Note: If Z is present then IFAIL should also be present.
! Q      Optional (output) REAL or COMPLEX square array, shape(:,:) with
!        size(Q,1) = n.
!        The n by n unitary matrix used in the reduction to tridiagonal
!        form. This is computed only if Z is present.
! ABSTOL Optional (input) REAL.
!        The absolute error tolerance for the eigenvalues. An approximate
!        eigenvalue is accepted as converged when it is determined to lie
!        in an interval [a,b] of width less than or equal to
!        ABSTOL + EPSILON(1.0_<wp>) * max(|a|, |b|),
!        where <wp> is the working precision. If ABSTOL<=0, then
!        EPSILON(1.0_<wp>)* ||T||1 will be used in its place, where
!        ||T||1 is the l1 norm of the tridiagonal matrix obtained by
!        reducing A to tridiagonal form. Eigenvalues will be computed most
!        accurately when ABSTOL is set to twice the underflow threshold
!        2 * LA_LAMCH(1.0_<wp>, 'Safe minimum'), not zero.
!        Default value: 0.0_<wp>.
!        Note: If this routine returns with INFO > 0, then some
!        eigenvectors did not converge. Try setting ABSTOL to
!        2 * LA_LAMCH(1.0_<wp>, 'Safe minimum').
! INFO   Optional (output) INTEGER
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value.
!        > 0: if INFO = i, then i eigenvectors failed to converge. Their
!        indices are stored in array IFAIL.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SBEVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBZ, LUPLO, LRANGE
   INTEGER :: N, LINFO, LD, LIL, LIU, LM, ISTAT, &
              SIFAIL, S1Z, S2Z, S1Q, S2Q, KD
   INTEGER, TARGET :: ISTAT1(1)
   REAL(WP), TARGET :: LLZ(1,1), LLQ(1,1)
   REAL(WP) :: LABSTOL, LVL, LVU
!  .. LOCAL ARRAYS ..
   INTEGER, POINTER :: IWORK(:), LIFAIL(:)
   REAL(WP), POINTER :: WORK(:), LQ(:,:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC HUGE, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0
   KD = SIZE(A,1)-1; N = SIZE(A,2); LD = MAX(1,SIZE(A,1))
   IF( PRESENT(IFAIL) )THEN; SIFAIL = SIZE(IFAIL); ELSE; SIFAIL = N; END IF
   IF( PRESENT(Q) )THEN; S1Q = SIZE(Q,1); S2Q = SIZE(Q,2)
   ELSE; S1Q = N; S2Q = N; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(VL) )THEN; LVL = VL; ELSE; LVL = -HUGE(LVL); ENDIF
   IF( PRESENT(VU) )THEN; LVU = VU; ELSE; LVU = HUGE(LVU); ENDIF
   IF( PRESENT(IL) )THEN; LIL = IL; ELSE; LIL = 1; ENDIF
   IF( PRESENT(IU) )THEN; LIU = IU; ELSE; LIU = N; ENDIF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2)
   ELSE; S1Z = 1; S2Z = 1; ENDIF
!  .. TEST THE ARGUMENTS
   IF( KD < 0 .OR. N < 0 ) THEN; LINFO = -1
   ELSE IF( SIZE( W ) /= N )THEN; LINFO = -2
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
   ELSE IF( PRESENT(Z) .AND. ( S1Z /= N .OR. S2Z /= N ) )THEN; LINFO = -4
   ELSE IF( LVU < LVL )THEN; LINFO = -5
   ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
            (PRESENT(IL) .OR. PRESENT(IU)) )THEN; LINFO = -6
   ELSE IF(( LIU < LIL .OR. LIL < 1 ) .AND. N>0 )THEN; LINFO = -7
   ELSE IF( N < LIU )THEN; LINFO = -8
   ELSE IF( SIFAIL /= N .OR. PRESENT(IFAIL).AND..NOT.PRESENT(Z) )THEN; LINFO = -10
   ELSE IF( S1Q /= N .OR. S2Q /= N .OR. PRESENT(Q).AND..NOT.PRESENT(Z) )THEN; LINFO = -11
   ELSE IF( N > 0 )THEN
      IF( PRESENT(VL) .OR. PRESENT(VU) )THEN; LRANGE = 'V'; LM = N
      ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN; LRANGE = 'I'; LM = LIU-LIL+1
      ELSE; LRANGE = 'A'; LM = N; END IF
      IF( PRESENT(Z) ) THEN; LJOBZ = 'V'
         IF( PRESENT(IFAIL) )THEN; LIFAIL => IFAIL
         ELSE; ALLOCATE( LIFAIL(N), STAT=ISTAT ); END IF
         IF( ISTAT == 0 )THEN
            IF( PRESENT(Q) )THEN; LQ => Q
            ELSE; ALLOCATE( LQ(N,N), STAT=ISTAT ); END IF
         END IF
      ELSE; LJOBZ = 'N'; LIFAIL => ISTAT1; LQ => LLQ; S1Q =1; ENDIF
!     .. DETERMINE THE WORKSPACE
      IF( ISTAT == 0 ) THEN
         ALLOCATE(IWORK(MAX(1,5*N)), WORK(MAX(1,7*N)), STAT=ISTAT)
         IF( ISTAT == 0 )THEN
            IF( PRESENT(ABSTOL) )THEN; LABSTOL = ABSTOL
            ELSE; LABSTOL = 2*LAMCH_F77('Safe minimum'); ENDIF
	    IF (PRESENT (Z)) THEN
               CALL SBEVX_F77( LJOBZ, LRANGE, LUPLO, N, KD, A, LD, LQ, S1Q, LVL, LVU, &
     &                LIL, LIU, LABSTOL, LM, W, Z, S1Z, WORK, &
     &                IWORK, LIFAIL, LINFO )
            ELSE
	       CALL SBEVX_F77( LJOBZ, LRANGE, LUPLO, N, KD, A, LD, LQ, S1Q, LVL, LVU, &
     &                LIL, LIU, LABSTOL, LM, W, LLZ, S1Z, WORK, &
     &                IWORK, LIFAIL, LINFO )
            ENDIF
            IF( PRESENT(M) ) M = LM
            W(LM+1:N) = 0.0_WP
         ELSE; LINFO = -100; END IF
      END IF
      IF( PRESENT(Z) .AND. .NOT.PRESENT(IFAIL) ) DEALLOCATE( LIFAIL, STAT=ISTAT1(1) )
      IF( PRESENT(Z) .AND. .NOT.PRESENT(Q) ) DEALLOCATE( LQ, STAT=ISTAT1(1) )
      DEALLOCATE(IWORK, WORK, STAT=ISTAT1(1))
   END IF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SSBEVX_F95


module game

use iso_fortran_env, only: wp=>real64, stdin=>input_unit, stderr=>error_unit
implicit none

logical :: debug=.false.
real(wp), parameter :: maxburn = 200._wp, z=1.8, G=1e-3, Wdry=16500
real(wp) :: altitude, AltIncr, Wwet, burnrate, Vvel, Vincr, Tincr

contains

subroutine updateparams(L, T)

real(wp), intent(inout) :: L, T

L=L+Tincr
T=T-Tincr
Wwet = Wwet - Tincr*burnrate
altitude=AltIncr
Vvel=Vincr

end subroutine updateparams

subroutine step370(L, T)

real(wp), intent(inout) :: L, T
real(wp) :: W

W=(1-Wwet*G/(Z*burnrate))/2
Tincr=Wwet*Vvel/(Z*burnrate*(W+sqrt(W**2+Vvel/Z)))+.05_wp

call calc420

IF (AltIncr<=0) call landing(L, T)

call updateparams(L, T)

end subroutine step370

subroutine loop370(L, T)

real(wp), intent(inout) :: L, T

call step370(L, T)
if (Vincr>0) return
do while (Vvel>0 .and. Vincr<=0)
  call step370(L, T)
end do

end subroutine loop370

subroutine calc420()

real(wp) :: Q

Q = Tincr*burnrate/Wwet

Vincr = Vvel + G*Tincr + Z*(-Q-Q**2/2-Q**3/3-Q**4/4-Q**5/5)

AltIncr = altitude - G*Tincr**2/2 - Vvel*Tincr + Z*Tincr*(Q/2+Q**2/6+Q**3/12+Q**4/20+Q**5/30)

end subroutine calc420

subroutine landing(L, T)

real(wp), value :: L, T
real(wp) :: D

do while (Tincr>=5e-3)

  D = Vvel + sqrt(Vvel**2 + 2*altitude*(G-Z*burnrate/Wwet))
  Tincr = 2*altitude/D
  call calc420()
  call updateparams(L, T)

end do

call landed(L)

end subroutine landing

subroutine landed(L)

real(wp), intent(in) :: L
real(wp) :: W

W=3600*Vvel
PRINT '(a,f12.2,a)', "ON THE MOON AT ",L," SECONDS"
print '(a,f12.2,a)', "IMPACT VELOCITY OF ",W," MPH"

IF (W<=1.2) THEN
  print *, "PERFECT LANDING!"
  print '(a7,a7,a12)',"SEC","MPH","LB FUEL"
  print '(f7.2,f7.2,f12.2)', L, W, Wwet-Wdry
  stop
elseif (W<=10) THEN
  print *, "GOOD LANDING (COULD BE BETTER)"
  print '(a7,a7,a12)',"SEC","MPH","LB FUEL"
  print '(f7.2,f7.2,f12.2)', L, W, Wwet-Wdry
  stop
elseif (w<=60) then
  print *, "CRAFT DAMAGE: YOU'RE STRANDED HERE UNTIL A RESCUE PARTY ARRIVES. HOPE YOU HAVE ENOUGH OXYGEN!"
  print '(a7,a7,a12)',"SEC","MPH","LB FUEL"
  print '(f7.2,f7.2,f12.2)', L, W, Wwet-Wdry
  stop 1
else
  PRINT *, "SORRY THERE WERE NO SURVIVORS."
  print *,"YOU BLEW IT! IN FACT, YOU BLASTED A NEW LUNAR CRATER"
  print '(f12.2,a)', W*0.227_wp," FEET DEEP!"
  print '(a12,a12,a12)',"SEC","MPH","LB FUEL"
  print '(f12.2,f12.2,f12.2)', L, W, Wwet-Wdry
  stop 2
endif

end subroutine landed

real(wp) function burn(L)

real(wp), intent(in) :: L
integer :: i

write(*, '(f5.0,i6,i5,f7.0,f12.0, 6x)', advance='no') L, int(altitude), int(5280*modulo(altitude,1._wp)), 3600*Vvel, Wwet-Wdry

read(stdin,*,iostat=i) burn
if (i<0) stop 'Landing aborted per user request.'

if (i/=0 .or. burn < 0) then
  burn = 0
  write(stderr,'(a,f9.2)') 'burn specification not possiblee, using burnrate',burn
elseif(burn > maxburn) then
  burn = maxburn
  write(stderr,'(a,f9.2)') 'burn specification not possible, using burnrate',burn
endif

if (debug) print '(f5.1)', burn

end function burn

subroutine fuelempty(L)

real(wp), value :: L

print '(a,f7.2,a)', "FUEL RAN OUT AT ",L," SECONDS"
Tincr=(-Vvel+sqrt(Vvel**2+2*altitude*G))/G

Vvel = Vvel + G*Tincr
L = L+Tincr

call landed(L)

end subroutine fuelempty

end module game

program lunar

use game
implicit none

real(wp) :: L, T, Wfuel
integer :: k
character(8) :: buf

Wfuel=16500
do k = 1,command_argument_count()
call get_command_argument(k,buf)
  select case (buf)
  case ('-d')
    debug=.true.
  case ('-f')
    call get_command_argument(k+1, buf)
    read(buf,*) Wfuel
  end select
end do

print '(33x,a)', "LUNAR"
print '(15x,a)', "CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
print *, ''
print *, "THIS IS A COMPUTER SIMULATION OF AN APOLLO LUNAR LANDING CAPSULE."
print *, "THE ON-BOARD COMPUTER HAS FAILED (IT WAS MADE BY XEROX) SO YOU HAVE TO LAND THE CAPSULE MANUALLY."
print *, ''
print *, "SET BURN RATE OF RETRO ROCKETS TO ANY VALUE BETWEEN "
print '(a,f7.0,a)', "0 (FREE FALL) AND ",maxburn," (MAXIMUM BURN) POUNDS PER SECOND."
print *, "SET NEW BURN RATE EVERY 10 SECONDS."

L=0
altitude=120
Vvel=1
Wwet = Wdry+Wfuel
T=10

print '(a,f7.0,a)', "CAPSULE WET WEIGHT ",Wwet," LBS"
print '(a,f7.0,a)', "FUEL WEIGHT ", Wwet-Wdry, " LBS."

print *, ''
print '(a5,a11,a7,a12,a15)',"SEC","MI + FT","MPH","LB FUEL", "BURN RATE"
print *,''

burnrate = burn(L)

do
if (Wwet-Wdry<1e-3) call fuelempty(L)

if (T<1e-3) then
  T = 10
  burnrate = burn(L)
  cycle
endif

Tincr=T
IF (Wwet < Wdry+Tincr*burnrate) Tincr = (Wwet-Wdry)/burnrate

call calc420()
IF (AltIncr<=0) exit

IF (Vvel<=0) THEN
  call updateparams(L, T)
  cycle
elseif (Vincr<0) THEN
  call loop370(L, T)
  cycle
else
  call updateparams(L, T)
  cycle
endif

call loop370(L, T)

enddo

call landing(L, T)

end program


      DOUBLE PRECISION FUNCTION DK89(I,A,B,M,N,X)
      DOUBLE PRECISION F89, A, B, X, CAPX, AMF, AN1, AN2, S, SF, AMMSF
      DOUBLE PRECISION AMN1F, ANM1F
      DIMENSION X(1)
      F89 = 0.0D0
      CAPX = A + B * X(I)
      NFAC = M
      ASSIGN 5 TO IRET
      GO TO 1000
    5 AMF = KFAC
      N1 = M + 1
      N2 = N1 - N
      AN1 = N1
      AN2 = N2
      IS = 0
      S = 0.0D0
      SF = 1.0D0
      AMMSF = AMF
      GO TO 50
   10 IS = IS + 1
      S = IS
      SF = SF * S
      AMMSF = AMMSF / (AN1 - S)
   50 CONTINUE
      N3 = N2 - IS
      IF (N3 .EQ. 0) GO TO 100
      F89 = F89 + AMF *((-A)** IS) * (CAPX ** N3) / (AMMSF * SF *
     1            (AN2 - S))
      GO TO 200
  100 CONTINUE
      NFAC = N2
      ASSIGN 110 TO IRET
      GO TO 1000
  110 AMN1F = KFAC
      NFAC = N-1
      ASSIGN 120 TO IRET
      GO TO 1000
  120 ANM1F = KFAC
      F89 = F89 + AMF *((-A)** N2) *DLOG(DABS(CAPX)) / (AMN1F * ANM1F)
  200 IF (IS .LT. M) GO TO 10
      IF( B .EQ. 0.0D0 ) GO TO 300
      F89 = F89 / (B ** N1)
      DK89 = F89
      RETURN
  300 DK89 = 0.0D0
      RETURN
 1000 KFAC = 1
      IF(NFAC.LT.2) GO TO 1020
      DO 1010 LFAC=2,NFAC
      KFAC=KFAC*LFAC
 1010 CONTINUE
 1020 GO TO IRET,(5,110,120)
      END


module type_GaussianSphere

    use, intrinsic :: ISO_Fortran_env, only: &
        stderr => ERROR_UNIT

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use type_Sphere, only: &
        Sphere

    use type_GaussianWorkspace, only: &
        GaussianWorkspace

    use type_GaussianGrid, only: &
        GaussianGrid

    use type_SphericalUnitVectors, only: &
        SphericalUnitVectors

    use type_TrigonometricTable, only: &
        TrigonometricTable

    use type_Vector3D, only: &
        Vector => Vector3D, &
        assignment(=), &
        operator(*)

    use scalar_analysis_routines, only: &
        ScalarForwardTransform

    use scalar_synthesis_routines, only: &
        ScalarBackwardTransform

    use vector_analysis_routines, only: &
        VectorForwardTransform

    use vector_synthesis_routines, only: &
        VectorBackwardTransform

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: GaussianSphere

    ! Parameter confined to the module
    real(wp), parameter :: ONE = 1.0_wp

    type, public, extends(Sphere) :: GaussianSphere
    contains
        ! Type-bound procedures
        procedure, public :: assert_initialized => assert_init_gaussian_sphere
        procedure, public :: create => create_gaussian_sphere
        procedure, public :: destroy => destroy_gaussian_sphere
        procedure, public :: perform_scalar_analysis => gaussian_scalar_analysis
        procedure, public :: perform_scalar_synthesis => gaussian_scalar_synthesis
        procedure, public :: vector_analysis_from_spherical_components => gaussian_vector_analysis
        procedure, public :: perform_vector_synthesis => gaussian_vector_synthesis
        procedure, public :: compute_surface_integral
        procedure, public :: compute_first_moment
    end type GaussianSphere

    ! Declare user-defined constructor
    interface GaussianSphere
        module procedure gaussian_sphere_constructor
    end interface

contains

    function gaussian_sphere_constructor(nlat, nlon) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: nlat ! number of latitudinal points 0 <= theta <= pi
        integer(ip), intent(in) :: nlon ! number of longitudinal points 0 <= phi <= 2*pi
        type(GaussianSphere)    :: return_value

        call return_value%create(nlat, nlon)

    end function gaussian_sphere_constructor

    subroutine create_gaussian_sphere(self, nlat, nlon, ntrunc, isym, itype, nt, rsphere)

        ! Dummy arguments
        class(GaussianSphere), intent(inout) :: self
        integer(ip),           intent(in)    :: nlat
        integer(ip),           intent(in)    :: nlon
        integer(ip), optional, intent(in)    :: ntrunc
        integer(ip), optional, intent(in)    :: isym  ! Either 0, 1, or 2
        integer(ip), optional, intent(in)    :: itype ! Either 0, 1, 2, 3, ..., 8
        integer(ip), optional, intent(in)    :: nt !
        real(wp),    optional, intent(in)    :: rsphere

        ! Local variables
        integer(ip) :: ntrunc_op
        integer(ip) :: isym_op
        integer(ip) :: ityp_op
        integer(ip) :: nt_op
        real(wp)    :: rsphere_op

        ! Ensure that object is usable
        call self%destroy()

        !  Allocate polymorphic components
        allocate (self%grid, source=GaussianGrid(nlat, nlon))
        allocate (self%workspace, source=GaussianWorkspace(nlat, nlon))

        !  Address optional arguments
        if (present(ntrunc)) then
            ntrunc_op = ntrunc
        else
            ntrunc_op = nlat - 1
        end if

        if (present(isym)) then
            isym_op = isym
        else
            isym_op = 0
        end if

        if (present(itype)) then
            ityp_op = itype
        else
            ityp_op = 0
        end if

        if (present(nt)) then
            nt_op = nt
        else
            nt_op = 1
        end if

        if (present(rsphere)) then
            rsphere_op = rsphere
        else
            rsphere_op = ONE
        end if

        !  Create parent type
        call self%create_sphere(nlat, nlon, ntrunc_op, isym_op, ityp_op, nt_op, rsphere_op)

        ! Set flag
        self%initialized = .true.

    end subroutine create_gaussian_sphere

    subroutine destroy_gaussian_sphere(self)

        ! Dummy arguments
        class(GaussianSphere), intent(inout)  :: self

        ! Check flag
        if (.not.self%initialized) return

        ! Release memory from parent type
        call self%destroy_sphere()

        ! Reset initialization flag
        self%initialized = .false.

    end subroutine destroy_gaussian_sphere

    subroutine assert_init_gaussian_sphere(self, routine)

        ! Dummy arguments
        class(GaussianSphere), intent(inout) :: self
        character(len=*),      intent(in)    :: routine

        ! Check if object is usable
        select type(self)
            class is (GaussianSphere)
            if (.not.self%initialized) then
                write (stderr, '(a)') &
                    'Uninitialized object of class(RegularSphere) in '//routine
            end if
        end select

    end subroutine assert_init_gaussian_sphere

    subroutine gaussian_scalar_analysis(self, scalar_function)

        ! Dummy arguments
        class(GaussianSphere), intent(inout) :: self
        real(wp),              intent(in)    :: scalar_function(:, :)

        ! Local variables
        integer(ip)    :: error_flag
        type(ScalarForwardTransform) :: aux

        ! Check if object is usable
        call self%assert_initialized('gaussian_scalar_analysis')

        select type(self)
            class is (GaussianSphere)
            associate (workspace => self%workspace)
                select type(workspace)
                    class is (GaussianWorkspace)
                    associate (&
                        nlat => self%NUMBER_OF_LATITUDES, &
                        nlon => self%NUMBER_OF_LONGITUDES, &
                        isym => self%SCALAR_SYMMETRIES, &
                        nt => self%NUMBER_OF_SYNTHESES, &
                        g => scalar_function, &
                        idg => self%NUMBER_OF_LATITUDES, &
                        jdg => self%NUMBER_OF_LONGITUDES, &
                        a => workspace%scalar_coefficients%real_component, &
                        b => workspace%scalar_coefficients%imaginary_component, &
                        mdab => self%NUMBER_OF_LATITUDES, &
                        ndab => self%NUMBER_OF_LATITUDES, &
                        wshags => workspace%forward_scalar, &
                        ierror => error_flag &
                       )

                        !  perform the (real) spherical harmonic scalar analysis
                        call aux%shags(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
                            wshags, ierror)
                    end associate
                end select
            end associate
        end select

        ! Address error flag
        select case (error_flag)
            case(0)
                return
            case (1)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //'invalid specification of NUMBER_OF_LATITUDES'
            case (2)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //'invalid specification of NUMBER_OF_LONGITUDES'
            case (3)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //'invalid specification for scalar_forward'
            case (4)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //'invalid specification for legendre_workspace'
            case (5)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //'invalid specification for dwork'
            case (6)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //' failure in compute_gaussian_latitudes_and_weights due to failure in eigenvalue routine'
            case default
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_analysis'&
                    //' undetermined error'
        end select

    end subroutine gaussian_scalar_analysis

    subroutine gaussian_scalar_synthesis(self, scalar_function)

        ! Dummy arguments
        class(GaussianSphere), intent(inout) :: self
        real(wp),              intent(out)   :: scalar_function(:, :)

        ! Local variables
        integer(ip)    :: error_flag
        type(ScalarBackwardTransform) :: aux

        ! Check if object is usable
        call self%assert_initialized('gaussian_scalar_synthesis')

        select type(self)
            class is (GaussianSphere)
            associate (workspace => self%workspace)
                select type(workspace)
                    class is (GaussianWorkspace)
                    associate (&
                        nlat => self%NUMBER_OF_LATITUDES, &
                        nlon => self%NUMBER_OF_LONGITUDES, &
                        isym => self%SCALAR_SYMMETRIES, &
                        nt => self%NUMBER_OF_SYNTHESES, &
                        g => scalar_function, &
                        idg => size(scalar_function, dim=1), &
                        jdg => size(scalar_function, dim=2), &
                        a => workspace%scalar_coefficients%real_component, &
                        b => workspace%scalar_coefficients%imaginary_component, &
                        mdab => size(workspace%scalar_coefficients%real_component, dim=1), &
                        ndab => size(workspace%scalar_coefficients%real_component, dim=2), &
                        wshsgs => workspace%backward_scalar, &
                        ierror => error_flag &
                       )
                        !
                        !  Perform gaussian scalar synthesis
                        !
                        call aux%shsgs(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshsgs, ierror)

                    end associate
                end select
            end associate
        end select

        !  Address error flag
        select case (error_flag)
            case(0)
                return
            case (1)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'invalid specification of NUMBER_OF_LATITUDES'
            case (2)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'invalid specification of NUMBER_OF_LONGITUDES'
            case (3)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'invalid specification for scalar_backward'
            case (4)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'invalid specification for legendre_workspace'
            case (5)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'invalid specification for dwork'
            case (6)
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'Failure in compute_gaussian_latitudes_and_weights due to failure in eigenvalue routine'
            case default
                error stop 'Object of class(GaussianSphere) in gaussian_scalar_synthesis'&
                    //'Undetermined error flag'
        end select

    end subroutine gaussian_scalar_synthesis

    subroutine gaussian_vector_analysis(self, polar_component, azimuthal_component)

        ! Dummy arguments
        class(GaussianSphere), intent(inout)  :: self
        real(wp),              intent(in)     :: polar_component(:, :)
        real(wp),              intent(in)     :: azimuthal_component(:, :)

        ! Local variables
        integer(ip)    :: error_flag
        type(VectorForwardTransform) :: aux

         ! Check if object is usable
        call self%assert_initialized('gaussian_vector_analysis')

        select type(self)
            class is (GaussianSphere)
            associate (workspace => self%workspace)
                select type(workspace)
                    class is (GaussianWorkspace)
                    associate (&
                        nlat => self%NUMBER_OF_LATITUDES, &
                        nlon => self%NUMBER_OF_LONGITUDES, &
                        ityp => self%VECTOR_SYMMETRIES, &
                        nt => self%NUMBER_OF_SYNTHESES, &
                        v => polar_component, &
                        w => azimuthal_component, &
                        idvw => size(polar_component, dim=1), &
                        jdvw => size(polar_component, dim=2), &
                        br => workspace%vector_coefficients%polar%real_component, &
                        bi => workspace%vector_coefficients%polar%imaginary_component, &
                        cr => workspace%vector_coefficients%azimuthal%real_component, &
                        ci => workspace%vector_coefficients%azimuthal%imaginary_component, &
                        mdab => size(workspace%vector_coefficients%polar%real_component, dim=1), &
                        ndab => size(workspace%vector_coefficients%polar%real_component, dim=2), &
                        wvhags => workspace%forward_vector, &
                        ierror => error_flag &
                       )

                        !  Perform gaussian vector analysis
                        call aux%vhags(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
                            mdab, ndab, wvhags, ierror)

                    end associate
                end select
            end associate
        end select

        !  Address error flag
        select case (error_flag)
            case(0)
                return
            case (1)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid specification of NUMBER_OF_LATITUDES'
            case (2)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid specification of NUMBER_OF_LONGITUDES'
            case (3)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid specification of VECTOR_SYMMETRIES'
            case (4)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid specification of NUMBER_OF_SYNTHESES'
            case (5)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid dim=1 extent for '&
                    //'polar_component (theta) or azimuthal_component (phi)'
            case (6)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid dim=2 extent '&
                    //'polar_component (theta) or azimuthal_component (phi)'
            case (7)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid dim=1 extent for br or cr'
            case (8)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid dim=1 extent for bi or ci'
            case (9)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid specification for forward_vector'
            case (10)
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'invalid specification for legendre_workspace'
            case default
                error stop 'Object of class(GaussianSphere) in '&
                    //'gaussian_vector_analysis'&
                    //'Undetermined error flag'
        end select

    end subroutine gaussian_vector_analysis

    subroutine gaussian_vector_synthesis(self, polar_component, azimuthal_component)

        ! Dummy arguments
        class(GaussianSphere), intent(inout)  :: self
        real(wp),              intent(out)    :: polar_component(:, :)
        real(wp),              intent(out)    :: azimuthal_component(:, :)

        ! Local variables
        integer(ip)    :: error_flag
        type(VectorBackwardTransform) :: aux

        ! Check if object is usable
        call self%assert_initialized('gaussian_vector_synthesis')

        select type(self)
            class is (GaussianSphere)
            associate (workspace => self%workspace)
                select type(workspace)
                    class is (GaussianWorkspace)
                    associate (&
                        nlat => self%NUMBER_OF_LATITUDES, &
                        nlon => self%NUMBER_OF_LONGITUDES, &
                        ityp => self%VECTOR_SYMMETRIES, &
                        nt => self%NUMBER_OF_SYNTHESES, &
                        v => polar_component, &
                        w => azimuthal_component, &
                        idvw => size(polar_component, dim=1),  &
                        jdvw => size(polar_component, dim=2),  &
                        br => workspace%vector_coefficients%polar%real_component, &
                        bi => workspace%vector_coefficients%polar%imaginary_component, &
                        cr => workspace%vector_coefficients%azimuthal%real_component, &
                        ci => workspace%vector_coefficients%azimuthal%imaginary_component, &
                        mdab => size(workspace%vector_coefficients%polar%real_component, dim=1), &
                        ndab => size(workspace%vector_coefficients%polar%real_component, dim=2), &
                        wvhsgs => workspace%backward_vector, &
                        ierror => error_flag &
                       )

                        !  Perform gaussian vector synthesis
                        call aux%vhsgs(nlat, nlon, ityp, nt, v, w, idvw, jdvw, &
                            br, bi, cr, ci, mdab, ndab, wvhsgs, ierror)
                    end associate
                end select
            end associate
        end select

        !  Address error flag
        select case (error_flag)
            case(0)
                return
            case (1)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid specification of NUMBER_OF_LATITUDES'
            case (2)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid specification of NUMBER_OF_LONGITUDES'
            case (3)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid specification of VECTOR_SYMMETRIES'
            case (4)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid specification of NUMBER_OF_SYNTHESES'
            case (5)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid dim=1 extent for '&
                    //'polar_component (theta) or azimuthal_component (phi)'
            case (6)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid dim=2 extent '&
                    //'polar_component (theta) or azimuthal_component (phi)'
            case (7)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid dim=1 extent for br or cr'
            case (8)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid dim=1 extent for bi or ci'
            case (9)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid specification for backward_vector'
            case (10)
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'invalid specification for legendre_workspace'
            case default
                error stop 'Object of class(GaussianSphere) in gaussian_vector_synthesis'&
                    //'Undetermined error flag'
        end select

    end subroutine gaussian_vector_synthesis

    !
    ! Purpose:
    !
    ! computes the (scalar) surface integral on the sphere (S^2):
    !
    ! * Trapezoidal rule    in phi:   0 <=  phi  <= 2*pi
    ! * Gaussian quadrature in theta: 0 <= theta <= pi
    !
    !   \int_{S^2} f( theta, phi) dS
    !
    !   where
    !
    !   dS = sin(theta) dtheta dphi
    !
    function compute_surface_integral(self, scalar_function) &
        result (return_value)

        ! Dummy arguments
        class(GaussianSphere), intent(inout) :: self
        real(wp),              intent(in)    :: scalar_function(:, :)
        real(wp)                             :: return_value

        ! Local variables
        integer(ip) :: k, nlat

        ! Check if object is usable
        call self%assert_initialized('get_surface_integral')

        nlat = self%NUMBER_OF_LATITUDES

        block
            real(wp) :: summation(nlat)

            !  compute the integrant
            associate (grid => self%grid)
                select type(grid)
                    class is (GaussianGrid)
                    associate (&
                        dphi => grid%LONGITUDINAL_MESH, &
                        wts => grid%gaussian_weights, &
                        f => scalar_function &
                       )

                        !  Apply trapezoidal rule
                        do k = 1, nlat
                            summation(k) = sum(f(k, :)) * dphi
                        end do

                        !  Apply gaussian quadrature
                        summation = summation * wts
                    end associate
                end select
            end associate

            !  Set integral \int_{S^2} f( theta, phi) dS
            return_value = sum(summation)
        end block

    end function compute_surface_integral

    subroutine compute_first_moment(self, scalar_function, first_moment)

        ! Dummy arguments
        class(GaussianSphere), intent(inout) :: self
        real(wp),              intent(in)    :: scalar_function(:, :)
        class(Vector),         intent(out)   :: first_moment

        ! Local variables
        integer(ip) :: i, j, nlat, nlon

        ! Check if object is usable
        call self%assert_initialized('compute_first_moment')

        nlat = self%NUMBER_OF_LATITUDES
        nlon = self%NUMBER_OF_LONGITUDES

        block
            real(wp) :: integrant(nlat, nlon, 3)

            ! Compute integrant
            do j = 1, nlon
                do i = 1, nlat
                    associate (&
                        u => self%unit_vectors%radial(i, j), &
                        f => scalar_function(i, j) &
                       )
                        integrant(i, j, 1) = u%x * f
                        integrant(i, j, 2) = u%y * f
                        integrant(i, j, 3) = u%z * f
                    end associate
                end do
            end do

            ! Compute first moment
            associate (&
                m => first_moment, &
                f1 => integrant(:, :, 1), &
                f2 => integrant(:, :, 2), &
                f3 => integrant(:, :, 3) &
               )
                m%x = self%compute_surface_integral(f1)
                m%y = self%compute_surface_integral(f2)
                m%z = self%compute_surface_integral(f3)
            end associate
        end block

    end subroutine compute_first_moment

end module type_GaussianSphere


PROGRAM test_complex_class
USE complex_class
IMPLICIT NONE

! Declare data types
TYPE(complex_ob) :: c1
TYPE(complex_ob) :: c2
REAL :: scalar

! Initialise data
c1 = c1%ini(1.,-3.)
c2 = c2%ini(-4.,2.)
scalar = 5.

! Write the results of adding two complex numbers
WRITE (*,*) c1%add(c2)

! Write the results of adding a scalar to a complex number
WRITE (*,*) c1%add(scalar)

END PROGRAM test_complex_class


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testGeom_Plane
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE Constants_Conversion
USE ParameterLists
USE Geom

IMPLICIT NONE

TYPE(PointType) :: point,point2,points(2)
TYPE(LineType) :: line1,line2
TYPE(PlaneType) :: plane1,plane2,planes(2)
LOGICAL(SBK) :: bool

CREATE_TEST('Test Geom')
CALL eParams%setQuietMode(.TRUE.)
CALL eParams%setStopOnError(.FALSE.)

REGISTER_SUBTEST('Test Plane',TestPlane)

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE TestPlane
  REAL(SRK) :: n(3)
!
!Test clear
  COMPONENT_TEST('%clear()')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK,0.5_SRK/))
  plane1%n=(/1.0_SRK,1.0_SRK,1.0_SRK/)
  plane1%v0=point2
  CALL plane1%clear()
  bool = .NOT.(ANY(plane1%n /= 0.0_SRK) .OR. plane1%v0%dim /= 0 .OR. &
      ALLOCATED(plane1%v0%coord))
  ASSERT(bool, 'plane1%clear()')

  COMPONENT_TEST('%set()')
  n=(/1.0_SRK,1.0_SRK,1.0_SRK/)
  CALL plane1%set(n,point)
  bool = .NOT.(ANY(plane1%v0%coord /= 0.5_SRK) .OR. ANY(.NOT.(plane1%n .APPROXEQ. &
      (/1._SRK/SQRT(3.0_SRK),1._SRK/SQRT(3.0_SRK),1._SRK/SQRT(3.0_SRK)/))))
  ASSERT(bool, 'plane1%set(...)')
  !CALL plane1%clear()

  !Test disjoint-ness
  COMPONENT_TEST('%intersect()')
  CALL line1%clear()
  CALL line1%p1%init(COORD=(/0._SRK,0._SRK,0._SRK/))
  CALL line1%p2%init(COORD=(/0.1_SRK,0.1_SRK,0.1_SRK/))
  point2=plane1%intersectLine(line1)
  ASSERT(point2%dim == -3, 'plane%intersect(...)')

  !Test for collinearity
  CALL line1%clear()
  CALL line1%p1%init(COORD=(/0.5_SRK,0.5_SRK,0.5_SRK/))
  CALL line1%p2%init(COORD=(/0.75_SRK,0.75_SRK,0._SRK/))
  point2=plane1%intersectLine(line1)
  ASSERT(point2%dim == -2, 'plane%intersect(...)')

  !Test for parallel
  CALL line1%clear()
  CALL line1%p1%init(COORD=(/0.4_SRK,0.4_SRK,0.4_SRK/))
  CALL line1%p2%init(COORD=(/0.65_SRK,0.65_SRK,-0.1_SRK/))
  point2=plane1%intersectLine(line1)
  ASSERT(point2%dim == -3, 'plane%intersect(...)')

  CALL line1%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK,1.0_SRK/))
  point2=plane1%intersectLine(line1)
  bool = .NOT.(point2%dim /= 3 .OR. ANY(.NOT.(point2%coord .APPROXEQ. 0.5_SRK)))
  ASSERT(bool, 'plane1%intersect(...)')

  !Test for bad input
  CALL line1%clear()
  point2=plane1%intersectLine(line1)
  ASSERT(point2%dim == -1, 'plane%intersect(...)')

  CALL line2%clear
  CALL line2%p1%init(COORD=(/-0.5_SRK,2.5_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,2.5_SRK/))
  point2=plane1%intersectLine(line2)
  ASSERT(point2%dim == -1, 'plane%intersect(...)')

  CALL plane1%clear()
  point2=plane1%intersectLine(line2)
  ASSERT(point2%dim == -1, 'plane%intersect(...)')

  !Test for equivalence operation
  COMPONENT_TEST('OPERATOR(==)')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK,0.5_SRK/))
  n=(/1.0_SRK,1.0_SRK,1.0_SRK/)
  CALL plane1%set(n,point)
  plane2=plane1
  ASSERT(plane1 == plane2,'plane equivalence')
  n=(/1.0_SRK,0.0_SRK,1.0_SRK/)
  CALL plane2%set(n,point)
  ASSERT(.NOT.(plane1 == plane2),'plane non-equivalence')

  COMPONENT_TEST('Elemental %set()')
  n=(/1.0_SRK,1.0_SRK,1.0_SRK/)
  CALL plane1%set(n,point)
  planes=plane1
  CALL line1%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK,1.0_SRK/))
  points=planes%intersectLine(line1)
  bool = .NOT.(points(1)%dim /= 3 .OR. ANY(.NOT.(points(1)%coord .APPROXEQ. 0.5_SRK)) .OR. &
      points(2)%dim /= 3 .OR. ANY(.NOT.(points(2)%coord .APPROXEQ. 0.5_SRK)))
  ASSERT(bool, 'planes%intersect(...)')

  COMPONENT_TEST('Elemental %clear()')
  CALL planes%clear()
  bool = .NOT.(ANY(planes(1)%n /= 0.0_SRK) .OR. planes(1)%v0%dim /= 0 .OR. &
      ALLOCATED(planes(1)%v0%coord) .OR. ANY(planes(2)%n /= 0.0_SRK) .OR. &
      planes(2)%v0%dim /= 0 .OR. ALLOCATED(planes(2)%v0%coord))
  ASSERT(bool, 'planes%clear()')
ENDSUBROUTINE TestPlane

ENDPROGRAM testGeom_Plane


!##############################################################################
! PROGRAM household2
!
! ## The life cycle model with wage risk
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog05_02m.f90"

program household2

    use globals
    use toolbox

    implicit none
    real*8 :: x(1+n_w)
    real*8 :: fret, low(1+n_w), up(1+n_w)
    integer :: j, iw

    ! discretize w
    call log_normal_discrete(w, weight_w, mu_w, sig_w)

    ! lower and upper border and initial guess
    low = 0d0
    up(1) = mu_w
    up(2:1+n_w) = R*mu_w+w
    x = up/2d0

    ! minimization routine
    call fminsearch(x, fret, low, up, utility)

    ! set up data for output
    do iw = 1, n_w
        wag(1,iw) = mu_w
        inc(1,iw) = mu_w
        sav(1,iw) = a(2,1)

        wag(2,iw) = w(iw)
        inc(2,iw) = w(iw)+R*a(2,1)
        sav(2,iw) = a(3,iw)

        wag(3,iw) = 0d0
        inc(3,iw) = R*a(3,iw)
        sav(3,iw) = 0d0
    enddo

    ! output
    write(*,'(/a/)')' AGE   CONS   WAGE    INC    SAV'
    do j = 1, 3
        write(*,'(i4,4f7.2,a)')j,E(c(j,:)),E(wag(j,:)),&
            E(inc(j,:)),E(sav(j,:)),' (MEAN)'
        write(*,'(4x,4f7.2,a/)')Std(c(j,:)),Std(wag(j,:)),&
            Std(inc(j,:)),Std(sav(j,:)),' (STD)'
    enddo

    write(*,'(/2(a,f6.2))')' E(w) = ',sum(weight_w*w),'   Var(w) = ', &
        sum(weight_w*w**2)-sum(weight_w*w)**2

end program


program vinay
  print *, (3 ** 2 ** 3)
end program vinay


CS    REAL FUNCTION BESI0(X)
      DOUBLE PRECISION FUNCTION BESI0(X)
C--------------------------------------------------------------------
C
C This long precision subprogram computes approximate values for
C   modified Bessel functions of the first kind of order zero for
C   arguments ABS(ARG) .LE. XMAX  (see comments heading CALCI0).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT=1
      CALL CALCI0(X,RESULT,JINT)
      BESI0=RESULT
      RETURN
C---------- Last line of BESI0 ----------
      END


      subroutine tqente(trans,cod,beam,al,bz,irad)
      use mathfun, only: sqrtl
      use sol, only:tsoldz
      use temw,only:tmulbs
      implicit none
      integer*4 irad,i
      real*8 trans(6,12),cod(6),beam(42),trans1(6,6),trans2(6,6),
     $     al,bz,pr,a,pz,r,pxi,pyi,bzh,z0,f,g,fx,fy,dpz,rpz,ptmin
      parameter (ptmin=0.9999d0)
      pr=1.d0+cod(6)
      if(bz .eq. 0.d0)then
        pxi=cod(2)
        pyi=cod(4)
        a=pxi**2+pyi**2
        dpz=-a/pr/(1.d0+sqrtl(1.d0-a/pr**2))
        pz=pr+dpz
        r=-dpz/pz/pr*al
        rpz=pz/pr
        cod(1)=cod(1)+r*pxi
        cod(3)=cod(3)+r*pyi
        cod(5)=cod(5)-(2.d0+rpz)*a/2.d0/(pr+pz)*r
        f=al/pz**3
        fx=f*pxi
        fy=f*pyi
        g=dpz*(1.d0+rpz+rpz**2)
        if(irad .gt. 6)then
          call tinitr(trans2)
        endif
        trans2(1,2)=r+pxi*fx
        trans2(1,4)=pyi*fx
        trans2(1,6)=g*fx
        trans2(3,2)=pxi*fy
        trans2(3,4)=r+pyi*fy
        trans2(3,6)=g*fy
        trans2(5,2)=trans2(1,6)
        trans2(5,4)=trans2(3,6)
        trans2(5,6)=-a*g/pr*f
        trans(1,1)=trans(1,1)+trans2(1,2)*trans(2,1)
     $       +trans2(1,4)*trans(4,1)+trans2(1,6)*trans(6,1)
        trans(3,1)=trans(3,1)+trans2(3,2)*trans(2,1)
     $       +trans2(3,4)*trans(4,1)+trans2(3,6)*trans(6,1)
        trans(5,1)=trans(5,1)+trans2(5,2)*trans(2,1)
     $       +trans2(5,4)*trans(4,1)+trans2(5,6)*trans(6,1)
        trans(1,2)=trans(1,2)+trans2(1,2)*trans(2,2)
     $       +trans2(1,4)*trans(4,2)+trans2(1,6)*trans(6,2)
        trans(3,2)=trans(3,2)+trans2(3,2)*trans(2,2)
     $       +trans2(3,4)*trans(4,2)+trans2(3,6)*trans(6,2)
        trans(5,2)=trans(5,2)+trans2(5,2)*trans(2,2)
     $       +trans2(5,4)*trans(4,2)+trans2(5,6)*trans(6,2)
        trans(1,3)=trans(1,3)+trans2(1,2)*trans(2,3)
     $       +trans2(1,4)*trans(4,3)+trans2(1,6)*trans(6,3)
        trans(3,3)=trans(3,3)+trans2(3,2)*trans(2,3)
     $       +trans2(3,4)*trans(4,3)+trans2(3,6)*trans(6,3)
        trans(5,3)=trans(5,3)+trans2(5,2)*trans(2,3)
     $       +trans2(5,4)*trans(4,3)+trans2(5,6)*trans(6,3)
        trans(1,4)=trans(1,4)+trans2(1,2)*trans(2,4)
     $       +trans2(1,4)*trans(4,4)+trans2(1,6)*trans(6,4)
        trans(3,4)=trans(3,4)+trans2(3,2)*trans(2,4)
     $       +trans2(3,4)*trans(4,4)+trans2(3,6)*trans(6,4)
        trans(5,4)=trans(5,4)+trans2(5,2)*trans(2,4)
     $       +trans2(5,4)*trans(4,4)+trans2(5,6)*trans(6,4)
        trans(1,5)=trans(1,5)+trans2(1,2)*trans(2,5)
     $       +trans2(1,4)*trans(4,5)+trans2(1,6)*trans(6,5)
        trans(3,5)=trans(3,5)+trans2(3,2)*trans(2,5)
     $       +trans2(3,4)*trans(4,5)+trans2(3,6)*trans(6,5)
        trans(5,5)=trans(5,5)+trans2(5,2)*trans(2,5)
     $       +trans2(5,4)*trans(4,5)+trans2(5,6)*trans(6,5)
        trans(1,6)=trans(1,6)+trans2(1,2)*trans(2,6)
     $       +trans2(1,4)*trans(4,6)+trans2(1,6)*trans(6,6)
        trans(3,6)=trans(3,6)+trans2(3,2)*trans(2,6)
     $       +trans2(3,4)*trans(4,6)+trans2(3,6)*trans(6,6)
        trans(5,6)=trans(5,6)+trans2(5,2)*trans(2,6)
     $       +trans2(5,4)*trans(4,6)+trans2(5,6)*trans(6,6)
        do i=7,irad
          trans(1,i)=trans(1,i)+trans2(1,2)*trans(2,i)
     $         +trans2(1,4)*trans(4,i)+trans2(1,6)*trans(6,i)
          trans(3,i)=trans(3,i)+trans2(3,2)*trans(2,i)
     $         +trans2(3,4)*trans(4,i)+trans2(3,6)*trans(6,i)
          trans(5,i)=trans(5,i)+trans2(5,2)*trans(2,i)
     $         +trans2(5,4)*trans(4,i)+trans2(5,6)*trans(6,i)
        enddo
      else
        bzh=bz*.5d0
c cod are canonical!
        pxi=cod(2)+bzh*cod(3)
        pyi=cod(4)-bzh*cod(1)
        a=pxi**2+pyi**2
        pz=pr*sqrtl(1.d0-a/pr**2)
        r=a/pr/(pr+pz)*al
        call tinitr(trans2)
        trans2(2,3)= bzh
        trans2(4,1)=-bzh
        trans2(5,2)= pxi/pr/pz*al
        trans2(5,3)= pxi*bzh/pr/pz*al
        trans2(5,4)= pyi/pr/pz*al
        trans2(5,1)=-pyi*bzh/pr/pz*al
        trans2(5,5)=0.d0
        trans2(5,6)=-a/pr**2/pz*al
        cod(2)=pxi
        cod(4)=pyi
        z0=cod(5)
        call tsoldz(trans1,cod,r,0.d0,0.d0,bz,.false.)
        trans2=matmul(trans1,trans2)
c        call tmultr(trans2,trans1,6)
        cod(5)=z0-(a/pr/(pr+pz))**2*(2.d0*pr+pz)/pz/2.d0*al
        trans2(5,5)=1.d0
        trans2(5,6)=a**2*(pr**2+pr*pz+pz**2)/(pr*pz)**3/(pr+pz)*al
        cod(2)=cod(2)-bzh*cod(3)
        cod(4)=cod(4)+bzh*cod(1)
        trans2(2,1)=trans2(2,1)-bzh*trans2(3,1)
        trans2(4,1)=trans2(4,1)+bzh*trans2(1,1)
        trans2(2,2)=trans2(2,2)-bzh*trans2(3,2)
        trans2(4,2)=trans2(4,2)+bzh*trans2(1,2)
        trans2(2,3)=trans2(2,3)-bzh*trans2(3,3)
        trans2(4,3)=trans2(4,3)+bzh*trans2(1,3)
        trans2(2,4)=trans2(2,4)-bzh*trans2(3,4)
        trans2(4,4)=trans2(4,4)+bzh*trans2(1,4)
        trans2(2,6)=trans2(2,6)-bzh*trans2(3,6)
        trans2(4,6)=trans2(4,6)+bzh*trans2(1,6)
        trans2(5,1)=
     $       -trans2(1,1)*trans2(2,6)
     $       +trans2(2,1)*trans2(1,6)
     $       -trans2(3,1)*trans2(4,6)
     $       +trans2(4,1)*trans2(3,6)
        trans2(5,2)=
     $       -trans2(1,2)*trans2(2,6)
     $       +trans2(2,2)*trans2(1,6)
     $       -trans2(3,2)*trans2(4,6)
     $       +trans2(4,2)*trans2(3,6)
        trans2(5,3)=
     $       -trans2(1,3)*trans2(2,6)
     $       +trans2(2,3)*trans2(1,6)
     $       -trans2(3,3)*trans2(4,6)
     $       +trans2(4,3)*trans2(3,6)
        trans2(5,4)=
     $       -trans2(1,4)*trans2(2,6)
     $       +trans2(2,4)*trans2(1,6)
     $       -trans2(3,4)*trans2(4,6)
     $       +trans2(4,4)*trans2(3,6)
        call tmultr5(trans,trans2,irad)
c      write(*,'(a/,6(1p6g11.4/))')
c     $     'tqente-2 ',((trans(i,j),j=1,6),i=1,6)
c      write(*,*)'with irad: ',irad
      endif
      if(irad .gt. 6)then
        call tmulbs(beam,trans2,.true.)
      endif
      return
      end


subroutine refl_ray_ini(xzt,yzt,xst,yst,ips, nrefl,tout)

real xtmp(1000),ytmp(1000)
common/ray/ nodes,xray(1000),yray(1000)
common/ray_param/ds_ini,ds_part_min,bend_min0,bend_max0

yzt2 = yyy_surf(xzt)*2 - yzt
yst2 = yyy_surf(xst)*2 - yst

write(*,*)' yzt2=',yzt2,' yst2=',yst2

aaa1=(yzt-yst2)/(xzt-xst)
bbb1=(xzt*yst2-xst*yzt)/(xzt-xst)

aaa2=(yzt2-yst)/(xzt-xst)
bbb2=(xzt*yst-xst*yzt2)/(xzt-xst)

xxx = (bbb2-bbb1) / (aaa1-aaa2)
yyy1 = aaa1 * xxx + bbb1
yyy2 = aaa2 * xxx + bbb2

write(*,*)' xxx=',xxx,' yyy=',yyy1,yyy2

xrefl=xxx
yrefl=yyy_surf(xxx)

write(*,*)' xrefl=',xrefl,' yrefl=',yrefl

call streight_line(xzt,yzt,xrefl,yrefl,ips, tout1)

nrefl=nodes

ntmp=nodes
xtmp=xray
ytmp=yray

call streight_line(xrefl,yrefl,xst,yst,ips, tout2)

do i=2,nodes
	ntmp=ntmp+1
	xtmp(ntmp)=xray(i)
	ytmp(ntmp)=yray(i)
end do

nodes=ntmp
xray=xtmp
yray=ytmp

tout=tout1+tout2

!do i=1,nodes
	!write(*,*)i,xray(i),yray(i)
!end do

return
end


program t_ddot
  implicit none
  integer, parameter :: N=4
  real(8) :: x(N), y(N)
  real(8) :: res
  ! Function
  real(8) :: ddot

  x(:) = 1.d0
  y(:) = 2.d0

  res = ddot(N,x,1,y,1)

  write(*,*) 'res = ', res

end program


PROGRAM Jim_solution_format

  IMPLICIT NONE

  INTEGER,PARAMETER :: max_grid_size1 = 31
  INTEGER,PARAMETER :: max_grid_size2 = 21
  INTEGER,PARAMETER :: max_cages = 10000
  INTEGER, PARAMETER :: max_cells_in_cage = 9
  INTEGER,DIMENSION(max_cages,max_cells_in_cage,2) :: cage_to_cells
  INTEGER,DIMENSION(max_cages) :: cage_sum
  INTEGER,DIMENSION(max_cages) :: cage_no_of_cells
  INTEGER :: i,j,ncells_local,cage_sum_local
  INTEGER :: ngroups_hor,ngroups_ver,ngroups_total
  INTEGER :: k,kk,jcell
  CHARACTER(LEN=max_grid_size2) :: sudoku_string

  INTEGER,DIMENSION(max_grid_size1,max_grid_size2) :: sudoku

  OPEN(UNIT=10,FILE='kakuro-initial-jim',STATUS='OLD',ACCESS='SEQUENTIAL',ACTION='READ')
  DO i=1,max_grid_size1
!      write(*,*) 'i is :',i
!     READ(10,*) sudoku_string
!     DO j=1,max_grid_size2
!	sudoku(i,j) = ICHAR(sudoku_string(j))
!     END DO
     READ(10,*) sudoku(i,:)
     write(*,*) sudoku(i,:)
  END DO

  ngroups_hor = 0
  ngroups_ver = 0
  ngroups_total = 0

  DO i=1,max_grid_size1
   ncells_local = 0
   cage_sum_local = 0
   DO j=1,max_grid_size2
     IF (sudoku(i,j) .eq. 0) THEN
       IF (ncells_local .eq. 0) CYCLE
       ngroups_hor = ngroups_hor+1
       ngroups_total=ngroups_total+1
       cage_sum(ngroups_total) = cage_sum_local
       cage_no_of_cells(ngroups_total) = ncells_local
       DO k=1,ncells_local
	 kk=j-k
	 cage_to_cells(ngroups_total,k,1) = i
	 cage_to_cells(ngroups_total,k,2) = kk
       END DO
       ncells_local = 0
       cage_sum_local = 0
     ELSE
	ncells_local= ncells_local+1
	cage_sum_local = cage_sum_local+sudoku(i,j)
     END IF

     IF ((j .eq. max_grid_size2) .AND. (sudoku(i,j) .ne. 0)) THEN
       ngroups_hor = ngroups_hor+1
       ngroups_total=ngroups_total+1
       cage_sum(ngroups_total) = cage_sum_local
       cage_no_of_cells(ngroups_total) = ncells_local
       DO k=1,ncells_local
         kk=j-k+1
         cage_to_cells(ngroups_total,k,1) = i
         cage_to_cells(ngroups_total,k,2) = kk
       END DO
       ncells_local = 0
       cage_sum_local = 0
     END IF
    END DO
  END DO

  DO j=1,max_grid_size2
   ncells_local = 0
   cage_sum_local = 0
   DO i=1,max_grid_size1
     IF (sudoku(i,j) .eq. 0) THEN
       IF (ncells_local .eq. 0) CYCLE
       ngroups_ver = ngroups_ver+1
       ngroups_total=ngroups_total+1
       cage_sum(ngroups_total) = cage_sum_local
       cage_no_of_cells(ngroups_total) = ncells_local
       DO k=1,ncells_local
         kk=i-k
         cage_to_cells(ngroups_total,k,1) = kk
         cage_to_cells(ngroups_total,k,2) = j
       END DO
       ncells_local = 0
       cage_sum_local = 0
     ELSE
        ncells_local= ncells_local+1
        cage_sum_local = cage_sum_local+sudoku(i,j)
     END IF

     IF ((i .eq. max_grid_size1) .AND. (sudoku(i,j) .ne. 0)) THEN
       ngroups_ver = ngroups_ver+1
       ngroups_total=ngroups_total+1
       cage_sum(ngroups_total) = cage_sum_local
       cage_no_of_cells(ngroups_total) = ncells_local
       DO k=1,ncells_local
         kk=i-k+1
         cage_to_cells(ngroups_total,k,1) = kk
         cage_to_cells(ngroups_total,k,2) = j
       END DO
       ncells_local = 0
       cage_sum_local = 0
     END IF
    END DO
  END DO

! Write out the input file in our format

  OPEN(UNIT=10,FILE='kakuro-initial',STATUS='NEW',ACCESS='SEQUENTIAL')
  write(10,*) ngroups_total
  write(10,*)
  DO i=1,ngroups_total
   write(10,*) cage_sum(i),cage_no_of_cells(i)
   DO jcell=1,cage_no_of_cells(i)
     write(10,*) cage_to_cells(i,jcell,1),cage_to_cells(i,jcell,2)
   END DO
   write(10,*)
  END DO
  CLOSE(UNIT=10)

END PROGRAM Jim_solution_format


c=================================================================
c     Daniel R. Reynolds
c     SMU Mathematics
c     Math 4370/6370
c     7 February 2015
c=================================================================

      program DotProd
c-----------------------------------------------------------------
c     Example routine to compute the dot-product of two vectors.
c-----------------------------------------------------------------
c======= Inclusions ===========

c======= Declarations =========
      implicit none

      integer, parameter :: MAX_INTEGER_DIGITS = 10
      integer :: i, n
      character(MAX_INTEGER_DIGITS) :: n_string
      double precision, allocatable :: a(:), b(:)
      double precision :: sum, stime, ftime
      double precision :: alloctime, inittime, runtime

c======= Internals ============

c     get n from the command line
      call getarg(1, n_string)

c     ensure that an argument was passed in
      if ( n_string == '' ) then
         stop 'Error: function requires one argument (vector length)'
      endif

c     convert n_string to integer, and ensure it's positive
      read (n_string, *) n
      if ( n < 1 ) then
         stop 'Error: vector length must be greater than 0'
      endif

c     allocate the vectors
      call get_time(stime)
      allocate(a(n),b(n))
      call get_time(ftime)
      alloctime = ftime - stime

c     initialize the vectors
      call get_time(stime)
      do i=1,n
         a(i) = 1.d-3*(i)/n
         b(i) = 1.d-3*(n-i)/n
      enddo
      call get_time(ftime)
      inittime = ftime - stime

c     compute dot-product
      call get_time(stime)
      sum = 0.d0
      do i=1,n,1
         sum = sum + a(i)*b(i)
      enddo
      call get_time(ftime)
      runtime = ftime-stime

c     output computed value and runtime
      print *, ' vector length =',n
      print *, '   dot-product =',sum
      print *, '    alloc time =',alloctime
      print *, '     init time =',inittime
      print *, '      run time =',runtime

c     free vectors
      deallocate(a,b)

      end program DotProd
c=================================================================


program main
   use omp_lib
   implicit none

   integer, parameter :: ITER = 100000000   ! use a smaller value if available memory is small
   integer :: i, id
   real*8 :: A(iter)
   real*8 :: tdata
   real :: x

   do i = 1, ITER
      A(i) = 2.0 * i
   enddo

   !$omp parallel private (id, tdata, x)

      id = omp_get_thread_num()
      tdata = omp_get_wtime()

      !$omp do schedule(static)
      do i = 1, ITER
         x =  i * 1.0
         A(i) = A(i) * sqrt(x) / (sin(x) ** tan(x))
      enddo

      tdata = omp_get_wtime() - tdata

      if (id == 0) print *, "Time spent is ", tdata, " sec"

   !$omp end parallel
end program main


module library_lls
  interface
     subroutine lls(x, a, f, flag)
       real x(:, :)
       ! The SIZE in the next statement is an intrinsic function
       real, dimension (size(x,2)) :: a, f
       integer flag
     end subroutine lls
  end interface
end module library_lls

use library_lls

call lls(x=abc, a=d, f=xx, flag = iflag)

end


program intrinsics_30
    use iso_fortran_env, only : int8, int16
    integer(4) :: i1
    integer(8) :: i2
    integer(int8) :: i3
    integer(int16) :: i4
    real(4) :: r1
    real(8) :: r2
    complex(4) :: c1
    complex(8) :: c2
    integer, parameter :: ri3 = range(i3)
    integer, parameter :: ri4 = range(i4)

    print *, range(i1), range(i2), ri3, ri4
    print *, range(r1), range(r2)
    print *, range(c1), range(c2)
end program


      SUBROUTINE DTSYS (ITASK,DATEA,FSEC,DPDTTM,ERR,MESSAG)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      INTEGER ITASK, DATEA(6)
      LOGICAL ERR
      REAL FSEC
      DOUBLE PRECISION DPDTTM
      CHARACTER*(*) MESSAG

**    Local variables
      INTEGER I1, NZERO, DAYMAX, NDAYS
      INTEGER IMOTB1(12),IMOTB2(12)
      DOUBLE PRECISION DTMP, DTMAX
      LOGICAL DTLEAP
      INTEGER INDAY, ISECS
      DOUBLE PRECISION FRDAY, DSECS, FSECS

*     The absolute day number belonging to a certain day is
*     the number of days passed since 1-jan-0001. Hence, the
*     absolute day number of 1-jan-0001 is 0. The absolute
*     day number belonging to 1-jan-0002 is 365.
*     The number of days N calculated for a certain year Y is
*     given by N = Y*365 + Y/4 - Y/100 + Y/400 - 1.
*     The 1 subtracted simplifies the use of DOY numbers.
*     For 1-jan-0002 for instance DOY=1. If this number is added
*     to the N = 364 calculated for the passed year, year 1, we
*     have again the absolute day number belonging to 1-jan-0002.
*     The offset value used in the TTUTIL day counting should
*     give the number 1 to 1-jan-1900, which implies:
*     ttutiloffset = 1899 * 365 + 1899/4 - 1899/100 + 1899/400 - 1.
*     Dates below 1-jan-0001 and above 31-dec-9999 are illegal.

      INTEGER OFFSET
      PARAMETER (OFFSET = 693594)
      INTEGER N400, N100, N4, N1, LEFT, LASTY, DLAST
      SAVE

      DATA IMOTB1 /0,31,59,90,120,151,181,212,243,273,304,334/
      DATA IMOTB2 /31,28,31,30,31,30,31,31,30,31,30,31/

      ERR    = .FALSE.
      MESSAG = ' '

*     value corresponding to 31-dec-9999 24:00
      DTMAX = DBLE (9999*365 + 9999/4 - 9999/100 + 9999/400 - OFFSET)

      IF (ITASK.EQ.1) THEN

*        convert from array to double precision real
         NZERO  = 0
         DO 10 I1=1,3
            IF (DATEA(I1).EQ.0) NZERO = NZERO+1
10       CONTINUE

         IF (NZERO.GT.0.AND.NZERO.LT.3) THEN
            ERR    = .TRUE.
            MESSAG = 'year 0 or partial date not allowed'
            RETURN
         END IF

*        days for the year
         IF (DATEA(1).GE.1) THEN
*           absolute day number belonging to 31 december previous year
            LASTY = DATEA(1) - 1
            INDAY = LASTY*365 + LASTY/4 - LASTY/100 + LASTY/400 - 1
         ELSE IF (DATEA(1).EQ.0) THEN
*           set date to TTUTIL offset value
            INDAY = OFFSET
         ELSE
            ERR    = .TRUE.
            MESSAG = 'illegal year'
            RETURN
         END IF

*        count days in month
         IF (DATEA(2).NE.0) THEN
            IF (DATEA(2).GE.1.AND.DATEA(2).LE.12) THEN
               IF (DATEA(2).GE.2) THEN
                  INDAY = INDAY+IMOTB1(DATEA(2))
                  IF (DTLEAP(DATEA(1)).AND.DATEA(2).GT.2)
     &                INDAY = INDAY + 1
               END IF
            ELSE
               ERR    = .TRUE.
               MESSAG = 'month invalid'
               RETURN
            END IF
         END IF

*        count days in day
         IF (DATEA(3).NE.0) THEN
            DAYMAX = IMOTB2(DATEA(2))
            IF (DTLEAP (DATEA(1)).AND.DATEA(2).EQ.2) DAYMAX = DAYMAX+1

            IF (DATEA(3).GE.1.AND.DATEA(3).LE.DAYMAX) THEN
               INDAY = INDAY + DATEA(3)
            ELSE
               ERR    = .TRUE.
               MESSAG = 'day invalid'
               RETURN
            END IF
         END IF

*        subtract TTUTIL offset value and convert
         DTMP = DBLE(INDAY-OFFSET)

         IF (DATEA(4).GE.0) THEN
*           important: hours can be more than 24 !!
            DTMP = DTMP+DBLE (DATEA(4))/24.D0
         ELSE
            ERR    = .TRUE.
            MESSAG = 'hour invalid'
            RETURN
         END IF

         IF (DATEA(5).GE.0.AND.DATEA(5).LE.59) THEN
            DTMP = DTMP+DBLE (DATEA(5))/1440.D0
         ELSE
            ERR    = .TRUE.
            MESSAG = 'minute invalid'
            RETURN
         END IF

         IF (DATEA(6).GE.0.AND.DATEA(6).LE.59) THEN
            DTMP = DTMP+DBLE (DATEA(6))/86400.D0
         ELSE
            ERR    = .TRUE.
            MESSAG = 'seconds invalid'
            RETURN
         END IF

         IF (FSEC.GE.0.AND.FSEC.LT.1.) THEN
            DTMP = DTMP+DBLE (FSEC)/86400.D0
         ELSE
            ERR    = .TRUE.
            MESSAG = 'fractional seconds invalid'
            RETURN
         END IF

         IF (DTMP .GE. DTMAX) THEN
            ERR    = .TRUE.
            MESSAG = 'year above 9999'
            RETURN
         END IF

         DPDTTM = DTMP

      ELSE IF (ITASK.EQ.2) THEN

*        convert from double precision real to date array and
*        fractional seconds

         IF (DPDTTM .GE. DTMAX) THEN
            ERR    = .TRUE.
            MESSAG = 'year above 9999'
            RETURN
         END IF

*        get integer and fractional day
         IF (DPDTTM .GE. 0.0D0) THEN
            INDAY = INT(DPDTTM)
            FRDAY = DPDTTM - DBLE(INDAY)
         ELSE
            INDAY = -INT(ABS(DPDTTM))
            FRDAY = ABS(DPDTTM) - DBLE(ABS(INDAY))
            IF (FRDAY .GT. 0.0D0) THEN
*              there is a fractional day ; get it right
               FRDAY = 1.0D0 - FRDAY
               INDAY = INDAY - 1
            END IF
         END IF

*        get fractional day in seconds
         DSECS = 86400.D0 * FRDAY
         ISECS = INT(DSECS)
         FSECS = DSECS - DBLE(ISECS)

*        if the fractional seconds are close to 1.0 ?
         IF (FSECS .GT. 0.999999D0) THEN
*           regard as 1.0
            FSECS = 0.0D0
            ISECS = ISECS + 1
            IF (ISECS.EQ.86400) THEN
*              regard as a day
               ISECS = 0
               INDAY = INDAY + 1
            END IF
         END IF

*        now we have integer days and integer seconds for the day
*        corrected for a nearly finished second
*        now the date calculation can be done in integer arithmetic

*        alogorithm from FSE 4 calendar routine
         INDAY = INDAY + OFFSET

         IF (INDAY.LT.0) THEN
            ERR    = .TRUE.
            MESSAG = 'date before 1-jan-0001'
            RETURN
         END IF

*        number of 400 year periods and number of days left
         N400 = INDAY / 146097
         LEFT = INDAY - N400 * 146097

*        number of 100 year periods (max 3) and the number of days left
         N100 = MIN (3, LEFT / 36524)
         LEFT = LEFT - N100 * 36524

*        number of 4 year periods and the number of days left
         N4   = LEFT / 1461
         LEFT = LEFT - N4 * 1461

*        number of 1 year periods (max 3) and the number of days left
         N1   = MIN (3, LEFT / 365)
         LEFT = LEFT - N1 * 365

*        current year number is all years passed plus 1
         DATEA(1) = n400*400 + n100*100 + n4*4 + n1 + 1

*        find day number in year (DOY) by subtracting last years
         LASTY = DATEA(1) - 1
         DLAST = LASTY*365 + LASTY/4 - LASTY/100 + LASTY/400 - 1
         INDAY = INDAY - DLAST

*        find out month number
         DATEA(2) = 1
         NDAYS = IMOTB2(DATEA(2))
         IF (DTLEAP (DATEA(1)).AND.DATEA(2).EQ.2) NDAYS = NDAYS+1

20       IF (INDAY.GT.NDAYS) THEN
            INDAY    = INDAY-NDAYS
            DATEA(2) = DATEA(2)+1
            NDAYS    = IMOTB2(DATEA(2))
            IF (DTLEAP (DATEA(1)).AND.DATEA(2).EQ.2) NDAYS = NDAYS+1
         GOTO 20
         END IF

*        day number in month
         DATEA(3) = INDAY

*        hh:mm:ss
         DATEA(4) = MOD(ISECS,86400) / 3600
         DATEA(5) = MOD(ISECS,3600) / 60
         DATEA(6) = MOD(ISECS,60)

*        fractional seconds
         FSEC = REAL (FSECS)

      ELSE
         CALL FATALERR ('DTSYS','unknown task')
      END IF

      RETURN
      END


!	Obtain conditional covariance matrix of item scale parameters for an observation.
!	catobsrange contains the range of underlying categories per observed category.
!	numcatobs is a vector with the number of observed  categories per item.
!	resp is the observation vector.
!	The items presented are indicated by mask.
!	condmeans contains the conditional means.
!	The underlying item conditional probabilities are in condprobcat.
!	The scale parameters are in scales.

function condcovmat(catobsrange,numcatobs,resp,mask,condmeans,condprobcat,scales)
implicit none
integer,intent(in)::numcatobs(:),catobsrange(:,:),resp(:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::condmeans(:,:),condprobcat(:),scales(:,:)
real(kind=8)::condcovmat(size(scales,1),size(scales,1),size(resp))
!	cat corresponds to an underlying category.
!	col is the column number.
!	item is the item number.
!	nlocobs points to the observed item category.
!	position points to the underlying categories for the item response.
!	row is the row number.
!
integer::cat,col,item,nlocobs,position,row
!	diff is the difference between the scale parameters and their conditional means.
real(kind=8)::diff(size(scales,1))
condcovmat=0.0_8
nlocobs=1
do item=1,size(scales,1)
	if(mask(item))then
		position=nlocobs+resp(item)

		do cat=catobsrange(1,position),catobsrange(2,position)
			diff=scales(:,cat)-condmeans(:,item)
			do row=1,size(scales,1)
				do col=1,row
					condcovmat(row,col,item)=condcovmat(row,col,item)&
						+diff(row)*diff(col)*condprobcat(cat)

				end do

			end do

		end do
	end if

	nlocobs=nlocobs+numcatobs(item)
end do
return
end function condcovmat


C-----------------------------------------------------------------------
      SUBROUTINE SPLAPLAC(I,M,ENN1,Q,QD2,IDIR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPLAPLAC    COMPUTE LAPLACIAN IN SPECTRAL SPACE
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES THE LAPLACIAN OR THE INVERSE LAPLACIAN
C           OF A SCALAR FIELD IN SPECTRAL SPACE.
C           SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY.
C           THE LAPLACIAN OF Q(L,N) IS SIMPLY -N*(N+1)/A**2*Q(L,N)
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPLAPLAC(I,M,ENN1,Q,QD2,IDIR)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     ENN1     - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
C     Q        - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD
C     QD2      - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN
C     IDIR     - INTEGER FLAG
C                IDIR > 0 TO TAKE LAPLACIAN
C                IDIR < 0 TO TAKE INVERSE LAPLACIAN
C
C   OUTPUT ARGUMENT LIST:
C     Q        - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD
C                (Q(0,0) IS NOT COMPUTED)
C     QD2      - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL ENN1((M+1)*((I+1)*M+2)/2)
      REAL Q((M+1)*((I+1)*M+2))
      REAL QD2((M+1)*((I+1)*M+2))
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TAKE LAPLACIAN
      IF(IDIR.GT.0) THEN
        K=1
        QD2(2*K-1)=0.
        QD2(2*K)=0.
        DO K=2,(M+1)*((I+1)*M+2)/2
          QD2(2*K-1)=Q(2*K-1)*(-ENN1(K))
          QD2(2*K)=Q(2*K)*(-ENN1(K))
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TAKE INVERSE LAPLACIAN
      ELSE
        DO K=2,(M+1)*((I+1)*M+2)/2
          Q(2*K-1)=QD2(2*K-1)/(-ENN1(K))
          Q(2*K)=QD2(2*K)/(-ENN1(K))
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


C$Procedure EDPNT ( Ellipsoid point  )

      SUBROUTINE EDPNT ( P, A, B, C, EP )

C$ Abstract
C
C     Scale a point so that it lies on the surface of a specified
C     triaxial ellipsoid that is centered at the origin and aligned
C     with the Cartesian coordinate axes.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     ELLIPSOID
C     GEOMETRY
C     MATH
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      P  ( 3 )
      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      EP ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     P          I   A point in three-dimensional space.
C     A          I   Semi-axis length in the X direction.
C     B          I   Semi-axis length in the Y direction.
C     C          I   Semi-axis length in the Z direction.
C     EP         O   Point on ellipsoid.
C
C$ Detailed_Input
C
C     P          is a non-zero point in three-dimensional space.
C
C     A,
C     B,
C     C          are, respectively, the semi-axis lengths of a triaxial
C                ellipsoid in the X, Y, and Z directions. The axes of
C                the ellipsoid are aligned with the axes of the
C                Cartesian coordinate system.
C
C$ Detailed_Output
C
C     EP         is the result of scaling the input point P so that
C                it lies on the surface of the triaxial ellipsoid
C                defined by the input semi-axis lengths.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If any of the target ellipsoid's semi-axis lengths is
C         non-positive, the error SPICE(INVALIDAXES) is signaled.
C
C     2)  If P is the zero vector, the error SPICE(ZEROVECTOR) is
C         signaled.
C
C     3)  If the level surface parameter of the input point
C         underflows, the error SPICE(POINTTOOSMALL) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine efficiently computes the ellipsoid surface point
C     corresponding to a specified ray emanating from the origin.
C     Practical examples of this computation occur in the SPICELIB
C     routines LATSRF and SRFREC.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C
C     1)  Find the surface intercept point on an ellipsoid having radii
C
C            ( 3, 2, 1 )
C
C         of the ray emanating from the origin and having direction
C         vector
C
C            ( 1, 1, 1 )
C
C
C     Example code begins here.
C
C
C           PROGRAM EX1
C           IMPLICIT NONE
C
C           CHARACTER*(*)         FMT1
C           PARAMETER           ( FMT1 = '(A,3F17.14)' )
C
C           DOUBLE PRECISION      A
C           DOUBLE PRECISION      B
C           DOUBLE PRECISION      C
C           DOUBLE PRECISION      V      ( 3 )
C           DOUBLE PRECISION      EP     ( 3 )
C           DOUBLE PRECISION      LEVEL
C
C           A = 3.D0
C           B = 2.D0
C           C = 1.D0
C
C           CALL VPACK ( 1.D0, 1.D0, 1.D0, V )
C
C           CALL EDPNT ( V, A, B, C, EP )
C
C           WRITE (*,FMT1) 'EP    = ', EP
C     C
C     C     Verify that EP is on the ellipsoid.
C     C
C           LEVEL = (EP(1)/A)**2 + (EP(2)/B)**2 + (EP(3)/C)**2
C
C           WRITE (*,FMT1) 'LEVEL = ', LEVEL
C
C           END
C
C
C     When this program was executed on a PC/Linux/gfortran 64-bit
C     platform, the output was:
C
C        EP    =  0.85714285714286 0.85714285714286 0.85714285714286
C        LEVEL =  1.00000000000000
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     E.D. Wright     (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0, 19-APR-2016 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     scale point to lie on ellipsoid
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      TOUCHD

      LOGICAL               FAILED
      LOGICAL               VZERO

C
C     Local variables
C
      DOUBLE PRECISION      LEVEL
      DOUBLE PRECISION      SQ

C
C     Use discovery check-in.
C
      IF ( FAILED() ) THEN
         RETURN
      END IF

      IF (      ( A .LE. 0.D0 )
     .     .OR. ( B .LE. 0.D0 )
     .     .OR. ( C .LE. 0.D0 ) ) THEN

         CALL CHKIN  ( 'EDPNT'                            )
         CALL SETMSG ( 'Ellipsoid radii must be strictly '
     .   //            'positive but are (#, #, #).'      )
         CALL ERRDP  ( '#', A                             )
         CALL ERRDP  ( '#', B                             )
         CALL ERRDP  ( '#', C                             )
         CALL SIGERR ( 'SPICE(INVALIDRADII)'              )
         CALL CHKOUT ( 'EDPNT'                            )
         RETURN

      END IF

C
C     The input point must be non-zero, or we can't scale it
C     to the ellipsoid.
C
      IF ( VZERO(P) ) THEN

         CALL CHKIN  ( 'EDPNT'                            )
         CALL SETMSG ( 'Input point was the zero vector. '
     .   //            'A non-zero vector is required.'   )
         CALL SIGERR ( 'SPICE(ZEROVECTOR)'                )
         CALL CHKOUT ( 'EDPNT'                            )
         RETURN

      END IF

C
C     Find the level surface parameter of the input point with respect
C     to the scaled ellipsoid.
C
      LEVEL = TOUCHD( ( P(1)/A )**2 + ( P(2)/B )**2 + ( P(3)/C )**2  )

      IF ( LEVEL .LE. 0.D0 ) THEN
C
C        We expect that LEVEL will be non-negative, but it could
C        be zero. We check for negative values as a precaution.
C
         CALL CHKIN  ( 'EDPNT'                                    )
         CALL SETMSG ( 'Input point''s level surface parameter '
     .   //            'was non-positive. The point is too close '
     .   //            'to the origin to be scaled to the '
     .   //            'ellipsoid. The point was (#, #, #).'      )
         CALL ERRDP  ( '#', P(1)                                  )
         CALL ERRDP  ( '#', P(2)                                  )
         CALL ERRDP  ( '#', P(3)                                  )
         CALL SIGERR ( 'SPICE(POINTTOOSMALL)'                     )
         CALL CHKOUT ( 'EDPNT'                                    )
         RETURN

      END IF

C
C     Scale the point to one for which the level surface parameter is 1.
C
      SQ    = SQRT(LEVEL)

      EP(1) = P(1) / SQ
      EP(2) = P(2) / SQ
      EP(3) = P(3) / SQ

      RETURN
      END