!*robodoc*u* tests/testABX
!  NAME
!    testABX
!  SYNOPSIS

!$Id: testABX.f90 526 2018-03-25 23:44:51Z mexas $

program testABX

!  PURPOSE
!    Testing Cray parallel direct access file IO, aka "assign"
!    environment, routine cgca_m2out/cgca_pc.
!  NOTE
!    Compile only on Cray! Don't try to compile with other compilers!
!  DESCRIPTION
!    Verify data integrity and compare timings of
!    cgca_swci and cgca_pc - i.e. a serial writer from image 1
!    and a parallel direct access shared writer. The latter is
!    a non standard Cray extension. So don't try to run this
!    on non-Cray machines.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  USES
!    cgca testaux
!  USED BY
!    Part of CGPACK test suite
!  SOURCE

use testaux

implicit none

real, parameter :: gigabyte=real(2**30)
logical( kind=ldef ), parameter :: yesdebug = .true., nodebug = .false.

real :: time1, time2, fsizeb, fsizeg, tdiff

integer( kind=idef ) :: ir(3), img, nimgs,                             &
  ng,   & ! number of grains in the whole model
  c(3)    ! coarray dimensions
integer( kind=iarr ), allocatable :: space(:,:,:,:) [:,:,:]

integer( kind=ilrg ) :: icells, mcells

real( kind=rdef ) ::    &
 qual,                  & ! quality
 bsz0(3),               & ! the given "box" size
 bsz(3),                & ! updated "box" size
 dm,                    & ! mean grain size, linear dim, phys units
 lres,                  & ! linear resolution, cells per unit of length
 res                      ! resolutions, cells per grain

logical( kind=ldef ) :: solid

!*********************************************************************72
! first executable statement

! physical dimensions of the box, assume mm
bsz0 = (/ 1.0, 2.0, 3.0 /)

! mean grain size, linear dimension, e.g. mean grain diameter, also mm
dm = 1.0e-1

! resolution
res = 1.0e5

! In this test set the number of images via the env var
! the code must be able to cope with any value >= 1.
   img = this_image()
 nimgs = num_images()

! do a check on image 1
if ( img .eq. 1 ) then
  ! print a banner
  call banner("ABX")
  ! print the parameter values
  call cgca_pdmp
  write (*,'(a,i0,a)') "running on ", nimgs, " images in a 3D grid"
end if

! want to sync here to make sure the banner is
! printed before the rest.
sync all

! each image calculates the coarray grid dimensions
call cgca_gdim( nimgs, ir, qual )

! calculate the resolution and the actual phys dimensions
! of the box
! subroutine cgca_cadim( bsz, res, dm, ir, c, lres, ng )
! c - coarray sizes
! ir - coarray grid sizes
bsz = bsz0
call cgca_cadim( bsz, res, dm, ir, c, lres, ng )

! total number of cells in a coarray
icells = int( c(1), kind=ilrg ) * int( c(2), kind=ilrg ) *             &
         int( c(3), kind=ilrg )

! total number of cells in the model
mcells = icells * int( nimgs, kind=ilrg )

if ( img .eq. 1 ) then
  write ( *, "(9(a,i0),tr1,g10.3,tr1,i0,3(a,g10.3),a)" )               &
    "img: ", img  , " nimgs: ", nimgs, " (", c(1) ,                    &
    ","    , c(2) , ","       , c(3) , ")[", ir(1),                    &
    ","    , ir(2), ","       , ir(3), "] ", ng   ,                    &
    qual, lres,                                                        &
    " (", bsz(1), ",", bsz(2), ",", bsz(3), ")"
  write (*,'(a,i0,a)') "Each image has ",icells, " cells"
  write (*,'(a,i0,a)') "The model has ", mcells, " cells"
end if

! Total output file size, in B and in GB.
fsizeb = real( mcells * storage_size( space, kind=ilrg ) / 8_ilrg )
fsizeg = fsizeb / gigabyte

! allocate space coarray with a single layer
! implicit sync all
!subroutine cgca_as( l1, u1, l2, u2, l3, u3, col1, cou1, col2, cou2,   &
!                    col3, props, coarray )
call cgca_as(1, c(1), 1, c(2), 1, c(3), 1, ir(1), 1, ir(2), 1, 1, space)

! initialise random number seed
call cgca_irs( nodebug )

! initialise space
space( :, :, :, cgca_state_type_grain ) = cgca_liquid_state

! nuclei, sync all inside
call cgca_nr( space, ng, nodebug )

! solidify with co_sum, implicit sync all inside
! subroutine cgca_sld3( coarray, iter, heartbeat, solid )
call cgca_sld3( space, 0, 10, solid )

! dump the model
call cpu_time(time1)
call cgca_pc( space, cgca_state_type_grain, 'craypario.raw' )
call cpu_time(time2)
tdiff = time2-time1
if (img .eq. 1) then
 write (*,*) "File size:", fsizeg, "GB"
 write (*,*) "Cray assign -m on IO: ", tdiff, "s, rate: ",             &
             fsizeg/tdiff, "GB/s."
end if

call cpu_time(time1)
call cgca_swci( space, cgca_state_type_grain, 10, 'serial.raw' )
call cpu_time(time2)
tdiff = time2-time1
if (img .eq. 1) write (*,*) "Serial IO: ", tdiff, "s, rate: ",         &
   fsizeg/tdiff, "GB/s."

! deallocate all arrays
call cgca_ds( space )

end program testABX

!*roboend*


c**********************************************************************
c     matmat.f - matrix - matrix multiply, simple self-scheduling version
c************************************************************************
      program main

      include "mpif.h"

      integer MAX_AROWS, MAX_ACOLS, MAX_BCOLS
      parameter (MAX_AROWS = 20, MAX_ACOLS = 1000, MAX_BCOLS = 20)
      double precision a(MAX_AROWS,MAX_ACOLS), b(MAX_ACOLS,MAX_BCOLS)
      double precision c(MAX_AROWS,MAX_BCOLS)
      double precision buffer(MAX_ACOLS), ans(MAX_ACOLS)

      integer myid, master, numprocs, ierr, status(MPI_STATUS_SIZE)
      integer i, j, numsent, sender
      integer anstype, row, arows, acols, brows, bcols, crows, ccols

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
      print *, "Process ", myid, " of ", numprocs, " is alive"

      master = 0
      arows  = 10
      acols  = 100
      brows  = 100
      bcols  = 10
      crows  = arows
      ccols  = bcols

      if ( myid .eq. master ) then
c        master initializes and then dispatches
c        initialize a and b
         do i = 1,acols
            do j = 1,arows
               a(j,i) = i
            enddo
         enddo
         do i = 1,bcols
            do j = 1,brows
               b(j,i) = i
            enddo
         enddo

         numsent = 0

c        send b to each other process
         do i = 1,bcols
         call MPI_BCAST(b(1,i), brows, MPI_DOUBLE_PRECISION, master,
     $        MPI_COMM_WORLD, ierr)
         enddo

c        send a row of a to each other process; tag with row number
         do i = 1,numprocs-1
            do j = 1,acols
               buffer(j) = a(i,j)
            enddo
            call MPI_SEND(buffer, acols, MPI_DOUBLE_PRECISION, i,
     $           i, MPI_COMM_WORLD, ierr)
            numsent = numsent+1
         enddo

         do i = 1,crows
            call MPI_RECV(ans, ccols, MPI_DOUBLE_PRECISION,
     $           MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status,
     $           ierr)
            sender     = status(MPI_SOURCE)
            anstype    = status(MPI_TAG)
            do j = 1,ccols
               c(anstype,j) = ans(j)
            enddo

            if (numsent .lt. arows) then
               do j = 1,acols
                  buffer(j) = a(numsent+1,j)
               enddo
               call MPI_SEND(buffer, acols, MPI_DOUBLE_PRECISION,
     $              sender, numsent+1, MPI_COMM_WORLD, ierr)
               numsent = numsent+1
            else
               call MPI_SEND(1.0, 1, MPI_DOUBLE_PRECISION, sender,
     $              0, MPI_COMM_WORLD, ierr)
            endif
         enddo

c        print out the answer
         do i = 1,crows
            do j = 1,ccols
               print *, "c(", i, ",", j, ") = ", c(i,j)
            enddo
         enddo

      else
c        slaves receive b, then compute rows of c until done message
         do i = 1,bcols
           call MPI_BCAST(b(1,i), brows, MPI_DOUBLE_PRECISION, master,
     $          MPI_COMM_WORLD, ierr)
         enddo
         do
            call MPI_RECV(buffer, acols, MPI_DOUBLE_PRECISION, master,
     $           MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
            if (status(MPI_TAG) .eq. 0) exit
            row = status(MPI_TAG)
            do i = 1,bcols
               ans(i) = 0.0
               do j = 1,acols
                  ans(i) = ans(i) + buffer(j)*b(j,i)
               enddo
            enddo
            call MPI_SEND(ans, bcols, MPI_DOUBLE_PRECISION, master, row,
     $           MPI_COMM_WORLD, ierr)
         enddo
      endif

      call MPI_FINALIZE(ierr)
      stop
      end


!|  mod_runtime_parameters is a module for run-time parameters,

!   that include one subroutine(read_runtime_parameters).
module mod_runtime_parameters
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public class_runtime_parameters
    type class_runtime_parameters
        real(real64) :: heat_capacity_ratio
            !! \(\gamma=C_p/C_v\) : heat capacity ratio
        real(real64),dimension(3) :: initial_primitive_values_left,initial_primitive_values_right
            !! left or right initial primitive values
 1:density, 2:velocity, 3:pressure
        real(real64) :: delta_t
            !! \(\Delta t\)
        integer(int32) :: time_accuracy
            !! time accuracy. This value is equal to the steps of Runge-Kutta methods.
        integer(int32) :: jmax
            !! number of grid points, that must be an even number
        integer(int32) :: spacial_accuracy
            !* spacial accuracy

            !  1:1st order (w/o MUSCL interpolation)

            !  2:2nd order (w MUSCL interpolation)
        integer(int32) :: type_of_interpolated
            !* values that interpolated by MUSCL scheme

            !  1:characteristics

            !  2:primitives

            !  3:conservatives

        integer(int32) :: type_of_limiter
            !* type of limiter function

            !  0:w/o limiter (unstable)

            !  1:superbee (less disspative)

            !  2:minmod (stable)
        integer(int32) :: max_timestep
            !! number of max time steps
        integer(int32) :: interval_of_flowfield_output
            !! interval of flowfield output
    contains
        procedure,pass,public :: read_runtime_parameters
    end type class_runtime_parameters
!---------
    contains
        !| read run-time parametes from file (filename)

        !  return number of errors (nerror)

        subroutine read_runtime_parameters(this,filename,nerror)
            class(class_runtime_parameters),intent(out) :: this
            character(len=20),intent(in) :: filename
            !! input file name
            integer(int32),intent(out) :: nerror
            !! number of errors
            integer(int32) :: unit_read_parameters

            nerror=0

            open(newunit=unit_read_parameters,file=filename)

            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%heat_capacity_ratio
            !> heat capacity ratio must be larger than one

            if(this%heat_capacity_ratio<1.0) then
                print *,'heat capacity ratio must be larger than one'
                print *,'but input value is ',this%heat_capacity_ratio
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*)
            ! left state
            read(unit_read_parameters,*) this%initial_primitive_values_left(1)   ! density
            read(unit_read_parameters,*) this%initial_primitive_values_left(2)   ! velocity
            read(unit_read_parameters,*) this%initial_primitive_values_left(3)   ! pressure
            read(unit_read_parameters,*)
            ! right state
            read(unit_read_parameters,*) this%initial_primitive_values_right(1)
            read(unit_read_parameters,*) this%initial_primitive_values_right(2)
            read(unit_read_parameters,*) this%initial_primitive_values_right(3)
            !> density must be positive

            if(this%initial_primitive_values_left(1)<=0.0 .or. this%initial_primitive_values_right(1)<=0.0) then
                print *,'density must be positive'
                print *,'but input values are',this%initial_primitive_values_left(1),this%initial_primitive_values_right(1)
                nerror=nerror+1
            end if
            !> two initial velocities must be equal

            if(this%initial_primitive_values_left(2).ne.this%initial_primitive_values_right(2)) then
                print *,'two initial velocities must be equal'
                print *,'but input values are',this%initial_primitive_values_left(2),this%initial_primitive_values_right(2)
                nerror=nerror+1
            end if
            !> pressure must be positive

            if(this%initial_primitive_values_left(3)<=0.0 .or. this%initial_primitive_values_right(3)<=0.0) then
                print *,'pressure must be positive'
                print *,'but input values are',this%initial_primitive_values_left(3),this%initial_primitive_values_right(3)
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%delta_t
            !> \(\Delta t\) must be positive and small enough

            if(this%delta_t<=0.0) then
                print *,'delta_t must be positive'
                print *,'but input value is',this%delta_t
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%time_accuracy
            !> time accuracy must be 1,2 or 3

            if(this%time_accuracy<1 .or. 3<this%time_accuracy) then
                print *,'time accuracy must be 1,2 or 3'
                print *,'but input value is',this%time_accuracy
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%jmax
            !> number of grid points must be even number

            if(this%jmax<1 .or. mod(this%jmax,2)/=0) then
                print *,'number of grid points must be even'
                print *,'but input value is',this%jmax
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%spacial_accuracy
            !> spacial accuracy (MUSCL interpolation) must be 1,2, or 3.

            if(this%spacial_accuracy<1 .or. 3<this%spacial_accuracy) then
                print *,'spacial accuracy must be 1,2, or 3'
                print *,'but input value is',this%spacial_accuracy
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%type_of_interpolated
            !> type of interpolated must be 1 (characteristics), 2 (primitives), or 3(conservatives).

            if(this%spacial_accuracy<1 .or. 3<this%spacial_accuracy) then
                print *,'type of interpolated must be 1,2, or 3'
                print *,'but input value is',this%type_of_interpolated
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%type_of_limiter
            !> type of limiter (MUSCL interpolation) must be 0 (w/o limiter), 1(superbee), or 2(minmod).

            if(this%type_of_limiter<0 .or. 2<this%type_of_limiter) then
                print *,'type of limiter must be 0,1, or 2'
                print *,'but input value is',this%type_of_limiter
                nerror=nerror+1
            end if

            read(unit_read_parameters,*)
            read(unit_read_parameters,*) this%max_timestep
            !> max (final) time step must be positive

            if(this%max_timestep<=0) then
                print *,'max time step must be positive'
                print *,'but input value is',this%max_timestep
                nerror=nerror+1
            end if

            read(unit_read_parameters,*) this%interval_of_flowfield_output
            !> interval of flowfield output must be positive

            if(this%interval_of_flowfield_output<=0) then
                print *,'interval of flowfield output must be positive'
                print *,'but input value is',this%interval_of_flowfield_output
                nerror=nerror+1
            end if

        end subroutine read_runtime_parameters
end module mod_runtime_parameters


C**********************************************************************
C
      SUBROUTINE ZRANDN (N,ZX,SEED)
C
C     Purpose:
C     Fills the vector ZX with random numbers  between 0 and 1.  If the
C     SEED is given, it should be odd and positive.  The generator is a
C     fairly unsophisticated one, from Pearson's  "Numerical methods in
C     engineering and science" book.
C
C     Parameters:
C     N    = the dimension of the vector (input).
C     ZX   = the vector to fill with random numbers (output).
C     SEED = the seed for the generator (input).
C
C     Noel M. Nachtigal
C     April 23, 1993
C
C**********************************************************************
C
      INTRINSIC DBLE, DCMPLX, IABS, MOD
C
      integer      N
      integer      SEED
      integer      I
      integer      J
C
C     Local variables.
c
      real*8       IMAGX
      real*8       REALX
c
      complex*16   ZX(N)
C
C     Local variables that are saved from one call to the next.
C
      real*8       DMAX
      integer      IM
      integer      IMAX
      integer      IS
      SAVE         DMAX, IM, IMAX, IS
c
      DATA IM/0/
C
C     Initialize the generator data.
C
      IF (IM.EQ.0) THEN
         J  = 0
         IM = 1
         DO 10 I = 1, 31
            J = J + 1
            IF (IM*2.LE.IM) GO TO 20
            IM = IM * 2
 10      CONTINUE
 20      IMAX = (IM-1) * 2 + 1
         DMAX = DBLE(IMAX)
         DO 30 I = 1, MOD(J,3)
            J = J - 1
            IM = IM / 2
 30      CONTINUE
         IM = IM + 5
         IS = IABS(MOD(IM*30107,IMAX))
      END IF
C
C     Check whether there is a new seed.
C
      IF (SEED.GT.0) IS = (SEED / 2) * 2 + 1
C
C     Here goes the rest.
C
      DO 40 I = 1, N
         REALX = DBLE(IS) / DMAX
         IS    = IABS(MOD(IM*IS,IMAX))
         IMAGX = DBLE(IS) / DMAX
         IS    = IABS(MOD(IM*IS,IMAX))
         ZX(I) = DCMPLX(REALX,IMAGX)
 40   CONTINUE
C
      RETURN
      END
C
C**********************************************************************


      SUBROUTINE PRPV1 (VX1,VY1,VZ1, VX2,VY2,VZ2)

C  PRPV1 accepts a 3D vector and returns another 3D vector
C  perpendicular to it.

      REAL  VX1,VY1,VZ1, VX2,VY2,VZ2, Z

      Z = 0.0
      VX2 = Z
      VY2 = Z
      VZ2 = Z
      IF (VX1 .EQ. Z) THEN
         VX2 = 1.0
      ELSEIF (VY1 .EQ. Z) THEN
         VY2 = 1.0
      ELSEIF (VZ1 .EQ. Z) THEN
         VZ2 = 1.0
      ELSE
         VX2 =  VY1
         VY2 = -VX1
      ENDIF

      END


subroutine where_example
  ! logical(logical_kind) :: should_set_upwind(nx,ny,nz)
  ! real(real_kind) :: donor(nx,ny,nz), upwind(nx,ny,nz), downwind(nx,ny,nz)
    logical(2) :: should_set_upwind(5,6,7)
    real(4) :: donor(5,6,7), upwind(5,6,7), downwind(5,6,7)

    upwind = 0;
    where(should_set_upwind)
        upwind = donor - upwind
      ! upwind = 0;
    end where

end subroutine where_example


!> @brief Test the square mesh generator creates a closed mesh.
!
!> @description A valid mesh should be "closed" that is the surface integral should be zero. The
!!              same is true of mesh cells.
program test_mesh_square_mesh_closed

  use testing_lib

  use constants

  use meshing, only : set_face_location, get_face_normal, get_face_area
  use mesh_utils, only : build_square_mesh

  implicit none

  type(ccs_mesh), target :: mesh
  type(face_locator) :: loc_f

  integer(ccs_int) :: n
  real(ccs_real) :: l

  real(ccs_real), dimension(ndim) :: S
  real(ccs_real), dimension(ndim) :: norm
  real(ccs_real) :: A

  integer(ccs_int) :: i, j

  call init()

  do n = 1, 100 ! XXX: Should use some named constant, not just "100"
    l = parallel_random(par_env)
    mesh = build_square_mesh(par_env, n, l)

    ! Loop over cells
    do i = 1, mesh%nlocal
      S(:) = 0.0_ccs_real

      ! Loop over neighbours/faces
      do j = 1, mesh%nnb(i)

        call set_face_location(mesh, i, j, loc_f)
        call get_face_area(loc_f, A)
        call get_face_normal(loc_f, norm)
        S(:) = S(:) + norm(:) * A
      end do

      ! Loop over axes
      do j = 1, ndim
        print *, S(j), j
        if (abs(S(j) - 0.0_ccs_real) > eps) then
          write(message, *) "FAIL: expected", 0.0_ccs_real, " got ", S(j)
          call stop_test(message)
        end if
      end do
    end do
  end do

  call fin()

end program test_mesh_square_mesh_closed


! Program to exercise lookahead parsing of subprogram defns
! to get type, kind, and size
program internalfuns
  implicit none
  integer :: n
  real*8 r8
  real(kind=4) k4
  type f_type
     integer :: x
  end type f_type
  type(f_type) :: f_var
  character(len=10,kind=1) :: c
  n = f(3)
  n = g(3)                      ! implicit declaration of external
  r8 = fr8(3.0d0)
  k4 = fk4(3.0_4) + 0.0
  k4 = k4 + 0.0
  f_var = ft(4)
  c = c_fun("hello")
  c = c_k1("hello") // "hello"
  c = c_k1_l10("hello")
  print *, n, r8, k4, f_var%x
  print *, c
contains
  integer function f(i)
    integer :: i
    f = i*i
  end function f

  real*8 function fr8(i)
    implicit none
    real*8 i
    fr8 = i*i
  end function fr8

  real(kind = 4 ) function fk4(i)
    real(kind=4) i
    fk4 = i*i
  end function fk4

  type(f_type) function ft(i)
    implicit none
    integer :: i
    ft%x = i*i
  end function ft

  character*10 function c_fun(str)
    character (len=*) :: str
    c_fun = str(1:5) // str(1:5)
  end function c_fun

  character ( kind = 1 ) function c_k1(str)
    character (len=*) :: str
    c_k1 = str(1:5) // str(1:5)
  end function c_k1

  character ( kind = 1, len = 10 ) function c_k1_l10(str)
    character (len=*) :: str
    c_k1_l10 = str(1:5) // str(1:5)
  end function c_k1_l10

end program internalfuns

! external function should not be found by lookahead
integer function g(n)
  g = n*3
end function g


      SUBROUTINE MB01SS( JOBS, UPLO, N, A, LDA, D )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To scale a symmetric N-by-N matrix A using the row and column
C     scaling factors stored in the vector D.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBS    CHARACTER*1
C             Specifies the scaling operation to be done, as follows:
C             = 'D':  row and column scaling with D, i.e., A will be
C                     transformed to diag(D)*A*diag(D);
C             = 'I':  row and column scaling with inv(D), i.e., A will
C                     be transformed to inv(diag(D))*A*inv(diag(D)).
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrix A is stored, as
C             follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper triangular part
C             (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
C             of this array must contain the upper triangular part or
C             lower triangular part, respectively, of the symmetric
C             matrix A.
C             On exit, the leading N-by-N upper triangular part
C             (if UPLO = 'U') or lower triangular part (if UPLO = 'L')
C             of this array contains the corresponding triangular part
C             of the matrix diag(D)*A*diag(D), if JOBS = 'D', or of the
C             matrix inv(diag(D))*A*inv(diag(D)), JOBS = 'I'.
C             The stricly lower triangular part (if UPLO = 'U') or
C             stricly upper triangular part (if UPLO = 'L') is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     D       (input) DOUBLE PRECISION array, dimension (N)
C             The diagonal elements of the diagonal matrix D.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 2019.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE   = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBS, UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), D(*)
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, J
      DOUBLE PRECISION   DJ
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      UPPER = LSAME( UPLO, 'U' )
C
      IF( LSAME( JOBS, 'D' ) ) THEN
C
C        Row and column scaling with D.
C
         IF( UPPER ) THEN
C
            DO 20 J = 1, N
               DJ = D(J)
               DO 10 I = 1, J
                  A(I,J) = DJ*D(I)*A(I,J)
   10          CONTINUE
   20       CONTINUE
C
         ELSE
C
            DO 40 J = 1, N
               DJ = D(J)
               DO 30 I = J, N
                  A(I,J) = DJ*D(I)*A(I,J)
   30          CONTINUE
   40       CONTINUE
C
         END IF
C
      ELSE
C
C        Row and column scaling with inv(D).
C
         IF( UPPER ) THEN
C
            DO 60 J = 1, N
               DJ = ONE/D(J)
               DO 50 I = 1, J
                  A(I,J) = ( DJ/D(I) )*A(I,J)
   50          CONTINUE
   60       CONTINUE
C
         ELSE
C
            DO 80 J = 1, N
               DJ = D(J)
               DO 70 I = J, N
                  A(I,J) = ( DJ/D(I) )*A(I,J)
   70          CONTINUE
   80       CONTINUE
C
         END IF
C
      END IF
C
      RETURN
C *** Last line of MB01SS ***
      END


C-----------------------------------------------------------------------
      SUBROUTINE SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP,
     &                   F,SPC,SPCTOP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPANALY     ANALYZE SPECTRAL FROM FOURIER
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: ANALYZES SPECTRAL COEFFICIENTS FROM FOURIER COEFFICIENTS
C           FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES).
C           VECTOR COMPONENTS ARE MULTIPLIED BY COSINE OF LATITUDE.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C   94-08-01  MARK IREDELL   MOVED ZONAL WAVENUMBER LOOP INSIDE
C 1998-12-15  IREDELL  OPENMP DIRECTIVES INSERTED
C
C USAGE:    CALL SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP,
C    &                   F,SPC,SPCTOP)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     IM       - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS
C     IX       - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2)
C     NC       - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS
C                (NC>=(M+1)*((I+1)*M+2))
C     NCTOP    - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP
C                (NCTOP>=2*(M+1))
C     KM       - INTEGER NUMBER OF FIELDS
C     WGT      - REAL GAUSSIAN WEIGHT
C     CLAT     - REAL COSINE OF LATITUDE
C     PLN      - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIALS
C     PLNTOP   - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP
C     MP       - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR)
C     F        - REAL (IX,2,KM) FOURIER COEFFICIENTS COMBINED
C     SPC      - REAL (NC,KM) SPECTRAL COEFFICIENTS
C     SPCTOP   - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP
C
C   OUTPUT ARGUMENT LIST:
C     SPC      - REAL (NC,KM) SPECTRAL COEFFICIENTS
C     SPCTOP   - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      INTEGER MP(KM)
      REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
      REAL F(IX,2,KM)
      REAL SPC(NC,KM),SPCTOP(NCTOP,KM)
      REAL FW(2,2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  FOR EACH ZONAL WAVENUMBER, ANALYZE TERMS OVER TOTAL WAVENUMBER.
C  ANALYZE EVEN AND ODD POLYNOMIALS SEPARATELY.
      LX=MIN(M,IM/2)
!C$OMP PARALLEL DO PRIVATE(L,NT,KS,KP,FW)
      DO K=1,KM
        DO L=0,LX
          NT=MOD(M+1+(I-1)*L,2)+1
          KS=L*(2*M+(I-1)*(L-1))
          KP=KS/2+1
          IF(MP(K).EQ.0) THEN
            FW(1,1)=WGT*(F(2*L+1,1,K)+F(2*L+1,2,K))
            FW(2,1)=WGT*(F(2*L+2,1,K)+F(2*L+2,2,K))
            FW(1,2)=WGT*(F(2*L+1,1,K)-F(2*L+1,2,K))
            FW(2,2)=WGT*(F(2*L+2,1,K)-F(2*L+2,2,K))
          ELSE
            FW(1,1)=WGT*CLAT*(F(2*L+1,1,K)+F(2*L+1,2,K))
            FW(2,1)=WGT*CLAT*(F(2*L+2,1,K)+F(2*L+2,2,K))
            FW(1,2)=WGT*CLAT*(F(2*L+1,1,K)-F(2*L+1,2,K))
            FW(2,2)=WGT*CLAT*(F(2*L+2,1,K)-F(2*L+2,2,K))
            SPCTOP(2*L+1,K)=SPCTOP(2*L+1,K)+PLNTOP(L+1)*FW(1,NT)
            SPCTOP(2*L+2,K)=SPCTOP(2*L+2,K)+PLNTOP(L+1)*FW(2,NT)
          ENDIF
          DO N=L,I*L+M,2
            SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,1)
            SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,1)
          ENDDO
          DO N=L+1,I*L+M,2
            SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,2)
            SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,2)
          ENDDO
        ENDDO
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


module lub
use prutil
use in_out

contains
! calculate the lubrication contribution to rfu rfe rsu rse
! rfu is symmetric
! rfe = transpose of rsu
! rse is symmetric
subroutine lubmxcalc(ntotal,p_pos,rfu,rfe,rsu,rse)
implicit none
integer, intent(in) :: ntotal
real(kind=cp), dimension(ntotal,3), intent(in) :: p_pos
real(kind=SP), dimension(6*ntotal,6*ntotal), intent(out) :: rfu
real(kind=SP), dimension(6*ntotal,5*ntotal), intent(out) :: rfe
real(kind=SP), dimension(5*ntotal,6*ntotal), intent(out) :: rsu
real(kind=SP), dimension(5*ntotal,5*ntotal), intent(out) :: rse

real(kind=cp) :: r,r1,r2,r3
real(kind=cp) :: x11a,x12a,y11a,y12a,y11b,y12b,x11c,x12c,y11c,y12c
real(kind=cp) :: x11g,x12g,y11g,y12g,y11h,y12h,xm,ym,zm
real(kind=cp), dimension(3) :: e
real(kind=cp), dimension(22,22) :: lub2bmx
real(kind=cp), dimension(2,2,3,3) :: alub
real(kind=cp), dimension(2,2,3,3) :: blub
real(kind=cp), dimension(2,2,3,3) :: club
real(kind=cp), dimension(2,2,3,3,3) :: glubtensor
real(kind=cp), dimension(2,2,3,3,3) :: hlubtensor
real(kind=cp), dimension(3,3,3,3) :: mlubtensor
real(kind=cp), dimension(5,5) :: mmx

integer :: alpha,beta
integer :: i,j,k,l

rfu=0.0_SP
rfe=0.0_SP
rsu=0.0_SP
rse=0.0_SP

do alpha=1,ntotal
        do beta=alpha+1,ntotal
        r1=p_pos(beta,1)-p_pos(alpha,1)
        r2=p_pos(beta,2)-p_pos(alpha,2)
        r3=p_pos(beta,3)-p_pos(alpha,3)
        r=sqrt(r1*r1+r2*r2+r3*r3)
        lub2bmx=0.0_cp
        alub=0.0_cp
        blub=0.0_cp
        club=0.0_cp
        glubtensor=0.0_cp
        hlubtensor=0.0_cp
        mlubtensor=0.0_cp

        if(r.lt.2.0_cp) then
                write(*,*) 'Contact Error, r='
                write(*,*) r,alpha,beta
                stop
        else if(r.gt.4.0_cp) then
                lub2bmx=0.0_cp
        else
        ! initialize the lub2bmx matrix
        ! build the 2body lubrication resistance matrix lub2bmx(22*22)
        call lubcalc(r,x11a,x12a,y11a,y12a,y11b,y12b,x11c,x12c,y11c,y12c,&
                        & x11g,x12g,y11g,y12g,y11h,y12h,xm,ym,zm)

        e(1)=r1/r
        e(2)=r2/r
        e(3)=r3/r

        forall(i=1:3,j=1:3)
        alub(1,1,i,j)=x11a*e(i)*e(j)+y11a*(kd(i,j)-e(i)*e(j))
        alub(1,2,i,j)=x12a*e(i)*e(j)+y12a*(kd(i,j)-e(i)*e(j))
        blub(1,1,i,j)=y11b*(per(i,j,1)*e(1)+per(i,j,2)*e(2)+per(i,j,3)*e(3))
        blub(1,2,i,j)=y12b*(per(i,j,1)*e(1)+per(i,j,2)*e(2)+per(i,j,3)*e(3))
        club(1,1,i,j)=x11c*e(i)*e(j)+y11c*(kd(i,j)-e(i)*e(j))
        club(1,2,i,j)=x12c*e(i)*e(j)+y12c*(kd(i,j)-e(i)*e(j))
        end forall

        forall(i=1:3,j=1:3,k=1:3)
        glubtensor(1,1,i,j,k)=x11g*(e(i)*e(j)-kd(i,j)/3.0_cp)*e(k)&
        &+y11g*(e(i)*kd(j,k)+e(j)*kd(i,k)-2*e(i)*e(j)*e(k))
        glubtensor(1,2,i,j,k)=x12g*(e(i)*e(j)-kd(i,j)/3.0_cp)*e(k)&
        &+y12g*(e(i)*kd(j,k)+e(j)*kd(i,k)-2*e(i)*e(j)*e(k))
        hlubtensor(1,1,i,j,k)=y11h*((per(i,k,1)*e(1)+per(i,k,2)*e(2)+&
        &per(i,k,3)*e(3))*e(j) + (per(j,k,1)*e(1)+per(j,k,2)*e(2)+&
        &per(j,k,3)*e(3))*e(i))
        hlubtensor(1,2,i,j,k)=y12h*((per(i,k,1)*e(1)+per(i,k,2)*e(2)+&
        &per(i,k,3)*e(3))*e(j) + (per(j,k,1)*e(1)+per(j,k,2)*e(2)+&
        &per(j,k,3)*e(3))*e(i))
        end forall

        forall(i=1:3,j=1:3,k=1:3,l=1:3)
        mlubtensor(i,j,k,l)=xm*(3.0_cp*(e(i)*e(j)-kd(i,j)/3.0_cp)*(e(k)*e(l)&
        & -kd(k,l)/3.0_cp)/2.0_cp)+ym*(e(i)*kd(j,l)*e(k)+e(j)*kd(i,l)*e(k)&
        & +e(i)*kd(j,k)*e(l)+e(j)*kd(i,k)*e(l)-4.0_cp*e(i)*e(j)*e(k)*e(l))&
        & /2.0_cp+zm*(kd(i,k)*kd(j,l)+kd(j,k)*kd(i,l)-kd(i,j)*kd(k,l)&
        & +e(i)*e(j)*kd(k,l)+kd(i,j)*e(k)*e(l)-e(i)*kd(j,l)*e(k)&
        & -e(j)*kd(i,l)*e(k)-e(i)*kd(j,k)*e(l)-e(j)*kd(i,k)*e(l)&
        & +e(i)*e(j)*e(k)*e(l))/2.0_cp
        end forall

        forall(i=1:3,j=1:3)
        alub(2,2,i,j)=alub(1,1,i,j) !x22a=x11a,y22a=y11a
        alub(2,1,i,j)=alub(1,2,i,j) !x12a=x21a,y12a=y21a
        blub(2,2,i,j)=-blub(1,1,i,j) !y11b=-y22b
        blub(2,1,i,j)=-blub(1,2,i,j) !y12b=-y21b
        club(2,2,i,j)=club(1,1,i,j) !x11c=x22c
        club(2,1,i,j)=club(1,2,i,j) !x21c=x12c
        end forall

        forall(i=1:3,j=1:3,k=1:3)
        glubtensor(2,2,i,j,k)=-glubtensor(1,1,i,j,k) ! x22g=-x11g, y22g=-y11g
        glubtensor(2,1,i,j,k)=-glubtensor(1,2,i,j,k) ! x21g=-x12g, y21g=-y12g
        hlubtensor(2,2,i,j,k)=hlubtensor(1,1,i,j,k) !  y22h=y11h
        hlubtensor(2,1,i,j,k)=hlubtensor(1,2,i,j,k) ! y21h=y12h
        end forall

        forall(i=1:3,j=1:3)
                ! fill in abc
                lub2bmx(i,j)=alub(1,1,i,j)
                lub2bmx(i+3,j)=alub(2,1,i,j)
                lub2bmx(i,j+3)=alub(1,2,i,j)
                lub2bmx(i+3,j+3)=alub(2,2,i,j)
                lub2bmx(6+i,6+j)=club(1,1,i,j)
                lub2bmx(9+i,6+j)=club(2,1,i,j)
                lub2bmx(6+i,9+j)=club(1,2,i,j)
                lub2bmx(9+i,9+j)=club(2,2,i,j)
                lub2bmx(6+i,j)=blub(1,1,i,j)
                lub2bmx(6+i,3+j)=blub(1,2,i,j)
                lub2bmx(9+i,j)=blub(2,1,i,j)
                lub2bmx(9+i,3+j)=blub(2,2,i,j)
                ! fill in btilda by symmetry
                lub2bmx(j,6+i)=blub(1,1,i,j)
                lub2bmx(3+j,6+i)=blub(1,2,i,j)
                lub2bmx(j,9+i)=blub(2,1,i,j)
                lub2bmx(3+j,9+i)=blub(2,2,i,j)
        end forall

        forall(j=1:3)
                ! fill in g & h
                ! ev1=e11-e33 ev2=2e12 ev3=2e13 ev4=2e23 ev5=e22-e33
                ! sv1=s11 sv2=s12=s21 sv3=s13=s31 sv4=s23=s32 sv5=s22
                lub2bmx(13,j)=glubtensor(1,1,1,1,j)
                lub2bmx(14,j)=glubtensor(1,1,1,2,j)
                lub2bmx(15,j)=glubtensor(1,1,1,3,j)
                lub2bmx(16,j)=glubtensor(1,1,2,3,j)
                lub2bmx(17,j)=glubtensor(1,1,2,2,j)
                lub2bmx(18,j)=glubtensor(2,1,1,1,j)
                lub2bmx(19,j)=glubtensor(2,1,1,2,j)
                lub2bmx(20,j)=glubtensor(2,1,1,3,j)
                lub2bmx(21,j)=glubtensor(2,1,2,3,j)
                lub2bmx(22,j)=glubtensor(2,1,2,2,j)
                lub2bmx(13,3+j)=glubtensor(1,2,1,1,j)
                lub2bmx(14,3+j)=glubtensor(1,2,1,2,j)
                lub2bmx(15,3+j)=glubtensor(1,2,1,3,j)
                lub2bmx(16,3+j)=glubtensor(1,2,2,3,j)
                lub2bmx(17,3+j)=glubtensor(1,2,2,2,j)
                lub2bmx(18,3+j)=glubtensor(2,2,1,1,j)
                lub2bmx(19,3+j)=glubtensor(2,2,1,2,j)
                lub2bmx(20,3+j)=glubtensor(2,2,1,3,j)
                lub2bmx(21,3+j)=glubtensor(2,2,2,3,j)
                lub2bmx(22,3+j)=glubtensor(2,2,2,2,j)
                lub2bmx(j,13)=glubtensor(1,1,1,1,j)
                lub2bmx(j,14)=glubtensor(1,1,1,2,j)
                lub2bmx(j,15)=glubtensor(1,1,1,3,j)
                lub2bmx(j,16)=glubtensor(1,1,2,3,j)
                lub2bmx(j,17)=glubtensor(1,1,2,2,j)
                lub2bmx(j,18)=glubtensor(2,1,1,1,j)
                lub2bmx(j,19)=glubtensor(2,1,1,2,j)
                lub2bmx(j,20)=glubtensor(2,1,1,3,j)
                lub2bmx(j,21)=glubtensor(2,1,2,3,j)
                lub2bmx(j,22)=glubtensor(2,1,2,2,j)
                lub2bmx(3+j,13)=glubtensor(1,2,1,1,j)
                lub2bmx(3+j,14)=glubtensor(1,2,1,2,j)
                lub2bmx(3+j,15)=glubtensor(1,2,1,3,j)
                lub2bmx(3+j,16)=glubtensor(1,2,2,3,j)
                lub2bmx(3+j,17)=glubtensor(1,2,2,2,j)
                lub2bmx(3+j,18)=glubtensor(2,2,1,1,j)
                lub2bmx(3+j,19)=glubtensor(2,2,1,2,j)
                lub2bmx(3+j,20)=glubtensor(2,2,1,3,j)
                lub2bmx(3+j,21)=glubtensor(2,2,2,3,j)
                lub2bmx(3+j,22)=glubtensor(2,2,2,2,j)

                lub2bmx(13,6+j)=hlubtensor(1,1,1,1,j)
                lub2bmx(14,6+j)=hlubtensor(1,1,1,2,j)
                lub2bmx(15,6+j)=hlubtensor(1,1,1,3,j)
                lub2bmx(16,6+j)=hlubtensor(1,1,2,3,j)
                lub2bmx(17,6+j)=hlubtensor(1,1,2,2,j)
                lub2bmx(18,6+j)=hlubtensor(2,1,1,1,j)
                lub2bmx(19,6+j)=hlubtensor(2,1,1,2,j)
                lub2bmx(20,6+j)=hlubtensor(2,1,1,3,j)
                lub2bmx(21,6+j)=hlubtensor(2,1,2,3,j)
                lub2bmx(22,6+j)=hlubtensor(2,1,2,2,j)
                lub2bmx(13,9+j)=hlubtensor(1,2,1,1,j)
                lub2bmx(14,9+j)=hlubtensor(1,2,1,2,j)
                lub2bmx(15,9+j)=hlubtensor(1,2,1,3,j)
                lub2bmx(16,9+j)=hlubtensor(1,2,2,3,j)
                lub2bmx(17,9+j)=hlubtensor(1,2,2,2,j)
                lub2bmx(18,9+j)=hlubtensor(2,2,1,1,j)
                lub2bmx(19,9+j)=hlubtensor(2,2,1,2,j)
                lub2bmx(20,9+j)=hlubtensor(2,2,1,3,j)
                lub2bmx(21,9+j)=hlubtensor(2,2,2,3,j)
                lub2bmx(22,9+j)=hlubtensor(2,2,2,2,j)
                lub2bmx(6+j,13)=hlubtensor(1,1,1,1,j)
                lub2bmx(6+j,14)=hlubtensor(1,1,1,2,j)
                lub2bmx(6+j,15)=hlubtensor(1,1,1,3,j)
                lub2bmx(6+j,16)=hlubtensor(1,1,2,3,j)
                lub2bmx(6+j,17)=hlubtensor(1,1,2,2,j)
                lub2bmx(6+j,18)=hlubtensor(2,1,1,1,j)
                lub2bmx(6+j,19)=hlubtensor(2,1,1,2,j)
                lub2bmx(6+j,20)=hlubtensor(2,1,1,3,j)
                lub2bmx(6+j,21)=hlubtensor(2,1,2,3,j)
                lub2bmx(6+j,22)=hlubtensor(2,1,2,2,j)
                lub2bmx(9+j,13)=hlubtensor(1,2,1,1,j)
                lub2bmx(9+j,14)=hlubtensor(1,2,1,2,j)
                lub2bmx(9+j,15)=hlubtensor(1,2,1,3,j)
                lub2bmx(9+j,16)=hlubtensor(1,2,2,3,j)
                lub2bmx(9+j,17)=hlubtensor(1,2,2,2,j)
                lub2bmx(9+j,18)=hlubtensor(2,2,1,1,j)
                lub2bmx(9+j,19)=hlubtensor(2,2,1,2,j)
                lub2bmx(9+j,20)=hlubtensor(2,2,1,3,j)
                lub2bmx(9+j,21)=hlubtensor(2,2,2,3,j)
                lub2bmx(9+j,22)=hlubtensor(2,2,2,2,j)

                ! the rewritted matrix is symmetric

        end forall

                !fill in m11
                mmx(1,1)=(2.0_cp*mlubtensor(1,1,1,1) &
                & -mlubtensor(1,1,2,2)-mlubtensor(1,1,3,3))/3.0_cp
                mmx(1,2)=(mlubtensor(1,1,1,2)+mlubtensor(1,1,2,1))/2.0_cp
                mmx(1,3)=(mlubtensor(1,1,1,3)+mlubtensor(1,1,3,1))/2.0_cp
                mmx(1,4)=(mlubtensor(1,1,2,3)+mlubtensor(1,1,3,2))/2.0_cp
                mmx(1,5)=(2.0_cp*mlubtensor(1,1,2,2) &
                & -mlubtensor(1,1,1,1)-mlubtensor(1,1,3,3))/3.0_cp

                mmx(2,1)=(2.0_cp*mlubtensor(1,2,1,1) &
                & -mlubtensor(1,2,2,2)-mlubtensor(1,2,3,3))/3.0_cp
                mmx(2,2)=(mlubtensor(1,2,1,2)+mlubtensor(1,2,2,1))/2.0_cp
                mmx(2,3)=(mlubtensor(1,2,1,3)+mlubtensor(1,2,3,1))/2.0_cp
                mmx(2,4)=(mlubtensor(1,2,2,3)+mlubtensor(1,2,3,2))/2.0_cp
                mmx(2,5)=(2.0_cp*mlubtensor(1,2,2,2) &
                & -mlubtensor(1,2,1,1)-mlubtensor(1,2,3,3))/3.0_cp

                mmx(3,1)=(2.0_cp*mlubtensor(1,3,1,1) &
                & -mlubtensor(1,3,2,2)-mlubtensor(1,3,3,3))/3.0_cp
                mmx(3,2)=(mlubtensor(1,3,1,2)+mlubtensor(1,3,2,1))/2.0_cp
                mmx(3,3)=(mlubtensor(1,3,1,3)+mlubtensor(1,3,3,1))/2.0_cp
                mmx(3,4)=(mlubtensor(1,3,2,3)+mlubtensor(1,3,3,2))/2.0_cp
                mmx(3,5)=(2.0_cp*mlubtensor(1,3,2,2) &
                & -mlubtensor(1,3,1,1)-mlubtensor(1,3,3,3))/3.0_cp

                mmx(4,1)=(2.0_cp*mlubtensor(2,3,1,1) &
                & -mlubtensor(2,3,2,2)-mlubtensor(2,3,3,3))/3.0_cp
                mmx(4,2)=(mlubtensor(2,3,1,2)+mlubtensor(2,3,2,1))/2.0_cp
                mmx(4,3)=(mlubtensor(2,3,1,3)+mlubtensor(2,3,3,1))/2.0_cp
                mmx(4,4)=(mlubtensor(2,3,2,3)+mlubtensor(2,3,3,2))/2.0_cp
                mmx(4,5)=(2.0_cp*mlubtensor(2,3,2,2) &
                & -mlubtensor(2,3,1,1)-mlubtensor(2,3,3,3))/3.0_cp

                mmx(5,1)=(2.0_cp*mlubtensor(2,2,1,1) &
                & -mlubtensor(2,2,2,2)-mlubtensor(2,2,3,3))/3.0_cp
                mmx(5,2)=(mlubtensor(2,2,1,2)+mlubtensor(2,2,2,1))/2.0_cp
                mmx(5,3)=(mlubtensor(2,2,1,3)+mlubtensor(2,2,3,1))/2.0_cp
                mmx(5,4)=(mlubtensor(2,2,2,3)+mlubtensor(2,2,3,2))/2.0_cp
                mmx(5,5)=(2.0_cp*mlubtensor(2,2,2,2) &
                & -mlubtensor(2,2,1,1)-mlubtensor(2,2,3,3))/3.0_cp

                !replicate m11 to m12,m21,m22
                forall(i=1:5,j=1:5)
                        lub2bmx(12+i,12+j)=mmx(i,j)
                        lub2bmx(17+i,12+j)=mmx(i,j)
                        lub2bmx(12+i,17+j)=mmx(i,j)
                        lub2bmx(17+i,17+j)=mmx(i,j)
                end forall
        end if

        ! add the lub2bmx to rfu , rsu , rse
        ! step1: add a,b,btilda,c to rfu
        forall(i=1:3,j=1:3)
        ! a
        rfu(3*(alpha-1)+i,3*(alpha-1)+j)=rfu(3*(alpha-1)+i,3*(alpha-1)+j)&
        & +lub2bmx(i,j) ! a alpha alpha
        rfu(3*(alpha-1)+i,3*(beta-1)+j)=rfu(3*(alpha-1)+i,3*(beta-1)+j)&
        & +lub2bmx(i,3+j) ! a alpha beta
        rfu(3*(beta-1)+i,3*(alpha-1)+j)=rfu(3*(beta-1)+i,3*(alpha-1)+j)&
        & +lub2bmx(3+i,j) ! a beta alpha
        rfu(3*(beta-1)+i,3*(beta-1)+j)=rfu(3*(beta-1)+i,3*(beta-1)+j)&
        & +lub2bmx(3+i,3+j) ! a beta beta
        ! b
        rfu(3*ntotal+3*(alpha-1)+i,3*(alpha-1)+j)=rfu(3*ntotal+3*(alpha-1)&
        & +i,3*(alpha-1)+j)+lub2bmx(6+i,j) !balphaalpha
        rfu(3*ntotal+3*(alpha-1)+i,3*(beta-1)+j)=rfu(3*ntotal+3*(alpha-1)&
        & +i,3*(beta-1)+j)+lub2bmx(6+i,3+j) !balphabeta
        rfu(3*ntotal+3*(beta-1)+i,3*(alpha-1)+j)=rfu(3*ntotal+3*(beta-1)&
        & +i,3*(alpha-1)+j)+lub2bmx(9+i,j) !b beta alpha
        rfu(3*ntotal+3*(beta-1)+i,3*(beta-1)+j)=rfu(3*ntotal+3*(beta-1)&
        & +i,3*(beta-1)+j)+lub2bmx(9+i,3+j) !b beta beta
        ! btilda by symmetry
        rfu(3*(alpha-1)+j,3*ntotal+3*(alpha-1)+i)=rfu(3*(alpha-1)+j,&
        & 3*ntotal+3*(alpha-1)+i)+lub2bmx(6+i,j) !balphaalpha
        rfu(3*(beta-1)+j,3*ntotal+3*(alpha-1)+i)=rfu(3*(beta-1)+j,&
        & 3*ntotal+3*(alpha-1)+i)+lub2bmx(6+i,3+j) !balphabeta
        rfu(3*(alpha-1)+j,3*ntotal+3*(beta-1)+i)=rfu(3*(alpha-1)+j,&
        & 3*ntotal+3*(beta-1)+i)+lub2bmx(9+i,j) !b beta alpha
        rfu(3*(beta-1)+j,3*ntotal+3*(beta-1)+i)=rfu(3*(beta-1)+j,&
        & 3*ntotal+3*(beta-1)+i)+lub2bmx(9+i,3+j) !b beta beta
        ! c
        rfu(3*ntotal+3*(alpha-1)+i,3*ntotal+3*(alpha-1)+j)=rfu(3*ntotal&
        & +3*(alpha-1)+i,3*ntotal+3*(alpha-1)+j)+lub2bmx(6+i,6+j) !c a a
        rfu(3*ntotal+3*(alpha-1)+i,3*ntotal+3*(beta-1)+j)=rfu(3*ntotal&
        & +3*(alpha-1)+i,3*ntotal+3*(beta-1)+j)+lub2bmx(6+i,9+j) !c a b
        rfu(3*ntotal+3*(beta-1)+i,3*ntotal+3*(alpha-1)+j)=rfu(3*ntotal&
        & +3*(beta-1)+i,3*ntotal+3*(alpha-1)+j)+lub2bmx(9+i,6+j) !c b a
        rfu(3*ntotal+3*(beta-1)+i,3*ntotal+3*(beta-1)+j)=rfu(3*ntotal&
        & +3*(beta-1)+i,3*ntotal+3*(beta-1)+j)+lub2bmx(9+i,9+j) !c b b
        end forall

        !step2: add g & h to rsu
        forall(i=1:5,j=1:3)
        ! g
        rsu(5*(alpha-1)+i,3*(alpha-1)+j)=rsu(5*(alpha-1)+i,3*(alpha-1)+j)&
        & +lub2bmx(12+i,j) ! g a a
        rsu(5*(alpha-1)+i,3*(beta-1)+j)=rsu(5*(alpha-1)+i,3*(beta-1)+j)&
        & +lub2bmx(12+i,3+j) ! g a b
        rsu(5*(beta-1)+i,3*(alpha-1)+j)=rsu(5*(beta-1)+i,3*(alpha-1)+j)&
        & +lub2bmx(17+i,j) ! g b a
        rsu(5*(beta-1)+i,3*(beta-1)+j)=rsu(5*(beta-1)+i,3*(beta-1)+j)&
        & +lub2bmx(17+i,3+j) ! g b b
        ! h
        rsu(5*(alpha-1)+i,3*(alpha-1)+j+3*ntotal)=&
        & rsu(5*(alpha-1)+i,3*(alpha-1)+j+3*ntotal)+lub2bmx(12+i,6+j) ! h a a
        rsu(5*(alpha-1)+i,3*(beta-1)+j+3*ntotal)=&
        & rsu(5*(alpha-1)+i,3*(beta-1)+j+3*ntotal)+lub2bmx(12+i,9+j) ! h a b
        rsu(5*(beta-1)+i,3*(alpha-1)+j+3*ntotal)=&
        & rsu(5*(beta-1)+i,3*(alpha-1)+j+3*ntotal)+lub2bmx(17+i,6+j) ! h b a
        rsu(5*(beta-1)+i,3*(beta-1)+j+3*ntotal)=&
        & rsu(5*(beta-1)+i,3*(beta-1)+j+3*ntotal)+lub2bmx(17+i,9+j) ! h b b
        end forall

        !step3: add m to rse
        forall(i=1:5,j=1:5)
        rse(5*(alpha-1)+i,5*(alpha-1)+j)=rse(5*(alpha-1)+i,5*(alpha-1)+j)&
        & +lub2bmx(12+i,12+j) ! m a a
        rse(5*(alpha-1)+i,5*(beta-1)+j)=rse(5*(alpha-1)+i,5*(beta-1)+j)&
        & +lub2bmx(12+i,17+j) ! m a b
        rse(5*(beta-1)+i,5*(alpha-1)+j)=rse(5*(beta-1)+i,5*(alpha-1)+j)&
        & +lub2bmx(17+i,12+j) ! m b a
        rse(5*(beta-1)+i,5*(beta-1)+j)=rse(5*(beta-1)+i,5*(beta-1)+j)&
        & +lub2bmx(17+i,17+j) ! m b b
        end forall

        !step4: fill rfe by symmetry with rsu
        forall(i=1:6*ntotal,j=1:5*ntotal)
        rfe(i,j)=rsu(j,i)
        endforall

        ! output rfu rfe rsu rse for debugging
        !open(unit=2001,file='rfu',status='replace')
        !write(*,*) rfu
        !close(unit=2001)
        !open(unit=2002,file='rfe',status='replace')
        !write(*,*) rfe
        !close(unit=2002)
        !open(unit=2003,file='rsu',status='replace')
        !write(*,*) rsu
        !close(unit=2003)
        !open(unit=2004,file='rse',status='replace')
        !write(*,*) rse
        !close(unit=2004)

        end do
end do

end subroutine lubmxcalc

subroutine lubcalc(r,x11a,x12a,y11a,y12a,y11b,y12b,x11c,x12c,y11c,y12c,&
 & x11g,x12g,y11g,y12g,y11h,y12h,xm,ym,zm)
implicit none
real(kind=cp), intent(in) :: r
real(kind=cp), intent(out) :: x11a
real(kind=cp), intent(out) :: x12a
real(kind=cp), intent(out) :: y11a
real(kind=cp), intent(out) :: y12a
real(kind=cp), intent(out) :: y11b
real(kind=cp), intent(out) :: y12b
real(kind=cp), intent(out) :: x11c
real(kind=cp), intent(out) :: x12c
real(kind=cp), intent(out) :: y11c
real(kind=cp), intent(out) :: y12c
real(kind=cp), intent(out) :: x11g
real(kind=cp), intent(out) :: x12g
real(kind=cp), intent(out) :: y11g
real(kind=cp), intent(out) :: y12g
real(kind=cp), intent(out) :: y11h
real(kind=cp), intent(out) :: y12h
real(kind=cp), intent(out) :: xm
real(kind=cp), intent(out) :: ym
real(kind=cp), intent(out) :: zm

real(kind=cp) :: xi
real(kind=cp) :: invxi
real(kind=cp) :: loginvxi
real(kind=cp) :: xiloginvxi

if (r.lt.2.1_cp) then
        xi=r-2.0_cp
        invxi=1.0_cp/xi
        loginvxi=log(invxi)
        xiloginvxi=xi*loginvxi

        x11a=-1.23041_cp+0.25_cp*invxi+1.8918_cp*xi+9.0_cp*loginvxi/40.0_cp &
        &+3.0_cp*xiloginvxi/112.0_cp
        x12a=-x11a+0.00312_cp-0.0011_cp*xi

        y11a=-0.39394_cp+0.95665_cp*xi+loginvxi/6.0_cp
        y12a=-y11a+0.004636_cp-0.007049_cp*xi

        y11b=0.408286_cp-0.84055_cp*xi-loginvxi/6.0_cp-xiloginvxi/12.0_cp

        x11c=0.0479_cp+0.12494_cp*xi-xiloginvxi/6.0_cp
        x12c=-x11c+0.016869_cp+0.049536_cp*xi

        y11c=-0.605434_cp+0.939139_cp*xi+4.0_cp*loginvxi/15.0_cp &
        &+94.0_cp*xiloginvxi/375.0_cp
        !y12c corrected, compare to the old code. 62/375
        !y12c tabulated data is the same
        y12c=loginvxi/15.0_cp+62.0_cp*xiloginvxi/375.0_cp-0.219032_cp&
        &+0.332843_cp*xi
        y12b=-0.405978_cp+0.833042_cp*xi+loginvxi/6.0_cp+xiloginvxi/12.0_cp

        x11g=-1.16897_cp+1.47882_cp*xi+invxi/4.0_cp &
        &+9.0_cp*loginvxi/40.0_cp+39.0_cp*xiloginvxi/280.0_cp
        x12g=-x11g+0.01_cp-0.00167_cp*xi

        y11g=-0.2041_cp+0.44226_cp*xi+loginvxi/12.0_cp+xiloginvxi/24.0_cp
        y12g=-y11g+0.012265_cp-0.02757_cp*xi

        y11h=-0.143777_cp+0.264207_cp*xi+loginvxi/30.0_cp &
        &+137.0_cp*xiloginvxi/1500.0_cp
        y12h=-0.298166_cp+0.534123_cp*xi+2.0_cp*loginvxi/15.0_cp &
        &+113.0_cp*xiloginvxi/1500.0_cp

        ! pay attention to m terms. here, in the equation,
        ! xm=(x11m+x12m)/2, ym=(y11m+y12m)/2, zm=(z11m+z12m)/2
        ! however, in the tabulated data, the data are
        ! (x11m+x12m), (y11m+y12m), (z11m+z12m)
        ! so, in the tabcalc function,
        ! xm ym zm tab values should be divided by 2
        ! this gives the same results as all the old codes

        xm=invxi/6.0_cp+3.0_cp*loginvxi/20.0_cp+47.0_cp*xiloginvxi/280.0_cp&
        & -0.740815_cp+0.706802_cp*xi
        ! the ym equation contains an extra term (xiloginvxi)
        ! compared to the old code, so the O(1), O(xi) terms are modified
        ym=-0.193518_cp+0.553883_cp*xi+loginvxi/12.0_cp&
        & -29.0_cp*xiloginvxi/500.0_cp
        ! the zm equation & tabulation are not modified
        zm = 0.00645755_cp - 0.021142_cp * xi
else
        call lubtabcalc(r,x11a,x12a,y11a,y12a,y11b,y12b,x11c,x12c,y11c,y12c,&
 & x11g,x12g,y11g,y12g,y11h,y12h,xm,ym,zm)
end if

end subroutine lubcalc

subroutine lubtabcalc(r,x11a,x12a,y11a,y12a,y11b,y12b,x11c,x12c,y11c,y12c,&
 & x11g,x12g,y11g,y12g,y11h,y12h,xm,ym,zm)
implicit none

real(kind=cp), intent(in) :: r
real(kind=cp), intent(out) :: x11a
real(kind=cp), intent(out) :: x12a
real(kind=cp), intent(out) :: y11a
real(kind=cp), intent(out) :: y12a
real(kind=cp), intent(out) :: y11b
real(kind=cp), intent(out) :: y12b
real(kind=cp), intent(out) :: x11c
real(kind=cp), intent(out) :: x12c
real(kind=cp), intent(out) :: y11c
real(kind=cp), intent(out) :: y12c
real(kind=cp), intent(out) :: x11g
real(kind=cp), intent(out) :: x12g
real(kind=cp), intent(out) :: y11g
real(kind=cp), intent(out) :: y12g
real(kind=cp), intent(out) :: y11h
real(kind=cp), intent(out) :: y12h
real(kind=cp), intent(out) :: xm
real(kind=cp), intent(out) :: ym
real(kind=cp), intent(out) :: zm

integer, parameter :: ntabc=39
real(kind=cp),dimension(ntabc) , save :: trabc
real(kind=cp),dimension(ntabc) , save:: tx11a
real(kind=cp),dimension(ntabc) , save:: tx12a
real(kind=cp),dimension(ntabc) , save:: ty11a
real(kind=cp),dimension(ntabc) , save:: ty12a
real(kind=cp),dimension(ntabc) , save:: ty11b
real(kind=cp),dimension(ntabc) , save:: ty12b
real(kind=cp),dimension(ntabc) , save:: tx11c
real(kind=cp),dimension(ntabc) , save:: tx12c
real(kind=cp),dimension(ntabc) , save:: ty11c
real(kind=cp),dimension(ntabc) , save:: ty12c

integer, parameter :: ntgh=47
real(kind=cp),dimension(ntgh) , save:: trgh
real(kind=cp),dimension(ntgh) , save:: tx11g
real(kind=cp),dimension(ntgh) , save:: tx12g
real(kind=cp),dimension(ntgh) , save:: ty11g
real(kind=cp),dimension(ntgh) , save:: ty12g
real(kind=cp),dimension(ntgh) , save:: ty11h
real(kind=cp),dimension(ntgh) , save:: ty12h

integer, parameter :: ntm=47
real(kind=cp),dimension(ntm) , save:: trm
real(kind=cp),dimension(ntm) , save:: txm
real(kind=cp),dimension(ntm) , save:: tym
real(kind=cp),dimension(ntm) , save:: tzm

integer :: i

integer, save :: readflag=0

if (readflag.eq.0) then

call readlubabc(ntabc,trabc,tx11a,tx12a,ty11a,ty12a,ty11b,ty12b,&
                &tx11c,tx12c,ty11c,ty12c)
call readlubgh(ntgh,trgh,tx11g,tx12g,ty11g,ty12g,ty11h,ty12h)
call readlubm(ntm,trm,txm,tym,tzm)

readflag = 1
end if

x11a=0
x12a=0
y11a=0
y12a=0
y11b=0
y12b=0
x11c=0
x12c=0
y11c=0
y12c=0
x11g=0
x12g=0
y11g=0
y12g=0
y11h=0
y12h=0
xm=0
ym=0
zm=0

do i=1,ntabc-1
        if((trabc(i).le.r).and.(trabc(i+1).gt.r)) then
        x11a=tx11a(i)+(r-trabc(i))*(tx11a(i+1)-tx11a(i))/(trabc(i+1)-trabc(i))
        x12a=tx12a(i)+(r-trabc(i))*(tx12a(i+1)-tx12a(i))/(trabc(i+1)-trabc(i))
        y11a=ty11a(i)+(r-trabc(i))*(ty11a(i+1)-ty11a(i))/(trabc(i+1)-trabc(i))
        y12a=ty12a(i)+(r-trabc(i))*(ty12a(i+1)-ty12a(i))/(trabc(i+1)-trabc(i))
        y11b=ty11b(i)+(r-trabc(i))*(ty11b(i+1)-ty11b(i))/(trabc(i+1)-trabc(i))
        y12b=ty12b(i)+(r-trabc(i))*(ty12b(i+1)-ty12b(i))/(trabc(i+1)-trabc(i))
        x11c=tx11c(i)+(r-trabc(i))*(tx11c(i+1)-tx11c(i))/(trabc(i+1)-trabc(i))
        x12c=tx12c(i)+(r-trabc(i))*(tx12c(i+1)-tx12c(i))/(trabc(i+1)-trabc(i))
        y11c=ty11c(i)+(r-trabc(i))*(ty11c(i+1)-ty11c(i))/(trabc(i+1)-trabc(i))
        y12c=ty12c(i)+(r-trabc(i))*(ty12c(i+1)-ty12c(i))/(trabc(i+1)-trabc(i))
        exit
        end if
end do

do i=1,ntgh-1
        if((trgh(i).le.r).and.(trgh(i+1).gt.r)) then
        x11g=tx11g(i)+(r-trgh(i))*(tx11g(i+1)-tx11g(i))/(trgh(i+1)-trgh(i))
        x12g=tx12g(i)+(r-trgh(i))*(tx12g(i+1)-tx12g(i))/(trgh(i+1)-trgh(i))
        y11g=ty11g(i)+(r-trgh(i))*(ty11g(i+1)-ty11g(i))/(trgh(i+1)-trgh(i))
        y12g=ty12g(i)+(r-trgh(i))*(ty12g(i+1)-ty12g(i))/(trgh(i+1)-trgh(i))
        y11h=ty11h(i)+(r-trgh(i))*(ty11h(i+1)-ty11h(i))/(trgh(i+1)-trgh(i))
        y12h=ty12h(i)+(r-trgh(i))*(ty12h(i+1)-ty12h(i))/(trgh(i+1)-trgh(i))
        exit
        end if
end do

do i=1,ntm-1
        if((trm(i).le.r).and.(trm(i+1).gt.r)) then
        xm=(txm(i)+(r-trm(i))*(txm(i+1)-txm(i))/(trm(i+1)-trm(i)))/2.0_cp
        ym=(tym(i)+(r-trm(i))*(tym(i+1)-tym(i))/(trm(i+1)-trm(i)))/2.0_cp
        zm=(tzm(i)+(r-trm(i))*(tzm(i+1)-tzm(i))/(trm(i+1)-trm(i)))/2.0_cp
        exit
        end if
end do

end subroutine lubtabcalc

end module lub


      subroutine diracout(rel,v,rnot,dstep,nmax,eh,nql,nqk, &
                          val,slo,nodes,z)

!rschmid
!         Integration of Dirac equation.
!
!  Input:
!
!    rel    switch for relativ. - nonrelativ. calculation
!    v      rad.sym. potential in Hartree
!    rnot   first radial meshpoint
!    dstep  log. step
!    nmax    number of radial meshpoints
!    eh     energy in hartree
!    nql    angular momentum
!    nqk    relativistic quantum number kappa
!    z      charge of nucleus
!
!  Output:
!
!    val,slo:  Wellenfunktion und Steigung am Kugelrand
!    nodes:    nomber of nodes
!
!rschmid
!
! ----------------------------------------------------------------
      USE param
      USE ams
      implicit real*8 (a-h,o-z)
      logical rel
!rschmid
!     V     =   potential*r
!rschmid
      DIMENSION V(NRAD)

!rschmid
!      DR   =    radial mesh
!rschmid
      dimension dr(NRAD)

!rschmid
!     dp    =  large component of the solution of the dirac equation
!     dq    =  small component of the solution
!rschmid
      real*8     dp(nrad),dq(nrad)
      DIMENSION  AP(NRAD),BP(NRAD),AE(NRAD),BE(NRAD)
      COMMON  /work/     dp,dq,AP,BP,AE,BE
      SAVE    /work/

      real*8     dv(nrad)
!
! DEP,DEQ DERIVEES DE DP ET DQ   DB=ENERGIE/DVC    DVC VITESSE DE LA
! LUMIERE EN U.A.   DSAL=2.*DVC   DK NOMBRE QUANTIQUE KAPPA
! DM=PAS EXPONENTIEL/720., DKOEF=1./720.

!rschmid
!  The name of dm should be changed to avoid a name collision
!  with dm in inouh
!rschmid

      COMMON /PS1/ DEP(5),DEQ(5),DB,DVC,DSAL,DK,DM
      save   /ps1/

      DATA DKOEF/.1388888888888888D-2/

!rschmid
!   Set up radial mesh.
!rschmid
      do i=1,nmax
         DR(i)=RNOT*(exp(DSTEP*(i-1.d0)))
      enddo

      if (rel) then
         dvc = clight
      else
         dvc = 1.d+10
      endif
      dsal = 2.d0*dvc
      db = eh/dvc
      dk = nqk
      dm=dstep*dkoef

      do i=1,nmax
         dv(i) = v(i)/dr(i)
      enddo
!rschmid
!  Behavior of the solution at the origin
!rschmid

!jk   finite size of the nucleus
      rnuc=2.2677D-05*(atom_mass(int(z))**(1/3.))
      do 10 i=1,nmax
       d1=rnot*exp(DSTEP*(i-1.d0))
      if (d1.ge.rnuc) goto 20
 10   continue
 20   nuc=I
      if (nuc.le.0) then
      dfl = sqrt(nqk*nqk-z*z/(dvc*dvc))
      else
      dfl=nqk*nqk
      do 30 i=1,nuc
 30   dv(i)=dv(i)+z/dr(i)+z*((dr(i)/dr(nuc))**2-3.)/(2*dr(nuc))
      end if
      dq1 = nqk/iabs(nqk)

!rschmid
!  Determine expansion of the potential at the origin.
!rschmid
      test =1.e-8

      CALL INOUH (dp,dq,dr,dq1,dfl,dv(1),Z,TEST,nuc,NSTOP)

!rschmid
!  Set up boundary conditions using a small r expansion.
!rschmid

      nodes = 0
      do i=1,5
        dval=dr(i)**dfl
        if (i.ne.1) then
          if (dp(i-1).ne.0.) then
             if ((dp(i)/dp(i-1)).le.0.) then
               nodes=nodes+1
             endif
          endif
        endif
        dp(i) = dp(i)*dval
        dq(i) = dq(i)*dval
        dep(i)=dep(i)*dval
        deq(i)=deq(i)*dval
      enddo

!rschmid
!    Perform outward integration of dirac equation
!rschmid

      do i = 6, nmax
        dp(i) = dp(i-1)
        dq(i) = dq(i-1)
        call inth (dp(i),dq(i),dv(i),dr(i))
        if (dp(i-1).ne.0.) then
          if ((dp(i)/dp(i-1)).gt.0.) then
            nodes=nodes+1
          endif
        endif
      enddo

      val = dp(nmax)/dr(nmax)
      slo = dep(5)/(dstep*dr(nmax))/dvc*2.d0
      slo = (slo-val)/dr(nmax)

      RETURN
      END


	SUBROUTINE GDTXTI ( gridin, nx, nv, xpts, xptso, nptso, grdout,
     +	                    iret )
C************************************************************************
C* GDTXTI								*
C*									*
C* This subroutine horizontally interpolates to an even grid		*
C*									*
C* GDTXTI ( GRIDIN, NX, NV, XPTS, XPTSO, NPTSO, GRDOUT, IRET )		*
C*									*
C* Input parameters:							*
C*	GRIDIN (NX, NV) REAL	Input cross section array		*
C*      NX		INTEGER	Number of points in horz		*
C*      NV		INTEGER	Number of points in vert		*
C*	XPTS(*)		REAL	X-positions of input data		*
C*	XPTSO(*)	REAL	X-positions of output data		*
C*	NPTSO		INTEGER	number of output x-positions		*
C*									*
C* Output parameters:							*
C*	GRDOUT(NPTSO,NV)REAL	Output data				*
C*	IRET		INTEGER	Return code				*
C*					  0 = normal return		*
C*					 -7 = invalid vert coord	*
C**									*
C* Log:									*
C* K. F. Brill/GSC       7/89  						*
C* K. Brill/GSC          8/89           Interpolate to exact levels	*
C* K. Brill/GSC          1/90           Set lower/upper lvls for int	*
C* K. Brill/NMC		 1/91		Check for equality between 	*
C*        				input and output levels		*
C* K. Brill/NMC		11/92		Remove print *,			*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
        REAL 		gridin (nx, nv), grdout (*), xpts (*), xptso (*)
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C*
        istp = nptso * nv
	DO i = 1, istp
	    grdout ( i ) = RMISSD
	END DO
C
C*	Do the interpolation to the regularly spaced grid.
C
	DO ko = 2, nx
	    DO kn = 1, nptso
		indx = nx * ( kn - 1 )
		q = xptso ( kn )
C
C*		Compute interpolation weights.
C
		IF ( q .eq. xpts ( ko - 1 ) ) THEN
		    wt = 0.
		ELSE IF ( q .eq. xpts ( ko ) ) THEN
		    wt = 1.0
		ELSE IF ( ( q .gt. xpts ( ko - 1 ) .and.
     +			    q .lt. xpts ( ko ) ) .or.
     +			  ( q .lt. xpts ( ko - 1 ) .and.
     +			    q .gt. xpts ( ko ) ) ) THEN
		    wt = ( q - xpts ( ko - 1 ) ) /
     +                   ( xpts ( ko ) - xpts ( ko - 1 ) )
		ELSE
		    wt = -9999.
		END IF
C
C*		If the weight is positive, apply it.
C
		IF ( wt .ge. 0.0 ) THEN
		    wb = 1.000 - wt
		    DO i = 1, nv
			indx = ((i-1)*nptso)+kn
			IF ( ERMISS (gridin ( ko, i ) ) .OR.
     +			     ERMISS (gridin ( ko-1, i ) ) ) THEN
			    grdout ( indx ) = RMISSD
			ELSE
			    grdout ( indx ) = gridin (ko, i) * wt +
     +					      gridin (ko-1, i ) * wb
			END IF
		    END DO
		END IF
	    END DO
	END DO
C*
	RETURN
	END


      PROGRAM LA_SSYGV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SYGV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:), W(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_SYEV Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), B(N,N), BB(N,N), W(N) )

      OPEN(UNIT=21,FILE='sygv.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=TRANSPOSE(A)

      WRITE(*,*)'Matrix A : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(A(I,:));
      ENDDO

      OPEN(UNIT=21,FILE='sygv.mb',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      BB=TRANSPOSE(B)

      WRITE(*,*)'Matrix B : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(B(I,:));
      ENDDO

      WRITE(*,*) 'CALL LA_SYGV( A, B, W )'
      CALL LA_SYGV( A, B, W )

      WRITE(*,*)'Matrix B on exit:'
      DO I=1,N;
         WRITE(*,"(5(E14.6,1X))") B(I,:);
      ENDDO

      WRITE(*,*) 'W on exit : '
      DO I=1,N
         WRITE(*,"(5(E14.6,1X))") W(I)
      ENDDO

      WRITE(*,*)
      WRITE(*,*) ' * EXAMPLE 2 * '

      WRITE(*,*)'Matrix A : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(AA(I,:));
      ENDDO

      WRITE(*,*)'Matrix B : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(BB(I,:));
      ENDDO

      WRITE(*,*) "CALL LA_SYGV( A, B, W, '2', 'V', 'L', INFO )"
      CALL LA_SYGV( AA, BB, W, 2, 'V', 'L', INFO )

      WRITE(*,*)'Matrix A on exit:'
      DO I=1,N;
         WRITE(*,"(5(E14.6,1X))") AA(I,:);
      ENDDO

      WRITE(*,*)'Matrix B on exit:'
      DO I=1,N;
         WRITE(*,"(5(E14.6,1X))") BB(I,:);
      ENDDO

      WRITE(*,*) 'W on exit : '
      DO I=1,N
         WRITE(*,"(5(F11.5,1X))") W(I)
      ENDDO

      WRITE(*,*) ' INFO = ', INFO

      END PROGRAM LA_SSYGV_EXAMPLE


c
c
c     =====================================================
      subroutine rpn2(ixy,maxm,meqn,mwaves,mbc,mx,ql,qr,
     &			auxl,auxr,wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann-solver for the advection equation
c     #    q_t  +  u*q_x + v*q_y = 0
c     # where u and v are a given velocity field.
c
c       -----------------------------------------------------------
c     # In advective form, with interface velocities specified in
c     # the auxiliary variable
c     # aux(i,j,1)  =  u-velocity at left edge of cell (i,j)
c     # aux(i,j,2)  =  v-velocity at bottom edge of cell (i,j)
c       -----------------------------------------------------------
c
c     # solve Riemann problems along one slice of data.
c     # This data is along a slice in the x-direction if ixy=1
c     #                            or the y-direction if ixy=2.
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # On output, wave contains the waves, s the speeds,
c     # and amdq, apdq the left-going and right-going flux differences,
c     # respectively.  Note that in this advective form, the sum of
c     # amdq and apdq is not equal to a difference of fluxes except in the
c     # case of constant velocities.
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c
      implicit real*8(a-h,o-z)
c
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension   ql(1-mbc:maxm+mbc, meqn)
      dimension   qr(1-mbc:maxm+mbc, meqn)
      dimension apdq(1-mbc:maxm+mbc, meqn)
      dimension amdq(1-mbc:maxm+mbc, meqn)
      dimension auxl(1-mbc:maxm+mbc, 3)
      dimension auxr(1-mbc:maxm+mbc, 3)
c
c
c     # Set wave, speed, and flux differences:
c     ------------------------------------------
c
      do 30 i = 2-mbc, mx+mbc
         wave(i,1,1) = ql(i,1) - qr(i-1,1)
	 s(i,1) = auxl(i,ixy)
c        # The flux difference df = s*wave  all goes in the downwind direction:
	 amdq(i,1) = dmin1(auxl(i,ixy), 0.d0) * wave(i,1,1)
	 apdq(i,1) = dmax1(auxl(i,ixy), 0.d0) * wave(i,1,1)
   30    continue
c
      return
      end


SUBROUTINE clawpack5_rpn2adv(ixy,maxm,meqn,mwaves,maux,mbc, &
     mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
  IMPLICIT NONE

  INTEGER ixy,maxm,meqn,mwaves,maux,mbc,mx
  DOUBLE PRECISION wave(meqn, mwaves, 1-mbc:maxm+mbc)
  DOUBLE PRECISION    s(mwaves, 1-mbc:maxm+mbc)
  DOUBLE PRECISION   ql(meqn, 1-mbc:maxm+mbc)
  DOUBLE PRECISION   qr(meqn, 1-mbc:maxm+mbc)
  DOUBLE PRECISION apdq(meqn,1-mbc:maxm+mbc)
  DOUBLE PRECISION amdq(meqn,1-mbc:maxm+mbc)
  DOUBLE PRECISION auxl(maux,1-mbc:maxm+mbc)
  DOUBLE PRECISION auxr(maux,1-mbc:maxm+mbc)

  INTEGER iface, i, i1

  IF (meqn .NE. 1) THEN
     WRITE(6,*) 'clawpack5_rpn2 : meqn should be equal to 1'
     STOP
  ENDIF

  iface = ixy
  DO i = 2-mbc, mx+mbc
     wave(1,1,i) = ql(1,i) - qr(1,i-1)
     s(1,i) = auxl(ixy,i)
     amdq(1,i) = dmin1(auxl(iface,i), 0.d0) * wave(1,1,i)
     apdq(1,i) = dmax1(auxl(iface,i), 0.d0) * wave(1,1,i)
  END DO

  RETURN
END SUBROUTINE clawpack5_rpn2adv


	FUNCTION TRAPZ_LR(X,Y,N,X1,X2,IERR)

c	Finds area below y(x) from x=X1 to x =X2
c	X1 and X2 are not necessarily values of x(i)
c	but must fulfill X1>=x(1) and X2<=x(n)

c	This routine was especially written for coarse X arrays
c	where there are few points (or none) from X1 to X2 (like in Kurucz
c	model atmospheres). Interpolates Y(X) every unit in X.

c	Array declaration
	real x(n),y(n),xa(1000),ya(1000),linear

c       Check for values outside valid range
        TRAPZ_LR=0.
        ierr=0.
        if (n.le.1) return
        if (x1.lt.x(1)) then
                write (6,*) 'TRAPZ_LR: X1 outside valid range:',x1,x(1),1
                ierr=1
                return
c               stop
        endif
        if (x2.gt.x(n)) then
                write (6,*) 'TRAPZ_LR: X2 outside valid range:',x2,x(n),n
                ierr=2
                return
c               stop
        endif

c	Build auxiliary arrays (xa,ya) by linear interpolation
	j=0
	icall=0
	w1=x1-1.
	do i=1,n
	w1=w1+1
	if (w1.gt.x2) goto 1
	j=j+1
	xa(j)=w1
	ya(j)=linear(w1,x,y,n,icall)
	enddo
1	j=j+1
	xa(j)=x2
	ya(j)=linear(x2,x,y,n,icall)
	trapz_lr=trapz1(xa,ya,j)
	return
	end


!version: 2d decomposition using communcator
!version: routines MPI_COMM_SPLIT
! solves the 2d Stommel Model of Ocean Circulation
! using a Five-point stencil and Jacobi iteration
!
! gamma*((d(d(psi)/dx)/dx) + (d(d(psi)/dy)/dy))
! +beta(d(psi)/dx)=-alpha*sin(pi*y/(2*ly))
!
module numz
! module defines the basic real type and pi
    integer, parameter:: b8 = selected_real_kind(14)
    real(b8), parameter :: pi = 3.141592653589793239_b8
end module
!*********************
module input
! module contains the inputs
    use numz
    integer nx,ny             ! number of interior points for our grid (50 50)
    real(b8) lx,ly            ! physical size of our grid (2000 2000)
    real(b8) alpha,beta,gamma ! parameters of the calculation (1.0e-9 2.25e-11 3.0e-6)
    integer steps             ! number of Jacobi iteration steps (60)
end module
!*********************
module constants
! this module contains the invariants (constants) of the
! calculation.  these values are determined in the main
! routine and used in the do_jacobi Jacobi iteration subroutine
! a6 is used in the force function
    use numz
    real(b8) dx,dy,a1,a2,a3,a4,a5,a6
    real(b8), allocatable:: for(:,:)     ! our force grid
end module
!*********************
module face
! this module contains the interface for the two subroutines
! that modify the grid.  an interface is a good idea in this
! case because we are passing allocatable arrays
    interface bc
        subroutine bc (psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface do_jacobi
        subroutine do_jacobi (psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
            real(b8) diff
        end subroutine
    end interface
! interface for the forcing function
    interface force
        function force(y)
            use numz
            real(b8) force,y
        end function force
    end interface
! interface for setting  the force routine
    interface do_force
        subroutine do_force (i1,i2,j1,j2)
! sets the force array
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
! interface for routine to write the grid
    interface write_grid
        subroutine write_grid (psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface do_transfer
        subroutine do_transfer (psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface unique
        function unique(name)
            character (len=*) name
            character (len=20) unique
        end function
    end interface
end module
module mpi
!DEC$ NOFREEFORM
         include "mpif.h"
!DEC$ FREEFORM
    integer numnodes,myid,mpi_err
    integer, parameter::mpi_master=0
    integer status(MPI_STATUS_SIZE)
    integer nrow,ncol
    integer myrow,mycol
    integer myid_col,myid_row,nodes_row,nodes_col
    integer ROW_COMM,COL_COMM
    integer mytop,mybot,myleft,myright
end module
!*********************

module get_glob
    contains
        subroutine get_index(on_proc,proc_index)
		use mpi
		implicit none
		character (len=MPI_MAX_PROCESSOR_NAME ), allocatable :: the_names(:)
		integer on_proc,proc_index,i
	    allocate(the_names(0:numnodes-1))
	    call MPI_GET_PROCESSOR_NAME(the_names(myid),i,mpi_err)
	    call MPI_allGather(the_names(myid),MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER, &
	                       the_names      ,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER, &
	                       MPI_COMM_WORLD,mpi_err)
	    on_proc=0
	    do i=0,numnodes-1
	        if(LGE(the_names(myid),the_names(i)).and. LLE(the_names(myid),the_names(i)))then
	            on_proc=on_proc+1
	            if(i .eq. myid)proc_index=on_proc
	        endif
	    enddo
!	    write(*,*)"myid = ",myid," which is mpi task ",proc_index," on ",the_names(myid)
	    deallocate(the_names)
	    end subroutine
end module

program stommel
    use numz
    use input
    use constants
    use face
    use mpi
    use get_glob
    implicit none
    character*(MPI_MAX_PROCESSOR_NAME) name
    integer on_proc,proc_index
    real(b8) t1,t2
    real(b8)diff,mydiff
    real(b8)dx2,dy2,bottom
    real(b8), allocatable:: psi(:,:)     ! our calculation grid
    real(b8), allocatable:: new_psi(:,:) ! temp storage for the grid
    integer i,j,i1,i2,j1,j2
    integer omp_get_max_threads,omp_get_num_threads,omp_get_thread_num
    integer iout
    integer n_mpi,n_thread
    real(b8) di,dj
    character (len=80):: aline1,aline2,aline3,aline4
! do the mpi init stuff
    call MPI_INIT( mpi_err )
    call MPI_COMM_SIZE( MPI_COMM_WORLD, numnodes, mpi_err )
    call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpi_err )
    call MPI_GET_PROCESSOR_NAME(name,i,mpi_err)
!    write(*,*)"threads=",omp_get_max_threads()," on ",name
    n_thread=omp_get_num_threads()
    n_mpi=numnodes
! find a reasonable grid topology based on the number
! of processors
  nrow=nint(sqrt(float(numnodes)))
  ncol=numnodes/nrow
  do while (nrow*ncol .ne. numnodes)
      nrow=nrow+1
      ncol=numnodes/nrow
  enddo
  if(nrow .gt. ncol)then
      i=ncol
      ncol=nrow
      nrow=i
  endif
  myrow=myid/ncol+1
  mycol=myid - (myrow-1)*ncol + 1
! make the row and col communicators
! all processors with the same row will be in the same ROW_COMM
  call MPI_COMM_SPLIT(MPI_COMM_WORLD,myrow,mycol,ROW_COMM,mpi_err)
  call MPI_COMM_RANK( ROW_COMM, myid_row, mpi_err )
  call MPI_COMM_SIZE( ROW_COMM, nodes_row, mpi_err )
! all processors with the same col will be in the same COL_COMM
  call MPI_COMM_SPLIT(MPI_COMM_WORLD,mycol,myrow,COL_COMM,mpi_err)
  call MPI_COMM_RANK( COL_COMM, myid_col, mpi_err )
  call MPI_COMM_SIZE( COL_COMM, nodes_col, mpi_err )
! find id of neighbors using the communicators created above
  mytop   = myid_col-1;if( mytop    .lt. 0         )mytop   = MPI_PROC_NULL
  mybot   = myid_col+1;if( mybot    .eq. nodes_col )mybot   = MPI_PROC_NULL
  myleft  = myid_row-1;if( myleft   .lt. 0         )myleft  = MPI_PROC_NULL
  myright = myid_row+1;if( myright  .eq. nodes_row )myright = MPI_PROC_NULL
! get the input.  see above for typical values
aline1="200 200"
aline2="2000000 2000000"
aline3="1.0e-9 2.25e-11 3.0e-6"
aline4="7500"
!write(*,*)"do read"
    if(myid .eq. mpi_master)then
        read(aline1,*)nx,ny
        read(aline2,*)lx,ly
        read(aline3,*)alpha,beta,gamma
        read(aline4,*)steps
        read(*,*)nx,ny
        read(*,*)lx,ly
        read(*,*)alpha,beta,gamma
        read(*,*)steps
        write(*,*)nx,ny
        write(*,*)lx,ly
        write(*,*)alpha,beta,gamma
        write(*,*)steps
    endif
!write(*,*)"do bcast"
!send the data to other processors
    call MPI_BCAST(nx,   1,MPI_INTEGER,         mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(ny,   1,MPI_INTEGER,         mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(steps,1,MPI_INTEGER,         mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(lx,   1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(ly,   1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(alpha,1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(beta, 1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(gamma,1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
!        write(*,*)nx,ny
!        write(*,*)lx,ly
!        write(*,*)alpha,beta,gamma
!        write(*,*)steps
!write(*,*)"! calculate the constants for the calculations"
    dx=lx/(nx+1)
    dy=ly/(ny+1)
    dx2=dx*dx
    dy2=dy*dy
    bottom=2.0_b8*(dx2+dy2)
    a1=(dy2/bottom)+(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a2=(dy2/bottom)-(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a3=dx2/bottom
    a4=dx2/bottom
    a5=dx2*dy2/(gamma*bottom)
    a6=pi/(ly)
!write(*,*)" ! set the indices for the interior of the grid"
! we block the grid across the processors
! for a 50 x 50 gird with 6 processors we get
! nrow=  2  ncol=  3
! myid=   0 myrow=   1 mycol=   1    (  1 <= i <=  25) ,  (  1 <= j <=  17)
! myid=   1 myrow=   1 mycol=   2    (  1 <= i <=  25) ,  ( 18 <= j <=  33)
! myid=   2 myrow=   1 mycol=   3    (  1 <= i <=  25) ,  ( 34 <= j <=  50)
! myid=   3 myrow=   2 mycol=   1    ( 26 <= i <=  50) ,  (  1 <= j <=  17)
! myid=   4 myrow=   2 mycol=   2    ( 26 <= i <=  50) ,  ( 18 <= j <=  33)
! myid=   5 myrow=   2 mycol=   3    ( 26 <= i <=  50) ,  ( 34 <= j <=  50)
    dj=real(nx,b8)/real(nodes_row,b8)
    j1=nint(1.0_b8+myid_row*dj)
    j2=nint(1.0_b8+(myid_row+1)*dj)-1
    di=real(ny,b8)/real(nodes_col,b8)
    i1=nint(1.0_b8+myid_col*di)
    i2=nint(1.0_b8+(myid_col+1)*di)-1
    if(myid == mpi_master)write(*,'("rows= ",i4," columns= ",i4)')nodes_row,nodes_col
    write(*,'("myid= ",i4," myid_row= ",i4," myid_col= ",i4)')myid,myid_row,myid_col
    write(*,101)myid,myrow,mycol,i1,i2,j1,j2
101 format("myid= ",i4," myrow= ",i4," mycol= ",i4,3x,&
           " (",i3," <= i <= ",i3,") , ",            &
           " (",i3," <= j <= ",i3,")")
! allocate the grid to (i1-1:i2+1,j1-1:j2+1) this includes boundary cells
    allocate(psi(i1-1:i2+1,j1-1:j2+1))
    allocate(new_psi(i1-1:i2+1,j1-1:j2+1))
    allocate(for(i1-1:i2+1,j1-1:j2+1))
! set initial guess for the value of the grid
    psi=1.0_b8
! set boundary conditions
    call bc(psi,i1,i2,j1,j2)
! set the force array
    call do_force(i1,i2,j1,j2)
    call do_transfer(psi,i1,i2,j1,j2)
    iout=steps/100
    if(iout == 0)iout=1
    t1=MPI_Wtime()
! do the jacobian iterations
    do i=1,steps
        call do_jacobi(psi,new_psi,mydiff,i1,i2,j1,j2)
        call do_transfer(psi,i1,i2,j1,j2)
!       write(*,*)myid,i,mydiff
	call MPI_REDUCE(mydiff,diff,1,MPI_DOUBLE_PRECISION, &
	                MPI_SUM,mpi_master,MPI_COMM_WORLD,mpi_err)
	if(myid .eq. mpi_master .and. mod(i,iout) .eq. 0)write(*,'(i6,1x,g20.10)')i,diff
    enddo
    t2=mpi_Wtime()
    if(myid .eq. mpi_master)write(*,*)"run time =",t2-t1,n_mpi,n_thread
! write out the final grid
!    call write_grid(psi,i1,i2,j1,j2)
100 continue
    call MPI_Finalize(mpi_err)
end program stommel
!*********************
subroutine bc(psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
    use numz
    use mpi
    use input, only : nx,ny
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
! do the top edges
    if(i1 .eq.  1) psi(i1-1,:)=0.0_b8
! do the bottom edges
    if(i2 .eq. ny) psi(i2+1,:)=0.0_b8
! do left edges
    if(j1 .eq.  1) psi(:,j1-1)=0.0_b8
! do right edges
    if(j2 .eq. nx) psi(:,j2+1)=0.0_b8
end subroutine bc
!*********************
subroutine do_jacobi(psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
    use numz
    use mpi, only: numnodes,myid
    use constants
    implicit none
    integer,intent(in) :: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
    real(b8) diff
    integer i,j
    integer omp_get_num_threads,omp_get_thread_num
    real(b8) y
    diff=0.0_b8
!$OMP PARALLEL
!$OMP DO SCHEDULE (STATIC) private(i) firstprivate(a1,a2,a3,a4,a5) reduction(+:diff)
    do j=j1,j2
        do i=i1,i2
!            y=j*dy
            new_psi(i,j)=a1*psi(i+1,j) + a2*psi(i-1,j) + &
                         a3*psi(i,j+1) + a4*psi(i,j-1) - &
                         a5*for(i,j)
!                         a5*force(y)
            diff=diff+abs(new_psi(i,j)-psi(i,j))
         enddo
     enddo
!$OMP END  DO
     psi(i1:i2,j1:j2)=new_psi(i1:i2,j1:j2)
!$OMP END PARALLEL
end subroutine do_jacobi
!*********************
function force(y)
    use numz
    use input
    use constants
    implicit none
    real(b8) force,y
    force=-alpha*sin(y*a6)
end function force
!*********************
subroutine do_force (i1,i2,j1,j2)
! sets the force conditions
! input is the grid and the indices for the interior cells
    use numz
    use constants, only:for,dy
    use face, only : force
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8) y
    integer i,j
    do i=i1,i2
        do j=j1,j2
            y=j*dy
            for(i,j)=force(y)
        enddo
    enddo
end subroutine
!*********************
subroutine write_grid(psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
    use numz
    use mpi
    use face ,only : unique
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    integer i,j
    integer istart,iend,jstart,jend
! each processor writes its section of the grid
    istart=i1-1
    iend=i2+1
    jstart=j1-1
    jend=j2+1
    open(18,file=unique("out_both"),recl=max(80,15*((jend-jstart)+3)+2))
    write(18,101)myid,istart,iend,jstart,jend

101 format("myid= ",i3,3x,                 &
           " (",i3," <= i <= ",i3,") , ", &
           " (",i3," <= j <= ",i3,")")
    do i=istart,iend
       do j=jstart,jend
           write(18,'(g14.7)',advance="no")psi(i,j)
           if(j .ne. j2)write(18,'(" ")',advance="no")
       enddo
       write(18,*)
    enddo
    close(18)
end subroutine write_grid
!*********************
subroutine do_transfer(psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
    use numz
    use mpi
    use input
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    integer num_x,num_y
    logical even
    num_x=i2-i1+3
    num_y=j2-j1+3
    if(even(myid_col))then
! send to left
            call MPI_SEND(psi(:,j1),  num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sl",myid,psi(:,j1)
! rec from left
            call MPI_RECV(psi(:,j1-1),num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rl",myid,psi(:,j1-1)
! rec from right
            call MPI_RECV(psi(:,j2+1),num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rr",myid,psi(:,j2+1)
! send to right
            call MPI_SEND(psi(:,j2),  num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sr",myid,psi(:,j2)
    else    ! we are on an odd col processor
! rec from right
            call MPI_RECV(psi(:,j2+1),num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rr",myid,psi(:,j2+1)
! send to right
            call MPI_SEND(psi(:,j2),  num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sr",myid,psi(:,j2)
! send to left
            call MPI_SEND(psi(:,j1),  num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sl",myid,psi(:,j1)
! rec from left
            call MPI_RECV(psi(:,j1-1),num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rl",myid,psi(:,j1-1)
    endif
    if(even(myid_row))then
! send to top
        call MPI_SEND(psi(i1,:),num_y,MPI_DOUBLE_PRECISION,mytop,     &
                      10, COL_COMM,mpi_err)
! rec from top
        call MPI_RECV(psi(i1-1,:),num_y,MPI_DOUBLE_PRECISION,mytop,  &
                      10,COL_COMM,status,mpi_err)
! rec from bot
        call MPI_RECV(psi(i2+1,:),num_y,MPI_DOUBLE_PRECISION,mybot,  &
                      10,COL_COMM,status,mpi_err)
! send to bot
        call MPI_SEND(psi(i2,:),num_y,MPI_DOUBLE_PRECISION,mybot,     &
                      10, COL_COMM,mpi_err)
    else
! rec from bot
        call MPI_RECV(psi(i2+1,:),num_y,MPI_DOUBLE_PRECISION,mybot,   &
                      10,COL_COMM,status,mpi_err)
! send to bot
        call MPI_SEND(psi(i2,:),num_y,MPI_DOUBLE_PRECISION,mybot,     &
                      10,COL_COMM,mpi_err)
! send to top
        call MPI_SEND(psi(i1,:),num_y,MPI_DOUBLE_PRECISION,mytop,     &
                      10,COL_COMM,mpi_err)
! rec from top
        call MPI_RECV(psi(i1-1,:),num_y,MPI_DOUBLE_PRECISION,mytop,   &
                      10,COL_COMM,status,mpi_err)
    endif
end subroutine do_transfer
!*********************
function even(i)
  integer i
  logical even
  j=i/2
  if(j*2 .eq. i)then
      even = .true.
  else
      even = .false.
  endif
  return
end function even
!*********************
function unique(name)
    use numz
    use mpi
    character (len=*) name
    character (len=20) unique
    character (len=80) temp
    if(myid .gt. 99)then
      write(temp,"(a,i3)")trim(name),myid
    else
        if(myid .gt. 9)then
            write(temp,"(a,'0',i2)")trim(name),myid
        else
            write(temp,"(a,'00',i1)")trim(name),myid
        endif
    endif
    unique=temp
    return
end function unique


submodule(euler_interface_m) euler_prob_0045_m
    implicit none

contains

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

    integer(int64) function ans()
        integer(int64) :: x, y

        call hex_n_pen(3, x, y)
        ans = y*(2_int64*y - 1_int64)
    end function ans

    recursive subroutine hex_n_pen(i, x, y)
        integer, intent(in) :: i
        integer(int64), intent(out) :: x, y
        integer(int64) :: a, b

        if (i == 1) then
            x = 1_int64
            y = 1_int64
        else
            call hex_n_pen(i - 1, a, b)
            x = 97_int64*a + 112_int64*b - 44_int64
            y = 84_int64*a + 97_int64*b - 38_int64
        end if
    end subroutine hex_n_pen

end submodule euler_prob_0045_m


*> \brief \b SLATM7
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N,
*                          RANK, INFO )
*
*       .. Scalar Arguments ..
*       REAL               COND
*       INTEGER            IDIST, INFO, IRSIGN, MODE, N, RANK
*       ..
*       .. Array Arguments ..
*       REAL               D( * )
*       INTEGER            ISEED( 4 )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    SLATM7 computes the entries of D as specified by MODE
*>    COND and IRSIGN. IDIST and ISEED determine the generation
*>    of random numbers. SLATM7 is called by SLATMT to generate
*>    random test matrices.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \verbatim
*>  MODE   - INTEGER
*>           On entry describes how D is to be computed:
*>           MODE = 0 means do not change D.
*>
*>           MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND
*>           MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND
*>           MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK
*>
*>           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
*>           MODE = 5 sets D to random numbers in the range
*>                    ( 1/COND , 1 ) such that their logarithms
*>                    are uniformly distributed.
*>           MODE = 6 set D to random numbers from same distribution
*>                    as the rest of the matrix.
*>           MODE < 0 has the same meaning as ABS(MODE), except that
*>              the order of the elements of D is reversed.
*>           Thus if MODE is positive, D has entries ranging from
*>              1 to 1/COND, if negative, from 1/COND to 1,
*>           Not modified.
*>
*>  COND   - REAL
*>           On entry, used as described under MODE above.
*>           If used, it must be >= 1. Not modified.
*>
*>  IRSIGN - INTEGER
*>           On entry, if MODE neither -6, 0 nor 6, determines sign of
*>           entries of D
*>           0 => leave entries of D unchanged
*>           1 => multiply each entry of D by 1 or -1 with probability .5
*>
*>  IDIST  - CHARACTER*1
*>           On entry, IDIST specifies the type of distribution to be
*>           used to generate a random matrix .
*>           1 => UNIFORM( 0, 1 )
*>           2 => UNIFORM( -1, 1 )
*>           3 => NORMAL( 0, 1 )
*>           Not modified.
*>
*>  ISEED  - INTEGER array, dimension ( 4 )
*>           On entry ISEED specifies the seed of the random number
*>           generator. The random number generator uses a
*>           linear congruential sequence limited to small
*>           integers, and so should produce machine independent
*>           random numbers. The values of ISEED are changed on
*>           exit, and can be used in the next call to SLATM7
*>           to continue the same random number sequence.
*>           Changed on exit.
*>
*>  D      - REAL array, dimension ( MIN( M , N ) )
*>           Array to be computed according to MODE, COND and IRSIGN.
*>           May be changed on exit if MODE is nonzero.
*>
*>  N      - INTEGER
*>           Number of entries of D. Not modified.
*>
*>  RANK   - INTEGER
*>           The rank of matrix to be generated for modes 1,2,3 only.
*>           D( RANK+1:N ) = 0.
*>           Not modified.
*>
*>  INFO   - INTEGER
*>            0  => normal termination
*>           -1  => if MODE not in range -6 to 6
*>           -2  => if MODE neither -6, 0 nor 6, and
*>                  IRSIGN neither 0 nor 1
*>           -3  => if MODE neither -6, 0 nor 6 and COND less than 1
*>           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 3
*>           -7  => if N negative
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup real_matgen
*
*  =====================================================================
      SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N,
     $                   RANK, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               COND
      INTEGER            IDIST, INFO, IRSIGN, MODE, N, RANK
*     ..
*     .. Array Arguments ..
      REAL               D( * )
      INTEGER            ISEED( 4 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
      REAL               HALF
      PARAMETER          ( HALF = 0.5E0 )
*     ..
*     .. Local Scalars ..
      REAL               ALPHA, TEMP
      INTEGER            I
*     ..
*     .. External Functions ..
      REAL               SLARAN
      EXTERNAL           SLARAN
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLARNV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, EXP, LOG, REAL
*     ..
*     .. Executable Statements ..
*
*     Decode and Test the input parameters. Initialize flags & seed.
*
      INFO = 0
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Set INFO if an error
*
      IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
         INFO = -1
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
         INFO = -2
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         COND.LT.ONE ) THEN
         INFO = -3
      ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
     $         ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -7
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLATM7', -INFO )
         RETURN
      END IF
*
*     Compute D according to COND and MODE
*
      IF( MODE.NE.0 ) THEN
         GO TO ( 100, 130, 160, 190, 210, 230 )ABS( MODE )
*
*        One large D value:
*
  100    CONTINUE
         DO 110 I = 2, RANK
            D( I ) = ONE / COND
  110    CONTINUE
         DO 120 I = RANK + 1, N
            D( I ) = ZERO
  120    CONTINUE
         D( 1 ) = ONE
         GO TO 240
*
*        One small D value:
*
  130    CONTINUE
         DO 140 I = 1, RANK - 1
            D( I ) = ONE
  140    CONTINUE
         DO 150 I = RANK + 1, N
            D( I ) = ZERO
  150    CONTINUE
         D( RANK ) = ONE / COND
         GO TO 240
*
*        Exponentially distributed D values:
*
  160    CONTINUE
         D( 1 ) = ONE
         IF( N.GT.1  .AND. RANK.GT.1 ) THEN
            ALPHA = COND**( -ONE / REAL( RANK-1 ) )
            DO 170 I = 2, RANK
               D( I ) = ALPHA**( I-1 )
  170       CONTINUE
            DO 180 I = RANK + 1, N
               D( I ) = ZERO
  180       CONTINUE
         END IF
         GO TO 240
*
*        Arithmetically distributed D values:
*
  190    CONTINUE
         D( 1 ) = ONE
         IF( N.GT.1 ) THEN
            TEMP = ONE / COND
            ALPHA = ( ONE-TEMP ) / REAL( N-1 )
            DO 200 I = 2, N
               D( I ) = REAL( N-I )*ALPHA + TEMP
  200       CONTINUE
         END IF
         GO TO 240
*
*        Randomly distributed D values on ( 1/COND , 1):
*
  210    CONTINUE
         ALPHA = LOG( ONE / COND )
         DO 220 I = 1, N
            D( I ) = EXP( ALPHA*SLARAN( ISEED ) )
  220    CONTINUE
         GO TO 240
*
*        Randomly distributed D values from IDIST
*
  230    CONTINUE
         CALL SLARNV( IDIST, ISEED, N, D )
*
  240    CONTINUE
*
*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
*        random signs to D
*
         IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $       IRSIGN.EQ.1 ) THEN
            DO 250 I = 1, N
               TEMP = SLARAN( ISEED )
               IF( TEMP.GT.HALF )
     $            D( I ) = -D( I )
  250       CONTINUE
         END IF
*
*        Reverse if MODE < 0
*
         IF( MODE.LT.0 ) THEN
            DO 260 I = 1, N / 2
               TEMP = D( I )
               D( I ) = D( N+1-I )
               D( N+1-I ) = TEMP
  260       CONTINUE
         END IF
*
      END IF
*
      RETURN
*
*     End of SLATM7
*
      END