!******************************************************************************
!*
!*                        INTEGRATION OF FUNCTIONS
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 08/2007
  !    - Correct bug of INTEG_TABULATED, when there is not point inside the
  ! interval to integrate over.
  !    - On 05/2014: add the log-lin integration.
  !    - On 05/2014: allow zero values in the function in the log case.
  !
  ! 3) DESCRIPTION: Various methods to integrate numerically a function.
  !==========================================================================

MODULE integration

  USE utilities, ONLY:
  USE arrays, ONLY:
  USE interpolation, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: dPrimitive, integ_tabulated, integ_romb

CONTAINS

  !==========================================================================
  ! dF[N] = DPRIMITIVE(x,f,XLOG,YLOG,lnx,lnf)
  !
  !   Returns the differential primitive of a function on a given grid, for
  ! various function assumptions (lin/log).
  !   Log(x) and LOG(f) can eventually be passed as argument to avoid having
  ! to comput them twice.
  !==========================================================================

  PURE FUNCTION dPrimitive (x,f,xlog,ylog,lnx,lnf)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x, f
    LOGICAL, INTENT(IN) :: xlog, ylog
    REAL(DP), INTENT(IN), DIMENSION(:), OPTIONAL :: lnx, lnf
    REAL(DP), DIMENSION(SIZE(x)) :: dPrimitive

    INTEGER :: N
    REAL(DP), DIMENSION(SIZE(x)) :: logx, logf

    !------------------------------------------------------------------------

    N = SIZE(x(:))
    dPrimitive(1) = 0._DP
    linlog: IF (.NOT. xlog .AND. .NOT. ylog) THEN

      ! Linear: assumes f(x) ~ a*x + b
      dPrimitive(2:N) = DPRIMITIVE_LINLIN(x(:),f(:),N)

    ELSE IF (xlog .AND. .NOT. ylog) THEN

      ! Logarithm: assumes f(x) ~ ln(a*x+b)
      dPrimitive(2:N) = DPRIMITIVE_LOGLIN(x(:),f(:),N)

    ELSE IF (.NOT. xlog .AND. ylog) THEN

      ! Exponential: assumes f(x) ~ exp(a*x+b)
      IF (PRESENT(lnf)) THEN
        logf(:) = lnf(:)
      ELSE
        logf(:) = LOG(f(:))
      END IF
      dPrimitive(2:N) = DPRIMITIVE_LINLOG(x(:),f(:),N,lnf(:))

    ELSE IF (xlog .AND. ylog) THEN

      ! Power-law: assumes f(x) ~ a*x^b
      IF (PRESENT(lnx)) THEN
        logx(:) = lnx(:)
      ELSE
        logx(:) = LOG(x(:))
      END IF
      IF (PRESENT(lnf)) THEN
        logf(:) = lnf(:)
      ELSE
        logf(:) = LOG(f(:))
      END IF
      dPrimitive(2:N) = DPRIMITIVE_LOGLOG(x(:),f(:),N,lnx(:),lnf(:))

    END IF linlog

    !------------------------------------------------------------------------

  END FUNCTION dPrimitive

  ! Formula for each method
  !------------------------
  ! Linear: assumes f(x) ~ a*x + b
  !  => F(x1)-F(x0) = (f(x1)+f(x0)) / 2 * (x1-x0)
  PURE FUNCTION dPrimitive_linlin (x,f,N)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(N), INTENT(IN) :: x, f
    INTEGER, INTENT(IN) :: N
    REAL(DP), DIMENSION(N-1) :: dPrimitive_linlin

    !------------------------------------------------------------------------

    dPrimitive_linlin(:) = 0.5_DP * ( f(2:N) + f(1:N-1) ) * ( x(2:N) - x(1:N-1) )

    !------------------------------------------------------------------------

  END FUNCTION dPrimitive_linlin

  ! Logarithm: assumes f(x) ~ ln(a*x+b)
  !  => F(x1)-F(x0) = ( (f(x1)-1)*EXP(f(x1)) - (f(x0)-1)*EXP(f(x0)) )
  !                 * (x1-x0) / ( EXP(f(x1)) - EXP(f(x0)) )
  PURE FUNCTION dPrimitive_loglin (x,f,N)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(N), INTENT(IN) :: x, f
    INTEGER, INTENT(IN) :: N
    REAL(DP), DIMENSION(N-1) :: dPrimitive_loglin
    REAL(DP), DIMENSION(N) :: expf, fm1
    REAL(DP), DIMENSION(N-1) :: dexpf

    !------------------------------------------------------------------------

    fm1 = f(:) - 1._DP
    expf = EXP(f(:))
    dexpf(:) = expf(2:N) - expf(1:N-1)
    WHERE (ABS(dexpf(:)) > epsDP*expf(2:N))
      dPrimitive_loglin(:) = ( fm1(2:N)*expf(2:N) - fm1(1:N-1)* expf(1:N-1) ) &
                           * ( x(2:N) - x(1:N-1) ) / dexpf(:)
    ELSEWHERE
      dPrimitive_loglin(:) = 0.5_DP * ( f(2:N) + f(1:N-1) ) * (x(2:N)-x(1:N-1))
    END WHERE

    !------------------------------------------------------------------------

  END FUNCTION dPrimitive_loglin

  ! Exponential: assumes f(x) ~ exp(a*x+b)
  !  => F(x1)-F(x0) = ( f(x1) - f(x0) ) * (x1-x0) / ( ln(f(x1)) - ln(f(x0)) )
  PURE FUNCTION dPrimitive_linlog (x,f,N,lnf)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(N), INTENT(IN) :: x, f, lnf
    INTEGER, INTENT(IN) :: N
    REAL(DP), DIMENSION(N-1) :: dPrimitive_linlog
    REAL(DP), DIMENSION(N-1) :: dlnf

    !------------------------------------------------------------------------

    dlnf(:) = lnf(2:N) - lnf(1:N-1)
    WHERE (f(1:N-1) > 0._DP .AND. f(2:N) > 0._DP &
           .AND. ABS(dlnf(:)) > epsDP*ABS(lnf(2:N)) )
      dPrimitive_linlog(:) = ( f(2:N) - f(1:N-1) ) * ( x(2:N) - x(1:N-1) ) &
                           / dlnf(:)
    ELSEWHERE
      dPrimitive_linlog(:) = 0.5_DP * ( f(2:N) + f(1:N-1) ) * (x(2:N)-x(1:N-1))
    END WHERE

    !------------------------------------------------------------------------

  END FUNCTION dPrimitive_linlog

  ! Power-law: assumes f(x) ~ a*x^b
  ! F(x1)-F(x0) = ( x1*f(x1) - x0*f(x0) ) / ( 1 + ( ln(f(x1)) - ln(f(x0) ) )
  !                                               / ( ln(x1) - ln(x0) ) )
  PURE FUNCTION dPrimitive_loglog (x,f,N,lnx,lnf)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(N), INTENT(IN) :: x, f, lnx, lnf
    INTEGER, INTENT(IN) :: N
    REAL(DP), DIMENSION(N-1) :: dPrimitive_loglog
    REAL(DP), DIMENSION(N-1) :: dlnx

    !------------------------------------------------------------------------

    dlnx(:) = lnx(2:N) - lnx(1:N-1)
    WHERE (f(1:N-1) > 0._DP .AND. f(2:N) > 0._DP &
           .AND. ABS(dlnx(:)) > epsDP*ABS(lnx(2:N)))
      dPrimitive_loglog(:) = ( x(2:N)*f(2:N) - x(1:N-1)*f(1:N-1) ) &
                           / ( 1._DP + ( lnf(2:N) - lnf(1:N-1) ) / dlnx(:) )
    ELSEWHERE
      dPrimitive_loglog(:) = 0.5_DP * ( f(2:N) + f(1:N-1) ) * (x(2:N)-x(1:N-1))
    END WHERE

    !------------------------------------------------------------------------

  END FUNCTION dPrimitive_loglog

  !==========================================================================
  ! I = INTEG_TABULATED(x[N],f[N],[x0,x1],PRIMITIVE[N],LINEAR,LOGARITHM, &
  !                     EXPONENTIAL,POWERLAW,XLOG,YLOG,FORCE,RESCALE)
  !
  !   Integration of tabulated functions. Returns the integration of f(x) from
  ! x0 to x1>x0, using the trapezium method. X must be SORTED without any
  ! duplicates. The boolean keywords select the integration method (lin-lin,
  ! log-lin, lin-log or log-log).
  !==========================================================================

  FUNCTION integ_tabulated (x,f,xrange,primitive,linear,logarithm,exponential, &
                            powerlaw,xlog,ylog,force,rescale)

    USE utilities, ONLY: DP, strike, warning, isNaN
    USE arrays, ONLY: iwhere

    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x, f
    REAL(DP), INTENT(IN), DIMENSION(2), OPTIONAL :: xrange
    REAL(DP), INTENT(OUT), DIMENSION(SIZE(x)), OPTIONAL :: primitive
    LOGICAL, INTENT(IN), OPTIONAL :: linear, logarithm, exponential, powerlaw
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog, force, rescale
    REAL(DP) :: integ_tabulated

    REAL(DP) :: x0, x1, min_x, max_x, x_inf, x_sup, f_inf, f_sup, logx2, logf2
    REAL(DP) :: scaling
    REAL(DP), DIMENSION(:), ALLOCATABLE :: xi, fi, dPrim, logx, logf
    INTEGER :: Nx, Nin, i, i0, i1, i2
    LOGICAL, DIMENSION(SIZE(x)) :: boolin
    LOGICAL, DIMENSION(2) :: interpol, extrapol
    LOGICAL :: xl, yl, forced, rescl

    !-----------------------------------------------------------------------

    ! Check the arguments
    !--------------------
    ! Size
    Nx = SIZE(x(:))
    IF (Nx <= 1) CALL STRIKE("INTEG_TABULATED","x should have >=2 elements")

    ! Integration range
    min_x = MINVAL(x(:))
    max_x = MAXVAL(x(:))
    range: IF (PRESENT(xrange)) THEN
      x0 = xrange(1)
      x1 = xrange(2)
      IF ((x0 > max_x) .OR. (x1 < min_x)) &
        CALL STRIKE("INTEG_TABULATED","bad integration range.")
    ELSE
      x0 = min_x
      x1 = max_x
    END IF range
    IF (x0 >= x1) CALL STRIKE("INTEG_TABULATED","bad XRANGE.")

    ! Type of integration (xlog and ylog have priority over powerlaw,
    ! exponential, linear, etc.)
    xl = .False.
    IF (PRESENT(xlog)) xl = xlog
    yl = .False.
    IF (PRESENT(ylog)) yl = ylog
    IF (PRESENT(linear)) THEN
      IF (linear) THEN
        xl = .False.
        yl = .False.
      END IF
    END IF
    IF (PRESENT(logarithm)) THEN
      IF (logarithm) THEN
        xl = .True.
        yl = .False.
      END IF
    END IF
    IF (PRESENT(exponential)) THEN
      IF (exponential) THEN
        xl = .False.
        yl = .True.
      END IF
    END IF
    IF (PRESENT(powerlaw)) THEN
      IF (powerlaw) THEN
        xl = .True.
        yl = .True.
      END IF
    END IF
    forced = .False.
    IF (PRESENT(force)) forced = force

    ! Rescale to avoid numerical problems
    rescl = .True.
    IF (PRESENT(rescale)) rescl = rescale

    ! Interpolation and extrapolation at the edges
    !---------------------------------------------
    ! Determine if extrapolation is necessary
    interpol(1) = ((.NOT. ANY(x(:) == x0)) .AND. (min_x < x0))
    interpol(2) = ((.NOT. ANY(x(:) == x1)) .AND. (max_x > x1))
    extrapol(1) = (min_x > x0)
    extrapol(2) = (max_x < x1)

    ! Logical mask of the points considered for integration
    boolin = (x(:) > x0 .AND. x(:) < x1)
    Nin = COUNT(boolin) + 2
    IF (rescl) THEN
      scaling = MERGE(MAXVAL(ABS(f(:)),MASK=( boolin(:) .AND. f(:) /= 0._DP &
                                              .AND. .NOT. isNaN(f(:)) )), &
                      1._DP,Nin > 2)
    ELSE
      scaling = 1._DP
    END IF
    ALLOCATE(xi(Nin),fi(Nin),dPrim(Nin),logx(Nin),logf(Nin))
    xi = [    x0, PACK(x(:),boolin),    x1 ]
    IF (.NOT. rescl) THEN
      fi = [ 1._DP, PACK(f(:),boolin), 1._DP ] ! edges will be replaced later
    ELSE
      fi = [ 1._DP, PACK(f(:),boolin)/scaling, 1._DP ]
    END IF
    logx = MERGE(LOG(xi(:)),xi(:),xl)
    logf = MERGE(LOG(fi(:)),fi(:),yl)

    ! Inter/extrapolates at the boundaries
    lower_boundary: IF (extrapol(1)) THEN
      logf(1) = logf(2) &
              - (logf(3)-logf(2)) / (logx(3)-logx(2)) * (logx(2)-logx(1))
    ELSE IF (interpol(1)) THEN
      x_inf = MAXVAL(PACK(x(:),x(:)<x0))
      IF (.NOT. rescl) THEN
        f_inf = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x_inf))), &
                      MINVAL(PACK(f(:),x(:)==x_inf)),yl)
      ELSE
        f_inf = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x_inf))/scaling), &
                      MINVAL(PACK(f(:),x(:)==x_inf))/scaling,yl)
      END IF
      x_inf = MERGE(LOG(x_inf),x_inf,xl)
      IF (Nin > 2) THEN
        logf(1) = logf(2) - (logf(2)-f_inf)/(logx(2)-x_inf) * (logx(2)-logx(1))
      ELSE
        CALL IWHERE(MERGE(LOG(x(:)),x(:),xl) == x_inf,i2)
        logx2 = MERGE(LOG(x(i2+1)),x(i2+1),xl)
        IF (.NOT. rescl) THEN
          logf2 = MERGE(LOG(f(i2+1)),f(i2+1),yl)
        ELSE
          logf2 = MERGE(LOG(f(i2+1)/scaling),f(i2+1)/scaling,yl)
        END IF
        logf(1) = logf2 - (logf2-f_inf)/(logx2-x_inf) * (logx2-logx(1))
      END IF
    ELSE
      IF (.NOT. rescl) THEN
        logf(1) = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x0))), &
                        MINVAL(PACK(f(:),x(:)==x0)),yl)
      ELSE
        logf(1) = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x0))/scaling), &
                        MINVAL(PACK(f(:),x(:)==x0))/scaling,yl)
      END IF
    END IF lower_boundary
    fi(1) = MERGE(EXP(logf(1)),logf(1),yl)
    upper_boundary: IF (extrapol(2)) THEN
      logf(Nin) = logf(Nin-1) &
                + (logf(Nin-1)-logf(Nin-2)) / (logx(Nin-1)-logx(Nin-2)) &
                  * (logx(Nin)-logx(Nin-1))
    ELSE IF (interpol(2)) THEN
      x_sup = MINVAL(PACK(x(:),x(:)>x1))
      IF (.NOT. rescl) THEN
        f_sup = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x_sup))), &
                      MINVAL(PACK(f(:),x(:)==x_sup)),yl)
      ELSE
        f_sup = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x_sup))/scaling), &
                      MINVAL(PACK(f(:),x(:)==x_sup))/scaling,yl)
      END IF
      x_sup = MERGE(LOG(x_sup),x_sup,xl)
      IF (Nin > 2) THEN
        logf(Nin) = logf(Nin-1) &
                  + (f_sup-logf(Nin-1)) / (x_sup-logx(Nin-1)) &
                    * (logx(Nin)-logx(Nin-1))
      ELSE
        CALL IWHERE(MERGE(LOG(x(:)),x(:),xl) == x_sup,i2)
        logx2 = MERGE(LOG(x(i2-1)),x(i2-1),xl)
        IF (.NOT. rescl) THEN
          logf2 = MERGE(LOG(f(i2-1)),f(i2-1),yl)
        ELSE
          logf2 = MERGE(LOG(f(i2-1)/scaling),f(i2-1)/scaling,yl)
        END IF
        logf(Nin) = logf2 &
                  + (f_sup-logf2) / (x_sup-logx2) * (logx(Nin)-logx2)
      END IF
    ELSE
      IF (.NOT. rescl) THEN
        logf(Nin) = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x1))), &
                          MINVAL(PACK(f(:),x(:)==x1)),yl)
      ELSE
        logf(Nin) = MERGE(LOG(MINVAL(PACK(f(:),x(:)==x1))/scaling), &
                          MINVAL(PACK(f(:),x(:)==x1))/scaling,yl)
      END IF
    END IF upper_boundary
    fi(Nin) = MERGE(EXP(logf(Nin)),logf(Nin),yl)

    ! Actual lin/log trapezium integration
    !-------------------------------------
    dPrim(:) = DPRIMITIVE(xi(:),fi(:),xl,yl,logx(:),logf(:))
    IF (rescl) dPrim(:) = dPrim(:) * scaling

    ! Remove the NaN
    IF (forced .AND. yl) THEN
      WHERE (ISNAN(dPrim(:))) dPrim(:) = 0._DP
    END IF

    ! Integral and primitive function if requested
    prim: IF (PRESENT(primitive)) THEN
      DO i=2,Nin ; dPrim(i) = dPrim(i) + dPrim(i-1) ; END DO
      integ_tabulated = dPrim(Nin)
      i0 = MERGE(2,1,(extrapol(1) .OR. interpol(1)))
      i1 = MERGE(Nin-1,Nin,(extrapol(2) .OR. interpol(2)))
      primitive(:) = UNPACK(dPrim(i0:i1),(x(:)>=x0 .AND. x(:)<=x1),FIELD=0._DP)
      primitive(:) = MERGE(integ_tabulated,primitive(:),x(:)>x1)
    ELSE
      integ_tabulated = SUM(dPrim(:))
    END IF prim

    DEALLOCATE(xi,fi,dPrim,logx,logf)

    !-----------------------------------------------------------------------

  END FUNCTION integ_tabulated

  !==========================================================================
  ! CALL TRAPEZ (func,a,b,s,n)
  !
  !   Returns the integration of f(x) from a to b>a, using the trapezium rule
  ! of order n.
  !==========================================================================

  SUBROUTINE trapez (func,a,b,s,n)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    INTERFACE
      FUNCTION func (x)
        USE utilities, ONLY: DP
        REAL(DP), INTENT(IN), DIMENSION(:) :: x
        REAL(DP), DIMENSION(SIZE(x)) :: func
      END FUNCTION func
    END INTERFACE
    REAL(DP), INTENT(IN) :: a, b
    REAL(DP), INTENT(INOUT) :: s
    INTEGER, INTENT(IN) :: n

    REAL(DP) :: del, fsum
    REAL(DP), DIMENSION(:), ALLOCATABLE :: arth
    INTEGER :: it, i

    !-----------------------------------------------------------------------

    IF (n == 1) THEN
      s = 0.5_DP*(b-a) * SUM(func((/a,b/)))
    ELSE
      it = 2**(n-2)
      del = (b-a)/it
      ALLOCATE(arth(it))
      FORALL (i=1:it) arth(i) = a+0.5_DP*del + (i-1)*del
      fsum = SUM(func(arth))
      s = 0.5_DP*(s+del*fsum)
      DEALLOCATE (arth)
    END IF

    !-----------------------------------------------------------------------

  END SUBROUTINE trapez

  !==========================================================================
  ! I = INTEG_ROMB(func(x),a,b)
  !
  !   Returns the integration of f(x) from a to b>a, using the Romberg
  ! method of order k.
  !==========================================================================

  FUNCTION integ_romb (func,a,b)

    USE utilities, ONLY: DP, strike, NaN
    USE arrays, ONLY: reverse
    USE interpolation, ONLY: interp_poly
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: a, b
    INTERFACE
      FUNCTION func (x)
        USE utilities, ONLY: DP
        REAL(DP), INTENT(IN), DIMENSION(:) :: x
        REAL(DP), DIMENSION(SIZE(x)) :: func
      END FUNCTION func
    END INTERFACE
    REAL(DP) :: integ_romb

    INTEGER, PARAMETER :: jmax=20, jmaxp=jmax+1, k=5, km=k-1
    REAL(DP), PARAMETER :: eps=1.E-6_DP

    REAL(DP), DIMENSION(jmaxp) :: h, s
    REAL(DP) :: dqromb
    INTEGER :: j

    !-----------------------------------------------------------------------

    integ_romb = NaN()
    h(1) = 1.0_DP
    DO j=1,jmax
      CALL TRAPEZ (func,a,b,s(j),j)
      IF (j >= k) THEN
        integ_romb = INTERP_POLY(REVERSE(s(j-km:j)),REVERSE(h(j-km:j)), &
                                 0._DP,ERR_NEW=dqromb,DEGREE=km-1)
        IF (ABS(dqromb) <= eps*ABS(integ_romb)) RETURN
      END IF
      s(j+1) = s(j)
      h(j+1) = 0.25_DP*h(j)
    END DO
    CALL STRIKE ("INTEG_ROMB","too many steps.")

    !-----------------------------------------------------------------------

  END FUNCTION integ_romb

END MODULE integration


! This program shows how to use selected_real_kind
! SELECTED_REAL_KIND(P,R, RADIX) returns the kind value of
! a real data type with decimal precision of at least
! P digits, exponent range of at least R, and with
! a radix of RADIX.
!
! Note the repeated kind type values for different precisions.
! Not all real representations are available
!
program kind_real_all
  implicit none
  integer, parameter  :: p1   = selected_real_kind(p=6, r=10, radix= 2)
  integer, parameter  :: p2   = selected_real_kind(20, 140)
  integer, parameter  :: p3   = selected_real_kind(p=10)

  real(kind = p1)     :: v1
  real(kind = p2)     :: v2
  real(kind = p3)     :: v3

  print*,'selected_real_kind(p=6, r=10, radix=2)', p1
  print*,' p = ', precision(v1), ' r = ', &
         range(v1), ' radix = ', radix(v1)
  print*,'selected_real_kind(20, 40)', p2
  print*,' p = ', precision(v2), ' r = ', &
         range(v2), ' radix = ', radix(v2)
  print*,'selected_real_kind(p=10)', p3
  print*,' p = ', precision(v3), ' r = ', &
         range(v3), ' radix = ', radix(v3)
end program kind_real_all


!Author: Anantha rao
program harmonic0
      ! Solution of the 1D quantum harmonic oscillator
      ! Forward integration only, Numerov algorithm
      ! Eigenvalue search using shooting method (bisection method)
      ! Need to use asymptotic limits
      ! Adimensional units: x = (mK/hbar^2)^(1/4) X
      !                     e = E/(hbar omega)

      implicit none
      integer, parameter :: dp=selected_real_kind(14,200)
      integer :: mesh, i, icl
      integer :: nodes, hnodes, ncross, kkk, n_iter
      real(dp) :: xmax, dx, ddx12, norm, arg
      real(dp) :: eup, elw, e
      real(dp), allocatable :: x(:), y(:), p(:), vpot(:), f(:)
      character(len=88) :: fileout

      ! Read input data
      print '(a,$)', 'Max value for x (typical value:10) ? '
      read(*,*) xmax
      print '(a,$)', 'Number of grid points (typically a few hundreds)?'
      read(*,*) mesh

      ! Allocate arrays, initialize grid
      allocate (x(0:mesh), y(0:mesh), p(0:mesh), vpot(0:mesh), f(0:mesh))
      dx = xmax/mesh
      ddx12=dx*dx/12.0_dp

      ! Set up the potential (must be even wrt x=0)
      do i=0,mesh
        x(i) = float(i)*dx
        vpot(i) = 0.5_dp*x(i)*x(i)
      end do

      print'(a,$)', 'output file name = '
      read(*,'(a)') fileout
      open(7, file=fileout, status='unknown', form='formatted')

      ! Entry point for new eigenvalue search
      search_loop: do
      ! read number of nodes (stop if <0)
      print '(a,$)', 'nodes (type -1 to stop) >> '
      read(*,*) nodes
      if (nodes < 0) then
          close(7)
          deallocate( f, vpot, p,y,x)
          stop
      end if

      ! Set initial lower and upper bounds to the eigenvalue
      eup = maxval(vpot(:))
      elw = minval(vpot(:))

      ! Set trial energy
      print '(a,$)', 'Trial energy (0=search with bisection) ? '
      read (*,*) e
      if ( e == 0.0_dp) then
          ! search eigenvalues with bisection
          e = 0.5_dp * (elw + eup)
          n_iter = 1000
      else
          ! test a single energy value
          n_iter = 1
      endif

      iterate: do kkk=1, n_iter
      ! setup the f-function used by Numerov algorithm
      ! and determine the position of its last crossing,, ie change of
      ! sign
      ! f < 0 means classically allowed region
      ! f > 0 means classically forbidden region

      f(0)=ddx12*(2.0_dp*(vpot(0)-e))
      icl=-1
      do i=1,mesh
        f(i)=ddx12*2.0_dp*(vpot(i)-e)
        ! if(f(i) is exactly zero then the change f sign is not observed
        ! The following line is a trick to prevent missing a change of
        ! sign; in this unlikely but impossible case:
        if (f(i) == 0.0_dp) f(i)=1.d-20
        ! store the index 'icl' where the last change of sign has been found
        if ( f(i) /= sign(f(i), f(i-1))) icl = i
      end do

      if (icl >= mesh-2) then
          deallocate (f,vpot, p,y,x)
          stop 'last cahnge of sign too far'
      else if (icl <1) then
          deallocate(f, vpot, p, y, x)
          stop 'no classical turning point?'
      end if

      ! f(x) as required by Numerov algorithm

      f = 1.0_dp - f
      y = 0.0_dp

      ! Determination of the wave function in the first two points

      hnodes = nodes/2

      ! be careful of integer division: 1/2 = 0 !
      ! if nodes is even, there are 2*hnodes nodes
      ! if nodes is odd, there are 2*hnodes+1 nodes (one is in x=0)
      ! hnodes is thus the number of nodes in the x>0 semi-axis (x=0 excepted)

      if (2*hnodes == nodes) then
          ! even number of nodes: wavefunction is even)
          y(0) = 1.0_dp
          ! assume f(-1) = f(1)
          y(1) = 0.5_dp*(12.0_dp - 10.0_dp*f(0))*y(0)/f(1)
      else
          ! odd number of nodes: wave function is odd
          y(0) = 0.0_dp
          y(1) = dx
      end if

      ! outward integration and count number of crossings

      ncross=0
      do i=1, mesh-1
        y(i+1) = ((12.0_dp - 10.0_dp*f(i))*y(i) - f(i-1)*y(i-1))/f(i+1)
        if (y(i) /= sign(y(i), y(i+1))) ncross=ncross+1
      end do

      print *, kkk, e, ncross, hnodes

      ! if iterating on energy: check number of crossings

      if (n_iter > 1) then

          if (ncross > hnodes) then
              ! too many crossings: current energy is too high
              ! lower the upper bound
              eup = e
          else
              ! too few (or correct number of crossings
              ! current energy is too low, raise the lower bound
              elw = e

          end if
          ! New trial value
          e=0.5_dp*(eup+elw)
          ! Convergence criterion:
          if (eup-elw < 1.d-10) exit iterate
      end if

      end do iterate

      ! Convergence has been achieved (or it want required)
      ! Note that the eavefunction is not normalized:
      ! THe problem is the divergence at alrge |x|

      ! Calculation of the classical probability density for energy e:

      norm = 0.0_dp
      p(icl:) = 0.0_dp
      do i=0,icl
        arg = (e-x(i)**2/2.0_dp)
        if (arg > 0.0_dp) then
            p(i) = 1.0_dp/sqrt(arg)
        else
            p(i) = 0.0_dp
        end if
        norm = norm + 2.0_dp*dx*p(i)
      end do

      ! The point at x=0 must be counter once
      norm = norm - dx*p(0)
      ! Normalize p(x) so that Int p(x)dx=1
      p(:icl-1) = p(:icl-1)/norm
      !lines starting with # ignored by gnuplot
      write(7, '("# x   y(x)  y(x)^2   classical p(x)    V")')
      ! x,0 region:
      do i=mesh,1,-1
      write(7,'(f7.2, 3e16.8, f12.6)') &
          -x(i), (-1)**nodes*y(i), y(i)*y(i), p(i), vpot(i)
      end do

      ! x>0 region
      do i=0, mesh
        write(7,'(f7.2, 3e16.8, f12.6)') &
            x(i), y(i), y(i)*y(i), p(i), vpot(i)
        end do
        ! two blank lines separating blocks of data, useful for gnuplot
        ! plotting
        write(7, '(/)')

        end do search_loop

end program harmonic0


program main

use euler

implicit none

        integer (int64), parameter :: MAXIMUM = 1000;
        integer (int64), parameter :: BASE = 10;
        integer (int64) :: i, len_, n, tmp;

        len_ = 0;

        do i = 1, MAXIMUM, 2

                tmp = reciprocal_count(i);

                if(tmp > len_) then
                        len_ = tmp;
                        n = i;
                endif

        end do

        call printint(n)

contains

        pure function reciprocal_count(i)

                integer (int64), intent(in) :: i;
                integer (int64) :: init_rem, rem;
                integer (int64) :: reciprocal_count;

                reciprocal_count = 1;

                if(mod(i, 5) == 0) then
                        return
                endif

                init_rem = 1
                rem = mod(BASE, i);

                do while(rem /= 0 .AND. rem /= init_rem)
                        rem = mod((BASE * rem), i);
                        call inc(reciprocal_count, ONE);
                end do

        end function reciprocal_count

end program main


program integration1

  !
  !  Perform a basic integration
  !

  implicit none

  integer :: i, j
  real(8) :: x, y, integ

  integ = 0.0d0

  open(unit=1, file='integration1.dat', action='write')

  write(1, *) integ

  do j = 1, 10

     y = dble(j) * 1.0d0

     do i = 1, 10

        x = dble(i) * 2.5d-1

        integ = integ + sin(x + y)

        if (ceiling(dble(j)/2.0d0)*2 == j .and. ceiling(dble(i)/2.0d0)*2 == i) then

           write(1, *) integ

        end if

     end do

  end do

  close(1)

  write(*,'(a,e20.10e3)') 'Integration value = ', integ

end program integration1


!> The problem is to determine the values of x(1), x(2), ..., x(9)
!>  which solve the system of tridiagonal equations
!>     (3-2*x(1))*x(1)           -2*x(2)                   = -1
!>             -x(i-1) + (3-2*x(i))*x(i)         -2*x(i+1) = -1, i=2-8
!>                                 -x(8) + (3-2*x(9))*x(9) = -1
program example_hybrd

    use minpack_module, only: wp, hybrd, enorm, dpmpar
    use iso_fortran_env, only: nwrite => output_unit

    implicit none

    integer,parameter :: n = 9
    integer,parameter :: ldfjac = n
    integer,parameter :: lr = (n*(n+1))/2

    integer :: maxfev, ml, mu, mode, nprint, info, nfev
    real(wp) :: epsfcn, factor, fnorm, xtol
    real(wp) :: x(n), fvec(n), diag(n), fjac(n, n), r(lr), qtf(n), &
                wa1(n), wa2(n), wa3(n), wa4(n)

    xtol = sqrt(dpmpar(1))  ! square root of the machine precision.
    maxfev = 2000
    ml = 1
    mu = 1
    epsfcn = 0.0_wp
    mode = 2
    factor = 100.0_wp
    nprint = 0
    diag = 1.0_wp
    x = -1.0_wp  !  starting values to provide a rough solution.

    call hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, &
               mode, factor, nprint, info, nfev, fjac, ldfjac, &
               r, lr, qtf, wa1, wa2, wa3, wa4)
    fnorm = enorm(n, fvec)

    write (nwrite, '(5x,a,d15.7//5x,a,i10//5x,a,16x,i10//5x,a//(5x,3d15.7))') &
           "FINAL L2 NORM OF THE RESIDUALS", fnorm, &
           "NUMBER OF FUNCTION EVALUATIONS", nfev, &
           "EXIT PARAMETER", info, &
           "FINAL APPROXIMATE SOLUTION", x

    !> Results obtained with different compilers or machines
    !>  may be slightly different.
    !>
    !>> FINAL L2 NORM OF THE RESIDUALS  0.1192636D-07
    !>>
    !>> NUMBER OF FUNCTION EVALUATIONS        14
    !>>
    !>> EXIT PARAMETER                         1
    !>>
    !>> FINAL APPROXIMATE SOLUTION
    !>>
    !>>  -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
    !>>  -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
    !>>  -0.6657920D+00 -0.5960342D+00 -0.4164121D+00

contains

    !> Subroutine fcn for hybrd example.
    subroutine fcn(n, x, fvec, iflag)

        implicit none
        integer, intent(in) :: n
        integer, intent(inout) :: iflag
        real(wp), intent(in) :: x(n)
        real(wp), intent(out) :: fvec(n)

        integer :: k !! counter
        real(wp) :: temp, temp1, temp2

        real(wp),parameter :: zero = 0.0_wp
        real(wp),parameter :: one = 1.0_wp
        real(wp),parameter :: two = 2.0_wp
        real(wp),parameter :: three = 3.0_wp

        if (iflag == 0) then
            !! Insert print statements here when nprint is positive.
        else
            do k = 1, n
                temp = (three - two*x(k))*x(k)
                temp1 = zero
                if (k /= 1) temp1 = x(k - 1)
                temp2 = zero
                if (k /= n) temp2 = x(k + 1)
                fvec(k) = temp - temp1 - two*temp2 + one
            end do
        end if

    end subroutine fcn

end program example_hybrd


subroutine sphere_distance(lat1, lon1, nlat, nlon, gridlat, gridlon, dist)

 implicit none

 integer, parameter :: RKIND  = selected_real_kind(12)
 integer :: nlat, nlon
 real (kind=RKIND), intent(in) :: lat1, lon1
 real (kind=RKIND), dimension(nlat,nlon) :: gridlat, gridlon
 real (kind=RKIND), dimension(nlat,nlon) :: dist

 ! local
 real (kind=RKIND), dimension(nlat,nlon) :: arg1
 real (kind=RKIND), parameter :: radius=1.0_RKIND

 arg1 = sqrt( sin(0.5*(gridlat-lat1))**2 +  &
              cos(lat1)*cos(gridlat)*sin(0.5*(gridlon-lon1))**2 )
 dist = 2.*radius*asin(arg1)

end subroutine sphere_distance

subroutine grid2mpas(nlat, nlon, gridlat, gridlon, gridvar, &
     ncell, latcell, loncell, var)

  implicit none

  integer, parameter :: RKIND  = selected_real_kind(12)
  integer :: nlat, nlon, ncell
  real(kind=RKIND), dimension(nlat, nlon) :: gridlat   ! [90, -90]
  real(kind=RKIND), dimension(nlat, nlon) :: gridlon   ! [0, 360]
  real(kind=RKIND), dimension(nlat, nlon) :: gridvar
  real(kind=RKIND), dimension(ncell) :: latcell, loncell, var

  !f2py intent(in) nlat, nlon, gridlat, gridlon, gridvar
  !f2py intent(in) ncell, latcell, loncell
  !f2py intent(out) var

  ! ----- local vars -----
  integer :: icell
  integer :: latloc1, latloc2, lonloc1, lonloc2
  integer, dimension(1) :: loc1d
  integer, dimension(2) :: shp
  real(kind=RKIND), dimension(nlat) :: lat1d
  real(kind=RKIND), dimension(nlon) :: lon1d

  where(loncell<0) latcell=loncell+360
  where(gridlon<0) gridlat=gridlat+360

  lat1d=gridlat(:,1)
  lon1d=gridlon(1,:)
  do icell=1, ncell

     loc1d=minloc(abs(latcell(icell)-lat1d))
     latloc1=loc1d(1)-1
     latloc2=loc1d(1)+1
     if(latloc1<1   ) latloc1=1
     if(latloc2>nlat) latloc2=nlat

     loc1d=minloc(abs(loncell(icell)-lon1d))
     lonloc1=loc1d(1)-1
     lonloc2=loc1d(1)+1
     if(lonloc1<1   ) lonloc1=1
     if(lonloc2>nlon) lonloc2=nlon

     shp=shape(gridvar(latloc1:latloc2,lonloc1:lonloc2))
     var(icell)=SUM(gridvar(latloc1:latloc2,lonloc1:lonloc2))/(shp(1)*shp(2))

  end do

  return
end subroutine grid2mpas


!Autor: Claudio Iván Esparza Castañeda
!Título: División de dos polinomios
!Descripción: Se encarga de dividir un polinomio de grado n entre uno de grado m, el resultado es un polinomio de grado (n-m) con un residuo (m-1)
!Fecha: 19/02/2020

program DivPoli
  !Inicio del programa
  implicit none !Sin variables implícitas
  REAL, allocatable, dimension(:)::a, b, c, d, e, f !Vector tipo REAL con dimensión dinámica
  INTEGER::i, j, m, n !Variables enteras
  WRITE(*, *) "Grado del polinomio mayor" !Preguntar por el grado del polinomio
  READ(*, *) m
  WRITE(*, *) "Grado del polinomio menor" !Preguntar por el grado del polinomio
  READ(*, *) n
  allocate(a(0:m), b(0:m), c(0:m), d(0:m), e(0:m)) !Asignar valor a variables dinámica
  WRITE(*, *) "Coeficientes del polinomio mayor a0+a1x+a2x²+...amx^m" !Pregunta coeficientes del polinomio
  do i=0, m
     READ(*, *) a(i)
  end do
  WRITE(*, *) "Coeficientes del polinomio menor b0+b1x+b2x²+...bnx^n, con n<m" !Pregunta coeficientes del polinomio
  do i=0, n
     READ(*, *) b(i)
  end do
  do i=0, m !Respaldar los valores del vector mayor
     c(i)=a(i)
     d(i)=0
  end do
  do i=m-n, 0, -1
     d(i+1)=c(n+i)/b(n) !Dividir los últimos elementos del polinomio mayor entre el último del polinomio menor
     do j=n+i-1, i, -1
        c(j)=c(j)-d(i+1)*b(j-i) !A los demás términos restarles el producto de el mayor elemento del polinomio mayor y el i-ésimo elemento del polinomio menor
     end do
  end do
  do i=n, m !Hacer 0 los últimos términos del residuo
     c(i)=0
  end do
  do i=0, m-n !Vector solución
     e(i)=d(i+1)
  end do
  write(*, *) "División real [c0+c1x+c2x²+...c(m-n)x^(m-n)]" !Imprimir resultado
  do i=0, m-n
     write(*, 1) "C(", i, ")=", e(i)
  end do
  write(*, *) "Con residuo [r0+r1x+r2x²+...r(m-n-1)x^(m-n-1)]" !Imprimir residuo
  do i=0, m-n
     write(*, 1) "R(", i, ")=", c(i)
  end do
  1 format(' ', a2, i2, a2, f10.3) !Formato para imprimir el resultado
  deallocate(a, b, c, d, e) !Liberar memoria dinámica
end program DivPoli


program sistu_ppal

use datasissim_interface
use jacobi_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

real :: eps
integer :: n, i,j, nmaxit, ier

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), b(n), u(n), r(n))

print*
print*, 'Introduce o epsilon: '
read*, eps
print*

print*
print*, 'Introduce o numero maximo de iteracions: '
read*, nmaxit
print*

!call datasissim(a, b)

do i=1,n
  do j=1,n
    if(i==j) then
      a(i,j) = 5
    else
      a(i,j) = (i+j)*0.1
    end if
  end do
  b(i) = 2
end do

call jacobi(a, b, u, eps, nmaxit, ier)

call residuo(a, b, u, r)

print*,
print*, 'Vector u (solucion): '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

if (allocated(r)) deallocate(r)

end program


PROGRAM square_and_cube_roots
  IMPLICIT NONE
  INTEGER,PARAMETER :: max_size =10
  INTEGER :: j
  REAL, DIMENSION(max_size) :: value
  REAL, DIMENSION(max_size) :: square_root
  REAL, DIMENSION(max_size) :: cube_root

  DO j=1,max_size
     value(j) = REAL (j) !real 是内置函数
     square_root(j) = SQRT(value(j))
     cube_root(j) = value(j) ** (1.0/3.0)
  END DO
  WRITE(*,100)
100 FORMAT ('0',20x,'Table of square and cube roots',/,&
       4x,' Number Square Root Cube Root',&
       3x,' Number Square Root Cube Root',/,&
       4x,' ====== ========== ==========',&
       3x,' ====== ========== ==========')
  WRITE(*,110) (value(j),square_root(j),cube_root(j),j=1,max_size)
110 FORMAT (2(4x,F6.0,9x,F6.4,6x,F6.4))
  WRITE(*,*)3.*(1./3.)
END PROGRAM square_and_cube_roots


subroutine derv(neqn,t,u,ut)
!
!  Subroutine derv computes the derivative vector
!  of the linear PDE problem
!
!  Double precision coding is used
implicit double precision(a-h,l,o-z)
!
!  Size the arrays
dimension u(neqn), ut(neqn)
!
!  Problem parameters
call par(xl,xu,pi)
!
!  BC at x = 0
ut(1)=0.0d0
!
!  BC at x = 1
ut(neqn)=0.0d0
!
!  Interior points
dx=(xu-xl)/dfloat(neqn-1)
dxs=dx*dx
do i=2,neqn-1
ut(i)=(u(i+1)-2.0d0*u(i)+u(i-1))/dxs
end do
return
!
!  End of derv
end


  SUBROUTINE GaussJordan( N, NRHS, A, LDA, B, LDB, INFO )
  IMPLICIT NONE

  INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
! Copyright (c) 2021   Anthony M de Beus
!          Arguments copied and modified from -- LAPACK routine (version 3.1) --
!          Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
!          November 2006
!
!  A       (input/output) array, dimension (LDA,N)
!          On entry, the N-by-N coefficient matrix A.
!          On exit, the N-by-N inverse of A
!
!  LDA    (input) INTEGER
!          The leading dimension of the array AB. LDA >= max(1,N)
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N > 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  B       (input/output) array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS matrix of right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  IPIV    IPIV is INTEGER array, dimension (N)
!          The pivot indices that define the permutation matrix P;
!          row i of the matrix was interchanged with row IPIV(i).
!
!  INFO    INFO is INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero so the solution could not be computed.

!     .. Scalar Arguments ..
  INTEGER,INTENT(IN)   :: LDA, LDB, N, NRHS
  INTEGER, INTENT(OUT) :: INFO
!     ..
!     .. Array Arguments ..
  REAL(wp),INTENT(INOUT) ::  A( LDA, * ), B( LDB, * )

!  .. Work space ..
  INTEGER ::  ipiv(N),icol(N),irow(N),i,j,k,ii,jj,index_row,index_col
  REAL(wp) :: largest,swap(N),temp,pivot,swap2(NRHS)

  info = 0
    IF( N.LT.0 ) THEN
         info = -1
    ELSE IF( NRHS.LT.0 ) THEN
         info = -2
    ELSE IF( LDA.LT.max( 1, N ) ) THEN
         info = -4
    ELSE IF( LDB.LT.max( 1, N ) ) THEN
         info = -6
    END IF
    IF( info.NE.0 ) THEN
!       CALL xerbla( 'GAUSSJ ', -info )
       RETURN
    END IF

   ipiv=0
   do i=1,N
     largest=0
     do j=1,N
       if(ipiv(j) == 1) then
        cycle
       endif
      do k=1,N
       if (ipiv(k) > 1) then
        info=ipiv(k)
        write(*,*) 'Singular matrix in GaussJordan'
        RETURN
       endif
       if(ipiv(k) == 1) then
        cycle
       endif
       if(largest >= ABS(A(j,k))) then
        exit
       endif
       index_row=j
       index_col=k
       largest=ABS(A(j,k))
      end do
    end do
    ipiv(index_col)=ipiv(index_col)+1
    irow(i)=index_row
    icol(i)=index_col
    if (index_row /= index_col) then
      swap(1:N)=A(index_row,1:N)
      A(index_row,1:N)=A(index_col,1:N)
      A(index_col,1:N)=swap(1:N)
      swap2(1:NRHS)=B(index_row,1:NRHS)
      B(index_row,1:NRHS)=B(index_col,1:NRHS)
      B(index_col,1:NRHS)=swap2(1:NRHS)
    endif
    pivot=A(index_col,index_col)
    A(index_col,index_col)=1
    A(index_col,1:N)=A(index_col,1:N)/pivot
    B(index_col,1:NRHS)=B(index_col,1:NRHS)/pivot
    do jj=1,N
     if (jj == index_col) then
      cycle
     endif
     temp=A(jj,index_col)
     A(jj,index_col)=0
     A(jj,1:N)=A(jj,1:N)-A(index_col,1:N)*temp
     B(jj,1:NRHS)=B(jj,1:NRHS)-B(index_col,1:NRHS)*temp
    end do
   end do
   ii=1
   do i=1,N
    ii=N-i+1
    if (irow(ii) == icol(ii)) then
     cycle
    endif
    index_row=irow(ii)
    index_col=icol(ii)
    swap(1:N)=A(1:N,index_row)
    A(1:N,index_row)=A(1:N,index_col)
    A(1:N,index_col)=swap(1:N)
   end do

  END SUBROUTINE GaussJordan


      SUBROUTINE ROTAT ( THETA, I, R )
      IMPLICIT None
C
C 1.    ROTAT
C
C 1.1   ROTAT PROGRAM SPECIFICATION
C
C 1.1.1 ROTAT is the matrix utility routine which creates a matrix 'R' which
C       performs a coordinate system rotation by an angle 'THETA' about
C       coordinate axis 'I' in the counterclockwise direction looking along the
C       axis towards the origin.
C
C 1.1.2 RESTRICTIONS - NONE
C
C 1.1.3 REFERENCES - NONE
C
C 1.2   ROTAT PROGRAM INTERFACE
C
C 1.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. I      -  THE INTEGER FLAG WHICH DETERMINES THE ROTATION AXIS.
C                          (I = 1, 2, 3 REFERS RESPECTIVELY TO ROTATIONS ABOUT
C                          THE X, Y, AND Z AXES.)
C             2. THETA  -  THE ANGLE THROUGH WHICH THE COORDINATE SYSTEM
C                          ROTATION IS PERFORMED. (RAD)
C
C           OUTPUT VARIABLES:
C             1. R(3,3)  -  THE 3x3 ROTATION MATRIX WHICH PERFORMS THE
C                            COORDINATE SYSTEM ROTATION. (UNITLESS)
C
C 1.2.2 COMMON BLOCKS USED -
C
       INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 1.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 R(3,3), THETA, C, S
      Integer*2 I
C
C 1.2.4 DATA BASE ACCESS - NONE
C
C 1.2.5 EXTERNAL INPUT/OUTPUT -  NONE
C
C           OUTPUT VARIABLES:
C             1.  POSSIBLE DEBUG OUTPUT
C
C 1.2.6 SUBROUTINE INTERFACE -
C
C             CALLER SUBROUTINES: DIRNL, ETDG, NUTG, PREG, SITI, WOBG
C             CALLED SUBROUTINES: DCOS, DSIN
C
C 1.2.7 CONSTANTS USED - NONE
C
C 1.2.8 PROGRAM VARIABLES -
C             1.  C  -  THE COSINE OF THE ROTATION ANGLE THETA. (UNITLESS)
C             2.  S  -  THE SINE OF THE ROTATION ANGLE THETA. (UNITLESS)
C
C 1.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    SAVITA GOEL    06/04/87 (CDS FOR A900)
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C     ROTAT Program structure
C
C   Compute the cosine and sine of the rotation angle THETA.
      C = DCOS ( THETA )
      S = DSIN ( THETA )
C
C   Go to the right logic depending to the axix of rotation.
      IF ( I .EQ. 1 )  GO TO 300
      IF ( I .EQ. 2 )  GO TO 400
      IF ( I .EQ. 3 )  GO TO 500
C
C   Rotation about the X-axis.
C
C          ( 1  0  0 )
C   R(X) = ( 0  C  S )
C          ( 0 -S  C )
C
  300 R(1,1) = 1.D0
      R(2,1) = 0.D0
      R(3,1) = 0.D0
      R(1,2) = 0.D0
      R(2,2) = +C
      R(3,2) = -S
      R(1,3) = 0.D0
      R(2,3) = +S
      R(3,3) = +C
      GO TO 600
C
C   Rotation about the Y-axis.
C
C          ( C  0 -S )
C   R(Y) = ( 0  1  0 )
C          ( S  0  C )
C
  400 R(1,1) = +C
      R(2,1) = 0.D0
      R(3,1) = +S
      R(1,2) = 0.D0
      R(2,2) = 1.D0
      R(3,2) = 0.D0
      R(1,3) = -S
      R(2,3) = 0.D0
      R(3,3) = +C
      GO TO 600
C
C   Rotation about the Z-axis.
C
C          ( C  S  0 )
C   R(Z) = (-S  C  0 )
C          ( 0  0  1 )
C
  500 R(1,1) = +C
      R(2,1) = -S
      R(3,1) = 0.D0
      R(1,2) = +S
      R(2,2) = +C
      R(3,2) = 0.D0
      R(1,3) = 0.D0
      R(2,3) = 0.D0
      R(3,3) = 1.D0
      GO TO 600
C
C   Check KMATD for debug output.
  600 IF ( KMATD .EQ. 0 )  GO TO 700
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utility ROTAT." )
      WRITE ( 6, 9200 )  C, S, I, THETA, R
 9200 FORMAT (1X, "C     = ", D30.16, /, 1X,
     1            'S     = ', D30.16, /, 1X,
     2            'I     = ', I2, /, 1X,
     3            'THETA = ', D30.16, /, 1X,
     4            'R     = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
C    Normal conclusion.
  700 RETURN
      END
C
C******************************************************************************
      SUBROUTINE DROTT ( THETA, DTHETA, I, DR )
      IMPLICIT None
C
C 2.    DROTT
C
C 2.1   DROTT PROGRAM SPECIFICATION
C
C 2.1.1 DROTT is the matrix utility routine which creates the partial derivative
C       of a rotation matrix with respect to a variable on which the rotation
C       matrix is functionally dependent.
C
C 2.1.2 RESTRICTIONS - NONE
C
C 2.1.3 REFERENCES - NONE
C
C 2.2   DROTT PROGRAM INTERFACE
C
C 2.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. DTHETA  -  THE PARTIAL DERIVATIVE OF THE ROTATION ANGLE THETA
C                           WITH RESPECT TO THE VARIABLE IN QUESTION.
C             2. I       -  THE INTEGER FLAG WHICH DETERMINES THE ROTATION AXIS.
C                           (I = 1, 2, 3 REFERS RESPECTIVELY TO ROTATIONS ABOUT
C                           THE X, Y, AND Z AXES.)
C             3. THETA   -  THE ANGLE THROUGH WHICH THE COORDINATE SYSTEM
C                           ROTATION IS PERFORMED. (RAD)
C
C           OUTPUT VARIABLES:
C             1. DR(3,3)  -  THE PARTIAL DERIVATIVE OF THE ROTATION MATRIX IN
C                            QUESTION WITH RESPECT TO THE VARIABLE IN QUESTION.
C
C 2.2.2 COMMON BLOCKS USED -
C
       INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1.  KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2.  KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 2.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 DR(3,3), THETA, DTHETA, DC, DS
      Integer*2 I
C
C 2.2.4 DATA BASE ACCESS - NONE
C
C 2.2.5 EXTERNAL INPUT/OUTPUT -
C             1.  POSSIBLE DEBUG OUTPUT
C
C 2.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: DIRNL, NUTG, PREG, PREP, UT1P, WOBP
C             CALLED SUBROUTINES: DCOS, DSIN
C
C 2.2.7 CONSTANTS USED - NONE
C
C 2.2.8 PROGRAM VARIABLES -
C
C             1. DC  -  THE COSINE OF THE ROTATION ANGLE (THETA) MULTIPLIED BY
C                       THE PARTIAL DERIVATIVE OF THE ROTATION ANGLE WITH
C                       RESPECT TO THE VARIABLE IN QUESTION (DTHETA).
C             2. DS  -  THE SINE OF THE ROTATION ANGLE (THETA) MULTIPLIED BY THE
C                       PARTIAL DERIVATIVE OF THE ROTATION ANGLE WITH RESPECT TO
C                       THE VARIABLE IN QUESTION (DTHETA).
C
C 2.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C     DROTT Program Structure
C
C   Compute the program variables DC and DS.
      DC = DCOS ( THETA ) * DTHETA
      DS = DSIN ( THETA ) * DTHETA
C
C   Go to the correct logic depending on the axis of rotation.
      IF ( I .EQ. 1 )  GO TO 300
      IF ( I .EQ. 2 )  GO TO 400
      IF ( I .EQ. 3 )  GO TO 500
C
C   Rotation about the X-axis.
C
C          (  0   0   0  )
C  DR(X) = (  0 -DS  DC  )
C          (  0 -DC -DS  )
C
  300 DR(1,1) = 0.D0
      DR(2,1) = 0.D0
      DR(3,1) = 0.D0
      DR(1,2) = 0.D0
      DR(2,2) = -DS
      DR(3,2) = -DC
      DR(1,3) = 0.D0
      DR(2,3) = +DC
      DR(3,3) = -DS
      GO TO 600
C
C   Rotation about the Y-axis.
C
C          (-DS   0 -DC  )
C  DR(Y) = (  0   0   0  )
C          ( DC   0 -DS  )
C
  400 DR(1,1) = -DS
      DR(2,1) = 0.D0
      DR(3,1) = +DC
      DR(1,2) = 0.D0
      DR(2,2) = 0.D0
      DR(3,2) = 0.D0
      DR(1,3) = -DC
      DR(2,3) = 0.D0
      DR(3,3) = -DS
      GO TO 600
C
C   Rotation about the Z-axis.
C
C          (-DS  DC   0  )
C  DR(Z) = (-DC -DS   0  )
C          (  0   0   0  )
C
  500 DR(1,1) = -DS
      DR(2,1) = -DC
      DR(3,1) = 0.D0
      DR(1,2) = +DC
      DR(2,2) = -DS
      DR(3,2) = 0.D0
      DR(1,3) = 0.D0
      DR(2,3) = 0.D0
      DR(3,3) = 0.D0
      GO TO 600
C
C   Check KMATD for debug output.
  600 IF ( KMATD .EQ. 0 )  GO TO 700
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utility DROTT." )
      WRITE ( 6, 9200 )  DC, DS, DTHETA, I, THETA, DR
 9200 FORMAT (1X, "DC     = ", D30.16, /, 1X,
     1            'DS     = ', D30.16, /, 1X,
     2            'DTHETA = ', D30.16, /, 1X,
     3            'I      = ', I2, /, 1X,
     4            'THETA  = ', D30.16, /, 1X,
     5            'DR     = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
C   7.    NORMAL PROGRAM CONCLUSION.
C
  700 RETURN
      END
C
C******************************************************************************
      SUBROUTINE DDROT ( THETA, DDTHTA, I, DDR )
      IMPLICIT None
C
C 3.    DDROT
C
C 3.1   DDROT PROGRAM SPECIFICATION
C
C 3.1.1 DDROT is the matrix utility routine which creates the second
C       partial derivative of a rotation matrix with respect to a
C       variable on which the rotation matrix is functionally dependent.
C
C 3.1.2 RESTRICTIONS - THIS UTILITY ROUTINE ASSUMES THAT THE SECOND PARTIAL
C                      DERIVATIVE OF THE FUNCTIONALLY DEPENDENT VARIABLE WITH
C                      RESPECT TO THE PARAMETER IN QUESTION IS EQUAL TO ZERO.
C                      THIS IS A VERY GOOD ASSUMPTION IN ALL CASES WHERE
C                      SUBROUTINE DDROT IS USED IN THIS PROGRAM.
C
C 3.1.3 REFERENCES - NONE
C
C 3.2   DDROT PROGRAM INTERFACE
C
C 3.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. DDTHTA  -  THE SECOND PARTIAL DERIVATIVE OF THE ROTATION ANGLE
C                           THETA WITH RESPECT TO THE VARIABLE IN QUESTION.
C             2. I       -  THE INTEGER FLAG WHICH DETERMINES THE ROTATION AXIS.
C                           (I = 1, 2, 3 REFERS RESPECTIVELY TO ROTATIONS ABOUT
C                           THE X, Y, AND Z AXES. )
C             3. THETA   -  THE ANGLE THROUGH WHICH THE COORDINATE SYSTEM
C                           ROTATION IS PERFORMED.  (RAD)
C
C           OUTPUT VARIABLES:
C             1. DDR(3,3)  -  THE SECOND PARTIAL DERIVATIVE OF THE ROTATION
C                             MATRIX IN QUESTION WITH RESPECT TO THE VARIABLE IN
C                             QUESTION.
C
C 3.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 3.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8  DDR(3,3), THETA, DDTHTA, DDC, DDS
      Integer*2 I
C
C 3.2.4 DATA BASE ACCESS - NONE
C
C 3.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 3.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: DIRNL, UT1P
C             CALLED SUBROUTINES: DCOS, DSIN
C
C 3.2.7 CONSTANTS USED - NONE
C
C 3.2.8 PROGRAM VARIABLES -
C             1. DDC  -  THE COSINE OF THE ROTATION ANGLE MULTIPLIED BY THE
C                        SECOND PARTIAL DERIVATIVE OF THE ROTATION ANGLE WITH
C                        RESPECT TO THE VARIABLE IN QUESTION.
C             2. DDS  -  THE SINE OF THE ROTATION ANGLE MULTIPLIED BY THE SECOND
C                        PARTIAL DERIVATIVE OF THE ROTATION ANGLE WITH RESPECT
C                        TO THE VARIABLE IN QUESTION.
C
C 3.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   DDROT Program Structure
C
C   Compute the program variables DDC and DDS.
      DDC = DCOS ( THETA ) * DDTHTA
      DDS = DSIN ( THETA ) * DDTHTA
C
C   Go to the correct logic depending of the axis of rotation.
      IF ( I .EQ. 1 )  GO TO 300
      IF ( I .EQ. 2 )  GO TO 400
      IF ( I .EQ. 3 )  GO TO 500
C
C   Rotation ablut the X-axis.
C
C           (   0    0    0   )
C  DDR(X) = (   0 -DDC -DDS   )
C           (   0  DDS -DDC   )
C
  300 DDR(1,1) = 0.D0
      DDR(2,1) = 0.D0
      DDR(3,1) = 0.D0
      DDR(1,2) = 0.D0
      DDR(2,2) = -DDC
      DDR(3,2) = +DDS
      DDR(1,3) = 0.D0
      DDR(2,3) = -DDS
      DDR(3,3) = -DDC
      GO TO 600
C
C   Rotation about the Y-axis.
C
C           (-DDC    0  DDS   )
C  DDR(Y) = (   0    0    0   )
C           (-DDS    0 -DDC   )
C
  400 DDR(1,1) = -DDC
      DDR(2,1) = 0.D0
      DDR(3,1) = -DDS
      DDR(1,2) = 0.D0
      DDR(2,2) = 0.D0
      DDR(3,2) = 0.D0
      DDR(1,3) = +DDS
      DDR(2,3) = 0.D0
      DDR(3,3) = -DDC
      GO TO 600
C
C   Rotation about the Z-axis.
C
C           (-DDC -DDS    0   )
C  DDR(Z) = ( DDS -DDC    0   )
C           (   0    0    0   )
C
  500 DDR(1,1) = -DDC
      DDR(2,1) = +DDS
      DDR(3,1) = 0.D0
      DDR(1,2) = -DDS
      DDR(2,2) = -DDC
      DDR(3,2) = 0.D0
      DDR(1,3) = 0.D0
      DDR(2,3) = 0.D0
      DDR(3,3) = 0.D0
      GO TO 600
C
C   Check KMATD for debug output.
  600 IF ( KMATD .EQ. 0 )  GO TO 700
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for subroutine DDROT." )
      WRITE ( 6, 9200 )  THETA, I, DDTHTA, DDR
 9200 FORMAT (1X, "THETA  = ", D30.16, /, 1X,
     1            'I      = ', I2, /, 1X,
     2            'DDTHTA = ', D30.16, /, 1X,
     3            'DDR    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
C     Normal Conclusion.
  700 RETURN
      END
C
C*******************************************************************************
      SUBROUTINE D3ROT ( THETA, D3THET, I, D3R )
      IMPLICIT None
C
C 2.    D3ROT
C
C 2.1   D3ROT PROGRAM SPECIFICATION
C
C 2.1.1 D3ROT is the matrix utility routine which creates the third partial
C       derivative of a rotation matrix with respect to a variable on which
C       the rotation matrix is functionally dependent.
C
C 2.1.2 RESTRICTIONS - NONE
C
C 2.1.3 REFERENCES - NONE
C
C 2.2   D3ROT PROGRAM INTERFACE
C
C 2.2.1 CALLING SEQUENCE - CALL D3ROT(THETA,D3THET,I,D3R)
C
C           INPUT VARIABLES:
C             1. D3THET  -  THE THIRD PARTIAL DERIVATIVE OF THE ROTATION ANGLE
C                           THETA WITH RESPECT TO THE VARIABLE IN QUESTION.
C             2. I       -  THE INTEGER FLAG WHICH DETERMINES THE ROTATION AXIS.
C                           (I = 1, 2, 3 REFERS RESPECTIVELY TO ROTATIONS ABOUT
C                           THE X, Y, AND Z AXES.)
C             3. THETA   -  THE ANGLE THROUGH WHICH THE COORDINATE SYSTEM
C                           ROTATION IS PERFORMED. (RAD)
C
C           OUTPUT VARIABLES:
C             1. D3R(3,3) -  THE THIRD PARTIAL DERIVATIVE OF THE ROTATION MATRIX
C                            IN QUESTION WITH RESPECT TO THE VARIABLE IN
C                            QUESTION.
C
C 2.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES "FROM":
C             1.  KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2.  KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 2.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8  D3R(3,3), THETA, D3THET, D3C, D3S
      Integer*2 I
C
C 2.2.4 DATA BASE ACCESS - NONE
C
C 2.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 2.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: DIRNL, NUTG, PREG, PREP, UT1P, WOBP
C             CALLED SUBROUTINES: DCOS, DSIN
C
C 2.2.7 CONSTANTS USED - NONE
C
C 2.2.8 PROGRAM VARIABLES -
C             1. D3C -  THE COSINE OF THE ROTATION ANGLE (THETA) MULTIPLIED BY
C                       THE SECOND PARTIAL DERIVATIVE OF THE ROTATION ANGLE WITH
C                       RESPECT TO THE VARIABLE IN QUESTION (DTHETA).
C             2. D3S -  THE SINE OF THE ROTATION ANGLE (THETA) MULTIPLIED BY THE
C                       SECOND PARTIAL DERIVATIVE OF THE ROTATION ANGLE WITH
C                       RESPECT TO THE VARIABLE IN QUESTION (DTHETA).
C
C 2.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    BRUCE SCHUPLER 03/27/78
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   D3ROT Program Structure
C
C   Compute the program variables D3C and D3S.
      D3C = DCOS ( THETA ) * D3THET
      D3S = DSIN ( THETA ) * D3THET
C
C   Go to the correct logic depending on the axis of rotation.
      IF ( I .EQ. 1 )  GO TO 300
      IF ( I .EQ. 2 )  GO TO 400
      IF ( I .EQ. 3 )  GO TO 500
C
C   Rotation about the X-axis.
C
C          (  0   0   0  )
C  D3R(X) = (  0 +D3S -D3C  )
C          (  0 +D3C +D3S  )
C
  300 D3R(1,1) = 0.D0
      D3R(2,1) = 0.D0
      D3R(3,1) = 0.D0
      D3R(1,2) = 0.D0
      D3R(2,2) = +D3S
      D3R(3,2) = +D3C
      D3R(1,3) = 0.D0
      D3R(2,3) = -D3C
      D3R(3,3) = +D3S
      GO TO 600
C
C   Rotation about the y-axis.
C
C          (+D3S   0 +D3C  )
C  D3R(Y) = (  0   0   0  )
C          (-D3C   0 +D3S  )
C
  400 D3R(1,1) = +D3S
      D3R(2,1) = 0.D0
      D3R(3,1) = -D3C
      D3R(1,2) = 0.D0
      D3R(2,2) = 0.D0
      D3R(3,2) = 0.D0
      D3R(1,3) = +D3C
      D3R(2,3) = 0.D0
      D3R(3,3) = +D3S
      GO TO 600
C
C   Rotation about the Z-axis.
C
C          (+D3S -D3C   0  )
C  D3R(Z) = (+D3C +D3S   0  )
C          (  0   0   0  )
C
  500 D3R(1,1) = +D3S
      D3R(2,1) = +D3C
      D3R(3,1) = 0.D0
      D3R(1,2) = -D3C
      D3R(2,2) = +D3S
      D3R(3,2) = 0.D0
      D3R(1,3) = 0.D0
      D3R(2,3) = 0.D0
      D3R(3,3) = 0.D0
      GO TO 600
C
C   Check KMATD for debug output.
  600 IF ( KMATD .EQ. 0 )  GO TO 700
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utility D3ROT." )
      WRITE ( 6, 9200 )  D3C, D3S, D3THET, I, THETA, D3R
 9200 FORMAT (1X, "D3C     = ", D30.16, /, 1X,
     1            'D3S     = ', D30.16, /, 1X,
     2            'D3THET = ', D30.16, /, 1X,
     3            'I      = ', I2, /, 1X,
     4            'THETA  = ', D30.16, /, 1X,
     5            'D3R     = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
C     Normal conclusion.
  700 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MMUL2 ( A, B, C )
      IMPLICIT None
C
C 4.    MMUL2
C
C 4.1   MMUL2 PROGRAM SPECIFICATION
C
C 4.1.1 MMUL2 is the matrix utility which multiplies two rotation matrices
C       producing a product rotation matrix.
C
C 4.1.2 RESTRICTIONS - NONE
C
C 4.1.3 REFERENCES - NONE
C
C 4.2   MMUL2 PROGRAM INTERFACE
C
C 4.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. C(3,3)  -  THE PRODUCT OF ROTATION MATRICES A AND B.
C
C 4.2.2 COMMON BLOCKS USED -
C
       INCLUDE 'ccon.i'
C
C            VARIABLES 'FROM':
C              1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C              2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C            VARIABLES 'TO': NONE
C
C 4.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8  A(3,3), B(3,3), C(3,3)
      Integer*2 I, J
C
C 4.2.4 DATA BASE ACCESS - NONE
C
C 4.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 4.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: MMUL3, SITI, WOBG, WOBP
C             CALLED SUBROUTINES: NONE
C
C 4.2.7 CONSTANTS USED - NONE
C
C 4.2.8 PROGRAM VARIABLES - NONE
C
C 4.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   MMUL2 Program Structure
C
C   Perform the multiplication.
      DO 120  J = 1,3
        DO 110  I = 1,3
          C(I,J) =   A(I,1) * B(1,J)
     1             + A(I,2) * B(2,J)
     2             + A(I,3) * B(3,J)
  110   CONTINUE
  120 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD. EQ. 0 )  GO TO 300
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utility MMUL2." )
      WRITE ( 6, 9200 )  A, B, C
 9200 FORMAT (1X, "A   = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'C   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MMUL3 ( A, B, C, D )
      IMPLICIT None
C
C 5.    MMUL3
C
C 5.1   MMUL3 PROGRAM SPECIFICATION
C
C 5.1.1 MMUL3 is the matrix utility routine which multiplies together
C       three rotation matrices producing a product rotation matrix.
C
C 5.1.2 RESTRICTIONS - NONE
C
C 5.1.3 REFERENCES - NONE
C
C 5.2   MMUL3 PROGRAM INTERFACE
C
C 5.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C             3. C(3,3)  -  THE THIRD ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. D(3,3)  -  THE PRODUCT OF ROTATION MATRICES A, B, AND C.
C
C 5.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES "FROM":
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 5.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8  A(3,3), AB(3,3), B(3,3), C(3,3), D(3,3)
C
C 5.2.4 DATA BASE ACCESS - NONE
C
C 5.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 5.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: MMUL5, NUTG, PREG, PREP
C             CALLED SUBROUTINES: MMUL2
C
C 5.2.7 CONSTANTS USED - NONE
C
C 5.2.8 PROGRAM VARIABLES -
C             1. AB(3,3)  -  THE PRODUCT OF ROTATION MATRICES A AND B.
C
C 5.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   MMUL3 Program Structure
C
C   Perform the multiplications.
      CALL MMUL2 ( A, B, AB )
      CALL MMUL2 ( AB, C, D )
C
C   Check KMATD to for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utility MMUL3." )
      WRITE ( 6, 9200 )  A, B, C
 9200 FORMAT (1X, "A    = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'C    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MMUL5 ( A, B, C, D, E, F )
      IMPLICIT None
C
C 6.    MMUL5
C
C 6.1   MMUL5 PROGRAM SPECIFICATION
C
C 6.1.1 MMUL5 is the matrix utility routine which multiplies together
C       five rotation matrices producing a product rotation matrix.
C
C 6.1.2 RESTRICTIONS - NONE
C
C 6.1.3 REFERENCES - NONE
C
C 6.2   MMUL5 PROGRAM INTERFACE
C
C 6.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C             3. C(3,3)  -  THE THIRD ROTATION MATRIX.
C             4. D(3,3)  -  THE FOURTH ROTATION MATRIX.
C             5. E(3,3)  -  THE FIFTH ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. F(3,3)  -  THE PRODUCT OF ROTATION MATRICES A, B, C, D, AND E.
C
C 6.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 6.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 A(3,3), ABC(3,3), B(3,3), C(3,3), D(3,3), E(3,3), F(3,3)
C
C 6.2.4 DATA BASE ACCESS - NONE
C
C 6.2.5 EXTERNAL INPUT/OUTPUT -
C             1.  POSSIBLE DEBUG OUTPUT
C
C 6.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: M1950, PREP, UT1P, WOBP
C             CALLED SUBROUTINES: MMUL3
C
C 6.2.7 CONSTANTS USED - NONE
C
C 6.2.8 PROGRAM VARIABLES -
C             1. ABC(3,3)  -  THE PRODUCT OF ROTATION MATRICES A, B, AND C.
C
C 6.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C     MMUL5 Program Structure
C
C   Perform the multiplications
      CALL MMUL3 ( A, B, C, ABC )
      CALL MMUL3 ( ABC, D, E, F )
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utililty MMUL5." )
      WRITE ( 6, 9200 )  A, ABC, B, C, D, E, F
 9200 FORMAT (1X, "A    = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'ABC  = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'B    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     3            'C    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     4            'D    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     5            'E    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     6            'F    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MADD2 ( A, B, C )
      IMPLICIT None
C
C 7.    MADD2
C
C 7.1   MADD2 PROGRAM SPECIFICATION
C
C 7.1.1 MADD2 is the matrix utility which adds togeter two matrices.
C
C 7.1.2 RESTRICTIONS - NONE
C
C 7.1.3 REFERENCES - NONE
C
C 7.2   MADD2 PROGRAM INTERFACE
C
C 7.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. C(3,3)  -  THE SUM OF ROTATION MATRICES A AND B.
C
C 7.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1.  KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2.  KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 7.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8  A(3,3), B(3,3), C(3,3)
      Integer*2 I, J
C
C 7.2.4 DATA BASE ACCESS - NONE
C
C 7.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 7.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: NONE
C             CALLED SUBROUTINES: NONE
C
C 7.2.7 CONSTANTS USED - NONE
C
C 7.2.8 PROGRAM VARIABLES - NONE
C
C 7.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   MADD2 Program Structure
C
C   Do the addition.
      DO 120  J = 1,3
        DO 110  I = 1,3
          C(I,J) = A(I,J) + B(I,J)
  110   CONTINUE
  120 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9100 )
 9100 FORMAT (1X, "DEBUG OUTPUT FOR SUBROUTINE MADD2." )
      WRITE ( 6, 9200 )  A, B, C
 9200 FORMAT (1X, "A    = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'C    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MADD3 ( A, B, C, D )
      IMPLICIT None
C
C 8.    MADD3
C
C 8.1   MADD3 PROGRAM SPECIFICATION
C
C 8.1.1 MADD3 adds together three matrices.
C
C 8.1.2 RESTRICTIONS - NONE
C
C 8.1.3 REFERENCES - NONE
C
C 8.2   MADD3 PROGRAM INTERFACE
C
C 8.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C             3. C(3,3)  -  THE THIRD ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. D(3,3)  -  THE SUM OF ROTATION MATRICES A, B, AND C.
C
C 8.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 8.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 A(3,3), B(3,3), C(3,3), D(3,3)
      Integer*2 I, J
C
C 8.2.4 DATA BASE ACCESS - NONE
C
C 8.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 8.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: M1950, NUTG, PREG, PREP
C             CALLED SUBROUTINES: NONE
C
C 8.2.7 CONSTANTS USED - NONE
C
C 8.2.8 PROGRAM VARIABLES - NONE
C
C 8.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C     MADD3 PROGRAM STRUCTURE
C
C   Do the additions.
      DO 120  J = 1,3
        DO 110  I = 1,3
          D(I,J) = A(I,J) + B(I,J) + C(I,J)
  110   CONTINUE
  120 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9100 )
 9100 FORMAT (1X, "DEBUG OUTPUT FOR SUBROUTINE MADD3." )
      WRITE ( 6, 9200 )  A, B, C, D
 9200 FORMAT (1X, "A   = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'C   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     3            'D   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MADD4 ( A, B, C, D, E )
      IMPLICIT None
C
C 8.    MADD4
C
C 8.1   MADD4 PROGRAM SPECIFICATION
C
C 8.1.1 MADD4 adds together four matrices.
C
C 8.1.2 RESTRICTIONS - NONE
C
C 8.1.3 REFERENCES - NONE
C
C 8.2   MADD4 PROGRAM INTERFACE
C
C 8.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C             3. C(3,3)  -  THE THIRD ROTATION MATRIX.
C             4. D(3,3)  -  THE FOURTH ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. E(3,3)  -  THE SUM OF ROTATION MATRICES A, B, C, AND D.
C
C 8.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 8.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 A(3,3), B(3,3), C(3,3), D(3,3), E(3,3)
      Integer*2 I, J
C
C 8.2.4 DATA BASE ACCESS - NONE
C
C 8.2.5 EXTERNAL INPUT/OUTPUT -  POSSIBLE DEBUG OUTPUT
C
C 8.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: M2000, ?
C             CALLED SUBROUTINES: NONE
C
C 8.2.7 CONSTANTS USED - NONE
C
C 8.2.8 PROGRAM VARIABLES - NONE
C
C 8.2.9 PROGRAMMER - 95.12.11 David Gordon Created from MADD3
C
C     MADD4 PROGRAM STRUCTURE
C
C   Do the additions.
      DO 120  J = 1,3
        DO 110  I = 1,3
          E(I,J) = A(I,J) + B(I,J) + C(I,J) + D(I,J)
  110   CONTINUE
  120 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9100 )
 9100 FORMAT (1X, "DEBUG OUTPUT FOR SUBROUTINE MADD4." )
      WRITE ( 6, 9200 )  A, B, C, D, E
 9200 FORMAT (1X, "A   = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'C   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     3            'D   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     4            'E   = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MADD5 ( A, B, C, D, E, F )
      IMPLICIT None
C
C 9.    MADD5
C
C 9.1   MADD5 PROGRAM SPECIFICATION
C
C 9.1.1 MADD5 adds together five matrices.
C
C 9.1.2 RESTRICTIONS - NONE
C
C 9.1.3 REFERENCES - NONE
C
C 9.2   MADD5 PROGRAM INTERFACE
C
C 9.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE FIRST ROTATION MATRIX.
C             2. B(3,3)  -  THE SECOND ROTATION MATRIX.
C             3. C(3,3)  -  THE THIRD ROTATION MATRIX.
C             4. D(3,3)  -  THE FOURTH ROTATION MATRIX.
C             5. E(3,3)  -  THE FIFTH ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. F(3,3)  -  THE SUM OF ROTATION MATRICES A, B, C, D, AND E.
C
C 9.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C 9.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 A(3,3), B(3,3), C(3,3), D(3,3), E(3,3), F(3,3)
      Integer*2 I,J
C
C 9.2.4 DATA BASE ACCESS - NONE
C
C 9.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C 9.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: M1950
C             CALLED SUBROUTINES: NONE
C
C 9.2.7 CONSTANTS USED - NONE
C
C 9.2.8 PROGRAM VARIABLES - NONE
C
C 9.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   MADD5 Program Structure
C
C     Do the additons.
      DO 120  J = 1,3
        DO 110  I = 1,3
          F(I,J) = A(I,J) + B(I,J) + C(I,J) + D(I,J) + E(I,J)
  110   CONTINUE
  120 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9100 )
 9100 FORMAT (1X, "DEBUG OUTPUT FOR SUBROUTINE MADD5." )
      WRITE ( 6, 9200 )  A, B, C, D, E, F
 9200 FORMAT (1X, "A    = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     2            'C    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     3            'D    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     4            'E    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ),
     5            'F    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C******************************************************************************
      SUBROUTINE MTRAN ( A, B )
      IMPLICIT None
C
C10.    MTRAN
C
C10.1   MTRAN PROGRAM SPECIFICATION
C
C10.1.1 MTRAN constructs the transpose of a matrix.
C
C10.1.2 RESTRICTIONS - NONE
C
C10.1.3 REFERENCES - NONE
C
C10.2   MTRAN PROGRAM INTERFACE
C
C10.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE ROTATION MATRIX TO BE TRANSPOSED.
C
C           OUTPUT VARIABLES:
C             1. B(3,3)  -  THE TRANSPOSE OF THE ROTATION MATRIX A.
C
C10.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C10.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8 A(3,3), B(3,3)
      Integer*2 I, J
C
C10.2.4 DATA BASE ACCESS - NONE
C
C10.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C10.2.6 SUBROUTINE INTERFACE -
C             CALLER SUBROUTINES: ATMG, AXOG
C             CALLED SUBROUTINES: NONE
C
C10.2.7 CONSTANTS USED - NONE
C
C10.2.8 PROGRAM VARIABLES - NONE
C
C10.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   MTRAN Program Structure
C
C     Do the transpostion.
      DO 120  J = 1,3
        DO 110  I = 1,3
          B(I,J) = A(J,I)
  110   CONTINUE
  120 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9100 )
 9100 FORMAT (1X, "Debug output for utility MTRAN." )
      WRITE ( 6, 9200 )  A, B
 9200 FORMAT (1X, "A    = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'B    = ', 3 ( 3 ( D30.16, 10X ), /, 1X ) )
C
  300 RETURN
      END
C
C*****************************************************************************
      SUBROUTINE VECRT ( A, V, RV )
      IMPLICIT None
C
C11.    VECRT
C
C11.1   VECRT PROGRAM SPECIFICATION
C
C11.1.1 VECRT is the matrix utility which multiplies a vector by a rotation
C       matrix.
C
C11.1.2 RESTRICTIONS - NONE
C
C11.1.3 REFERENCES - NONE
C
C11.2   VECRT PROGRAM INTERFACE
C
C11.2.1 CALLING SEQUENCE -
C
C           INPUT VARIABLES:
C             1. A(3,3)  -  THE ROTATION MATRIX PERFORMING THE COORDINATE SYSTEM
C                           ROTATION.
C             2. V(3)    -  THE VECTOR BEING ROTATED BY THE ROTATION MATRIX.
C
C           OUTPUT VARIABLES:
C             1. RV(3)  -  THE ROTATED VECTOR.
C
C11.2.2 COMMON BLOCKS USED -
C
      INCLUDE 'ccon.i'
C
C           VARIABLES 'FROM':
C             1. KMATC  -  THE MATRIX UTILITY ROUTINE FLOW CONTROL FLAG.
C             2. KMATD  -  THE MATRIX UTILITY ROUTINE DEBUG OUTPUT FLAG.
C
C           VARIABLES 'TO': NONE
C
C11.2.3 PROGRAM SPECIFICATIONS -
C
      Real*8  A(3,3), V(3), RV(3)
      Integer*2 I
C
C11.2.4 DATA BASE ACCESS - NONE
C
C11.2.5 EXTERNAL INPUT/OUTPUT -
C             1. POSSIBLE DEBUG OUTPUT
C
C11.2.6 SUBROUTINE INTERFACE -
C           CALLER SUBROUTINES: ATMG, AXOG, ETDG, ETDP, PREP, ROSIT, UT1P, WOBP
C           CALLED SUBROUTINES: NONE
C
C11.2.7 CONSTANTS USED - NONE
C
C11.2.8 PROGRAM VARIABLES - NONE
C
C11.2.9 PROGRAMMER - DALE MARKHAM  01/19/77
C                    PETER DENATALE 07/18/77
C                    Jim Ryan 89.07.25 Documentation simplified.
C                    David Gordon 94.04.15 Converted to Implicit None.
C
C   VECRT PROGRAM STRUCTURE
C
C   Perform the rotation.
      DO 100  I = 1,3
        RV(I) =   A(I,1) * V(1)
     1          + A(I,2) * V(2)
     2          + A(I,3) * V(3)
  100 CONTINUE
C
C   Check KMATD for debug output.
      IF ( KMATD .EQ. 0 )  GO TO 300
      WRITE ( 6, 9)
    9 FORMAT (1X, "Debug output for utility VECRT." )
      WRITE ( 6, 9200 )  A, V, RV
 9200 FORMAT (1X, "A   = ", 3 ( 3 ( D30.16, 10X ), /, 1X ),
     1            'V   = ', 3 ( D30.16, 10X ), /, 1X,
     2            'RV  = ', 3 ( D30.16, 10X ) )
C
  300 RETURN
      END


! initial_field.f90
! author: sunder

!-----------------------------------------------------------------------
! Definition of initial condition
!-----------------------------------------------------------------------

subroutine initial_field(q0, xp)
    use ader_weno
    use constants, only : m_pi
    implicit none
    ! Argument list
    double precision, intent(out) :: q0(nVar)
    double precision, intent(in)  :: xp
    ! Local variable declaration
    double precision :: F1, G1, F2, G2, F3, G3
    double precision, parameter :: alpha = 10.0, a = 0.5, z = -0.7, delta = 0.005, beta = log(2.0)/(36.0*delta*delta)

    if (ICType .eq. 1) then
        q0(1) = sin(m_pi*xp)
    else if (ICType .eq. 2) then
        q0(1) = sin(m_pi*xp + (1.0d0/m_pi)*SIN(m_pi*xp))
    else if (ICType .eq. 3) then
        q0(1) = sin(m_pi*xp)**4
    else if (ICType .eq. 4) then
        if ((-0.5d0 .lt. xp) .AND. (xp .LT. 0.5d0)) then
            q0(1) = 1.0d0
        else
            q0(1) = 0.0d0
        end if
    else if (ICType .eq. 5) then
        F1 = sqrt(max(1.0 - alpha*alpha*(xp-a)*(xp-a) , 0.0d0 ))
        G1 = exp(-beta*(xp-z)*(xp-z))
        F2 = sqrt(max(1.0 - alpha*alpha*(xp-(a-delta))*(xp-(a-delta)) , 0.0d0 ))
        G2 = exp(-beta*(xp-(z-delta))*(xp-(z-delta)))
        F3 = sqrt(max(1.0 - alpha*alpha*(xp-(a+delta))*(xp-(a+delta)) , 0.0d0 ))
        G3 = exp(-beta*(xp-(z+delta))*(xp-(z+delta)))

        if (xp .ge. -0.8d0 .and. xp .lt. -0.6d0) then
            q0(1) = (1.0d0/6.0d0)*(4.0d0*G1 + G2 + G3)
        else if (xp .ge. -0.4d0 .and. xp .lt. -0.2d0) then
            q0(1) = 1.0d0
        else if (xp .ge. 0.0d0 .and. xp .lt. 0.2d0) then
            q0(1) = 1.0d0 - abs(10.0d0*(xp - 0.1d0))
        else if (xp .ge. 0.4d0 .and. xp .lt. 0.6d0) then
            q0(1) = (1.0d0/6.0d0)*(4.0d0*F1 + F2 + F3)
        else
            q0(1) = 0.0d0
        end if

    end if

end subroutine initial_field


 FUNCTION JONSWAP_spectrum(FREQ, Hs, Tp, gamma)
!
! This function returns the value of the JONSWAP spectrum
! for the frequency FREQ, significant wave height Hs, and peak period
! Tp.

   IMPLICIT none
   integer, parameter :: long=selected_real_kind(12,99)
   REAL(kind=long) :: jonswap_spectrum, Hs, Tp, A, B, a_exp, alpha, gamma, &
        sigma, freq, f_p, four=4._long, pi, zero=0._long, one=1._long,     &
        two=2._long, half=.5_long, five=5._long, grav=9.82_long
   pi = acos (-one)
   f_p=one/Tp
   alpha=3.32285_long * Hs**2 * f_p**4
   A=alpha*grav**2/(two*pi)**4
   B=five/four * f_p**4

   IF (freq.le.zero) then
      jonswap_spectrum = zero
   ELSEIF(freq<=f_p)THEN
      sigma=.07_long
      a_exp=exp(-half*((freq-f_p)/(sigma*f_p))**2)
      jonswap_spectrum = A/freq**5 * exp(-B/freq**4) * gamma**a_exp
   ELSE
      sigma=.09_long
      a_exp=exp(-half*((freq-f_p)/(sigma*f_p))**2)
      jonswap_spectrum = A/freq**5 * exp(-B/freq**4) * gamma**a_exp
   ENDIF
   RETURN
 END FUNCTION JONSWAP_spectrum


*dk solvsym3
      subroutine solvsym3(a11,a12,a13,a22,a23,a33,
     &   b1,b2,b3,x1,x2,x3)
C #####################################################################
C
C     PURPOSE -
C
C        Solve 3x3 linear system "AX=B" for symmetric A using
C        Cramer's Rule.
C
C     INPUT ARGUMENTS -
C
C        A11,A12,A13,A22,A23,A33 - Coefficients of a symmetric 3x3
C                                  matrix.
C        B1,B2,B3                - Righthand side vector.
C
C
C     OUTPUT ARGUMENTS -
C
C        X1,X2,X3                - Solution vector.
C
C     CHANGE HISTORY -
C$Log: solvsym3.f,v $
CRevision 2.00  2007/11/09 20:04:03  spchu
CImport to CVS
C
CPVCS
CPVCS       Rev 1.2   Mon Apr 14 17:02:00 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.1   06/02/95 23:45:38   kuprat
CPVCS    Commented out print statement
CPVCS
CPVCS       Rev 1.0   02/15/95 13:37:56   dcg
CPVCS    Original version
C
C ######################################################################
      implicit none
      real*8 a11,a12,a13,a22,a23,a33,b1,b2,b3,x1,x2,x3
      real*8 c11,c12,c13,c22,c23,c33,det

      c11=a22*a33-a23**2
      c12=a13*a23-a12*a33
      c13=a12*a23-a22*a13
      c22=a11*a33-a13**2
      c23=a13*a12-a11*a23
      c33=a11*a22-a12**2

      det=a11*c11+a12*c12+a13*c13

      if (det.eq.0.) then
ccccc         print*,'Solvsym3: Zero determinant!!'
         x1=0.
         x2=0.
         x3=0.
      else
         x1=(b1*c11+b2*c12+b3*c13)/det
         x2=(b1*c12+b2*c22+b3*c23)/det
         x3=(b1*c13+b2*c23+b3*c33)/det
      endif
      return
      end


PROGRAM FIZZBUZZ
      INTEGER :: A = 0;
      DO WHILE(A > -1)
        A = A+1;
        IF(MODULO(A,15) == 0) THEN
          PRINT *, "FIZZ BUZZ";
        ELSE IF(MODULO(A,5) == 0) THEN
          PRINT *, "BUZZ";
        ELSE IF(MODULO(A,3) == 0) THEN
          PRINT *, "FIZZ";
        ELSE
          PRINT *, A;
        END IF
      END DO
END PROGRAM FIZZBUZZ


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... file sfvpgc.f
!
!     this file includes documentation and code for
!     subroutine sfvpgc          i
!
! ... files which must be loaded with sfvpgc.f
!
!     type_SpherepackUtility.f, type_RealPeriodicFastFourierTransform.f, vhagc.f, shsgc.f, compute_gaussian_latitudes_and_weights.f
!
!
!     subroutine sfvpgc(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci,
!    +                   mdb, ndb, wshsgc, lshsgc, work, lwork, ierror)
!
!     given the vector spherical harmonic coefficients br, bi, cr, ci,
!     computed by subroutine vhagc for a vector field (v, w), sfvpgc
!     computes a scalar stream function sf and scalar velocity potential
!     vp for (v, w).  (v, w) is expressed in terms of sf and vp by the
!     helmholtz relations (in mathematical spherical coordinates):
!
!          v = -1/sint*d(vp)/dlambda + d(st)/dtheta
!
!          w =  1/sint*d(st)/dlambda + d(vp)/dtheta
!
!     where sint = sin(theta).  w is the east longitudinal and v
!     is the colatitudinal component of the vector field from which
!     br, bi, cr, ci were precomputed.  required associated legendre
!     polynomials are recomputed rather than stored as they are in
!     subroutine sfvpgs. sf(i, j) and vp(i, j) are given at the i(th)
!     gaussian colatitude point theta(i) (see nlat description below)
!     and east longitude lambda(j) = (j-1)*2*pi/nlon on the sphere.
!
!     input parameters
!
!     nlat   the number of points in the gaussian colatitude grid on the
!            full sphere. these lie in the interval (0, pi) and are computed
!            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
!            if nlat is odd the equator will be included as the grid point
!            theta((nlat + 1)/2).  if nlat is even the equator will be
!            excluded as a grid point and will lie half way between
!            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
!            note: on the half sphere, the number of grid points in the
!            colatitudinal direction is nlat/2 if nlat is even or
!            (nlat + 1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater than
!            3.  the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!
!     isym   a parameter which determines whether the stream function and
!            velocity potential are computed on the full or half sphere
!            as follows:
!
!      = 0
!
!            the symmetries/antsymmetries described in isym=1, 2 below
!            do not exist in (v, w) about the equator.  in this case st
!            and vp are not necessarily symmetric or antisymmetric about
!            the equator.  sf and vp are computed on the entire sphere.
!            i.e., in arrays sf(i, j), vp(i, j) for i=1, ..., nlat and
!            j=1, ..., nlon.
!
!      = 1
!
!            w is antisymmetric and v is symmetric about the equator.
!            in this case sf is symmetric and vp antisymmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the sf(i, j), vp(i, j) are computed
!            for i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is
!            even then sf(i, j), vp(i, j) are computed for i=1, ..., nlat/2
!            and j=1, ..., nlon.
!
!      = 2
!
!            w is symmetric and v is antisymmetric about the equator.
!            in this case sf is antisymmetric and vp symmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the sf(i, j), vp(i, j) are computed
!            for i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is
!            even then sf(i, j), vp(i, j) are computed for i=1, ..., nlat/2
!            and j=1, ..., nlon.
!
!     nt     nt is the number of scalar and vector fields.  some
!            computational efficiency is obtained for multiple fields. arrays
!            can be three dimensional corresponding to an indexed multiple
!            vector field.  in this case multiple scalar synthesis will
!            be performed to compute sf, vp for each field.  the
!            third index is the synthesis index which assumes the values
!            k=1, ..., nt.  for a single synthesis set nt = 1.  the
!            description of the remaining parameters is simplified by
!            assuming that nt=1 or that all the arrays are two dimensional.
!
!     idv    the first dimension of the arrays sf, vp as it appears in
!            the program that calls sfvpgc. if isym = 0 then idv
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then idv must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then idv must be at least (nlat + 1)/2.
!
!     jdv    the second dimension of the arrays sf, vp as it appears in
!            the program that calls sfvpgc. jdv must be at least nlon.
!
!     br, bi, two or three dimensional arrays (see input parameter nt)
!     cr, ci  that contain vector spherical harmonic coefficients
!            of the vector field (v, w) as computed by subroutine vhagc.
!
!     mdb    the first dimension of the arrays br, bi, cr, ci as it
!            appears in the program that calls sfvpgc. mdb must be at
!            least min(nlat, nlon/2) if nlon is even or at least
!            min(nlat, (nlon + 1)/2) if nlon is odd.
!
!     ndb    the second dimension of the arrays br, bi, cr, ci as it
!            appears in the program that calls sfvpgc. ndb must be at
!            least nlat.
!
!     wshsgc an array which must be initialized by subroutine shsgci.
!            once initialized, wshsgc can be used repeatedly by sfvpgc
!            as long as nlon and nlat remain unchanged.  wshsgc must
!            not bel altered between calls of sfvpgc.
!
!
!     lshsgc the dimension of the array wshsgc as it appears in the
!            program that calls sfvpgc. define
!
!               l1 = min(nlat, (nlon+2)/2) if nlon is even or
!               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat + 1)/2    if nlat is odd
!
!            then lshsgc must be at least
!
!               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
!
!
!     work   a work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls sfvpgc. define
!
!               l1 = min(nlat, (nlon+2)/2) if nlon is even or
!               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2                    if nlat is even or
!               l2 = (nlat + 1)/2                if nlat is odd
!
!            if isym is zero then lwork must be at least
!
!                nlat*((nt*nlon+max(3*l2, nlon)) + 2*l1*nt+1)
!
!            if isym is not zero then lwork must be at least
!
!                l2*(nt*nlon+max(3*nlat, nlon)) + nlat*(2*l1*nt+1)
!
!     **************************************************************
!
!     output parameters
!
!    sf, vp  two or three dimensional arrays (see input parameter nt)
!           that contains the stream function and velocity potential
!           of the vector field (v, w) whose coefficients br, bi, cr, ci
!           where precomputed by subroutine vhagc.  sf(i, j), vp(i, j)
!           are given at the i(th) gaussian colatitude point theta(i)
!           and longitude point lambda(j) = (j-1)*2*pi/nlon.  the index
!           ranges are defined above at the input parameter isym.
!
!
!    ierror = 0  no errors
!           = 1  error in the specification of nlat
!           = 2  error in the specification of nlon
!           = 3  error in the specification of isym
!           = 4  error in the specification of nt
!           = 5  error in the specification of idv
!           = 6  error in the specification of jdv
!           = 7  error in the specification of mdb
!           = 8  error in the specification of ndb
!           = 9  error in the specification of lshsgc
!           = 10 error in the specification of lwork
! **********************************************************************
!
module module_sfvpgc

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

    use scalar_synthesis_routines, only: &
        shsgc

    ! Explicit typing only
    implicit none

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

contains

    subroutine sfvpgc(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci, &
        mdb, ndb, wshsgc, lshsgc, work, lwork, ierror)

        integer(ip) :: nlat, nlon, isym, nt, idv, jdv, mdb, ndb, lshsgc, lwork, ierror
        real(wp) :: sf(idv, jdv, nt), vp(idv, jdv, nt)
        real(wp) :: br(mdb, ndb, nt), bi(mdb, ndb, nt)
        real(wp) :: cr(mdb, ndb, nt), ci(mdb, ndb, nt)
        real(wp) :: wshsgc(lshsgc), work(lwork)
        integer(ip) :: imid, mmax, lzz1, labc, ls, nln, mab, mn, ia, ib, is, lwk, iwk, lwmin
        integer(ip) :: l1, l2
        !
        ! Check calling arguments
        !
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. idv<nlat) .or. &
            (isym>0 .and. idv<imid)) return
        ierror = 6
        if (jdv < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon+2)/2)
        if (mdb < min(nlat, (nlon + 1)/2)) return
        ierror = 8
        if (ndb < nlat) return
        ierror = 9
        !
        !     verify saved workspace (same as shsgc)
        !
        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        labc = 3*(max(mmax-2, 0)*(2*nlat-mmax-1))/2
        lwmin = lzz1+labc+nlon+15
        l2 = (nlat + 1)/2
        l1 = min((nlon+2)/2, nlat)
        if (lshsgc < nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
        !
        !     verify unsaved workspace (add to what shsgc requires)
        !
        ierror = 10
        ls = nlat
        if (isym> 0) ls = imid
        nln = nt*ls*nlon
        !
        !     set first dimension for a, b (as required by shsgc)
        !
        mab = min(nlat, nlon/2+1)
        mn = mab*nlat*nt
        if (lwork < nln+max(ls*nlon, 3*nlat*imid)+2*mn+nlat) return
        ierror = 0
        !
        ! Set workspace pointer indices
        !
        ia = 1
        ib = ia+mn
        is = ib+mn
        iwk = is+nlat
        lwk = lwork-2*mn-nlat
        call sfvpgc_lower_utility_routine(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci, mdb, ndb, &
            work(ia), work(ib), mab, work(is), wshsgc, lshsgc, work(iwk), lwk, &
            ierror)

    contains

        subroutine sfvpgc_lower_utility_routine(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci, &
            mdb, ndb, a, b, mab, fnn, wshsgc, lshsgc, wk, lwk, ierror)

            integer(ip) :: nlat, nlon, isym, nt, idv, jdv, mdb, ndb, mab, lshsgc, lwk, ierror
            real(wp) :: sf(idv, jdv, nt), vp(idv, jdv, nt)
            real(wp) :: br(mdb, ndb, nt), bi(mdb, ndb, nt), cr(mdb, ndb, nt), ci(mdb, ndb, nt)
            real(wp) :: a(mab, nlat, nt), b(mab, nlat, nt)
            real(wp) :: wshsgc(lshsgc), wk(lwk), fnn(nlat)
            integer(ip) :: n, m, mmax, k
            !
            !     set coefficient multiplyers
            !
            do n=2, nlat
                fnn(n) = 1.0/sqrt(real(n*(n-1)))
            end do
            mmax = min(nlat, (nlon + 1)/2)
            !
            !     compute sf scalar coefficients from cr, ci
            !
            do k=1, nt
                do n=1, nlat
                    do m=1, mab
                        a(m, n, k) = 0.0
                        b(m, n, k) = 0.0
                    end do
                end do
                !
                ! Compute m=0 coefficients
                !
                do n=2, nlat
                    a(1, n, k) =-fnn(n)*cr(1, n, k)
                    b(1, n, k) =-fnn(n)*ci(1, n, k)
                end do
                !
                !     compute m>0 coefficients using vector spherepack value for mmax
                !
                do m=2, mmax
                    do n=m, nlat
                        a(m, n, k) =-fnn(n)*cr(m, n, k)
                        b(m, n, k) =-fnn(n)*ci(m, n, k)
                    end do
                end do
            end do
            !
            !     synthesize a, b into st
            !
            call shsgc(nlat, nlon, isym, nt, sf, idv, jdv, a, b, mab, nlat, wshsgc, ierror)
            !
            !    set coefficients for vp from br, bi
            !
            do k=1, nt
                do n=1, nlat
                    do m=1, mab
                        a(m, n, k) = 0.0
                        b(m, n, k) = 0.0
                    end do
                end do
                 !
                 ! Compute m=0 coefficients
                 !
                do n=2, nlat
                    a(1, n, k) = fnn(n)*br(1, n, k)
                    b(1, n, k) = fnn(n)*bi(1, n, k)
                end do
                !
                !     compute m>0 coefficients using vector spherepack value for mmax
                !
                mmax = min(nlat, (nlon + 1)/2)
                do m=2, mmax
                    do n=m, nlat
                        a(m, n, k) = fnn(n)*br(m, n, k)
                        b(m, n, k) = fnn(n)*bi(m, n, k)
                    end do
                end do
            end do
            !
            !     synthesize a, b into vp
            !
            call shsgc(nlat, nlon, isym, nt, vp, idv, jdv, a, b, mab, nlat, wshsgc, ierror)

        end subroutine sfvpgc_lower_utility_routine

    end subroutine sfvpgc

end module module_sfvpgc


!7. Write a program that prints a multiplication table for numbers up to 12.

    program Exercises
    implicit none
    integer :: x
    integer :: y

    write (*, fmt='(A)', advance='no') '     '
    do x=1,12
        write(*, fmt='(I4)', advance='no') x
    end do
    print *, ''

    write (*, fmt='(A)', advance='no') '   --'
    do x=1,12
        write(*, fmt='(A)', advance='no') ' ---'
    end do
    print *, ''

    do y=1,12
        write (*, fmt='(I4, A)', advance='no') y, '|'
        do x=1,12
            write (*, fmt='(I4)', advance='no') x*y ! Implicit unit 6. Unit 6 is the one specially reserved for written output to the console.
            flush (unit=6) ! Same-line output doesn't appear right away unless you flush. Not strictly necessary it was useful to get visible output when debugging
        end do
        print *, '' !Newline
    end do

    end program Exercises