program mpilaplace
  implicit none
  include "mpif.h"
  integer, parameter :: n=200, nprocs=4, m=n/nprocs
  real(8), dimension(0:n+1,0:m+1) :: u
  real(8), dimension(1:n,1:m) :: unew
  real(8) :: error, tot_error
  integer :: iter, i, j
  integer :: ierror, rank, size, up, down
  integer, dimension(MPI_STATUS_SIZE) :: status

  call MPI_Init(ierror)

  call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror)
  call MPI_Comm_size(MPI_COMM_WORLD, size, ierror)

  if (size /= nprocs) then
     write(*, *) "Can only run with 4 processesd!"
     call MPI_Finalize(ierror)
     stop
  end if

  up = rank + 1
  if (up == size) up = MPI_PROC_NULL

  down = rank - 1
  if (down == -1) down = MPI_PROC_NULL

  u = 0.0d0
  unew = 0.0d0

  if (rank == size-1) then
     u(:,m+1) = 10.0d0
  end if

  tot_error = 1000.0d0
  iter = 0

  do while ( tot_error > 1.0d-6 .and. iter < 1000)
     do j = 1,m
        do i = 1,n
           unew(i,j) = 0.25d0*(  u(i+1,j) + u(i-1,j) + u(i,j+1) + u(i,j-1) )
        end do
     end do

     error = 0.0d0

     do j = 1,m
        do i = 1,n
           error = error + abs(unew(i,j)-u(i,j))
           u(i,j) = unew(i,j)
        end do
     end do

     call MPI_AllReduce(error, tot_error, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
          MPI_COMM_WORLD, ierror)

     if ((rank/2)*2 == rank) then
        call MPI_Send( u(:,m), n, MPI_DOUBLE_PRECISION, up, 1, &
             MPI_COMM_WORLD, ierror)
        call MPI_Send( u(:,1), n, MPI_DOUBLE_PRECISION, down, 2, &
             MPI_COMM_WORLD, ierror)
        call MPI_Recv( u(:,m+1), n, MPI_DOUBLE_PRECISION, up, 2, &
             MPI_COMM_WORLD, status, ierror)
        call MPI_Recv( u(:,0), n, MPI_DOUBLE_PRECISION, down, 1, &
             MPI_COMM_WORLD, status, ierror)
     else
        call MPI_Recv( u(:,m+1), n, MPI_DOUBLE_PRECISION, up, 2, &
             MPI_COMM_WORLD, status, ierror)
        call MPI_Recv( u(:,0), n, MPI_DOUBLE_PRECISION, down, 1, &
             MPI_COMM_WORLD, status, ierror)
        call MPI_Send( u(:,m), n, MPI_DOUBLE_PRECISION, up, 1, &
             MPI_COMM_WORLD, ierror)
        call MPI_Send( u(:,1), n, MPI_DOUBLE_PRECISION, down, 2, &
             MPI_COMM_WORLD, ierror)
     end if

     iter = iter+1

     if( mod(iter,100) == 0 .and. rank == 0) then
        write(*, *) "Iteration ",iter,", error = ",tot_error
     end if
  end do

  call MPI_Finalize(ierror)

end program mpilaplace


module planewave_sources
    use meshread_mod
    implicit none

    complex(8), parameter, private :: iu = (0d0, 1d0)

contains
    subroutine planewave_source_currents(msh, p, alpha, ep1, ep2, mu1, mu2, w, Msrc, Jsrc)
        type(Mesh), intent(in) :: msh     ! Mesh object
        real(8), intent(in) :: p(3)       ! 'p' vector
        real(8), intent(in) :: alpha      ! incidence angle in (-pi, 0)
        real(8), intent(in) :: ep1, ep2   ! Permittivities [F/m]
        real(8), intent(in) :: mu1, mu2   ! Permeabilities [H/m]
        real(8), intent(in) :: w          ! Angular frequency [rad/s]

        complex(8), allocatable, intent(out) :: Msrc(:, :)  ! magnetic current source
        complex(8), allocatable, intent(out) :: Jsrc(:, :)  ! electric current source

        real(8) :: E0, H0                 ! Amplitudes
        real(8) :: k1, k2                 ! Wavenumbers [1/m]
        real(8) :: k1y, k1z, k2y
        complex(8) :: k2z
        complex(8) :: R_TE, R_TM          ! Reflection coefficients
        complex(8) :: T_TE, T_TM          ! Transmission coefficients

        complex(8), allocatable :: E1(:, :), E2(:, :) ! Electric fields
        complex(8), allocatable :: H1(:, :), H2(:, :) ! Magnetic fields

        complex(8) :: exp1(msh%nbNod)   ! exp(iu * (k1y*y - k1z*z))
        complex(8) :: exp2(msh%nbNod)   ! exp(iu * (k1y*y + k1z*z))
        complex(8) :: exp3(msh%nbNod)   ! exp(iu * (k2y*y - k2z*z))

        complex(8) :: Einc_x(msh%nbNod), Hinc_x(msh%nbNod)
        complex(8) :: Eref_x(msh%nbNod), Href_x(msh%nbNod)
        complex(8) :: Etrs_x(msh%nbNod), Htrs_x(msh%nbNod)

        ! initialize variables
        k1 = w * sqrt(ep1 * mu1)
        k1y = k1 * cos(alpha)
        k1z = -k1 * sin(alpha)

        k2 = w * sqrt(ep2 * mu2)
        k2y = k1y
        k2z = sqrt(dcmplx(k2**2 - k2y**2))
        k2z = dreal(k2z) + abs(dimag(k2z))

        R_TE = (mu2*k1z - mu1*k2z) / (mu2*k1z + mu1*k2z)
        R_TM = (ep2*k1z - ep1*k2z) / (ep2*k1z - ep1*k2z)
        T_TE = 2d0*mu2*k1z  / (mu2*k1z + mu1*k2z)
        T_TM = 2d0*ep2*k1z  / (ep2*k1z - ep1*k2z)

        E0 = -p(3)*k1y - p(2)*k1z
        H0 = w*ep1*p(1)

        ! compute exponentials
        exp1 = exp(iu * (k1y * msh%POS(:, 2) - k1z * msh%POS(:, 3)))
        exp2 = exp(iu * (k1y * msh%POS(:, 2) + k1z * msh%POS(:, 3)))
        exp3 = exp(iu * (k2y * msh%POS(:, 2) - k2z * msh%POS(:, 3)))

        ! compute transverse fields
        Einc_x = E0 * exp1
        Hinc_x = H0 * exp1
        Eref_x = E0 * R_TE * exp2
        Href_x = H0 * R_TM * exp2
        Etrs_x = E0 * T_TE * exp3
        Htrs_x = H0 * T_TM * exp3

        ! allocate buffers
        allocate(E1(msh%nbNod, 3))
        allocate(E2(msh%nbNod, 3))
        allocate(H1(msh%nbNod, 3))
        allocate(H2(msh%nbNod, 3))

        ! x components
        E1(:, 1) = Einc_x + Eref_x
        E2(:, 1) = Etrs_x
        H1(:, 1) = Hinc_x + Href_x
        H2(:, 1) = Htrs_x

        ! y components
        E1(:, 2) = -1d0/(IU*w*ep1) * IU*k1z * (-Hinc_x + Href_x)
        E2(:, 2) = -1d0/(IU*w*ep2) * IU*k2z * (-Htrs_x)
        H1(:, 2) = 1d0/(IU*w*mu1) * IU*k1z * (-Einc_x + Eref_x)
        H2(:, 2) = 1d0/(IU*w*mu2) * IU*k2z * (-Etrs_x)

        ! z components
        E1(:, 3) = 1d0/(IU*w*ep1) * IU*k1y * (Hinc_x + Href_x)
        E2(:, 3) = 1d0/(IU*w*ep2) * IU*k2y * (Htrs_x)
        H1(:, 3) = -1d0/(IU*w*mu1) * IU*k1y * (Einc_x + Eref_x)
        H2(:, 3) = -1d0/(IU*w*mu2) * IU*k2y * (Etrs_x)

        ! compute currents
        allocate(Msrc(msh%nbNod, 3))
        allocate(Jsrc(msh%nbNod, 3))
        Msrc = E1 - E2
        Jsrc = H1 - H2
    end subroutine

end module


! Subroutine RCOLUM

! This software is part of the GLOW model.  Use is governed by the Open Source
! Academic Research License Agreement contained in the file glowlicense.txt.
! For more information see the file glow.txt.

! Stan Solomon, 1988, 1991
! Stan Solomon, 2016: removed problematic extrapolation below lower
! boundary.  If grazing height is below lower boundary of atmosphere
! supplied, column density is set to 1.0e30.
! Stan Solomon, 2016: refactored for f90.
! Stan Solomon, 2017: corrected chi to pi-chi at line 79.  Note this has no effect.

! Calculates the column density ZCOL for each species ZMAJ above height
! ZZ at zenith angle CHI.  Calls subroutine VCD to calculate the
! vertical column density, and then uses a fit to the Chapman Grazing
! Incidence Integral [Smith and Smith, JGR 77, 3592, 1972] to calculate
! the slant column density.  If CHI is less than 90 degrees, column
! densities are calculated directly; if CHI is greater than 90 degrees
! the column density at grazing height for 90 degrees is calculated and
! doubled, and the column density above ZZ(J) is subtracted.  If the
! grazing height is lower than the bottom of the atmosphere supplied,
! column densities are set to 'infinity', i.e., 1.0e30.

    subroutine rcolum (chi, zz, zmaj, tn, zcol, zvcd, jmax, nmaj)

      implicit none

      integer,intent(in) :: jmax, nmaj
      real,intent(in) :: chi, zz(jmax), zmaj(nmaj,jmax), tn(jmax)
      real,intent(out) :: zcol(nmaj,jmax), zvcd(nmaj,jmax)

      integer,parameter :: nm=3
      real,parameter :: pi=3.1415926536
      real,parameter :: re=6.37e8

      integer :: i, j, k
      real :: zcg(nm), ghrg, ghz, tng
      real,external :: chap

      call vcd (zz, zmaj, zvcd, jmax, nmaj)

      if (chi >= 2.) then
        do i=1,nmaj
          do j=1,jmax
            zcol(i,j) = 1.0e30
          enddo
        enddo
        return
      endif

      if (chi <= pi/2.) then
        do i=1,nmaj
          do j=1,jmax
            zcol(i,j) = zvcd(i,j) * chap(chi,zz(j),tn(j),i)
          enddo
        enddo
      else
        do j=1,jmax
          ghrg=(re+zz(j))*sin(chi)
          ghz=ghrg-re
          if (ghz <= zz(1)) then
            do i=1,nmaj
              zcol(i,j) = 1.0e30
            enddo
          else
            do k=1,j-1
              if (zz(k) <= ghz .and. zz(k+1) > ghz) then
                tng = tn(k)+(tn(k+1)-tn(k))*(ghz-zz(k))/(zz(k+1)-zz(k))
                do i=1,nmaj
                  zcg(i) = zvcd(i,k) * (zvcd(i,k+1) / zvcd(i,k)) ** &
                           ((ghz-zz(k)) / (zz(k+1)-zz(k)))
                enddo
              endif
            enddo
            do i=1,nmaj
              zcol(i,j) = 2. * zcg(i) * chap(pi/2.,ghz,tng,i) &
                        - zvcd(i,j) * chap(pi-chi,zz(j),tn(j),i)
            enddo
          endif
        enddo
      endif

      return

    end subroutine rcolum

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

    real function chap (chi, z, t, i)

      implicit none

      real,intent(in) :: chi, z, t
      integer,intent(in) :: i

      integer,parameter ::  nmaj=3
      real,parameter :: pi=3.1415926536
      real,parameter :: re=6.37e8
      real,parameter :: g=978.1

      real :: am(nmaj), gr, hn, hg, hf, sqhf
      real,external :: sperfc

      data am/16., 32., 28./

      gr=g*(re/(re+z))**2
      hn=1.38e-16*t/(am(i)*1.662e-24*gr)
      hg=(re+z)/hn
      hf=0.5*hg*(cos(chi)**2)
      sqhf=sqrt(hf)
      chap=sqrt(0.5*pi*hg)*sperfc(sqhf)

      return

    end function chap

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

    real function sperfc(dummy)

      implicit none

      real,intent(in) :: dummy

      if (dummy <= 8.) then
        sperfc = (1.0606963+0.55643831*dummy) / &
                 (1.0619896+1.7245609*dummy+dummy*dummy)
      else
        sperfc=0.56498823/(0.06651874+dummy)
      endif

      return

    end function sperfc

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

    subroutine vcd(zz,zmaj,zvcd,jmax,nmaj)

      implicit none

      integer,intent(in) :: jmax,nmaj
      real,intent(in) :: zz(jmax), zmaj(nmaj,jmax)

      real,intent(out) :: zvcd(nmaj,jmax)

      integer :: i, j
      real :: rat

      do i=1,nmaj
        zvcd(i,jmax) =   zmaj(i,jmax) &
                       * (zz(jmax)-zz(jmax-1)) &
                       / alog(zmaj(i,jmax-1)/zmaj(i,jmax))
        do j=jmax-1,1,-1
          rat = zmaj(i,j+1) / zmaj(i,j)
          zvcd(i,j) = zvcd(i,j+1)+zmaj(i,j)*(zz(j)-zz(j+1))/alog(rat)*(1.-rat)
        enddo
      enddo

      return

    end subroutine vcd


module material_rates_m

	use datatypes,	only: interactions
	use globvar, 	only: ntotal_loc,nvirt_loc,nhalo_loc
	use param, 		only: mass,dim,f

	public:: art_visc,ext_force,int_force,con_density

contains

	!=================================================================================
	subroutine art_visc(ki,pair,ardvxdt)

		use param, only: alpha,beta,etq,hsml,c

		implicit none
		integer,intent(in):: ki
		type(interactions),intent(in):: pair
		real(f),intent(inout):: ardvxdt(dim,ntotal_loc+nvirt_loc+nhalo_loc)
		real(f):: dx(dim),piv(dim),muv,vr,rr,h,mrho

		dx(:) = pair%i%x(:) - pair%j%x(:)
		vr = MIN(0d0,DOT_PRODUCT(pair%i%vx(:) - pair%j%vx(:),dx(:)))

		!Artificial viscous force only if v_ij * r_ij < 0
		rr = DOT_PRODUCT(dx(:),dx(:))
		muv  = hsml*vr/(rr + hsml*hsml*etq*etq)
		mrho = 0.5d0*(pair%i%rho + pair%j%rho)
		piv  = (beta*muv - alpha*c)*muv/mrho*pair%dwdx(:)

		ardvxdt(:,pair%i%indloc) = ardvxdt(:,pair%i%indloc) - mass*piv(:)
		ardvxdt(:,pair%j%indloc) = ardvxdt(:,pair%j%indloc) + mass*piv(:)

	end subroutine art_visc

	!=================================================================================
	subroutine ext_force(ki,pair,exdvxdt)

		use param, only: p1,p2,rr0,dd

		implicit none
		integer,intent(in):: ki
		type(interactions),intent(in):: pair
		real(f),intent(inout):: exdvxdt(dim,ntotal_loc+nvirt_loc+nhalo_loc)
		real(f):: dx(dim),rr,f

		dx(:) = pair%i%x(:) - pair%j%x(:)
		rr = SQRT(SUM(dx(:)*dx(:)))

		if (rr.lt.rr0) then
			f = ((rr0/rr)**p1-(rr0/rr)**p2)/rr**2
			exdvxdt(:,pair%i%indloc) = exdvxdt(:,pair%i%indloc) + dd*dx(:)*f
			exdvxdt(:,pair%j%indloc) = exdvxdt(:,pair%j%indloc) - dd*dx(:)*f
		endif

	end subroutine ext_force

	!=================================================================================
	subroutine int_force(ki,pair,indvxdt)

		implicit none
		integer,intent(in):: ki
		type(interactions),intent(in):: pair
		real(f),intent(inout):: indvxdt(dim,ntotal_loc+nvirt_loc+nhalo_loc)
		real(f):: h(dim)

		h = -(pair%i%p/pair%i%rho**2 + pair%j%p/pair%j%rho**2)*pair%dwdx(:)
		indvxdt(:,pair%i%indloc) = indvxdt(:,pair%i%indloc) + mass*h(:)
		indvxdt(:,pair%j%indloc) = indvxdt(:,pair%j%indloc) - mass*h(:)

	end subroutine int_force

	!=================================================================================
	subroutine con_density(ki,pair,codrhodt)

		implicit none
		integer,intent(in):: ki
		type(interactions),intent(in):: pair
		real(f),intent(inout):: codrhodt(ntotal_loc+nvirt_loc+nhalo_loc)
		real(f):: dvx(dim),vcc

		dvx(:) = pair%i%vx(:) - pair%j%vx(:)

		vcc = DOT_PRODUCT(dvx(:),pair%dwdx(:))

		codrhodt(pair%i%indloc) = codrhodt(pair%i%indloc) + mass*vcc
		codrhodt(pair%j%indloc) = codrhodt(pair%j%indloc) + mass*vcc

	end subroutine con_density

end module material_rates_m


module data_type
  implicit none
  !=========================================================
  !
  !                        Array
  !
  !---------------------------------------------------------
  ! Bool type arrays
  !---------------------------------------------------------
  type :: bvector_t
    logical,dimension(:),allocatable :: p
    integer :: d
  end type bvector_t

  type :: bmatrix_t
    logical,dimension(:,:),allocatable :: p
    integer :: d(2)
  end type bmatrix_t

  type :: btensor_t
    logical,dimension(:,:,:),allocatable :: p
    integer :: d(3)
  end type btensor_t

  !---------------------------------------------------------
  ! Integer type arrays
  !---------------------------------------------------------
  type :: ivector_t
    integer,dimension(:),allocatable :: p
    integer :: d
  end type ivector_t

  type :: imatrix_t
    integer,dimension(:,:),allocatable :: p
    integer :: d(2)
  end type imatrix_t

  type :: itensor_t
    integer,dimension(:,:,:),allocatable :: p
    integer :: d(3)
  end type itensor_t

  !---------------------------------------------------------
  ! Real type arrays
  !---------------------------------------------------------
  type :: rvector_t
    double precision,dimension(:),allocatable :: p
    integer :: d
  end type

  type :: rmatrix_t
    double precision,dimension(:,:),allocatable :: p
    integer,dimension(2) :: d
  end type

  type :: rtensor_t
    double precision,dimension(:,:,:),allocatable :: p
    integer,dimension(3) :: d
  end type
  !---------------------------------------------------------
  !
  !                        End of Array
  !
  !=========================================================

  !=========================================================
  !
  !                       Field shape
  !
  !---------------------------------------------------------
  type :: fscalarshape_t
    integer,dimension(2) :: d
  end type

  type :: fvectorshape_t
    integer,dimension(3) :: d
  end type

  type :: fmatrixshape_t
    integer,dimension(4) :: d
  end type

  type :: ftensorshape_t
    integer,dimension(5) :: d
  end type
  !---------------------------------------------------------
  !
  !                   End of Field shape
  !
  !=========================================================

  !=========================================================
  !
  !                        Field
  !
  !---------------------------------------------------------
  ! Bool type field
  !---------------------------------------------------------
  type :: bscalarfield_t
    logical,dimension(:,:),allocatable :: p
    type(fscalarshape_t) :: s
  end type

  type :: bvectorfield_t
    logical,dimension(:,:,:),allocatable :: p
    type(fvectorshape_t) :: s
  end type

  type :: bmatrixfield_t
    logical,dimension(:,:,:,:),allocatable :: p
    type(fmatrixshape_t) :: s
  end type

  type :: btensorfield_t
    logical,dimension(:,:,:,:,:),allocatable :: p
    type(ftensorshape_t) :: s
  end type

  !---------------------------------------------------------
  ! Integeer type field
  !---------------------------------------------------------
  type :: iscalarfield_t
    integer,dimension(:,:),allocatable :: p
    type(fscalarshape_t) :: s
  end type

  type :: ivectorfield_t
    integer,dimension(:,:,:),allocatable :: p
    type(fvectorshape_t) :: s
  end type

  type :: imatrixfield_t
    integer,dimension(:,:,:,:),allocatable :: p
    type(fmatrixshape_t) :: s
  end type

  type :: itensorfield_t
    integer,dimension(:,:,:,:,:),allocatable :: p
    type(ftensorshape_t) :: s
  end type

  !---------------------------------------------------------
  ! Real type field
  !---------------------------------------------------------
  type :: rscalarfield_t
    double precision,dimension(:,:),allocatable :: p
    type(fscalarshape_t) :: s
  end type

  type :: rvectorfield_t
    double precision,dimension(:,:,:),allocatable :: p
    type(fvectorshape_t) :: s
  end type

  type :: rmatrixfield_t
    double precision,dimension(:,:,:,:),allocatable :: p
    type(fmatrixshape_t) :: s
  end type

  type :: rtensorfield_t
    double precision,dimension(:,:,:,:,:),allocatable :: p
    type(ftensorshape_t) :: s
  end type
  !---------------------------------------------------------
  !
  !                       End of Field
  !
  !=========================================================

  !=========================================================
  !
  !                       Field shape
  !
  !---------------------------------------------------------
  type :: ascalarshape_t
    integer :: d
  end type

  type :: avectorshape_t
    integer,dimension(2) :: d
  end type

  type :: amatrixshape_t
    integer,dimension(3) :: d
  end type

  type :: atensorshape_t
    integer,dimension(4) :: d
  end type
  !---------------------------------------------------------
  !
  !                   End of Field shape
  !
  !=========================================================

  !=========================================================
  !
  !                        array
  !
  !---------------------------------------------------------
  ! Bool type array
  !---------------------------------------------------------
  type :: bscalararray_t
    logical,dimension(:),allocatable :: p
    type(ascalarshape_t) :: s
  end type

  type :: bvectorarray_t
    logical,dimension(:,:),allocatable :: p
    type(avectorshape_t) :: s
  end type

  type :: bmatrixarray_t
    logical,dimension(:,:,:),allocatable :: p
    type(amatrixshape_t) :: s
  end type

  type :: btensorarray_t
    logical,dimension(:,:,:,:),allocatable :: p
    type(atensorshape_t) :: s
  end type

  !---------------------------------------------------------
  ! Integeer type array
  !---------------------------------------------------------
  type :: iscalararray_t
    integer,dimension(:),allocatable :: p
    type(ascalarshape_t) :: s
  end type

  type :: ivectorarray_t
    integer,dimension(:,:),allocatable :: p
    type(avectorshape_t) :: s
  end type

  type :: imatrixarray_t
    integer,dimension(:,:,:),allocatable :: p
    type(amatrixshape_t) :: s
  end type

  type :: itensorarray_t
    integer,dimension(:,:,:,:),allocatable :: p
    type(atensorshape_t) :: s
  end type

  !---------------------------------------------------------
  ! Real type array
  !---------------------------------------------------------
  type :: rscalararray_t
    double precision,dimension(:),allocatable :: p
    type(ascalarshape_t) :: s
  end type

  type :: rvectorarray_t
    double precision,dimension(:,:),allocatable :: p
    type(avectorshape_t) :: s
  end type

  type :: rmatrixarray_t
    double precision,dimension(:,:,:),allocatable :: p
    type(amatrixshape_t) :: s
  end type

  type :: rtensorarray_t
    double precision,dimension(:,:,:,:),allocatable :: p
    type(atensorshape_t) :: s
  end type
  !---------------------------------------------------------
  !
  !                       End of Field
  !
  !=========================================================

  interface create
    module procedure create_bvector
    module procedure create_bmatrix
    module procedure create_btensor
    module procedure create_ivector
    module procedure create_imatrix
    module procedure create_itensor
    module procedure create_rvector
    module procedure create_rmatrix
    module procedure create_rtensor
    module procedure create_bscalarfield
    module procedure create_bvectorfield
    module procedure create_bmatrixfield
    module procedure create_btensorfield
    module procedure create_iscalarfield
    module procedure create_ivectorfield
    module procedure create_imatrixfield
    module procedure create_itensorfield
    module procedure create_rscalarfield
    module procedure create_rvectorfield
    module procedure create_rmatrixfield
    module procedure create_rtensorfield
  end interface create

  interface destroy
    module procedure destroy_bvector
    module procedure destroy_bmatrix
    module procedure destroy_btensor
    module procedure destroy_ivector
    module procedure destroy_imatrix
    module procedure destroy_itensor
    module procedure destroy_rvector
    module procedure destroy_rmatrix
    module procedure destroy_rtensor
    module procedure destroy_bscalarfield
    module procedure destroy_bvectorfield
    module procedure destroy_bmatrixfield
    module procedure destroy_btensorfield
    module procedure destroy_iscalarfield
    module procedure destroy_ivectorfield
    module procedure destroy_imatrixfield
    module procedure destroy_itensorfield
    module procedure destroy_rscalarfield
    module procedure destroy_rvectorfield
    module procedure destroy_rmatrixfield
    module procedure destroy_rtensorfield
  end interface destroy

  interface assignment (=)
    module procedure fscalarshape_to_fscalarshape
    module procedure fvectorshape_to_fvectorshape
    module procedure fmatrixshape_to_fmatrixshape
    module procedure ftensorshape_to_ftensorshape
    module procedure bvector_to_bvector
    module procedure bmatrix_to_bmatrix
    module procedure btensor_to_btensor
    module procedure ivector_to_ivector
    module procedure imatrix_to_imatrix
    module procedure itensor_to_itensor
    module procedure rvector_to_rvector
    module procedure rmatrix_to_rmatrix
    module procedure rtensor_to_rtensor
    module procedure bscalarfield_to_bscalar
    module procedure bvectorfield_to_bvector
    module procedure bmatrixfield_to_bmatrix
    module procedure btensorfield_to_btensor
    module procedure iscalarfield_to_iscalar
    module procedure ivectorfield_to_ivector
    module procedure imatrixfield_to_imatrix
    module procedure itensorfield_to_itensor
    module procedure rscalarfield_to_rscalar
    module procedure rvectorfield_to_rvector
    module procedure rmatrixfield_to_rmatrix
    module procedure rtensorfield_to_rtensor
    module procedure bscalarfield_to_bscalarfield
    module procedure bvectorfield_to_bvectorfield
    module procedure bmatrixfield_to_bmatrixfield
    module procedure btensorfield_to_btensorfield
    module procedure iscalarfield_to_iscalarfield
    module procedure ivectorfield_to_ivectorfield
    module procedure imatrixfield_to_imatrixfield
    module procedure itensorfield_to_itensorfield
    module procedure rscalarfield_to_rscalarfield
    module procedure rvectorfield_to_rvectorfield
    module procedure rmatrixfield_to_rmatrixfield
    module procedure rtensorfield_to_rtensorfield
  end interface

  interface operator (.eq.)
    module procedure fscalarshape_eq_fscalarshape
    module procedure fvectorshape_eq_fvectorshape
    module procedure fmatrixshape_eq_fmatrixshape
    module procedure ftensorshape_eq_ftensorshape
  end interface

  interface set_shape
    module procedure set_fscalarshape
    module procedure set_fvectorshape
    module procedure set_fmatrixshape
    module procedure set_ftensorshape
  end interface

  integer,parameter :: bias_upwind   = 0
  integer,parameter :: bias_downwind = 1
  integer,parameter :: axis_xi  = 0
  integer,parameter :: axis_eta = 1

contains
subroutine create_bvector(bvector,dimn)
  implicit none
  integer,intent(in) :: dimn
  type(bvector_t),intent(inout) :: bvector
  if(dimn.ne.0) then
    bvector%d = dimn
  else
    write(*,*) "create_bvector() error:"
    write(*,*) "Zero allocation size:",dimn
    stop
  endif

  if(.not.allocated(bvector%p)) then
    allocate(bvector%p(bvector%d))
  else
    write(*,*) "create_bvector() error:"
    write(*,*) "rbvector_t has been allocated"
    stop
  endif
end subroutine create_bvector

subroutine create_bmatrix(bmatrix,dimm,dimn)
  implicit none
  integer,intent(in) :: dimm,dimn
  type(bmatrix_t),intent(inout) :: bmatrix
  if((dimm.ne.0).and. &
     (dimn.ne.0)) then
      bmatrix%d(1) = dimm
      bmatrix%d(2) = dimn
  else
    write(*,*) "create_bmatrix() error:"
    write(*,*) "Zero allocation size:",dimm,dimn
    stop
  endif

  if(.not.allocated(bmatrix%p)) then
    allocate(bmatrix%p(bmatrix%d(1),bmatrix%d(2)))
  else
    write(*,*) "create_bmatrix() error:"
    write(*,*) "bmatrix_t has been allocated"
    stop
  endif
end subroutine create_bmatrix

subroutine create_btensor(btensor,diml,dimm,dimn)
  implicit none
  integer,intent(in) :: diml,dimm,dimn
  type(btensor_t),intent(inout) :: btensor
  if((diml.ne.0).and. &
     (dimm.ne.0).and. &
     (dimn.ne.0)) then
      btensor%d(1) = diml
      btensor%d(2) = dimm
      btensor%d(3) = dimn
  else
    write(*,*) "create_btensor() error:"
    write(*,*) "Zero allocation size:",diml,dimm,dimn
    stop
  endif

  if(.not.allocated(btensor%p)) then
    allocate(btensor%p(btensor%d(1),btensor%d(2),btensor%d(3)))
  else
    write(*,*) "create_btensor() error:"
    write(*,*) "rbtensor_t has been allocated"
    stop
  endif
end subroutine create_btensor

subroutine create_ivector(ivector,dimn)
  implicit none
  integer,intent(in) :: dimn
  type(ivector_t),intent(inout) :: ivector
  if(dimn.ne.0) then
    ivector%d = dimn
  else
    write(*,*) "create_ivector() error:"
    write(*,*) "Zero allocation size:",dimn
    stop
  endif

  if(.not.allocated(ivector%p)) then
    allocate(ivector%p(ivector%d))
  else
    write(*,*) "create_ivector() error:"
    write(*,*) "ivector_t has been allocated"
    stop
  endif
end subroutine create_ivector

subroutine create_imatrix(imatrix,dimm,dimn)
  implicit none
  integer,intent(in) :: dimm,dimn
  type(imatrix_t),intent(inout) :: imatrix
  if((dimm.ne.0).and. &
     (dimn.ne.0)) then
      imatrix%d(1) = dimm
      imatrix%d(2) = dimn
  else
    write(*,*) "create_imatrix() error:"
    write(*,*) "Zero allocation size:",dimm,dimn
    stop
  endif

  if(.not.allocated(imatrix%p)) then
    allocate(imatrix%p(imatrix%d(1),imatrix%d(2)))
  else
    write(*,*) "create_imatrix() error:"
    write(*,*) "imatrix_t has been allocated"
    stop
  endif
end subroutine create_imatrix

subroutine create_itensor(itensor,diml,dimm,dimn)
  implicit none
  integer,intent(in) :: diml,dimm,dimn
  type(itensor_t),intent(inout) :: itensor
  if((diml.ne.0).and. &
     (dimm.ne.0).and. &
     (dimn.ne.0)) then
      itensor%d(1) = diml
      itensor%d(2) = dimm
      itensor%d(3) = dimn
  else
    write(*,*) "create_itensor() error:"
    write(*,*) "Zero allocation size:",diml,dimm,dimn
    stop
  endif

  if(.not.allocated(itensor%p)) then
    allocate(itensor%p(itensor%d(1),itensor%d(2),itensor%d(3)))
  else
    write(*,*) "create_itensor() error:"
    write(*,*) "itensor_t has been allocated"
    stop
  endif
end subroutine create_itensor

subroutine create_rvector(rvector,dimn)
  implicit none
  integer,intent(in) :: dimn
  type(rvector_t),intent(inout) :: rvector
  if(dimn.ne.0) then
    rvector%d = dimn
  else
    write(*,*) "create_rvector() error:"
    write(*,*) "Zero allocation size:",dimn
    stop
  endif

  if(.not.allocated(rvector%p)) then
    allocate(rvector%p(rvector%d))
  else
    write(*,*) "create_rvector() error:"
    write(*,*) "rvector_t has been allocated"
    stop
  endif
end subroutine create_rvector

subroutine create_rmatrix(rmatrix,dimm,dimn)
  implicit none
  integer,intent(in) :: dimm,dimn
  type(rmatrix_t),intent(inout) :: rmatrix
  if((dimm.ne.0).and. &
     (dimn.ne.0)) then
      rmatrix%d(1) = dimm
      rmatrix%d(2) = dimn
  else
    write(*,*) "create_rmatrix() error:"
    write(*,*) "Zero allocation size:",dimm,dimn
    stop
  endif

  if(.not.allocated(rmatrix%p)) then
    allocate(rmatrix%p(rmatrix%d(1),rmatrix%d(2)))
  else
    write(*,*) "create_rmatrix() error:"
    write(*,*) "rmatrix_t has been allocated"
    stop
  endif
end subroutine create_rmatrix

subroutine create_rtensor(rtensor,diml,dimm,dimn)
  implicit none
  integer,intent(in) :: diml,dimm,dimn
  type(rtensor_t),intent(inout) :: rtensor
  if((diml.ne.0).and. &
     (dimm.ne.0).and. &
     (dimn.ne.0)) then
      rtensor%d(1) = diml
      rtensor%d(2) = dimm
      rtensor%d(3) = dimn
  else
    write(*,*) "create_rtensor() error:"
    write(*,*) "Zero allocation size:",diml,dimm,dimn
    stop
  endif

  if(.not.allocated(rtensor%p)) then
    allocate(rtensor%p(rtensor%d(1),rtensor%d(2),rtensor%d(3)))
  else
    write(*,*) "create_rtensor() error:"
    write(*,*) "rtensor_t has been allocated"
    stop
  endif
end subroutine create_rtensor

subroutine destroy_bvector(bvector)
  implicit none
  type(bvector_t),intent(inout) :: bvector
  if(allocated(bvector%p)) then
    deallocate(bvector%p)
  endif
end subroutine destroy_bvector

subroutine destroy_bmatrix(bmatrix)
  implicit none
  type(bmatrix_t),intent(inout) :: bmatrix
  if(allocated(bmatrix%p)) then
    deallocate(bmatrix%p)
  endif
end subroutine destroy_bmatrix

subroutine destroy_btensor(btensor)
  implicit none
  type(btensor_t),intent(inout) :: btensor
  if(allocated(btensor%p)) then
    deallocate(btensor%p)
  endif
end subroutine destroy_btensor

subroutine destroy_ivector(ivector)
  implicit none
  type(ivector_t),intent(inout) :: ivector
  if(allocated(ivector%p)) then
    deallocate(ivector%p)
  endif
end subroutine destroy_ivector

subroutine destroy_imatrix(imatrix)
  implicit none
  type(imatrix_t),intent(inout) :: imatrix
  if(allocated(imatrix%p)) then
    deallocate(imatrix%p)
  endif
end subroutine destroy_imatrix

subroutine destroy_itensor(itensor)
  implicit none
  type(itensor_t),intent(inout) :: itensor
  if(allocated(itensor%p)) then
    deallocate(itensor%p)
  endif
end subroutine destroy_itensor

subroutine destroy_rvector(rvector)
  implicit none
  type(rvector_t),intent(inout) :: rvector
  if(allocated(rvector%p)) then
    deallocate(rvector%p)
  endif
end subroutine destroy_rvector

subroutine destroy_rmatrix(rmatrix)
  implicit none
  type(rmatrix_t),intent(inout) :: rmatrix
  if(allocated(rmatrix%p)) then
    deallocate(rmatrix%p)
  endif
end subroutine destroy_rmatrix

subroutine destroy_rtensor(rtensor)
  implicit none
  type(rtensor_t),intent(inout) :: rtensor
  if(allocated(rtensor%p)) then
    deallocate(rtensor%p)
  endif
end subroutine destroy_rtensor

subroutine create_bscalarfield(bfield,s)
  implicit none
  type(fscalarshape_t),intent(in) :: s
  type(bscalarfield_t),intent(inout) :: bfield
  integer :: err
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0)) then
    bfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(bfield%p)) then
    allocate(bfield%p(s%d(1),s%d(2)),stat = err)
    if(err.ne.0) write(*,*) "Scalarfield allocation failed."
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_bscalarfield

subroutine create_bvectorfield(bfield,s)
  implicit none
  type(fvectorshape_t),intent(in) :: s
  type(bvectorfield_t),intent(inout) :: bfield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0)) then
    bfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(bfield%p)) then
    allocate(bfield%p(s%d(1),s%d(2),s%d(3)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_bvectorfield

subroutine create_bmatrixfield(bfield,s)
  implicit none
  type(fmatrixshape_t),intent(in) :: s
  type(bmatrixfield_t),intent(inout) :: bfield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0).and. &
      (s%d(4).ne.0)) then
    bfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(bfield%p)) then
    allocate(bfield%p(s%d(1),s%d(2),s%d(3),s%d(4)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_bmatrixfield

subroutine create_btensorfield(bfield,s)
  implicit none
  type(ftensorshape_t),intent(in) :: s
  type(btensorfield_t),intent(inout) :: bfield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0).and. &
      (s%d(4).ne.0).and. &
      (s%d(5).ne.0)) then
    bfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(bfield%p)) then
    allocate(bfield%p(s%d(1),s%d(2),s%d(3),s%d(4),s%d(5)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_btensorfield

subroutine create_iscalarfield(ifield,s)
  implicit none
  type(fscalarshape_t),intent(in) :: s
  type(iscalarfield_t),intent(inout) :: ifield
  integer :: err
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0)) then
    ifield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(ifield%p)) then
    allocate(ifield%p(s%d(1),s%d(2)),stat = err)
    if(err.ne.0) write(*,*) "Scalarfield allocation failed."
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_iscalarfield

subroutine create_ivectorfield(ifield,s)
  implicit none
  type(fvectorshape_t),intent(in) :: s
  type(ivectorfield_t),intent(inout) :: ifield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0)) then
    ifield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(ifield%p)) then
    allocate(ifield%p(s%d(1),s%d(2),s%d(3)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_ivectorfield

subroutine create_imatrixfield(ifield,s)
  implicit none
  type(fmatrixshape_t),intent(in) :: s
  type(imatrixfield_t),intent(inout) :: ifield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0).and. &
      (s%d(4).ne.0)) then
    ifield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(ifield%p)) then
    allocate(ifield%p(s%d(1),s%d(2),s%d(3),s%d(4)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_imatrixfield

subroutine create_itensorfield(ifield,s)
  implicit none
  type(ftensorshape_t),intent(in) :: s
  type(itensorfield_t),intent(inout) :: ifield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0).and. &
      (s%d(4).ne.0).and. &
      (s%d(5).ne.0)) then
    ifield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(ifield%p)) then
    allocate(ifield%p(s%d(1),s%d(2),s%d(3),s%d(4),s%d(5)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_itensorfield

subroutine create_rscalarfield(rfield,s)
  implicit none
  type(fscalarshape_t),intent(in) :: s
  type(rscalarfield_t),intent(inout) :: rfield
  integer :: err
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0)) then
    rfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(rfield%p)) then
    allocate(rfield%p(s%d(1),s%d(2)),stat = err)
    if(err.ne.0) write(*,*) "Scalarfield allocation failed."
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_rscalarfield

subroutine create_rvectorfield(rfield,s)
  implicit none
  type(fvectorshape_t),intent(in) :: s
  type(rvectorfield_t),intent(inout) :: rfield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0)) then
    rfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(rfield%p)) then
    allocate(rfield%p(s%d(1),s%d(2),s%d(3)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_rvectorfield

subroutine create_rmatrixfield(rfield,s)
  implicit none
  type(fmatrixshape_t),intent(in) :: s
  type(rmatrixfield_t),intent(inout) :: rfield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0).and. &
      (s%d(4).ne.0)) then
    rfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(rfield%p)) then
    allocate(rfield%p(s%d(1),s%d(2),s%d(3),s%d(4)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_rmatrixfield

subroutine create_rtensorfield(rfield,s)
  implicit none
  type(ftensorshape_t),intent(in) :: s
  type(rtensorfield_t),intent(inout) :: rfield
  if((s%d(1).ne.0).and. &
      (s%d(2).ne.0).and. &
      (s%d(3).ne.0).and. &
      (s%d(4).ne.0).and. &
      (s%d(5).ne.0)) then
    rfield%s = s
  else
    write(*,*) "Allocation error:"
    write(*,*) "Zero allocation size:",s%d(:)
    stop
  endif

  if(.not.allocated(rfield%p)) then
    allocate(rfield%p(s%d(1),s%d(2),s%d(3),s%d(4),s%d(5)))
  else
    write(*,*) "Allocation error:"
    write(*,*) "Field has been allocated"
    stop
  endif
end subroutine create_rtensorfield

subroutine destroy_bscalarfield(bfield)
  implicit none
  type(bscalarfield_t),intent(inout) :: bfield
  if(allocated(bfield%p)) then
    deallocate(bfield%p)
  endif
end subroutine destroy_bscalarfield

subroutine destroy_bvectorfield(bfield)
  implicit none
  type(bvectorfield_t),intent(inout) :: bfield
  if(allocated(bfield%p)) then
    deallocate(bfield%p)
  endif
end subroutine destroy_bvectorfield

subroutine destroy_bmatrixfield(bfield)
  implicit none
  type(bmatrixfield_t),intent(inout) :: bfield
  if(allocated(bfield%p)) then
    deallocate(bfield%p)
  endif
end subroutine destroy_bmatrixfield

subroutine destroy_btensorfield(bfield)
  implicit none
  type(btensorfield_t),intent(inout) :: bfield
  if(allocated(bfield%p)) then
    deallocate(bfield%p)
  endif
end subroutine destroy_btensorfield

subroutine destroy_iscalarfield(ifield)
  implicit none
  type(iscalarfield_t),intent(inout) :: ifield
  if(allocated(ifield%p)) then
    deallocate(ifield%p)
  endif
end subroutine destroy_iscalarfield

subroutine destroy_ivectorfield(ifield)
  implicit none
  type(ivectorfield_t),intent(inout) :: ifield
  if(allocated(ifield%p)) then
    deallocate(ifield%p)
  endif
end subroutine destroy_ivectorfield

subroutine destroy_imatrixfield(ifield)
  implicit none
  type(imatrixfield_t),intent(inout) :: ifield
  if(allocated(ifield%p)) then
    deallocate(ifield%p)
  endif
end subroutine destroy_imatrixfield

subroutine destroy_itensorfield(ifield)
  implicit none
  type(itensorfield_t),intent(inout) :: ifield
  if(allocated(ifield%p)) then
    deallocate(ifield%p)
  endif
end subroutine destroy_itensorfield

subroutine destroy_rscalarfield(rfield)
  implicit none
  type(rscalarfield_t),intent(inout) :: rfield
  if(allocated(rfield%p)) then
    deallocate(rfield%p)
  endif
end subroutine destroy_rscalarfield

subroutine destroy_rvectorfield(rfield)
  implicit none
  type(rvectorfield_t),intent(inout) :: rfield
  if(allocated(rfield%p)) then
    deallocate(rfield%p)
  endif
end subroutine destroy_rvectorfield

subroutine destroy_rmatrixfield(rfield)
  implicit none
  type(rmatrixfield_t),intent(inout) :: rfield
  if(allocated(rfield%p)) then
    deallocate(rfield%p)
  endif
end subroutine destroy_rmatrixfield

subroutine destroy_rtensorfield(rfield)
  implicit none
  type(rtensorfield_t),intent(inout) :: rfield
  if(allocated(rfield%p)) then
    deallocate(rfield%p)
  endif
end subroutine destroy_rtensorfield

subroutine fscalarshape_to_fscalarshape(left,right)
  implicit none
  type(fscalarshape_t),intent(in) :: right
  type(fscalarshape_t),intent(inout) :: left
  left%d(:) = right%d(:)
end subroutine

subroutine fvectorshape_to_fvectorshape(left,right)
  implicit none
  type(fvectorshape_t),intent(in) :: right
  type(fvectorshape_t),intent(inout) :: left
  left%d(:) = right%d(:)
end subroutine

subroutine fmatrixshape_to_fmatrixshape(left,right)
  implicit none
  type(fmatrixshape_t),intent(in) :: right
  type(fmatrixshape_t),intent(inout) :: left
  left%d(:) = right%d(:)
end subroutine

subroutine ftensorshape_to_ftensorshape(left,right)
  implicit none
  type(ftensorshape_t),intent(in) :: right
  type(ftensorshape_t),intent(inout) :: left
  left%d(:) = right%d(:)
end subroutine

function fscalarshape_eq_fscalarshape(left,right)
  implicit none
  type(fscalarshape_t),intent(in) :: left,right
  logical :: fscalarshape_eq_fscalarshape
  if((left%d(1).eq.right%d(1)) .and. &
  (left%d(2).eq.right%d(2))) then
    fscalarshape_eq_fscalarshape = .true.
  else
    fscalarshape_eq_fscalarshape = .false.
  endif
end function

function fvectorshape_eq_fvectorshape(left,right)
  implicit none
  type(fvectorshape_t),intent(in) :: left,right
  logical :: fvectorshape_eq_fvectorshape
  if((left%d(1).eq.right%d(1)) .and. &
  (left%d(2).eq.right%d(2)) .and. &
  (left%d(3).eq.right%d(3))) then
    fvectorshape_eq_fvectorshape = .true.
  else
    fvectorshape_eq_fvectorshape = .false.
  endif
end function

function fmatrixshape_eq_fmatrixshape(left,right)
  implicit none
  type(fmatrixshape_t),intent(in) :: left,right
  logical :: fmatrixshape_eq_fmatrixshape
  if((left%d(1).eq.right%d(1)) .and. &
  (left%d(2).eq.right%d(2)) .and. &
  (left%d(3).eq.right%d(3)) .and. &
  (left%d(4).eq.right%d(4))) then
    fmatrixshape_eq_fmatrixshape = .true.
  else
    fmatrixshape_eq_fmatrixshape = .false.
  endif
end function

function ftensorshape_eq_ftensorshape(left,right)
  implicit none
  type(ftensorshape_t),intent(in) :: left,right
  logical :: ftensorshape_eq_ftensorshape
  if((left%d(1).eq.right%d(1)) .and. &
  (left%d(2).eq.right%d(2)) .and. &
  (left%d(3).eq.right%d(3)) .and. &
  (left%d(4).eq.right%d(4)) .and. &
  (left%d(5).eq.right%d(5))) then
    ftensorshape_eq_ftensorshape = .true.
  else
    ftensorshape_eq_ftensorshape = .false.
  endif
end function ftensorshape_eq_ftensorshape

function set_fscalarshape(dim1,dim2)
  implicit none
  integer,intent(in) :: dim1,dim2
  type(fscalarshape_t) :: set_fscalarshape
  set_fscalarshape%d(1) = dim1
  set_fscalarshape%d(2) = dim2
end function set_fscalarshape

function set_fvectorshape(dim1,dim2,dim3)
  implicit none
  integer,intent(in) :: dim1,dim2,dim3
  type(fvectorshape_t) :: set_fvectorshape
  set_fvectorshape%d(1) = dim1
  set_fvectorshape%d(2) = dim2
  set_fvectorshape%d(3) = dim3
end function set_fvectorshape

function set_fmatrixshape(dim1,dim2,dim3,dim4)
  implicit none
  integer,intent(in) :: dim1,dim2,dim3,dim4
  type(fmatrixshape_t) :: set_fmatrixshape
  set_fmatrixshape%d(1) = dim1
  set_fmatrixshape%d(2) = dim2
  set_fmatrixshape%d(3) = dim3
  set_fmatrixshape%d(4) = dim4
end function set_fmatrixshape

function set_ftensorshape(dim1,dim2,dim3,dim4,dim5)
  implicit none
  integer,intent(in) :: dim1,dim2,dim3,dim4,dim5
  type(ftensorshape_t) :: set_ftensorshape
  set_ftensorshape%d(1) = dim1
  set_ftensorshape%d(2) = dim2
  set_ftensorshape%d(3) = dim3
  set_ftensorshape%d(4) = dim4
  set_ftensorshape%d(5) = dim5
end function set_ftensorshape

subroutine bvector_to_bvector(left,right)
  implicit none
  type(bvector_t),intent(in) :: right
  type(bvector_t),intent(inout) :: left
  integer :: mindim
  integer :: i
  mindim = min(left%d,right%d)
  do i = 1, mindim
    left%p(:) = right%p(:)
  enddo
end subroutine

subroutine bmatrix_to_bmatrix(left,right)
  implicit none
  type(bmatrix_t),intent(in) :: right
  type(bmatrix_t),intent(inout) :: left
  integer :: mindimn,mindimm
  integer :: i,j
  mindimn = min(left%d(1),right%d(1))
  mindimm = min(left%d(2),right%d(2))
  do j = 1, mindimm
    do i = 1, mindimn
      left%p(i,j) = right%p(i,j)
    enddo
  enddo
end subroutine

subroutine btensor_to_btensor(left,right)
  implicit none
  type(btensor_t),intent(in) :: right
  type(btensor_t),intent(inout) :: left
  integer :: mindimn,mindimm,mindiml
  integer :: i,j,k
  mindimn = min(left%d(1),right%d(1))
  mindimm = min(left%d(2),right%d(2))
  mindiml = min(left%d(3),right%d(3))
  do k = 1, mindiml
    do j = 1, mindimm
      do i = 1, mindimn
        left%p(i,j,k) = right%p(i,j,k)
      enddo
    enddo
  enddo
end subroutine

subroutine ivector_to_ivector(left,right)
  implicit none
  type(ivector_t),intent(in) :: right
  type(ivector_t),intent(inout) :: left
  integer :: mindim
  integer :: i
  mindim = min(left%d,right%d)
  do i = 1, mindim
    left%p(:) = right%p(:)
  enddo
end subroutine

subroutine imatrix_to_imatrix(left,right)
  implicit none
  type(imatrix_t),intent(in) :: right
  type(imatrix_t),intent(inout) :: left
  integer :: mindimn,mindimm
  integer :: i,j
  mindimn = min(left%d(1),right%d(1))
  mindimm = min(left%d(2),right%d(2))
  do j = 1, mindimm
    do i = 1, mindimn
      left%p(i,j) = right%p(i,j)
    enddo
  enddo
end subroutine

subroutine itensor_to_itensor(left,right)
  implicit none
  type(itensor_t),intent(in) :: right
  type(itensor_t),intent(inout) :: left
  integer :: mindimn,mindimm,mindiml
  integer :: i,j,k
  mindimn = min(left%d(1),right%d(1))
  mindimm = min(left%d(2),right%d(2))
  mindiml = min(left%d(3),right%d(3))
  do k = 1, mindiml
    do j = 1, mindimm
      do i = 1, mindimn
        left%p(i,j,k) = right%p(i,j,k)
      enddo
    enddo
  enddo
end subroutine

subroutine rvector_to_rvector(left,right)
  implicit none
  type(rvector_t),intent(in) :: right
  type(rvector_t),intent(inout) :: left
  integer :: mindim
  integer :: i
  mindim = min(left%d,right%d)
  do i = 1, mindim
    left%p(:) = right%p(:)
  enddo
end subroutine

subroutine rmatrix_to_rmatrix(left,right)
  implicit none
  type(rmatrix_t),intent(in) :: right
  type(rmatrix_t),intent(inout) :: left
  integer :: mindimn,mindimm
  integer :: i,j
  mindimn = min(left%d(1),right%d(1))
  mindimm = min(left%d(2),right%d(2))
  do j = 1, mindimm
    do i = 1, mindimn
      left%p(i,j) = right%p(i,j)
    enddo
  enddo
end subroutine

subroutine rtensor_to_rtensor(left,right)
  implicit none
  type(rtensor_t),intent(in) :: right
  type(rtensor_t),intent(inout) :: left
  integer :: mindimn,mindimm,mindiml
  integer :: i,j,k
  mindimn = min(left%d(1),right%d(1))
  mindimm = min(left%d(2),right%d(2))
  mindiml = min(left%d(3),right%d(3))
  do k = 1, mindiml
    do j = 1, mindimm
      do i = 1, mindimn
        left%p(i,j,k) = right%p(i,j,k)
      enddo
    enddo
  enddo
end subroutine

subroutine bscalarfield_to_bscalar(scalarfield,scalar)
  implicit none
  logical,intent(in) :: scalar
  type(bscalarfield_t),intent(inout) :: scalarfield
  integer :: i,j
  do j = 1, scalarfield%s%d(2)
    do i = 1, scalarfield%s%d(1)
      scalarfield%p(i,j) = scalar
    enddo
  enddo
end subroutine

subroutine bvectorfield_to_bvector(vectorfield,vector)
  implicit none
  type(bvector_t),intent(in) :: vector
  type(bvectorfield_t),intent(inout) :: vectorfield
  integer :: i,j
  if(vectorfield%s%d(1).eq.vector%d) then
    do j = 1, vectorfield%s%d(3)
      do i = 1, vectorfield%s%d(2)
        vectorfield%p(:,i,j) = vector%p(:)
      enddo
    enddo
  else
    write(*,*) "operator vectorfield_to_vector error:"
    write(*,*) "Unequal rank size:",vectorfield%s%d(1),vector%d
  endif
end subroutine

subroutine bmatrixfield_to_bmatrix(matrixfield,matrix)
  implicit none
  type(bmatrix_t),intent(in) :: matrix
  type(bmatrixfield_t),intent(inout) :: matrixfield
  integer :: i,j
  if((matrixfield%s%d(1).eq.matrix%d(1)).or. &
      (matrixfield%s%d(2).eq.matrix%d(2))) then
    do j = 1, matrixfield%s%d(4)
      do i = 1, matrixfield%s%d(3)
        matrixfield%p(:,:,i,j) = matrix%p(:,:)
      enddo
    enddo
  else
    write(*,*) "operator matrixfield_to_matrix error:"
    write(*,*) "Unequal rank size:",matrixfield%s%d(1:2),matrix%d
  endif
end subroutine

subroutine btensorfield_to_btensor(tensorfield,tensor)
  implicit none
  type(btensor_t),intent(in) :: tensor
  type(btensorfield_t),intent(inout) :: tensorfield
  integer :: i,j
  if((tensorfield%s%d(1).eq.tensor%d(1)).or. &
      (tensorfield%s%d(2).eq.tensor%d(2)).or. &
      (tensorfield%s%d(3).eq.tensor%d(3))) then
    do j = 1, tensorfield%s%d(5)
      do i = 1, tensorfield%s%d(4)
        tensorfield%p(:,:,:,i,j) = tensor%p(:,:,:)
      enddo
    enddo
  else
    write(*,*) "operator tensorfield_to_tensor error:"
    write(*,*) "Unequal rank size:",tensorfield%s%d(1:3),tensor%d
  endif
end subroutine

subroutine iscalarfield_to_iscalar(scalarfield,scalar)
  implicit none
  integer,intent(in) :: scalar
  type(iscalarfield_t),intent(inout) :: scalarfield
  integer :: i,j
  do j = 1, scalarfield%s%d(2)
    do i = 1, scalarfield%s%d(1)
      scalarfield%p(i,j) = scalar
    enddo
  enddo
end subroutine

subroutine ivectorfield_to_ivector(vectorfield,vector)
  implicit none
  type(ivector_t),intent(in) :: vector
  type(ivectorfield_t),intent(inout) :: vectorfield
  integer :: i,j
  if(vectorfield%s%d(1).eq.vector%d) then
    do j = 1, vectorfield%s%d(3)
      do i = 1, vectorfield%s%d(2)
        vectorfield%p(:,i,j) = vector%p(:)
      enddo
    enddo
  else
    write(*,*) "operator vectorfield_to_vector error:"
    write(*,*) "Unequal rank size:",vectorfield%s%d(1),vector%d
  endif
end subroutine

subroutine imatrixfield_to_imatrix(matrixfield,matrix)
  implicit none
  type(imatrix_t),intent(in) :: matrix
  type(imatrixfield_t),intent(inout) :: matrixfield
  integer :: i,j
  if((matrixfield%s%d(1).eq.matrix%d(1)).or. &
      (matrixfield%s%d(2).eq.matrix%d(2))) then
    do j = 1, matrixfield%s%d(4)
      do i = 1, matrixfield%s%d(3)
        matrixfield%p(:,:,i,j) = matrix%p(:,:)
      enddo
    enddo
  else
    write(*,*) "operator matrixfield_to_matrix error:"
    write(*,*) "Unequal rank size:",matrixfield%s%d(1:2),matrix%d
  endif
end subroutine

subroutine itensorfield_to_itensor(tensorfield,tensor)
  implicit none
  type(itensor_t),intent(in) :: tensor
  type(itensorfield_t),intent(inout) :: tensorfield
  integer :: i,j
  if((tensorfield%s%d(1).eq.tensor%d(1)).or. &
      (tensorfield%s%d(2).eq.tensor%d(2)).or. &
      (tensorfield%s%d(3).eq.tensor%d(3))) then
    do j = 1, tensorfield%s%d(5)
      do i = 1, tensorfield%s%d(4)
        tensorfield%p(:,:,:,i,j) = tensor%p(:,:,:)
      enddo
    enddo
  else
    write(*,*) "operator tensorfield_to_tensor error:"
    write(*,*) "Unequal rank size:",tensorfield%s%d(1:3),tensor%d
  endif
end subroutine

subroutine rscalarfield_to_rscalar(scalarfield,scalar)
  implicit none
  double precision,intent(in) :: scalar
  type(rscalarfield_t),intent(inout) :: scalarfield
  integer :: i,j
  do j = 1, scalarfield%s%d(2)
    do i = 1, scalarfield%s%d(1)
      scalarfield%p(i,j) = scalar
    enddo
  enddo
end subroutine

subroutine rvectorfield_to_rvector(vectorfield,vector)
  implicit none
  type(rvector_t),intent(in) :: vector
  type(rvectorfield_t),intent(inout) :: vectorfield
  integer :: i,j
  if(vectorfield%s%d(1).eq.vector%d) then
    do j = 1, vectorfield%s%d(3)
      do i = 1, vectorfield%s%d(2)
        vectorfield%p(:,i,j) = vector%p(:)
      enddo
    enddo
  else
    write(*,*) "operator vectorfield_to_vector error:"
    write(*,*) "Unequal rank size:",vectorfield%s%d(1),vector%d
  endif
end subroutine

subroutine rmatrixfield_to_rmatrix(matrixfield,matrix)
  implicit none
  type(rmatrix_t),intent(in) :: matrix
  type(rmatrixfield_t),intent(inout) :: matrixfield
  integer :: i,j
  if((matrixfield%s%d(1).eq.matrix%d(1)).or. &
      (matrixfield%s%d(2).eq.matrix%d(2))) then
    do j = 1, matrixfield%s%d(4)
      do i = 1, matrixfield%s%d(3)
        matrixfield%p(:,:,i,j) = matrix%p(:,:)
      enddo
    enddo
  else
    write(*,*) "operator matrixfield_to_matrix error:"
    write(*,*) "Unequal rank size:",matrixfield%s%d(1:2),matrix%d
  endif
end subroutine

subroutine rtensorfield_to_rtensor(tensorfield,tensor)
  implicit none
  type(rtensor_t),intent(in) :: tensor
  type(rtensorfield_t),intent(inout) :: tensorfield
  integer :: i,j
  if((tensorfield%s%d(1).eq.tensor%d(1)).or. &
      (tensorfield%s%d(2).eq.tensor%d(2)).or. &
      (tensorfield%s%d(3).eq.tensor%d(3))) then
    do j = 1, tensorfield%s%d(5)
      do i = 1, tensorfield%s%d(4)
        tensorfield%p(:,:,:,i,j) = tensor%p(:,:,:)
      enddo
    enddo
  else
    write(*,*) "operator tensorfield_to_tensor error:"
    write(*,*) "Unequal rank size:",tensorfield%s%d(1:3),tensor%d
  endif
end subroutine

subroutine bscalarfield_to_bscalarfield(left,right)
  implicit none
  type(bscalarfield_t),intent(in) :: right
  type(bscalarfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(2)
      do i = 1, left%s%d(1)
        left%p(i,j) = right%p(i,j)
      enddo
    enddo
  else
    write(*,*) "operator bscalarfield_to_bscalarfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine bvectorfield_to_bvectorfield(left,right)
  implicit none
  type(bvectorfield_t),intent(in) :: right
  type(bvectorfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(3)
      do i = 1, left%s%d(2)
        left%p(:,i,j) = right%p(:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator bvectorfield_to_bvectorfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine bmatrixfield_to_bmatrixfield(left,right)
  implicit none
  type(bmatrixfield_t),intent(in) :: right
  type(bmatrixfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(4)
      do i = 1, left%s%d(3)
        left%p(:,:,i,j) = right%p(:,:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator bmatrixfield_to_bmatrixfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine btensorfield_to_btensorfield(left,right)
  implicit none
  type(btensorfield_t),intent(in) :: right
  type(btensorfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(5)
      do i = 1, left%s%d(4)
        left%p(:,:,:,i,j) = right%p(:,:,:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator btensorfield_to_btensorfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine iscalarfield_to_iscalarfield(left,right)
  implicit none
  type(iscalarfield_t),intent(in) :: right
  type(iscalarfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(2)
      do i = 1, left%s%d(1)
        left%p(i,j) = right%p(i,j)
      enddo
    enddo
  else
    write(*,*) "operator iscalarfield_to_iscalarfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine ivectorfield_to_ivectorfield(left,right)
  implicit none
  type(ivectorfield_t),intent(in) :: right
  type(ivectorfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(3)
      do i = 1, left%s%d(2)
        left%p(:,i,j) = right%p(:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator ivectorfield_to_ivectorfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine imatrixfield_to_imatrixfield(left,right)
  implicit none
  type(imatrixfield_t),intent(in) :: right
  type(imatrixfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(4)
      do i = 1, left%s%d(3)
        left%p(:,:,i,j) = right%p(:,:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator imatrixfield_to_imatrixfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine itensorfield_to_itensorfield(left,right)
  implicit none
  type(itensorfield_t),intent(in) :: right
  type(itensorfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(5)
      do i = 1, left%s%d(4)
        left%p(:,:,:,i,j) = right%p(:,:,:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator itensorfield_to_itensorfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine rscalarfield_to_rscalarfield(left,right)
  implicit none
  type(rscalarfield_t),intent(in) :: right
  type(rscalarfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(2)
      do i = 1, left%s%d(1)
        left%p(i,j) = right%p(i,j)
      enddo
    enddo
  else
    write(*,*) "operator rscalarfield_to_rscalarfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine rvectorfield_to_rvectorfield(left,right)
  implicit none
  type(rvectorfield_t),intent(in) :: right
  type(rvectorfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(3)
      do i = 1, left%s%d(2)
        left%p(:,i,j) = right%p(:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator rvectorfield_to_rvectorfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine rmatrixfield_to_rmatrixfield(left,right)
  implicit none
  type(rmatrixfield_t),intent(in) :: right
  type(rmatrixfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(4)
      do i = 1, left%s%d(3)
        left%p(:,:,i,j) = right%p(:,:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator rmatrixfield_to_rmatrixfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

subroutine rtensorfield_to_rtensorfield(left,right)
  implicit none
  type(rtensorfield_t),intent(in) :: right
  type(rtensorfield_t),intent(inout) :: left
  integer :: i,j
  if(left%s.eq.right%s) then
    do j = 1, left%s%d(5)
      do i = 1, left%s%d(4)
        left%p(:,:,:,i,j) = right%p(:,:,:,i,j)
      enddo
    enddo
  else
    write(*,*) "operator rtensorfield_to_rtensorfield() error:"
    write(*,*) "Unequal rank :"
    write(*,*) "Left size:",left%s%d
    write(*,*) "Rightsize:",right%s%d
  endif
end subroutine

end module


!##############################################################################
!# Tutorial 006f: Discretise with Q1, create a vector
!##############################################################################

module tutorial006f

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use spatialdiscretisation
  use linearsystemscalar

  use vectorio

  implicit none
  private

  public :: start_tutorial006f

contains

  ! ***************************************************************************

  subroutine start_tutorial006f

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation
    type(t_vectorScalar) :: rx
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006f")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a scalar vector
    ! =================================

    call lsyssc_createVector (rdiscretisation,rx)

    ! Fill the vector with "1.0".
    call lsyssc_clearVector (rx,1.0_DP)

    ! =================================
    ! Output to files.
    ! =================================
    call output_line ("Writing vector to text files...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the vector to a text file.
      call vecio_writeVectorHR (rx, "vector", .true., 0, &
          trim(spostdir)//"/tutorial006f_vector.txt", "(E11.2)")

      ! Write the vector to a MATLAB file.
      call vecio_spyVector(&
          trim(spostdir)//"/tutorial006f_vector","vector",rx,.true.)

      ! Write the vector to a MAPLE file
      call vecio_writeVectorMaple (rx, "vector", .true., 0, &
          trim(spostdir)//"/tutorial006f_vector.maple", "(E11.2)")
    else
      ! Write the vector to a text file.
      call vecio_writeVectorHR (rx, "vector", .true., 0, &
          "./post/tutorial006f_vector.txt", "(E11.2)")

      ! Write the vector to a MATLAB file.
      call vecio_spyVector(&
          "./post/tutorial006f_vector","vector",rx,.true.)

      ! Write the vector to a MAPLE file
      call vecio_writeVectorMaple (rx, "vector", .true., 0, &
          "./post/tutorial006f_vector.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsyssc_releaseVector (rx)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


program NonlinearSteadySWE
!******************************************************************************
!	Peter A. Bosler
!	Department of Mathematics
!	University of Michigan
!	pbosler@umich.edu
!
!******************************************************************************
!
!	This program solves the shallow water equations for Williamson et al (1992) test case 2.
!
!	Bosler, P.A., "Particle Methods for Geophysical Flow on the Sphere," PhD Thesis; the University of Michigan, 2013.
!
!	Williamson, D.L. et al, "A standard test set for numerical approximations to the shallow water equations in
!		spherical geometry." J. Comp. Phys., 102:211-224, 1992.
!
!----------------

use NumberKindsModule
use SphereGeomModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use PanelsModule
use SphereMeshModule
use VTKOutputModule
use SWESetupModule
use TracerSetupModule
use SWEDirectSumModule

implicit none

include 'mpif.h'

!
! mesh variables
!
type(SphereMesh) :: sphere
integer(kint) :: panelKind, initNest, AMR, nTracer, problemKind
type(Particles), pointer :: sphereParticles => null()
type(Panels), pointer :: spherePanels => null()

!
! time stepping variables
!
type(SWERK4Data) :: sweRK4
real(kreal) :: t, dt, tfinal
integer(kint) :: timesteps, timeJ

!
! vorticity / divergence variables
!
type(SWESetup) :: testCase2
real(kreal) :: u0, rotAlpha, h0

!
! output variables
!
type(VTKSource) :: vtkOut
character(len=128) :: vtkRoot, vtkFile, outputDir, jobPrefix
character(len=128) :: dataFile, summaryFile
character(len=56) :: amrString
integer(kint) :: frameCounter, frameOut, readWriteStat
type(OutputWriter) :: writer

!
! user input
!
character(len=128) :: namelistInputFile = 'TestCase2.namelist'
namelist /sphereDefine/ panelKind, initNest, AMR
namelist /testCaseDefine/ u0, rotAlpha, h0
namelist /timestepping/ tfinal, dt
namelist /fileIO/ outputDir, jobPrefix, frameOut

!
! logging
!
type(Logger) :: exeLog
character(len=28) :: logKey
character(len=128) :: logString

!
! general and mpi variables
!
integer(kint) :: i, j, k, errCode
integer(kint), parameter :: BROADCAST_INT_SIZE = 3, BROADCAST_REAL_SIZE = 5
integer(kint) :: broadcastIntegers(BROADCAST_INT_SIZE)
real(kreal) :: broadcastReals(BROADCAST_REAL_SIZE)
real(kreal) :: wallClock

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	PROGRAM START
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
call MPI_INIT(errCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numProcs,errCode)
call MPI_COMM_RANK(MPI_COMM_WORLD,procRank,errCode)

call InitLogger(exeLog,procRank)

wallClock = MPI_WTIME()

!
!	read user input from namelist file, set starting state
!
call ReadNamelistInputFile(procRank)
call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logkey,' initial broadcast done.')

!
! define test case
!
call New(testCase2,TC2_NINT, TC2_NREAL)
call InitNonlinearSteadyStateTC2(testCase2, u0, rotAlpha, h0)

!
! initialize sphere
!
nTracer = 4
problemKind = SWE_SOLVER
call New(sphere,panelKind,initNest,AMR,nTracer,problemKind)
call SetFlowMapLatitudeTracerOnMesh(sphere,1)
call SetNonlinearSteadyStateTC2OnMesh(sphere,testCase2)
call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,trim(logKey),' base sphere (t = 0) done.')

if ( AMR > 0 ) then
! TO DO : AMR
else
	if ( procRank == 0 .AND. panelKind == QUAD_PANEL ) then
		write(amrString, '(A,I1,A)') 'quadUnif',initNest,'_'
	endif
endif

!
! initialize output, output t=0 data
!
frameCounter = 0
if ( procRank == 0 ) then
	call LogStats(sphere,exeLog,'initial mesh :')
	write(vtkRoot,'(A,A,A,A)') trim(outputDir),'/vtkOut/',trim(jobPrefix),trim(amrString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot),frameCounter,'.vtk'

	call New(vtkOut,sphere,vtkFile,'SWE test case 2')
	call VTKOutput(vtkOut,sphere)
	frameCounter = frameCounter + 1
endif

!
! initialize timestepping
!
call New(sweRK4,sphere,numProcs)
timesteps = floor(tfinal/dt)
t = 0.0_kreal

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	RUN THE PROBLEM
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do timeJ = 0, timesteps-1
	! TO DO : remeshing for SWE

	!
	! increment time
	!
	call SWERK4Timestep(sweRK4, sphere, dt, procRank, numProcs)

	!
	! TO DO : error calculation
	!

	t = real(timeJ+1,kreal)*dt

	!
	! output timestep data
	!
	if ( procRank == 0 .AND. mod(timeJ+1,frameOut) == 0 ) then
		call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'day = ',t/ONE_DAY)

		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call UpdateFileName(vtkOut,vtkFile)
		call VTKOutput(vtkOut,sphere)

		frameCounter = frameCounter + 1
	endif
enddo

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	Clear memory and Finalize
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

write(logstring,'(A, F8.2,A)') 'elapsed time = ', (MPI_WTIME() - wallClock)/60.0, ' minutes.'
call LogMessage(exelog,TRACE_LOGGING_LEVEL,'PROGRAM COMPLETE : ',trim(logstring))

call Delete(sweRK4)
if (procRank == 0 ) call Delete(vtkOut)
call Delete(sphere)
call Delete(testCase2)
call Delete(exeLog)
call MPI_FINALIZE(ErrCode)

contains

subroutine ReadNamelistInputFile(rank)
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		open(unit = READ_UNIT, file=namelistInputFile, status = 'OLD', action = 'READ', iostat = readWriteStat)
		if ( readWriteStat /= 0 ) then
			stop 'cannot read namelist file'
		endif
		read(READ_UNIT,nml=sphereDefine)
		rewind(READ_UNIT)
		read(READ_UNIT,nml=testCaseDefine)
		rewind(READ_UNIT)
		read(READ_UNIT,nml=timestepping)
		rewind(READ_UNIT)
		read(READ_UNIT,nml=fileIO)

		broadcastIntegers(1) = panelKind
		broadcastIntegers(2) = initNest
		broadcastIntegers(3) = AMR

		broadcastReals(1) = u0
		broadcastReals(2) = rotAlpha
		broadcastReals(3) = h0
		broadcastReals(4) = tfinal
		broadcastReals(5) = dt
	endif

	call MPI_BCAST(broadcastIntegers, BROADCAST_INT_SIZE, MPI_INTEGER, 0, MPI_COMM_WORLD, errCode)
	panelKind = broadcastIntegers(1)
	initNest = broadcastIntegers(2)
	AMR = broadcastIntegers(3)

	call MPI_BCAST(broadcastReals, BROADCAST_REAL_SIZE, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, errCode)
	u0 = broadcastReals(1)
	rotAlpha = broadcastReals(2)
	h0 = broadcastReals(3)
	tfinal = broadcastReals(4)*ONE_DAY ! convert tfinal from days to seconds
	dt = broadcastReals(5)*ONE_DAY ! convert dt from days to seconds
end subroutine

subroutine InitLogger(aLog, rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	if (rank == 0 ) then
		call New(aLog,DEBUG_LOGGING_LEVEL)
	else
		call New(aLog,DEBUG_LOGGING_LEVEL)
	endif
	write(logkey,'(A,I0.2,A)') 'EXE_LOG',rank,' : '
end subroutine

end program


PROGRAM F025

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER (LEN=1000), DIMENSION(3) :: FIBONACCI_VAL = REPEAT("0", 1000)

    CHARACTER (LEN=10) :: SUMMAND_1, SUMMAND_2
    CHARACTER (LEN=11) :: TEMP_STR

    INTEGER :: VAL_1_LENGTH = 3
    INTEGER :: VAL_2_LENGTH = 2

    INTEGER (KIND=8) :: SUMMATION, SUMMAND_1_NUM, SUMMAND_2_NUM

    INTEGER :: I, J, STR_LENGTH, VAL_0_LENGTH, TEMP_INDEX

    FIBONACCI_VAL(1)( 998:998 ) = '1'
    FIBONACCI_VAL(1)( 999:999 ) = '4'
    FIBONACCI_VAL(1)(1000:1000) = '4'
    FIBONACCI_VAL(2)( 999:999 ) = '8'
    FIBONACCI_VAL(2)(1000:1000) = '9'
    FIBONACCI_VAL(3)( 999:999 ) = '5'
    FIBONACCI_VAL(3)(1000:1000) = '5'

    I = 12

    DO WHILE (FIBONACCI_VAL(1)(1:1) == '0')

        FIBONACCI_VAL(3) = FIBONACCI_VAL(2)
        FIBONACCI_VAL(2) = FIBONACCI_VAL(1)

        STR_LENGTH = VAL_1_LENGTH
        IF (VAL_2_LENGTH > VAL_1_LENGTH) STR_LENGTH = VAL_2_LENGTH
        STR_LENGTH = ( INT((STR_LENGTH - 1) / 10) + 1 ) * 10

        VAL_0_LENGTH = 0

        DO J = 1, (STR_LENGTH - 9), 10

            SUMMAND_1 = FIBONACCI_VAL(2)(992-J:1001-J)
            SUMMAND_2 = FIBONACCI_VAL(3)(992-J:1001-J)

            READ (SUMMAND_1, '(I10)') SUMMAND_1_NUM
            READ (SUMMAND_2, '(I10)') SUMMAND_2_NUM

            SUMMATION = SUMMAND_1_NUM + SUMMAND_2_NUM

            IF (J /= 1) SUMMATION = SUMMATION                                  &
                                  + IACHAR(FIBONACCI_VAL(1)(1001-J:1001-J))    &
                                  - IACHAR('0')

            WRITE (TEMP_STR, '(I0.11)') SUMMATION

            TEMP_INDEX = 991 - J

            IF (TEMP_INDEX == 0) THEN
                TEMP_INDEX = 1
                FIBONACCI_VAL(1)(TEMP_INDEX:TEMP_INDEX+9 ) = TEMP_STR(2:)
            ELSE
                FIBONACCI_VAL(1)(TEMP_INDEX:TEMP_INDEX+10) = TEMP_STR(1:)
            END IF

            IF (J == (STR_LENGTH - 9))                                         &
                VAL_0_LENGTH = J + INT(LOG10(REAL(SUMMATION, 8)))

        END DO

        VAL_2_LENGTH = VAL_1_LENGTH
        VAL_1_LENGTH = VAL_0_LENGTH

        I = I + 1

    END DO

    PRINT ('(I0)'), I

END PROGRAM F025


submodule(euler_interface_m) euler_prob_0011_m
    implicit none

contains

    module character(len=20) function euler0011()
        write (euler0011, "(i20)") ans()
    end function euler0011

    integer function ans()
        use euler_data_m, only: get_euler_data_0011
        implicit none

        integer :: int_arr(20, 20), the_box(4, 4)
        integer :: i, j, prod_max
        character(len=:), allocatable :: euler_data(:)

        call get_euler_data_0011(euler_data)
        read (euler_data, *) int_arr

        prod_max = 0
        outer: do i = 1, 17
            inner: do j = 1, 17
                the_box = int_arr(i:i + 3, j:j + 3)
                if (max_block(the_box) > prod_max) then
                    prod_max = max_block(the_box)
                end if
            end do inner
        end do outer
        ans = prod_max
    end function ans

    integer function max_block(m)
        integer, intent(in) :: m(:, :)
        integer :: d1(4), d2(4)
        integer :: k

        do k = 1, 4
            d1(k) = m(k, k)
            d2(k) = m(k, 5 - k)
        end do

        max_block = max(product(m(1:4, 1)), product(m(1:4, 4)), &
                        product(m(1, 1:4)), product(m(4, 1:4)), &
                        product(d1(1:4)), product(d2(1:4)))
    end function max_block
end submodule euler_prob_0011_m


program test
  integer, dimension(10) :: array
  integer :: k
  array(1:10) = (/ (k,k=1,10) /)
  print *,array
end program test


program nbody

  implicit none

  include "mpif.h"

  integer, parameter :: n=50, ndim=3
  real(8), parameter :: pi=3.14159265359, e0=8.854187817d-12, &
       e=1.6d-19, m=9.11d-31, delta=1.0d-12, bsize=100.0d0

  integer :: ierr, mpirank, mpisize, i, j, k, l, up, down
  integer, dimension(2) :: requests
  integer, dimension(MPI_STATUS_SIZE, 2) :: statuss
  real(8), dimension(ndim) :: d
  real(8), dimension(ndim, n) :: s, v, a, ibuf, obuf, tbuf
  real(8) :: r1, r2, t, tmax, tstep, tmp, energy, twrite

  call MPI_Init(ierr)
  call MPI_Comm_size(MPI_COMM_WORLD, mpisize, ierr)
  call MPI_Comm_rank(MPI_COMM_WORLD, mpirank, ierr)

  do i = 0, mpirank
     call random_number(s)
  end do

  s = bsize*s
  v = 0.0d0
  a = 0.0d0
  tmax = 1.0d0
  tstep = 0.0001d0
  twrite = 0.0d0
  t = 0.0d0
  energy = 0.0d0
  up = modulo(mpirank+1, mpisize)
  down = modulo(mpirank-1, mpisize)

  do while(t <= tmax)
     ibuf = s

     do l = 1, mpisize
        do i = 1, n
           do j = 1, n
              d = s(:, i) - ibuf(:, j)
              r1 = sqrt(sum(d**2))
              r2 = max(r1, delta)
              a(:,i) = a(:,i) + 0.25d0/pi/e0*e*e/r2**3/m * d
           end do
        end do

        obuf = ibuf

        call MPI_Irecv(ibuf, n*ndim, MPI_DOUBLE_PRECISION, &
             & down, 1, MPI_COMM_WORLD, requests(1), ierr)
        call MPI_Issend(obuf, n*ndim, MPI_DOUBLE_PRECISION, &
             & up, 1, MPI_COMM_WORLD, requests(2), ierr)
        call MPI_Waitall(2, requests, statuss, ierr)
     end do

     do i= 1, n
        tbuf(:, i) = s(:, i) + 0.5d0*v(:, i)*tstep + 0.25d0*a(:, i)*tstep**2

        where (tbuf(:, i) > bsize)
           tbuf(:, i) = 2.0d0*bsize-tbuf(:, i)
        end where

        where (tbuf(:, i) < 0.0d0)
           tbuf(:, i) = -tbuf(:, i)
        end where

        a(:, i) = 0.0d0
     end do

     ibuf = tbuf

     do l = 1, mpisize
        do i = 1, n
           do j = 1, n
              d = tbuf(:, i) - ibuf(:, j)
              r1 = sqrt(sum(d**2))
              r2 = max(r1, delta)
              a(:,i) = a(:,i) + 0.25d0/pi/e0*e*e/r2**3/m * d
              energy = energy + 0.125d0/pi/e0*e*e/r2**2*r1
           end do
        end do

        obuf = ibuf

        call MPI_Irecv(ibuf, n*ndim, MPI_DOUBLE_PRECISION, &
             & down, 1, MPI_COMM_WORLD, requests(1), ierr)
        call MPI_Issend(obuf, n*ndim, MPI_DOUBLE_PRECISION, &
             & up, 1, MPI_COMM_WORLD, requests(2), ierr)
        call MPI_Waitall(2, requests, statuss, ierr)
     end do

     call MPI_Allreduce(energy, tmp, 1, MPI_DOUBLE_PRECISION, &
          & MPI_SUM, MPI_COMM_WORLD, ierr)

     energy = tmp

     if (t >= twrite) then
        if (mpirank == 0) then
           write(*,*) energy
        end if

        twrite = t+tmax/100.0d0
     end if

     energy = 0.0d0

     do i= 1, n
        v(:, i) = v(:, i) + a(:, i)*tstep
        s(:, i) = s(:, i) + v(:, i)*tstep

        where (s(:, i) > bsize)
           s(:, i) = 2.0d0*bsize-s(:, i)
           v(:, i) = -v(:, i)
        end where

        where (s(:, i) < 0.0d0)
           s(:, i) = -s(:, i)
           v(:, i) = -v(:, i)
        end where

        energy = energy + 0.5d0*m*sum(v(:, i)**2)
        a(:, i) = 0.0d0
     end do

     t = t + tstep
  end do

  call MPI_Finalize(ierr)

end program nbody


program test_eigb_f
 use tt_lib
 use ttaux_lib
 use ttop_lib
 use ttio_lib
!  use ttm_lib
 use time_lib
 implicit none

 real(8), allocatable :: arr(:)
 type(dtt), target :: tt
 integer(8), allocatable :: n(:)
 integer(8) :: d, nel, rmax
 integer(8) :: i
 integer(8), pointer :: r(:), nn(:)
 real(8), pointer :: current_core(:, :, :) !They are all 3d-dimensional, including the border ones
 rmax = 20

 !Create an array
 d = 5 !5-dim array
 allocate(n(d))
 n(:) = 2
 allocate(arr(product(n)))
 nel = product(n)
 do i = 1, nel
     arr(i) = i
 end do
 !Call the function
 call svd(n, arr, tt, 1d-8)
 !call say(tt)

 !The TT-structure is:
 ! tt % r(0:d+1) -> the ranks
 ! tt % n(1:d) -> mode sizes
 ! tt % u(1:d) -> 3d arrays o
 r => tt % r(0:d)
 nn => tt % n(1:d)
 print *, 'ranks:', r(1:d+1)
 print *, 'mode sizes:', nn
 print *, 'printing cores'
 do i = 1, d
     current_core => tt % u(i) % p(1:r(i), 1:nn(i), 1:r(i+1))
     print *, 'The core', i, ' is', current_core
 end do
 deallocate(n)
 deallocate(arr)
 !call dealloc(tt)
end program


!	Extract the linear component lintheta and the quadratic component quadtheta from the parameter vector beta.
subroutine getlinquad(beta,lintheta,quadtheta)
implicit none
interface
!	convert an n by n symmetric matrix from compact to regular form.
	function expandmat(n,compmat)
		implicit none
		integer,intent(in)::n
		real(kind=8),intent(in)::compmat(:)
		real(kind=8)::expandmat(n,n)
	end function expandmat

end interface

real(kind=8),intent(in)::beta(:)
real(kind=8),intent(out)::lintheta(:,:),quadtheta(:,:,:)
!	dimcovlat is the number of elements per predictor of the quadratic component.
!	dimlatin is the dimension of the underlying latent vector.
!	nlin points to linear components.
!	npred is the number of predictors.

!	nquadratic points to quadratic components.
!	position and position1 point to elements of the parameter vector.
!	pred counts predictors.
integer::dimcovlat,dimlatin,nlin,npred,nquadratic,position,position1,pred

dimlatin=size(lintheta,1)
npred=size(lintheta,2)
dimcovlat=dimlatin*(dimlatin+1)/2
nquadratic=size(beta)-dimcovlat*npred+1
nlin=nquadratic-dimlatin*npred
lintheta=reshape(beta(nlin:nquadratic-1),(/dimlatin,npred/))
position=nquadratic
do pred=1,npred
	position1=position+dimcovlat-1
	quadtheta(:,:,pred)=expandmat(dimlatin,beta(position:position1))
	position=position1+1
end do
return
end subroutine getlinquad


      subroutine setprob()
      implicit none

      double precision kappa,tfinal
      integer n, m, vflag, ichoice

      double precision rp2, th, lambda, wc(3,10), rps, a, w(3)

      double precision rot_angle(2), scale
      double precision r, hmax,b,c
      integer meqn
      double precision g

      double precision pi
      common /compi/ pi

      common /sw/  g

c     # This should be a user parm...
      g = 1.d0

      pi = 4.d0*atan(1.d0)

c     # -------------------------------------------------
c     # Setup location of cosine or Gaussians in array wc.
c     # Array 'wc' will be set in common block 'prob.i'
c     # -------------------------------------------------
c     # Locations of cosine bell or Gaussian

      th = pi/2.d0
      lambda = 5.d0*pi/6.d0
      lambda = 0.0
      wc(1,1) = cos(th)*cos(lambda)
      wc(2,1) = cos(th)*sin(lambda)
      wc(3,1) = sin(th)

      th = 0
      lambda = 7.d0*pi/6.d0
      wc(1,2) = cos(th)*cos(lambda)
      wc(2,2) = cos(th)*sin(lambda)
      wc(3,2) = sin(th)

      n = 1

      call set_initial_gaussian_locations(wc,n)

      a = 20
      hmax = 0.05d0
      call set_initial_gaussian_parms(a,hmax)

      end


      SUBROUTINE HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,
     1                   BDRS,BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     SUBROUTINE HWSCSP SOLVES A FINITE DIFFERENCE APPROXIMATION TO THE
C       MODIFIED HELMHOLTZ EQUATION IN SPHERICAL COORDINATES ASSUMING
C       AXISYMMETRY  (NO DEPENDENCE ON LONGITUDE)
C
C          (1/R**2)(D/DR)((R**2)(D/DR)U)
C
C             + (1/(R**2)SIN(THETA))(D/DTHETA)(SIN(THETA)(D/DTHETA)U)
C
C             + (LAMBDA/(RSIN(THETA))**2)U = F(THETA,R).
C
C     THIS TWO DIMENSIONAL MODIFIED HELMHOLTZ EQUATION RESULTS FROM
C     THE FOURIER TRANSFORM OF THE THREE DIMENSIONAL POISSON EQUATION
C
C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
C
C     INTL
C       = 0  ON INITIAL ENTRY TO HWSCSP OR IF ANY OF THE ARGUMENTS
C            RS, RF, N, NBDCND ARE CHANGED FROM A PREVIOUS CALL.
C       = 1  IF RS, RF, N, NBDCND ARE ALL UNCHANGED FROM PREVIOUS CALL
C            TO HWSCSP.
C
C       NOTE   A CALL WITH INTL=0 TAKES APPROXIMATELY 1.5 TIMES AS
C              MUCH TIME AS A CALL WITH INTL = 1  .  ONCE A CALL WITH
C              INTL = 0 HAS BEEN MADE THEN SUBSEQUENT SOLUTIONS
C              CORRESPONDING TO DIFFERENT F, BDTS, BDTF, BDRS, BDRF CAN
C              BE OBTAINED FASTER WITH INTL = 1 SINCE INITIALIZATION IS
C              NOT REPEATED.
C
C     TS,TF
C       THE RANGE OF THETA (COLATITUDE), I.E., TS .LE. THETA .LE. TF.
C       TS MUST BE LESS THAN TF.  TS AND TF ARE IN RADIANS.  A TS OF
C       ZERO CORRESPONDS TO THE NORTH POLE AND A TF OF PI CORRESPONDS
C       TO THE SOUTH POLE.
C
C     * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * *
C
C     IF TF IS EQUAL TO PI THEN IT MUST BE COMPUTED USING THE STATEMENT
C     TF = PIMACH(DUM). THIS INSURES THAT TF IN THE USERS PROGRAM IS
C     EQUAL TO PI IN THIS PROGRAM WHICH PERMITS SEVERAL TESTS OF THE
C     INPUT PARAMETERS THAT OTHERWISE WOULD NOT BE POSSIBLE.
C
C     M
C       THE NUMBER OF PANELS INTO WHICH THE INTERVAL (TS,TF) IS
C       SUBDIVIDED.  HENCE, THERE WILL BE M+1 GRID POINTS IN THE
C       THETA-DIRECTION GIVEN BY THETA(K) = (I-1)DTHETA+TS FOR
C       I = 1,2,...,M+1, WHERE DTHETA = (TF-TS)/M IS THE PANEL WIDTH.
C
C     MBDCND
C       INDICATES THE TYPE OF BOUNDARY CONDITION AT THETA = TS AND
C       THETA = TF.
C
C       = 1  IF THE SOLUTION IS SPECIFIED AT THETA = TS AND THETA = TF.
C       = 2  IF THE SOLUTION IS SPECIFIED AT THETA = TS AND THE
C            DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TF (SEE NOTE 2 BELOW).
C       = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TS AND THETA = TF (SEE NOTES 1,2
C            BELOW).
C       = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TS (SEE NOTE 1 BELOW) AND THE
C            SOLUTION IS SPECIFIED AT THETA = TF.
C       = 5  IF THE SOLUTION IS UNSPECIFIED AT THETA = TS = 0 AND THE
C            SOLUTION IS SPECIFIED AT THETA = TF.
C       = 6  IF THE SOLUTION IS UNSPECIFIED AT THETA = TS = 0 AND THE
C            DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TF (SEE NOTE 2 BELOW).
C       = 7  IF THE SOLUTION IS SPECIFIED AT THETA = TS AND THE
C            SOLUTION IS UNSPECIFIED AT THETA = TF = PI.
C       = 8  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C            SPECIFIED AT THETA = TS (SEE NOTE 1 BELOW) AND THE SOLUTION
C            IS UNSPECIFIED AT THETA = TF = PI.
C       = 9  IF THE SOLUTION IS UNSPECIFIED AT THETA = TS = 0 AND
C            THETA = TF = PI.
C
C       NOTES:  1.  IF TS = 0, DO NOT USE MBDCND = 3,4, OR 8, BUT
C                   INSTEAD USE MBDCND = 5,6, OR 9  .
C               2.  IF TF = PI, DO NOT USE MBDCND = 2,3, OR 6, BUT
C                   INSTEAD USE MBDCND = 7,8, OR 9  .
C
C     BDTS
C       A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA AT
C       THETA = TS.  WHEN MBDCND = 3,4, OR 8,
C
C            BDTS(J) = (D/DTHETA)U(TS,R(J)), J = 1,2,...,N+1  .
C
C       WHEN MBDCND HAS ANY OTHER VALUE, BDTS IS A DUMMY VARIABLE.
C
C     BDTF
C       A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA AT
C       THETA = TF.  WHEN MBDCND = 2,3, OR 6,
C
C            BDTF(J) = (D/DTHETA)U(TF,R(J)), J = 1,2,...,N+1  .
C
C       WHEN MBDCND HAS ANY OTHER VALUE, BDTF IS A DUMMY VARIABLE.
C
C     RS,RF
C       THE RANGE OF R, I.E., RS .LE. R .LT. RF.  RS MUST BE LESS THAN
C       RF.  RS MUST BE NON-NEGATIVE.
C
C       N
C       THE NUMBER OF PANELS INTO WHICH THE INTERVAL (RS,RF) IS
C       SUBDIVIDED.  HENCE, THERE WILL BE N+1 GRID POINTS IN THE
C       R-DIRECTION GIVEN BY R(J) = (J-1)DR+RS FOR J = 1,2,...,N+1,
C       WHERE DR = (RF-RS)/N IS THE PANEL WIDTH.
C       N MUST BE GREATER THAN 2
C
C     NBDCND
C       INDICATES THE TYPE OF BOUNDARY CONDITION AT R = RS AND R = RF.
C
C       = 1  IF THE SOLUTION IS SPECIFIED AT R = RS AND R = RF.
C       = 2  IF THE SOLUTION IS SPECIFIED AT R = RS AND THE DERIVATIVE
C            OF THE SOLUTION WITH RESPECT TO R IS SPECIFIED AT R = RF.
C       = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS
C            SPECIFIED AT R = RS AND R = RF.
C       = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS
C            SPECIFIED AT RS AND THE SOLUTION IS SPECIFIED AT R = RF.
C       = 5  IF THE SOLUTION IS UNSPECIFIED AT R = RS = 0 (SEE NOTE
C            BELOW) AND THE SOLUTION IS SPECIFIED AT R = RF.
C       = 6  IF THE SOLUTION IS UNSPECIFIED AT R = RS = 0 (SEE NOTE
C            BELOW) AND THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO
C            R IS SPECIFIED AT R = RF.
C
C       NOTE:  NBDCND = 5 OR 6 CANNOT BE USED WITH
C              MBDCND = 1,2,4,5, OR 7 (THE FORMER INDICATES THAT THE
C                       SOLUTION IS UNSPECIFIED AT R = 0, THE LATTER
C                       INDICATES THAT THE SOLUTION IS SPECIFIED).
C                       USE INSTEAD
C              NBDCND = 1 OR 2  .
C
C     BDRS
C       A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R AT R = RS.
C       WHEN NBDCND = 3 OR 4,
C
C            BDRS(I) = (D/DR)U(THETA(I),RS), I = 1,2,...,M+1  .
C
C       WHEN NBDCND HAS ANY OTHER VALUE, BDRS IS A DUMMY VARIABLE.
C
C     BDRF
C       A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R AT R = RF.
C       WHEN NBDCND = 2,3, OR 6,
C
C            BDRF(I) = (D/DR)U(THETA(I),RF), I = 1,2,...,M+1  .
C
C       WHEN NBDCND HAS ANY OTHER VALUE, BDRF IS A DUMMY VARIABLE.
C
C     ELMBDA
C       THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION.  IF
C       LAMBDA .GT. 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HWSCSP WILL
C       ATTEMPT TO FIND A SOLUTION.  IF NBDCND = 5 OR 6 OR
C       MBDCND = 5,6,7,8, OR 9, ELMBDA MUST BE ZERO.
C
C     F
C       A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUE OF THE RIGHT
C       SIDE OF THE HELMHOLTZ EQUATION AND BOUNDARY VALUES (IF ANY).
C       FOR I = 2,3,...,M AND J = 2,3,...,N
C
C            F(I,J) = F(THETA(I),R(J)).
C
C       ON THE BOUNDARIES F IS DEFINED BY
C
C            MBDCND   F(1,J)            F(M+1,J)
C            ------   ----------        ----------
C
C              1      U(TS,R(J))        U(TF,R(J))
C              2      U(TS,R(J))        F(TF,R(J))
C              3      F(TS,R(J))        F(TF,R(J))
C              4      F(TS,R(J))        U(TF,R(J))
C              5      F(0,R(J))         U(TF,R(J))   J = 1,2,...,N+1
C              6      F(0,R(J))         F(TF,R(J))
C              7      U(TS,R(J))        F(PI,R(J))
C              8      F(TS,R(J))        F(PI,R(J))
C              9      F(0,R(J))         F(PI,R(J))
C
C            NBDCND   F(I,1)            F(I,N+1)
C            ------   --------------    --------------
C
C              1      U(THETA(I),RS)    U(THETA(I),RF)
C              2      U(THETA(I),RS)    F(THETA(I),RF)
C              3      F(THETA(I),RS)    F(THETA(I),RF)
C              4      F(THETA(I),RS)    U(THETA(I),RF)   I = 1,2,...,M+1
C              5      F(TS,0)           U(THETA(I),RF)
C              6      F(TS,0)           F(THETA(I),RF)
C
C       F MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C       NOTE
C
C       IF THE TABLE CALLS FOR BOTH THE SOLUTION U AND THE RIGHT SIDE F
C       AT  A CORNER THEN THE SOLUTION MUST BE SPECIFIED.
C
C     IDIMF
C       THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C       PROGRAM CALLING HWSCSP.  THIS PARAMETER IS USED TO SPECIFY THE
C       VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M+1  .
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE. ITS LENGTH CAN BE COMPUTED FROM THE FORMULA BELOW
C       WHICH DEPENDS ON THE VALUE OF NBDCND
C
C       IF NBDCND=2,4 OR 6 DEFINE NUNK=N
C       IF NBDCND=1 OR 5   DEFINE NUNK=N-1
C       IF NBDCND=3        DEFINE NUNK=N+1
C
C       NOW SET K=INT(LOG2(NUNK))+1 AND L=2**(K+1) THEN W MUST BE
C       DIMENSIONED AT LEAST (K-2)*L+K+5*(M+N)+MAX(2*N,6*M)+23
C
C       **IMPORTANT** FOR PURPOSES OF CHECKING, THE REQUIRED LENGTH
C                     OF W IS COMPUTED BY HWSCSP AND STORED IN W(1)
C                     IN FLOATING POINT FORMAT.
C
C
C     * * * * * * * * * *     ON OUTPUT     * * * * * * * * * *
C
C     F
C       CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C       APPROXIMATION FOR THE GRID POINT (THETA(I),R(J)),
C       I = 1,2,...,M+1,   J = 1,2,...,N+1  .
C
C     PERTRB
C       IF A COMBINATION OF PERIODIC OR DERIVATIVE BOUNDARY CONDITIONS
C       IS SPECIFIED FOR A POISSON EQUATION (LAMBDA = 0), A SOLUTION MAY
C       NOT EXIST.  PERTRB IS A CONSTANT, CALCULATED AND SUBTRACTED FROM
C       F, WHICH ENSURES THAT A SOLUTION EXISTS.  HWSCSP THEN COMPUTES
C       THIS SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO THE ORIGINAL
C       APPROXIMATION. THIS SOLUTION IS NOT UNIQUE AND IS UNNORMALIZED.
C       THE VALUE OF PERTRB SHOULD BE SMALL COMPARED TO THE RIGHT SIDE
C       F. OTHERWISE , A SOLUTION IS OBTAINED TO AN ESSENTIALLY
C       DIFFERENT PROBLEM. THIS COMPARISON SHOULD ALWAYS BE MADE TO
C       INSURE THAT A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C       FOR NUMBERS 0 AND 10, A SOLUTION IS NOT ATTEMPTED.
C
C       = 1  TS.LT.0. OR TF.GT.PI
C       = 2  TS.GE.TF
C       = 3  M.LT.5
C       = 4  MBDCND.LT.1 OR MBDCND.GT.9
C       = 5  RS.LT.0
C       = 6  RS.GE.RF
C       = 7  N.LT.5
C       = 8  NBDCND.LT.1 OR NBDCND.GT.6
C       = 9  ELMBDA.GT.0
C       = 10 IDIMF.LT.M+1
C       = 11 ELMBDA.NE.0 AND MBDCND.GE.5
C       = 12 ELMBDA.NE.0 AND NBDCND EQUALS 5 OR 6
C       = 13 MBDCND EQUALS 5,6 OR 9 AND TS.NE.0
C       = 14 MBDCND.GE.7 AND TF.NE.PI
C       = 15 TS.EQ.0 AND MBDCND EQUALS 3,4 OR 8
C       = 16 TF.EQ.PI AND MBDCND EQUALS 2,3 OR 6
C       = 17 NBDCND.GE.5 AND RS.NE.0
C       = 18 NBDCND.GE.5 AND MBDCND EQUALS 1,2,4,5 OR 7
C
C       SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSLIBY INCORRECT
C       CALL TO HWSCSP, THE USER SHOULD TEST IERROR AFTER A CALL.
C
C     W
C       CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF
C       HWSCSP WILL BE CALLED AGAIN WITH INTL = 1.  W(1) CONTAINS THE
C       NUMBER OF LOCATIONS WHICH W MUST HAVE
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   BDTS(N+1),BDTF(N+1),BDRS(M+1),BDRF(M+1),
C     ARGUMENTS      F(IDIMF,N+1),W(SEE ARGUMENT LIST)
C
C     LATEST         JUNE 1979
C     REVISION
C
C     SUBPROGRAMS    HWSCSP,HWSCS1,BLKTRI,BLKTR1,PROD,PRODP,CPROD,CPRODP
C     REQUIRED       ,COMBP,PPADD,PSGF,BSRH,PPSGF,PPSPF,TEVLS,INDXA,
C                    ,INDXB,INDXC,EPMACH,STORE
C
C     SPECIAL
C     CONDITIONS
C
C     COMMON         CBLKT,VALUE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     PAUL N SWARZTRAUBER
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        VERSION 1 SEPTEMBER 1973
C                    VERSION 2 APRIL     1976
C                    VERSION 3 JUNE      1979
C
C     ALGORITHM      THE ROUTINE DEFINES THE FINITE DIFFERENCE
C                    EQUATIONS, INCORPORATES BOUNDARY DATA, AND ADJUSTS
C                    THE RIGHT SIDE OF SINGULAR SYSTEMS AND THEN CALLS
C                    BLKTRI TO SOLVE THE SYSTEM.
C
C     SPACE
C     REQUIRED
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    THE MACHINE ACCURACY IS COMPUTED APPROXIMATELY
C                    IN FUNCTION EPMACH
C
C     REQUIRED       NONE
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      SWARZTRAUBER,P. AND R. SWEET, 'EFFICIENT FORTRAN
C                    SUBPROGRAMS FOR THE SOLUTION OF ELLIPTIC EQUATIONS'
C                    NCAR TN/IA-109, JULY, 1975, 138 PP.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
      DIMENSION       F(IDIMF,1) ,BDTS(1)    ,BDTF(1)    ,BDRS(1)    ,
     1                BDRF(1)    ,W(1)
      PI = PIMACH(DUM)
      IERROR = 0
      IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1
      IF (TS .GE. TF) IERROR = 2
      IF (M .LT. 5) IERROR = 3
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 4
      IF (RS .LT. 0.) IERROR = 5
      IF (RS .GE. RF) IERROR = 6
      IF (N .LT. 5) IERROR = 7
      IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 8
      IF (ELMBDA .GT. 0.) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 11
      IF (ELMBDA.NE.0. .AND. (NBDCND.EQ.5 .OR. NBDCND.EQ.6)) IERROR = 12
      IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND.
     1    TS.NE.0.) IERROR = 13
      IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 14
      IF (TS.EQ.0. .AND.
     1    (MBDCND.EQ.4 .OR. MBDCND.EQ.8 .OR. MBDCND.EQ.3)) IERROR = 15
      IF (TF.EQ.PI .AND.
     1    (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 16
      IF (NBDCND.GE.5 .AND. RS.NE.0.) IERROR = 17
      IF (NBDCND.GE.5 .AND. (MBDCND.EQ.1 .OR. MBDCND.EQ.2 .OR.
     1                                    MBDCND.EQ.5 .OR. MBDCND.EQ.7))
     2    IERROR = 18
      IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN
      NCK = N
      GO TO (101,103,102,103,101,103),NBDCND
  101 NCK = NCK-1
      GO TO 103
  102 NCK = NCK+1
  103 L = 2
      K = 1
  104 L = L+L
      K = K+1
      IF (NCK-L) 105,105,104
  105 L = L+L
      NP1 = N+1
      MP1 = M+1
      I1 = (K-2)*L+K+MAX0(2*N,6*M)+13
      I2 = I1+NP1
      I3 = I2+NP1
      I4 = I3+NP1
      I5 = I4+NP1
      I6 = I5+NP1
      I7 = I6+MP1
      I8 = I7+MP1
      I9 = I8+MP1
      I10 = I9+MP1
      W(1) = FLOAT(I10+M)
      CALL HWSCS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS,
     1             BDRF,ELMBDA,F,IDIMF,PERTRB,W(2),W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10))
      RETURN
      END


program number_guess
!! not every compiler inits  arandom seed (Gfortran yes, flang no)
use, intrinsic:: iso_fortran_env, only: stdin=>input_unit, stdout=>output_unit
use numerical, only: isprime

implicit none

integer :: secret, guess, i
real :: r
character(20) :: msg, buf

call random_init(.false., .false.)

call random_number(r)
secret = int((r*99+1))

msg = 'guess my number  '

main: do
  write(stdout,'(A)', advance='no') msg
  read(stdin,*, iostat=i) buf
  if (i/=0) stop 'goodbye'

  if (buf == 'h' .or. buf == 'hint' .or. buf == 'help') then
    if (isprime(secret)) then
      print *,'my secret number is prime'
    else
      print *,'my secret number is NOT prime'
    endif
  else
    read(buf,*, iostat=i) guess
    if (i/=0) stop 'goodbye'
  endif

  if(guess < secret) then
    msg = 'try bigger  '
  elseif(guess > secret) then
    msg = 'try smaller  '
  elseif(guess == secret) then
    print *,'you guessed my secret number -- hooray!'
    exit main
  else
    error stop 'impossible'
  endif

enddo main

end program