!##############################################################################
!# Tutorial 005b: Working with small, dense matrices
!##############################################################################

module tutorial005b

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use mprimitives

  implicit none
  private

  public :: start_tutorial005b

contains

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

  subroutine start_tutorial005b

    ! Declare some variables
    real(DP), dimension(4,4) :: DaTrans, Da, DaInv
    integer :: i,j
    logical :: bsuccess

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

    ! =================================
    ! Transpose a matrix
    ! =================================

    ! Initialise a matrix - transposed, as Fortran works column-wise
    DaTrans = reshape ( (/ 2.0_DP, -1.0_DP, 0.0_DP, 0.0_DP, &
                           0.0_DP,  2.0_DP,-1.0_DP, 0.0_DP, &
                           0.0_DP,  0.0_DP, 2.0_DP,-1.0_DP, &
                           0.0_DP,  0.0_DP, 0.0_DP, 2.0_DP /), (/ 4, 4 /) )

    ! Transpose the matrix.
    ! This is an optimised variant of the TRANSPOSE command of Fortran.
    call mprim_transposeMatrix(DaTrans,Da)

    ! =================================
    ! Invert the matrix
    ! =================================

    ! Invert the matrix
    DaInv(:,:) = Da(:,:)
    call mprim_invertMatrixPivot(DaInv,4,bsuccess)

    if (.not. bsuccess) then
      call sys_halt()
    end if

    ! =================================
    ! Output
    ! =================================

    call output_line ("Transposed matrix:")
    do i=1,4
      do j=1,4
        call output_line (sys_adjustr(sys_sdL(DaTrans(i,j),2),6), bnolinebreak=(j .ne. 4) )
      end do
    end do

    call output_lbrk()
    call output_line ("Matrix:")
    do i=1,4
      do j=1,4
        call output_line (sys_adjustr(sys_sdL(Da(i,j),2),6), bnolinebreak=(j .ne. 4) )
      end do
    end do

    call output_lbrk()
    call output_line ("Its inverse:")

    do i=1,4
      do j=1,4
        call output_line (" " // sys_sdL(DaInv(i,j),2), bnolinebreak=(j .ne. 4) )
      end do
    end do

  end subroutine

end module


      PROGRAM   MAIN

      IMPLICIT NONE

      DOUBLE PRECISION ALPHA, BETA
      INTEGER          N, I, J
      PARAMETER        (N=1500)
      DOUBLE PRECISION A(N,N), B(N,N), C(N,N)

      ALPHA = 1.0
      BETA = 0.0

      DO I = 1, N
        DO J = 1, N
          A(I,J) = (I-1) * N + J
          B(I,J) = -((I-1) * N + J)
          C(I,J) = 0.0
        END DO
      END DO

      CALL DGEMM('N','N',N,N,N,ALPHA,A,N,B,N,BETA,C,N)

      STOP

      END


! ********** HILFSROUTINEN **********

module fdschemes

  implicit none

contains

  ! ***** Forward Algorithmus *****
  subroutine forward(u0,u,a,dx,dt)

    ! Eingabe:
    ! u0 = Ausgangsvektor
    ! u = Ausgabevektor
    ! a = Geschwindigkeit (>0)
    ! dx = Ortsschrittweite
    ! dt = Zeitschrittweite

    double precision, intent(in)			:: a, dx, dt
    double precision, dimension(:), intent(out)		:: u
    double precision, dimension(:), intent(in)		:: u0
    integer						:: i,j
    double precision					:: k1

    ! Hilfsvariable
    k1 = a*dt/dx

    ! Berechne den Loesungsvektor fuer alle ausser dem linken x (parallel)
    forall(i=lbound(u0,1)+1:ubound(u0,1))
       u(i) = u0(i)-k1*(u0(i)-u0(i-1))
    end forall

    ! Berechne den Loesungswert fuer das linke x
    u(lbound(u0,1)) = u0(lbound(u0,1))+k1*u0(lbound(u0,1))

  end subroutine forward

  ! ***** generalisierter Upwind und Lax-Wendroff *****
  subroutine gul(u0, u, x, dt, dx, funcf, funcfstrich, alg)
	! Loest:
	! d/dt u + d/dx f(u) = 0
	! u(x,0) = u0(x)

	! Eingabeparameter:
	! u0            Startwert-Vektor (Zeilenvektor)
	! x		Ortsdiskretisierung (Zeilenvektor)
	! dt            Laenge des Zeitschritts
	! dx            Schrittweite des Ortsgitters
	! funcf         Funktionhandle auf die Funktion f(u)
	! funcfstrich   Funktionhandle auf die Funktion f'(u)
	! alg           waehlt den zu verwendenden Algorithmus
	!               0: generalisierter Upwind
	!               1: generalisierter Lax Wendroff

	double precision, intent(in)				:: dx, dt, alg
	double precision, dimension(:), intent(out)		:: u
	double precision, dimension(:), intent(in)		:: u0, x
	integer							:: i,j
	double precision					:: k1

	interface
	double precision function funcf(u,i,x)
		double precision, intent(in)	:: u, x
		integer, intent(in)		:: i
    	end function funcf
    	double precision function funcfstrich(u,i,x)
		double precision, intent(in)	:: u, x
		integer, intent(in)		:: i
    	end function funcfstrich
	end interface

	! Loesungsvektor: Randbedingung
	u(lbound(u0,1)) = u0(lbound(u0,1))
	u(ubound(u0,1)) = u0(ubound(u0,1))

	! Hilfsvariablen
	k1 = dt/dx

	! Berechne alle inneren Werte

	gulloop: do i = lbound(u0,1)+1,ubound(u0,1)-1
		u(i) = u0(i) - k1*(fl(i)-fl(i-1))
	end do gulloop

  contains

  ! Hilfsfunktionen fuer gul
  ! flux-function f_{i+1/2}  =f^L fuer alpha = 0, f^H fuer alpha = 1
    double precision function fl(i)
	double precision	:: k2, tempa
	integer, intent(in) 	:: i
        tempa = approxa(i);
        k2 = tempa*k1;    ! = nu
        fl = (funcf(u0(i+1),i+1,x(i+1))+funcf(u0(i),i,x(i)))/2.0d0-abs(tempa)/2.0d0*(u0(i+1)-u0(i))&
		+alg*abs(tempa)/2.0d0*(1-abs(k2))*(u0(i+1)-u0(i))
    end function fl
  ! berechnet a_{i+1/2}
    double precision function approxa(i)
	integer, intent(in)	:: i
        if (abs(u0(i+1)-u0(i))< 0.001d0) then
            approxa = funcfstrich(u0(i),i,x(i))
        else
            approxa = (funcf(u0(i+1),i+1,x(i+1))-funcf(u0(i),i,x(i)))/(u0(i+1)-u0(i))
        end if
    end function approxa

 end subroutine gul

  ! ***** generalisierter Upwind und Lax-Wendroff *****
  subroutine gtvd(u0, u, x, dt, dx, funcf, funcfstrich, limiter)
	! Loest:
	! d/dt u + d/dx f(u) = 0
	! u(x,0) = u0(x)

	! Eingabeparameter:
	! u0            Startwert-Vektor (Zeilenvektor)
	! x		Ortsdiskretisierung (Zeilenvektor)
	! dt            Laenge des Zeitschritts
	! dx            Schrittweite des Ortsgitters
	! funcf         Funktionhandle auf die Funktion f(u)
	! funcfstrich   Funktionhandle auf die Funktion f'(u)
	! limiter	waehlt den zu verwendenden Limiter (1=minmod, 2=mc, 3=vl, 4=superbee)

	double precision, intent(in)				:: dx, dt
	double precision, dimension(:), intent(out)		:: u
	double precision, dimension(:), intent(in)		:: u0, x
	integer, intent(in)					:: limiter
	integer							:: i,j
	double precision					:: k1

	interface
	double precision function funcf(u,i,x)
		double precision, intent(in)	:: u, x
		integer, intent(in)		:: i
    	end function funcf
    	double precision function funcfstrich(u,i,x)
		double precision, intent(in)	:: u, x
		integer, intent(in)		:: i
    	end function funcfstrich
	end interface

	! Loesungsvektor: Randbedingungen
	u(lbound(u0,1)) = u0(lbound(u0,1))
	u(lbound(u0,1)+1) = u0(lbound(u0,1)+1)
	u(ubound(u0,1)) = u0(ubound(u0,1))
	u(ubound(u0,1)-1) = u0(ubound(u0,1)-1)

	! Hilfsvariablen
	k1 = dt/dx

	! Berechne alle inneren Werte
	tvdloop: do i = lbound(u0,1)+2,ubound(u0,1)-2
		u(i) = u0(i) - k1*(fl(i)-fl(i-1))
	end do tvdloop

  contains

  ! Hilfsfunktionen fuer gtvd
  ! flux-function f_{i+1/2}  =f^L fuer alpha = 0, f^H fuer alpha = 1 (alpha = erg. des limiters)
    double precision function fl(i)
	double precision	:: k2, tempa
	integer, intent(in) 	:: i
	integer			:: j

        tempa = approxa(i)
        k2 = tempa*k1    ! = nu

	j=i-int(sign(1d0,tempa))          !???????????????????????????????????????????????????????????????
	!if (sign(tempa,1.0d0)>0d0) then
	!j=i-1
	!else
	!j=1+1
	!end if

        fl = (funcf(u0(i+1),i+1,x(i+1))+funcf(u0(i),i,x(i)))/2.0&
		-abs(tempa)/2.0*(u0(i+1)-u0(i))&
		 + limiterfunc(u0(i+1)-u0(i),u0(j+1)-u0(j))*abs(tempa)/2.0*(1-abs(k2))
    end function fl
  ! berechnet a_{i+1/2}
    double precision function approxa(i)
	integer, intent(in)	:: i
        if (abs(u0(i+1)-u0(i))< 0.001d0) then
            approxa = funcfstrich(u0(i),i,x(i))
        else
            approxa = (funcf(u0(i+1),i+1,x(i+1))-funcf(u0(i),i,x(i)))/(u0(i+1)-u0(i))
        end if
    end function approxa
  ! limiter function
    double precision function limiterfunc(a,b)
	double precision, intent(in)		:: a,b
	double precision			:: temp5,na,nb
        temp5=(sign(1.0d0,a)+sign(1.0d0,b))/2.0d0   ! ???????????????????
        na=abs(a)
        nb=abs(b)
        if (temp5.ne.0d0) then
        select case(limiter)
            case (1)
                    limiterfunc = temp5*min(na,nb)
            case (2)
                    if (na+nb < 0.00001d0) then
                        limiterfunc=1
                    else
                        limiterfunc = temp5*2.0d0*na*nb/(na+nb)
                    end if
            case (3)
                    limiterfunc = temp5*min(2.0d0*na,(na+nb)/2.0d0,2.0d0*nb)
            case (4)
                    limiterfunc = temp5*max(min(2.0d0*na,nb),min(na,2.0d0*nb))
        end select
        else
            limiterfunc=0d0
        end if
    end function limiterfunc

 end subroutine gtvd

  ! ***** Benchmarkfunctions *****
    double precision function bench1funcf(u,i,x)
	double precision, intent(in)	:: u,x
	integer, intent(in)		:: i
        bench1funcf = x*u
    end function bench1funcf
    double precision function bench1funcfstrich(u,i,x)
	double precision, intent(in)	:: u,x
	integer, intent(in)		:: i
        bench1funcfstrich = x
    end function bench1funcfstrich
    double precision function bench2funcf(u,i,x)
	double precision, intent(in)	:: u,x
	integer, intent(in)		:: i
        bench2funcf = (0.5d0-x)*u
    end function bench2funcf
    double precision function bench2funcfstrich(u,i,x)
	double precision, intent(in)	:: u,x
	integer, intent(in)		:: i
        bench2funcfstrich = 0.5d0-x
    end function bench2funcfstrich
    double precision function bench3funcf(u,i,x)
	double precision, intent(in)	:: u,x
	integer, intent(in)		:: i
        bench3funcf = u*u/2d0
    end function bench3funcf
    double precision function bench3funcfstrich(u,i,x)
	double precision, intent(in)	:: u,x
	integer, intent(in)		:: i
        bench3funcfstrich = u
    end function bench3funcfstrich

end module fdschemes

! ********** HAUPTPROGRAMM **********

program finite_differences
  use fdschemes

  implicit none

  integer, parameter				:: n = 101		! Anzahl der x-Gitterpunkte
  double precision, parameter			:: tfinal = 0.4		! Endzeit
  double precision				:: a, dx, dt, time
  double precision				:: time0, time1		! Zur Zeitmessung
  double precision, dimension(1:n)		:: u0 ,u ,x		! Startvektor, Loesungsvektor, Gittervektor
  integer					:: i			! Laufvariable

  ! Parameter initialisieren
  a = 1.0				! Welleneschwindigkeit (fuer die linear advection equation)
  dx = 1.0d0/(n-1)			! dx
  dt = 0.001d0				! dt

  ! Gittervektor initialisieren
  forall(i=1:n)
     x(i)=(i-1)*dx
  end forall

  ! Startwerte festlegen
  u0 = 0
  where (x>=0.1d0 .AND. x<=0.4d0)
     u0 = 1
  end where

  ! Datei oeffnen
  open(10,file='ausgabe.dat')

  ! Startvektor in Datei schreiben
  write(10,*) u0

  ! Zeitschritte ausfuehren und Ergebnis in Datei schreiben
  ! mit Zeitmessung
  call cpu_time(time0)
  time = 0.0
  timestepping: do
     time = time + dt
     if (time>tfinal) exit timestepping
     call gtvd(u0, u, x, dt, dx, bench3funcf, bench3funcfstrich, 4)
     u0 = u
     write(10,*) u
  end do timestepping
  call cpu_time(time1)

  ! Datei schliessen
  close(10)

  ! Zeitaufwand ausgeben
  print*,'Zeitaufwand: ',time1-time0,' Sekunden.'
end program finite_differences


program problem30
  implicit none
  integer, parameter :: limit=999999
  integer            :: i
  integer            :: answer=0

  do i=2,limit
     if (predicate(i)) then
        answer=answer+i
     end if
  end do

  print *, answer

contains
  pure function predicate(n)
    implicit none
    integer, intent(in) :: n
    integer             :: current,sum
    logical             :: predicate

    current=n
    sum=0
    do while (current > 0)
       sum=sum+(mod(current,10)**5)
       current=current/10
    end do
    predicate=(sum == n)

  end function predicate

end program problem30


      PROGRAM FOO
      INTEGER I, J
      INTEGER A(10, 10)
      DO J = 1, 10
         DO I = 1, 10
            A(I,J) = I+J*10
         ENDDO
      ENDDO
      END


! --------------
! Compute triangles area
! --------------

PROGRAM HeronFormula
      IMPLICIT NONE

      REAL      :: a, b, c
      REAL      :: s
      REAL      :: Area
      LOGICAL   :: Cond_1, Cond_2

      READ(*,*) a, b, c

      WRITE(*,*) "a = ", a
      WRITE(*,*) "b = ", b
      WRITE(*,*) "c = ", c
      WRITE(*,*)

END PROGRAM


| http://www.tempest-sw.com/benchmark/
| Tweak from the first port (pi.f) to avoid some variable accesses in favor of stack

variable pi
variable numdigits
variable alength
variable a
variable nines
variable predigit
variable pilength

: >pi pi @ pilength @ + c! ;
: >pi2 pi @ pilength @ + + c! ;

0 value Q
: 2-under [ $022e83 3, ;inline
: 10* ( n -- 10*n) [ $c001c389 , $0103e3c1 , $d8 1, ;inline
: computepi
	| allocate work area:
	numdigits @ 10 3 */ dup alength ! cells allocate dup a !
	| initialize work area to '2'
	alength @ 0 do 2 over ! cell+ loop  drop
	| main loop
	0 to Q
	numdigits @ 0 do
		alength @ 2* 1-
		Q alength @ 0 do
			remains swap over 1+ * swap
			cells a @ + dup >r
			@ 10* +
			over /mod swap
			r> !  2-under
		loop
		nip dup to Q

		| a[0] = q % 10
		| q /= 10
		10 /mod to Q a @ !
		Q dup 9 =if nines ++ drop else
			predigit @
			swap
			10 =if
				1+
				'0 + >pi
				nines @ 1+ 1 do '0 i >pi2 loop
				predigit off
			else
				'0 + >pi
				Q predigit !
				nines @ 1+ 1 do '9 i >pi2 loop
			then
			nines @ 1+ pilength +!
			nines off
		then
	loop
	predigit @ '0 + >pi
	;
: setup
	argc 3 <>if ." usage: pi #DIGITS" cr bye then
	2 argv >single 0if ." #DIGITS must be a number!" cr bye then
	dup numdigits !
	1+ allocate pi !
	;
: printpi pi @ numdigits @ type cr ;
: cleanup pi @ free a @ free ;

setup computepi printpi cleanup bye


module mother

implicit none
real, parameter :: pi = 4.*atan(1.)
real :: tau

interface
module real elemental function pi2tau(pi)
real, intent(in) :: pi
end function pi2tau
end interface

contains

end module mother

program hier1
use mother
implicit none

tau = pi2tau(pi)

print *,'pi=',pi, 'tau=', tau

end program


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      written by the UFO converter
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      SUBROUTINE MP_COUP2()

      IMPLICIT NONE
      INCLUDE 'model_functions.inc'
      REAL*16 MP__PI, MP__ZERO
      PARAMETER (MP__PI=3.1415926535897932384626433832795E0_16)
      PARAMETER (MP__ZERO=0E0_16)
      INCLUDE 'mp_input.inc'
      INCLUDE 'mp_coupl.inc'

      MP__R2_GGHB = 4.000000E+00_16*(-((MP__MDL_COMPLEXI*MP__MDL_YB)
     $ /MP__MDL_SQRT__2))*(1.000000E+00_16/2.000000E+00_16)*(MP__MDL_G_
     $ _EXP__2/(8.000000E+00_16*MP__PI**2))*MP__MDL_MB
      MP__R2_GGHT = 4.000000E+00_16*(-((MP__MDL_COMPLEXI*MP__MDL_YT)
     $ /MP__MDL_SQRT__2))*(1.000000E+00_16/2.000000E+00_16)*(MP__MDL_G_
     $ _EXP__2/(8.000000E+00_16*MP__PI**2))*MP__MDL_MT
      MP__R2_GGHHB = 4.000000E+00_16*(-MP__MDL_YB__EXP__2/2.000000E
     $ +00_16)*(1.000000E+00_16/2.000000E+00_16)*((MP__MDL_COMPLEXI
     $ *MP__MDL_G__EXP__2)/(8.000000E+00_16*MP__PI**2))
      MP__R2_GGHHT = 4.000000E+00_16*(-MP__MDL_YT__EXP__2/2.000000E
     $ +00_16)*(1.000000E+00_16/2.000000E+00_16)*((MP__MDL_COMPLEXI
     $ *MP__MDL_G__EXP__2)/(8.000000E+00_16*MP__PI**2))
      MP__GC_5 = MP__MDL_COMPLEXI*MP__G
      END


!!
!! The famous Bohren and Huffman Mie scattering code.
!! This version was ported to Fortran90/95 from the Python version by Attila Juhasz.
!! The Python version was ported from the original Fortran 77 version by Cornelis Dullemond.
!! The original Fortran 77 code was written by Bruce Drain and can be downloaded from:
!! https://www.astro.princeton.edu/~draine/scattering.html
!! The code originates from the book by Bohren & Huffman (1983) on
!! "Absorption and Scattering of Light by Small Particles".
!!
SUBROUTINE bhmie(x, refrel, theta, nang, S1, S2, Qext, Qabs, Qsca, Qback, gsca)
    implicit none

    real(kind=8), intent(in)        :: x
    complex(kind=8), intent(in)     :: refrel
    integer, intent(in)             :: nang
    real(kind=8), intent(in)        :: theta(nang)

    complex(kind=8), intent(out)    :: S1(nang)
    complex(kind=8), intent(out)    :: S2(nang)
    real(kind=8), intent(out)       :: Qext
    real(kind=8), intent(out)       :: Qabs
    real(kind=8), intent(out)       :: Qsca
    real(kind=8), intent(out)       :: Qback
    real(kind=8), intent(out)       :: gsca
    !! ---------------------------------------
    !! Local variables
    !! ---------------------------------------
    real(kind=8)                    :: math_pi=3.14159265358979323846264338328
    integer                         :: i, iang
    integer                         :: nstop
    real(kind=8)                    :: xstop
    complex(kind=8)                 :: y
    integer                         :: nmx
    real(kind=8)                    :: mu(nang)
    complex(kind=8), allocatable    :: log_der(:)

    real(kind=8)                    :: chi0, chi1, chi, p
    complex(kind=8)                 :: xi1, xi
    complex(kind=8)                 :: an, bn, an1, bn1
    real(kind=8)                    :: pi(nang), pi1(nang), pi0(nang), tau(nang)
    real(kind=8)                    :: fn

    real(kind=8)                    :: psi0, psi1, psi
    real(kind=8)                    :: en
    !!
    !! Reset all output arrays
    !!
    do i=1, nang
        S1(i)    = (0d0, 0d0)
        S2(i)    = (0d0, 0d0)
        pi(i)    = 0d0
        pi0(i)   = 0d0
        pi1(i)   = 1d0
        tau(i)   = 0d0
    end do
    Qext  = 0e0
    Qabs  = 0e0
    Qsca  = 0e0
    Qback = 0e0
    gsca  = 0e0

    !!
    !! Compute an alternative to x
    !!
    y = x * refrel
    !!
    !! Determine at which n=nstop to terminate the series expansion
    !!
    xstop = x + 4.0 * x**0.3333 + 2.0
    nstop = int(floor(xstop))
    !!
    !! Determine the start of the logarithmic derivatives iteration
    !!
    nmx = int(floor(max(xstop, abs(y))) + 15)
    !!
    !! Compute the mu = cos(theta*pi/180.) for all scattering angles
    !!
    do iang=1, nang
        mu(iang) = cos(theta(iang) * math_pi / 180.0)
        if (abs(theta(iang)/90.0 - 1.0) < 1e-8) then
            mu(iang) = 0.0
        end if
    end do
    mu(1) = 1.0d0
    mu(nang) = -1.0d0
    !!
    !! Now calculate the logarithmic derivative dlog by downward recurrence
    !! beginning with initial value 0.+0j at nmx-1
    !!
    allocate(log_der(nmx))
    log_der(nmx) = (0e0, 0e0)
    do i=1, nmx-1
        en = dble(nmx - i + 1)
        log_der(nmx - i) = (en / y) - 1.0 / (log_der(nmx - i + 1) + en / y)
    end do
    !!
    !! In preparation for the series expansion, reset some variables
    !!
    psi0 = cos(x)
    psi1 = sin(x)
    chi0 = -sin(x)
    chi1 = cos(x)
    xi1 = cmplx(psi1, -chi1, kind=8)
    p = -1.0
    an = (0e0, 0e0)
    bn = (0e0, 0e0)
    !!
    !! Riccati-Bessel functions with real argument x
    !! calculated by upward recurrence. This is where the
    !! series expansion is done
    !!
    do i=1, nstop
        !!
        !! Basic calculation of the iteration
        !!
        en = dble(i)
        fn = (2 * en + 1.0) / (en * (en + 1.0))
        psi = (2 * en - 1.0) * psi1 / x - psi0
        chi = (2 * en - 1.0) * chi1 / x - chi0
        xi = cmplx(psi, -chi, kind=8)
        an1 = an
        bn1 = bn
        an = log_der(i) / refrel + en / x
        an = (an * psi - psi1) / (an * xi - xi1)
        bn = log_der(i) * refrel + en / x
        bn = (bn * psi - psi1) / (bn * xi - xi1)

        !!
        !! Add contributions to Qsca and gsca
        !!
        Qsca = Qsca + (2d0 * en + 1d0) * (abs(an)**2 + abs(bn)**2)
        gsca = gsca + (2d0 * en + 1d0) / (en * (en + 1d0)) * &
                (real(an) * real(bn) + aimag(an) * aimag(bn))
        gsca = gsca + (en - 1.0) * (en + 1.0) / en * &
                (real(an1) * real(an) + aimag(an1) * aimag(an) + &
                 real(bn1) * real(bn) + aimag(bn1) * aimag(bn))
        !!
        !! Now contribute to scattering intensity pattern as a function of angle
        !!
        pi = pi1
        tau = en * abs(mu) * pi - (en + 1.0) * pi0
        p = -p
        do iang=1, nang
            !!
            !! For mu>=0
            !!
            if (mu(iang).ge.0) then
                S1(iang) = S1(iang) + fn * (an * pi(iang) + bn * tau(iang))
                S2(iang) = S2(iang) + fn * (an * tau(iang) + bn * pi(iang))
            !!
            !! For mu<0
            !!
            else
                S1(iang) = S1(iang) + fn * p * (an * pi(iang) - bn * tau(iang))
                S2(iang) = S2(iang) + fn * p * (bn * pi(iang) - an * tau(iang))
            endif
        end do
        !!
        !! Now prepare for the next iteration
        !!
        psi0 = psi1
        psi1 = psi
        chi0 = chi1
        chi1 = chi
        xi1  = cmplx(psi1, -chi1, kind=8)
        pi1  = ((2d0 * en + 1d0) * abs(mu) * pi - (en + 1d0) * pi0) / en
        pi0  = pi
    end do

    !!
    !! Now do the final calculations
    !!
    gsca = 2 * gsca / Qsca
    Qsca = (2d0 / (x * x)) * Qsca
    Qext = (4d0 / (x * x)) * real(S1(1))
    Qback = abs(S1(nang)) * abs(S1(nang)) / (x * x * math_pi)
    Qabs = Qext - Qsca
    deallocate(log_der)

END SUBROUTINE bhmie


C Compute north azimuth, spacecraft azimuth, and solar azimuth angles.
C The azimuth angles are measured at the surface point defined by the vector V.
C To compute the solar azimuth, the solar vector is (1) projected into the
C plane tangent to the surface point, and (2) this projected vector is then
C projected into the image plane.  The solar azimuth is the angle between a
C horizontal line pointing to the right in the image and this projected vector,
C measured in a clockwise direction.  The other azimuths are defined similarly.
C
      subroutine azimuth(om,op,vsc,vsun,ra,rb,rc,flg,noraz,scaz,sunaz)
      implicit none
      real*8 om(3,3)		!Target to camera transformation (OM matrix)
      real*8 op(3)		!Vector from target center to surface point
      real*8 vsc(3)		!Vector from target center to S/C (RS vector)
      real*8 vsun(3)		!Vector from target center to sun
      real*8 ra,rb,rc		!Target radii
      integer*4 flg		!=1 if surface pt is target center, =0 otherwise
      real*8 noraz		!Output north azimuth (degrees)
      real*8 scaz		!Output spacecraft azimuth (degrees)
      real*8 sunaz		!Output solar azimuth (degrees)

      real*8 n(3),s(3),c(3),v(3),m(3,3),r,rlat,rlon,halfpi,dpr
      integer i

C     ...Compute vector from target center to north pole
      n(1) = 0.
      n(2) = 0.
      n(3) = rc

C     ...Compute the three vectors of interest
      do i=1,3
         c(i) = vsc(i) - op(i)		!Vector from surface point to spacecraft
         s(i) = vsun(i) - op(i)		!Vector from surface point to sun
         n(i) = n(i) - op(i)		!Vector from surface point to north pole
      enddo
C
C We need to project these vectors into the tangent plane.  To do this, we
C transform the vectors to a coordinate system where the z-axis is normal to the
C surface.  The projection into the tangent plane is then simply the x and y
C components of the vector.
C
C If the surface point is the target center, the spacecraft vector projects
C to a single point and the azimuth is undefined.  For this case, the S/C
C vector is projected directly onto the image plane.
C
C The tangent plane is defined by the surface normal vector v:
C
      v(1) = op(1)*(rc/ra)**2
      v(2) = op(2)*(rc/ra)**2
      v(3) = op(3)

C Convert to lat-lon and compute transformation matrix m

      call reclat(v,r,rlon,rlat)
      call eul2m(0.d0,halfpi()-rlat,halfpi()+rlon,3,1,3,m)

C Transform the vectors to "tangent plane coordinate system"

      call mxv(m,n,n)
      if (flg .ne. 1) call mxv(m,c,c)
      call mxv(m,s,s)

C Project vectors into plane

      n(3) = 0.
      if (flg .ne. 1) c(3) = 0.
      s(3) = 0.

C Now project the projected vectors into the image plane by first transforming
C the vectors back into planet coordinates, and then using to OM matrix to
C tranform them into image plane coordinates.

      call mtxv(m,n,n)
      if (flg .ne. 1) call mtxv(m,c,c)
      call mtxv(m,s,s)

      call mxv(om,n,n)
      call mxv(om,c,c)
      call mxv(om,s,s)

      noraz = datan2(n(2),n(1))*dpr()
      if (noraz .lt. 0.) noraz=noraz+360.

      scaz = datan2(c(2),c(1))*dpr()
      if (scaz .lt. 0.) scaz=scaz+360.

      sunaz = datan2(s(2),s(1))*dpr()
      if (sunaz .lt. 0.) sunaz=sunaz+360.
      return
      end


module camera

    use types

    implicit none

    real :: projection(4,4), viewport(4,4), modelview(4,4)

    private
    public :: identity, m2v, v2m, lookat, view_init, proj
    public :: projection, viewport, modelview

    contains

    type(ivec) function m2v(m)

        implicit none

        real :: m(:,:)

        m2v = ivec(int(m(1,1)/m(4,1)), int(m(2,1)/m(4,1)), int(m(3,1)/m(4,1)))

    end function m2v

    function v2m(v)

        implicit none

        real :: v2m(4,1)
        type(vector), intent(IN) :: v

        v2m(1,1) = v%x
        v2m(2,1) = v%y
        v2m(3,1) = v%z
        v2m(4,1) = 1.

    end function v2m

    subroutine invtranspose(m, minv, ok_flag)

        implicit none

        double precision, intent(IN)  :: m(4,4)
        double precision, intent(OUT) :: minv(4,4)
        logical,          intent(OUT) :: ok_flag

        double precision, parameter :: eps = 1.0D-10
        double precision            :: det, cofactor(4,4)

        det =  m(1,1)*(m(2,2)*(m(3,3)*m(4,4)-m(3,4)*m(4,3))+m(2,3)*(m(3,4)*m(4,2)-m(3,2)*m(4,4))+m(2,4)*(m(3,2)*m(4,3)- &
               m(3,3)*m(4,2)))-m(1,2)*(m(2,1)*(m(3,3)*m(4,4)-m(3,4)*m(4,3))+m(2,3)*(m(3,4)*m(4,1)-m(3,1)*m(4,4))+ &
               m(2,4)*(m(3,1)*m(4,3)-m(3,3)*m(4,1)))+m(1,3)*(m(2,1)*(m(3,2)*m(4,4)-m(3,4)*m(4,2))+m(2,2)*(m(3,4)*m(4,1)- &
               m(3,1)*m(4,4))+m(2,4)*(m(3,1)*m(4,2)-m(3,2)*m(4,1)))-m(1,4)*(m(2,1)*(m(3,2)*m(4,3)-m(3,3)*m(4,2))+ &
               m(2,2)*(m(3,3)*m(4,1)-m(3,1)*m(4,3))+m(2,3)*(m(3,1)*m(4,2)-m(3,2)*m(4,1)))

        if(abs(det) <= eps)then
            minv = 0.0d0
            ok_flag = .false.
            return
        end if

    cofactor(1,1) = m(2,2)*(m(3,3)*m(4,4)-m(3,4)*m(4,3))+m(2,3)*(m(3,4)*m(4,2)-m(3,2)*m(4,4))+m(2,4)*(m(3,2)*m(4,3)-m(3,3)*m(4,2))
    cofactor(1,2) = m(2,1)*(m(3,4)*m(4,3)-m(3,3)*m(4,4))+m(2,3)*(m(3,1)*m(4,4)-m(3,4)*m(4,1))+m(2,4)*(m(3,3)*m(4,1)-m(3,1)*m(4,3))
    cofactor(1,3) = m(2,1)*(m(3,2)*m(4,4)-m(3,4)*m(4,2))+m(2,2)*(m(3,4)*m(4,1)-m(3,1)*m(4,4))+m(2,4)*(m(3,1)*m(4,2)-m(3,2)*m(4,1))
    cofactor(1,4) = m(2,1)*(m(3,3)*m(4,2)-m(3,2)*m(4,3))+m(2,2)*(m(3,1)*m(4,3)-m(3,3)*m(4,1))+m(2,3)*(m(3,2)*m(4,1)-m(3,1)*m(4,2))
    cofactor(2,1) = m(1,2)*(m(3,4)*m(4,3)-m(3,3)*m(4,4))+m(1,3)*(m(3,2)*m(4,4)-m(3,4)*m(4,2))+m(1,4)*(m(3,3)*m(4,2)-m(3,2)*m(4,3))
    cofactor(2,2) = m(1,1)*(m(3,3)*m(4,4)-m(3,4)*m(4,3))+m(1,3)*(m(3,4)*m(4,1)-m(3,1)*m(4,4))+m(1,4)*(m(3,1)*m(4,3)-m(3,3)*m(4,1))
    cofactor(2,3) = m(1,1)*(m(3,4)*m(4,2)-m(3,2)*m(4,4))+m(1,2)*(m(3,1)*m(4,4)-m(3,4)*m(4,1))+m(1,4)*(m(3,2)*m(4,1)-m(3,1)*m(4,2))
    cofactor(2,4) = m(1,1)*(m(3,2)*m(4,3)-m(3,3)*m(4,2))+m(1,2)*(m(3,3)*m(4,1)-m(3,1)*m(4,3))+m(1,3)*(m(3,1)*m(4,2)-m(3,2)*m(4,1))
    cofactor(3,1) = m(1,2)*(m(2,3)*m(4,4)-m(2,4)*m(4,3))+m(1,3)*(m(2,4)*m(4,2)-m(2,2)*m(4,4))+m(1,4)*(m(2,2)*m(4,3)-m(2,3)*m(4,2))
    cofactor(3,2) = m(1,1)*(m(2,4)*m(4,3)-m(2,3)*m(4,4))+m(1,3)*(m(2,1)*m(4,4)-m(2,4)*m(4,1))+m(1,4)*(m(2,3)*m(4,1)-m(2,1)*m(4,3))
    cofactor(3,3) = m(1,1)*(m(2,2)*m(4,4)-m(2,4)*m(4,2))+m(1,2)*(m(2,4)*m(4,1)-m(2,1)*m(4,4))+m(1,4)*(m(2,1)*m(4,2)-m(2,2)*m(4,1))
    cofactor(3,4) = m(1,1)*(m(2,3)*m(4,2)-m(2,2)*m(4,3))+m(1,2)*(m(2,1)*m(4,3)-m(2,3)*m(4,1))+m(1,3)*(m(2,2)*m(4,1)-m(2,1)*m(4,2))
    cofactor(4,1) = m(1,2)*(m(2,4)*m(3,3)-m(2,3)*m(3,4))+m(1,3)*(m(2,2)*m(3,4)-m(2,4)*m(3,2))+m(1,4)*(m(2,3)*m(3,2)-m(2,2)*m(3,3))
    cofactor(4,2) = m(1,1)*(m(2,3)*m(3,4)-m(2,4)*m(3,3))+m(1,3)*(m(2,4)*m(3,1)-m(2,1)*m(3,4))+m(1,4)*(m(2,1)*m(3,3)-m(2,3)*m(3,1))
    cofactor(4,3) = m(1,1)*(m(2,4)*m(3,2)-m(2,2)*m(3,4))+m(1,2)*(m(2,1)*m(3,4)-m(2,4)*m(3,1))+m(1,4)*(m(2,2)*m(3,1)-m(2,1)*m(3,2))
    cofactor(4,4) = m(1,1)*(m(2,2)*m(3,3)-m(2,3)*m(3,2))+m(1,2)*(m(2,3)*m(3,1)-m(2,1)*m(3,3))+m(1,3)*(m(2,1)*m(3,2)-m(2,2)*m(3,1))

        minv = transpose(cofactor) / det

        ok_flag = .true.

    end subroutine invtranspose

    function identity(m)

        implicit none

        real, intent(INOUT) :: m(:,:)
        real :: identity(size(m,1), size(m,2))

        integer :: i, j

        do i = 1, size(m,1)
            do j = 1, size(m,2)
                if(i == j)then
                    m(i, j) = 1.
                else
                    m(i, j) = 0.
                end if
            end do
        end do
        identity = m
    end function identity

    function proj(coeff)

        implicit none

        real:: coeff
        real :: proj(4,4)

        proj = identity(proj)
        proj(4,3) = coeff

    end function proj

    function view_init(x, y, w, h, depth)

        implicit none

        real :: view_init(4,4)
        integer, intent(IN)  :: x, y, w, h, depth

        view_init = identity(view_init)
        view_init(1,4) = x + w/2.
        view_init(2,4) = y + h/2.
        view_init(3,4) = depth/2.

        view_init(1,1) = w/2.
        view_init(2,2) = h/2.
        view_init(3,3) = depth/2.

    end function view_init

    function lookat(eye, centre, up)

        implicit none

        real :: lookat(4,4), minv(4,4)!,tr(4,4)
        type(vector), intent(IN)  :: eye, centre,  up

        type(vector) :: x, y, z
        real :: tmpx(3),tmpy(3),tmpz(3),tmpc(3)
        integer :: i

        z = normal(eye-centre)
        x = normal(up .cross. z)
        y = normal(z .cross. x)
        ! print*,'y',y

        tmpx(1:3) = [x%x,x%y,x%z]
        tmpy(1:3) = [y%x,y%y,y%z]
        tmpz(1:3) = [z%x,z%y,z%z]
        tmpc(1:3) = [centre%x,centre%y,centre%z]

        minv = identity(minv)
        ! tr = identity(tr)
        do i = 1, 3
            minv(1,i) = tmpx(i)![x%x,x%y,x%z]
            minv(2,i) = tmpy(i)![y%x,y%y,y%z]
            minv(3,i) = tmpz(i)![z%x,z%y,z%z]
            minv(i,4) = -tmpc(i)![-centre%x,-centre%y,-centre%z]
        end do
        lookat = minv
    end function lookat
end module camera


      subroutine rbf_eval(idim, jdim, r, nwp, rw, wt)
      implicit none
      include 'dim.h'
      integer idim, jdim, nwp
      real    r  (idim,jdim,NDIM),
     1        rw (NDIM,*),
     2        wt (NDIM,*)

      integer i, j, k
      real    dx, dy, dx1, dy1, dr1, rbf

      do i=1,idim
         do j=1,jdim
            dx = 0.0
            dy = 0.0
            do k=1,nwp
               dx1 = r(i,j,1) - rw(1,k)
               dy1 = r(i,j,2) - rw(2,k)
               dr1 = sqrt(dx1*dx1 + dy1*dy1)
               if(dr1.eq.0.0)then
                  rbf = 0.0
               else
                  rbf = dr1*dr1*log(dr1)
               endif
               dx  = dx + wt(1,k)*rbf
               dy  = dy + wt(2,k)*rbf
            enddo
            dx       = dx + wt(1,nwp+1) + wt(1,nwp+2)*r(i,j,1) +
     1                 wt(1,nwp+3)*r(i,j,2)
            dy       = dy + wt(2,nwp+1) + wt(2,nwp+2)*r(i,j,1) +
     1                 wt(2,nwp+3)*r(i,j,2)
            r(i,j,1) = r(i,j,1) + dx
            r(i,j,2) = r(i,j,2) + dy
         enddo
      enddo

      return
      end


      SUBROUTINE MB03AG( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1,
     $                   S1, C2, S2, IWORK, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute two Givens rotations (C1,S1) and (C2,S2) such that the
C     orthogonal matrix
C
C               [ Q  0 ]        [  C1  S1  0 ]   [ 1  0   0  ]
C           Z = [      ],  Q := [ -S1  C1  0 ] * [ 0  C2  S2 ],
C               [ 0  I ]        [  0   0   1 ]   [ 0 -S2  C2 ]
C
C     makes the first column of the real Wilkinson double shift
C     polynomial of the product of matrices in periodic upper Hessenberg
C     form, stored in the array A, parallel to the first unit vector.
C     Only the rotation defined by C1 and S1 is used for the real
C     Wilkinson single shift polynomial (see SLICOT Library routines
C     MB03BE or MB03BF). All factors whose exponents differ from that of
C     the Hessenberg factor are assumed nonsingular. The matrix product
C     is evaluated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SHFT    CHARACTER*1
C             Specifies the number of shifts employed by the shift
C             polynomial, as follows:
C             = 'D':  two shifts (assumes N > 2);
C             = 'S':  one real shift.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of the factors.  N >= 2.
C
C     AMAP    (input)  INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C             AMAP(1) is the pointer to the Hessenberg matrix.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     SINV    (input)  INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
C             The leading N-by-N-by-K part of this array must contain
C             the product (implicitly represented by its K factors)
C             in periodic upper Hessenberg form.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= N.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= N.
C
C     C1      (output)  DOUBLE PRECISION
C     S1      (output)  DOUBLE PRECISION
C             On exit, C1 and S1 contain the parameters for the first
C             Givens rotation.
C
C     C2      (output)  DOUBLE PRECISION
C     S2      (output)  DOUBLE PRECISION
C             On exit, if SHFT = 'D', C2 and S2 contain the parameters
C             for the second Givens rotation. Otherwise, C2 = 1, S2 = 0.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (2*N*N)
C             On exit, DWORK(N*N+1:N*N+N) and DWORK(N*N+N+1:N*N+2*N)
C             contain the real and imaginary parts, respectively, of the
C             eigenvalues of the matrix product.
C
C     METHOD
C
C     The necessary elements of the real Wilkinson double shift
C     polynomial are computed, and suitable Givens rotations are
C     found. For numerical reasons, this routine should be called
C     when convergence difficulties are encountered for small order
C     matrices and small K, e.g., N, K <= 6.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Jan. 2019.
C
C     REVISIONS
C
C     V. Sima, Sep. 2019, Dec. 2019.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TWO, ZERO
      PARAMETER         ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SHFT
      INTEGER           K, LDA1, LDA2, N, SINV
      DOUBLE PRECISION  C1, C2, S1, S2
C     .. Array Arguments ..
      INTEGER           AMAP(*), IWORK(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           FC, SGLE
      INTEGER           I, IC, II, IM, IR, IS, J, L, NN
      DOUBLE PRECISION  E1, E2, MC, MN, MX, P1, P2, P3, PR, SM
C     .. Local Arrays ..
      DOUBLE PRECISION  Z(1)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           IDAMAX
      DOUBLE PRECISION  DLAPY2
      EXTERNAL          DLAPY2, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGESC2, DGETC2, DLAHQR, DLARTG, DLASET,
     $                  DTRMV
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked for errors.
C
C     Evaluate the matrix product.
C
      SGLE = LSAME( SHFT, 'S' )
C
      NN = N*N
      IR = NN + 1
      II = IR + N
      I  = AMAP(K)
      IC = 1
C
      Z(1) = ZERO
C
      IF ( K.GT.1 ) THEN
C
         IF ( S(I).EQ.SINV ) THEN
            IS = 1
C
            DO 10  L = 1, N
               CALL DCOPY( L, A(1,L,I), 1, DWORK(IC), 1 )
               CALL DCOPY( N-L, Z, 0, DWORK(IC+L), 1 )
               IC = IC + N
   10       CONTINUE
C
         ELSE
            IS = 0
            CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N )
         END IF
C
         DO 50  J = K - IS, 2, -1
            I = AMAP(J)
            IF ( S(I).EQ.SINV ) THEN
               IC = 1
C
               DO 20  L = 1, N
                  CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', L, A(1,1,I),
     $                        LDA1, DWORK(IC), 1 )
                  IC = IC + N
   20          CONTINUE
C
            ELSE
               IC = IR
C
               DO 30  L = 1, N
                  CALL DCOPY( L, A(1,L,I), 1, DWORK(IC), 1 )
                  CALL DCOPY( N-L, Z, 0, DWORK(IC+L), 1 )
                  IC = IC + N
   30          CONTINUE
C
C              Complete pivoting is used for triangular factors whose
C              exponents differ from SINV. It is assumed that SM = 1,
C              i.e., no overflow could appear when calling DGESC2.
C
               CALL DGETC2( N, DWORK(IR), N, IWORK, IWORK(N+1), IM )
C
               DO 40  IC = 1, NN, N
                  CALL DGESC2( N, DWORK(IR), N, DWORK(IC), IWORK,
     $                         IWORK(N+1), SM )
   40          CONTINUE
C
            END IF
   50    CONTINUE
C
         I  = AMAP(1)
         IC = 1
C
         DO 70 J = 1, N - 1
            CALL DCOPY( J, DWORK(IC), 1, DWORK(IR), 1 )
            CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, A(1,1,I), LDA1,
     $                  DWORK(IC), 1 )
C
            DO 60 L = 1, J
               DWORK(IC+L) = DWORK(IC+L) + A(L+1,L,I)*DWORK(IR+L-1)
   60       CONTINUE
C
            IC = IC + N
   70    CONTINUE
C
         CALL DCOPY( N, DWORK(IC), 1, DWORK(IR), 1 )
         CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, A(1,1,I), LDA1,
     $               DWORK(IC), 1 )
C
         DO 80 L = 1, N
            DWORK(IC+L) = DWORK(IC+L) + A(L+1,L,I)*DWORK(IR+L-1)
   80    CONTINUE
C
      ELSE
         I = AMAP(1)
C
         DO 90  L = 1, N - 1
            CALL DCOPY( L+1, A(1,L,I), 1, DWORK(IC), 1 )
            CALL DCOPY( N-L-1, Z, 0, DWORK(IC+L+1), 1 )
            IC = IC + N
   90    CONTINUE
C
         CALL DCOPY( N, A(1,N,I), 1, DWORK(IC), 1 )
      END IF
C
      IF ( SGLE ) THEN
         CALL DLARTG( DWORK(1) - DWORK(NN), DWORK(2), C1, S1, E1 )
         C2 = ONE
         S2 = ZERO
      ELSE
C
C        Save the needed elements of the product.
C
         E1 = DWORK(1)
         E2 = DWORK(2)
         P1 = DWORK(N+1)
         P2 = DWORK(N+2)
         P3 = DWORK(N+3)
C
C        Compute eigenvalues of the product.
C
         CALL DLAHQR( .FALSE., .FALSE., N, 1, N, DWORK, N, DWORK(IR),
     $                DWORK(II), 1, 1, Z, 1, IM )
C
C        Find two eigenvalues with the smallest moduli.
C        If there are complex eigenvalues, selection is based on them.
C
         I = IDAMAX( N, DWORK(II), 1 )
         IF ( DWORK(II+I-1).EQ.ZERO ) THEN
            IM = IR + IDAMAX( N, DWORK(IR), 1 ) - 1
            MX = ABS( DWORK(IM) )
            MN = MX
C
            DO 100  I = IR, IR + N - 1
               MC = ABS( DWORK(I) )
               IF ( MC.LT.MN ) THEN
                  MN = MC
                  IM = I
               END IF
  100       CONTINUE
C
            PR = DWORK(IM)
            MN = MX
            DWORK(IM) = MX
            IS = IM
            MX = PR
C
            DO 110  I = IR, IR + N - 1
               MC = ABS( DWORK(I) )
               IF ( MC.LT.MN ) THEN
                  MN = MC
                  IM = I
               END IF
  110       CONTINUE
C
            SM = PR + DWORK(IM)
            PR = PR * DWORK(IM)
            DWORK(IS) = MX
C
         ELSE
C
            I  = II
            FC = .FALSE.
C
C           WHILE ( I <= II+N-1 ) DO
C
  120       CONTINUE
            IF ( I.LE.II + N - 1 ) THEN
               IF ( DWORK(I).NE.ZERO ) THEN
                  MC = DLAPY2( DWORK(I-N), DWORK(I) )
                  IF ( .NOT.FC ) THEN
                     FC = .TRUE.
                     IM = I
                     MN = MC
                  ELSE IF ( MC.LT.MN ) THEN
                     MN = MC
                     IM = I
                  END IF
                  I = I + 2
               ELSE
                  I = I + 1
               END IF
               GO TO 120
            END IF
C
C           END WHILE 120
C
            SM = TWO*DWORK(IM-N)
            PR = MN**2
         END IF
C
C        Compute a multiple of the first column of the real Wilkinson
C        double shift polynomial, having only three nonzero elements.
C
         P1 = P1 + ( ( E1 - SM )*E1 + PR )/E2
         P2 = P2 + E1 - SM
C
C        Compute the rotations to annihilate P2 and P3.
C
         CALL DLARTG( P2, P3, C2, S2, E1 )
         CALL DLARTG( P1, E1, C1, S1, E2 )
      END IF
C
      RETURN
C *** Last line of MB03AG ***
      END


!> @file math_tools.f
!! @ingroup math
!! @brief Set of math related tools for KTH modules
!! @author Adam Peplinski
!! @date Jan 31, 2017
!=======================================================================
!> @brief Step function
!! @ingroup math
!! @details Continuous step function:
!!  \f{eqnarray*}{
!!    stepf(x) = \left\{ \begin{array}{ll}
!!  0 &\mbox{ if $x \leq x_{min}$} \\
!!  \left(1+e^{\left((x-1)^{-1} + x^{-1}\right)}\right)^{-1} &\mbox{ if $x \leq x_{max}$} \\
!!  1 &\mbox{ if $x >  x_{max}$}
!!       \end{array} \right.
!!  \f}
!!  with \f$ x_{min} = 0.02\f$ and \f$ x_{max}=0.98\f$
!! @param[in] x       function argument
!! @return mth_stepf
      real function mth_stepf(x)
      implicit none

      ! argument list
      real x

      ! local variables
      real xdmin, xdmax
      parameter (xdmin = 0.001, xdmax = 0.999)
!-----------------------------------------------------------------------
      ! get function vale
      if (x.le.xdmin) then
         mth_stepf = 0.0
      else if (x.le.xdmax) then
         mth_stepf = 1./( 1. + exp(1./(x - 1.) + 1./x) )
      else
         mth_stepf = 1.
      end if

      return
      end function mth_stepf
!=======================================================================
!> @brief Give random distribution depending on position
!! @ingroup math
!! @details The original Nek5000 rundom number generator is implementted
!!  in @ref ran1. This totally ad-hoc random number generator below
!!  could be preferable to the origina one for the simple reason that it
!!  gives the same initial cindition independent of the number of
!!  processors, which is important for code verification.
!! @param[in] ix,iy,iz     GLL point index
!! @param[in] ieg          global element number
!! @param[in] xl           physical point coordinates
!! @param[in] fcoeff       function coefficients
!! @return  random distribution
      real function mth_ran_dst(ix,iy,iz,ieg,xl,fcoeff)
      implicit none

      include 'SIZE'
      include 'INPUT'       ! IF3D

      ! argument list
      integer ix,iy,iz,ieg
      real xl(LDIM)
      real fcoeff(3)
!-----------------------------------------------------------------------
      mth_ran_dst = fcoeff(1)*(ieg+xl(1)*sin(xl(2))) + fcoeff(2)*ix*iy +
     $     fcoeff(3)*ix
      if (IF3D) mth_ran_dst =
     $     fcoeff(1)*(ieg +xl(NDIM)*sin(mth_ran_dst)) +
     $     fcoeff(2)*iz*ix + fcoeff(3)*iz
      mth_ran_dst = 1.e3*sin(mth_ran_dst)
      mth_ran_dst = 1.e3*sin(mth_ran_dst)
      mth_ran_dst = cos(mth_ran_dst)

      return
      end function mth_ran_dst
!=======================================================================
!> @brief Give random number in the defined range
!! @ingroup math
!! @param[in] lower, upper     range for random numer
!! @return  random number in the defined range
      real function mth_ran_rng(lower, upper)
      implicit none

      ! argument list
      real lower, upper

      ! functions
      real mth_zbqlu01
!-----------------------------------------------------------------------
      mth_ran_rng = lower + mth_zbqlu01()*(upper-lower)

      return
      end function mth_ran_rng
!=======================================================================
!> @brief Marsaglia-Zaman random number generator
!! @ingroup math
!! @details Returns a uniform random number between 0 & 1, using
!!   a Marsaglia-Zaman type subtract-with-borrow generator.
!! @remarks Uses double precision, rather than integer, arithmetic
!!   throughout because MZ's INTEGER constants overflow
!!   32-bit INTEGER storage (which goes from -2^31 to 2^31).
!!   Ideally, we would explicitly truncate all INTEGER
!!   quantities at each stage to ensure that the DOUBLE
!!   PRECISION representations DO not accumulate approximation
!!   error; however, on some machines the USE of DNINT to
!!   accomplish this is *seriously* slow (run-time increased
!!   by a factor of about 3). This DOUBLE PRECISION version
!!   has been tested against an INTEGER implementation that
!!   uses long integers (non-standard and, again, slow) -
!!   the output was identical up to the 16th decimal place
!!   after 10^10 calls, so we're probably OK ...
!!   In current implementation we follow Nek5000 compilation
!!   rulles prolonging all reals to doulbe with compiler flaggs.
!! @author Richard Chandler (richard@stats.ucl.ac.uk)
!! @author Paul Northrop (northrop@stats.ox.ac.uk)
!! @return  random number
      real function mth_zbqlu01()
      implicit none

      ! global variables
      real zbqlix(43), br, cr
      common /math_zbql01/ zbqlix, br, cr

      ! local variables
      integer curpos,id22,id43
      save curpos,id22,id43
      data curpos,id22,id43 /1,22,43/
      real xr,b2,binv

!-----------------------------------------------------------------------
      b2 = br
      binv = 1.0/br

      do
         xr = zbqlix(id22) - zbqlix(id43) - cr
         if (xr.lt.0.0) then
            xr = xr + br
            cr = 1.0
         else
            cr = 0.0
         endif
         zbqlix(id43) = xr

         ! Update array pointers. Do explicit check for bounds of each to
         ! avoid expense of modular arithmetic. If one of them is 0
         ! the others won't be
         curpos = curpos - 1
         id22 = id22 - 1
         id43 = id43 - 1
         if (curpos.eq.0) then
            curpos=43
         elseif (id22.eq.0) then
            id22 = 43
         elseif (id43.eq.0) then
            id43 = 43
         endif

         ! The INTEGER arithmetic there can yield X=0, which can cause
         ! problems in subsequent routines (e.g. ZBQLEXP). The problem
         ! is simply that X is discrete whereas U is supposed to
         ! be continuous - hence IF X is 0, go back and generate another
         ! X and RETURN X/B^2 (etc.), which will be uniform on (0,1/B).
         if (xr.ge.binv) exit
         b2 = b2*br
      enddo

      mth_zbqlu01 = xr/b2
      return
      end function mth_zbqlu01
!=======================================================================
!> @brief Initialise Marsaglia-Zaman random number generator
!! @ingroup math
!! @details To initialise the random number generator - either repeatably
!!    or nonrepeatably.
!! @param[in] seed     number which generates elements of the array ZBQLIX
      subroutine math_zbqlini(seed)
      implicit none

      ! argiment list
      integer seed

      ! global variables
      real zbqlix(43), br, cr
      common /math_zbql01/ zbqlix, br, cr

      ! local variables
      integer icall
      save    icall
      data    icall  /0/

      integer il

      !  Initialisation data for random number generator.
      !  The values below have themselves been generated using the
      !  NAG generator.
      real zbq_ini(43),b_ini,c_ini
      data (zbq_ini(il),il=1,43) /8.001441d7,5.5321801d8,
     $   1.69570999d8,2.88589940d8,2.91581871d8,1.03842493d8,
     $   7.9952507d7,3.81202335d8,3.11575334d8,4.02878631d8,
     $   2.49757109d8,1.15192595d8,2.10629619d8,3.99952890d8,
     $   4.12280521d8,1.33873288d8,7.1345525d7,2.23467704d8,
     $   2.82934796d8,9.9756750d7,1.68564303d8,2.86817366d8,
     $   1.14310713d8,3.47045253d8,9.3762426d7 ,1.09670477d8,
     $   3.20029657d8,3.26369301d8,9.441177d6,3.53244738d8,
     $   2.44771580d8,1.59804337d8,2.07319904d8,3.37342907d8,
     $   3.75423178d8,7.0893571d7 ,4.26059785d8,3.95854390d8,
     $   2.0081010d7,5.9250059d7,1.62176640d8,3.20429173d8,
     $   2.63576576d8/
      data b_ini / 4.294967291d9 /
      data c_ini / 0.0d0 /

      real tmpvar1

      ! functions
      real dnekclock
!-----------------------------------------------------------------------
      if (icall.gt.0) return
      icall = icall + 1

      br = b_ini
      cr = c_ini
      ! if seed==0 use cpu time as seed
      if (seed.eq.0) then
         tmpvar1 = mod(dnekclock(),br)
      else
         tmpvar1 = mod(real(seed),br)
      endif
      zbqlix(1) = tmpvar1
      do il= 2, 43
         tmpvar1 = zbq_ini(il-1)*3.0269d4
         tmpvar1 = mod(tmpvar1,br)
         zbqlix(il) = tmpvar1
      enddo

      return
      end subroutine math_zbqlini
!=======================================================================
!> @brief Give bounds for loops to extract edge
!! @ingroup math
!! @note All edge related routines used IXCN and ESKIP, but this
!!   caused some problems as these arrays have to be continuosly
!!   updated for different levels in pressure solver, so I add this
!!   routine.
!! @param[out]   istart    lower loop bound
!! @param[out]   istop     upper loop bound
!! @param[out]   iskip     stride
!! @param[in]    iedg      edge number
!! @param[in]    nx,ny,xz  element size
      subroutine math_edgind(istart,istop,iskip,iedg,nx,ny,nz)
      implicit none
      include 'SIZE'
      include 'INPUT'
      include 'TOPOL'

!     argument list
      integer istart,istop,iskip,iedg,nx,ny,nz

!     local variables
      integer ivrt, icx, icy, icz
!-----------------------------------------------------------------------
!     find vertex position
!     start
      ivrt = icedg(1,iedg)
      icx = mod(ivrt +1,2)
      icy = mod((ivrt-1)/2,2)
      icz = (ivrt-1)/4
      istart =  1 + (nx-1)*icx + nx*(ny-1)*icy + nx*ny*(nz-1)*icz

!     stop
      ivrt = icedg(2,iedg)
      icx = mod(ivrt +1,2)
      icy = mod((ivrt-1)/2,2)
      icz = (ivrt-1)/4
      istop =  1 + (nx-1)*icx + nx*(ny-1)*icy + nx*ny*(nz-1)*icz

!     find stride
      if (iedg.le.4) then
         iskip = 1
      elseif (iedg.le.8) then
         iskip = nx
      else
         iskip =nx*nx
      endif

      return
      end subroutine
!=======================================================================
!> @brief Extract element edge
!! @ingroup math
!! @note This routine works on singe element not whole field.
!! @param[out]   vec       vector containg edge values
!! @param[in]    edg       edge number
!! @param[in]    vfld      pointer to singe element in the field
!! @param[in]    nx,ny,xz  element size
      subroutine math_etovec(vec,edg,vfld,nx,ny,nz)
      implicit none

      include 'SIZE'
      include 'TOPOL'

!     argument list
      real vfld(nx*ny*nz)
      integer edg,nx,ny,nz
      real vec(nx)

!     local variables
      integer is, ie, isk, il, jl
!-----------------------------------------------------------------------
!      is  = IXCN(icedg(1,edg))
!      ie  = IXCN(icedg(2,edg))
!      isk = ESKIP(edg,3)
      call math_edgind(is,ie,isk,edg,nx,ny,nz)
      jl = 1
      do il=is,ie,isk
        vec(jl) = vfld(il)
        jl = jl + 1
      enddo

      return
      end subroutine
!=======================================================================
!> @brief 3D rotation of a vector along given axis
!! @ingroup math
!! @param[in]  vo     output vector
!! @param[in]  vi     input vector
!! @param[in]  va     rotation axis
!! @param[in]  an     rotation angle
      subroutine mth_rot3Da(vo,vi,va,an)
      implicit none

      ! parameters
      integer ldim
      parameter (ldim=3)

      ! argument list
      real vo(ldim), vi(ldim), va(ldim), an

      ! local variables
      integer il, jl
      real mat(ldim,ldim), ta(ldim)
      real rtmp, can, can1, san
!-----------------------------------------------------------------------
      if (an.eq.0.0) then
         call copy(vo,vi,ldim)
      else
         ! make sure the axis vector is normalised
         rtmp = 0.0
         do il=1,ldim
            rtmp = rtmp + va(il)**2
         enddo
         ! add check if rtmp.gt.0
         rtmp = 1.0/sqrt(rtmp)
         do il=1,ldim
            ta(il) = rtmp*va(il)
         enddo
         ! fill in rotation mtrix
         can = cos(an)
         can1 = 1.0 - can
         san = sin(an)
         mat(1,1) = can + ta(1)*ta(1)*can1
         mat(2,1) = ta(1)*ta(2)*can1 - ta(3)*san
         mat(1,2) = ta(1)*ta(2)*can1 + ta(3)*san
         mat(3,1) = ta(1)*ta(3)*can1 + ta(2)*san
         mat(1,3) = ta(1)*ta(3)*can1 - ta(2)*san
         mat(2,2) = can + ta(2)*ta(2)*can1
         mat(3,2) = ta(2)*ta(3)*can1 - ta(1)*san
         mat(2,3) = ta(2)*ta(3)*can1 + ta(1)*san
         mat(3,3) = can + ta(3)*ta(3)*can1
         ! perform rotation
         do il = 1, ldim
            vo(il) = 0.0
            do jl=1,ldim
               vo(il) = vo(il) + mat(jl,il)*vi(jl)
            enddo
         enddo
      endif

      return
      end subroutine
!=======================================================================


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp
      integer blockno

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      double precision init_radius, init_location(2)
      common /initradius_comm/ init_radius, init_location

      double precision x0, y0, r0, r, ravg, th

      call mapc2m_annulus(xc,yc,xp,yp,zp)

      ravg = (1 + beta)/2.d0
c      th = pi2*((0.25 + 1.d0/32.d0) + 0.25)
      x0 = init_location(1)
      y0 = init_location(2)

      r = sqrt((xp - x0)**2 + (yp-y0)**2)

      r0 = init_radius
      fdisc = r - r0

      end


*     AB01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDZ
      PARAMETER        ( LDA = NMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), TAU(NMAX),
     $                 Z(LDZ,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB01MD, DORGQR
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( B(I), I = 1,N )
*        Find a controllable realization for the given system.
         CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) NCONT
            DO 20 I = 1, NCONT
               WRITE ( NOUT, FMT = 99994 ) ( A(I,J), J = 1,NCONT )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99996 ) ( B(I), I = 1,NCONT )
            IF ( LSAME( JOBZ, 'F' ) )
     $         CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO )
            IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) ( Z(I,J), J = 1,N )
   40          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01MD = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2,//' The state dynamics matrix A of a controlla',
     $       'ble realization is ')
99996 FORMAT (/' The input/state vector B of a controllable realizatio',
     $       'n is ',/(1X,F8.4))
99995 FORMAT (/' The similarity transformation matrix Z is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE CONRNG (ISLINE, FMINI, FMAXI, NCNTR, DELC, CMIN, CMAX)
C=======================================================================

C   --*** CONRNG *** (DETOUR) Calculate contour range
C   --   Written by Amy Gilkey - revised 06/09/87
C   --
C   --CONRNG calculates a new contour range from the minimum and maximum
C   --values.  Note that the contour interval and range are rounded to
C   --get "nice" numbers.  For the line contour, the contour minimum and
C   --maximum should fall between the actual value range (about one-half
C   --an interval in).  For the paint contour, the contour range must
C   --cover the actual value range.
C   --
C   --Parameters:
C   --   ISLINE - IN - true if line contour, else paint contour
C   --   FMINI, FMAXI - IN - the minimum and maximum value in the contour plot
C   --   NCNTR - IN/OUT - the number of contours defined
C   --   DELC - OUT - the contour interval
C   --   CMIN - OUT - the minimum contour value
C   --   CMAX - OUT - the maximum contour value

      LOGICAL ISLINE

      CHARACTER*8 STRING

      IF (NCNTR .LE. 0) NCNTR = 6

C   --Check for minimum equal maximum

      IF (FMINI .EQ. FMAXI) THEN
         CALL PRTERR ('CMDWARN', 'Contour variable does not vary'
     &      // ' - an artificial range is supplied')
         IF (FMINI .EQ. 0.0) THEN
            FMIN = -1.0
            FMAX = 1.0
         ELSE
            FMIN = FMINI - .05 * ABS(FMINI)
            FMAX = FMINI + .05 * ABS(FMINI)
         END IF
      ELSE
         FMIN = FMINI
         FMAX = FMAXI
      END IF

      IF (ISLINE) THEN

C      --Compute decimal scale factor

         DELC = (FMAX - FMIN) / NCNTR
         WRITE (STRING, '(E8.1)') DELC
         STRING(4:4) = '1'
         READ (STRING, '(E8.1)') P10

C      --Compute rounded increment and offset

         DELC = .5 * P10 * NINT (2. * DELC / P10)
         CMIN = .5 *
     &      (P10 * NINT ((FMAX + FMIN) / P10) - (NCNTR-1) * DELC)
         CMAX = CMIN + (NCNTR-1) * DELC

      ELSE
         FRNG = FMAX - FMIN
  100    CONTINUE

C      --Compute decimal scale factor

         DELC = FRNG / NCNTR
         WRITE (STRING, '(E8.1)') DELC
         STRING(4:4) = '1'
         READ (STRING, '(E8.1)') P10

C      --Compute rounded increment and offset

         DELC = .25 * P10 * NINT (4. * DELC / P10)
         CMIN = .5 * (P10 * NINT ((FMAX + FMIN) / P10) - NCNTR * DELC)
         IF ((FMIN .GE. 0.0) .AND. (CMIN .LT. 0.0)) CMIN = 0.0
         CMAX = CMIN + NCNTR * DELC

C      --Adjust and recompute, if needed

         IF ((CMIN .GT. FMIN) .OR. (CMAX .LT. FMAX)) THEN
            IF (CMIN .GT. FMIN) FRNG = FRNG + .25*DELC
            IF (CMAX .LT. FMAX) FRNG = FRNG + .25*DELC
            GOTO 100
         END IF

      END IF

      RETURN
      END


PROGRAM mlqmns

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!       =========================================================
!       Purpose: This program computes the associated Legendre
!                functions Qmn(x) and their derivatives Qmn'(x)
!                for a given order using subroutine LQMNS
!       Input :  x --- Argument of Qmn(x)
!                m --- Order of Qmn(x),  m = 0,1,2,...
!                n --- Degree of Qmn(x), n = 0,1,2,...
!       Output:  QM(n) --- Qmn(x)
!                QD(n) --- Qmn'(x)
!       Examples:
!                m = 1,  N = 5,  x = .5
!                n        Qmn(x)           Qmn'(x)
!               -------------------------------------
!                0    .11547005D+01    .76980036D+00
!                1    .10530633D+01    .23771592D+01
!                2   -.72980606D+00    .51853281D+01
!                3   -.24918526D+01    .10914062D+01
!                4   -.19340866D+01   -.11454786D+02
!                5    .93896830D+00   -.18602587D+02

!                m = 2,  N = 5,  x = 2.5
!                n        Qmn(x)           Qmn'(x)
!               -------------------------------------
!                0    .95238095D+00   -.52607710D+00
!                1    .38095238D+00   -.36281179D+00
!                2    .12485160D+00   -.17134314D+00
!                3    .36835513D-01   -.66284127D-01
!                4    .10181730D-01   -.22703958D-01
!                5    .26919481D-02   -.71662396D-02
!       =========================================================

IMPLICIT DOUBLE PRECISION (q,x,y)
DIMENSION qm(0:200),qd(0:200)
WRITE(*,*)'Please enter m, N, and x '
!        READ(*,*)M,N,X
m=1
n=5
x=.5
WRITE(*,30)m,n,x
CALL lqmns(m,n,x,qm,qd)
WRITE(*,*)
WRITE(*,*)'  n        Qmn(x)           Qmn''(X)'
WRITE(*,*)' -------------------------------------'
DO  j=0,n
  WRITE(*,20)j,qm(j),qd(j)
END DO
20      FORMAT(1X,i3,2D17.8)
30      FORMAT(1X,'m =',i2,',  ','n =',i2,',  ','x =',f5.1)
END PROGRAM mlqmns

SUBROUTINE lqmns(m,n,x,qm,qd)

!       ========================================================
!       Purpose: Compute associated Legendre functions Qmn(x)
!                and Qmn'(x) for a given order
!       Input :  x --- Argument of Qmn(x)
!                m --- Order of Qmn(x),  m = 0,1,2,...
!                n --- Degree of Qmn(x), n = 0,1,2,...
!       Output:  QM(n) --- Qmn(x)
!                QD(n) --- Qmn'(x)
!       ========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: qm(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: qd(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

DO  k=0,n
  qm(k)=0.0D0
  qd(k)=0.0D0
END DO
IF (DABS(x) == 1.0D0) THEN
  DO  k=0,n
    qm(k)=1.0D+300
    qd(k)=1.0D+300
  END DO
  RETURN
END IF
ls=1
IF (DABS(x) > 1.0D0) ls=-1
xq=DSQRT(ls*(1.0D0-x*x))
q0=0.5D0*DLOG(DABS((x+1.0)/(x-1.0)))
q00=q0
q10=-1.0D0/xq
q01=x*q0-1.0D0
q11=-ls*xq*(q0+x/(1.0D0-x*x))
qf0=q00
qf1=q10
DO  k=2,m
  qm0=-2.0D0*(k-1.0)/xq*x*qf1-ls*(k-1.0)*(2.0-k)*qf0
  qf0=qf1
  qf1=qm0
END DO
IF (m == 0) qm0=q00
IF (m == 1) qm0=q10
qm(0)=qm0
IF (DABS(x) < 1.0001D0) THEN
  IF (m == 0.AND.n > 0) THEN
    qf0=q00
    qf1=q01
    DO  k=2,n
      qf2=((2.0*k-1.0D0)*x*qf1-(k-1.0)*qf0)/k
      qm(k)=qf2
      qf0=qf1
      qf1=qf2
    END DO
  END IF
  qg0=q01
  qg1=q11
  DO  k=2,m
    qm1=-2.0D0*(k-1.0)/xq*x*qg1-ls*k*(3.0-k)*qg0
    qg0=qg1
    qg1=qm1
  END DO
  IF (m == 0) qm1=q01
  IF (m == 1) qm1=q11
  qm(1)=qm1
  IF (m == 1.AND.n > 1) THEN
    qh0=q10
    qh1=q11
    DO  k=2,n
      qh2=((2.0*k-1.0D0)*x*qh1-k*qh0)/(k-1.0)
      qm(k)=qh2
      qh0=qh1
      qh1=qh2
    END DO
  ELSE IF (m >= 2) THEN
    qg0=q00
    qg1=q01
    qh0=q10
    qh1=q11
    DO  l=2,n
      q0l=((2.0D0*l-1.0D0)*x*qg1-(l-1.0D0)*qg0)/l
      q1l=((2.0*l-1.0D0)*x*qh1-l*qh0)/(l-1.0D0)
      qf0=q0l
      qf1=q1l
      DO  k=2,m
        qmk=-2.0D0*(k-1.0)/xq*x*qf1-ls*(k+l-1.0)* (l+2.0-k)*qf0
        qf0=qf1
        qf1=qmk
      END DO
      qm(l)=qmk
      qg0=qg1
      qg1=q0l
      qh0=qh1
      qh1=q1l
    END DO
  END IF
ELSE
  IF (DABS(x) > 1.1) THEN
    km=40+m+n
  ELSE
    km=(40+m+n)*INT(-1.0-1.8*LOG(x-1.0))
  END IF
  qf2=0.0D0
  qf1=1.0D0
  DO  k=km,0,-1
    qf0=((2.0*k+3.0D0)*x*qf1-(k+2.0-m)*qf2)/(k+m+1.0)
    IF (k <= n) qm(k)=qf0
    qf2=qf1
    qf1=qf0
  END DO
  DO  k=0,n
    qm(k)=qm(k)*qm0/qf0
  END DO
END IF
IF (DABS(x) < 1.0D0) THEN
  DO  k=0,n
    qm(k)=(-1)**m*qm(k)
  END DO
END IF
qd(0)=((1.0D0-m)*qm(1)-x*qm(0))/(x*x-1.0)
DO  k=1,n
  qd(k)=(k*x*qm(k)-(k+m)*qm(k-1))/(x*x-1.0)
END DO
RETURN
END SUBROUTINE lqmns


!=============================================================================!
        subroutine smoother3D(rl, vl)
!
!       Fourth order explicit smoother for the NS equations.
!       From: Computational Fluid Mechanics and Heat Transfer
!             D.A. Anderson, J. C. Tannehill, Rl H. Pletcher
!             Page:  450, 495
!
!       Written: 6-9-95
!
!       Revised: 7-9-96
!
!       Notes:   Need to account for periodicity smoothed fields.
!=============================================================================!
        use stuff
        use buff_stuff
        use diff
        implicit none

        complex :: rl(ny,nx,ndof), vl(ny,nx,ndof)
        real :: isign
        integer :: idof, i, j

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

!.... fourth-order dissipation with reduced order near the boundaries

        if (eps_e .eq. zero) return

!.... \eta direction

        do idof = 1, ndof
          do i = 1, nx

            j = 2
            rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                           -1.0 * vl(j-1,i,idof) + &
                                            2.0 * vl(j,i  ,idof) - &
                                            1.0 * vl(j+1,i,idof) )

            j = 3
            rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                          vl(j-2,i,idof) - &
                                          4.0 * vl(j-1,i,idof) + &
                                          6.0 * vl(j  ,i,idof) - &
                                          4.0 * vl(j+1,i,idof) + &
                                          1.0 * vl(j+2,i,idof) )

            do j = 4, ny-3
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            fa1 * vl(j-3,i,idof) + &
                                            fa2 * vl(j-2,i,idof) + &
                                            fa3 * vl(j-1,i,idof) + &
                                            fa4 * vl(j  ,i,idof) + &
                                            fa5 * vl(j+1,i,idof) + &
                                            fa6 * vl(j+2,i,idof) + &
                                            fa7 * vl(j+3,i,idof) )
            end do

            j = ny-2
            rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                          vl(j-2,i,idof) - &
                                          4.0 * vl(j-1,i,idof) + &
                                          6.0 * vl(j  ,i,idof) - &
                                          4.0 * vl(j+1,i,idof) + &
                                          1.0 * vl(j+2,i,idof) )

            j = ny-1
            rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                          -1.0 * vl(j-1,i,idof) + &
                                            2.0 * vl(j  ,i,idof) - &
                                            1.0 * vl(j+1,i,idof) )

          end do
        end do

!.... \xi direction

        if (lsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if
            do j = 1, ny
              i = 1
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            isign * fa1 * vl(j,4,idof) + &
                                            isign * fa2 * vl(j,3,idof) + &
                                            isign * fa3 * vl(j,2,idof) + &
                                            fa4 * vl(j,1,idof) + &
                                            fa5 * vl(j,2,idof) + &
                                            fa6 * vl(j,3,idof) + &
                                            fa7 * vl(j,4,idof) )

              i = 2
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            isign * fa1 * vl(j,3,idof) + &
                                            isign * fa2 * vl(j,2,idof) + &
                                            fa3 * vl(j,1,idof) + &
                                            fa4 * vl(j,2,idof) + &
                                            fa5 * vl(j,3,idof) + &
                                            fa6 * vl(j,4,idof) + &
                                            fa7 * vl(j,5,idof) )

              i = 3
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            isign * fa1 * vl(j,2,idof) + &
                                            fa2 * vl(j,1,idof) + &
                                            fa3 * vl(j,2,idof) + &
                                            fa4 * vl(j,3,idof) + &
                                            fa5 * vl(j,4,idof) + &
                                            fa6 * vl(j,5,idof) + &
                                            fa7 * vl(j,6,idof) )
            end do
          end do
        else
          do idof = 1, ndof
            do j = 1, ny
              i = 2
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            -1.0 * vl(j,i-1,idof) + &
                                            2.0 * vl(j,i  ,idof) - &
                                            1.0 * vl(j,i+1,idof) )

              i = 3
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            vl(j,i-2,idof) - &
                                            4.0 * vl(j,i-1,idof) + &
                                            6.0 * vl(j,i  ,idof) - &
                                            4.0 * vl(j,i+1,idof) + &
                                            1.0 * vl(j,i+2,idof) )
            end do
          end do
        end if

!.... Interior

        do idof = 1, ndof
          do j = 1, ny
            do i = 4, nx-3
              rl(j,i,idof) = rl(j,i,idof) + &
                                  eps_e * buff(j,i) * ( &
                                  fa1 * vl(j,i-3,idof) + &
                                  fa2 * vl(j,i-2,idof) + &
                                  fa3 * vl(j,i-1,idof) + &
                                  fa4 * vl(j,i  ,idof) + &
                                  fa5 * vl(j,i+1,idof) + &
                                  fa6 * vl(j,i+2,idof) + &
                                  fa7 * vl(j,i+3,idof) )
            end do
          end do
        end do

        if (rsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if
            do j = 1, ny
              i = nx-2
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            fa1 * vl(j,nx-5,idof) + &
                                            fa2 * vl(j,nx-4,idof) + &
                                            fa3 * vl(j,nx-3,idof) + &
                                            fa4 * vl(j,nx-2,idof) + &
                                            fa5 * vl(j,nx-1,idof) + &
                                            fa6 * vl(j,nx,idof) + &
                                            isign * fa7 * vl(j,nx-1,idof) )

              i = nx-1
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            fa1 * vl(j,nx-4,idof) + &
                                            fa2 * vl(j,nx-3,idof) + &
                                            fa3 * vl(j,nx-2,idof) + &
                                            fa4 * vl(j,nx-1,idof) + &
                                            fa5 * vl(j,nx,idof) + &
                                            isign * fa6 * vl(j,nx-1,idof) + &
                                            isign * fa7 * vl(j,nx-2,idof) )

              i = nx
              rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                            fa1 * vl(j,nx-3,idof) + &
                                            fa2 * vl(j,nx-2,idof) + &
                                            fa3 * vl(j,nx-1,idof) + &
                                            fa4 * vl(j,nx,idof) + &
                                            isign * fa5 * vl(j,nx-1,idof) + &
                                            isign * fa6 * vl(j,nx-2,idof) + &
                                            isign * fa7 * vl(j,nx-3,idof) )
            end do
          end do
        else
          i = nx-2
          rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                        vl(j,i-2,idof) - &
                                        4.0 * vl(j,i-1,idof) + &
                                        6.0 * vl(j,i  ,idof) - &
                                        4.0 * vl(j,i+1,idof) + &
                                        1.0 * vl(j,i+2,idof) )

          i = nx-1
          rl(j,i,idof) = rl(j,i,idof) + eps_e * buff(j,i) * ( &
                                        -1.0 * vl(j,i-1,idof) + &
                                        2.0 * vl(j,i,idof) - &
                                        1.0 * vl(j,i+1,idof) )
        end if

        return
        end


c=======================================================================
c
c     subroutine SCHURS
c
c     Matrix Schur Decomposition of a symmetric matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE schurs ( n, X, iwork, dwork, eigval, vpmat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : input matrix (n*n)                          double
c
c     WORKSPACE
c            iwork  : vector ( 12*n )                            integer
c            dwork  : vector ( n*(n+26) )                         double
c
c     OUTPUT
c            eigval : eigenvalues (n)                             double
c            vpmat  : eigenvectors (n*n)                          double
c            info   : diagnostic argument                        integer
c
c     CALL
c            YM     : copy a vectorized matrix in a vectorized matrix
c            DSYEVR : Schur factorization for symmetric matrices (cf. LAPACK)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION eigval(*), X(*), vpmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pisup, pmat, pdw, ldwork, liwork, ild, ili, il, iu,
     &        msy
      DOUBLE PRECISION vl, vu, abstol
      PARAMETER ( abstol = 0.0, ili = 10, ild = 26 )
      PARAMETER ( il = 1, vl = 0.0, vu = 0.0 )
c
c     external subroutines
      EXTERNAL YM, DSYEVR
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
      liwork = ili*n
      ldwork = ild*n
      iu = n
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for work matrix of DSYEVR who needs  (n*ili)
c              so n*ili = n*10 more
      pisup = piw + ( 10*n )
c     pisup : pointer for work matrix of DSYEVR who needs  (2*n) so 2*n more
c     pinext = pisup + ( 2*n )
c     pinext : pointer for the next iwork array
c
c     Total size of iwork array ( 12*n )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pmat = 1
c     pmat   : pointer for work matrix, so (n*n) more
      pdw = pmat + ( n*n )
c     pdw    : pointer for work matrix of DSYEVR ( n*ild ),
c              so n*ild = n*26 more
c     pdnext = pdw + ( 26*n )
c     pdnext  : pointer of the next dwork array
c
c     Total size of dwork array = ( n*(n + 26) )
c
c-----------------------------------------------------------------------
c
c     saves initial matrix ( altered by DSYEVR )
      CALL YM ( n, n, X, dwork(pmat) )
c
c     DSYEVR (cf. LAPACK)
c     DSYEVR computes selected eigenvalues and, optionally, eigenvectors
c     of a real symmetric matrix T.  Eigenvalues and eigenvectors can be
c     selected by specifying either a range of values or a range of
c     indices for the desired eigenvalues
      CALL DSYEVR ( 'V', 'A', 'U', n, dwork(pmat), n,
     &              vl, vu, il, iu, abstol, msy, eigval,
     &              vpmat, n, iwork(pisup),
     &              dwork(pdw), ldwork, iwork(piw), liwork, info )
c
      RETURN
      END


submodule(euler_interface_m) euler_prob_0021_m
    implicit none

contains

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

    integer function ans(n)
        integer, intent(in) :: n
        procedure(sum_of_prop_div), pointer :: f
        integer :: p, t

        t = 0
        f => sum_of_prop_div
        do p = 1, n
            if (f(f(p)) == p .and. f(p) /= p) then
                t = t + p
            end if
        end do
        ans = t
    end function ans

    integer function sum_of_prop_div(n)
        integer, intent(in) :: n
        integer :: i, sum

        sum = 1
        do i = 2, int(sqrt(real(n, sp)))
            if (mod(n, i) == 0) then
                sum = sum + i + n/i
            end if
        end do
        sum_of_prop_div = sum
    end function sum_of_prop_div
end submodule euler_prob_0021_m


real*8 function hw1(r1, r2)
real*8 :: r1, r2
!f2py intent(in) r1
!f2py intent(in) r2
hw1 = sin(r1 + r2)
print*, hw1
return
end function hw1

subroutine hw2(r1, r2)
real*8 :: r1, r2, s
!f2py intent(in) r1
!f2py intent(in) r2
s = sin(r1 + r2)
print*, 'Hello, World!, sin(',r1+r2,')=',s
return
end subroutine hw2

subroutine hw3(r3, r4, s)
! integer, intent(in) :: r3, r4 这里不能用integer（整型），否则会报错
real, intent(in) :: r3,r4
real, intent(out) :: s
!f2py intent(in) r3
!f2py intent(in) r4
!f2py intent(out) s
s = sin(r3 + r4)
return
end


program array_reshape
  implicit none
  integer                           :: N, M, J
  real, dimension(:,:), ALLOCATABLE :: A
  integer                           :: err

  read *, N, M

  allocate( A(N, M), STAT=err )
  if (err /= 0) STOP "Error when allocating M"
  A = reshape((/(j,j=1,N*M)/),shape=(/N,M/))
  do j=1,N
    print*, A(J,:)
  enddo
  deallocate( A )
end program array_reshape


! Tests WHERE satement with non-integer array in the mask expression
program where_5
   integer, dimension(5) :: a
   real(kind=8), dimension(5) :: b

   a = (/1, 2, 3, 4, 5/)
   b = (/1d0, 0d0, 1d0, 0d0, 1d0/)

   where (b .ne. 0d0)
      a(:) = a(:) + 10
   endwhere
   if (any (a .ne. (/11, 2, 13, 4, 15/))) call abort
end program


subroutine CompGibbsMagneticSolnInit(i,j)

    USE ModuleParseCS
    USE ModuleThermo
    USE ModuleThermoIO

    implicit none

    integer :: i, j
    real(8) :: B, D, p, invpmone, tau, Tcritical, g, StructureFactor

    ! Assign the critical temperature can either be the Curie temperature for ferromagnetic materials
    ! or the Neel temperature for antiferromagnetic materials:
    Tcritical       = dCoeffGibbsMagnetic(j,1)
    B               = dCoeffGibbsMagnetic(j,2)
    StructureFactor = dCoeffGibbsMagnetic(j,3)
    p               = dCoeffGibbsMagnetic(j,4)
    invpmone        = 1D0/p - 1D0

    ! ChemSage files store the critical (i.e., Neel) temperature for antiferromagnetic materials
    ! as a negative real value divided by the structure factor.  Correct Tcritical and B:
    if (Tcritical < 0D0) then
        Tcritical = -Tcritical * StructureFactor
        B         = -B * StructureFactor
    end if

    tau = dTemperature / Tcritical
    D   = 518D0/1125D0 + (11692D0/15975D0) * invpmone

    if (tau > 1D0) then
        g = -((tau**(-5))/10D0 + (tau**(-15))/315D0 + (tau**(-25))/1500D0) / D
    else
        g = 1D0 - (79D0/(140D0*p*tau) + (474D0/497D0)*invpmone*((tau**3)/6D0 + (tau**9)/135D0 + (tau**15)/600D0)) / D
    end if

    ! Add the magnetic contribution to the Gibbs energy term:
    dMagGibbsEnergy(j) = DLOG(B + 1D0) * g
    ! print *, cSpeciesName(j), dMagGibbsEnergy(j)

    return

end subroutine CompGibbsMagneticSolnInit


      subroutine Acalc(k1,k2,k3,k4,k5,k6,mt,A)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'ZZclabels.f'
      include 'ZZdlabels.f'
      include 'ggZZintegrals.f'
      double complex A(6)
      double precision mt,mtsq,s12,s134,s234,s134bar,s234bar,p3sq,Y
      integer k1,k2,k3,k4,k5,k6
      mtsq=mt**2
      s12=s(k1,k2)
      s134bar=s(k1,k3)+s(k1,k4)
      s234bar=s(k2,k3)+s(k2,k4)
      p3sq=s(k3,k4)
      s234=s234bar+p3sq
      s134=s134bar+p3sq
      Y=s134bar*s234bar-s12*p3sq

      A(1)=+0.5d0*mtsq/s12*(
     & +2d0*C0(c1_34)*s134bar
     & +2d0*C0(c2_56)*(-s234bar-s12)
     & +2d0*C0(c2_34)*s234bar
     & +2d0*C0(c1_56)*(-s12-s134bar)
     & -2d0*Y*D0(d1_34_2)
     & +s12*(s12-4*mtsq)*(D0(d1_2_34)+D0(d2_1_34)+D0(d1_34_2)))

      A(2)=2d0*mtsq*(D0(d6_1_2_34)+D0(d6_2_1_34)+C0(c12_34)
     & +mtsq*(D0(d1_2_34)+D0(d2_1_34)-D0(d1_34_2)))

c      A(2)=mtsq/Y*(
c     & +C0(c1_34)*s134*s134bar
c     & +C0(c2_56)*s134*(-s234bar-s12)
c     & +C0(c2_34)*s234*s234bar
c     & +C0(c1_56)*s234*(-s134bar-s12)
c     & +C0(c1_2)*s12*(s234+s134)
c     & +C0(c12_34)*(2d0*Y-((s134bar+s234bar)**2-4d0*s12*p3sq))
c     & -D0(d2_1_34)*s12*s134**2-D0(d1_2_34)*s12*s234**2
c     & -2d0*Y*mtsq*(D0(d1_2_34)+D0(d1_34_2)+D0(d2_1_34)))

      A(3)=0.5d0*mtsq*s12*(D0(d1_2_34)-D0(d2_1_34)-D0(d1_34_2))
      A(4)=0.5d0*mtsq*s12*(D0(d2_1_34)-D0(d1_2_34)-D0(d1_34_2))

      A(5)=0.5d0*mtsq*s12/(s134*s234)*(
     & +2d0*s134*D0(d6_1_2_34)+2d0*s234*D0(d6_2_1_34)
     & -s134*s234*D0(d1_34_2)
     & +4d0*mtsq*(s134*D0(d1_2_34)+s234*D0(d2_1_34))
     & +2d0*(s234+s134)*C0(c12_34))

c      A(5)=0.5d0*mtsq*s12/Y*(
c     & +C0(c1_34)*2d0*s134bar
c     & -C0(c1_56)*2d0*(s12+s134bar)
c     & +C0(c1_2)*2d0*s12
c     & -D0(d1_2_34)*s12*s234-D0(d2_1_34)*s12*s134-Y*D0(d1_34_2))

      A(6)=czip
c      A(6)=mtsq*s12/Y*(
c     & -C0(c1_34)*s134bar
c     & +C0(c1_56)*(s12+s134bar)
c     & +C0(c2_34)*s234bar
c     & -C0(c2_56)*(s12+s234bar))
c      write(6,*) 'A(6)',A(6)

      return
      end


 implicit none

 complex :: a

 a=(1.,2.)
 print*,a,real(a),aimag(a)
 a=a*(0.,1.)
 print*,a

 end