program arrays
    implicit none
    integer :: i, j
    real, dimension(2, 3) :: matrix1
    real, dimension(3, 2) :: matrix2
    real, dimension(2, 2) :: matrix3

    matrix1 = reshape([ 2.0, 3.0, 5.0, 7.0, 11.0, 13.0 ], shape(matrix1))
    do i = 1, size(matrix1, 1)
        print *, matrix1(i, :)
    end do
    matrix2 = reshape([ ((i - 2*j, i=1, 2), j=1, 3) ], shape(matrix2))
    do i = 1, size(matrix2, 1)
        print *, matrix2(i, :)
    end do
    print *, size(matrix2)
    print *, size(matrix2, 1), size(matrix2, 2)
    matrix3 = matmul(matrix1, matrix2)
    do i = 1, size(matrix3, 1)
        print *, matrix3(i, :)
    end do
    print *, matrix1 + matrix2
end program arrays


      recursive
     *subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin)
      integer n,ldr
      double precision alpha
      double precision r(ldr,n),w(n),b(n),cos(n),sin(n)
c     **********
c
c     subroutine rwupdt
c
c     given an n by n upper triangular matrix r, this subroutine
c     computes the qr decomposition of the matrix formed when a row
c     is added to r. if the row is specified by the vector w, then
c     rwupdt determines an orthogonal matrix q such that when the
c     n+1 by n matrix composed of r augmented by w is premultiplied
c     by (q transpose), the resulting matrix is upper trapezoidal.
c     the matrix (q transpose) is the product of n transformations
c
c           g(n)*g(n-1)* ... *g(1)
c
c     where g(i) is a givens rotation in the (i,n+1) plane which
c     eliminates elements in the (n+1)-st plane. rwupdt also
c     computes the product (q transpose)*c where c is the
c     (n+1)-vector (b,alpha). q itself is not accumulated, rather
c     the information to recover the g rotations is supplied.
c
c     the subroutine statement is
c
c       subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the upper triangular part of
c         r must contain the matrix to be updated. on output r
c         contains the updated triangular matrix.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       w is an input array of length n which must contain the row
c         vector to be added to r.
c
c       b is an array of length n. on input b must contain the
c         first n elements of the vector c. on output b contains
c         the first n elements of the vector (q transpose)*c.
c
c       alpha is a variable. on input alpha must contain the
c         (n+1)-st element of the vector c. on output alpha contains
c         the (n+1)-st element of the vector (q transpose)*c.
c
c       cos is an output array of length n which contains the
c         cosines of the transforming givens rotations.
c
c       sin is an output array of length n which contains the
c         sines of the transforming givens rotations.
c
c     subprograms called
c
c       fortran-supplied ... dabs,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, dudley v. goetschel, kenneth e. hillstrom,
c     jorge j. more
c
c     **********
      integer i,j,jm1
      double precision cotan,one,p5,p25,rowj,tan,temp,zero
      data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/
c
      do 60 j = 1, n
         rowj = w(j)
         jm1 = j - 1
c
c        apply the previous transformations to
c        r(i,j), i=1,2,...,j-1, and to w(j).
c
         if (jm1 .lt. 1) go to 20
         do 10 i = 1, jm1
            temp = cos(i)*r(i,j) + sin(i)*rowj
            rowj = -sin(i)*r(i,j) + cos(i)*rowj
            r(i,j) = temp
   10       continue
   20    continue
c
c        determine a givens rotation which eliminates w(j).
c
         cos(j) = one
         sin(j) = zero
         if (rowj .eq. zero) go to 50
         if (dabs(r(j,j)) .ge. dabs(rowj)) go to 30
            cotan = r(j,j)/rowj
            sin(j) = p5/dsqrt(p25+p25*cotan**2)
            cos(j) = sin(j)*cotan
            go to 40
   30    continue
            tan = rowj/r(j,j)
            cos(j) = p5/dsqrt(p25+p25*tan**2)
            sin(j) = cos(j)*tan
   40    continue
c
c        apply the current transformation to r(j,j), b(j), and alpha.
c
         r(j,j) = cos(j)*r(j,j) + sin(j)*rowj
         temp = cos(j)*b(j) + sin(j)*alpha
         alpha = -sin(j)*b(j) + cos(j)*alpha
         b(j) = temp
   50    continue
   60    continue
      return
c
c     last card of subroutine rwupdt.
c
      end


module grid_module

    implicit none
    save

    integer, parameter :: mx_grid_max=100000
    integer :: mx_grid
    logical :: radial
    real(kind=8), dimension(0:mx_grid_max+1) :: dxm, dxc, cm, cp, c0

    real(kind=8), dimension(0:mx_grid_max+1) ::  xgrid, zgrid, xcell

contains

subroutine read_grid(fname)

   implicit none
   character(len=*), intent(in) :: fname
   integer :: i,j
   real(kind=8) :: rim,rip,ric,c0i,cmi,cpi,r

   open(unit=58, file=fname, status='old',form='formatted')
   read(58,*) mx_grid
   write(6,*) 'Reading grid with mx_grid = ',mx_grid
   if (mx_grid+1 > mx_grid_max) then
      write(6,*) '*** too many topo values'
      stop
      endif

   ! read in grid cell edges and topo value at each edge:
   do i=1,mx_grid+1
      read(58,*) xgrid(i),zgrid(i)
      enddo

   ! extend to ghost cells, to have same width as first interior cell:
   xgrid(0) = 2.d0*xgrid(1) - xgrid(2)
   xgrid(mx_grid+2) = 2.d0*xgrid(mx_grid+1) - xgrid(mx_grid)
   zgrid(0) = zgrid(1)
   zgrid(mx_grid+2) = zgrid(mx_grid+1)

   do i=0,mx_grid+1
      ! cell centers based on grid edges:
      xcell(i) = 0.5d0*(xgrid(i) + xgrid(i+1))
      enddo

   do i=1,mx_grid+1
      dxm(i) = xcell(i) - xcell(i-1)
      enddo

   do i=1,mx_grid
      ! define coefficients cm(i), cp(i), c0(i) so that
      !   q_{xx} \approx cm(i)*Q(i-1) - c0(i)*Q(i) + cp(i)*Q(i+1)
      ! Note that approximation is not centered at xcell(i), so only 1st order
      ! in general, but should be 2nd order if grid is smoothly varying (?).

      dxc(i) = (xcell(i+1) - xcell(i-1))  ! = 2*dx for uniform grid!
      cm(i) = 2.d0 / (dxm(i)*dxc(i))
      cp(i) = 2.d0 / (dxm(i+1)*dxc(i))
      c0(i) = cm(i) + cp(i)

      if (radial) then
         ! include factors for ((1/r)*(r*q)_r)_r
         ! using form q_{rr} + (1/r)q_r - (1/r**2)q
         r = xcell(i) - xgrid(1)  ! assuming radial about left edge!
         cm(i) = cm(i) - 1.d0/(r*dxc(i))
         cp(i) = cp(i) + 1.d0/(r*dxc(i))
         c0(i) = c0(i) + 1.d0/(r**2)
         endif
      enddo

end subroutine read_grid

end module grid_module


      FUNCTION HORNER(N,A,X)
      IMPLICIT NONE
      INTEGER I,N
      DOUBLE PRECISION A(N),X,Y,HORNER
      Y=A(N)
      DO I=N-1,1,-1
      Y=Y*X+A(I)
      END DO
      HORNER=Y
      END


PROGRAM CelestialMech
IMPLICIT NONE

INTEGER:: i, k, t
DOUBLE PRECISION:: time, G, dt, L, o, pi, Au, d1, d2, d3, c1, c2, c3, c4
DOUBLE PRECISION, DIMENSION(3):: Vector, dvdt, dvdt2
DOUBLE PRECISION, DIMENSION(10):: Mass, Albedo, temp, OrbitTime, X1, Y1, Z1, X2, Y2, Z2, Vx, Vy, Vz, r, avgr, rmin, rmax, e
CHARACTER(LEN=5), DIMENSION(10)::Body=(/'Sun', 'Earth', 'Moon', 'Mer', 'Venus', 'Mars', 'Jup', 'Sat', 'Ura', 'Nep'/)
CHARACTER(LEN=10) :: the_time
CHARACTER(LEN=1):: choice
G = 6.67408E-11; L=3.828E26; o=5.6705E-8; pi=4.0*atan(1.0); Au = 149598000E3
d1=1.351207192; d3=d1; d2=-1.702414384; c1=0.675603596; c4=c1; c2=-0.175603596; c3=c2; rmax=0.0; rmin=9E9999
!Defining constants for Yoshida integration, to calculate acceleration and temperature

OPEN(12, file='ExtraData.dat'); OPEN(13, file='IntialConditions.dat')
OPEN(14, file='Earth.dat');OPEN(15, file='Moon.dat');OPEN(16, file='Mercury.dat')
OPEN(17, file='Venus.dat');OPEN(18, file='Mars.dat');OPEN(19, file='Jupiter.dat')
OPEN(20, file='Saturn.dat'); OPEN(21, file='Uranus.dat');OPEN(22, file='Neptune.dat')
!Gives every planet their own file, making plotting, finding the data and formatting much easier
READ(13,*) Albedo, Mass, X1, Y1, Z1, Vx, Vy, Vz
!Reads initial conditions
CLOSE(13)
!Telling the user about the program
WRITE(6,*) 'This program is designed to calculate the positions of the planets'
WRITE(6,*) 'solar systems planets using newtons law of gravity'
WRITE(6,*) 'and various numerical integration techniques, times, and time steps'
WRITE(6,*) 'Would you like to choose a time step, integration time,'
WRITE(6,*) 'and numerical technique or use the default settings?'
WRITE(6,*) 'The default settings are 1 year, 40 seconds and the Yoshida Method'
WRITE(6,*) 'Press y to enter your own settings, n for default.'
READ(5,*) Choice

IF (choice =='y' .or. choice =='Y') THEN

!Gives user a way to change settings without changing the code directly
!Which can be easier in some cases

  WRITE(6,*) 'Please enter the numerical integration technique you would like to use'
  WRITE(6,*) 'Y for Yoshida, L for leapfrog, E for Euler'
  READ(5,*) Choice
  WRITE(6,*) 'Please enter the integration time.'
  READ(5,*) time
  WRITE(6,*) 'Please enter the time step'
  READ(5,*) dt

ELSE IF (choice =='n'.or. choice =='N') THEN
!This choice still allows the option to change the code directly
 dt=40; time=31536000; choice='y'

END IF

WRITE(6,*) 'Coordinates are printed to files labeled with the planets name, such'
WRITE(6,*) 'as ''Earth.dat'', the coordinates are printed, X, Y, Z for 3d plotting'
WRITE(6,*) 'For other data such as orbit time and temperature please see the file'
WRITE(6,*) '''ExtraData.dat'''
!Tells user where to find the data generated

CALL DATE_AND_TIME(TIME=the_time)
WRITE(12,*) 'Start time: ', the_time
!Records the time the calculation started for later use

X2=X1; Y2=Y1; Z2=Z1

IF (choice =='y'.or. choice =='Y') THEN
  !Yoshida Integration, if loop allows for choice and allows quick testing of all
  !integration methods without having to change the code

  DO t = 0, NINT(time/dt)
    !Do loop over all time for the required number of time steps
    WRITE(14, '(e13.5,e13.5,e13.5)') X2(2), Y2(2), Z2(2);  WRITE(15, '(e13.5,e13.5,e13.5)') X2(3), Y2(3), Z2(3)
    WRITE(16, '(e13.5,e13.5,e13.5)') X2(4), Y2(4), Z2(4);  WRITE(17, '(e13.5,e13.5,e13.5)') X2(5), Y2(5), Z2(5)
    WRITE(18, '(e13.5,e13.5,e13.5)') X2(6), Y2(6), Z2(6);  WRITE(19, '(e13.5,e13.5,e13.5)') X2(7), Y2(7), Z2(7)
    WRITE(20, '(e13.5,e13.5,e13.5)') X2(8), Y2(8), Z2(8);  WRITE(21, '(e13.5,e13.5,e13.5)') X2(9), Y2(9), Z2(9)
    WRITE(22, '(e13.5,e13.5,e13.5)') X2(10), Y2(10), Z2(10)
    !Prints X & Y coordinates to files

    X1=X2; Y1=Y2; Z1=Z2
    !Defines new positions X1 as the final positions of last time step, X2

    DO k=2,10 !k= planet force acting on, i= planet causing force.

      dvdt=0.0 !Resets acceleration for next planet
      X2(k)=X1(k)+c1*Vx(K)*dt; Y2(k)=Y1(k)+c1*Vy(k)*dt; z2(k)=z1(k)+c1*Vz(k)*dt
      !X2 is the variable point, and X1 is the initial position of the planets at the
      !start of the time step

      DO i=1,10  !calculating acceleration, dvdt, at new point
        !Do loop sums over different planets to add their contributions to the acceleration
        IF (i /= k)Then !Avoids calculating acceleration of a planet on itself
          r(k) = sqrt((X2(k)-X1(i))**2+(Y2(k)-Y1(i))**2+(Z2(k)-Z1(i))**2)
          !calculating 'r' from planets new position and other planets initial positions
          !This means that the acceleration for the last planet will still be considering
          !The other planets positions as the start of the time step
          Vector=(/(X2(k)-X1(i)), (Y2(k)-Y1(i)), (Z2(k)-Z1(i))/)/r(k)  !unit Vector for direction of force
          dVdt=-(G*Mass(i)/r(k)**2)*vector+dVdt !Newtons Law  to calculate acceleration due to gravity
        END IF
      END DO

      Vx(k)=Vx(k)+d1*dvdt(1)*dt; Vy(k)=Vy(k)+d1*dvdt(2)*dt; Vz(k)=Vz(k)+d1*dvdt(3)*dt
      X2(k)=X2(k)+c2*Vx(k)*dt;  Y2(k)=Y2(k)+c2*Vy(k)*dt; Z2(k)=Z2(k)+c2*Vz(k)*dt;
      dvdt=0.0 !Acceleration reset in between as we are now considering it at a new point

      DO i=1,10   !calculating acceleration, dvdt, at new point
        IF (i /= k)Then
          r(k) = sqrt((X2(k)-X1(i))**2+(Y2(k)-Y1(i))**2+(Z2(k)-Z1(i))**2)
          Vector=(/(X2(k)-X1(i)), (Y2(k)-Y1(i)), (Z2(k)-Z1(i))/)/r(k)
          dVdt=-(G*Mass(i)/r(k)**2)*vector+dVdt
        END IF
      END DO

      !Yoshida integration step
      Vx(k)=Vx(k)+d2*dvdt(1)*dt; Vy(k)=Vy(k)+d2*dvdt(2)*dt; Vz(k)=Vz(k)+d2*dvdt(3)*dt
      X2(k)=X2(k)+c3*Vx(k)*dt;  y2(k)=y2(k)+c3*Vy(k)*dt;  z2(k)=z2(k)+c3*Vz(k)*dt
      dvdt=0.0  !Acceleration reset in between as we are now considering it at a new point

      DO i=1,10   !calculating acceleration, dvdt,  at new point
        IF (i /= k)Then
          r(k) = sqrt((X2(k)-X1(i))**2+(Y2(k)-Y1(i))**2+(Z2(k)-Z1(i))**2)
          Vector=(/(X2(k)-X1(i)), (Y2(k)-Y1(i)), (Z2(k)-Z1(i))/)/r(k)
          dVdt=-(G*Mass(i)/r(k)**2)*vector+dVdt
        END IF
      END DO

      !Yoshida integration step
      Vx(k)=Vx(k)+d3*dvdt(1)*dt; Vy(k)=Vy(k)+d3*dvdt(2)*dt; Vz(k)=Vz(k)+d3*dvdt(3)*dt
      x2(k)=x2(k)+c4*vx(k)*dt; y2(k)=y2(k)+c4*vy(k)*dt; z2(k)=z2(k)+c4*vz(k)*dt
      dvdt=0.0 !Acceleration reset in between as we are now considering it at a new point

      avgr(k)=sqrt((X2(k)-X1(1))**2+(Y2(k)-Y1(1))**2+(Z2(k)-Z1(1))**2)+avgr(k)
      !Summing up total distance between the planet and the sun to calculate the mean late

      r(k) = sqrt((X2(k)-X1(1))**2+(Y2(k)-Y1(1))**2+(Z2(k)-Z1(1))**2)
      !Considers new distance (r) between planet and sun to calculate eccentricity

      IF (r(k) < rmin(k)) THEN
        !If r is smaller than the smallest r so far it is stored and used to calculate eccentricity
        rmin(k)=r(k)
      ELSE IF (r(k) > rmax(k)) THEN
        rmax(k)=r(k)
        !If r is larger than the largest so far it is stored and used to calculate eccentricity
      END IF

    END DO

  END DO

ELSE IF (choice == 'l'.or. choice =='L') THEN !Leapfrog method

  DO t = 0, NINT(time/dt)

    !Do loop over all time for the required number of time steps
    WRITE(14, '(e13.5,e13.5,e13.5)') X2(2), Y2(2), Z2(2);  WRITE(15, '(e13.5,e13.5,e13.5)') X2(3), Y2(3), Z2(3)
    WRITE(16, '(e13.5,e13.5,e13.5)') X2(4), Y2(4), Z2(4);  WRITE(17, '(e13.5,e13.5,e13.5)') X2(5), Y2(5), Z2(5)
    WRITE(18, '(e13.5,e13.5,e13.5)') X2(6), Y2(6), Z2(6);  WRITE(19, '(e13.5,e13.5,e13.5)') X2(7), Y2(7), Z2(7)
    WRITE(20, '(e13.5,e13.5,e13.5)') X2(8), Y2(8), Z2(8);  WRITE(21, '(e13.5,e13.5,e13.5)') X2(9), Y2(9), Z2(9)
    WRITE(22, '(e13.5,e13.5,e13.5)') X2(10), Y2(10), Z2(10)
    !Prints X & Y coordinates to files

    X1=X2; Y1=Y2; Z1=Z2
    !Defines new positions X1 as the final positions of last time step, X2

    DO k=2,10 !k= planet force acting on, i= planet causing force.
      dvdt=0.0; dvdt2=0.0 !Resets acceleration for when a new planet is considered

      DO i=1,10  !calculating acceleration of intial point

        IF (i /= k) THEN !if command avoids calculating acceleration of a planet on itself
          r(k) = sqrt((X2(k)-X1(i))**2+(Y2(k)-Y1(i))**2+(Z2(k)-Z1(i))**2)
          !calculating 'r' from intial positions of time step
          Vector=(/(X2(k)-X1(i)), (Y2(k)-Y1(i)), (Z2(k)-Z1(i))/)/r(k)  !unit Vector for direction of force
          dVdt=-(G*Mass(i)/r(k)**2)*vector+dVdt !Sums up all contributions to accelerations
        END IF

      END DO

      X2(k)=X2(K)+dt*Vx(k)+0.5*(dt**2)*dvdt(1); Y2(k)=Y2(K)+dt*Vy(k)+0.5*(dt**2)*dvdt(2)
      Z2(k)=Z2(K)+dt*Vz(k)+0.5*(dt**2)*dvdt(3)
      !Calculating  new positions

      DO i=1,10  !calculating acceleration from new positions, dvdt2

        IF (i /= k) THEN
          r(k) = sqrt((X2(k)-X1(i))**2+(Y2(k)-Y1(i))**2+(Z2(k)-Z1(i))**2)
           !calculating 'r' from intial positions of time step
          Vector=(/(X2(k)-X1(i)), (Y2(k)-Y1(i)), (Z2(k)-Z1(i))/)/r(k)  !unit Vector for direction of force
          dVdt2=-(G*Mass(i)/r(k)**2)*vector+dVdt2
        END IF

      END DO

      Vx(k)=Vx(k)+0.5*dt*(dvdt(1)+dvdt2(1)); Vy(k)=Vy(k)+0.5*dt*(dvdt(2)+dvdt2(2))
      Vz(k)=Vz(k)+0.5*dt*(dvdt(3)+dvdt2(3))
      !New velocity calculated using the average acceleration between intial and final positions

      avgr(k)=sqrt((X2(k)-X1(1))**2+(Y2(k)-Y1(1))**2+(Z2(k)-Z1(1))**2)+avgr(k)
      !Summing up total distance between the planet and the sun to calculate the mean late

      r(k) = sqrt((X2(k)-X1(1))**2+(Y2(k)-Y1(1))**2+(Z2(k)-Z1(1))**2)
      !Calculates new distance (r) between planet and sun to calculate eccentricity

      IF (r(k) < rmin(k)) THEN
        !If r is smaller than the smallest r so far it is stored and used to calculate eccentricity
        rmin(k)=r(k)
      ELSE IF (r(k) > rmax(k)) THEN
        rmax(k)=r(k)
        !If r is larger than the largest so far it is stored and used to calculate eccentricity
      END IF

    END DO

  END DO

ELSE IF (choice == 'e'.or. choice =='E') THEN !Euler Method

  DO t = 0, NINT(time/dt)

    !Do loop over all time for the required number of time steps
    WRITE(14, '(e13.5,e13.5,e13.5)') X2(2), Y2(2), Z2(2);  WRITE(15, '(e13.5,e13.5,e13.5)') X2(3), Y2(3), Z2(3)
    WRITE(16, '(e13.5,e13.5,e13.5)') X2(4), Y2(4), Z2(4);  WRITE(17, '(e13.5,e13.5,e13.5)') X2(5), Y2(5), Z2(5)
    WRITE(18, '(e13.5,e13.5,e13.5)') X2(6), Y2(6), Z2(6);  WRITE(19, '(e13.5,e13.5,e13.5)') X2(7), Y2(7), Z2(7)
    WRITE(20, '(e13.5,e13.5,e13.5)') X2(8), Y2(8), Z2(8);  WRITE(21, '(e13.5,e13.5,e13.5)') X2(9), Y2(9), Z2(9)
    WRITE(22, '(e13.5,e13.5,e13.5)') X2(10), Y2(10), Z2(10)
    !Prints X & Y coordinates to files

    X1=X2; Y1=Y2; Z1=Z2

    DO k=2,10 !k= planet force acting on, i= planet causing force.
      dvdt=0

      DO i=1,10  !calculating acceleration

        IF (i /= k)Then !Avoids calculating acceleration of a planet on itself
          r(k) = sqrt((X2(k)-X1(i))**2+(Y2(k)-Y1(i))**2+(Z2(k)-Z1(i))**2)
          !calculating 'r' from intial positions of time step
          Vector=(/(X2(k)-X1(i)), (Y2(k)-Y1(i)), (Z2(k)-Z1(i))/)/r(k)  !unit Vector for direction of force
          dVdt=-(G*Mass(i)/r(k)**2)*vector+dVdt !Newtons law of gravitation
        END IF

      END DO

      X2(k) = Vx(k)*dt + X2(k); Y2(k) = Vy(k)*dt + Y2(k); Z2(k) = Vz(k)*dt + Z2(k)
      !Assume velocity is constant over time step and use this to calculate new positions
      Vx(K) = dVdt(1)*dt + Vx(k); Vy(k) = dVdt(2)*dt + Vy(k); Vz(k) = dVdt(3)*dt + Vz(k)
      !Assume acceleration is constant over time step and use this to calculate new velocities

      avgr(k)=sqrt((X2(k)-X1(1))**2+(Y2(k)-Y1(1))**2+(Z2(k)-Z1(1))**2)+avgr(k)
      !Summing up total distance between the planet and the sun to calculate the mean late

      r(k) = sqrt((X2(k)-X1(1))**2+(Y2(k)-Y1(1))**2+(Z2(k)-Z1(1))**2)
      !Considers new distance (r) between planet and sun to calculate eccentricity

      IF (r(k) < rmin(k)) THEN
        !If r is smaller than the smallest r so far it is stored and used to calculate eccentricity
        rmin(k)=r(k)
      ELSE IF (r(k) > rmax(k)) THEN
        rmax(k)=r(k)
        !If r is larger than the largest so far it is stored and used to calculate eccentricity
      END IF

    END DO

  END DO

END IF

avgr = avgr/NINT(time/dt)

Temp = ((L*(1-albedo))/(4.0*pi*o*(avgr)**2))**0.25 -273.15
!Calculating surface temp. from flux, albedo, and average distance of planet to sun
OrbitTime = (2*pi*((avgr**3)/(G*Mass(1)))**0.5)/31536000
!Calculating orbit time from average distance of planet to sun and the mass of the sun, in years
e=(rmax-rmin)/(rmax+rmin)
!Calculating eccentricity of orbit

WRITE(12,*) 'Body, Avg. dist. to sun (AU Orbital Period, Temp, eccentricity'
!Printing titles to make data easier to interpret.

DO k = 2, 10

  WRITE(12,'(a5, f6.3, f8.3, f9.3, f8.4)') Body(k), avgr(k)/au, orbitTime(k), TEMP(K), e(k)
  !Printing data to file

END DO

WRITE(12,'(a10, f6.1)') 'Step time:', dt
WRITE(12,'(a17, f13.2)') 'Integration time:', time
WRITE(12,*) 'Number of steps:', NINT(time/dt)
WRITE(12,'(a11, a2)') 'Method used', Choice
CALL DATE_AND_TIME(TIME=the_time)
WRITE(12,*) 'Final time: ', the_time
!Recording all the final data in a file

CLOSE(12); CLOSE(14); CLOSE(15); CLOSE(16); CLOSE(17); CLOSE(18); CLOSE(19); CLOSE(20)
CLOSE(21); CLOSE(22)

END PROGRAM

Celestial Mechanics - With Report/CelestialMechanics.f90


!-----------------------------------------------------------------------
subroutine sub_HSMAC(ustg,vstg,pcnt)
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,imx1,jmx1,dx,divmax,itrp,divg,iblk,dt
  implicit none
!
!-----------------------------------------------------------------------
  integer :: itrmax = 10     ! total # of iteration
  real(8) :: epsmax = 1.d-12 ! max tolerance
  real(8) :: omg    = 1.5d0  ! accel. coef.
  real(8) :: ustg(imx1,jmax)
  real(8) :: vstg(imax,jmx1)
  real(8) :: pcnt(imax,jmax)
!-----------------------------------------------------------------------
!
  integer :: ic,jc,im,jm,ip,jp
  real(8) :: ibl,dp,dive,dtdx
  real(8) :: ibl_xm,ibl_xp,ibl_ym,ibl_yp
  real(8) :: UD1X_TMP,VD1Y_TMP
  real(8) :: C0,dxi
!-----------------------------------------------------------------------
!
  C0  =-omg/(2.d0*dt*(2.d0/(dx**2)))
  dxi = 1.d0/dx
!
  do itrp=1,itrmax
!
    call sub_bc_wall(ustg,vstg,pcnt)
    call sub_bc_outer(ustg,vstg,pcnt)
!
    divmax = 0.d0
!
    do jc=2,jmax-1
    do ic=2,imax-1
!
      im          = ic-1
      jm          = jc-1
      ip          = ic+1
      jp          = jc+1
!
      ibl         = dble(iblk(ic,jc))
      ibl_xm      = dble(iblk(im,jc))
      ibl_xp      = dble(iblk(ip,jc))
      ibl_ym      = dble(iblk(ic,jm))
      ibl_yp      = dble(iblk(ic,jp))
!
!---- U
      UD1X_TMP    = (ustg(ip,jc)-ustg(ic,jc))
!---- V
      VD1Y_TMP    = (vstg(ic,jp)-vstg(ic,jc))
!
!---> Divergence
      dive        = (UD1X_TMP+VD1Y_TMP)*dxi*ibl
      dp          = C0*dive
      pcnt(ic,jc) = pcnt(ic,jc)+dp
      divg(ic,jc) = dive
!
      dp          = dp*dt*dxi
      ustg(ic,jc) = ustg(ic,jc)-dp*ibl_xm
      ustg(ip,jc) = ustg(ip,jc)+dp*ibl_xp
      vstg(ic,jc) = vstg(ic,jc)-dp*ibl_ym
      vstg(ic,jp) = vstg(ic,jp)+dp*ibl_yp
!
      divmax      = dmax1(divmax,dabs(divg(ic,jc)))
!
    enddo
    enddo
!
!   if(divmax<epsmax) exit
!
  enddo
!
  return
end subroutine sub_HSMAC
!-----------------------------------------------------------------------
!
!
!
!-----------------------------------------------------------------------
subroutine sub_plevel
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,dx,pcnt,iblk
  implicit none
!
  integer :: ic,jc
  real(8) :: psum,pmean,volm,vol2,dxmin
!-----------------------------------------------------------------------
!
  volm = 0.d0
  psum = 0.d0
  vol2 = dx**2
  do jc=1,jmax
  do ic=1,imax
    if(iblk(ic,jc)==1) then
      psum = psum+pcnt(ic,jc)*vol2
      volm = volm+vol2
    endif
  enddo
  enddo
!
  pmean = psum/volm
!
  do jc=1,jmax
  do ic=1,imax
    if(iblk(ic,jc)==1) then
      pcnt(ic,jc) = pcnt(ic,jc)-pmean
    endif
  enddo
  enddo
!
  return
end subroutine sub_plevel
!-----------------------------------------------------------------------


use LinearSolverClass
use FEMDomainClass
implicit none

type(LinearSolver_) :: solver
type(FEMDomain_) :: domain
type(IO_) :: f
integer(int32) :: ElementID, i
integer(int32),allocatable :: FixBoundary(:)
real(real64),allocatable :: A_ij(:,:), x_i(:), b_i(:) ! A x = b

! create Mesh
! create sample mesh (element=1~8, 8-node element)
call domain%create(meshtype="Cube3D",x_num=5, y_num=10,z_num=5)
call domain%resize(x=2.0d0)
call domain%resize(y=8.0d0)
call domain%resize(z=2.0d0)
call domain%move(x=3.0d0)

! show initial mesh
call domain%msh("init")
call domain%move(x=-3.0d0)

! initialize solver
call solver%init(NumberOfNode=[domain%nn()],DOF=3 )

! create Elemental Matrices and Vectors
do ElementID=1, domain%ne()

    ! For 1st element, create stiffness matrix
    A_ij = domain%StiffnessMatrix(ElementID=ElementID, E=100.0d0, v=0.40d0)
    b_i  = domain%MassVector(&
        ElementID=ElementID,&
        DOF=domain%nd() ,&
        Density=0.00d0,&
        Accel=(/0.0d0, 0.0d0, -9.80d0/)&
        )

    ! assemble them
    call solver%assemble(&
        connectivity=domain%connectivity(ElementID=ElementID),&
        DOF=domain%nd() ,&
        eMatrix=A_ij)
    call solver%assemble(&
        connectivity=domain%connectivity(ElementID=ElementID),&
        DOF=domain%nd(),&
        eVector=b_i)
enddo

call solver%prepareFix()

! fix deformation >> Dirichlet Boundary
FixBoundary = domain%select(y_max=0.10d0)
do i=1,size(FixBoundary)
    call solver%fix(nodeid=FixBoundary(i)*3-2,entryvalue=0.0d0,row_DomainID=1)
    call solver%fix(nodeid=FixBoundary(i)*3-1,entryvalue=0.0d0,row_DomainID=1)
    call solver%fix(nodeid=FixBoundary(i)*3-0,entryvalue=0.0d0,row_DomainID=1)
enddo

FixBoundary = domain%select(y_min=maxval(domain%mesh%nodcoord(:,2) ) )
do i=1,size(FixBoundary)
    call solver%fix(nodeid=FixBoundary(i)*3-2,entryvalue=0.0d0,row_DomainID=1)
    call solver%fix(nodeid=FixBoundary(i)*3-1,entryvalue=0.0d0,row_DomainID=1)
    call solver%fix(nodeid=FixBoundary(i)*3-0,entryvalue=1.0d0,row_DomainID=1)
enddo

! solve > get displacement
call solver%solve("BiCGSTAB")

! x = X + u
domain%mesh%Nodcoord(:,:) = domain%mesh%Nodcoord(:,:) + reshape(solver%x,domain%nn(),domain%nd() )

! show result
call domain%msh("result")

end


SUBROUTINE p47(input_file,output_file)
!-------------------------------------------------------------------------
! Program 4.7 Analysis of plates using 4-node rectangular plate elements.
!             Homogeneous material with identical elements.
!             Mesh numbered in x- or y-direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,ndim=2,ndof=16,nels,neq,    &
   nip=16,nn,nod=4,nodof=4,nprops=2,np_types,nr,nxe,nye,nlen
 REAL(iwp)::aa,bb,d,d4=4.0_iwp,d12=12.0_iwp,e,one=1.0_iwp,                &
   penalty=1.0e20_iwp,th,two=2.0_iwp,v,zero=0.0_iwp
 CHARACTER(LEN=15)::element='quadrilateral',argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::bm(:),coord(:,:),dtd(:,:),d2x(:),d2xy(:),d2y(:),  &
   g_coord(:,:),km(:,:),kv(:),loads(:),points(:,:),prop(:,:),x_coords(:), &
   y_coords(:),value(:),weights(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types,aa,bb,th
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),g_coord(ndim,nn),g_num(nod,nels),g(ndof),bm(3),    &
   g_g(ndof,nels),coord(nod,ndim),km(ndof,ndof),dtd(ndof,ndof),d2x(ndof), &
   d2y(ndof),d2xy(ndof),num(nod),x_coords(nxe+1),y_coords(nye+1),         &
   points(nip,ndim),weights(nip),prop(nprops,np_types),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)read(10,*)etype
 DO i=1,nxe+1
   x_coords(i)=(i-1)*aa
 END DO
 DO i=1,nye+1
   y_coords(i)=(i-1)*bb
 END DO
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq))
!-----------------------loop the elements to find global array sizes------
 kdiag=0
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   CALL num_to_g(num,nf,g)
   CALL fkdiag(kdiag,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------element stiffness integration and assembly--------
 CALL sample(element,points,weights)
 kv=zero
 elements_2: DO iel=1,nels
   e=prop(1,etype(iel))
   v=prop(2,etype(iel))
   d=e*th**3/(d12*(one-v**2))
   g=g_g(:,iel)
   km=zero
   integration: DO i=1,nip
     CALL fmplat(d2x,d2y,d2xy,points,aa,bb,i)
     DO k=1,ndof
         dtd(k,:)=d4*aa*bb*d*weights(i)*                                  &
         (d2x(k)*d2x(:)/(aa**4)+d2y(k)*d2y(:)/(bb**4)+(v*d2x(k)*d2y(:)+   &
         v*d2x(:)*d2y(k)+two*(one-v)*d2xy(k)*d2xy(:))/(aa**2*bb**2))
         dtd(:,k)=dtd(k,:)
     END DO
     km=km+dtd
   END DO integration
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
!-----------------------read loads and/or displacements-------------------
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(nf(:,k)),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),no(fixed_freedoms),sense(fixed_freedoms),         &
     value(fixed_freedoms))
   READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   loads(no)=kv(kdiag(no))*value
 END IF
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 WRITE(11,'(/A)')"  Node   Disp        Rot-x       Rot-y       Twist-xy"
 DO k=1,nn
   WRITE(11,'(I5,6E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------recover moments at element centroids--------------
 nip=1
 DEALLOCATE(points)
 ALLOCATE(points(nip,ndim))
 CALL sample(element,points,weights)
 WRITE(11,'(/A)')(" Element x-moment    y-moment    xy-moment")
 DO iel=1,nels
   g=g_g(:,iel)
   moms: DO i=1,nip
     CALL fmplat(d2x,d2y,d2xy,points,aa,bb,i)
     bm=zero
     DO k=1,ndof
       bm(1)=bm(1)+d4*d*(d2x(k)/aa/aa+v*d2y(k)/bb/bb)*loads(g(k))
       bm(2)=bm(2)+d4*d*(v*d2x(k)/aa/aa+d2y(k)/bb/bb)*loads(g(k))
       bm(3)=bm(3)+d4*d*(one-v)*d2xy(k)/aa/bb*loads(g(k))
     END DO
   END DO moms
   WRITE(11,'(I5,3E12.4)')iel,bm
 END DO
END SUBROUTINE p47


C ORDER.F  - Gateway function for computation of the order of a
C            discrete-time system using SLICOT routine IB01AD.
C
C RELEASE 2.0 of SLICOT System Identification Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [R(,n,sval,rcnd)] = order(meth,alg,jobd,batch,conct,s,Y(,U,tol,
C                             printw,ldwork,R))
C
C Purpose:
C   To preprocess the input-output data for estimating the matrices
C   of a linear time-invariant dynamical system, using Cholesky or
C   QR factorization and subspace identification techniques (MOESP
C   and N4SID), and to find an estimate of the system order. The
C   input-output data can, optionally, be processed sequentially.
C
C Input parameters:
C   meth  - integer option to determine the method to use:
C           = 1 : MOESP method with past inputs and outputs;
C           = 2 : N4SID method.
C   alg   - integer option to determine the algorithm for computing the
C           triangular factor of the concatenated block-Hankel matrices
C           built from the input-output data:
C           = 1 : Cholesky algorithm on the correlation matrix;
C           = 2 : fast QR algorithm;
C           = 3 : standard QR algorithm.
C   jobd  - integer option to specify if the matrices B and D should
C           later be computed using the MOESP approach:
C           = 1 : the matrices B and D should later be computed using
C                 the MOESP approach;
C           = 2 : the matrices B and D should not be computed using
C                 the MOESP approach.
C           This parameter is not relevant for meth = 2.
C   batch - integer option to specify whether or not sequential data
C           processing is to be used, and, for sequential processing,
C           whether or not the current data block is the first block,
C           an intermediate block, or the last block, as follows:
C           = 1:  the first block in sequential data processing;
C           = 2:  an intermediate block in sequential data processing;
C           = 3:  the last block in sequential data processing;
C           = 4:  one block only (non-sequential data processing).
C   conct - integer option to specify whether or not the successive data
C           blocks in sequential data processing belong to a single
C           experiment, as follows:
C           = 1:  the current data block is a continuation of the
C                 previous data block and/or it will be continued by the
C                 next data block;
C           = 2:  there is no connection between the current data block
C                 and the previous and/or the next ones.
C           This parameter is not used if batch = 4.
C   s     - the number of block rows in the input and output block
C           Hankel matrices to be processed.  s > 0.
C   Y     - the t-by-l output-data sequence matrix.  Column j of  Y
C           contains the  t  values of the j-th output component for
C           consecutive time increments.
C   U     - (optional) the t-by-m input-data sequence matrix.  Column j
C           of  U  contains the  t  values of the j-th input component
C           for consecutive time increments.
C           Default:    U = [].
C   tol   - (optional) vector of length 2 containing tolerances:
C           tol(1) - tolerance used for estimating the rank of matrices.
C           If  tol(1) > 0,  then the given value of  tol(1)  is used
C           as a lower bound for the reciprocal condition number;
C           an m-by-n matrix whose estimated condition number is less
C           than  1/tol(1)  is considered to be of full rank.
C           If  tol(1) <= 0,  then a default value m*n*epsilon_machine
C           is used, where epsilon_machine is the relative machine
C           precision.
C           tol(2) - tolerance used for determining an estimate of the
C           system order. If  tol(2) >= 0,  the estimate is indicated
C           by the index of the last singular value greater than or
C           equal to  tol(2).  (Singular values less than  tol(2) are
C           considered as zero.) When  tol(2) = 0,  an internally
C           computed default value,  tol(2) = s*epsilon_machine*sval(1),
C           is used, where  sval(1)  is the maximal singular value, and
C           epsilon_machine the relative machine precision.
C           When  tol(2) < 0,  the estimate is indicated by the index of
C           the singular value that has the largest logarithmic gap to
C           its successor.
C           Default:    tol(1:2) = [0,-1].
C   printw- (optional) switch for printing the warning messages.
C           = 1:  print warning messages;
C           = 0:  do not print warning messages.
C           Default:    printw = 0.
C   ldwork- (optional) the workspace size.
C           Default : computed by the formulas
C           nr = 2*( m + l )*s
C           LDWORK = ( t - 2*s + 3 + 64 )*nr
C           if ( CSIZE > MAX( nr*nr + t*( m + l ) + 16, 2*nr ) ) then
C              LDWORK = MIN( LDWORK, CSIZE - nr*nr - t*( m + l ) - 16 )
C           else
C              LDWORK = MIN( LDWORK, MAX( 2*nr, CSIZE/2 ) )
C           end if
C           LDWORK = MAX( minimum workspace size needed, LDWORK )
C           where CSIZE is the cache size in double precision words.
C           If LDWORK is specified less than the minimum workspace size
C           needed, that minimum value is used instead.
C   R     - (optional) if batch = 2 or 3, the 2*(m+l)*s-by-2*(m+l)*s
C           (upper triangular, if alg <> 2) part of  R  must contain the
C           (upper triangular) matrix  R  computed at the previous call
C           of this mexfile in sequential data processing. If conct = 1,
C           R  has an additional column, also set at the previous call.
C           If alg = 2,  R  has m+l+1 additional columns, set at the
C           previous call.
C           This parameter is not used for batch = 1 or batch = 4.
C
C Output parameter:
C   R     - if batch = 3 or 4, the 2*(m+l)*s-by-2*(m+l)*s part of  R
C           contains the processed upper triangular factor  R  from the
C           QR factorization of the concatenated block-Hankel matrices,
C           and further details needed for computing system matrices.
C           If batch = 1 or 2, then  R  contains intermediate results
C           needed at the next call of this mexfile. If batch = 1 or 2
C           and conct = 1,  R  has an additional column, also set before
C           return. If batch = 1 or 2 and alg = 2,  R  has m+l+1
C           additional columns, set before return.
C   n     - the order of the system.
C   sval  - (optional) the singular values used for estimating the order
C           of the system.
C   rcnd  - (optional) if meth = 2, vector of length 2 containing the
C           reciprocal condition numbers of the matrices involved in
C           rank decisions or least squares solutions.
C
C Contributor:
C   V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999.
C
C Revisions:
C   V. Sima, May 2000, July 2000, February 2001, Apr. 2009, Dec. 2012,
C   May 2020.
C
C **********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      DOUBLE PRECISION  TOL1, TOL2
      INTEGER           INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N,
     $                  NOBR, NSMP
      CHARACTER         ALG, BATCH, CONCT, CTRL, JOBD, METH
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      INTEGER,          ALLOCATABLE :: IWORK(:)
      DOUBLE PRECISION, ALLOCATABLE :: DWORK(:), R(:,:), SV(:), U(:,:),
     $                                 Y(:,:)
C
C .. Local variables and constant dimension arrays ..
      DOUBLE PRECISION  TEMP, TOL(2)
      INTEGER           CSIZE, IALG, IBCH, ICNC, IJOB, IMTH, IP, ISIZE,
     $                  ITMP, IWRK(3), LDWMIN, LIWORK, NCOL, NR, NRSAVE,
     $                  NSMPMN
      CHARACTER*120     TEXT
      LOGICAL           PRINTW
C
C .. Cache size in double precision words ..
      PARAMETER         ( CSIZE = 64000 )
C
C .. External subroutines ..
      EXTERNAL          DCOPY, DLACPY, IB01AD
C
C ..Intrinsic functions..
      INTRINSIC         INT, MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.7 ) THEN
         CALL mexErrMsgTxt
     $        ( 'ORDER requires at least 7 input arguments' )
      ELSE IF ( NLHS.LT.1 ) THEN
         CALL mexErrMsgTxt
     $        ( 'ORDER requires at least 1 output arguments' )
      END IF
C
C Check dimensions of input parameters and read/set scalar parameters.
C
C   meth
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'METH must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'METH must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      IMTH = TEMP
      IF ( IMTH.LT.1 .OR. IMTH.GT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'METH has 1 or 2 the only admissible values' )
      END IF
C
      IF ( IMTH.EQ.1 ) THEN
         METH = 'M'
      ELSE
         METH = 'N'
      END IF
C
C   alg
C
      IF ( mxGetM( PRHS(2) ).NE.1 .OR. mxGetN( PRHS(2) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'ALG must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'ALG must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), TEMP, 1 )
      IALG = TEMP
      IF ( IALG.LT.1 .OR. IALG.GT.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'ALG has 1, 2 or 3 the only admissible values' )
      END IF
C
      IF ( IALG.EQ.1 ) THEN
         ALG = 'C'
      ELSE IF ( IALG.EQ.2 ) THEN
         ALG = 'F'
      ELSE
         ALG = 'Q'
      END IF
C
C   jobd
C
      IF ( mxGetM( PRHS(3) ).NE.1 .OR. mxGetN( PRHS(3) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'JOBD must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'JOBD must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), TEMP, 1 )
      IJOB = TEMP
      IF ( IJOB.LT.1 .OR. IJOB.GT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'JOBD has 1 or 2 the only admissible values' )
      END IF
C
      IF ( IJOB.EQ.1 ) THEN
         JOBD = 'M'
      ELSE
         JOBD = 'N'
      END IF
C
C   batch
C
      IF ( mxGetM( PRHS(4) ).NE.1 .OR. mxGetN( PRHS(4) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'BATCH must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'BATCH must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), TEMP, 1 )
      IBCH = TEMP
      IF ( IBCH.LT.1 .OR. IBCH.GT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'BATCH has 1, 2, 3 or 4 the only admissible values' )
      END IF
C
      IF ( IBCH.EQ.1 ) THEN
         BATCH = 'F'
      ELSE IF ( IBCH.EQ.2 ) THEN
         BATCH = 'I'
      ELSE IF ( IBCH.EQ.3 ) THEN
         BATCH = 'L'
      ELSE
         BATCH = 'O'
      END IF
C
C   conct
C
      IF ( mxGetM( PRHS(5) ).NE.1 .OR. mxGetN( PRHS(5) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'CONCT must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(5) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'CONCT must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), TEMP, 1 )
      ICNC = TEMP
      IF ( ICNC.LT.1 .OR. ICNC.GT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'CONCT has 1 or 2 the only admissible values' )
      END IF
C
      IF ( ICNC.EQ.1 ) THEN
         CONCT = 'C'
      ELSE
         CONCT = 'N'
      END IF
C
C   ctrl is set to 'N'
C
      CTRL = 'N'
C
C   s
C
      IF ( mxGetM( PRHS(6) ).NE.1 .OR. mxGetN( PRHS(6) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 's must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(6) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 's must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), TEMP, 1 )
      NOBR = TEMP
      IF ( NOBR.LT.1 ) THEN
         CALL mexErrMsgTxt
     $        ( 's must be a positive integer' )
      END IF
C
C   Y(txp), (U(txm))
C
      NSMP = mxGetM( PRHS(7) )
      L    = mxGetN( PRHS(7) )
C
      IF ( L.LE.0 ) THEN
         CALL mexErrMsgTxt( 'The system has no outputs' )
      END IF
C
      IF ( NRHS.GE.8 ) THEN
         M = mxGetN( PRHS(8) )
      ELSE
         M = 0
      END IF
      NR = 2*( M + L )*NOBR
      IF ( IBCH.LE.2 ) THEN
         NSMPMN = 2*NOBR
      ELSE
         NSMPMN = NR + 2*NOBR - 1
      END IF
C
      IF ( NSMP.LT.NSMPMN ) THEN
         WRITE( TEXT, '('' The number of samples should be at least '',
     $                     I10)' ) NSMPMN
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      IF ( mxIsNumeric( PRHS(7) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(7) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'Y must be a real matrix' )
      END IF
C
      IF ( M.GT.0 ) THEN
         IF ( mxIsNumeric( PRHS(8) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(8) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'U must be a real matrix' )
         END IF
         IF ( mxGetM( PRHS(8) ).NE.NSMP ) THEN
            CALL mexErrMsgTxt
     $          ( 'U must have the same row dimension as Y' )
         END IF
      END IF
C
C     tol
C
      TOL1 = ZERO
      TOL2 = -ONE
      IF ( NRHS.GE.9 ) THEN
         ISIZE = mxGetM( PRHS(9) ) * mxGetN( PRHS(9) )
         IF ( ISIZE.GT.2 )
     $      CALL mexErrMsgTxt
     $           ( 'TOL must be a vector with at most 2 elements' )
         IF ( mxIsNumeric( PRHS(9) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(9) ).EQ.1 ) THEN
              CALL mexErrMsgTxt( 'TOL must be a real vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(9) ), TOL, ISIZE )
         IF ( ISIZE.GT.0 ) TOL1 = TOL(1)
         IF ( ISIZE.GT.1 ) TOL2 = TOL(2)
      END IF
C
      PRINTW = .FALSE.
      IP     = 10
      NCOL   = NR
      IF ( IBCH.LT.4 ) THEN
         IF ( ICNC.EQ.1 )
     $      NCOL = NCOL + 1
         IF ( IALG.EQ.2 )
     $      NCOL = NCOL + M + L + 1
      END IF
      NRSAVE  = ( NCOL - NR )*NR
C
C     printw
C
      IF ( NRHS.GE.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'PRINTW must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'PRINTW must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         ITMP = TEMP
         IF ( ITMP.LT.0 .OR. ITMP.GT.1 ) THEN
            CALL mexErrMsgTxt
     $           ( 'PRINTW has 0 or 1 the only admissible values' )
         END IF
         PRINTW = ITMP.EQ.1
         IP = IP + 1
      END IF
C
C Determine the lenghts of working arrays.
C The quasi-optimal value for LDWORK (assumed block-size 64) is possibly
C modified, so that the sum of the lenghts of DWORK and other needed
C arrays does not exceed the cache size. Specifically, the default value
C for LDWORK is computed using the formulas
C           nr = 2*( m + l )*s
C           LDWORK = ( t - 2*s + 3 + 64 )*nr
C           if ( CSIZE > MAX( nr*nr + t*( m + l ) + 16, 2*nr ) ) then
C              LDWORK = MIN( LDWORK, CSIZE - nr*nr - t*( m + l ) - 16 )
C           else
C              LDWORK = MIN( LDWORK, MAX( 2*nr, CSIZE/2 ) )
C           end if
C           LDWORK = MAX( minimum workspace size needed, LDWORK )
C where CSIZE is the cache size in double precision words.
C If LDWORK is specified, but it is less than the minimum workspace size
C needed, that minimum value is used instead.
C
      LDY = NSMP
      IF ( M.GT.0 ) THEN
         LDU = LDY
      ELSE
         LDU = 1
      END IF
      LDR = NR
      IF ( IMTH.EQ.1 .AND. IJOB.EQ.1 )
     $   LDR = MAX( NR, 3*M*NOBR )
      IF ( IMTH.EQ.2 ) THEN
         LIWORK = ( M + L )*NOBR
      ELSE IF ( IALG.EQ.2) THEN
         LIWORK = M + L
      ELSE
         LIWORK = 1
      END IF
C
C     The next statement is included in order to allow switching
C     from Cholesky or fast QR to QR algorithm.
C
      LDWORK = ( NSMP - 2*NOBR + 3 + 64 )*NR
      IF ( CSIZE .GT. MAX( NR*NR + NSMP*( M + L ) + 16, 2*NR ) ) THEN
         LDWORK = MIN( LDWORK, CSIZE - NR*NR - NSMP*( M + L ) - 16 )
      ELSE
         LDWORK = MIN( LDWORK, MAX( 2*NR, CSIZE/2 ) )
      END IF
      LDWMIN = 2*NR*( NOBR + 1 )
      IF ( IALG.EQ.2 )
     $   LDWMIN = MAX( LDWMIN, 2*NR*( M + L + 1 ) + NR,
     $                 NR*( M + L + 3 ) )
      LDWORK = MAX( LDWORK, LDWMIN )
C
C   ldwork
C
      IF ( NRHS.GE.IP ) THEN
         IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $        mxGetN( PRHS(IP) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'LDWORK must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
              CALL mexErrMsgTxt( 'LDWORK must be a real scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
         ITMP = INT( TEMP )
         IF ( ITMP.LT.LDWMIN ) THEN
            LDWORK = LDWMIN
         ELSE
            LDWORK = ITMP
         END IF
         IP = IP + 1
C
C     R(2*(m+p)*s,2*(m+p)*s(+c)), where
C     c = 1,       if conct = 1 and batch < 4;
C     c = 0,       if conct = 2 or  batch = 4;
C     c = c+m+l+1, if  alg  = 2 and batch < 4.
C
         IF ( NRHS.GE.IP .AND. ( IBCH.EQ.2 .OR. IBCH.EQ.3 ) ) THEN
            IF ( mxGetM( PRHS(IP) ).NE.NR ) THEN
               WRITE( TEXT, '(''R must have '',I5,'' rows'')' ) NR
               CALL mexErrMsgTxt( TEXT )
            END IF
            IF ( mxGetN( PRHS(IP) ).NE.NCOL ) THEN
               WRITE( TEXT, '(''R must have '',I5,'' columns'')' ) NCOL
               CALL mexErrMsgTxt( TEXT )
            END IF
            IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'R must be a real matrix' )
            END IF
         END IF
      END IF
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( R( LDR, NCOL ), SV( L*NOBR ), U( LDU, M ), Y( LDY, L )
     $         )
      ALLOCATE ( IWORK( LIWORK ), DWORK( LDWORK ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(7) ), Y, NSMP*L )
      IF ( M.GT.0 ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(8) ), U, NSMP*M )
      END IF
      IF ( NRHS.GE.IP .AND. ( IBCH.EQ.2 .OR. IBCH.EQ.3 ) ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), R, NR*NCOL )
         IF ( IALG.EQ.2 .OR. ICNC.EQ.1 ) THEN
            IF ( LDR.EQ.NR ) THEN
               CALL DCOPY( NRSAVE, R(1,NR+1), 1, DWORK, 1 )
            ELSE
               CALL DCOPY( NRSAVE, R(NR*NR+1,1), 1, DWORK, 1 )
            END IF
         END IF
      END IF
C
C Do the actual computations.
C
      IF ( IBCH.EQ.2 .OR. IBCH.EQ.3 ) THEN
         IWORK(1) = IWRK(1)
         IWORK(2) = IWRK(2)
         IWORK(3) = IWRK(3)
      END IF
      CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L,
     $             NSMP, U, LDU, Y, LDY, N, R, LDR, SV, TOL1, TOL2,
     $             IWORK, DWORK, LDWORK, IWARN, INFO )
      IF ( IWARN.NE.0 .AND. PRINTW ) THEN
         WRITE( TEXT, '(''  IWARN = '',I4,'' ON EXIT FROM IB01AD'')' )
     $          IWARN
      END IF
      IF ( INFO.NE.0 ) THEN
         WRITE( TEXT, '(''INFO = '',I4,'' ON EXIT FROM IB01AD'')' )
     $          INFO
         GO TO 20
      END IF
      IF ( IBCH.EQ.1 .OR. IBCH.EQ.2 ) THEN
         IWRK(1) = IWORK(1)
         IWRK(2) = IWORK(2)
         IWRK(3) = IWORK(3)
      END IF
C
C Copy output to MATLAB workspace.
C
      IF ( LDR.GT.NR )
     $   CALL DLACPY( 'Full', NR, NR, R, LDR, R, NR )
      IF ( ( IALG.EQ.2 .OR. ICNC.EQ.1 ) .AND. IBCH.LE.2 ) THEN
         IF ( LDR.EQ.NR ) THEN
            CALL DCOPY( NRSAVE, DWORK, 1, R(1,NR+1), 1 )
         ELSE
            CALL DCOPY( NRSAVE, DWORK, 1, R(NR*NR+1,1), 1 )
         END IF
      END IF
      PLHS(1) = mxCreateDoubleMatrix( NR, NCOL, 0 )
      CALL mxCopyReal8ToPtr( R, mxGetPr( PLHS(1) ), NR*NCOL )
      IF ( IBCH.GT.2 ) THEN
         IF ( NLHS.GT.1 ) THEN
            PLHS(2) = mxCreateDoubleMatrix( 1, 1, 0 )
            TEMP = N
            CALL mxCopyReal8ToPtr( TEMP, mxGetPr( PLHS(2) ), 1 )
            IF ( NLHS.GT.2 ) THEN
               PLHS(3) = mxCreateDoubleMatrix( L*NOBR, 1, 0 )
               CALL mxCopyReal8ToPtr( SV, mxGetPr( PLHS(3) ), L*NOBR )
            END IF
            IF ( IMTH.EQ.2 .AND. NLHS.GT.3 ) THEN
               PLHS(4) = mxCreateDoubleMatrix( 2, 1, 0 )
               CALL mxCopyReal8ToPtr( DWORK(2), mxGetPr( PLHS(4) ), 2 )
            END IF
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
   20 CONTINUE
C
      DEALLOCATE( R, SV, U, Y, IWORK, DWORK )
C
C Error and warning handling.
C
      IF ( IWARN.NE.0 .AND. PRINTW ) THEN
         CALL mexPrintf( TEXT )
      END IF
C
      IF ( INFO.NE.0 ) THEN
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of ORDER ***
      END


!======================================================================
! Module for the Matsuno baroclinic wave (Paldor et al 2019)
! tc56 - Eastward inertial gravity wave (EIGW)
! tc57 - Rossby wave (RW)
!======================================================================
module swm_matsuno
    use swm_data
    use constants, only: &
    i4, &
    r8, &
    erad, &
    Omega, &
    rad2deg, &
    deg2rad, &
    pi, &
    piby2, &
    grav, &
    datadir, &
    sec2day

    !Use main grid data structures
    use datastruct, only: &
    grid_structure, &
    scalar_field

    !Use routines from the spherical mesh pack
    use smeshpack, only: &
    convert_vec_sph2cart, &
    convert_vec_cart2sph, &
    insidetrmesh, &
    sph2cart

    !Use routines from the interpolation pack
    use interpack, only: &
    plot_hovmoller_diagram

contains

  subroutine parameters_matsuno(w,ks,n,Am,H0,coef)
  !----------------------------------------------------------------------------------
  !
  !----------------------------------------------------------------------------------
    real(r8), intent(inout) :: w, ks, Am, H0
    complex(r8),intent(inout) :: coef(0:4)
    real(r8) :: eps ! Lamb parameter
    real(r8) :: w_nk(1:3), a, g, k
    complex(r8) :: D(0:4), imag
    complex(r8) :: c1, c2, c3, c4, c5, c6
    integer, intent(inout) :: n
    integer :: j

    !Parameters
    a = erad
    g = grav
    H0 = 30.d0
    eps = (2.d0*omega*a)**2/(g*H0)
    Am = 0.00001
    n = 1
    k = 5.d0
    ks = 5.d0/a

    !Computes the values of delta
    imag = (0.d0,1.d0)
    D(0) = 3.d0*(g*H0*ks*ks + 2.d0*omega*sqrt(g*H0)*(2.d0*n+1.d0)/a)
    D(4) = -54.d0*omega*g*H0*ks/a

    do j = 1,3
      D(j) = sqrt(D(4)**2-4.d0*D(0)**3)
      D(j) = (D(j) + D(4))*0.5d0
      D(j) = D(j)**(1.d0/3.d0)
      D(j) = D(j)*exp((2.d0*pi*j/3.d0)*imag)
    end do

    ! Computes the omegas
    do j = 1, 3
      w_nk(j) = -real((D(j) + D(0)/D(j)))/3.d0
    end do

    if(testcase==56)then
      w = maxval(w_nk) !EIG
    else if(testcase==57)then
      w = -minval(abs(w_nk)) ! Rossby
    end if

    !Others parameters
    c1 = eps**(0.25d0)/a
    coef(0) = c1

    c2 = g*H0*eps**(0.25d0)/((w*w-g*H0*ks*ks)*a)/imag
    c3 = -sqrt(real((n+1.d0)*0.5d0))*(w/sqrt(g*H0)+ks)
    coef(1) = c2*c3
    c4 = -sqrt(real(n*0.5d0))*(w/sqrt(g*H0)-ks)
    coef(2) = c2*c4

    c5 = -sqrt(real((n+1.d0)*0.5d0))*(w+sqrt(g*H0)*ks)
    coef(3) = c2*c5
    c6 = sqrt(real(n*0.5d0))*(w-sqrt(g*H0)*ks)
    coef(4) = c2*c6
    return
  end subroutine parameters_matsuno

  function h_matsuno(lon,lat,w,coef,n,ks,Am,H0,t)
  !----------------------------------------------------------------------------------
  !
  !----------------------------------------------------------------------------------
    real(r8) :: h_matsuno
    real(r8) :: phi
    real(r8), intent(in) :: lon, lat, w, ks, Am,H0,t
    complex(r8),intent(in) :: coef(0:4)
    real(r8) :: x,y, yy
    integer(i4), intent(in) :: n
    complex(r8):: ubar, vbar(-1:1), phibar
    complex(r8) :: imag

    x = lon*erad
    y = lat*erad
    imag = (0.d0,1.d0)

    ! Computes vbar
    yy = coef(0)*y
    vbar(-1) = Am*Hermite(yy,n-1)*exp(-0.5d0*yy**2)
    vbar(0) = Am*Hermite(yy,n)*exp(-0.5d0*yy**2)
    vbar(1) = Am*Hermite(yy,n+1)*exp(-0.5d0*yy**2)
    ! Computes u_n and h_n
    !ubar = coef(1)*vbar(1) + coef(2)*vbar(-1)
    phibar = coef(3)*vbar(1) + coef(4)*vbar(-1)

    ! Computes u, v and h
    !u = real(ubar*exp((ks*x-w*t)*imag))
    !v = real(vbar(0)*exp((ks*x-w*t)*imag))
    phi = real(phibar*exp((ks*x-w*t)*imag))
    h_matsuno = phi/grav + H0
    !print*,hbar
    return
  end function h_matsuno

  ! Set velocity fields for Matsuno test case
  subroutine velocity_matsuno(u,v,lon,lat,w,coef,n,ks,Am,t)
    real(r8), intent(out) :: u,v
    real(r8), intent(in) :: lon, lat, w, ks, Am,t
    complex(r8),intent(in) :: coef(0:4)
    real(r8) :: x,y, yy
    integer(i4), intent(in) :: n
    complex(r8):: ubar, vbar(-1:1), hbar
    complex(r8) :: imag

    x = lon*erad
    y = lat*erad
    imag = (0.d0,1.d0)

    ! Computes vbar
    yy = coef(0)*y
    vbar(-1) = Am*Hermite(yy,n-1)*exp(-0.5d0*yy**2)
    vbar(0) = Am*Hermite(yy,n)*exp(-0.5d0*yy**2)
    vbar(1) = Am*Hermite(yy,n+1)*exp(-0.5d0*yy**2)
    ! Computes u_n and h_n
    ubar = coef(1)*vbar(1) + coef(2)*vbar(-1)
    !hbar = coef(3)*vbar(1) + coef(4)*vbar(-1)

    ! Computes u, v and h
    u = real(ubar*exp((ks*x-w*t)*imag))
    v = real(vbar(0)*exp((ks*x-w*t)*imag))
  end subroutine velocity_matsuno

  function Hermite(x,n)
  !----------------------------------------------------------------------------------
  ! compute the normalized Hermite polynomial
  !----------------------------------------------------------------------------------
    real(r8):: Hermite
    real(r8), intent(in) :: x
    real(r8) :: H(-1:n)
    integer, intent(in) :: n
    integer :: i

    H(-1) = 0.d0
    H(0) = 1.d0/pi**(0.25d0)
    do i = 0, n-1
      H(i+1) = x*sqrt(2.d0/(i+1))*H(i) - sqrt(real(i)/real(i+1))*H(i-1)
    end do
    Hermite = H(n)
  end function Hermite

  subroutine exact_matsuno(t)
  !----------------------------------------------------------------------------------
  ! compute the exact solution
  !----------------------------------------------------------------------------------
    real(r8), intent(in) ::  t
    complex(r8) :: coef(0:4)
    real(r8) :: w, ks, Am, H0, lon, lat, u_aux, v_aux
    real(r8):: vectmp(1:3)
    integer :: i,j, n

    !Computes the parameters
    call parameters_matsuno(w,ks,n,Am,H0,coef)

    !Computes the height field
    do i=1, mesh%nv
      lon=mesh%v(i)%lon
      lat=mesh%v(i)%lat
      h_exact%f(i) = h_matsuno(lon,lat,w,coef,n,ks,Am,H0,t)
    end do

    !Set velocity field
    do l=1,mesh%ne
      if(useStagHC)then
        lat = mesh%edhx(l)%c%lat
        lon = mesh%edhx(l)%c%lon
        call velocity_matsuno(u_aux,v_aux,lon,lat,w,coef,n,ks,Am,t)
        call convert_vec_sph2cart(u_aux, v_aux, mesh%edhx(l)%c%p, vectmp)
        u_exact%f(l)=dot_product(vectmp,mesh%edhx(l)%nr)
      elseif(useStagHTC)then
        lat = mesh%ed(l)%c%lat
        lon = mesh%ed(l)%c%lon
        call velocity_matsuno(u_aux,v_aux,lon,lat,w,coef,n,ks,Am,t)
        call convert_vec_sph2cart(u_aux, v_aux, mesh%ed(l)%c%p, vectmp)
        u_exact%f(l)=dot_product(vectmp,mesh%ed(l)%tg)
      end if
    end do
  end subroutine exact_matsuno

  subroutine matsuno_analysis(k,time)
  !----------------------------------------------------------------------------------
  ! Plot the Hovmoller diagrams
  !----------------------------------------------------------------------------------
    integer, intent(in) :: k

    !Filename
    character (len=70) :: filename

    real(r8), intent(in) :: time

    real(r8) :: t

    !Matsuno parameters
    real(r8) :: w, ks, Am, H0
    complex(r8) :: coef(0:4)

    !Open files
    integer :: iunit
    logical::  ifile

    !Counter
    integer :: i

    call parameters_matsuno(w,ks,n,Am,H0,coef)
    call exact_matsuno(time)

    !Wave period
    if(testcase==56)then !EIGW
      t = 1.9d0
    else if(testcase==57)then !RW
      t = 18.5d0
    endif

    if(time*sec2day>(99.d0)*t .and. time*sec2day<(100.d0)*t) then
    !if(time*sec2day>(0.d0)*t .and. time*sec2day<(1.d0)*t) then
      !Plot the Hovmoller diagrams
      h%f = h%f - 30._r8
      h%name=trim(swmname)//"_h"!//trim(adjustl(trim(atime)))
      call plot_hovmoller_diagram(h, mesh,0.d0,-65.d0,k)

      !Exact solution diagrams
      !Plot the Hovmoller diagrams
      h_exact%f = h_exact%f - 30._r8
      h_exact%name=trim(swmname)//"_h_exact"!//trim(adjustl(trim(atime)))
      call plot_hovmoller_diagram(h_exact, mesh,0.d0,-65.d0,k)

      h%f = h%f + 30._r8
      h_exact%f = h_exact%f + 30._r8
    end if

  end subroutine

end module


program cdemo
    complex :: a = (5,3), b = (0.5, 6.0)      ! complex initializer
    complex :: absum, abprod, aneg, ainv

    absum  = a + b
    abprod = a * b
    aneg   = -a
    ainv   = 1.0 / a
end program cdemo


      MODULE LAIROTCAF	!Calculates "left factorials".
       CONTAINS		!The usual suspects.
        INTEGER*8 FUNCTION FACT(N)	!Factorial, the ordinary.
         INTEGER N	!The number won't ever get far.
         INTEGER I	!The stepper.
          FACT = 1	!Here we go.
          DO I = 2,N		!Does nothing for N < 2.
            FACT = FACT*I		!Perhaps this overflows.
            IF (FACT.LE.0) STOP "Factorial: Overflow!"	!Two's complement arithmetic.
          END DO		!No longer any IF OVERFLOW tests.
        END FUNCTION FACT	!Simple enough.

        INTEGER*8 FUNCTION LFACT(N)	!Left factorial.
         INTEGER N	!This number won't get far either.
         INTEGER K	!A stepper.
          LFACT = 0	!Here we go.
          DO K = 0,N - 1	!Apply the definition.
            LFACT = LFACT + FACT(K)	!Perhaps this overflows.
            IF (LFACT.LE.0) STOP "Lfact: Overflow!"	!Unreliable test.
          END DO		!On to the next step in the summation.
        END FUNCTION LFACT	!No attempts at saving effort.
      END MODULE LAIROTCAF	!Just the minimum.

      PROGRAM POKE
      USE LAIROTCAF
      INTEGER I

      WRITE (6,*) "Left factorials, from 0 to 10..."
      DO I = 0,10
        WRITE (6,1) I,LFACT(I)
    1   FORMAT ("!",I0,T6,I0)
      END DO

      WRITE (6,*) "Left factorials, from 20 to 110 by tens..."
      DO I = 20,110,10
        WRITE (6,1) I,LFACT(I)
      END DO
      END


c
c
c
c     =================================================
      function fdisc(x,y,z)
c     =================================================
c
c     # For computing cell averages for initial data or coefficients that
c     # have a discontinuity along some surface in 3d.

c     # fdisc should be negative to the "left" of the surface and
c     # positive to the "right".

c     # The cellave routine can then be used to compute the fraction wl of
c     # a grid cell that lies to the "left" of the surface.

c     # Sample code for the case where the surface is the unit sphere:

      implicit double precision (a-h,o-z)

      fdisc = x**2 + y**2 + z**2 - 1.d0
c
      return
      end


      PROGRAM XFIT
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  EXAMPLE PROGRAM FOR REGIONAL FREQUENCY ANALYSIS USING THE METHOD OF
C  L-MOMENTS. THE PROGRAM FITS A DISTRIBUTION TO REGIONAL DATA AND USES
C  IT TO ESTIMATE QUANTILES AT EACH SITE.
C
C  THIS EXAMPLE FITS A WAKEBY DISTRIBUTION, USING A VARIANT (PLOTTING
C  POSITION ESTIMATORS INSTEAD OF UNBIASED) OF THE REGIONAL L-MOMENT
C  ALGORITHM DESCRIBED BY HOSKING AND WALLIS ("REGIONAL FREQUENCY
C  ANALYSIS: AN APPROACH BASED ON L-MOMENTS", CAMBRIDGE UNIV. PRESS,
C  1997).  TO FIT A DIFFERENT DISTRIBUTION, REPLACE THE CALLS TO
C  SUBROUTINES PELWAK AND QUAWAK BY THE APPROPRIATE PEL... AND QUA...
C  ROUTINES, CHANGE THE 'WAKEBY' IN FORMAT STATEMENT 6030 AND CHANGE
C  THE VALUE OF PARAMETER NPAR.
C
C  PARAMETERS OF PROGRAM:
C  MAXNS  - SHOULD BE AT LEAST AS LARGE AS THE NUMBER OF SITES IN THE
C           REGION
C  MAXN   - SHOULD BE AT LEAST AS LARGE AS THE LARGEST RECORD LENGTH
C           AT ANY SITE IN THE REGION
C  NPAR   - NUMBER OF PARAMETERS IN THE DISTRIBUTION TO BE FITTED
C           (5 FOR WAKEBY, OF COURSE)
C  NPROB  - NUMBER OF FLOOD QUANTILES TO BE ESTIMATED AT EACH SITE
C  INFILE - STREAM NUMBER TO WHICH INPUT FILE IS ATTACHED
C
C  ARRAYS TO BE INITIALIZED IN DATA STATEMENTS:
C  PROB(NPROB) - PROBABILITIES FOR WHICH QUANTILES ARE TO BE ESTIMATED
C
C  VARIABLES TO BE INITIALIZED IN DATA STATEMENTS:
C  A      - ) PARAMETERS OF
C  B      - ) PLOTTING POSITION
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXNS=100,MAXN=200,NPAR=5,NPROB=10,INFILE=7)
      CHARACTER*32 SITEID
      DOUBLE PRECISION PROB(NPROB),QUANT(NPROB),PARA(5),RMOM(5),
     *  RQUANT(NPROB),WEIGHT(MAXNS),X(MAXN),XMOM(5,MAXNS)
C
      DATA PROB/0.1D0,0.2D0,0.5D0,0.8D0,0.9D0,0.95D0,0.98D0,0.99D0,
     *  0.999D0,0.9999D0/
      DATA A,B/-0.35D0,0D0/
C
      IF(A.EQ.0D0.AND.B.EQ.0D0)WRITE(6,6000)
      IF(A.NE.0D0.OR.B.NE.0D0)WRITE(6,6010)A,B
C
C         READ THE DATA AND CALCULATE AT-SITE L-MOMENTS.
C         ASSUMED STRUCTURE OF DATA FILE IS AS FOLLOWS.
C         1. ONE RECORD CONTAINING THE NUMBER OF SITES IN THE REGION.
C         2. FOR EACH SITE:
C            A  ONE RECORD CONTAINING AN IDENTIFYING LABEL FOR THE SITE;
C            B. ONE RECORD CONTAINING THE RECORD LENGTH AT THE SITE;
C            C. THE DATA VALUES, IN FREE FORMAT.
C
      READ(INFILE,*)NSITE
      DO 10 ISITE=1,NSITE
      READ(INFILE,'(A32)')SITEID
      READ(INFILE,*)N
      READ(INFILE,*)(X(I),I=1,N)
      WEIGHT(ISITE)=N
      CALL SORT(X,N)
      CALL SAMLMR(X,N,XMOM(1,ISITE),NPAR,A,B)
      WRITE(6,6020)ISITE,SITEID,N,(XMOM(I,ISITE),I=1,NPAR)
   10 CONTINUE
C
C         CALCULATE REGIONAL AVERAGE L-MOMENTS
C
      CALL REGLMR(NSITE,NPAR,5,XMOM,WEIGHT,RMOM)
      WRITE(6,6030)(RMOM(I),I=1,NPAR)
C
C         FIT REGIONAL FREQUENCY DISTRIBUTION
C
      CALL PELWAK(RMOM,PARA,IFAIL)
      IF(IFAIL.NE.0)WRITE(6,6040)IFAIL
      WRITE(6,6050)(PARA(I),I=1,NPAR)
C
C         CALCULATE QUANTILES OF REGIONAL FREQUENCY DISTRIBUTION
C
      WRITE(6,6060)(PROB(IQ),IQ=1,NPROB)
      DO 20 IQ=1,NPROB
   20 RQUANT(IQ)=QUAWAK(PROB(IQ),PARA)
      WRITE(6,6070)(RQUANT(IQ),IQ=1,NPROB)
C
C         CALCULATE QUANTILE ESTIMATES FOR EACH SITE
C
      DO 40 ISITE=1,NSITE
      DO 30 IQ=1,NPROB
   30 QUANT(IQ)=XMOM(1,ISITE)*RQUANT(IQ)
      WRITE(6,6080)ISITE,(QUANT(IQ),IQ=1,NPROB)
   40 CONTINUE
C
      STOP
C
 6000 FORMAT(' REGIONAL ANALYSIS, UNBIASED L-MOMENTS'/)
 6010 FORMAT(' REGIONAL ANALYSIS,',
     *  ' L-MOMENT PLOTTING POSITION PARAMETERS ',2F8.4/)
 6020 FORMAT(' SITE',I3,1X,A32,'N=',I3,'   L-MOMENT RATIOS', F9.2,4F9.4)
 6030 FORMAT(//' REGIONAL AVERAGE L-MOMENT RATIOS',5F9.4)
 6040 FORMAT(/' PARAMETER ESTIMATION: FAIL FLAG',I2)
 6050 FORMAT(/' REGIONAL WAKEBY PARAMETERS',5F12.4)
 6060 FORMAT(///'  SITE',25X,'QUANTILES'/' NUMBER',10F10.4/1X,106('-'))
 6070 FORMAT(' REGION',10F10.2/)
 6080 FORMAT(1X,I4,2X,10F10.2)
      END