	FUNCTION bessi_s(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessi0
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(SP), INTENT(IN) :: x
	REAL(SP) :: bessi_s
	INTEGER(I4), PARAMETER :: IACC=40,IEXP=maxexponent(x)/2
	INTEGER(I4) :: j,m
	REAL(SP) :: bi,bim,bip,tox
	call assert(n >= 2, 'bessi_s args')
	bessi_s=0.0
	if (x*x <= 8.0_sp*tiny(x)) RETURN
	tox=2.0_sp/abs(x)
	bip=0.0
	bi=1.0
	m=2*((n+int(sqrt(real(IACC*n,sp)))))
	do j=m,1,-1
		bim=bip+j*tox*bi
		bip=bi
		bi=bim
		if (exponent(bi) > IEXP) then
			bessi_s=scale(bessi_s,-IEXP)
			bi=scale(bi,-IEXP)
			bip=scale(bip,-IEXP)
		end if
		if (j == n) bessi_s=bip
	end do
	bessi_s=bessi_s*bessi0(x)/bi
	if (x < 0.0 .and. mod(n,2) == 1) bessi_s=-bessi_s
	END FUNCTION bessi_s

	FUNCTION bessi_v(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessi0
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(SP), DIMENSION(:), INTENT(IN) :: x
	REAL(SP), DIMENSION(size(x)) :: bessi_v
	INTEGER(I4), PARAMETER :: IACC=40,IEXP=maxexponent(x)/2
	INTEGER(I4) :: j,m
	REAL(SP), DIMENSION(size(x)) :: bi,bim,bip,tox
	LOGICAL(LGT), DIMENSION(size(x)) :: mask
	call assert(n >= 2, 'bessi_v args')
	bessi_v=0.0
	mask = (x <= 8.0_sp*tiny(x))
	tox=2.0_sp/merge(2.0_sp,abs(x),mask)
	bip=0.0
	bi=1.0_sp
	m=2*((n+int(sqrt(real(IACC*n,sp)))))
	do j=m,1,-1
		bim=bip+j*tox*bi
		bip=bi
		bi=bim
		where (exponent(bi) > IEXP)
			bessi_v=scale(bessi_v,-IEXP)
			bi=scale(bi,-IEXP)
			bip=scale(bip,-IEXP)
		end where
		if (j == n) bessi_v=bip
	end do
	bessi_v=bessi_v*bessi0(x)/bi
	where (mask) bessi_v=0.0_sp
	where (x < 0.0 .and. mod(n,2) == 1) bessi_v=-bessi_v
	END FUNCTION bessi_v

	FUNCTION dbessi_s(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessi0
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(DP), INTENT(IN) :: x
	REAL(DP) :: dbessi_s
	INTEGER(I4), PARAMETER :: IACC=40,IEXP=maxexponent(x)/2
	INTEGER(I4) :: j,m
	REAL(DP) :: bi,bim,bip,tox
	call assert(n >= 2, 'dbessi_s args')
	dbessi_s=0.0
	if (x*x <= 8.0_dp*tiny(x)) RETURN
	tox=2.0_dp/abs(x)
	bip=0.0
	bi=1.0
	m=2*((n+int(sqrt(real(IACC*n,dp)))))
	do j=m,1,-1
		bim=bip+j*tox*bi
		bip=bi
		bi=bim
		if (exponent(bi) > IEXP) then
			dbessi_s=scale(dbessi_s,-IEXP)
			bi=scale(bi,-IEXP)
			bip=scale(bip,-IEXP)
		end if
		if (j == n) dbessi_s=bip
	end do
	dbessi_s=dbessi_s*bessi0(x)/bi
	if (x < 0.0 .and. mod(n,2) == 1) dbessi_s=-dbessi_s
	END FUNCTION dbessi_s

	FUNCTION dbessi_v(n,x)
	use mo_kind
          use mo_nrutil, ONLY : assert
	use mo_nr, ONLY : bessi0
	IMPLICIT NONE
	INTEGER(I4), INTENT(IN) :: n
	REAL(DP), DIMENSION(:), INTENT(IN) :: x
	REAL(DP), DIMENSION(size(x)) :: dbessi_v
	INTEGER(I4), PARAMETER :: IACC=40,IEXP=maxexponent(x)/2
	INTEGER(I4) :: j,m
	REAL(DP), DIMENSION(size(x)) :: bi,bim,bip,tox
	LOGICAL(LGT), DIMENSION(size(x)) :: mask
	call assert(n >= 2, 'dbessi_v args')
	dbessi_v=0.0
	mask = (x <= 8.0_dp*tiny(x))
	tox=2.0_dp/merge(2.0_dp,abs(x),mask)
	bip=0.0
	bi=1.0_dp
	m=2*((n+int(sqrt(real(IACC*n,dp)))))
	do j=m,1,-1
		bim=bip+j*tox*bi
		bip=bi
		bi=bim
		where (exponent(bi) > IEXP)
			dbessi_v=scale(dbessi_v,-IEXP)
			bi=scale(bi,-IEXP)
			bip=scale(bip,-IEXP)
		end where
		if (j == n) dbessi_v=bip
	end do
	dbessi_v=dbessi_v*bessi0(x)/bi
	where (mask) dbessi_v=0.0_dp
	where (x < 0.0 .and. mod(n,2) == 1) dbessi_v=-dbessi_v
	END FUNCTION dbessi_v


!  ConsoleFortran.f90
!
!  FUNCTIONS:
!  ConsoleFortran - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: ConsoleFortran
!
!  PURPOSE:  Testing rand with gfortran.
!
!****************************************************************************

    program ConsoleFortran
      implicit none

      integer(8) npts
      parameter (npts = 10d5)

      integer(8) i

      real(8) f,sum
      real(8) xmin,xmax,x

      xmin = 0.0d0
      xmax = 1.0d0

      do i=1,npts
         x = (xmax-xmin)*rand(0) + xmin
         sum = sum + 4.0d0/(1.0d0 + x**2)
      enddo
      f = sum/npts

      write(*,*)'PI calculated with ',npts,' points = ',f
      call ZBQLUAB(-10.0,10.0)

      stop
      end


module runge_kutta_mod
!
private
!
public :: runge_kutta_allroutines

    contains
!
    subroutine runge_kutta_allroutines(rk_order,y,nvar,x1,x2,derivs)
!
        IMPLICIT NONE
!
        external        :: derivs
        integer         :: rk_order,nvar
        double precision :: x1,x2,h1
        double precision, dimension(nvar) :: y,dydx,yout
!
        h1=x2-x1
!
        select case(rk_order)
            case(4)
                call derivs(x1,y,dydx)
                call rk4(y,dydx,x1,h1,yout,derivs)
                y = yout
!
            case DEFAULT
                print *, 'Chosen Runge Kutta is not available'
                stop
!
        end select
!
    end subroutine runge_kutta_allroutines
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
    SUBROUTINE rk4(y,dydx,x,h,yout,derivs)
!
        IMPLICIT NONE
!
        external        :: derivs
        double precision, DIMENSION(:), INTENT(IN) :: y,dydx
        double precision, INTENT(IN) :: x,h
        double precision, DIMENSION(:), INTENT(OUT) :: yout
!
!        INTERFACE
!                SUBROUTINE derivs(x,y,dydx)
!!
!                IMPLICIT NONE
!!
!                double precision, INTENT(IN) :: x
!                double precision, DIMENSION(:), INTENT(IN) :: y
!                double precision, DIMENSION(:), INTENT(OUT) :: dydx
!!
!                END SUBROUTINE derivs
!        END INTERFACE
!
        double precision :: h6,hh,xh
        double precision, DIMENSION(size(y)) :: dym,dyt,yt
!
        hh=h*0.5d0
        h6=h/6.0d0
        xh=x+hh
        yt=y+hh*dydx
        call derivs(xh,yt,dyt)
        yt=y+hh*dyt
        call derivs(xh,yt,dym)
        yt=y+h*dym
        dym=dyt+dym
        call derivs(x+h,yt,dyt)
        yout=y+h6*(dydx+dyt+2.0d0*dym)
!
    END SUBROUTINE rk4
!
end module


program arrays_04_func
implicit none
real :: a(3), b
a(1) = 3
a(2) = 2
a(3) = 1
b = sum(a)
if (abs(b-6) > 1e-5) error stop

contains

    real function sum(a) result(r)
    real, intent(in) :: a(:)
    integer :: i
    print *, "sum"
    r = 0
    do i = 1, size(a)
        r = r + a(i)
    end do
    end function

    real function abs(a) result(r)
    real, intent(in) :: a
    print *, "abs"
    if (a > 0) then
        r = a
    else
        r = -a
    end if
    end function

end


	REAL*8	FUNCTION MODUL(V)
	IMPLICIT NONE

	REAL*8	V(3)

	MODUL = SQRT(V(1)**2 + V(2)**2 + V(3)**2)
	END

	REAL*8 FUNCTION DOTPRD(V1,V2)
	IMPLICIT NONE

	REAL*8 V1(3), V2(3)
	REAL*8 DP
	INTEGER*2 I

	DP = 0
	DO I=1,3
		DP = DP + V1(I) * V2(I)
	ENDDO
	DOTPRD = DP
	END

	SUBROUTINE CRSPRD(V1,V2,CP)
	IMPLICIT NONE
	REAL*8 V1(3),V2(3),CP(3)

	CP(1) = V1(2)*V2(3) - V1(3)*V2(2)
	CP(2) = V1(3)*V2(1) - V1(1)*V2(3)
	CP(3) = V1(1)*V2(2) - V1(2)*V2(1)
	RETURN
	END

	SUBROUTINE NORM(V,NV)
	IMPLICIT NONE
	REAL*8 V(3),NV(3)
	REAL*8 M
	REAL*8 MODUL
	INTEGER I

	M = MODUL(V)
	IF (M .NE. 0) THEN
	    DO I=1,3
	        NV(I) = V(I) / M
	    ENDDO
        ELSE
	    DO I=1,3
		NV(I) = 0
	    ENDDO
	END IF
	RETURN
	END

	REAL*8 FUNCTION ANGLE(V1,V2)
	IMPLICIT NONE
	REAL*8 V1(3)
	REAL*8 V2(3)
	REAL*8 MODUL,DOTPRD
	REAL*8 DP
	REAL*8 AB

	DP = DOTPRD(V1,V2)
	AB = MODUL(V1) * MODUL(V2)

	ANGLE = ACOS(DP / AB)
	RETURN
	END

	SUBROUTINE VECADD(A,B,R)
	IMPLICIT NONE
	REAL*8	A(3),B(3),R(3)
	INTEGER	I

	DO I=1,3
	    R(I) = A(I) + B(I)
	ENDDO
	RETURN
	END

	SUBROUTINE VECSUB(A,B,R)
	IMPLICIT NONE
	REAL*8	A(3),B(3),R(3)
	INTEGER	I

	DO I=1,3
	    R(I) = A(I) - B(I)
	ENDDO
	RETURN
	END

	SUBROUTINE VECCPY(O,D)
	IMPLICIT NONE
	REAL*8 O(3),D(3)
	INTEGER I

	DO I=1,3
	    D(I) = O(I)
	ENDDO
	RETURN
	END

	SUBROUTINE VECMUL(O,S,D)
	IMPLICIT NONE
	REAL*8 O(3),S,D(3)
	INTEGER I

	DO I=1,3
	    D(I) =S*O(I)
	ENDDO
	RETURN
	END

	SUBROUTINE VECINV(O,D)
	IMPLICIT NONE
	REAL*8 O(3),D(3)
	CALL VECMUL(O,-1.0D0,D)
	RETURN
	END


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine wfn_rho
  use global_variables
  implicit none
  integer :: ix,iy
  real(dp) :: tmp

  rho(:)=0d0

!  do ix = 0,Nx
!    tmp = 0d0
!    do iy = 0,Nx
!      tmp = tmp + wfn(ix,iy)**2
!    end do
!    rho(ix) = tmp
!  end do

  do ix = 0,Nx
    rho(ix) = sum(wfn(:,ix)**2)
  end do
  rho = rho*2d0*dx

  return
end subroutine wfn_rho
!=======10========20========30========40========50========60========70========80========90=======100
subroutine zwfn_rho
  use global_variables
  implicit none
  integer :: ix,iy
  real(dp) :: tmp

  rho(:)=0d0

!  do ix = 0,Nx
!    tmp = 0d0
!    do iy = 0,Nx
!      tmp = tmp + wfn(ix,iy)**2
!    end do
!    rho(ix) = tmp
!  end do

  do ix = 0,Nx
    rho(ix) = sum(abs(zwfn(:,ix))**2)
  end do
  rho = rho*2d0*dx

  return
end subroutine zwfn_rho


      FUNCTION hypgeo(a,b,c,z)
      COMPLEX hypgeo,a,b,c,z
      REAL EPS
      PARAMETER (EPS=1.e-6)
CU    USES bsstep,hypdrv,hypser,odeint
      INTEGER kmax,nbad,nok
      EXTERNAL bsstep,hypdrv
      COMPLEX z0,dz,aa,bb,cc,y(2)
      COMMON /hypg/ aa,bb,cc,z0,dz
      COMMON /path/ kmax
      kmax=0
      if (real(z)**2+aimag(z)**2.le.0.25) then
        call hypser(a,b,c,z,hypgeo,y(2))
        return
      else if (real(z).lt.0.) then
        z0=cmplx(-0.5,0.)
      else if (real(z).le.1.0) then
        z0=cmplx(0.5,0.)
      else
        z0=cmplx(0.,sign(0.5,aimag(z)))
      endif
      aa=a
      bb=b
      cc=c
      dz=z-z0
      call hypser(aa,bb,cc,z0,y(1),y(2))
      call odeint(y,4,0.,1.,EPS,.1,.0001,nok,nbad,hypdrv,bsstep)
      hypgeo=y(1)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/hypgeo.for


C
C     file hwscsp.f
C
      SUBROUTINE HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,
     1                   BDRS,BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDTS(N+1),     BDTF(N+1), BDRS(M+1), BDRF(M+1),
C ARGUMENTS              F(IDIMF,N+1),  W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES A FINITE DIFFERENCE APPROXIMATION
C                        TO THE MODIFIED HELMHOLTZ EQUATION IN
C                        SPHERICAL COORDINATES ASSUMING AXISYMMETRY
C                        (NO DEPENDENCE ON LONGITUDE).  THE EQUATION
C                        IS
C
C                          (1/R**2)(D/DR)((R**2)(D/DR)U) +
C
C                          (1/(R**2)SIN(THETA))(D/DTHETA)
C
C                          (SIN(THETA)(D/DTHETA)U) +
C
C                          (LAMBDA/(RSIN(THETA))**2)U = F(THETA,R).
C
C                        THIS TWO DIMENSIONAL MODIFIED HELMHOLTZ
C                        EQUATION RESULTS FROM THE FOURIER TRANSFORM
C                        OF THE THREE DIMENSIONAL POISSON EQUATION.
C
C USAGE                  CALL HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,
C                                     RS,RF,N,NBDCND,BDRS,BDRF,ELMBDA,
C                                     F,IDIMF,PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               INTL
C                          = 0  ON INITIAL ENTRY TO HWSCSP OR IF ANY
C                               OF THE ARGUMENTS RS, RF, N, NBDCND
C                               ARE CHANGED FROM A PREVIOUS CALL.
C                          = 1  IF RS, RF, N, NBDCND ARE ALL UNCHANGED
C                               FROM PREVIOUS CALL TO HWSCSP.
C
C                          NOTE:
C                          A CALL WITH INTL=0 TAKES APPROXIMATELY
C                          1.5 TIMES AS MUCH TIME AS A CALL WITH
C                          INTL = 1  .  ONCE A CALL WITH INTL = 0
C                          HAS BEEN MADE THEN SUBSEQUENT SOLUTIONS
C                          CORRESPONDING TO DIFFERENT F, BDTS, BDTF,
C                          BDRS, BDRF CAN BE OBTAINED FASTER WITH
C                          INTL = 1 SINCE INITIALIZATION IS NOT
C                          REPEATED.
C
C                        TS,TF
C                          THE RANGE OF THETA (COLATITUDE), I.E.,
C                          TS .LE. THETA .LE. TF. TS MUST BE LESS
C                          THAN TF.  TS AND TF ARE IN RADIANS. A TS OF
C                          ZERO CORRESPONDS TO THE NORTH POLE AND A
C                          TF OF PI CORRESPONDS TO THE SOUTH POLE.
C
C                          **** IMPORTANT ****
C
C                          IF TF IS EQUAL TO PI THEN IT MUST BE
C                          COMPUTED USING THE STATEMENT
C                          TF = PIMACH(DUM). THIS INSURES THAT TF
C                          IN THE USER'S PROGRAM IS EQUAL TO PI IN
C                          THIS PROGRAM WHICH PERMITS SEVERAL TESTS
C                          OF THE  INPUT PARAMETERS THAT OTHERWISE
C                          WOULD NOT BE POSSIBLE.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (TS,TF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE M+1 GRID POINTS
C                          IN THE THETA-DIRECTION GIVEN BY
C                          THETA(K) = (I-1)DTHETA+TS FOR
C                          I = 1,2,...,M+1, WHERE DTHETA = (TF-TS)/M
C                          IS THE PANEL WIDTH.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT THETA = TS AND  THETA = TF.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = TS AND THETA = TF.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = TS AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = TF
C                               (SEE NOTE 2 BELOW).
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = TS AND THETA = TF
C                               (SEE NOTES 1,2 BELOW).
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = TS (SEE NOTE 1 BELOW) AND
C                               SOLUTION IS SPECIFIED AT THETA = TF.
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TS = 0 AND THE SOLUTION IS
C                                SPECIFIED AT THETA = TF.
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TS = 0 AND THE DERIVATIVE
C                               OF THE SOLUTION WITH RESPECT TO THETA
C                               IS SPECIFIED AT THETA = TF
C                               (SEE NOTE 2 BELOW).
C                          = 7  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = TS AND THE SOLUTION IS
C                                UNSPECIFIED AT THETA = TF = PI.
C                          = 8  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = TS (SEE NOTE 1 BELOW)
C                               AND THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TF = PI.
C                          = 9  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TS = 0 AND THETA = TF = PI.
C
C                          NOTE 1:
C                          IF TS = 0, DO NOT USE MBDCND = 3,4, OR 8,
C                          BUT INSTEAD USE MBDCND = 5,6, OR 9  .
C
C                          NOTE 2:
C                          IF TF = PI, DO NOT USE MBDCND = 2,3, OR 6,
C                          BUT INSTEAD USE MBDCND = 7,8, OR 9  .
C
C                        BDTS
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO THETA AT
C                          THETA = TS.  WHEN MBDCND = 3,4, OR 8,
C
C                            BDTS(J) = (D/DTHETA)U(TS,R(J)),
C                            J = 1,2,...,N+1  .
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDTS IS
C                          A DUMMY VARIABLE.
C
C                        BDTF
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO THETA AT
C                          THETA = TF.  WHEN MBDCND = 2,3, OR 6,
C
C                          BDTF(J) = (D/DTHETA)U(TF,R(J)),
C                          J = 1,2,...,N+1  .
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDTF IS
C                          A DUMMY VARIABLE.
C
C                        RS,RF
C                          THE RANGE OF R, I.E., RS .LE. R .LT. RF.
C                          RS MUST BE LESS THAN RF.  RS MUST BE
C                          NON-NEGATIVE.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (RS,RF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE N+1 GRID POINTS IN THE
C                          R-DIRECTION GIVEN BY R(J) = (J-1)DR+RS
C                          FOR J = 1,2,...,N+1, WHERE DR = (RF-RS)/N
C                          IS THE PANEL WIDTH.
C                          N MUST BE GREATER THAN 2
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT R = RS AND R = RF.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               R = RS AND R = RF.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               R = RS AND THE DERIVATIVE
C                               OF THE SOLUTION WITH RESPECT TO R
C                               IS SPECIFIED AT R = RF.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = RS AND R = RF.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               RS AND THE SOLUTION IS SPECIFIED AT
C                               R = RF.
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = RS = 0 (SEE NOTE BELOW)  AND THE
C                               SOLUTION IS SPECIFIED AT R = RF.
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = RS = 0 (SEE NOTE BELOW) AND THE
C                               DERIVATIVE OF THE SOLUTION WITH
C                               RESPECT TO R IS SPECIFIED AT R = RF.
C
C                          NOTE:
C                          NBDCND = 5 OR 6 CANNOT BE USED WITH
C                          MBDCND = 1,2,4,5, OR 7.  THE FORMER
C                          INDICATES THAT THE SOLUTION IS UNSPECIFIED
C                          AT R = 0, THE LATTER INDICATES THAT THE
C                          SOLUTION IS SPECIFIED).
C                          USE INSTEAD   NBDCND = 1 OR 2  .
C
C                        BDRS
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO R AT R = RS.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDRS(I) = (D/DR)U(THETA(I),RS),
C                            I = 1,2,...,M+1  .
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDRS IS
C                          A DUMMY VARIABLE.
C
C                        BDRF
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1
C                          THAT SPECIFIES THE VALUES OF THE
C                          DERIVATIVE OF THE SOLUTION WITH RESPECT
C                          TO R AT R = RF.
C
C                          WHEN NBDCND = 2,3, OR 6,
C                            BDRF(I) = (D/DR)U(THETA(I),RF),
C                            I = 1,2,...,M+1  .
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDRF IS
C                          A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA .GT. 0, A SOLUTION
C                          MAY NOT EXIST.  HOWEVER, HWSCSP WILL
C                          ATTEMPT TO FIND A SOLUTION.  IF NBDCND = 5
C                          OR 6 OR  MBDCND = 5,6,7,8, OR 9, ELMBDA
C                          MUST BE ZERO.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY, OF DIMENSION AT
C                          LEAST (M+1)*(N+1), SPECIFYING VALUES OF THE
C                          RIGHT SIDE OF THE HELMHOLTZ EQUATION AND
C                          BOUNDARY VALUES (IF ANY).
C
C                          ON THE INTERIOR, F IS DEFINED AS FOLLOWS:
C                          FOR I = 2,3,...,M AND J = 2,3,...,N
C                          F(I,J) = F(THETA(I),R(J)).
C
C                          ON THE BOUNDARIES, F IS DEFINED AS FOLLOWS:
C                          FOR J=1,2,...,N+1,  I=1,2,...,M+1,
C
C                          MBDCND   F(1,J)            F(M+1,J)
C                          ------   ----------        ----------
C
C                            1      U(TS,R(J))        U(TF,R(J))
C                            2      U(TS,R(J))        F(TF,R(J))
C                            3      F(TS,R(J))        F(TF,R(J))
C                            4      F(TS,R(J))        U(TF,R(J))
C                            5      F(0,R(J))         U(TF,R(J))
C                            6      F(0,R(J))         F(TF,R(J))
C                            7      U(TS,R(J))        F(PI,R(J))
C                            8      F(TS,R(J))        F(PI,R(J))
C                            9      F(0,R(J))         F(PI,R(J))
C
C                            NBDCND   F(I,1)            F(I,N+1)
C                            ------   --------------    --------------
C
C                              1      U(THETA(I),RS)    U(THETA(I),RF)
C                              2      U(THETA(I),RS)    F(THETA(I),RF)
C                              3      F(THETA(I),RS)    F(THETA(I),RF)
C                              4      F(THETA(I),RS)    U(THETA(I),RF)
C                              5      F(TS,0)           U(THETA(I),RF)
C                              6      F(TS,0)           F(THETA(I),RF)
C
C                          NOTE:
C                          IF THE TABLE CALLS FOR BOTH THE SOLUTION
C                          U AND THE RIGHT SIDE F AT A CORNER THEN
C                          THE SOLUTION MUST BE SPECIFIED.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HWSCSP.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.  IDIMF MUST
C                          BE AT LEAST M+1  .
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          ITS LENGTH CAN BE COMPUTED FROM THE
C                          FORMULA BELOW WHICH DEPENDS ON THE VALUE
C                          OF NBDCND
C
C                          IF NBDCND=2,4 OR 6 DEFINE NUNK=N
C                          IF NBDCND=1 OR 5   DEFINE NUNK=N-1
C                          IF NBDCND=3        DEFINE NUNK=N+1
C
C                          NOW SET K=INT(LOG2(NUNK))+1 AND
C                          L=2**(K+1) THEN W MUST BE DIMENSIONED
C                          AT LEAST (K-2)*L+K+5*(M+N)+MAX(2*N,6*M)+23
C
C                          **IMPORTANT**
C                          FOR PURPOSES OF CHECKING, THE REQUIRED
C                          LENGTH OF W IS COMPUTED BY HWSCSP AND
C                          STORED IN W(1) IN FLOATING POINT FORMAT.
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (THETA(I),R(J)),  I = 1,2,...,M+1,
C                                            J = 1,2,...,N+1  .
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                          BOUNDARY CONDITIONS IS SPECIFIED FOR A
C                          POISSON EQUATION (LAMBDA = 0), A SOLUTION
C                          MAY NOT EXIST.  PERTRB IS A CONSTANT,
C                          CALCULATED AND SUBTRACTED FROM F, WHICH
C                          ENSURES THAT A SOLUTION EXISTS.  HWSCSP
C                          THEN COMPUTES THIS SOLUTION, WHICH IS A
C                          LEAST SQUARES SOLUTION TO THE ORIGINAL
C                          APPROXIMATION. THIS SOLUTION IS NOT UNIQUE
C                          AND IS UNNORMALIZED. THE VALUE OF PERTRB
C                          SHOULD BE SMALL COMPARED TO THE RIGHT SIDE
C                          F. OTHERWISE , A SOLUTION IS OBTAINED TO
C                          AN ESSENTIALLY DIFFERENT PROBLEM. THIS
C                          COMPARISON SHOULD ALWAYS BE MADE TO INSURE
C                          THAT A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBERS 0 AND 10,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          = 1  TS.LT.0. OR TF.GT.PI
C                          = 2  TS.GE.TF
C                          = 3  M.LT.5
C                          = 4  MBDCND.LT.1 OR MBDCND.GT.9
C                          = 5  RS.LT.0
C                          = 6  RS.GE.RF
C                          = 7  N.LT.5
C                          = 8  NBDCND.LT.1 OR NBDCND.GT.6
C                          = 9  ELMBDA.GT.0
C                          = 10 IDIMF.LT.M+1
C                          = 11 ELMBDA.NE.0 AND MBDCND.GE.5
C                          = 12 ELMBDA.NE.0 AND NBDCND EQUALS 5 OR 6
C                          = 13 MBDCND EQUALS 5,6 OR 9 AND TS.NE.0
C                          = 14 MBDCND.GE.7 AND TF.NE.PI
C                          = 15 TS.EQ.0 AND MBDCND EQUALS 3,4 OR 8
C                          = 16 TF.EQ.PI AND MBDCND EQUALS 2,3 OR 6
C                          = 17 NBDCND.GE.5 AND RS.NE.0
C                          = 18 NBDCND.GE.5 AND MBDCND EQUALS 1,2,4,5 OR
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSLIBY INCORRECT CALL TO HWSCSP, THE
C                          USER SHOULD TEST IERROR AFTER A CALL.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT
C                          BE DESTROYED IF HWSCSP WILL BE CALLED AGAIN
C                          WITH INTL = 1.  W(1) CONTAINS THE NUMBER
C                          OF LOCATIONS WHICH W MUST HAVE
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       BLKTRI, AND COMF FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77.
C
C ALGORITHM              THE ROUTINE DEFINES THE FINITE DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                        ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS
C                        AND THEN CALLS BLKTRI TO SOLVE THE SYSTEM.
C
C REFERENCES             SWARZTRAUBER,P. AND R. SWEET, "EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS"
C                          NCAR TN/IA-109, JULY, 1975, 138 PP.
C***********************************************************************
      DIMENSION       F(IDIMF,1) ,BDTS(*)    ,BDTF(*)    ,BDRS(*)    ,
     1                BDRF(*)    ,W(*)
C
      PI = PIMACH(DUM)
      IERROR = 0
      IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1
      IF (TS .GE. TF) IERROR = 2
      IF (M .LT. 5) IERROR = 3
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 4
      IF (RS .LT. 0.) IERROR = 5
      IF (RS .GE. RF) IERROR = 6
      IF (N .LT. 5) IERROR = 7
      IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 8
      IF (ELMBDA .GT. 0.) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 11
      IF (ELMBDA.NE.0. .AND. (NBDCND.EQ.5 .OR. NBDCND.EQ.6)) IERROR = 12
      IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND.
     1    TS.NE.0.) IERROR = 13
      IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 14
      IF (TS.EQ.0. .AND.
     1    (MBDCND.EQ.4 .OR. MBDCND.EQ.8 .OR. MBDCND.EQ.3)) IERROR = 15
      IF (TF.EQ.PI .AND.
     1    (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 16
      IF (NBDCND.GE.5 .AND. RS.NE.0.) IERROR = 17
      IF (NBDCND.GE.5 .AND. (MBDCND.EQ.1 .OR. MBDCND.EQ.2 .OR.
     1                                    MBDCND.EQ.5 .OR. MBDCND.EQ.7))
     2    IERROR = 18
      IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN
      NCK = N
      GO TO (101,103,102,103,101,103),NBDCND
  101 NCK = NCK-1
      GO TO 103
  102 NCK = NCK+1
  103 L = 2
      K = 1
  104 L = L+L
      K = K+1
      IF (NCK-L) 105,105,104
  105 L = L+L
      NP1 = N+1
      MP1 = M+1
      I1 = (K-2)*L+K+MAX0(2*N,6*M)+13
      I2 = I1+NP1
      I3 = I2+NP1
      I4 = I3+NP1
      I5 = I4+NP1
      I6 = I5+NP1
      I7 = I6+MP1
      I8 = I7+MP1
      I9 = I8+MP1
      I10 = I9+MP1
      W(1) = FLOAT(I10+M)
      CALL HWSCS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS,
     1             BDRF,ELMBDA,F,IDIMF,PERTRB,W(2),W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10))
      RETURN
      END
      SUBROUTINE HWSCS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,
     1                   BDRS,BDRF,ELMBDA,F,IDIMF,PERTRB,W,S,AN,BN,CN,
     2                   R,AM,BM,CM,SINT,BMH)
      DIMENSION       F(IDIMF,*) ,BDRS(*)    ,BDRF(*)    ,BDTS(*)    ,
     1                BDTF(*)    ,AM(*)      ,BM(*)      ,CM(*)      ,
     2                AN(*)      ,BN(*)      ,CN(*)      ,S(*)       ,
     3                R(*)       ,SINT(*)    ,BMH(*)     ,W(*)
      PI = PIMACH(DUM)
      EPS = EPMACH(DUM)
      MP1 = M+1
      DTH = (TF-TS)/FLOAT(M)
      TDT = DTH+DTH
      HDTH = DTH/2.
      SDTS = 1./(DTH*DTH)
      DO 102 I=1,MP1
         THETA = TS+FLOAT(I-1)*DTH
         SINT(I) = SIN(THETA)
         IF (SINT(I)) 101,102,101
  101    T1 = SDTS/SINT(I)
         AM(I) = T1*SIN(THETA-HDTH)
         CM(I) = T1*SIN(THETA+HDTH)
         BM(I) = -(AM(I)+CM(I))
  102 CONTINUE
      NP1 = N+1
      DR = (RF-RS)/FLOAT(N)
      HDR = DR/2.
      TDR = DR+DR
      DR2 = DR*DR
      CZR = 6.*DTH/(DR2*(COS(TS)-COS(TF)))
      DO 103 J=1,NP1
         R(J) = RS+FLOAT(J-1)*DR
         AN(J) = (R(J)-HDR)**2/DR2
         CN(J) = (R(J)+HDR)**2/DR2
         BN(J) = -(AN(J)+CN(J))
  103 CONTINUE
      MP = 1
      NP = 1
C
C BOUNDARY CONDITION AT PHI=PS
C
      GO TO (104,104,105,105,106,106,104,105,106),MBDCND
  104 AT = AM(2)
      ITS = 2
      GO TO 107
  105 AT = AM(1)
      ITS = 1
      CM(1) = CM(1)+AM(1)
      GO TO 107
  106 ITS = 1
      BM(1) = -4.*SDTS
      CM(1) = -BM(1)
C
C BOUNDARY CONDITION AT PHI=PF
C
  107 GO TO (108,109,109,108,108,109,110,110,110),MBDCND
  108 CT = CM(M)
      ITF = M
      GO TO 111
  109 CT = CM(M+1)
      AM(M+1) = AM(M+1)+CM(M+1)
      ITF = M+1
      GO TO 111
  110 ITF = M+1
      AM(M+1) = 4.*SDTS
      BM(M+1) = -AM(M+1)
  111 WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS)
      WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF)
      ITSP = ITS+1
      ITFM = ITF-1
C
C BOUNDARY CONDITION AT R=RS
C
      ICTR = 0
      GO TO (112,112,113,113,114,114),NBDCND
  112 AR = AN(2)
      JRS = 2
      GO TO 118
  113 AR = AN(1)
      JRS = 1
      CN(1) = CN(1)+AN(1)
      GO TO 118
  114 JRS = 2
      ICTR = 1
      S(N) = AN(N)/BN(N)
      DO 115 J=3,N
         L = N-J+2
         S(L) = AN(L)/(BN(L)-CN(L)*S(L+1))
  115 CONTINUE
      S(2) = -S(2)
      DO 116 J=3,N
         S(J) = -S(J)*S(J-1)
  116 CONTINUE
      WTNM = WTS+WTF
      DO 117 I=ITSP,ITFM
         WTNM = WTNM+SINT(I)
  117 CONTINUE
      YPS = CZR*WTNM*(S(2)-1.)
C
C BOUNDARY CONDITION AT R=RF
C
  118 GO TO (119,120,120,119,119,120),NBDCND
  119 CR = CN(N)
      JRF = N
      GO TO 121
  120 CR = CN(N+1)
      AN(N+1) = AN(N+1)+CN(N+1)
      JRF = N+1
  121 WRS = AN(JRS+1)*R(JRS)**2/CN(JRS)
      WRF = CN(JRF-1)*R(JRF)**2/AN(JRF)
      WRZ = AN(JRS)/CZR
      JRSP = JRS+1
      JRFM = JRF-1
      MUNK = ITF-ITS+1
      NUNK = JRF-JRS+1
      DO 122 I=ITS,ITF
         BMH(I) = BM(I)
  122 CONTINUE
      ISING = 0
      GO TO (132,132,123,132,132,123),NBDCND
  123 GO TO (132,132,124,132,132,124,132,124,124),MBDCND
  124 IF (ELMBDA) 132,125,125
  125 ISING = 1
      SUM = WTS*WRS+WTS*WRF+WTF*WRS+WTF*WRF
      IF (ICTR) 126,127,126
  126 SUM = SUM+WRZ
  127 DO 129 J=JRSP,JRFM
         R2 = R(J)**2
         DO 128 I=ITSP,ITFM
            SUM = SUM+R2*SINT(I)
  128    CONTINUE
  129 CONTINUE
      DO 130 J=JRSP,JRFM
         SUM = SUM+(WTS+WTF)*R(J)**2
  130 CONTINUE
      DO 131 I=ITSP,ITFM
         SUM = SUM+(WRS+WRF)*SINT(I)
  131 CONTINUE
      HNE = SUM
  132 GO TO (133,133,133,133,134,134,133,133,134),MBDCND
  133 BM(ITS) = BMH(ITS)+ELMBDA/SINT(ITS)**2
  134 GO TO (135,135,135,135,135,135,136,136,136),MBDCND
  135 BM(ITF) = BMH(ITF)+ELMBDA/SINT(ITF)**2
  136 DO 137 I=ITSP,ITFM
         BM(I) = BMH(I)+ELMBDA/SINT(I)**2
  137 CONTINUE
      GO TO (138,138,140,140,142,142,138,140,142),MBDCND
  138 DO 139 J=JRS,JRF
         F(2,J) = F(2,J)-AT*F(1,J)/R(J)**2
  139 CONTINUE
      GO TO 142
  140 DO 141 J=JRS,JRF
         F(1,J) = F(1,J)+TDT*BDTS(J)*AT/R(J)**2
  141 CONTINUE
  142 GO TO (143,145,145,143,143,145,147,147,147),MBDCND
  143 DO 144 J=JRS,JRF
         F(M,J) = F(M,J)-CT*F(M+1,J)/R(J)**2
  144 CONTINUE
      GO TO 147
  145 DO 146 J=JRS,JRF
         F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT/R(J)**2
  146 CONTINUE
  147 GO TO (151,151,153,153,148,148),NBDCND
  148 IF (MBDCND-3) 155,149,155
  149 YHLD = F(ITS,1)-CZR/TDT*(SIN(TF)*BDTF(2)-SIN(TS)*BDTS(2))
      DO 150 I=1,MP1
         F(I,1) = YHLD
  150 CONTINUE
      GO TO 155
  151 RS2 = (RS+DR)**2
      DO 152 I=ITS,ITF
         F(I,2) = F(I,2)-AR*F(I,1)/RS2
  152 CONTINUE
      GO TO 155
  153 DO 154 I=ITS,ITF
         F(I,1) = F(I,1)+TDR*BDRS(I)*AR/RS**2
  154 CONTINUE
  155 GO TO (156,158,158,156,156,158),NBDCND
  156 RF2 = (RF-DR)**2
      DO 157 I=ITS,ITF
         F(I,N) = F(I,N)-CR*F(I,N+1)/RF2
  157 CONTINUE
      GO TO 160
  158 DO 159 I=ITS,ITF
         F(I,N+1) = F(I,N+1)-TDR*BDRF(I)*CR/RF**2
  159 CONTINUE
  160 CONTINUE
      PERTRB = 0.
      IF (ISING) 161,170,161
  161 SUM = WTS*WRS*F(ITS,JRS)+WTS*WRF*F(ITS,JRF)+WTF*WRS*F(ITF,JRS)+
     1      WTF*WRF*F(ITF,JRF)
      IF (ICTR) 162,163,162
  162 SUM = SUM+WRZ*F(ITS,1)
  163 DO 165 J=JRSP,JRFM
         R2 = R(J)**2
         DO 164 I=ITSP,ITFM
            SUM = SUM+R2*SINT(I)*F(I,J)
  164    CONTINUE
  165 CONTINUE
      DO 166 J=JRSP,JRFM
         SUM = SUM+R(J)**2*(WTS*F(ITS,J)+WTF*F(ITF,J))
  166 CONTINUE
      DO 167 I=ITSP,ITFM
         SUM = SUM+SINT(I)*(WRS*F(I,JRS)+WRF*F(I,JRF))
  167 CONTINUE
      PERTRB = SUM/HNE
      DO 169 J=1,NP1
         DO 168 I=1,MP1
            F(I,J) = F(I,J)-PERTRB
  168    CONTINUE
  169 CONTINUE
  170 DO 172 J=JRS,JRF
         RSQ = R(J)**2
         DO 171 I=ITS,ITF
            F(I,J) = RSQ*F(I,J)
  171    CONTINUE
  172 CONTINUE
      IFLG = INTL
  173 CALL BLKTRI (IFLG,NP,NUNK,AN(JRS),BN(JRS),CN(JRS),MP,MUNK,
     1             AM(ITS),BM(ITS),CM(ITS),IDIMF,F(ITS,JRS),IERROR,W)
      IFLG = IFLG+1
      IF (IFLG-1) 174,173,174
  174 IF (NBDCND) 177,175,177
  175 DO 176 I=1,MP1
         F(I,JRF+1) = F(I,JRS)
  176 CONTINUE
  177 IF (MBDCND) 180,178,180
  178 DO 179 J=1,NP1
         F(ITF+1,J) = F(ITS,J)
  179 CONTINUE
  180 XP = 0.
      IF (ICTR) 181,188,181
  181 IF (ISING) 186,182,186
  182 SUM = WTS*F(ITS,2)+WTF*F(ITF,2)
      DO 183 I=ITSP,ITFM
         SUM = SUM+SINT(I)*F(I,2)
  183 CONTINUE
      YPH = CZR*SUM
      XP = (F(ITS,1)-YPH)/YPS
      DO 185 J=JRS,JRF
         XPS = XP*S(J)
         DO 184 I=ITS,ITF
            F(I,J) = F(I,J)+XPS
  184    CONTINUE
  185 CONTINUE
  186 DO 187 I=1,MP1
         F(I,1) = XP
  187 CONTINUE
  188 RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


C GARESOL.F - Gateway function for solving descriptor algebraic Riccati
C             equations using SLICOT routine SG02AD.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2003-2020 NICONET e.V.
C
C Matlab call:
C       [X,F,ev,db,rcond1] = garesol(A,E,Q,R,B,L,flag)
C         [X,ev,db,rcond1] = garesol(A,E,Q,R,B,L,flag)
C         [X,ev,db,rcond1] = garesol(A,E,Q,G,flag)
C   [Z,scale,ev,db,rcond1] = garesol(A,E,Q,R,B,L,flag)
C   [Z,scale,ev,db,rcond1] = garesol(A,E,Q,G,flag)
C
C Purpose:
C   To solve the continuous-time algebraic Riccati equations
C                                              -1
C      0 = Q + A'*X*E + E'*X*A - (L + E'*X*B)*R  *(L + E'*X*B)' ,  (1a)
C
C   or the discrete-time algebraic Riccati equations
C                                                 -1
C      E'*X*E = A'*X*A - (L + A'*X*B)*(R + B'*X*B)  (L + A'*X*B)' + Q;
C                                                                  (1b)
C   or, in alternate forms,
C
C                 -1
C      0 = Q - L*R  *L' + A1'*X*E + E'*X*A1 - E'*X*G*X*E,          (2a)
C
C   or
C                      -1                     -1
C      E'*X*E = Q - L*R  *L' + A1'*X*(I + G*X)  *A1,               (2b)
C
C                -1                 -1
C   where G = B*R  *B', A1 = A - B*R  *L'. The optimal feedback gain
C   matrix is
C
C           -1
C      F = R  (L+E'XB)' ,        for (1a),
C
C     and
C                  -1
C      F = (R+B'XB)  (L+A'XB)' , for (2a).
C
C   The function can also be used to compute an orthogonal basis of the
C   subspace which generates the solution.
C
C   The generalized Schur method is used on the extended pencils
C
C             [ A   0   B ]      [ E   0   0 ]
C           a [ Q   A'  L ] -  b [ 0  -E'  0 ] ,                   (3a)
C             [ L'  B'  R ]      [ 0   0   0 ]
C   or
C
C             [ A   0   B ]      [ E   0   0 ]
C           a [ Q  -E'  L ] -  b [ 0  -A'  0 ] ,                   (3b)
C             [ L'  0   R ]      [ 0  -B'  0 ]
C
C   to solve the equations (1a) or (1b).
C
C Input parameters:
C   A      - real N-by-N system state matrix.
C   E      - real N-by-N descriptor system matrix.
C   Q      - normally, real symmetric N-by-N state weighting matrix.
C            If flag(5) <> 0, array Q stores the P-by-N factor C of Q,
C            Q = C'*C.
C   R      - normally, real symmetric M-by-M input weighting matrix.
C            If R is an input parameter and flag(6) <> 0, array R stores
C            the P-by-M factor D of R, R = D'*D.
C   B      - real N-by-M input matrix.
C   L      - real N-by-M coupling matrix.
C   G      - real symmetric N-by-N matrix.
C   flag   - (optional) vector of length 10 containing options:
C               flag(1)  = 0 : solve the continuous-time equation (1a);
C                              otherwise, solve the discrete-time
C                              equation (1b).
C               flag(2)  = 0 : compute the stabilizing solution;
C                              otherwise, compute the anti-stabilizing
C                              solution.
C               flag(3)  = 0 : compute both the solution X and the
C                              feedback gain matrix F;
C                        > 0 : compute the solution only;
C                        < 0 : compute the related subspace.
C               flag(4)      : tolerance to check the singularity of
C                              the matrix pencil. If tol <= 0, tol will
C                              be replaced by EPS, the machine epsilon.
C               flag(5)  = 0 : matrix Q is not factored; otherwise Q is
C                              assumed factored as Q = C'*C, where C is
C                              P-by-N.
C               flag(6)  = 0 : matrix R is not factored; otherwise R is
C                              assumed factored as R = D'*D, where D is
C                              P-by-M.
C               flag(7)  = 0 : the upper triangles of matrices Q and G,
C                              or Q and R, are stored; otherwise, lower
C                              triangles are stored.
C               flag(8)  = 0 : matrix L is zero; otherwise, L is given.
C               flag(9)  = 0 : use a scaling strategy (for given R, B);
C                              otherwise, do not use a scaling strategy.
C               flag(10) = 0 : iterative refinement should not be used
C                              for solving the system of algebraic
C                              equations giving the solution matrix X;
C                              otherwise, use iterative refinement.
C            Default:    flag(1:4) = [0,0,1,0,0,0,0,1,0,0].
C
C Output parameters:
C   X      - N-by-N real symmetric solution of Riccati equations (1)
C            or (2).
C   F      - M-by-N real state feedback matrix, returned only when R
C            and B are input arguments, the number of output parameters
C            is at least 2, and X is computed.
C   Z      - 2N-by-N real matrix with orthonormal columns, the basis of
C            the subspace related to the solution X.
C   scale  - the scaling factor used internally, which should multiply
C            the submatrix Z(N+1:2N,:) to recover X from Z.
C   ev     - complex vector of length N.
C            the "a" part of the associated eigenvalues in (3).
C   db     - real vector of length N containing the "b" part of
C            the associated eigenvalues in (3), i.e., the associated
C            eigenvalues with respect to X are ev(k)/db(k), k=1,...,N.
C   rcond1 - estimate of the reciprocal of the 1-norm condition number
C            of the N-th order system of algebraic equations from which
C            the solution matrix X is obtained.
C
C Contributor:
C   V. Sima, Katholieke Univ. Leuven, Belgium, March 2003.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, Jan. 2005,
C   Apr. 2009, Dec. 2012, Dec. 2014, Jan. 2015, Apr. 2017.
C
C **********************************************************************
C
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         ACC, DICO, FACT, FACTR, JOBB, JOBL, SCAL, SORT,
     $                  UPLO
      INTEGER           INFO, IWARN, LDA, LDB, LDE, LDF, LDL, LDQ, LDR,
     $                  LDS, LDT, LDU, LDWORK, LDX, M, N, P
      DOUBLE PRECISION  RCOND1, RNORM, TOL
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      LOGICAL,          ALLOCATABLE :: BWORK(:)
      INTEGER,          ALLOCATABLE :: IPIV(:), IWORK(:)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:), B(:,:), BETA(:),
     $                                 DWORK(:), E(:,:), F(:,:), L(:,:),
     $                                 Q(:,:), R(:,:), S(:,:), T(:,:),
     $                                 U(:,:), WI(:), WR(:), X(:,:)
      COMPLEX*16,       ALLOCATABLE :: EV(:)
C
C .. Local variables and constant dimension arrays ..
      LOGICAL           WITHF, WITHL, WITHR
      CHARACTER*120     TEXT
      INTEGER           FLAG(10), FLAGF, I, IP, ISIZE, LIWORK, LOUT(2),
     $                  NCB, NN, NO, NP
      DOUBLE PRECISION  FLAGR(10), SCALE
C
C     .. External Functions ..
      LOGICAL           LSAME, MA02HD
      EXTERNAL          LSAME, MA02HD
C
C .. External subroutines ..
      EXTERNAL          SB02ND, SG02AD, SG02ND
C
C ..Intrinsic functions..
      INTRINSIC         DCMPLX, MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'GARESOL requires at least 4 input arguments' )
      ELSE IF ( NLHS.GT.5 ) THEN
         CALL mexErrMsgTxt
     $        ( 'GARESOL requires at most 5 output arguments' )
      END IF
C
C   A(NxN), E(NxN), Q(NxN), (R(MxM), B(NxM), L(NxM),) (G(NxN))
C
      N  = mxGetM( PRHS(1) )
      P  = mxGetM( PRHS(3) )
      NP = mxGetM( PRHS(4) )
      M  = mxGetN( PRHS(4) )
C
      IF ( mxGetN( PRHS(1) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'A must be a square matrix' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
C
      IF ( mxGetM( PRHS(2) ).NE.N .OR. mxGetN( PRHS(2) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'E must have the same dimension as A' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'E must be a real matrix' )
      END IF
C
      IF ( mxGetN( PRHS(3) ).NE.N ) THEN
         CALL mexErrMsgTxt
     $           ( 'Q must have the same column dimension as A' )
      END IF
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'Q must be a real matrix' )
      END IF
C
      IF ( NRHS.GE.6 ) THEN
         JOBB  = 'B'
         WITHR = .TRUE.
         IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(4) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'R must be a real matrix' )
         END IF
C
         IF ( mxGetM( PRHS(5) ).NE.N ) THEN
            CALL mexErrMsgTxt
     $           ( 'B must have the same row dimension as A' )
         END IF
         IF ( mxGetN( PRHS(5) ).NE.M ) THEN
            CALL mexErrMsgTxt
     $           ( 'B must have the same column dimension as R' )
         END IF
         IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(5) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'B must be a real matrix' )
         END IF
C
         IF ( mxGetM( PRHS(6) ).NE.N ) THEN
            CALL mexErrMsgTxt
     $           ( 'L must have the same row dimension as A' )
         END IF
         IF ( mxGetN( PRHS(6) ).NE.M ) THEN
            CALL mexErrMsgTxt
     $           ( 'L must have the same column dimension as R' )
         END IF
         IF ( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(6) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'L must be a real matrix' )
         END IF
C
         IP = 7
      ELSE
         JOBB  = 'G'
         WITHR = .FALSE.
         IF ( NP.NE.N .OR. M.NE.N ) THEN
            CALL mexErrMsgTxt
     $           ( 'G must have the same dimension as A' )
         END IF
         IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(4) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'G must be a real matrix' )
         END IF
         IP = 5
      END IF
C
      DO 10 I = 1, 10
         FLAG(I) = 0
   10 CONTINUE
C
      FLAG(3) = 1
      FLAG(8) = 1
C
      IF ( NRHS.GE.IP ) THEN
C
C   flag
C
         ISIZE = mxGetM( PRHS(IP) ) * mxGetN( PRHS(IP) )
         IF ( ISIZE.GT.10 )
     $      CALL mexErrMsgTxt
     $           ( 'FLAG must be a vector with at most 10 elements' )
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'FLAG must be a real vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), FLAGR, ISIZE )
C
         DO 20 I = 1, ISIZE
            FLAG(I) = FLAGR(I)
   20    CONTINUE
C
      END IF
C
      IF ( FLAG(1).EQ.0 ) THEN
         DICO = 'C'
      ELSE
         DICO = 'D'
      END IF
C
      IF ( FLAG(2).EQ.0 ) THEN
         SORT = 'S'
      ELSE
         SORT = 'U'
      END IF
      FLAGF = FLAG(3)
      WITHF = FLAGF.EQ.0 .AND. WITHR .AND. NLHS.GE.2
      TOL   = FLAGR(4)
C
      IF ( FLAG(5).EQ.0 .AND. P.NE.N )
     $   CALL mexErrMsgTxt( 'Q must have the same size as A' )
      IF ( WITHR ) THEN
         IF ( FLAG(6).EQ.0 ) THEN
            FACTR = 'N'
            IF ( NP.NE.M )
     $         CALL mexErrMsgTxt( 'R must be a square matrix' )
         ELSE
            FACTR = 'D'
            IF ( FLAG(5).NE.0 .AND. NP.NE.P ) THEN
               CALL mexErrMsgTxt
     $            ( 'D must must have the same row dimension as C' )
            END IF
         END IF
      ELSE
         FLAG(6) = 0
         FLAG(8) = 0
      END IF
C
      IF ( FLAG(5).EQ.0 ) THEN
         IF ( FLAG(6).EQ.0 ) THEN
            FACT = 'N'
         ELSE
            FACT = 'D'
         END IF
      ELSE
         IF ( FLAG(6).EQ.0 ) THEN
            FACT = 'C'
         ELSE
            FACT = 'B'
         END IF
      END IF
C
      IF ( FLAG(7).EQ.0 ) THEN
         UPLO = 'U'
      ELSE
         UPLO = 'L'
      END IF
C
      IF ( FLAG(8).EQ.0 ) THEN
         JOBL = 'Z'
         WITHL = .FALSE.
      ELSE
         JOBL = 'N'
         WITHL = .TRUE.
      END IF
C
      IF ( FLAG(9).EQ.0 .AND. WITHR ) THEN
         SCAL = 'G'
      ELSE
         SCAL = 'N'
      END IF
C
      IF ( FLAG(10).EQ.0 ) THEN
         ACC = 'N'
      ELSE
         ACC = 'R'
      END IF
C
C Determine the lenghts of working arrays.
C Use a larger value for LDWORK for enabling calls of block algorithms
C in DGEES or DGGES, and also in DGEQRF/DGEQLF (M*NB), DGETRI (N*NB),
C DSYTRF (M*NB), DORMQL (2*N*NB).
C
      NN  = 2*N
      LDA = MAX( 1, N )
      LDE = LDA
      LDB = LDA
      LDU = MAX( 1, NN )
      LDL = 1
C
      LDWORK = MAX( 7*(2*N + 1) + 16, 16*N )
      IF ( WITHR ) THEN
         NCB    = M
         LDS    = MAX( 1, NN + M )
         LIWORK = MAX( 1, M, NN )
         LDWORK = MAX( LDWORK, 2*N + M, 3*M )
         IF ( WITHL )
     $      LDL = LDA
      ELSE
         NCB    = N
         LDS    = LDU
         LIWORK = LDU
      END IF
      LDQ = MAX( 1, P )
      LDR = MAX( 1, NP )
      LDT = LDS
      LDX = LDA
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE( A(LDA,N), E(LDE,N), B(LDB,NCB), Q(LDQ,N), U(LDU,NN),
     $          EV(N), WR(NN), WI(NN), IWORK(LIWORK), DWORK(LDWORK),
     $          BWORK(NN), T(LDT,NN), BETA(NN), S(LDS,LDS), X(LDX,N) )
      IF ( WITHR ) THEN
         ALLOCATE( R(LDR,M) )
         IF ( WITHL )
     $      ALLOCATE( L(LDL,M) )
         IF ( WITHF ) THEN
            LDF = LDR
            ALLOCATE( F(LDF,N), IPIV(M) )
         END IF
      END IF
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), E, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), Q, P*N )
C
      IF ( WITHR ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), R, NP*M )
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), B, N*M )
         IF ( WITHL )
     $      CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), L, N*M )
C
      ELSE
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), B, N*N )
      END IF
C
C Do the actual computations.
C
      CALL SG02AD( DICO, JOBB, FACT, UPLO, JOBL, SCAL, SORT, ACC, N,
     $             M, P, A, LDA, E, LDE, B, LDB, Q, LDQ, R, LDR, L, LDL,
     $             RCOND1, X, LDX, WR, WI, BETA, S, LDS, T, LDT, U, LDU,
     $             TOL, IWORK, DWORK, LDWORK, BWORK, IWARN, INFO )
C
      IF ( INFO.NE.0 ) THEN
         WRITE( TEXT, '('' INFO = '', I4, '' ON EXIT FROM SG02AD'')' )
     $          INFO
         GO TO 40
      END IF
C
      SCALE = DWORK(4)
      IF ( WITHF ) THEN
         IF ( FLAG(1).EQ.0 ) THEN
            IF ( N.EQ.0 .OR. MA02HD( 'Full', N, N, ONE, E, LDE ) ) THEN
               CALL SB02ND( DICO, FACTR, UPLO, JOBL, N, M, P, A, LDA, B,
     $                      LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F,
     $                      LDF, LOUT, IWORK, DWORK, LDWORK, INFO )
            ELSE
               CALL SG02ND( DICO, 'GenE', 'Kalman', 'No XE', FACTR,
     $                      UPLO, JOBL, 'NoTrans', N, M, P, A, LDA, E,
     $                      LDE, B, LDB, R, LDR, IPIV, L, LDL, X, LDX,
     $                      RNORM, F, LDF, A, 1, A, 1, LOUT, IWORK,
     $                      DWORK, LDWORK, INFO )
            END IF
         ELSE
            CALL SB02ND( DICO, FACTR, UPLO, JOBL, N, M, P, A, LDA, B,
     $                   LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F,
     $                   LDF, LOUT, IWORK, DWORK, LDWORK, INFO )
         END IF
C
         IF ( INFO.NE.0 ) THEN
            WRITE( TEXT, '('' INFO = '', I4, '' ON EXIT FROM SB02ND'')')
     $             INFO
            GO TO 40
         END IF
      END IF
C
C Copy output to MATLAB workspace.
C
      IF ( INFO.EQ.0 ) THEN
         IF ( FLAGF.GE.0 ) THEN
            PLHS(1) = mxCreateDoubleMatrix( N, N, 0 )
            CALL mxCopyReal8ToPtr( X, mxGetPr( PLHS(1) ), N*N )
            NO = 2
            IF ( WITHF ) THEN
               PLHS(2) = mxCreateDoubleMatrix( M, N, 0 )
               CALL mxCopyReal8ToPtr( F, mxGetPr( PLHS(2) ), M*N )
               NO = NO + 1
            END IF
         ELSE
            PLHS(1) = mxCreateDoubleMatrix( NN, N, 0 )
            CALL mxCopyReal8ToPtr( U, mxGetPr( PLHS(1) ), NN*N )
            PLHS(2) = mxCreateDoubleMatrix( 1, 1, 0 )
            CALL mxCopyReal8ToPtr( SCALE, mxGetPr( PLHS(2) ), 1 )
            NO = 3
         END IF
C
         IF ( NLHS.GE.NO ) THEN
C
            DO 30 I = 1, N
               EV(I) = DCMPLX( WR(I), WI(I) )
   30       CONTINUE
C
            NP = MIN( 1, N )
            PLHS(NO) = mxCreateDoubleMatrix( N, NP, 1 )
            CALL mxCopyComplex16ToPtr( EV, mxGetPr( PLHS(NO) ),
     $                                 mxGetPi( PLHS(NO) ), N*NP )
            NO = NO + 1
            PLHS(NO) = mxCreateDoubleMatrix( N, NP, 0 )
            CALL mxCopyReal8ToPtr( BETA, mxGetPr( PLHS(NO) ), N*NP )
         END IF
C
         NO = NO + 1
         IF ( NLHS.GE.NO ) THEN
            PLHS(NO) = mxCreateDoubleMatrix( 1, 1, 0 )
            CALL mxCopyReal8ToPtr( RCOND1, mxGetPr( PLHS(NO) ), 1 )
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
   40 CONTINUE
C
      DEALLOCATE( A, E, B, Q, S, U, EV, WR, WI, IWORK, DWORK, BWORK,
     $            T, X, BETA )
      IF ( WITHR ) THEN
         DEALLOCATE( R )
         IF ( WITHL )
     $      DEALLOCATE( L )
         IF ( WITHF )
     $      DEALLOCATE( F, IPIV )
      END IF
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         CALL mexErrMsgTxt( TEXT )
      ELSE IF ( IWARN.NE.0 ) THEN
         WRITE( TEXT, '(''  IWARN = '',I4,'' ON EXIT FROM SG02AD'')'
     $        ) IWARN
         CALL mexPrintf( TEXT )
      END IF
C
      RETURN
C
C *** Last line of GARESOL ***
      END


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

subroutine fitgauss(s,yag,y,w,nlocal,yfit)

!  (1) Fit local asymmetric Gaussian functions                                  !
!                                                                               !
!          /                                                                    !
!         |  c(1) + c(2)*exp(-((x(1)-t)/x(2)).^x(3)),    t <= x(1)              !
!  y(t) = |                                                                     !
!         |  c(1) + c(2)*exp(-((t-x(1))/x(4)).^x(5)),    t >  x(1)              !
!          \                                                                    !
!                                                                               !
!  in an iterative proceedure to approach the upper/lower envelope of           !
!  the data values. The linear, c(1) and c(2), and non-linear x(1),...,x(5)     !
!  parameters are determined using Marquard's method. Note that we separate     !
!  the two parameter sets in order to improve performance. The non-linear       !
!  parameters are box constrained bl(i) <= x(i) <= bu(i) to ensure that we      !
!  find a phenologically sound solution.                                        !
!                                                                               !
!  (2) Merge the local functions to a global function                           !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Improved estimates of starting parameters                                    !
!                                                                               !
!  Updated September 2006                                                       !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,k,l,nyear,nptperyear,npt,nenvi,printflag,debugflag,win(3)
integer :: m0,m1,m2,n,n1,n2,nmid,nlocal,s(4*nyear+2),term,nseason,kmin,lmin
integer :: sumnonconstant
double precision :: wfact,y(npt),w(npt),yfit(npt),wfit(npt),ylocal(nlocal,npt)
double precision :: width,x(5),xn(5),ones(npt),t(npt),cut,ndiff,mid
double precision :: exparg(npt),arg(npt),ytilde(npt),Btilde(npt,2),c(2),bl(5),bu(5)
double precision :: yag(2*nptperyear,7,2),fact(7),chi2,chi2min,ymed

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

yfit = y
wfit = w
ylocal = 0.d0
ones = 1.d0

!---- Initiate matrix that will contain the local functions ---------------------

ylocal = 0.d0

!---- Define widths for one and two seasons respectively ------------------------

if (nlocal/nyear == 2) then
  width = nptperyear/4.d0
  nseason = 1
else
  width = nptperyear/8.d0
  nseason = 2;
end if

fact = (/ 0.2d0, 0.4d0, 0.7d0, 1.d0, 1.3d0, 1.7d0, 2.1d0 /)

!---- Iterative fits to local asymmetric Gaussians in all intervalls ------------

do j = 1,nenvi
  do i = 1,nlocal

!---- Fitting intervall given by [m0,m2] ----------------------------------------

    m0 = s(i)
    m1 = s(i+1)
    m2 = s(i+2)
	n = m2 - m0 + 1

!---- Check if the are enought non constant data values in the intervall ---------

    sumnonconstant = 0
	do k = m0,m2-1
	  if (abs(y(k) - y(k+1)) < 1.d-6) then
	    sumnonconstant = sumnonconstant + 1
	  end if
	end do

	if ((sumnonconstant < 3.d0*(m2-m0+1)/4.d0) .and. (count(w(m0:m2) == 0.d0) < 3.d0*(m2-m0+1)/4.d0)) then

!---- Initial estimates of fitting parameters -----------------------------------
!     Loop over width and position in time

      chi2min = 1.d60

	  do k = 1,7
	    do l = 1,5
	      x(1) = floor(m1 - m0 + dble(l-3)*width/3.d0)
		  if ( (1.d0 <= x(1)) .and. (x(1) <= dble(n-1)) ) then
		    nmid = x(1)
		    x(1) = x(1) + 0.5d0
		    exparg(1:n) = yag(nptperyear-nmid+1:nptperyear+n-nmid,k,nseason)
            ytilde(1:n) = wfit(m0:m2)*y(m0:m2)
            Btilde(1:n,1:2) = reshape(source = (/ wfit(m0:m2), wfit(m0:m2)*exparg(1:n) /), &
	                           shape = (/ n,2 /))
	        call gauss(2,matmul(transpose(Btilde(1:n,1:2)),Btilde(1:n,1:2)), &
	             matmul(ytilde(1:n),Btilde(1:n,1:2)),c)

!---- Evaluate the fitted function and compute chi-square ----------------------

            ylocal(i,m0:m2) = c(1) + c(2)*exparg(1:n)
		    chi2 = sum((wfit(m0:m2)*(ylocal(i,m0:m2)-y(m0:m2)))**2.d0)
		    if (chi2 < chi2min) then
		      chi2min = chi2
			  kmin = k
			  lmin = l
	        end if

		  end if
	    end do
	  end do

!---- Best starting values ------------------------------------------------------

      x(1) = floor(m1 - m0 + (lmin-3.d0)*width/3.d0) + 0.5d0
      x(2) = width*fact(kmin)/(log(2.d0)**0.25d0)
      x(4) = x(2)
      x(3) = 3.d0
      x(5) = 3.d0

!---- Set constraints -----------------------------------------------------------

      bl = (/ 1.d0+0.01d0, 0.6d0*x(2), 2.d0, 0.6d0*x(4), 2.d0 /)
      bu = (/ n-0.01d0,    1.4d0*x(2), 8.d0, 1.4d0*x(4), 8.d0 /)

!---- Separable box constrained non-linear least squares fit --------------------

!     write(*,*) 'Gauss,x,chi2min',x,chi2min
	  call marquardt(1,term,x,xn,bl,bu,5,y(m0:m2),wfit(m0:m2),n)
!	  write(*,*) 'xn',xn
!	  pause
	  nmid = floor(xn(1))

!---- Final linear fit to determine c(1) and c(2) -------------------------------

      t = dble((/(i,i=1,npt)/))
! write(*,*) nmid+1, n
! changed for compiling in gfortran
if(nmid .LE. n) then
      arg(1:n) = (/ ((xn(1)-t(1:nmid))/xn(2))**xn(3), &
	              ((t(nmid+1:n)-xn(1))/xn(4))**xn(5) /)
else
      arg(1:n) = ((xn(1)-t(1:nmid))/xn(2))**xn(3)
end if
      exparg(1:n) = exp(-arg(1:n))
      ytilde(1:n) = wfit(m0:m2)*y(m0:m2)
      Btilde(1:n,1:2) = reshape(source = (/ wfit(m0:m2), wfit(m0:m2)*exparg(1:n) /), &
	                           shape = (/ n,2 /))
	  call gauss(2,matmul(transpose(Btilde(1:n,1:2)),Btilde(1:n,1:2)), &
	           matmul(ytilde(1:n),Btilde(1:n,1:2)),c)

!---- Evaluate the fitted function ----------------------------------------------

      ylocal(i,m0:m2) = c(1) + c(2)*exparg(1:n)

    else

!---- If many constant values in interval replace with median value -------------

	  call median(y(m0:m2),m2-m0+1,ymed)
	  ylocal(i,m0:m2) = ymed

	end if

  end do ! end loop over local functions

!---- Merge local functions to a global function --------------------------------

  do i = 2,nlocal
    n1 = s(i)
    n2 = s(i+1)
	ndiff = dble(n2 - n1)
    mid = (n1 + n2)/2.d0
    do k = n1,n2
      cut = (atan(10.d0*(k-mid)/ndiff) - atan(10.d0*(n1-mid)/ndiff))/ &
            (atan(10.d0*(n2-mid)/ndiff) - atan(10.d0*(n1-mid)/ndiff))
      yfit(k) = cut*ylocal(i,k) + (1.d0-cut)*ylocal(i-1,k)
    end do
  end do

!---- Add points in the beginning and at the end -------------------------------

  yfit(s(1):s(2)) = ylocal(1,s(1):s(2))
  yfit(s(nlocal+1):s(nlocal+2)) = ylocal(nlocal,s(nlocal+1):s(nlocal+2))

!---- Modify weights --------------------

  if (j < nenvi) then
    call modweight(j,npt,wfit,y,yfit)
  end if

end do ! end loop over envelope iterations

!---- Output for debug purposes ------------------------------------------------

! write(*,*) 2,sum(yfit)

end subroutine fitgauss


      program sndrv2
c
c     Simple program to illustrate the idea of reverse communication
c     in shift-invert mode for a standard nonsymmetric eigenvalue problem.
c
c     We implement example two of ex-nonsym.doc in DOCUMENTS directory
c
c\Example-2
c     ... Suppose we want to solve A*x = lambda*x in shift-invert mode,
c         where A is derived from the centered difference discretization
c         of the 1-dimensional convection-diffusion operator
c                          (d^2u / dx^2) + rho*(du/dx)
c         on the interval [0,1] with zero Dirichlet boundary condition.
c
c     ... The shift sigma is a real number.
c
c     ... OP = inv[A-sigma*I] and  B = I.
c
c     ... Use mode 3 of SNAUPD.
c
c\BeginLib
c
c\Routines called:
c     snaupd  ARPACK reverse communication interface routine.
c     sneupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     sgttrf  LAPACK tridiagonal factorization routine.
c     sgttrs  LAPACK tridiagonal solve routine.
c     slapy2  LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     saxpy   Level 1 BLAS that computes y <- alpha*x+y.
c     scopy   Level 1 BLAS that copies one vector to another.
c     sdot    Level 1 BLAS that computes the dot product of two vectors.
c     snrm2   Level 1 BLAS that computes the norm of a vector.
c     av      Matrix vector multiplication routine that computes A*x.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: ndrv2.F   SID: 2.4   DATE OF SID: 4/22/96   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c--------------------------------------------------------------------------
c
c     %-----------------------------%
c     | Define leading dimensions   |
c     | for all arrays.             |
c     | MAXN:   Maximum dimension   |
c     |         of the A allowed.   |
c     | MAXNEV: Maximum NEV allowed |
c     | MAXNCV: Maximum NCV allowed |
c     %-----------------------------%
c
      integer           maxn, maxnev, maxncv, ldv
      parameter         (maxn=256, maxnev=10, maxncv=25,
     &                   ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer           iparam(11), ipntr(14), ipiv(maxn)
      logical           select(maxncv)
      Real
     &                  ax(maxn), d(maxncv,3), resid(maxn),
     &                  v(ldv, maxncv), workd(3*maxn),
     &                  workev(3*maxncv),
     &                  workl(3*maxncv*maxncv+6*maxncv),
     &                  dd(maxn), dl(maxn), du(maxn),
     &                  du2(maxn)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character         bmat*1, which*2
      integer           ido, n, nev, ncv, lworkl, info, j,
     &                  ierr, nconv, maxitr, ishfts, mode
      Real
     &                  tol, h, s,
     &                  sigmar, sigmai, s1, s2, s3
      logical           first, rvec
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &                   one, zero, two, rho
      common            /convct/ rho
      parameter         (one = 1.0E+0, zero = 0.0E+0,
     &                   two = 2.0E+0)
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
c
      Real
     &                  sdot, snrm2, slapy2
      external          sgttrf, sgttrs, sdot, snrm2, slapy2
c
c     %--------------------%
c     | Intrinsic function |
c     %--------------------%
c
      intrinsic         abs
c
c     %-----------------------%
c     | Executable statements |
c     %-----------------------%
c
c     %--------------------------------------------------%
c     | The number N is the dimension of the matrix.  A  |
c     | standard eigenvalue problem is solved (BMAT =    |
c     | 'I').  NEV is the number of eigenvalues (closest |
c     | to the shift SIGMAR) to be approximated.  Since  |
c     | the shift-invert mode is used, WHICH is set to   |
c     | 'LM'.  The user can modify NEV, NCV, SIGMAR to   |
c     | solve problems of different sizes, and to get    |
c     | different parts of the spectrum.  However, The   |
c     | following conditions must be satisfied:          |
c     |                 N <= MAXN,                       |
c     |               NEV <= MAXNEV,                     |
c     |           NEV + 2 <= NCV <= MAXNCV               |
c     %--------------------------------------------------%
c
      n     = 100
      nev   = 4
      ncv   = 20
      if ( n .gt. maxn ) then
         print *, ' ERROR with _NDRV2: N is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _NDRV2: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _NDRV2: NCV is greater than MAXNCV '
         go to 9000
      end if
      bmat  = 'I'
      which = 'LM'
      sigmar = 1.0E+0
      sigmai = 0.0E+0
c
c     %----------------------------------------------------%
c     | Construct C = A - SIGMA*I in real arithmetic, and  |
c     | factor C in real arithmetic using LAPACK           |
c     | subroutine sgttrf. The matrix A is chosen to be    |
c     | the tridiagonal matrix derived from standard       |
c     | central difference of the 1-d convection diffusion |
c     | operator u" + rho*u' on the interval [0, 1] with   |
c     | zero Dirichlet boundary condition.                 |
c     %----------------------------------------------------%
c
      rho = 1.0E+1
      h = one / real(n+1)
      s = rho*h / two
c
      s1 = -one-s
      s2 = two - sigmar
      s3 = -one+s
c
      do 10 j = 1, n-1
         dl(j) = s1
         dd(j) = s2
         du(j) = s3
  10  continue
      dd(n) = s2
c
      call sgttrf(n, dl, dd, du, du2, ipiv, ierr)
      if ( ierr .ne. 0 ) then
         print*, ' '
         print*, ' ERROR with _gttrf in _NDRV2.'
         print*, ' '
         go to 9000
      end if
c
c     %-----------------------------------------------------%
c     | The work array WORKL is used in SNAUPD as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.  The parameter TOL determines    |
c     | the stopping criterion. If TOL<=0, machine          |
c     | precision is used.  The variable IDO is used for    |
c     | reverse communication, and is initially set to 0.   |
c     | Setting INFO=0 indicates that a random vector is    |
c     | generated in SNAUPD to start the Arnoldi iteration. |
c     %-----------------------------------------------------%
c
      lworkl = 3*ncv**2+6*ncv
      tol    = zero
      ido    = 0
      info   = 0
c
c     %---------------------------------------------------%
c     | This program uses exact shifts with respect to    |
c     | the current Hessenberg matrix (IPARAM(1) = 1).    |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed. Mode 3 of SNAUPD is used      |
c     | (IPARAM(7) = 3).  All these options can be        |
c     | changed by the user. For details see the          |
c     | documentation in SNAUPD.                          |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = 300
      mode   = 3

      iparam(1) = ishfts
      iparam(3) = maxitr
      iparam(7) = mode
c
c     %-------------------------------------------%
c     | M A I N   L O O P (Reverse communication) |
c     %-------------------------------------------%
c
 20   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine SNAUPD and take |
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call snaupd ( ido, bmat, n, which, nev, tol, resid,
     &        ncv, v, ldv, iparam, ipntr, workd, workl, lworkl,
     &        info )
c
         if ( ido .eq. -1 .or. ido .eq. 1) then
c
c           %-------------------------------------------%
c           | Perform  y <--- OP*x = inv[A-SIGMA*I]*x   |
c           | The user should supply his/her own linear |
c           | system solver here that takes             |
c           | workd(ipntr(1)) as the input, and returns |
c           | the result to workd(ipntr(2)).            |
c           %-------------------------------------------%
c
            call scopy( n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
c
            call sgttrs('N', n, 1, dl, dd, du, du2, ipiv,
     &                  workd(ipntr(2)), n, ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' ERROR with _gttrs in _NDRV2.'
               print*, ' '
               go to 9000
            end if
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call SNAUPD again. |
c           %-----------------------------------------%
c
            go to 20
c
         end if
c
c     %-----------------------------------------%
c     | Either we have convergence, or there is |
c     | an error.                               |
c     %-----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %--------------------------%
c        | Error message, check the |
c        | documentation in SNAUPD. |
c        %--------------------------%
c
         print *, ' '
         print *, ' Error with _naupd, info = ', info
         print *, ' Check the documentation in _naupd.'
         print *, ' '
c
      else
c
c        %-------------------------------------------%
c        | No fatal errors occurred.                 |
c        | Post-Process using SNEUPD.                |
c        |                                           |
c        | Computed eigenvalues may be extracted.    |
c        |                                           |
c        | Eigenvectors may also be computed now if  |
c        | desired.  (indicated by rvec = .true.)    |
c        %-------------------------------------------%
c
         rvec = .true.
c
         call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv,
     &        sigmar, sigmai, workev, bmat, n, which, nev, tol,
     &        resid, ncv, v, ldv, iparam, ipntr, workd,
     &        workl, lworkl, ierr )
c
c        %-----------------------------------------------%
c        | The real part of the eigenvalue is returned   |
c        | in the first column of the two dimensional    |
c        | array D, and the imaginary part is returned   |
c        | in the second column of D.  The corresponding |
c        | eigenvectors are returned in the first NEV    |
c        | columns of the two dimensional array V if     |
c        | requested.  Otherwise, an orthogonal basis    |
c        | for the invariant subspace corresponding to   |
c        | the eigenvalues in D is returned in V.        |
c        %-----------------------------------------------%
c
         if ( ierr .ne. 0 ) then
c
c           %------------------------------------%
c           | Error condition:                   |
c           | Check the documentation of SNEUPD. |
c           %------------------------------------%
c
            print *, ' '
            print *, ' Error with _neupd, info = ', ierr
            print *, ' Check the documentation of _neupd. '
            print *, ' '
c
         else
c
            first  = .true.
            nconv =  iparam(5)
            do 30 j=1, nconv
c
c              %---------------------------%
c              | Compute the residual norm |
c              |                           |
c              |   ||  A*x - lambda*x ||   |
c              |                           |
c              | for the NCONV accurately  |
c              | computed eigenvalues and  |
c              | eigenvectors.  (iparam(5) |
c              | indicates how many are    |
c              | accurate to the requested |
c              | tolerance)                |
c              %---------------------------%
c
               if (d(j,2) .eq. zero)  then
c
c                 %--------------------%
c                 | Ritz value is real |
c                 %--------------------%
c
                  call av(n, v(1,j), ax)
                  call saxpy(n, -d(j,1), v(1,j), 1, ax, 1)
                  d(j,3) = snrm2(n, ax, 1)
                  d(j,3) = d(j,3) / abs(d(j,1))
c
               else if (first) then
c
c                 %------------------------%
c                 | Ritz value is complex  |
c                 | Residual of one Ritz   |
c                 | value of the conjugate |
c                 | pair is computed.      |
c                 %------------------------%
c
                  call av(n, v(1,j), ax)
                  call saxpy(n, -d(j,1), v(1,j), 1, ax, 1)
                  call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1)
                  d(j,3) = snrm2(n, ax, 1)
                  call av(n, v(1,j+1), ax)
                  call saxpy(n, -d(j,2), v(1,j), 1, ax, 1)
                  call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1)
                  d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) )
                  d(j+1,3) = d(j,3)
                  first = .false.
               else
                  first = .true.
               end if
c
 30         continue
c
c           %-----------------------------%
c           | Display computed residuals. |
c           %-----------------------------%
c
            call smout(6, nconv, 3, d, maxncv, -6,
     &           'Ritz values (Real,Imag) and relative residuals')
c
         end if
c
c        %-------------------------------------------%
c        | Print additional convergence information. |
c        %-------------------------------------------%
c
         if ( info .eq. 1) then
             print *, ' '
             print *, ' Maximum number of iterations reached.'
             print *, ' '
         else if ( info .eq. 3) then
             print *, ' '
             print *, ' No shifts could be applied during implicit
     &                  Arnoldi update, try increasing NCV.'
             print *, ' '
         end if
c
         print *, ' '
         print *, ' _NDRV2 '
         print *, ' ====== '
         print *, ' '
         print *, ' Size of the matrix is ', n
         print *, ' The number of Ritz values requested is ', nev
         print *, ' The number of Arnoldi vectors generated',
     &            ' (NCV) is ', ncv
         print *, ' What portion of the spectrum: ', which
         print *, ' The number of converged Ritz values is ',
     &              nconv
         print *, ' The number of Implicit Arnoldi update',
     &            ' iterations taken is ', iparam(3)
         print *, ' The number of OP*x is ', iparam(9)
         print *, ' The convergence criterion is ', tol
         print *, ' '
c
      end if
c
c     %---------------------------%
c     | Done with program sndrv2. |
c     %---------------------------%
c
 9000 continue
c
      end
c
c-------------------------------------------------------------------
c
c     matrix vector multiplication subroutine
c
      subroutine av (n, v, w)
      integer           n, j
      Real
     &                   v(n), w(n), rho, two, one, dd, dl, du, s, h
      common            /convct/ rho
      parameter         (one = 1.0E+0, two = 2.0E+0 )
c
c     Compute the matrix vector multiplication y<---A*x
c     where A is a n by n nonsymmetric tridiagonal matrix derived from
c     the central difference discretization of the 1-dimensional
c     convection diffusion operator on the interval [0,1] with
c     zero Dirichlet boundary condition.
c
c
      h = one / real(n+1)
      s = rho *h / two
      dd = two
      dl = -one - s
      du = -one + s
c
      w(1) =  dd*v(1) + du*v(2)
      do 10 j = 2,n-1
         w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1)
 10   continue
      w(n) =  dl*v(n-1) + dd*v(n)
      return
      end


!*********************************************************************
!
! This benchmark test program is measuring a cpu performance
! of floating point operation by a Poisson equation solver.
!!
! If you have any question, please ask me via email.
! written by Ryutaro HIMENO, November 26, 2001.
! Version 3.0
! ----------------------------------------------
! Ryutaro Himeno, Dr. of Eng.
! Head of Computer Information Division,
! RIKEN (The Institute of Pysical and Chemical Research)
! Email : himeno@postman.riken.go.jp
! ---------------------------------------------------------------
! You can adjust the size of this benchmark code to fit your target
! computer. In that case, please chose following sets of
! (mimax,mjmax,mkmax):
! small : 65,33,33
! small : 129,65,65
! midium: 257,129,129
! large : 513,257,257
! ext.large: 1025,513,513
! This program is to measure a computer performance in MFLOPS
! by using a kernel which appears in a linear solver of pressure
! Poisson eq. which appears in an incompressible Navier-Stokes solver.
! A point-Jacobi method is employed in this solver as this method can
! be easyly vectrized and be parallelized.
! ------------------
! Finite-difference method, curvilinear coodinate system
! Vectorizable and parallelizable on each grid point
! No. of grid points : imax x jmax x kmax including boundaries
! ------------------
! A,B,C:coefficient matrix, wrk1: source term of Poisson equation
! wrk2 : working area, OMEGA : relaxation parameter
! BND:control variable for boundaries and objects ( = 0 or 1)
! P: pressure
! -------------------
! -------------------
! "use portlib" statement on the next line is for Visual fortran
! to use UNIX libraries. Please remove it if your system is UNIX.
! -------------------
! use portlib
!
module pres
  real(4),dimension(:,:,:),allocatable :: p
end module pres
!
module mtrx
  real(4),dimension(:,:,:,:),allocatable :: a,b,c
end module mtrx
!
module bound
  real(4),dimension(:,:,:),allocatable :: bnd
end module bound
!
module work
  real(4),dimension(:,:,:),allocatable :: wrk1,wrk2
end module work
!
module others
  integer :: mimax,mjmax,mkmax
  integer :: imax,jmax,kmax
  real(4),parameter :: omega=0.8
end module others
!
!
program HimenoBMTxp_F90
  use others
!
  implicit none
!
  integer :: nn
  integer :: ic,icr,icm
  real(4) :: flop,xmflops2,score,gosa
  real(8) :: cpu0,cpu1,cpu,dt
  ! ttarget specifys the measuring period in sec
  real(4),parameter :: ttarget=60.0
  real(8),external :: second
!
  call readparam
!
!! Initializing matrixes
  call initmem
  call initmt
  print *,' mimax=',mimax,' mjmax=',mjmax,' mkmax=',mkmax
  print *,' imax=',imax,' jmax=',jmax,' kmax=',kmax
!
  call system_clock(ic,icr,icm)
  dt= 1.0/real(icr,8)
  print '(2x,a,e10.5)','Time measurement accuracy : ',dt
!! Start measuring
!
  nn=3
  print *,' Start rehearsal measurement process.'
  print *,' Measure the performance in 3 times.'
!
  cpu0=second()
!! Jacobi iteration
  call jacobi(nn,gosa)
!
  cpu1=second()
  cpu = (cpu1 - cpu0)*dt
  flop=real(kmax-2,4)*real(jmax-2,4)*real(imax-2,4)*34.0
  if(cpu /= 0.0)  xmflops2=flop/real(cpu,4)*1.0e-6*real(nn,4)
  print *,'  MFLOPS:',xmflops2,'  time(s):',cpu,gosa
!
!! end the test loop
  nn=int(ttarget/(cpu/3.0))
  print *,'Now, start the actual measurement process.'
  print *,'The loop will be excuted in',nn,' times.'
  print *,'This will take about one minute.'
  print *,'Wait for a while.'
!
!! Jacobi iteration
  cpu0= second()
!! Jacobi iteration
  call jacobi(nn,gosa)
!
  cpu1= second()
  cpu = (cpu1 - cpu0)*dt
  if(cpu /= 0.0)  xmflops2=flop*1.0e-6/real(cpu,4)*real(nn,4)
!
!!!      xmflops2=nflop/cpu*1.0e-6*float(nn)
!
  print *,' Loop executed for ',nn,' times'
  print *,' Gosa :',gosa
  print *,' MFLOPS:',xmflops2, '  time(s):',cpu
  score=xmflops2/82.84
  print *,' Score based on Pentium III 600MHz :',score
!
!  pause
!   stop
end program HimenoBMTxp_F90
!
!
subroutine readparam
!
  use others
!
  implicit none
!
  character(10) :: size
!
  print *,'Select Grid-size:'
!  print *,'For example:'
  print *,'Grid-size= '
  print *,'           XS (64x32x32)'
  print *,'           S  (128x64x64)'
  print *,'           M  (256x128x128)'
  print *,'           L  (512x256x256)'
  print *,'           XL (1024x512x512)'
!  print *,' Grid-size = '
!  read(*,*) size
  size="M"

  call grid_set(size)
!
  imax=mimax-1
  jmax=mjmax-1
  kmax=mkmax-1
!
  return
end subroutine readparam
!
!
subroutine grid_set(size)
!
  use others
!
  implicit none
!
  character(10),intent(in) :: size
!
  select case(size)
  case("xs")
     mimax=65
     mjmax=33
     mkmax=33
  case("XS")
     mimax=65
     mjmax=33
     mkmax=33
  case("s")
     mimax=129
     mjmax=65
     mkmax=65
  case("S")
     mimax=129
     mjmax=65
     mkmax=65
  case("m")
     mimax=257
     mjmax=129
     mkmax=129
  case("M")
     mimax=257
     mjmax=129
     mkmax=129
  case("l")
     mimax=513
     mjmax=257
     mkmax=257
  case("L")
     mimax=513
     mjmax=257
     mkmax=257
  case("xl")
     mimax=1025
     mjmax=513
     mkmax=513
  case("XL")
     mimax=1025
     mjmax=513
     mkmax=513
  case default
     print *,'Invalid input character !!'
     stop
  end select
!
  return
end subroutine grid_set
!
!
!**************************************************************
subroutine initmt
!**************************************************************
  use pres
  use mtrx
  use bound
  use work
  use others
!
  implicit none
!
  integer :: i,j,k
!
!  a=0.0
!  b=0.0
!  c=0.0
!  p=0.0
!  wrk1=0.0
!  wrk2=0.0
!  bnd=0.0
      do k=1,mkmax
         do j=1,mjmax
            do i=1,mimax
               a(i,j,k,1)=0.0
               a(i,j,k,2)=0.0
               a(i,j,k,3)=0.0
               a(i,j,k,4)=0.0
               b(i,j,k,1)=0.0
               b(i,j,k,2)=0.0
               b(i,j,k,3)=0.0
               c(i,j,k,1)=0.0
               c(i,j,k,2)=0.0
               c(i,j,k,3)=0.0
               p(i,j,k)=0.0
               wrk1(i,j,k)=0.0
               wrk2(i,j,k)=0.0
               bnd(i,j,k)=0.0
            enddo
         enddo
      enddo
!
!  a(1:imax,1:jmax,1:kmax,1:3)=1.0
!  a(1:imax,1:jmax,1:kmax,4)=1.0/6.0
!  c(1:imax,1:jmax,1:kmax,:)=1.0
!  bnd(1:imax,1:jmax,1:kmax)=1.0
!  do k=1,kmax
!     p(:,:,k)=real((k-1)*(k-1),4)/real((kmax-1)*(kmax-1),4)
!  enddo
      do k=1,kmax
         do j=1,jmax
            do i=1,imax
               a(i,j,k,1)=1.0
               a(i,j,k,2)=1.0
               a(i,j,k,3)=1.0
               a(i,j,k,4)=1.0/6.0
               b(i,j,k,1)=0.0
               b(i,j,k,2)=0.0
               b(i,j,k,3)=0.0
               c(i,j,k,1)=1.0
               c(i,j,k,2)=1.0
               c(i,j,k,3)=1.0
               p(i,j,k)=real((k-1)*(k-1),4)/real((kmax-1)*(kmax-1),4)
               wrk1(i,j,k)=0.0
               wrk2(i,j,k)=0.0
               bnd(i,j,k)=1.0
            enddo
         enddo
      enddo
!
  return
end subroutine initmt
!
!*************************************************************
subroutine initmem
!*************************************************************
  use pres
  use mtrx
  use bound
  use work
  use others
!
  implicit none
!
  allocate(p(mimax,mjmax,mkmax))
  allocate(a(mimax,mjmax,mkmax,4),b(mimax,mjmax,mkmax,3), &
       c(mimax,mjmax,mkmax,3))
  allocate(bnd(mimax,mjmax,mkmax))
  allocate(wrk1(mimax,mjmax,mkmax),wrk2(mimax,mjmax,mkmax))
!
  return
end subroutine initmem
!
!*************************************************************
subroutine jacobi(nn,gosa)
!*************************************************************
  use pres
  use mtrx
  use bound
  use work
  use others
!
  implicit none
!
  integer,intent(in) :: nn
  real(4),intent(inout) :: gosa
  integer :: i,j,k,loop
  real(4) :: s0,ss
!
!
  do loop=1,nn
     gosa= 0.0
     do k=2,kmax-1
        do j=2,jmax-1
           do i=2,imax-1
              s0=a(I,J,K,1)*p(I+1,J,K) &
                   +a(I,J,K,2)*p(I,J+1,K) &
                   +a(I,J,K,3)*p(I,J,K+1) &
                   +b(I,J,K,1)*(p(I+1,J+1,K)-p(I+1,J-1,K) &
                               -p(I-1,J+1,K)+p(I-1,J-1,K)) &
                   +b(I,J,K,2)*(p(I,J+1,K+1)-p(I,J-1,K+1) &
                               -p(I,J+1,K-1)+p(I,J-1,K-1)) &
                   +b(I,J,K,3)*(p(I+1,J,K+1)-p(I-1,J,K+1) &
                               -p(I+1,J,K-1)+p(I-1,J,K-1)) &
                   +c(I,J,K,1)*p(I-1,J,K) &
                   +c(I,J,K,2)*p(I,J-1,K) &
                   +c(I,J,K,3)*p(I,J,K-1)+wrk1(I,J,K)
              ss=(s0*a(I,J,K,4)-p(I,J,K))*bnd(I,J,K)
              GOSA=GOSA+SS*SS
              wrk2(I,J,K)=p(I,J,K)+OMEGA *SS
           enddo
        enddo
     enddo
!
!     p(2:imax-1,2:jmax-1,2:kmax-1)= &
!          wrk2(2:imax-1,2:jmax-1,2:kmax-1)
     do k=2,kmax-1
        do j=2,jmax-1
          do i=2,imax-1
              p(I,J,K)=wrk2(I,J,K)
           enddo
        enddo
     enddo
!
  enddo
!! End of iteration
  return
end subroutine jacobi
!
!
!
function second() result(rtime)
!
  implicit none
!
  integer :: ic,ir,im
  real(8) :: rtime
!
  call system_clock(ic,ir,im)
!
  rtime= real(ic,8)
!
end function second


SUBROUTINE FIB(A,N)
!
!   CALCULATE FIRST N FIBONACCI NUMBERS
!
   INTEGER N
   REAL*8 A(N)
   DO I=1,N
      IF (I.EQ.1) THEN
         A(I) = 0.5D0
      ELSEIF (I.EQ.2) THEN
         A(I) = 1.0D0
      ELSE
         A(I) = A(I-1) + A(I-2)
      ENDIF
   ENDDO
END


      DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DSDOT  Krogh   Declared all vars.
C>> 1985-08-02 DSDOT  Lawson  Initial code.
C
C     RETURNS D.P. DOT PRODUCT ACCUMULATED IN D.P., FOR S.P. SX AND SY
C     DSDOT = SUM FOR I = 0 TO N-1 OF  SX(LX+I*INCX) * SY(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
      INTEGER N, INCX, INCY, KX, KY, I, NS
      REAL SX(*),SY(*)
C
      DSDOT = 0.D0
      IF(N .LE. 0)RETURN
      IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20
      KX = 1
      KY = 1
      IF(INCX.LT.0) KX = 1+(1-N)*INCX
      IF(INCY.LT.0) KY = 1+(1-N)*INCY
          DO 10 I = 1,N
          DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
          KX = KX + INCX
          KY = KY + INCY
   10 CONTINUE
      RETURN
   20 CONTINUE
      NS = N*INCX
          DO 30 I=1,NS,INCX
          DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
   30     CONTINUE
      RETURN
      END


C Copyright 2021 Dennis Blondell Decker
C Date: 29 May 2021
C Purpose: Maximum Sum Subarray - Kadane's Algorithm
C Tectonics: gfortran -ffixed-form -c maxsumsubarray.f90
C Can handle negative integer sums
C The ISTART and ISTOP are inclusive as always in Fortran

      SUBROUTINE MAXSUMSUBARRAY(NUMBERS,ILEN,ISUM,ISTART,ISTOP)
         DIMENSION NUMBERS(ILEN)

         ISUM=-(2**32-1)
         ISTART=1
         ISTOP=1
         ICURSUM=-(2**32-1)
         DO 10 J=1,ILEN
            IF (ICURSUM.LT.0) THEN
               I=J
               ICURSUM=NUMBERS(J)
            ELSE
               ICURSUM=ICURSUM+NUMBERS(J)
            ENDIF
            IF (ICURSUM.GT.ISUM) THEN
               ISUM=ICURSUM
               ISTART=I
               ISTOP=J
            ENDIF
   10    CONTINUE
      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mnspro : sproot test program                       cc
cc      application : to find the intersection of a planar            cc
cc      cubic spline curve   x = sx(u)   y = sy(u)   with             cc
cc      a straight line   alfa*x + beta*y = gamma                     cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real t(13),c(26),zero(20),sp(40),cc(13)
      integer i,idim,ier,is,i1,i2,j,k,k1,l1,l2,m,mest,n,nc,nk1
      real alfa,beta,gamma,per
c  we have a planar curve
      idim = 2
c  we have a cubic spline curve.
      k = 3
      k1 = k+1
c  set up the dimension information
      nc = 26
      mest = 20
c  n denotes the total number of knots.
      n = 13
c  set up the knots of the spline curve
      t(4) = 0.
      t(5) = 0.2e0
      t(6) = 0.3e0
      t(7) = 0.5e0
      t(8) = 0.6e0
      t(9) = 0.7e0
      t(10) = 0.1e+01
c  fetch the b-spline coefficients for sx(u)
      c(1) = 0.1e+01
      c(2) = 0.3e+01
      c(3) = 0.4e+01
      c(4) = 0.5e+01
      c(5) = 0.3e+01
      c(6) = -0.1e+01
c  fetch the b-spline coefficients for sy(u)
      c(14) = 0.1e+01
      c(15) = 0.2e+01
      c(16) = -0.3e+01
      c(17) = 0.2e+01
      c(18) = 0.1e+01
      c(19) = 0.4e+01
c  we have a closed curve.
c  incorporate the boundary conditions for periodic splines
      per = t(10)-t(4)
      do 10 i=1,3
c  the boundary knots
        t(i) = t(i+6)-per
        t(i+10) = t(i+4)+per
c  the boundary coefficients
        c(i+6) = c(i)
        c(i+19) = c(i+13)
  10  continue
c  print the data of the spline curve.
      write(6,900) k
      write(6,905)
      write(6,910) (t(i),i=1,n)
      write(6,915)
      nk1 = n-k1
      write(6,920) (c(i),i=1,nk1)
      write(6,925)
      i1 = n+1
      i2 = n+nk1
      write(6,920) (c(i),i=i1,i2)
c  loop for the different lines.
      do 200 is=1,5
        go to (110,120,130,140,150),is
c  fetch the parameters of the straight line.
 110    alfa = 0.
        beta = 0.1e+01
        gamma = 0.
        go to 160
 120    alfa = 0.1e+01
        beta = 0.
        go to 160
 130    beta = -0.1e+01
        go to 160
 140    alfa = 0.4e0
        beta = 0.3e0
        gamma = 0.12e+01
        go to 160
 150    beta = 0.4e0
        gamma = 0.
c  print the parameters of the straight line.
 160    write(6,930) alfa,beta,gamma
c  calculate the coefficients of s(u) = sx(u)*alfa + sy(u)*beta - gamma
        do 170 i=1,nk1
          j = i+n
          cc(i) = alfa*c(i)+beta*c(j)-gamma
 170    continue
c  find the zeros of s(u)
        call sproot(t,n,cc,zero,mest,m,ier)
        write(6,935) m
        if(m.eq.0) go to 200
c  find the intersection points
        call curev(idim,t,n,c,nc,k,zero,m,sp,nc,ier)
c  print the intersection points
        write(6,940)
        l2 = 0
        do 180 i=1,m
          l1 = l2+1
          l2 = l1+1
          write(6,945) i,zero(i),sp(l1),sp(l2)
 180    continue
 200  continue
      stop
c  format statements.
 900  format(31h0degree of the spline curve k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,7f6.1)
 915  format(1x,30hb-spline coefficients of sx(u))
 920  format(5x,14f5.0)
 925  format(1x,30hb-spline coefficients of sy(u))
 930  format(18h0intersection with,f6.1,5h *x +,f5.1,5h *y =,f5.1)
 935  format(1x,33hnumber of intersection points m =,i3)
 940  format(6x,1hi,7x,4hu(i),5x,8hsx(u(i)),4x,8hsy(u(i)))
 945  format(1x,i6,3f12.5)
      end


c $Id: ffft.f,v 1.1 2002/12/03 22:09:46 ahotan Exp $
c $Log: ffft.f,v $
c Revision 1.1  2002/12/03 22:09:46  ahotan
c Migrating from tas/archive
c
c Revision 1.1.1.1  1998/08/03 06:39:55  mbritton
c start
c
c Revision 1.1  1994/11/25  03:13:05  jsandhu
c Initial revision
c
c Revision 1.1  1994/11/25  03:13:05  jsandhu
c Initial revision
c

* ffft.f,v 1.1 93/10/29 22:56:39 will
C @(#)ffft.f	1.1 9/7/90
	subroutine ffft(d,npts,isign,ireal)

C  Fourier transform of length npts=2**k, performed in place.
C  Input data in array d, treated as complex if ireal=0, and as real if ireal=1.
C  In either case the transform values are returned in array d, treated as
C  complex. The DC term is d(1), and d(npts/2+1) is the term at the Nyquist
C  frequency.  The basic algorithm is the same as Norm Brenner's FOUR1, and
C  uses radix-2 transforms.

C  J. H. Taylor, Princeton University.
*	MODIFICATIONS:
*		Removed MAXSAM in size of d() 	- WD 14aug92

	complex d(*),t,w,wstep,tt,uu
	data pi/3.14159265/

C  Shuffle the data to bit-reversed order.

	imax=npts/(ireal+1)
	irev=1
	do 5 i=1,imax
	if(i.ge.irev) go to 2
	t=d(i)
	d(i)=d(irev)
	d(irev)=t
2	mmax=imax/2
3	if(irev.le.mmax) go to 5
	irev=irev-mmax
	mmax=mmax/2
	if(mmax.ge.1) go to 3
5	irev=irev+mmax

C  The radix-2 transform begins here.

	api=isign*pi/2.
	mmax=1
6	istep=2*mmax
	wstep=cmplx(-2.*sin(api/mmax)**2,sin(2.*api/mmax))
	w=1.
	do 9 m=1,mmax

C  This in the inner-most loop -- optimization here is important!
	do 8 i=m,imax,istep
	t=w*d(i+mmax)
	d(i+mmax)=d(i)-t
8	d(i)=d(i)+t

9	w=w*(1.+wstep)
	mmax=istep
	if(mmax.lt.imax) go to 6

	if(ireal.eq.0) return

C  Now complete the last stage of a doubled-up real transform.

	jmax=imax/2 + 1
	wstep=cmplx(-2.*sin(isign*pi/npts)**2,sin(isign*pi/imax))
	w=1.0
	d(imax+1)=d(1)

	do 10 j=1,jmax
	uu=cmplx(real(d(j))+real(d(2+imax-j)),aimag(d(j)) -
     +    aimag(d(2+imax-j)))
	tt=w*cmplx(aimag(d(j))+aimag(d(2+imax-j)),-real(d(j)) +
     +    real(d(2+imax-j)))
	d(j)=uu+tt
	d(2+imax-j)=conjg(uu-tt)
10	w=w*(1.+wstep)

	return
	end