!!
!! Luke McCulloch
!!
!! This Program will
!! read in the hull and free surface geometry
!! Solve for the source strengths
!! Find the flow properties and forces on the hull

PROGRAM flowsolver

  use precise,   only : defaultp ! Double Precision
  USE constants                  ! gravity,length
  use io                         ! Input Output (read in fifi)
  use geometry                   ! Get the Panel Geometry vn, vt1, vt2
  use influencefunctions         ! Compute Dij coefficients in the "A" influence matrix
  use vtkxmlmod                  ! Create Paraview files
  use slae                       ! invert the Dij "A" influence matrix

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  integer, parameter :: WP=defaultp

  INTEGER :: narg      ! Integer variables
  INTEGER :: i, j, Row, Col !, k , error
  INTEGER :: npoints, npanels, nfspanels
  INTEGER :: iounit

  CHARACTER(len=24) :: inputfile   ! file name can be max. 24 char. long
  CHARACTER(len=24) :: outputfile  ! file name can be max. 24 char. long
  CHARACTER(len=24) :: str_Fr      ! Froude number

  !! output vtk file names:
  CHARACTER(len=24) :: datafile1
  CHARACTER(len=24) :: datafile2
  CHARACTER(len=24) :: datafile3

  !! title
  CHARACTER(len=30) :: title

  LOGICAL :: flexists  ! a logical variable. I .true. or .false.

  ! panel and point data
  ! to be allocated in the io module
  INTEGER, ALLOCATABLE, DIMENSION(:,:) :: panels
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: points

  ! Arrays for the geometry.f90 panel property computations
  REAL(WP), DIMENSION(3,4) :: corners  ! temporary storage for panel corners
  REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: center
  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: coordsys
  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: cornerslocal
  REAL(wp), ALLOCATABLE, DIMENSION(:) :: area

  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: vel
  REAL(WP), DIMENSION(3) :: vp
  REAL(WP), DIMENSION(3) :: fieldpoint, fieldpointp

  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: am

  REAL(WP), ALLOCATABLE, DIMENSION(:) :: b
  REAL(WP), DIMENSION(3) :: vinf

  REAL(WP), ALLOCATABLE, DIMENSION(:) :: sigma
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: vtotal
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: vn
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: vt1
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: vt2
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: cp

  REAL(WP),DIMENSION(3) :: force

  REAL(WP), DIMENSION(3) :: vtottest
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: velt
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: vtest
  REAL(WP), DIMENSION(3) :: testpoint
  REAL(WP), DIMENSION(3) :: vtp
  REAL(WP), DIMENSION(3) :: vtpp
  REAL(WP), DIMENSION(3) :: vtppp
  REAL(WP), DIMENSION(3) :: testpointp, testpointpp
  REAL(WP), DIMENSION(3) :: testpointppp
  REAL(WP), DIMENSION(1) :: cpt

  real(wp) :: deltax
  !!simquit solver data
  REAL(wp) :: Amatmax, sing, av, dx
  INTEGER :: nmax, iter
  !!end simquit data

  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:,:) :: hessglobal
  REAL(WP), DIMENSION(3,3) :: hp

  REAL(WP), ALLOCATABLE,DIMENSION(:) :: zeta
  REAL(WP), DIMENSION(2,128) :: profilewave

  REAL(wp) :: cw, S, sourcesink
  REAL(WP) :: Fr

  ! start up message
  WRITE(*,*) ''
  WRITE(6,'(A)') ' -------------------------------------------------------------------- '
  WRITE(6,'(A)') ' -------------------------------------------------------------------- '
  WRITE(6,'(A)') ' Linear Free Surface Panel Method, '
  WRITE(6,'(A)') '  code sample version 2019, Luke McCulloch '
  WRITE(6,'(A)') ' -------------------------------------------------------------------- '
  WRITE(6,'(A)') ' -------------------------------------------------------------------- '
  WRITE(6,'(A)') " "
  WRITE(6,'(A)') ' Hi, and welcome to my flow solver sample code! '
  WRITE(6,'(A)') " In general this code computes Laplace's equation "
  WRITE(6,'(A)') ' using a BEM method, Rankine Green functions, and linear superposition '
  WRITE(6,'(A)') ' for simple potential flow about an arbitrary ship hull shape '
  WRITE(6,'(A)') ' (symmetric about the vertical-longitudinal midplane)'
  WRITE(6,'(A)') ' with forward speed given by Froude number.'
  WRITE(6,'(A)') ' and with the linearized free surface boundary condition.'
  WRITE(6,'(A)') ' such that a steady wave field and pressure distribution will be found.'
  WRITE(6,'(A)') ' .vtp output files will be written to paraview/vtk format.'
  WRITE(6,'(A)') ' '
  WRITE(6,'(A)') ' Note this sample is set up to solve a simple canoe body.'
  WRITE(6,'(A)') ' The geometry file is called fifi.dat.'
  WRITE(6,'(A)') ' '
  WRITE(6,'(A)') ' -------------------------------------------------------------------- '
  WRITE(6,'(A)') ' -------------------------------------------------------------------- '
  WRITE(6,'(A)') " "

  ! Count the number command line arguments (Fortran 2003)
  ! If your compiler does not support this feature look
  ! for the common extension iargc()
  ! narg = iargc()
  narg = command_argument_count()
  WRITE(6, FMT='(AI3A)') ' we have ', narg, ' command line arguments '

  ! Now read the name of the input file and output file from the command line

  IF ( narg == 3 ) THEN
     CALL get_command_argument(1, inputfile)
     CALL get_command_argument(2, outputfile)
     !CALL get_command_argument(3, str_vx)
     !READ(str_vx,*) vx
     CALL get_command_argument(3, str_Fr)
     READ(str_Fr,*) Fr
  ELSE
     WRITE(6,'(A)') ' Output file name and/or input velocity missing!'
     WRITE(*,*) ''
     WRITE(6,'(A)') ' Usage Instructions:'
     WRITE(6,'(A)') ' Input the geometry filename, then output file names, then Froude number of the flow.'
     WRITE(6,'(A)') ' e.g., usage:'
     WRITE(6,'(A)') ' $ ./flowsolve <fifi.dat> <outFileName> <FroudeNumber(float)> '
     STOP
  ENDIF

  INQUIRE(file=inputfile, exist=flexists)

  IF (flexists) THEN

     WRITE(6,'(AA)') ' input file,  ', inputfile
     WRITE(6,'(AA)') 'output file, ', outputfile

!! Call a subroutine to read the input file back into the main program
!! This is from the "io" MODULE
!! ALLOCATE 2 ARRAYS : "points" and "panels"
!!
!! and output the input file into the out.dat file as a check.
!!----------------------------------------------------------------------
     CALL input( inputfile, outputfile, title, &
                         npanels, nfspanels, npoints, &
                         panels, points,i,j,deltax)
!!----------------------------------------------------------------------

  Else
     ! If not, the program stops
     WRITE(6,'(A)') ' Input file does not exist!'
     STOP ! abort program
  ENDIF

  ! Write geometry to the screen
  write(6,*) title
  write(6,*) i,j
  write(6,*) 'npanels, nfspanels, npoints, deltax'
  write(6,*) npanels, nfspanels, npoints, deltax
!
!
!!
!!--------------------------------------------------------------------
!!--------------------------------------------------------------------
!!  compute panel properties
 ALLOCATE( center(3,npanels+nfspanels) )
 ALLOCATE( coordsys(3,3,npanels+nfspanels) )
 ALLOCATE( cornerslocal(2,4,npanels+nfspanels) )
 ALLOCATE( area(npanels+nfspanels) )

  DO i = 1, npanels+nfspanels
 !    WRITE(6,'(A)') 'Panel point numbers:'
 !    WRITE(6,'(4I6)') (panels(j,i), j=1,4)

 !    WRITE(6,'(A)') 'Panel point coordinates:'
 !    DO j = 1, 4
 !       WRITE(6,'(I5'': ''3(G12.6,2X))') panels(j,i), &
 !            (points(k,panels(j,i)), k = 1,3)
 !    END DO
 !
 !    ! we store the panel corner points in a 3 by 4 array
     DO j=1, 4
        corners(:,j) = points(:,panels(j,i))
     END DO

     ! call the panel geometry function IN THE  MODULE "geometry"
     ! Output data is collected in arrays with additional dimension
     ! for number of panels
     CALL panelgeometry( corners, coordsys(:,:,i), cornerslocal(:,:,i), &
                      area(i), center(:,i) )

     ! We pick some output to check.
     !WRITE(6,'(''nv: '',3(G12.6,2X))') coordsys(:,3,i)
     !WRITE(6,'(''cl: '',8(G12.6,2X))') cornerslocal(:,:,i)
     !WRITE(6,'(''A: '',G12.6)') area(i)
     !WRITE(6,'(''center: '',3(G12.6,2X))') center(:,i)

  END DO

!! end of panelgeometry.f90 computations
!!--------------------------------------------------------------------

!! Compute the influence matrix, "A"
!!---------------------------------------------------------------------
!!---------------------------------------------------------------------
    !!
    !! procedure to compute the A matrix of v dot a
    !!
    !! Input:  the locations of panel centers pi and qj
    !!         the normal vector of each panel center
    !!         the area of each panel
    !!
    !!
    !!
    !! Output:  the velocity at panel i induced by panel j
    !!          the A matrix
    !!
    !!
    !!
    !! Note we will use the following  from geometry Output:
    !!     coordsys: a 3x3 matrix containing the two tangent vectors
    !!               and the normal vector
    !!                  t1x   t2x   nx
    !!                  t1y   t2y   ny
    !!                  t1z   t2z   nz
    !!               i.e. coordsys(:,3) is the normal vector
    !!     area: the area of the panel
    !!     center: the 3D coordinates of the panel center
    !!

  !! Allocate needed memory
  ALLOCATE(vel(3,npanels+nfspanels,npanels+nfspanels))
  ALLOCATE(hessglobal(3,3,npanels+nfspanels,npanels+nfspanels))
  ALLOCATE(am(npanels+nfspanels+2,npanels+nfspanels+2))
  am = REAL(0.,kind=wp)
  ALLOCATE(b(npanels+nfspanels))
  ALLOCATE(sigma(npanels+nfspanels))

  !!  Define Vinfinity
  !!vinf = (/1.503404137,0.,0./) !Corresponding to Fr=.350
  vinf = (/0.,0.,0./)
  vinf(1) = Fr*sqrt(length*gravity)
  write(*,*)
  write(*,*) ' v_infinity',vinf

  !!  Double Nested Double Do Loop to compute the A matrix
  !!  PART 1:  Body B.C.
  !!********************************************************************************

    !! First get the image system of mirrored points  (enforce the centerplane!)
    !! in lieu of mirroring panels
    DO i=1,npanels

       Row=i

       fieldpoint(:)=center(:,Row)

!       !! First mirror the fieldpoints about the Z-X plane
       fieldpointp(:)=fieldpoint(:)
       fieldpointp(2)=-fieldpoint(2)

       !! Compute the Influence of the Body Panels on hull fieldpoints
       !!****************************************************************************
       Do j=1,npanels

          Col = j
!
!          !First get the singular points
          IF(Row==Col)THEN
             vel(:,Row,Col)=-0.5*coordsys(:,3,Row)
!
!          !Then get the nonsingular points
          ELSE
             vel(:,Row,Col)=hsinfluence(fieldpoint(:),        &
                                        center(:,Col),        &
                                        area(Col),            &
                                        coordsys(:,:,Col),    &
                                        cornerslocal(:,:,Col))
          END IF

          !Now get the influence of the panel
          !on the mirrored points  (must enforce no flow through the centerplane of the ship!)
          vp(:)=hsinfluence(fieldpointp(:),       &
                            center(:,Col),        &
                            area(Col),            &
                            coordsys(:,:,Col),    &
                            cornerslocal(:,:,Col))
!

          !Get Influence of panel sj
          !and its mirrors @ point pi

          !Velocities for the half ship (flow is symetric)
          vel(1,Row,Col) = vel(1,Row,Col)+vp(1)
          vel(2,Row,Col) = vel(2,Row,Col)-vp(2)
          vel(3,Row,Col) = vel(3,Row,Col)+vp(3)

          !Finally, compute the am(i,j) matrix components satisfying no flow through the body surface
          am(Row,Col)= DOT_PRODUCT(coordsys(:,3,Row),vel(:,Row,Col))

       END DO

       !! Compute the Influence of the Free Surface Panels on hull fieldpoints
       !! ***********************************************************************************
       Do j=1,nfspanels

          Col = j+npanels
!
!          !There are no singular points.  We put the sources above the free surface!
          IF(Row==Col)THEN
             vel(:,Row,Col)=-0.5*coordsys(:,3,Row)
!
!          ! Get the nonsingular points
          ELSE
             vel(:,Row,Col)=hsinfluence(fieldpoint(:),       &
                                        center(:,Col),area(Col),coordsys(:,:,Col),cornerslocal(:,:,Col))
          END IF

          !Now get the influence of the panel
          !on the mirrored points
          vp(:)=hsinfluence(fieldpointp(:),center(:,Col),area(Col),coordsys(:,:,Col),cornerslocal(:,:,Col))
!

          !Get Influence of panel sj
          !and its mirror @ point pi

          !Velocities for the half ship (flow is symetric)
          vel(1,Row,Col) = vel(1,Row,Col)+vp(1)
          vel(2,Row,Col) = vel(2,Row,Col)-vp(2)
          vel(3,Row,Col) = vel(3,Row,Col)+vp(3)

          !Finally, make the a(i,j) matrix components satisfying no flow through the body surface
          am(Row,Col)= DOT_PRODUCT(coordsys(:,3,Row),vel(:,Row,Col))

       END DO

    END DO

!!***********************************************************************************************************************************************
!!
!!  Double Nested Double Do Loop to compute the A matrix
!!  PART 2:  Free Surface B.C.

    Do i=1,nfspanels

       !Get the field points on the first order free surface, include x offset

       Row = npanels + i

       fieldpoint(:)=center(:,Row)

!      !! No mirrors, but need offsets in i and k
       fieldpoint(1)=fieldpoint(1)+deltax
       fieldpoint(3)=0.

       fieldpointp(:) = fieldpoint(:)
       fieldpointp(2) = -fieldpoint(2)

       !! Calculate the contribution of body panels to the free surface condition
       !! ***********************************************************************
       Do j=1,npanels

          Col=j

          !  Call influence functions  Using the Linear free surface condition
          vel(:,Row,Col)=hsinfluence(fieldpoint(:),        &
                                     center(:,Col),        &
                                     area(Col),            &
                                     coordsys(:,:,Col),    &
                                     cornerslocal(:,:,Col))

          vp(:)=hsinfluence(fieldpointp(:),       &
                            center(:,Col),        &
                            area(Col),            &
                            coordsys(:,:,Col),    &
                            cornerslocal(:,:,Col))

          !Velocities for the half ship (flow is symetric)
          vel(1,Row,Col) = vel(1,Row,Col)+vp(1)
          vel(2,Row,Col) = vel(2,Row,Col)-vp(2)
          vel(3,Row,Col) = vel(3,Row,Col)+vp(3)

          hessglobal(:,:,Row,Col)=phixxinfluence(fieldpoint(:),        &
                                                 center(:,Col),        &
                                                 area(Col),            &
                                                 coordsys(:,:,Col),    &
                                                 cornerslocal(:,:,Col))

          hp(:,:)=phixxinfluence(fieldpointp(:),       &
                                 center(:,Col),        &
                                 area(Col),            &
                                 coordsys(:,:,Col),    &
                                 cornerslocal(:,:,Col))

          hessglobal(1,1,Row,Col)=hessglobal(1,1,Row,Col)+hp(1,1)

          !Finally, make the a(i,j) matrix components satisfying the FS BC
          am(Row,Col)= (vinf(1)**2.)*hessglobal(1,1,Row,Col) + gravity*vel(3,Row,Col)

       END DO

       !! Calculate the contribution of free surface panels to the free surface condition
       !!********************************************************************************
       Do j=1,nfspanels

          Col=j+npanels

          !   Enforce PHIz
          vel(:,Row,Col)=hsinfluence(fieldpoint(:),center(:,Col),area(Col),coordsys(:,:,Col),cornerslocal(:,:,Col))
          vp(:)=hsinfluence(fieldpointp(:),center(:,Col),area(Col),coordsys(:,:,Col),cornerslocal(:,:,Col))

             !Velocities for the half ship (flow is symetric)
          vel(1,Row,Col) = vel(1,Row,Col)+vp(1)
          vel(2,Row,Col) = vel(2,Row,Col)-vp(2)
          vel(3,Row,Col) = vel(3,Row,Col)+vp(3)

          ! Enforce PHIxx squared
          hessglobal(:,:,Row,Col)=phixxinfluence(fieldpoint(:),center(:,Col),area(Col),coordsys(:,:,Col),cornerslocal(:,:,Col))
          hp(:,:)=phixxinfluence(fieldpointp(:),center(:,Col),area(Col),coordsys(:,:,Col),cornerslocal(:,:,Col))

          hessglobal(1,1,Row,Col)=hessglobal(1,1,Row,Col)+hp(1,1)

          !Finally, make the a(i,j) matrix components satisfying the FS BC
          am(Row,Col)= (vinf(1)**2.)*hessglobal(1,1,Row,Col) + gravity*vel(3,Row,Col)

       END DO

    END DO
!!************************************************************************************************

!!  End of a(i,j) matrix computations
!!---------------------------------------------------------------------

!!---------------------------------------------------------------------
!!  Compute the RHS

  DO i=1, npanels

     b(i)= DOT_PRODUCT(coordsys(:,3,i),vinf)  !From MODULE "SLAE"

  END DO

  Do i=1, nfspanels
     row=i+npanels
     b(row)=0.
  end do

!!  RHS done
!!---------------------------------------------------------------------

!! Additional Control Parameters for the Simqit matrix inverter
  Amatmax = maxval(am)                  !returns the largest value in am
  sing = REAL(1.e-6,kind=wp)*Amatmax    !make the matrix singular if any value exceeds Amatmax
  av = sqrt(1./REAL(npanels+nfspanels))
  dx = 0.000001
  nmax = npanels+nfspanels+2

  !!  Invert the a matrix and solve for the Source Strength
  call SIMQIT(TRANSPOSE(am), b, npanels+nfspanels, nmax, &
       sing, av, dx, sigma, iter)

  write(6,*) 'inversion finished '
  write(6,*) 'number of simquit iterations', iter

!Dealocate a and b matrices!

  IF (ALLOCATED(am)) DEALLOCATE(am)
  IF (ALLOCATED(b)) DEALLOCATE(b)

! Allocate space for flow data
  ALLOCATE(vtotal(3,npanels+nfspanels))
  ALLOCATE(vn(npanels+nfspanels))
  ALLOCATE(vt1(npanels+nfspanels))
  ALLOCATE(vt2(npanels+nfspanels))
  ALLOCATE(cp(npanels+nfspanels))
  ALLOCATE(zeta(npanels+nfspanels))
  !ALLOCATE(profilewave(nfspanels/32))

  !!Evaluate Flow Properties
  !!************************************************************
  Do i=1,npanels+nfspanels
     vtotal(:,i) = -vinf(:)
     Do j=1, npanels+nfspanels
        vtotal(:,i)=vtotal(:,i)+sigma(j)*vel(:,i,j)
      End Do

     !! Get the NORMAL VELOCITY on each panel:
     vn(i)=Dot_Product(coordsys(:,3,i),vtotal(:,i))
     !Should be 0 for all panels

     !write(6,*) vn

     !! Get the tangent components on a panel
     vt1(i)=dot_product(coordsys(:,1,i),vtotal(:,i))
     vt2(i)=dot_product(coordsys(:,2,i),vtotal(:,i))

  End Do

  Do i=1,npanels

     ! Get the pressure on each panel from the steady Bernoulli Equation:
     cp(i)=1.-((sum(vtotal(:,i)**2))/(sum(vinf**2)))

  End do

  sourcesink=0.
  Do i=1,npanels+nfspanels
     sourcesink = sourcesink+sigma(i)*area(i)
  end do

  write(6,*) 'sourcesink sum (should be near 0.)',sourcesink

!!************************************************************
!! Compute the wave height
  zeta=0.
  Do i=1,nfspanels
      Row=i+npanels
      !zeta(Row) = zeta(Row)+ ((vinf(1)/gravity)*sigma(Col)*vel(1,Row,Col))     ! Free surface wave elevation
      !zeta(Row) = zeta(Row)+ ((vinf(1)/gravity)*vtotal(1,Row))   !4-26-10 old
      zeta(Row) = (vinf(1)/gravity)*(vtotal(1,Row) + vinf(1))
   End Do

!! Coompute the forces on the hull

   force(:)=(/0.,0.,0./)

   Do i=1,npanels  ! Hull summation only

      if(center(3,i)<0.)Then

      force(:)=force(:)+ area(i)*( .5*1025.*sum(vinf**2.)*cp(i)-1025.*gravity*center(3,i) )*coordsys(:,3,i)
      Else

      End if

  end do
  !force(1)=2.*force(1)

!! Wave Resistance Coefficient

  S=0.
  Do i=1,npanels
     if(center(3,i)<0.)Then
        S=S+area(i)
        Else
        End if
     End do

  cw = -force(1)/(.5*1000.*(vinf(1)**2.)*S)

  write(6,*) 'wave resistance coefficient, cw'
  write(6,*) 'cw:', cw
  write(6,*) 'force', force

  do i=npanels,npanels+128
     row=(i-npanels)
     profilewave(:,row) = (/center(1,i)+deltax, zeta(i)/)
  end do

write(*,*) ''
write(6,*) 'writing output dat and paraview files...'
!!Write solution data to the output file
!!----------------------------------------------------------------------
     CALL output( outputfile, iter, sourcesink, cw, profilewave )
!!----------------------------------------------------------------------

  !! Store the wave data on each free surface panel...
  !!***************************************************************

    ! First we store data valid for a panel (cell in VTK jargon)

  ! Create a file name with the appropriate extension
   i = INDEX(outputfile, ".", BACK=.TRUE.)
   IF (i == 0) THEN
      WRITE(datafile1, '(A,A,A)')  TRIM(outputfile), 'wave', '.vtp'
   ELSE
      IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
      WRITE(datafile1, '(A,A,A)')  outputfile(1:i-1), 'wave', '.vtp'
   ENDIF
   PRINT*, datafile1

   iounit = 10
   CALL VtkXmlPolyDataCellScalar( iounit, datafile1, npoints, &
         0, 0, 0, npanels+nfspanels, &
         RESHAPE(points, (/3*npoints/)), &
         RESHAPE((panels-1), (/4*(npanels+nfspanels)/)), &
         scalar1=zeta, &
         scalar2=sigma, &
         namescalar1='zeta', &
         namescalar2='sigma')

  !! Lets try to store the cp on each hull panel...
  !!***************************************************************
  !!
  !! First we store data valid for a panel (cell in VTK jargon)

  ! Create a file name with the appropriate extension
   i = INDEX(outputfile, ".", BACK=.TRUE.)
   IF (i == 0) THEN
      WRITE(datafile2, '(A,A,A)')  TRIM(outputfile), 'pressure', '.vtp'
   ELSE
      IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
      WRITE(datafile2, '(A,A,A)')  outputfile(1:i-1), 'pressure', '.vtp'
   ENDIF
   PRINT*, datafile2

   iounit = 10
   CALL VtkXmlPolyDataCellScalar( iounit, datafile2, npoints, &
         0, 0, 0, npanels, &
         RESHAPE(points, (/3*npoints/)), &
         RESHAPE((panels-1), (/4*(npanels)/)), &
         scalar1=cp, &
         namescalar1='cp')

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

  !! Now the vector data on each panel...
  !!***************************************************************
  !!
  !! Face specific
  !! Scalar components of the velocity vector
  !!
  i = INDEX(outputfile, ".", BACK=.TRUE.)
  IF (i == 0) THEN
     WRITE(datafile3, '(A,A,A)')  TRIM(outputfile), 'VelComponents', '.vtp'
  ELSE
     IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
     WRITE(datafile3, '(A,A,A)')  outputfile(1:i-1), 'VelComponents', '.vtp'
  ENDIF
  PRINT*, datafile3

  iounit = 10
  CALL VtkXmlPolyDataCellScalar( iounit, datafile3, npoints, &
        0, 0, 0, npanels+nfspanels, &
        RESHAPE(points, (/3*npoints/)), &
        RESHAPE((panels-1), (/4*(npanels+nfspanels)/)), &
        scalar1=vn, &
        scalar2=vt1, &
        scalar3=vt2, &
        namescalar1='vn', &
        namescalar2='vt1', &
        namescalar3='vt2')
  !!
  !!******************************************************************

  ! De-allocate all arrays
  IF (ALLOCATED(points)) DEALLOCATE(points)
  IF (ALLOCATED(panels)) DEALLOCATE(panels)

  IF (ALLOCATED(center)) DEALLOCATE(center)
  IF (ALLOCATED(coordsys)) DEALLOCATE(coordsys)
  IF (ALLOCATED(cornerslocal)) DEALLOCATE(cornerslocal)
  IF (ALLOCATED(area)) DEALLOCATE(area)

  IF (ALLOCATED(vel)) DEALLOCATE(vel)

  IF (ALLOCATED(sigma)) DEALLOCATE(sigma)

  IF (ALLOCATED(vtotal)) DEALLOCATE(vtotal)
  IF (ALLOCATED(vn)) DEALLOCATE(vn)
  IF (ALLOCATED(vt1)) DEALLOCATE(vt1)
  IF (ALLOCATED(vt2)) DEALLOCATE(vt2)
  IF (ALLOCATED(cp)) DEALLOCATE(cp)
  IF (ALLOCATED(vtest)) DEALLOCATE(vtest)
  IF (ALLOCATED(velt)) DEALLOCATE(velt)
  IF (ALLOCATED(zeta)) DEALLOCATE(zeta)

END PROGRAM flowsolver


      SUBROUTINE MB04TV( UPDATZ, N, NRA, NCA, IFIRA, IFICA, A, LDA, E,
     $                   LDE, Z, LDZ )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a submatrix A(k) of A to upper triangular form by column
C     Givens rotations only.
C     Here A(k) = A(IFIRA:ma,IFICA:na) where ma = IFIRA - 1 + NRA,
C     na = IFICA - 1 + NCA.
C     Matrix A(k) is assumed to have full row rank on entry. Hence, no
C     pivoting is done during the reduction process. See Algorithm 2.3.1
C     and Remark 2.3.4 in [1].
C     The constructed column transformations are also applied to matrix
C     E(k) = E(1:IFIRA-1,IFICA:na).
C     Note that in E columns are transformed with the same column
C     indices as in A, but with row indices different from those in A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATZ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal column transformations, as
C             follows:
C             = .FALSE.: Do not form Z;
C             = .TRUE.:  The given matrix Z is updated by the orthogonal
C                        column transformations used in the reduction.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             Number of columns of A and E.  N >= 0.
C
C     NRA     (input) INTEGER
C             Number of rows in A to be transformed.  0 <= NRA <= LDA.
C
C     NCA     (input) INTEGER
C             Number of columns in A to be transformed.  0 <= NCA <= N.
C
C     IFIRA   (input) INTEGER
C             Index of the first row in A to be transformed.
C
C     IFICA   (input) INTEGER
C             Index of the first column in A to be transformed.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the elements of A(IFIRA:ma,IFICA:na) must
C             contain the submatrix A(k) of full row rank to be reduced
C             to upper triangular form.
C             On exit, it contains the transformed matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,NRA).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the elements of E(1:IFIRA-1,IFICA:na) must
C             contain the submatrix E(k).
C             On exit, it contains the transformed matrix E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,IFIRA-1).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             On entry, if UPDATZ = .TRUE., then the leading N-by-N
C             part of this array must contain a given matrix Z (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading N-by-N part of this array contains the
C             product of the input matrix Z and the column
C             transformation matrix that has transformed the columns of
C             the matrices A and E.
C             If UPDATZ = .FALSE., the array Z is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDZ = 1 and declare this array to be Z(1,1) in the calling
C             program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If UPDATZ = .TRUE.,
C             LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1.
C
C     REFERENCES
C
C     [1] Beelen, Th.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology,
C         The Netherlands, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB04FV by Th.G.J. Beelen,
C     Philips Glass Eindhoven, Holland.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, orthogonal transformation,
C     staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           UPDATZ
      INTEGER           IFICA, IFIRA, LDA, LDE, LDZ, N, NCA, NRA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), Z(LDZ,*)
C     .. Local Scalars ..
      INTEGER           I, IFIRA1, J, JPVT
      DOUBLE PRECISION  SC, SS
C     .. External Subroutines ..
      EXTERNAL          DROT, DROTG
C     .. Executable Statements ..
C
      IF ( N.LE.0 .OR. NRA.LE.0 .OR. NCA.LE.0 )
     $   RETURN
      IFIRA1 = IFIRA - 1
      JPVT = IFICA + NCA
C
      DO 40 I = IFIRA1 + NRA, IFIRA, -1
         JPVT = JPVT - 1
C
         DO 20 J = JPVT - 1, IFICA, -1
C
C           Determine the Givens transformation on columns j and jpvt
C           to annihilate A(i,j). Apply the transformation to these
C           columns from rows 1 up to i.
C           Apply the transformation also to the E-matrix (from rows 1
C           up to ifira1).
C           Update column transformation matrix Z, if needed.
C
            CALL DROTG( A(I,JPVT), A(I,J), SC, SS )
            CALL DROT( I-1, A(1,JPVT), 1, A(1,J), 1, SC, SS )
            A(I,J) = ZERO
            CALL DROT( IFIRA1, E(1,JPVT), 1, E(1,J), 1, SC, SS )
            IF( UPDATZ ) CALL DROT( N, Z(1,JPVT), 1, Z(1,J), 1, SC, SS )
   20    CONTINUE
C
   40 CONTINUE
C
      RETURN
C *** Last line of MB04TV ***
      END


  subroutine sfis (sxfi, bs, rs, fis, dataObj)

! ======================================================================
!
!   Calculates r**2 * (the Coulomb potential) as a function of r.
!
!   CEM95 written by S. G. Mashnik
!
!    Edited by A. J. Sierk  LANL  T-2  February, 1996.
!    Modified by A. J. Sierk  LANL  T-2  March, 1996.
!    Modified by AJS, March, 1999.
!   "Last" change: 14-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMDataParams, only: zro

    implicit none
    real(real64), intent(in   ) :: sxfi
    real(real64), intent(in   ) :: bs
    real(real64), intent(in   ) :: rs
    real(real64), intent(  out) :: fis
    type(StandardDCMData), intent(inout) :: dataObj

    real(real64)   :: ab1, ab2, rsm
    procedure(IntegralInterface), pointer :: ss1Ptr => ss1
    procedure(IntegralInterface), pointer :: ss2Ptr => ss2

! ======================================================================

    rsm = dataObj%target%zoneBoundR( dataObj%options%numZones )

    call sfint1 (ss2Ptr, sxfi, zro, bs, rs, ab1, dataObj)
    call sfint1 (ss1Ptr, rsm, sxfi, bs, rs, ab2, dataObj)
    fis = (ab1 + ab2*sxfi)*sxfi

    return

! ======================================================================
  end subroutine sfis


        SUBROUTINE ZINTEG(X,Y,N,XLOW,XHIGH,NI,RLOW,RHIGH,TOTAL)
*
* Module Number:
*
* Module Name: zinteg
*
* Keyphrase:
* ----------
* trapezoidal integration
*
* Description:
* ------------
* The input tabular function X, Y is integrated between XLOW and XHIGH
* using trapezoidal integration.  The effective indices of XLOW and
* XHIGH in X are also returned.
*
* Fortran Name: zinteg.for
*
* Keywords of accessed files and tables:
* --------------------------------------
*       none
*
* Subroutines Called:
* -------------------
* CDBS:
*       zindex
* SDAS:
*       none
*
* History:
* --------
* version         date            Author          Description
*    1          3/5/87          D. Lindler      Designed and coded
*
*-------------------------------------------------------------------------
*
* Input parameters
*
*       X - vector of x-positions (real*8)
*       Y - vector of y-positions (real*8)
*       N - number of points in X and Y
*       XLOW - vector of lower limits of integration (real*8)
*       XHIGH - vector of upper limits of integration (real*8)
*       NI - number of points in XLOW and XHIGH (integer)
*
* Output parameters
*
*       RLOW - vector of effective indices of XLOW (real*8)
*       RHIGH - vector of effective indices of XHIGH (real*8)
*       TOTAL - vector of integrations between XLOW and XHIGH (real*8)
*
	IMPLICIT NONE
        DOUBLE PRECISION X(*),Y(*),XLOW(*),XHIGH(*),TOTAL(*),
     *                      RLOW(*),RHIGH(*)
        INTEGER N,NI
*
* LOCAL VARIABLES
*
        DOUBLE PRECISION Y1,Y2,V1,V2,SUM,R1,R2
        INTEGER I,J
        INTEGER I1,I2
*---------------------------------------------------------------------------
C
C LOOP ON POINTS IN XLOW AND XHIGH
C
        DO 1000 I=1,NI
C
C COMPUTE INDICES OF XLOW(I) AND XHIGH(I)
C
                CALL ZINDEX(X,N,XLOW(I),I1,R1)
                CALL ZINDEX(X,N,XHIGH(I),I2,R2)
C
C INTEGRATE BETWEEN I1 AND I2 (COMPUTE TWICE THE INTEGRAL)
C WE WILL DIVIDE BY TWO AT THE END
C
                SUM=0.0
                IF(I2.NE.I1) THEN
                        DO 100 J=I1,I2-1
                                SUM=SUM+(Y(J)+Y(J+1))*(X(J+1)-X(J))
100                     CONTINUE
                ENDIF
C
C COMPUTE FUNCTION VALUE AT R1 AND R2
C
                Y1 = Y(I1) + (R1-I1)*(Y(I1+1)-Y(I1))
                Y2 = Y(I2) + (R2-I2)*(Y(I2+1)-Y(I2))
C
C COMPUTE INTEGRAL FROM I1 TO R1
C
                V1 = (Y(I1)+Y1)*(XLOW(I)-X(I1))
C
C COMPUTE INTEGRAL FROM I2 TO R2
C
                V2 = (Y(I2)+Y2)*(XHIGH(I)-X(I2))
C
C INTEGRAL FROM R1 TO R2  INTEGRAL(I1-I2) + INTEGRAL(I2-R2) - INTEGRAL(I1,R1)
C
                SUM=SUM+V2-V1
                TOTAL(I)=SUM/2.0
                RLOW(I)=R1
                RHIGH(I)=R2
1000    CONTINUE
        RETURN
        END


module Environment
use standard_collection
use atmosphere1976
implicit none

contains

!------------------------------------
!-       Atmosphere Calculate
!------------------------------------

subroutine Atmosphere_Setting(Ta_0,P_0,rho_0,g0,Z,g,Cs,Ta,P,rho)

  real(8),intent(in) :: Ta_0,P_0,rho_0,g0,Z
  real(8),intent(out) :: g,Cs
  real(8),intent(inout) :: Ta,P,rho

  call Atmosphere(Z/1000.0d0,rho,P,Ta)
  Ta = Ta*Ta_0
  P = P*P_0
  rho = rho*rho_0

  g = g0*(Re / (Re + Z))**2

  Cs = sqrt(ganma*R*Ta)

end subroutine Atmosphere_Setting

!------------------------------------
!-    Velocity of Wind Calculate
!------------------------------------

subroutine VelocityOfWind_Vecter(Vw_syn,Vw_angle,Z,Hw,Wh,Vw)

  real(8),intent(in) :: Vw_syn,Vw_angle,Z,Hw,Wh
  real(8),intent(out) :: Vw(:)

  !風 向 は - を つ け て deg か ら の 風 に し て る

  Vw(1) = -Vw_syn*cos(deg2rad(Vw_angle))*(Z / Hw)**(1.0d0 / Wh)
  Vw(2) = -Vw_syn*sin(deg2rad(Vw_angle))*(Z / Hw)**(1.0d0 / Wh)
  Vw(3) = 0.0d0

end subroutine VelocityOfWind_Vecter

end module Environment


      SUBROUTINE XS_RDF (TT1,TT2,IVM)
C--
c--   SUBROUTINE XS_RDF (TT1,TT2,IVM)
C--
C--   Purpose: compute zonal-mean cross-sec. of random diabatic forcing
C--   Input: TT1, TT2 = diabatic heating fields
C--          IVM      = index of vertical mode (1 or 2)
C--   Modified common block: RANDF
C--
      include "atparam.h"
      include "atparam1.h"

      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

      include "com_physcon.h"

      include "com_randfor.h"

      real tt1(nlon,nlat,nlev), tt2(nlon,nlat,nlev)

      real rand1(0:nlat+1)

      rnlon = 1./float(nlon)
      pigr2 = 4.*asin(1.)

C--   1. Compute cross sections

      do k=1,nlev

         if (ivm.eq.1) then
            rnsig = rnlon
         else
            rnsig = rnlon*sin(pigr2*sig(k))
         endif

         do j=1,nlat
           randfv(j,k,ivm) = 0.
           do i=1,nlon
              randfv(j,k,ivm) = randfv(j,k,ivm)+tt1(i,j,k)+tt2(i,j,k)
           enddo
           randfv(j,k,ivm) = randfv(j,k,ivm)*rnsig
         enddo

      enddo

C--   2. Perform smoothing in latitude

      do nsmooth=1,2
        do k=1,nlev

          do j=1,nlat
             rand1(j) = randfv(j,k,ivm)
          enddo
          rand1(0) = rand1(2)
          rand1(nlat+1) = rand1(nlat-1)

          do j=1,nlat
             randfv(j,k,ivm) = 0.5*rand1(j)+0.25*(rand1(j-1)+rand1(j+1))
          enddo

        enddo
      enddo

      return
      end

      SUBROUTINE SETRDF (TT_RDF)
C--
c--   SUBROUTINE SETRDF (TT_RDF)
C--
C--   Purpose: compute 3-D pattern of random diabatic forcing
C--   Output: TT_RDF = random diabatic forcing
C--
      include "atparam.h"
      include "atparam1.h"

      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

      include "com_randfor.h"

      real tt_rdf(nlon,nlat,nlev)

      do k=1,nlev
        do j=1,nlat
           do i=1,nlon
               tt_rdf(i,j,k) = randfh(i,j,1)*randfv(j,k,1)+
     &                         randfh(i,j,2)*randfv(j,k,2)
           enddo
         enddo
       enddo

       return
       end


      REAL FUNCTION slRVER (PHI, RA, DA, ST)
*+
*     - - - - - - -
*      R V E R
*     - - - - - - -
*
*  Velocity component in a given direction due to Earth rotation
*  (single precision)
*
*  Given:
*     PHI     real    latitude of observing station (geodetic)
*     RA,DA   real    apparent RA,DEC
*     ST      real    local apparent sidereal time
*
*  PHI, RA, DEC and ST are all in radians.
*
*  Result:
*     Component of Earth rotation in direction RA,DA (km/s)
*
*  Sign convention:
*     The result is +ve when the observatory is receding from the
*     given point on the sky.
*
*  Accuracy:
*     The simple algorithm used assumes a spherical Earth, of
*     a radius chosen to give results accurate to about 0.0005 km/s
*     for observing stations at typical latitudes and heights.  For
*     applications requiring greater precision, use the routine
*     slPVOB.
*
*  P.T.Wallace   Starlink   20 July 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL PHI,RA,DA,ST

*  Nominal mean sidereal speed of Earth equator in km/s (the actual
*  value is about 0.4651)
      REAL ESPEED
      PARAMETER (ESPEED=0.4655)

      slRVER=ESPEED*COS(PHI)*SIN(ST-RA)*COS(DA)

      END


! from http://calcul.math.cnrs.fr/Documents/Ecoles/2010/f2py-cours.pdf
! Pierre Navaro

!
! f2py does not handle derived types (structs)
! => the TRICK is to let f2py think that the struct is an integer(8)
!    ! default integer= integer(4) do not work on 64 machines!!
!

module mesh
    implicit none
    type :: geometry
        real(8) :: x0, x1, dx ! coordinates of origin and grid size
        integer :: nx ! number of grid points
        real(8), dimension(:), pointer :: xgrid ! coordinates of points
    end type geometry

contains
    subroutine create(geom,x0,nx,dx)
        !f2py integer(8), intent(out) :: geom
        type(geometry), pointer :: geom
        !type(geometry), allocatable :: geom  ! also works
        real(8), intent(in) :: x0, dx
        integer, intent(in) :: nx
        integer :: i
        allocate(geom)
        print *, associated(geom)
        !print *, allocated(geom)  ! with allocatable
        geom%x0=x0; geom%x1=x0+nx*dx; geom%dx=dx; geom%nx=nx
        allocate(geom%xgrid(nx))
        do i=1,nx
            geom%xgrid(i)=geom%x0+(i-1)*geom%dx
        end do
    end subroutine create

    subroutine view(this)
        !f2py integer(8), intent(in) :: this
        type(geometry),allocatable :: this
        print*, 'nx = ', this%nx
        print*, 'x0 = ', this%x0, ' x1 = ', this%x1
        print*, 'xgrid = ', this%xgrid(:)
    end subroutine view
end module mesh


program test
      integer :: a = (2*3) * 2 * 2
      integer :: b = 2 * 3 * 2

      if ( a / b == 2) THEN
        a = 11
      END IF

      PRINT *,a
end program test


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_OPERATOR_XUV

    USE MR_KINDS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: OPERATOR( .MRXUVDTM. )
    PUBLIC :: OPERATOR( .MRXUVTPS. ) , OPERATOR( .MRXUVIVS. ) , OPERATOR( .MRXUVMAT. )

    INTERFACE OPERATOR( .MRXUVDTM. )
      MODULE PROCEDURE MR_TENSOR_DETERMINANT_KIND4
      MODULE PROCEDURE MR_TENSOR_DETERMINANT_KIND8
    END INTERFACE

    INTERFACE OPERATOR( .MRXUVTPS. )
      MODULE PROCEDURE MR_TENSOR_TRANSPOSE_KIND4
      MODULE PROCEDURE MR_TENSOR_TRANSPOSE_KIND8
    END INTERFACE

    INTERFACE OPERATOR( .MRXUVIVS. )
      MODULE PROCEDURE MR_TENSOR_INVERSE_KIND4_X_KIND4
      MODULE PROCEDURE MR_TENSOR_INVERSE_KIND8_X_KIND4
      MODULE PROCEDURE MR_TENSOR_INVERSE_KIND4_X_KIND8
      MODULE PROCEDURE MR_TENSOR_INVERSE_KIND8_X_KIND8
    END INTERFACE

    INTERFACE OPERATOR( .MRXUVMAT. )
      MODULE PROCEDURE MR_TENSOR_MATRIX_MULTIPLY_KIND4_X_KIND4
      MODULE PROCEDURE MR_TENSOR_MATRIX_MULTIPLY_KIND8_X_KIND4
      MODULE PROCEDURE MR_TENSOR_MATRIX_MULTIPLY_KIND4_X_KIND8
      MODULE PROCEDURE MR_TENSOR_MATRIX_MULTIPLY_KIND8_X_KIND8
    END INTERFACE

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_DETERMINANT_KIND4( XUV0 ) RESULT( XUVDTM )

    IMPLICIT NONE

    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (4)         , ALLOCATABLE , DIMENSION(:,:    ) :: XUVDTM

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVDTM(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2)) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , SIZE(XUV0,DIM=1)
        XUVDTM( I , J ) = XUV0( I , J ,1,1) * XUV0( I , J ,2,2) - XUV0( I , J ,2,1) * XUV0( I , J ,1,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_DETERMINANT_KIND4

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_DETERMINANT_KIND8( XUV0 ) RESULT( XUVDTM )

    IMPLICIT NONE

    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (8)         , ALLOCATABLE , DIMENSION(:,:    ) :: XUVDTM

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVDTM(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2)) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , SIZE(XUV0,DIM=1)
        XUVDTM( I , J ) = XUV0( I , J ,1,1) * XUV0( I , J ,2,2) - XUV0( I , J ,2,1) * XUV0( I , J ,1,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_DETERMINANT_KIND8

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_TRANSPOSE_KIND4( XUV0 ) RESULT( XUVTPS )

    IMPLICIT NONE

    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (4)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVTPS

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVTPS(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , SIZE(XUV0,DIM=1)
        XUVTPS( I , J ,1,1) = XUV0( I , J ,1,1)
        XUVTPS( I , J ,2,1) = XUV0( I , J ,1,2)
        XUVTPS( I , J ,1,2) = XUV0( I , J ,2,1)
        XUVTPS( I , J ,2,2) = XUV0( I , J ,2,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_TRANSPOSE_KIND4

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_TRANSPOSE_KIND8( XUV0 ) RESULT( XUVTPS )

    IMPLICIT NONE

    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (8)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVTPS

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVTPS(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , SIZE(XUV0,DIM=1)
        XUVTPS( I , J ,1,1) = XUV0( I , J ,1,1)
        XUVTPS( I , J ,2,1) = XUV0( I , J ,1,2)
        XUVTPS( I , J ,1,2) = XUV0( I , J ,2,1)
        XUVTPS( I , J ,2,2) = XUV0( I , J ,2,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_TRANSPOSE_KIND8

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_INVERSE_KIND4_X_KIND4( MW , XUV0 ) RESULT( XUVIVS )

    IMPLICIT NONE

    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:    ) :: MW
    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (4)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVIVS

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVIVS(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(MW,DIM=1) , SIZE(XUV0,DIM=1) )
        XUVIVS( I , J ,1,1) = XUV0( I , J ,2,2) / MW( I , J )
        XUVIVS( I , J ,2,1) =-XUV0( I , J ,2,1) / MW( I , J )
        XUVIVS( I , J ,1,2) =-XUV0( I , J ,1,2) / MW( I , J )
        XUVIVS( I , J ,2,2) = XUV0( I , J ,1,1) / MW( I , J )
      END DO
    END DO

  END FUNCTION MR_TENSOR_INVERSE_KIND4_X_KIND4

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_INVERSE_KIND8_X_KIND4( MW , XUV0 ) RESULT( XUVIVS )

    IMPLICIT NONE

    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:    ) :: MW
    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (4)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVIVS

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVIVS(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(MW,DIM=1) , SIZE(XUV0,DIM=1) )
        XUVIVS( I , J ,1,1) = XUV0( I , J ,2,2) / MW( I , J )
        XUVIVS( I , J ,2,1) =-XUV0( I , J ,2,1) / MW( I , J )
        XUVIVS( I , J ,1,2) =-XUV0( I , J ,1,2) / MW( I , J )
        XUVIVS( I , J ,2,2) = XUV0( I , J ,1,1) / MW( I , J )
      END DO
    END DO

  END FUNCTION MR_TENSOR_INVERSE_KIND8_X_KIND4

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_INVERSE_KIND4_X_KIND8( MW , XUV0 ) RESULT( XUVIVS )

    IMPLICIT NONE

    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:    ) :: MW
    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (8)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVIVS

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVIVS(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(MW,DIM=1) , SIZE(XUV0,DIM=1) )
        XUVIVS( I , J ,1,1) = XUV0( I , J ,2,2) / MW( I , J )
        XUVIVS( I , J ,2,1) =-XUV0( I , J ,2,1) / MW( I , J )
        XUVIVS( I , J ,1,2) =-XUV0( I , J ,1,2) / MW( I , J )
        XUVIVS( I , J ,2,2) = XUV0( I , J ,1,1) / MW( I , J )
      END DO
    END DO

  END FUNCTION MR_TENSOR_INVERSE_KIND4_X_KIND8

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_INVERSE_KIND8_X_KIND8( MW , XUV0 ) RESULT( XUVIVS )

    IMPLICIT NONE

    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:    ) :: MW
    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0

    REAL   (8)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVIVS

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVIVS(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(MW,DIM=1) , SIZE(XUV0,DIM=1) )
        XUVIVS( I , J ,1,1) = XUV0( I , J ,2,2) / MW( I , J )
        XUVIVS( I , J ,2,1) =-XUV0( I , J ,2,1) / MW( I , J )
        XUVIVS( I , J ,1,2) =-XUV0( I , J ,1,2) / MW( I , J )
        XUVIVS( I , J ,2,2) = XUV0( I , J ,1,1) / MW( I , J )
      END DO
    END DO

  END FUNCTION MR_TENSOR_INVERSE_KIND8_X_KIND8

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND4_X_KIND4( XUV0 , XUV ) RESULT( XUVMAT )

    IMPLICIT NONE

    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0
    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV

    REAL   (4)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVMAT

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVMAT(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(XUV0,DIM=1) , SIZE(XUV,DIM=1) )
        XUVMAT( I , J ,1,1) = XUV0( I , J ,1,1) * XUV( I , J ,1,1) + XUV0( I , J ,1,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,2,1) = XUV0( I , J ,2,1) * XUV( I , J ,1,1) + XUV0( I , J ,2,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,1,2) = XUV0( I , J ,1,1) * XUV( I , J ,1,2) + XUV0( I , J ,1,2) * XUV( I , J ,2,2)
        XUVMAT( I , J ,2,2) = XUV0( I , J ,2,1) * XUV( I , J ,1,2) + XUV0( I , J ,2,2) * XUV( I , J ,2,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND4_X_KIND4

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND8_X_KIND4( XUV0 , XUV ) RESULT( XUVMAT )

    IMPLICIT NONE

    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0
    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV

    REAL   (8)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVMAT

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVMAT(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(XUV0,DIM=1) , SIZE(XUV,DIM=1) )
        XUVMAT( I , J ,1,1) = XUV0( I , J ,1,1) * XUV( I , J ,1,1) + XUV0( I , J ,1,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,2,1) = XUV0( I , J ,2,1) * XUV( I , J ,1,1) + XUV0( I , J ,2,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,1,2) = XUV0( I , J ,1,1) * XUV( I , J ,1,2) + XUV0( I , J ,1,2) * XUV( I , J ,2,2)
        XUVMAT( I , J ,2,2) = XUV0( I , J ,2,1) * XUV( I , J ,1,2) + XUV0( I , J ,2,2) * XUV( I , J ,2,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND8_X_KIND4

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND4_X_KIND8( XUV0 , XUV ) RESULT( XUVMAT )

    IMPLICIT NONE

    REAL   (4)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0
    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV

    REAL   (4)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVMAT

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVMAT(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(XUV0,DIM=1) , SIZE(XUV,DIM=1) )
        XUVMAT( I , J ,1,1) = XUV0( I , J ,1,1) * XUV( I , J ,1,1) + XUV0( I , J ,1,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,2,1) = XUV0( I , J ,2,1) * XUV( I , J ,1,1) + XUV0( I , J ,2,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,1,2) = XUV0( I , J ,1,1) * XUV( I , J ,1,2) + XUV0( I , J ,1,2) * XUV( I , J ,2,2)
        XUVMAT( I , J ,2,2) = XUV0( I , J ,2,1) * XUV( I , J ,1,2) + XUV0( I , J ,2,2) * XUV( I , J ,2,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND4_X_KIND8

!***********************************************************************************************************************************
! UNIT:
!
!  (FUNCTION)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND8_X_KIND8( XUV0 , XUV ) RESULT( XUVMAT )

    IMPLICIT NONE

    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV0
    REAL   (8)         , INTENT(IN ) , DIMENSION(:,:,:,:) :: XUV

    REAL   (8)         , ALLOCATABLE , DIMENSION(:,:,:,:) :: XUVMAT

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE( XUVMAT(1:SIZE(XUV0,DIM=1),1:SIZE(XUV0,DIM=2),1:2,1:2) )

    DO J = 1 , SIZE(XUV0,DIM=2)
     !DIR$ VECTOR ALIGNED
      DO I = 1 , MIN( SIZE(XUV0,DIM=1) , SIZE(XUV,DIM=1) )
        XUVMAT( I , J ,1,1) = XUV0( I , J ,1,1) * XUV( I , J ,1,1) + XUV0( I , J ,1,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,2,1) = XUV0( I , J ,2,1) * XUV( I , J ,1,1) + XUV0( I , J ,2,2) * XUV( I , J ,2,1)
        XUVMAT( I , J ,1,2) = XUV0( I , J ,1,1) * XUV( I , J ,1,2) + XUV0( I , J ,1,2) * XUV( I , J ,2,2)
        XUVMAT( I , J ,2,2) = XUV0( I , J ,2,1) * XUV( I , J ,1,2) + XUV0( I , J ,2,2) * XUV( I , J ,2,2)
      END DO
    END DO

  END FUNCTION MR_TENSOR_MATRIX_MULTIPLY_KIND8_X_KIND8

  END MODULE MR_MOD_OPERATOR_XUV


! Program to test evaluation of integer intrinsics for parameter expressions.
! It also tests propagation of constant expression values.
! Various named constants are defined using the intrinsics and then used to
! declare lengths of character variables, so values appear in symbol table.
! Evaluated integer operators are:
!    + - * / **, char operator: // (for len)
! Evaluated intrinsics are:
!    abs dim ichar index len max min mod sign

program intrins_eval
  integer, parameter :: five = len('12345'), ten = 2*five
  integer, parameter :: fifteen = max(five,ten,15), two = min(five,ten,5/2,11)
  integer, parameter :: seven = abs(-7), thirteen = dim(30,36/2-1)+dim(10,11)
  integer, parameter :: twenty_five = ichar('Z') - ichar('A')
  integer, parameter :: three = index('abcdef','c'), four = mod(five**2,7)
  integer, parameter :: six = mod(41,seven), twenty_one = sign(23,1)+sign(2,-1)
  character :: c5*(five), c10*(ten), c15*(fifteen), c6*(six)
  character :: c7*(seven), c13*(thirteen), c25*(twenty_five)
  character :: c3*(three), c4*(four), c2*(two), c21*(twenty_one)
  complex, parameter :: imag_unit = (0.0, 1.0)
  double complex :: dc = (3.14d0,1.414d0)
  real :: r
  double precision :: d
  integer, dimension(10) :: a
  integer, dimension(2*size(a)) :: b
! Test that return value of CHAR(n) is size 1.
  c2 = char(46) // char(47) // char(48) ! truncation warning
! Test that REAL(intg) returns real
  d = real(20)                  ! gives promotion warning
! Test that ABS(real), REAL(real) return real, IMAG(real) is error
  r = abs(20.0)                 ! OK
  r = imag(20.0)                ! type mismatch
  r = real(20.0)                ! OK
  d = abs(20.0)                 ! promotion warning
  d = real(20.0)                ! promotion warning
! Test that ABS(cplx), IMAG(cplx), REAL(cplx) return real
  r = abs(imag_unit)            ! OK
  r = imag(imag_unit)           ! OK
  r = real(imag_unit)           ! OK
  d = abs(imag_unit)            ! promotion warning
  d = imag(imag_unit)           ! promotion warning
  d = real(imag_unit)           ! promotion warning
! Test that ABS(dcpx), IMAG(dcpx), REAL(dcpx) return real
  r = abs(dc)                   ! truncation warning
  r = imag(dc)                  ! truncation warning
  r = real(dc)                  ! truncation warning
  d = abs(dc)                   ! OK
  d = imag(dc)                  ! OK
  d = real(dc)                  ! OK
! Test evaluation of size intrinsic
  a = b                         ! array size mismatch
end program intrins_eval


      subroutine parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest,
     * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c  given the set of ordered points f(i,j) in the idim-dimensional space,
c  corresponding to grid values (u(i),v(j)) ,i=1,...,mu ; j=1,...,mv,
c  parsur determines a smooth approximating spline surface s(u,v) , i.e.
c    f1 = s1(u,v)
c      ...                u(1) <= u <= u(mu) ; v(1) <= v <= v(mv)
c    fidim = sidim(u,v)
c  with sl(u,v), l=1,2,...,idim bicubic spline functions with common
c  knots tu(i),i=1,...,nu in the u-variable and tv(j),j=1,...,nv in the
c  v-variable.
c  in addition, these splines will be periodic in the variable u if
c  ipar(1) = 1 and periodic in the variable v if ipar(2) = 1.
c  if iopt=-1, parsur determines the least-squares bicubic spline
c  surface according to a given set of knots.
c  if iopt>=0, the number of knots of s(u,v) and their position
c  is chosen automatically by the routine. the smoothness of s(u,v) is
c  achieved by minimalizing the discontinuity jumps of the derivatives
c  of the splines at the knots. the amount of smoothness of s(u,v) is
c  determined by the condition that
c  fp=sumi=1,mu(sumj=1,mv(dist(f(i,j)-s(u(i),v(j)))**2))<=s,
c  with s a given non-negative constant.
c  the fit s(u,v) is given in its b-spline representation and can be
c  evaluated by means of routine surev.
c
c calling sequence:
c     call parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest,nu,tu,
c    *  nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c
c parameters:
c  iopt  : integer flag. unchanged on exit.
c          on entry iopt must specify whether a least-squares surface
c          (iopt=-1) or a smoothing surface (iopt=0 or 1)must be
c          determined.
c          if iopt=0 the routine will start with the initial set of
c          knots needed for determining the least-squares polynomial
c          surface.
c          if iopt=1 the routine will continue with the set of knots
c          found at the last call of the routine.
c          attention: a call with iopt=1 must always be immediately
c          preceded by another call with iopt = 1 or iopt = 0.
c  ipar  : integer array of dimension 2. unchanged on exit.
c          on entry ipar(1) must specify whether (ipar(1)=1) or not
c          (ipar(1)=0) the splines must be periodic in the variable u.
c          on entry ipar(2) must specify whether (ipar(2)=1) or not
c          (ipar(2)=0) the splines must be periodic in the variable v.
c  idim  : integer. on entry idim must specify the dimension of the
c          surface. 1 <= idim <= 3. unchanged on exit.
c  mu    : integer. on entry mu must specify the number of grid points
c          along the u-axis. unchanged on exit.
c          mu >= mumin where mumin=4-2*ipar(1)
c  u     : real array of dimension at least (mu). before entry, u(i)
c          must be set to the u-co-ordinate of the i-th grid point
c          along the u-axis, for i=1,2,...,mu. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c  mv    : integer. on entry mv must specify the number of grid points
c          along the v-axis. unchanged on exit.
c          mv >= mvmin where mvmin=4-2*ipar(2)
c  v     : real array of dimension at least (mv). before entry, v(j)
c          must be set to the v-co-ordinate of the j-th grid point
c          along the v-axis, for j=1,2,...,mv. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c  f     : real array of dimension at least (mu*mv*idim).
c          before entry, f(mu*mv*(l-1)+mv*(i-1)+j) must be set to the
c          l-th co-ordinate of the data point corresponding to the
c          the grid point (u(i),v(j)) for l=1,...,idim ,i=1,...,mu
c          and j=1,...,mv. unchanged on exit.
c          if ipar(1)=1 it is expected that f(mu*mv*(l-1)+mv*(mu-1)+j)
c          = f(mu*mv*(l-1)+j), l=1,...,idim ; j=1,...,mv
c          if ipar(2)=1 it is expected that f(mu*mv*(l-1)+mv*(i-1)+mv)
c          = f(mu*mv*(l-1)+mv*(i-1)+1), l=1,...,idim ; i=1,...,mu
c  s     : real. on entry (if iopt>=0) s must specify the smoothing
c          factor. s >=0. unchanged on exit.
c          for advice on the choice of s see further comments
c  nuest : integer. unchanged on exit.
c  nvest : integer. unchanged on exit.
c          on entry, nuest and nvest must specify an upper bound for the
c          number of knots required in the u- and v-directions respect.
c          these numbers will also determine the storage space needed by
c          the routine. nuest >= 8, nvest >= 8.
c          in most practical situation nuest = mu/2, nvest=mv/2, will
c          be sufficient. always large enough are nuest=mu+4+2*ipar(1),
c          nvest = mv+4+2*ipar(2), the number of knots needed for
c          interpolation (s=0). see also further comments.
c  nu    : integer.
c          unless ier=10 (in case iopt>=0), nu will contain the total
c          number of knots with respect to the u-variable, of the spline
c          surface returned. if the computation mode iopt=1 is used,
c          the value of nu should be left unchanged between subsequent
c          calls. in case iopt=-1, the value of nu should be specified
c          on entry.
c  tu    : real array of dimension at least (nuest).
c          on succesful exit, this array will contain the knots of the
c          splines with respect to the u-variable, i.e. the position of
c          the interior knots tu(5),...,tu(nu-4) as well as the position
c          of the additional knots tu(1),...,tu(4) and tu(nu-3),...,
c          tu(nu) needed for the b-spline representation.
c          if the computation mode iopt=1 is used,the values of tu(1)
c          ...,tu(nu) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values tu(5),
c          ...tu(nu-4) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  nv    : integer.
c          unless ier=10 (in case iopt>=0), nv will contain the total
c          number of knots with respect to the v-variable, of the spline
c          surface returned. if the computation mode iopt=1 is used,
c          the value of nv should be left unchanged between subsequent
c          calls. in case iopt=-1, the value of nv should be specified
c          on entry.
c  tv    : real array of dimension at least (nvest).
c          on succesful exit, this array will contain the knots of the
c          splines with respect to the v-variable, i.e. the position of
c          the interior knots tv(5),...,tv(nv-4) as well as the position
c          of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
c          tv(nv) needed for the b-spline representation.
c          if the computation mode iopt=1 is used,the values of tv(1)
c          ...,tv(nv) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values tv(5),
c          ...tv(nv-4) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  c     : real array of dimension at least (nuest-4)*(nvest-4)*idim.
c          on succesful exit, c contains the coefficients of the spline
c          approximation s(u,v)
c  fp    : real. unless ier=10, fp contains the sum of squared
c          residuals of the spline surface returned.
c  wrk   : real array of dimension (lwrk). used as workspace.
c          if the computation mode iopt=1 is used the values of
c          wrk(1),...,wrk(4) should be left unchanged between subsequent
c          calls.
c  lwrk  : integer. on entry lwrk must specify the actual dimension of
c          the array wrk as declared in the calling (sub)program.
c          lwrk must not be too small.
c           lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+
c           4*(mu+mv)+q*idim where q is the larger of mv and nuest.
c  iwrk  : integer array of dimension (kwrk). used as workspace.
c          if the computation mode iopt=1 is used the values of
c          iwrk(1),.,iwrk(3) should be left unchanged between subsequent
c          calls.
c  kwrk  : integer. on entry kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program.
c          kwrk >= 3+mu+mv+nuest+nvest.
c  ier   : integer. unless the routine detects an error, ier contains a
c          non-positive value on exit, i.e.
c   ier=0  : normal return. the surface returned has a residual sum of
c            squares fp such that abs(fp-s)/s <= tol with tol a relat-
c            ive tolerance set to 0.001 by the program.
c   ier=-1 : normal return. the spline surface returned is an
c            interpolating surface (fp=0).
c   ier=-2 : normal return. the surface returned is the least-squares
c            polynomial surface. in this extreme case fp gives the
c            upper bound for the smoothing factor s.
c   ier=1  : error. the required storage space exceeds the available
c            storage space, as specified by the parameters nuest and
c            nvest.
c            probably causes : nuest or nvest too small. if these param-
c            eters are already large, it may also indicate that s is
c            too small
c            the approximation returned is the least-squares surface
c            according to the current set of knots. the parameter fp
c            gives the corresponding sum of squared residuals (fp>s).
c   ier=2  : error. a theoretically impossible result was found during
c            the iteration proces for finding a smoothing surface with
c            fp = s. probably causes : s too small.
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            abs(fp-s)/s < tol.
c   ier=3  : error. the maximal number of iterations maxit (set to 20
c            by the program) allowed for finding a smoothing surface
c            with fp=s has been reached. probably causes : s too small
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            abs(fp-s)/s < tol.
c   ier=10 : error. on entry, the input data are controlled on validity
c            the following restrictions must be satisfied.
c            -1<=iopt<=1, 0<=ipar(1)<=1, 0<=ipar(2)<=1, 1 <=idim<=3
c            mu >= 4-2*ipar(1),mv >= 4-2*ipar(2), nuest >=8, nvest >= 8,
c            kwrk>=3+mu+mv+nuest+nvest,
c            lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))
c             +4*(mu+mv)+max(nuest,mv)*idim
c            u(i-1)<u(i),i=2,..,mu, v(i-1)<v(i),i=2,...,mv
c            if iopt=-1: 8<=nu<=min(nuest,mu+4+2*ipar(1))
c                        u(1)<tu(5)<tu(6)<...<tu(nu-4)<u(mu)
c                        8<=nv<=min(nvest,mv+4+2*ipar(2))
c                        v(1)<tv(5)<tv(6)<...<tv(nv-4)<v(mv)
c                    the schoenberg-whitney conditions, i.e. there must
c                    be subset of grid co-ordinates uu(p) and vv(q) such
c                    that   tu(p) < uu(p) < tu(p+4) ,p=1,...,nu-4
c                           tv(q) < vv(q) < tv(q+4) ,q=1,...,nv-4
c                     (see fpchec or fpchep)
c            if iopt>=0: s>=0
c                       if s=0: nuest>=mu+4+2*ipar(1)
c                               nvest>=mv+4+2*ipar(2)
c            if one of these conditions is found to be violated,control
c            is immediately repassed to the calling program. in that
c            case there is no approximation returned.
c
c further comments:
c   by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the surface will be too smooth and signal will be
c   lost ; if s is too small the surface will pick up too much noise. in
c   the extreme cases the program will return an interpolating surface
c   if s=0 and the constrained least-squares polynomial surface if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the accuracy of the data values.
c   if the user has an idea of the statistical errors on the data, he
c   can also find a proper estimate for s. for, by assuming that, if he
c   specifies the right s, parsur will return a surface s(u,v) which
c   exactly reproduces the surface underlying the data he can evaluate
c   the sum(dist(f(i,j)-s(u(i),v(j)))**2) to find a good estimate for s.
c   for example, if he knows that the statistical errors on his f(i,j)-
c   values is not greater than 0.1, he may expect that a good s should
c   have a value not larger than mu*mv*(0.1)**2.
c   if nothing is known about the statistical error in f(i,j), s must
c   be determined by trial and error, taking account of the comments
c   above. the best is then to start with a very large value of s (to
c   determine the le-sq polynomial surface and the corresponding upper
c   bound fp0 for s) and then to progressively decrease the value of s
c   ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
c   and more carefully as the approximation shows more detail) to
c   obtain closer fits.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt=0.
c   if iopt = 1 the program will continue with the knots found at
c   the last call of the routine. this will save a lot of computation
c   time if parsur is called repeatedly for different values of s.
c   the number of knots of the surface returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   surface underlying the data. if the computation mode iopt = 1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of trials with different s-values and iopt=1,the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   parsur once more with the chosen value for s but now with iopt=0.
c   indeed, parsur may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c   the number of knots may also depend on the upper bounds nuest and
c   nvest. indeed, if at a certain stage in parsur the number of knots
c   in one direction (say nu) has reached the value of its upper bound
c   (nuest), then from that moment on all subsequent knots are added
c   in the other (v) direction. this may indicate that the value of
c   nuest is too small. on the other hand, it gives the user the option
c   of limiting the number of knots the routine locates in any direction
c   for example, by setting nuest=8 (the lowest allowable value for
c   nuest), the user can indicate that he wants an approximation with
c   splines which are simple cubic polynomials in the variable u.
c
c  other subroutines required:
c    fppasu,fpchec,fpchep,fpknot,fprati,fpgrpa,fptrnp,fpback,
c    fpbacp,fpbspl,fptrpe,fpdisc,fpgivs,fprota
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1989
c
c  ..
c  ..scalar arguments..
      real s,fp
      integer iopt,idim,mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier
c  ..array arguments..
      real u(mu),v(mv),f(mu*mv*idim),tu(nuest),tv(nvest),
     * c((nuest-4)*(nvest-4)*idim),wrk(lwrk)
      integer ipar(2),iwrk(kwrk)
c  ..local scalars..
      real tol,ub,ue,vb,ve,peru,perv
      integer i,j,jwrk,kndu,kndv,knru,knrv,kwest,l1,l2,l3,l4,
     * lfpu,lfpv,lwest,lww,maxit,nc,mf,mumin,mvmin
c  ..function references..
      integer max0
c  ..subroutine references..
c    fppasu,fpchec,fpchep
c  ..
c  we set up the parameters tol and maxit.
      maxit = 20
      tol = 0.1e-02
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 200
      if(ipar(1).lt.0 .or. ipar(1).gt.1) go to 200
      if(ipar(2).lt.0 .or. ipar(2).gt.1) go to 200
      if(idim.le.0 .or. idim.gt.3) go to 200
      mumin = 4-2*ipar(1)
      if(mu.lt.mumin .or. nuest.lt.8) go to 200
      mvmin = 4-2*ipar(2)
      if(mv.lt.mvmin .or. nvest.lt.8) go to 200
      mf = mu*mv
      nc = (nuest-4)*(nvest-4)
      lwest = 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+
     * 4*(mu+mv)+max0(nuest,mv)*idim
      kwest = 3+mu+mv+nuest+nvest
      if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200
      do 10 i=2,mu
        if(u(i-1).ge.u(i)) go to 200
  10  continue
      do 20 i=2,mv
        if(v(i-1).ge.v(i)) go to 200
  20  continue
      if(iopt.ge.0) go to 100
      if(nu.lt.8 .or. nu.gt.nuest) go to 200
      ub = u(1)
      ue = u(mu)
      if (ipar(1).ne.0) go to 40
      j = nu
      do 30 i=1,4
        tu(i) = ub
        tu(j) = ue
        j = j-1
  30  continue
      call fpchec(u,mu,tu,nu,3,ier)
      if(ier.ne.0) go to 200
      go to 60
  40  l1 = 4
      l2 = l1
      l3 = nu-3
      l4 = l3
      peru = ue-ub
      tu(l2) = ub
      tu(l3) = ue
      do 50 j=1,3
        l1 = l1+1
        l2 = l2-1
        l3 = l3+1
        l4 = l4-1
        tu(l2) = tu(l4)-peru
        tu(l3) = tu(l1)+peru
  50  continue
      call fpchep(u,mu,tu,nu,3,ier)
      if(ier.ne.0) go to 200
  60  if(nv.lt.8 .or. nv.gt.nvest) go to 200
      vb = v(1)
      ve = v(mv)
      if (ipar(2).ne.0) go to 80
      j = nv
      do 70 i=1,4
        tv(i) = vb
        tv(j) = ve
        j = j-1
  70  continue
      call fpchec(v,mv,tv,nv,3,ier)
      if(ier.ne.0) go to 200
      go to 150
  80  l1 = 4
      l2 = l1
      l3 = nv-3
      l4 = l3
      perv = ve-vb
      tv(l2) = vb
      tv(l3) = ve
      do 90 j=1,3
        l1 = l1+1
        l2 = l2-1
        l3 = l3+1
        l4 = l4-1
        tv(l2) = tv(l4)-perv
        tv(l3) = tv(l1)+perv
  90  continue
      call fpchep(v,mv,tv,nv,3,ier)
      if(ier) 200,150,200
 100  if(s.lt.0.) go to 200
      if(s.eq.0. .and. (nuest.lt.(mu+4+2*ipar(1)) .or.
     * nvest.lt.(mv+4+2*ipar(2))) )go to 200
      ier = 0
c  we partition the working space and determine the spline approximation
 150  lfpu = 5
      lfpv = lfpu+nuest
      lww = lfpv+nvest
      jwrk = lwrk-4-nuest-nvest
      knru = 4
      knrv = knru+mu
      kndu = knrv+mv
      kndv = kndu+nuest
      call fppasu(iopt,ipar,idim,u,mu,v,mv,f,mf,s,nuest,nvest,
     * tol,maxit,nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),
     * wrk(lfpu),wrk(lfpv),iwrk(1),iwrk(2),iwrk(3),iwrk(knru),
     * iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier)
 200  return
      end


************************************************************************
*
*     Function TRANSF                                  Called by: SETXL
*
*     create an observation of an explanatory variable using the
*     observed value of the data variable (FLOW, DECTIM, or ADDLi, as
*     determined from DVNAME) and the requested transformation (TRANS)
*
*     local vars
*     ----------
*     IADDL   index denoting the additional data variable.  (when the
*             data variable is an 'additional data variable', ADDLI,
*             IADDL tells us which one it is)
*
*     XVAL    observed value of the data variable
*
************************************************************************
      DOUBLE PRECISION FUNCTION TRANSF(DVNAME,TRANS,DECTIM,FLOW,ADDLI,
     &                                 LQCENT)
*
*     function arguments
*
      CHARACTER*(*) DVNAME,TRANS
      DOUBLE PRECISION DECTIM,FLOW,LQCENT
      DOUBLE PRECISION ADDLI(*)
*
*     local var
*
      INTEGER*4 IADDL
      DOUBLE PRECISION XVAL
      DOUBLE PRECISION PI
*
*     define PI
*
      PARAMETER (PI=3.1415926536D0)
*
*     format statement for determining the i in ADDLi
*
 1000 FORMAT(I1)
*
*     using DVNAME, determine the data variable (FLOW, DECTIM, or ADDLI)
*     that's used to create the explanatory variable.  Then set XVAL
*     equal to the observation of the data variable.
*
*     note that valid DVNAMEs are checked on input -- therefore if the
*     ELSE statement is reached, DVNAME is one of the additional
*     data variables ADDLi (where i is less than or equal to NADDL).  I
*     (IADDL) is determined by reading the 5th character in DVNAME.
*
      IF (DVNAME .EQ. 'Q') THEN
         XVAL = FLOW
      ELSEIF (DVNAME .EQ. 'DTIME') THEN
         XVAL = DECTIM
      ELSE
         READ(DVNAME(5:5),1000) IADDL
         XVAL = ADDLI(IADDL)
      ENDIF
*
*     XVAL is now equal to the observation of the data variable. Perform
*     the requested transformation and return the value as TRANSF.
*
*     Note that if the data variable is 'Q', the log transformations
*     include the log Q adjustment such that the user-defined model is
*     consistent with the predefined models.  DECTIM has already been
*     adjusted (the decimal time adjustment) so no special treatment is
*     needed here.
*
      IF (TRANS .EQ. 'NONE') THEN
         TRANSF = XVAL
      ELSEIF(TRANS .EQ. 'SQ') THEN
         TRANSF = XVAL*XVAL
      ELSEIF(TRANS .EQ. 'SQRT') THEN
         TRANSF = SQRT(XVAL)
      ELSEIF(TRANS .EQ. 'LN') THEN
         IF (DVNAME .EQ. 'Q') THEN
            TRANSF = DLOG(XVAL) - LQCENT
         ELSE
            TRANSF = DLOG(XVAL)
         ENDIF
      ELSEIF(TRANS .EQ. 'LNSQ') THEN
         IF (DVNAME .EQ. 'Q') THEN
            TRANSF = (DLOG(XVAL) - LQCENT)**2
         ELSE
            TRANSF = DLOG(XVAL)**2
         ENDIF
      ELSEIF(TRANS .EQ. 'SIN2P') THEN
         TRANSF = DSIN(2.D0*PI*XVAL)
      ELSEIF(TRANS .EQ. 'SIN4P') THEN
         TRANSF = DSIN(4.D0*PI*XVAL)
      ELSEIF(TRANS .EQ. 'SIN6P') THEN
         TRANSF = DSIN(6.D0*PI*XVAL)
      ELSEIF(TRANS .EQ. 'COS2P') THEN
         TRANSF = DCOS(2.D0*PI*XVAL)
      ELSEIF(TRANS .EQ. 'COS4P') THEN
         TRANSF = DCOS(4.D0*PI*XVAL)
      ELSEIF(TRANS .EQ. 'COS6P') THEN
         TRANSF = DCOS(6.D0*PI*XVAL)
      ENDIF

      RETURN
      END


      PROGRAM LA_SPOSVX_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_POSVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, N, NRHS
      CHARACTER(LEN=1) :: EQUED
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), X(:,:), S(:), &
                               FERR(:), BERR(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPOSVX Example Program Results'
      N = 5; NRHS = 3
      ALLOCATE ( A(N,N), B(N,NRHS), X(N,NRHS), S(N), FERR(NRHS), &
                 BERR(NRHS) )

      OPEN(UNIT=21,FILE='posv.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=I,N
         READ(21,'(F3.0)') A(I,J);
         ENDDO
      ENDDO;
      CLOSE(21)

      A(:,1)=1E-6*A(:,1);A(1,2:N)=1E-6*A(1,2:N)

      DO J = 1, NRHS; DO I = 1, N
      B(I,J) = (SUM(A(I,I:N)) + SUM(A(1:I-1,I)))*J
      ENDDO; ENDDO

      WRITE(*,*) 'The array B :'
      DO J=1,NRHS; DO I = 1, N
       WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(B(I,J));
      ENDDO; ENDDO

      WRITE(*,*) 'CALL LA_POSVX( A, B, X, FACT="E", EQUED=EQUED, S=S )'
      CALL LA_POSVX(  A, B, X, FACT='E', EQUED=EQUED, S=S )

      WRITE(*,*)'EQUED = ', EQUED
      WRITE(*,*)'S = ', S
      WRITE(*,*)'FERR = ', FERR
      WRITE(*,*)'BERR = ', BERR

      WRITE(*,*) 'The solution of the system $ A\,X = B $ is:'
      WRITE(*,*) '$$ X = \left( \begin{array}{rrr}'
      DO I=1,N; WRITE(*,"(2(F9.5,' & '),F9.5,' \\')") X(I,:); ENDDO
      WRITE(*,*) '\end{array} \right). $$'

      END PROGRAM LA_SPOSVX_EXAMPLE


module learning_fortran_objs

  use iso_fortran_env

  implicit none

  real(real64), parameter :: pi = 3.14159
  real(real64), parameter :: e0 = 8.854188e-12

  type, public :: Particle
     real(real64) :: radius
     real(real64) :: mass
   contains
     procedure :: cross_area => ca
  end type Particle

  type, extends(Particle) :: Electron
     real(real64) :: charge
   contains
     procedure :: electric_potential => ep
  end type Electron

contains

  subroutine ca(this)
    ! arguments
    class(Particle), intent(in) :: this

    print *, pi * (this%radius + this%radius)**2

  end subroutine ca

  real(real64) function ep(this, radius) &
       result(V)
    ! arguments
    class(Electron), intent(in) :: this
    real(real64), intent(in) :: radius

    V = 1./(4.*pi*e0) * this%charge / radius

  end function ep

end module learning_fortran_objs


!>
!
!
PROGRAM advections_threads_test

USE advection, only : GetRHSAdvection, InitializeAdvection, FinalizeAdvection

DOUBLE PRECISION, PARAMETER :: pi = 3.1415926535897932_8 ! underscore indicates rounding to real(8) precision

INTEGER order, Nx, Ny, Nz, Nthreads, i, j, k, nt

INTEGER, DIMENSION(5) :: N_v = (/ 20, 30, 40, 50, 60 /)

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q, RQ

DOUBLE PRECISION :: dx, dy, dz, x, y, z

DO order=1,5,4

  DO nn=1,SIZE(N_v)

    Nx = N_v(nn)
    Ny = Nx+5
    Nz = Nx-3

    dx = 1.0/DBLE(Nx)
    dy = 1.0/DBLE(Ny)
    dz = 1.0/DBLE(Nz)

    DO Nthreads=1,8

      ALLOCATE(Q( -2:Nx+3,-2:Ny+3,-2:Nz+3,0:Nthreads-1))
      ALLOCATE(RQ(-2:Nx+3,-2:Ny+3,-2:Nz+3,0:Nthreads-1))

      ! Initialize RHS to zero.
      RQ = 0.0

      CALL InitializeAdvection(-2,Nx+3,-2,Ny+3,-2,Nz+3, Nthreads, .FALSE.)

      ! Fill Q
      DO i=-2,Nx+3
        DO j=-2,Ny+3
          DO k=-2,Nz+3

            x = 0.5*dx + DBLE(i - 1)*dx
            y = 0.5*dy + DBLE(j - 1)*dy
            z = 0.5*dz + DBLE(k - 1)*dz

            Q(i,j,k,:) = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)
          END DO
        END DO
      END DO

      !$OMP PARALLEL DO schedule(static)
      DO nt=0,Nthreads-1
          CALL GetRHSAdvection(Q(:,:,:,nt), RQ(:,:,:,nt), dx, dy, dz, 1, Nx, 1, Ny, 1, Nz, order)
      END DO
      !$OMP END PARALLEL DO

      DO nt=1,Nthreads-1
        IF ( MAXVAL(ABS(RQ(:,:,:,nt) - RQ(:,:,:,nt-1)))>1e-12) THEN
          WRITE(*,*) 'ERROR: For identical input GetRHSDiffusion produced differences in output across multiple threads. Now exiting.'
          STOP
        END IF
      END DO

      DEALLOCATE(Q)
      DEALLOCATE(RQ)

      Call FinalizeAdvection

    END DO ! Nthreads
  END DO ! N_v
END DO ! order

WRITE(*,*) '\x1B[32m[0] -- Successful: GetRHSAdvection on multiple threads on identical input yields identical output.\x1B[0m'

END PROGRAM advections_threads_test


module local_routines
    !!
    !! Very shallow steady uniform flow down a uniform slope
    !!
    use global_mod, only: dp, ip, wall_elevation
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    implicit none

    contains

    subroutine set_initial_conditions_uniform_slope(domain, bed_slope)
        class(domain_type), intent(inout):: domain
        real(dp), intent(in) :: bed_slope
        integer(ip):: i,j
        real(dp):: x, y, cx, cy, slope

        ! Set elevation
        slope = bed_slope

        cx = (domain%lw(1))*0.5
        cy = (domain%lw(2))*0.5
        do i = 1,domain%nx(1)
            do j = 1, domain%nx(2)
                x = (i-0.5_dp)*domain%dx(1) - cx
                y = (j-0.5_dp)*domain%dx(2) - cy
                domain%U(i,j,ELV) = y*slope
            end do
        end do
        ! Wall boundaries along the sides and top
        domain%U(1,:,ELV) = wall_elevation
        domain%U(domain%nx(1),:,ELV) = wall_elevation
        domain%U(:,domain%nx(2),ELV) = wall_elevation
        domain%U(:,1,ELV) = wall_elevation

        ! Stage
        domain%U(:,:,STG) = domain%U(:,:,ELV)

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV))

        domain%manning_squared = 0.03_dp**2

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program uniform_slope_shallow
    !!
    !! Very shallow steady uniform flow down a uniform slope
    !!

    use global_mod, only: ip, dp, charlen, gravity
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use file_io_mod, only: read_csv_into_array
    use local_routines
    implicit none

    integer(ip):: i, j
    real(dp):: last_write_time
    type(domain_type):: domain

    ! Slope of surface. Use higher value to make it supercritical
    real(dp), parameter:: bed_slope = 0.01_dp ! 0.05_dp

    ! Rate of input discharge
    ! 0.00001_dp fails with second order spatial (because limiter pushes it to
    ! first order). 2.0_dp fails with first order spatial
    real(dp), parameter :: discharge_per_unit_width = 0.0001_dp
    ! At first order spatial accuracy with 'euler' timestepping, the test fails
    ! once the depth is around the elevation drop between cells (e.g. discharge_per_unit_width=2.0_dp)
    ! At second order accuracy, the test fails at much shallower depths.
    logical, parameter:: force_first_order_accurate = .false.

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 60.0_dp
    real(dp), parameter :: final_time = 1000.0_dp/(discharge_per_unit_width)**(1.0_dp/3.0_dp) ! The division is a 'rough way' to account for different timescales to equilibrium required. Might not work for every discharge.

    ! length/width
    real(dp), parameter, dimension(2):: global_lw = [50._dp, 1000._dp]
    ! lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = [0._dp, 0._dp]
    ! grid size (number of x/y cells)
    integer(ip), parameter, dimension(2):: global_nx = [50, 100] ! [400, 400]

    ! Discharge of 1 cubic meter / second per metre width
    real(dp) :: Qin, model_vd, model_d, model_v, theoretical_d, theoretical_v, theoretical_vol, model_vol

    ! This gives the inflow discharge per cell, where it is applied
    Qin = discharge_per_unit_width * (global_lw(1)/global_nx(1))

    domain%timestepping_method = 'rk2' !'euler' !'rk2n'

    ! Prevent dry domain from causing enormous initial step
    domain%maximum_timestep = 5.0_dp

    ! Allocate domain
    call domain%allocate_quantities(global_lw, global_nx, global_ll)

    ! call local routine to set initial conditions
    call set_initial_conditions_uniform_slope(domain, bed_slope)

    ! If we force the code to be first-order accurate, we fail on this problem
    if(force_first_order_accurate) domain%theta = 0.0_dp

    ! Trick to get the code to write out just after the first timestep
    last_write_time = -approximate_writeout_frequency

    ! Evolve the code
    do while (.true.)

        if(domain%time - last_write_time >= approximate_writeout_frequency) then

            last_write_time = last_write_time + approximate_writeout_frequency

            call domain%print()
            call domain%write_to_output_files()

            if (domain%time > final_time) then
                exit
            end if

        end if

        call domain%evolve_one_step()

        ! Add discharge inflow
        domain%U(2:(domain%nx(1)-1), domain%nx(2)-1, STG) = &
            domain%U(2:(domain%nx(1)-1), domain%nx(2)-1, STG) + Qin*domain%evolve_step_dt / product(domain%dx)

    end do

    call domain%write_max_quantities()

    call domain%timer%print()

    theoretical_vol = Qin * domain%time * (domain%nx(1) - 2) ! * domain%lw(1) * (global_nx(1) - 2) * 1.0_dp / global_nx(1)
    model_vol = sum(domain%U(:,:,STG) - domain%U(:,:,ELV)) * domain%dx(1) * domain%dx(2)
    print*, 'Cell area: ', domain%dx, product(domain%dx)
    ! Analytical solution
    ! vd = discharge_per_unit_width
    ! bed_slope = manning_squared * v * abs(v) / d^(4/3)
    ! bed_slope = manning_squared * discharge_per_unit_width**2 / (d^(10/3))
    ! d = (manning_squared * discharge_per_unit_width**2 / bed_slope )**(3/10)

    i = domain%nx(1)/2
    j = domain%nx(2)/2
    model_vd = -1.0_dp * domain%U(i,j,VH)
    model_d = domain%U(i,j,STG) - domain%U(i,j,ELV)
    model_v = model_vd/model_d

    theoretical_d = (domain%manning_squared(i,j) * discharge_per_unit_width**2 / bed_slope)**(3.0_dp/10.0_dp)

    print*, '## Testing ##'
    print*, '    Froude: ', (discharge_per_unit_width/theoretical_d)/sqrt(gravity * theoretical_d)
    print*, ' '
    print*, '    Theoretical volume: ', theoretical_vol
    print*, '    Model volume: ', model_vol
    print*, '      error: ', theoretical_vol - model_vol
    if( abs(theoretical_vol - model_vol) < 1.0e-06_dp * theoretical_vol) then
        print*, 'PASS'
    else
        stop 'FAIL: Mass conservation error'
    end if
    print*, ' '
    print*, '   Theoretical d: ', theoretical_d
    print*, '   Model d: ', model_d
    if( abs(theoretical_d - model_d) < 1.0e-04_dp*theoretical_d) then
        print*, 'PASS'
    else
        stop 'FAIL: Friction or steady flow error'
    end if

    print*, ' '
    print*, '   Theoretical vd: ', discharge_per_unit_width
    print*, '   Model vd (near centre): ', model_vd
    if( abs(discharge_per_unit_width - model_vd) < 1.0e-04_dp*discharge_per_unit_width) then
        print*, 'PASS'
    else
        stop 'FAIL: Flux error '
    end if

    call domain%finalise()

end program


program main
    implicit none

    integer :: i
    interface
        function Load_subtraction_Weyl_generator(seed_1_, seed_2_)
            implicit none
            integer, parameter :: li = selected_int_kind(10)
            integer, parameter :: dp = selected_real_kind(8)

            integer(li), intent(in), optional :: seed_1_, seed_2_
            real(dp) :: Load_subtraction_Weyl_generator
        end function Load_subtraction_Weyl_generator
    end interface

    do i = 1, 100
        write(*,*) Load_subtraction_Weyl_generator()
    end do
end program main

function Load_subtraction_Weyl_generator(seed_1_, seed_2_)
    ! 带载减法 Weyl 产生器
    implicit none
    integer, parameter :: li = selected_int_kind(10)
    integer, parameter :: dp = selected_real_kind(8)

    integer(li), intent(in), optional :: seed_1_, seed_2_
    real(dp) :: Load_subtraction_Weyl_generator

    integer :: i
    integer(li), save :: J_list(44) =[(-1, i = 1, 44)]
    integer(li), save :: K_n = -1, I_n
    logical :: initialized = .false.
    integer(li), parameter :: m = 16807
    integer :: C = 0

    if (present(seed_1_)) then
        J_list(1) = seed_1_
        if (present(seed_2_)) then
            K_n = seed_2_
        else if (K_n == -1) then
            K_n = 1
        end if
        initialized = .false.
    else if (J_list(1) == -1) then
        J_list(1) = 1
        if (present(seed_2_)) then
            K_n = seed_2_
        else if (K_n == -1) then
            K_n = 1
        end if
        initialized = .false.
    end if

    if (initialized) then
        J_list(1:43) = J_list(2:44)
    else
        J_list(2) = Congruential_16807(J_list(1))
        do i = 2, 43
            J_list(i + 1) = Congruential_16807()
        end do
        initialized = .true.
    end if
    J_list(44) = J_list(22) - J_list(1) - C
    if (J_list(44) >= 0) then
        C = 0
    else
        C = 1
        J_list(44) = J_list(44) + (2**32 - 5)
    end if
    K_n = mod(K_n - 362436069, 2**32_li)
    I_n = mod(J_list(44) - K_n, 2**32_li)
    Load_subtraction_Weyl_generator = mod(I_n, m) / dble(m)

    contains
        function Congruential_16807(seed_)
            ! Schrage 方法产生 16807 产生器中的随机整数
            implicit none
            integer, parameter :: li = selected_int_kind(10)

            integer(li), intent(in), optional :: seed_
            integer :: Congruential_16807

            integer, parameter :: a = 7**5, m = 2**31 - 1
            integer, parameter :: q = 12773, r = 2836
            integer, save :: z

            if (present(seed_)) then
                z = seed_
            else if (z == -1) then
                z = 1
            end if
            z = a * mod(z, q) - r * (z / q)
            if (z < 0) then
                z = z + m
            end if
            Congruential_16807 = z
        end function Congruential_16807
end function Load_subtraction_Weyl_generator