module strength
use hamiltonian_types
use maths
use build_hamiltonian_routines
implicit none
contains

!------------------------------------------------
! Locates a given value in a vector
!------------------------------------------------
	function locate(a,b)
	integer :: locate
	real(kind=8), INTENT(IN) :: a(:), b
	integer :: location(1)
		locate = -1

		location = minloc(abs(a-b))
		if (location(1) /= 0) then
			locate = location(1)
		endif

	end function locate

!------------------------------------------------
! Returns the kronecker's delta
!------------------------------------------------
	function kronecker(a,b)
	real*8 :: kronecker
	real*8, INTENT(IN) :: a, b
		kronecker = 0.d0
		if (a == b) then
			kronecker = 1.d0
		endif
	end function kronecker

! ------------------------------------------------------------
! This function returns the matrix elements of the dipole moment in the Hund's a)
! eigenfunctions
! ------------------------------------------------------------
	function q_o_m(Lambda_up,Omega_up,J_up,M_up,Lambda_low,Omega_low,J_low,M_low)
	real*8 :: q_o_m
	real*8, INTENT(IN) :: Lambda_up, Omega_up, J_up, M_up, Lambda_low, Omega_low, J_low, M_low
	real*8 :: q_m, q_o

		q_m = qm(J_up,M_up,J_low,M_low)
		q_o = qo(Lambda_up,Omega_up,J_up,Lambda_low,Omega_low,J_low)

		q_o_m = q_o * q_m

	end function q_o_m

! ------------------------------------------------------------
! This function returns the matrix elements of q_o
! ------------------------------------------------------------
	function qm(J_up,M_up,J_low,M_low)
	real*8 :: qm
	real*8, INTENT(IN) :: J_up, M_up, J_low, M_low
	real*8 :: deltam, deltaj, J, M

		deltaj = J_up - J_low
		deltam = M_up - M_low

		J = J_low
		M = M_low
		qm = 0.d0

		if (deltam == 0.d0) then
			if (deltaj == 1.d0) then
				qm = dsqrt((J+1.d0)**2 - M**2)
			else if (deltaj == 0) then
				qm = M
			else if (deltaj == -1.d0) then
				qm = dsqrt(J**2 - M**2)
			endif
		endif

		if (dabs(deltam) == 1.d0) then
			if (deltaj == 1.d0) then
				qm = -deltam * dsqrt(0.5d0*(J+1.d0+M*deltam)*(J+2.d0+M*deltam))
			else if (deltaj == 0) then
				qm = dsqrt(0.5d0*(J-M*deltam)*(J+1.d0+M*deltam))
			else if (deltaj == -1.d0) then
				qm = deltam * dsqrt(0.5d0*(J-M*deltam)*(J-1.d0-M*deltam))
			endif
		endif

	end function qm

! ------------------------------------------------------------
! This function returns the matrix elements of q_o
! ------------------------------------------------------------
	function qo(Lambda_up,Omega_up,J_up,Lambda_low,Omega_low,J_low)
	real*8 :: qo
	real*8, INTENT(IN) :: Lambda_up, Omega_up, J_up, Lambda_low, Omega_low, J_low
	real*8 :: deltao, deltaj, Omega, J, pi_eps

		deltao = Omega_up - Omega_low
		deltaj = J_up - J_low
		pi_eps = 1.d0 + kronecker(1.d0,Lambda_up+Lambda_low)

		J = J_low
		Omega = Omega_low
		qo = 0.d0

		if (deltao == 0.d0) then
			if (deltaj == 1.d0) then
				qo = 1.d0/(J+1.d0) * dsqrt(( (J+1.d0)**2 - Omega**2)/( (2.d0*J+1.d0)*(2.d0*J+3.d0)) )
			else if (deltaj == 0) then
				qo = Omega / (J*(J+1.d0))
			else if (deltaj == -1.d0) then
				qo = 1.d0/J * dsqrt(( J**2 - Omega**2)/((2.d0*J-1.d0)*(2.d0*J+1.d0)))
			endif
		endif

		if (dabs(deltao) == 1.d0) then
			if (deltaj == 1.d0) then
				qo = -deltao/(J+1.d0) * dsqrt(pi_eps*(J+1.d0+Omega*deltao)*(J+2.d0+Omega*deltao) /&
					(2.d0*(2.d0*J+1.d0)*(2.d0*J+3.d0)))
			else if (deltaj == 0) then
				qo = 1.d0/(J*(J+1.d0)) * dsqrt(0.5d0*pi_eps*(J-Omega*deltao)*(J+1.d0+Omega*deltao))
			else if (deltaj == -1.d0) then
				qo = deltao/J * dsqrt(pi_eps*(J-Omega*deltao)*(J-1.d0-Omega*deltao) /&
					(2.d0*(2.d0*J-1.d0)*(2.d0*J+1.d0)))
			endif
		endif

	end function qo

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Strength of the Zeeman components in the Hund's case (a) coupling
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function case_a_strength(Ju,Jl,Mu,Ml,Ou,Ol)
	real(kind=8) :: case_a_strength
	real(kind=8) :: Mu, Ml, Ju, Jl, Ou, Ol, qm, qo

		qm = Mu - Ml
		qo = Ou - Ol

! Falta un factor sqrt((2Ju+1)*(2Jl+1)) ??

		case_a_strength = w3js(int(2.d0*Jl),int(2.d0*Ju),2,int(2.d0*Ml),-int(2.d0*Mu),int(2.d0*qm)) * &
			w3js(int(2.d0*Jl),int(2.d0*Ju),2,int(2.d0*Ol),-int(2.d0*Ou),int(2.d0*qo)) * &
			sqrt((2.d0*Ju+1.d0)*(2.d0*Jl+1.d0))

	end function case_a_strength

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Count the number of Zeeman components and generate the index arrays
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine count_zeeman_components(trans)
	type(type_transition) :: trans
	integer :: i, j, i2, j2, k, nJup, nJlow, ind_up, ind_low
	real(kind=8) :: Ju, Jl, Mu, Ml, Ou, Ol, case_a_str, spli_up, spli_low, spli, m_up, m_low
	real(kind=8), allocatable :: direction_cosine(:,:), strength_matrix(:,:), caca(:,:)

		nJup = int(2.d0*trans%upper%J+1.d0)
		nJlow = int(2.d0*trans%lower%J+1.d0)

		k = 0
		do i = 1, trans%upper%hamiltonian_size
			do j = 1, trans%lower%hamiltonian_size
				if ( abs(trans%upper%ket(i)%M-trans%lower%ket(j)%M) <= 1.d0 .and. &
					trans%upper%active(i) /= -9999 .and. trans%lower%active(j) /= -9999) then
						k = k + 1
				endif
			enddo
		enddo
		print *, 'Number of Zeeman transitions : ', k

		allocate(direction_cosine(trans%upper%hamiltonian_size,trans%lower%hamiltonian_size))
		allocate(strength_matrix(trans%upper%hamiltonian_size,trans%lower%hamiltonian_size))

		do i = 1, trans%upper%hamiltonian_size
			do j = 1, trans%lower%hamiltonian_size
				Ju = trans%upper%ket_m_ordered(i)%J
				Jl = trans%lower%ket_m_ordered(j)%J
				Mu = trans%upper%ket_m_ordered(i)%M
				Ml = trans%lower%ket_m_ordered(j)%M
				Ou = trans%upper%ket_m_ordered(i)%Omega
				Ol = trans%lower%ket_m_ordered(j)%Omega

				direction_cosine(i,j) = kronecker(trans%upper%ket_m_ordered(i)%Sigma,trans%lower%ket_m_ordered(j)%Sigma) * &
					q_o_m(trans%upper%Lambda,Ou,Ju,Mu,trans%lower%Lambda,Ol,Jl,Ml)
			enddo
		enddo

		strength_matrix = matmul(matmul(transpose(trans%upper%eigenvec),direction_cosine),trans%lower%eigenvec)

		allocate(trans%ind_up(k))
		allocate(trans%ind_low(k))
		allocate(trans%str(k))
		trans%str = 0.d0

		print *, trans%upper%hamiltonian_size, trans%lower%hamiltonian_size
		write(18,*) strength_matrix
		write(17,*) direction_cosine

		open(unit=12,file='pattern.dat',action='write',status='replace')
		write(12,*) k

		k = 0
		do i = 1, 2*trans%upper%J+1
			m_up = -trans%upper%J + (i-1)
			do j = 1, 2*trans%lower%J+1
				m_low = -trans%lower%J + (j-1)

				if (dabs(m_up-m_low) <= 1.d0) then

					ind_up = locate(trans%upper%active,m_up)
					ind_low = locate(trans%lower%active,m_low)

					spli_up = trans%upper%eigenval(ind_up)-trans%upper%eigenval_zerofield(ind_up)
					spli_low = trans%lower%eigenval(ind_low)-trans%lower%eigenval_zerofield(ind_low)
					spli = -(spli_up-spli_low)*(trans%wavelength*1.d-8)**2 * 1.d8
					write(*,FMT='(F5.1,1X,F5.1,1X,F13.8,3X,F13.8,3X,E13.7)') trans%upper%ket(ind_up)%M, &
							trans%lower%ket(ind_low)%M, spli, strength_matrix(ind_up,ind_low)**2
					write(12,FMT='(F5.1,1X,F5.1,1X,F13.8,3X,F13.8,3X,E13.7)') trans%upper%ket(ind_up)%M, &
							trans%lower%ket(ind_low)%M, spli, strength_matrix(ind_up,ind_low)**2

				endif
			enddo
		enddo
		close(12)

	end subroutine count_zeeman_components

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Strength of the Zeeman components
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine zeeman_strength(trans)
	type(type_transition) :: trans

! First count the number of components of the Zeeman transition
		call count_zeeman_components(trans)

	end subroutine zeeman_strength

end module strength


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

C=======================================================================
      SUBROUTINE TMAG (PARTYP, LENARY, NELBLK, IXELB, ISEVOK,
     &                 SIG1, SIG2, SIG3, SIG12, SIG23, SIG31,
     &                 NUMIX, IXNODE, IXELEM, RESULT)
C=======================================================================

C   --*** TMAG *** (ALGEBRA) Calculate tensor magnitude
C   --   Written by Amy Gilkey - revised 12/03/87
C   --
C   --TMAG calculates the tensor magnitudes.
C   --
C   --Parameters:
C   --   PARTYP - IN - the parameter type (element must be handled differently)
C   --   LENARY - IN - the length of the parameter arrays
C   --   NELBLK - IN - the number of element blocks
C   --   IXELB  - IN - the cumulative element counts for each element block
C   --   ISEVOK - IN - the element variable truth table for each element block
C   --   SIG1, SIG2, SIG3, SIG12, SIG23, SIG31 - IN - the tensor components
C   --   NUMIX  - IN  - the number of selected values; <0 if all
C   --   IXNODE - IN  - the indices of the selected nodes (only if NUMIX>=0)
C   --   IXELEM - IN  - the indices of the selected elements (only if NUMIX>=0)
C   --   RESULT - OUT - the returned tensor magnitudes

      CHARACTER PARTYP
      INTEGER IXELB(0:NELBLK)
      LOGICAL ISEVOK(*)
      REAL SIG1(*), SIG2(*), SIG3(*), SIG12(*), SIG23(*), SIG31(*)
      INTEGER NUMIX
      INTEGER IXNODE(*)
      INTEGER IXELEM(*)
      REAL RESULT(*)

      IF (NUMIX .GE. 0) THEN
C        COMPUTE TMAG ONLY FOR ELEMENTS/NODES THAT EXIST
         IF (PARTYP .NE. 'E') THEN
            DO 50 I = 1, NUMIX
               J = IXNODE(I)
               RESULT(J) = SQRT ((SIG1(J)-SIG2(J))**2
     &            + (SIG2(J)-SIG3(J))**2
     &            + (SIG3(J)-SIG1(J))**2
     &            + 6 * (SIG12(J)**2 + SIG23(J)**2 + SIG31(J)**2))
   50       CONTINUE
         ELSE
            DO 75 IELB = 1, NELBLK
               IF (ISEVOK(IELB)) THEN
                  DO 95 I = IXELB(IELB-1)+1, IXELB(IELB)
                     J = IXELEM(I)
                     RESULT(J) = SQRT ((SIG1(J)-SIG2(J))**2
     &                  + (SIG2(J)-SIG3(J))**2
     &                  + (SIG3(J)-SIG1(J))**2
     &                  + 6 * (SIG12(J)**2 + SIG23(J)**2 + SIG31(J)**2))
   95             CONTINUE
               END IF
   75       CONTINUE
         END IF
      ELSE
C        NUMIX < 0; All Values are selected
C        NUMEL = NUMELO; NUMNP = NUMNPO; IXELB(J) = IXELBO(J) J=1,NELBLK
         IF (PARTYP .NE. 'E') THEN
            DO 100 J = 1, LENARY
               RESULT(J) = SQRT ((SIG1(J)-SIG2(J))**2
     &            + (SIG2(J)-SIG3(J))**2
     &            + (SIG3(J)-SIG1(J))**2
     &            + 6 * (SIG12(J)**2 + SIG23(J)**2 + SIG31(J)**2))
  100       CONTINUE
         ELSE
            DO 120 IELB = 1, NELBLK
               IF (ISEVOK(IELB)) THEN
                  DO 110 J = IXELB(IELB-1)+1, IXELB(IELB)
                     RESULT(J) = SQRT ((SIG1(J)-SIG2(J))**2
     &                  + (SIG2(J)-SIG3(J))**2
     &                  + (SIG3(J)-SIG1(J))**2
     &                  + 6 * (SIG12(J)**2 + SIG23(J)**2 + SIG31(J)**2))
  110             CONTINUE
               END IF
  120       CONTINUE
         END IF
      END IF

      RETURN
      END


      PROGRAM PRIMES3
C
C     PROGRAM TO PRINT THE FIRST N PRIMES
C
      READ(*,*)N
      I=1
      J=0
 10   I=I+1
      IS = SQRT(FLOAT(I))
      DO 20 K=2,IS
      IF (I/K*K .EQ.I) GOTO 10
 20   CONTINUE
      WRITE(*,30)I
 30   FORMAT(I8,$)
      J=J+1
      IF (J/10*10 .EQ.J) WRITE (*,40)
 40   FORMAT()
      IF (J.LT.N) GOTO 10
      IF (J/10*10.NE.J) WRITE (*,40)
      END


      PROGRAM xsor
C     driver for routine sor
      INTEGER JMAX,NSTEP
      REAL PI
      PARAMETER(JMAX=33,NSTEP=4,PI=3.1415926)
      INTEGER i,j,midl
      DOUBLE PRECISION rjac,a(JMAX,JMAX),b(JMAX,JMAX),c(JMAX,JMAX),
     *     d(JMAX,JMAX),e(JMAX,JMAX),f(JMAX,JMAX),u(JMAX,JMAX)
      do 12 i=1,JMAX
        do 11 j=1,JMAX
          a(i,j)=1.d0
          b(i,j)=1.d0
          c(i,j)=1.d0
          d(i,j)=1.d0
          e(i,j)=-4.d0
          f(i,j)=0.d0
          u(i,j)=0.d0
11      continue
12    continue
      midl=JMAX/2+1
      f(midl,midl)=2.d0/(JMAX-1)**2
      rjac=cos(PI/JMAX)
      call sor(a,b,c,d,e,f,u,JMAX,rjac)
      write(*,'(1x,a)') 'SOR Solution:'
      do 13 i=1,JMAX,NSTEP
        write(*,'(1x,9f8.4)') (u(i,j),j=1,JMAX,NSTEP)
13    continue
      write(*,'(/1x,a)') 'Test that solution satisfies Difference Eqns:'
      do 15 i=NSTEP+1,JMAX-1,NSTEP
        do 14 j=NSTEP+1,JMAX-1,NSTEP
          f(i,j)=u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-4.d0*u(i,j)
14      continue
        write(*,'(7x,9f8.4)') (f(i,j),j=NSTEP+1,JMAX-1,NSTEP)
15    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsor.for


!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
!   frc :      A periodically forced system
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION a,b,c,amp,beta,x,y,sn,cs,ss

! FHN parameters
       a = PAR(1)
       b = PAR(2)
       c = PAR(3)

! Forcing parameters
       amp = PAR(4)
       beta= PAR(5)

! FHN variables
       x=U(1)
       y=U(2)

! Forcing variables
       sn=U(3)
       cs=U(4)
       ss = sn**2 + cs**2

! FHN equations
       F(1)= c * ( x - x**3/3 + y - amp*cs )
       F(2)=-( x - a + b*y ) / c

! Oscillator
       F(3) =  sn + beta*cs - sn*ss
       F(4) = -beta*sn + cs - cs*ss

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,t)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: t

      DOUBLE PRECISION a,b,c,amp,beta,TPI

! FHN parameters
       a = 0.
       b = 0.8
       c = 3.

       PAR(1)=a
       PAR(2)=b
       PAR(3)=c

! Forcing parameters
       amp=0.
       beta=10

       PAR(4)=amp
       PAR(5)=beta

       TPI=8*ATAN(1.d0)
       PAR(11)=TPI/beta

!      Initial FHB stationary solution (assuming a=0)
       U(1)= 0.
       U(2)= 0.

! Initialize the oscillator
       U(3)=SIN(TPI*t)
       U(4)=COS(TPI*t)

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


program test_utils

  use mo_kind,        only: sp, dp, i4
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_utils,       only: eq, ge, le, ne
  use mo_utils,       only: equal, greaterequal, lesserequal, notequal
  use mo_utils,       only: swap, locate, cumsum, arange, linspace
  use mo_utils,       only: is_finite, is_nan, is_normal, special_value
  use mo_utils,       only: isin, isinloc

  implicit none

  real(dp) :: a_dp
  real(dp) :: b_dp
  real(sp) :: a_sp
  real(sp) :: b_sp

  integer(i4), parameter :: nn = 100
  real(dp),    dimension(nn) :: dat1, dat2, dat3
  real(sp),    dimension(nn) :: sat1, sat2, sat3
  integer(i4), dimension(nn) :: iat1, iat2, iat3
  complex(dp), dimension(nn) :: cat1, cat2
  real(dp),    dimension(:), allocatable :: adat1
  character(len=10), dimension(nn) :: chat1

  real(dp) :: d1
  real(dp), dimension(5) :: d5
  real(sp) :: s1
  real(sp), dimension(5) :: s5
  integer(i4) :: ii1
  integer(i4), dimension(5) :: ii5

  integer(i4) :: i
  logical  :: isgood
  logical  :: compare

  isgood = .true.

  ! -----------------------------------------------------
  ! DOUBLE PRECISON
  ! -----------------------------------------------------

  write(*,*) ''
  write(*,*) 'Test: eq/equal: dp'
  ! 0.1 == 0.1+eps --> .False.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = eq(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' == ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 == 1.0+eps --> .True.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = eq(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' == ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 == 0.1+eps --> .False.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = equal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' == ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 == 1.0+eps --> .True.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = equal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' == ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  write(*,*) ''
  write(*,*) 'Test: ge/greaterequal: dp'
  ! 0.1 >= 0.1+eps  --> .False.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = ge(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 >= 1.0+eps  --> .True.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = ge(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 >= 0.2  --> .False.
  a_dp = 0.1_dp
  b_dp = 0.2_dp
  compare = ge(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! tiny >= 2*tiny  --> .False.
  a_dp = tiny(1.0_dp)
  b_dp = 2.0_dp*a_dp
  compare = ge(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 0.1 >= 0.1+eps  --> .False.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = greaterequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 >= 1.0+eps  --> .True.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = greaterequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 >= 0.2  --> .False.
  a_dp = 0.1_dp
  b_dp = 0.2_dp
  compare = greaterequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! tiny >= 2*tiny  --> .False.
  a_dp = tiny(1.0_dp)
  b_dp = 2.0_dp*a_dp
  compare = greaterequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' >= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  write(*,*) ''
  write(*,*) 'Test: le/lesserequal: dp'
  ! 0.1 <= 0.1+eps  --> .True.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = le(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 <= 1.0+eps  --> .True.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = le(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 <= 0.2  --> .True.
  a_dp = 0.1_dp
  b_dp = 0.2_dp
  compare = le(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! tiny <= 2*tiny  --> .True.
  a_dp = tiny(1.0_dp)
  b_dp = 2.0_dp*a_dp
  compare = le(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 <= 0.1+eps  --> .True.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = lesserequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 <= 1.0+eps  --> .True.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = lesserequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 <= 0.2  --> .True.
  a_dp = 0.1_dp
  b_dp = 0.2_dp
  compare = lesserequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! tiny <= 2*tiny  --> .True.
  a_dp = tiny(1.0_dp)
  b_dp = 2.0_dp*a_dp
  compare = lesserequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' <= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  write(*,*) ''
  write(*,*) 'Test: ne/notequal: dp'
  ! 0.1 /= 0.1+eps --> .True.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = ne(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' /= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 /= 1.0+eps --> .False.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = ne(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' /= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 0.1 /= 0.1+eps --> .True.
  a_dp = 0.1_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = notequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' /= ',b_dp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 /= 1.0+eps --> .False.
  a_dp = 1.0_dp
  b_dp = a_dp + epsilon(1.0_dp)
  compare = notequal(a_dp, b_dp)
  write(*,'(E24.17,A4,E24.17,A5,L2)') a_dp,' /= ',b_dp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! -----------------------------------------------------
  ! SINGLE PRECISON
  ! -----------------------------------------------------

  write(*,*) ''
  write(*,*) 'Test: eq/ equal: sp'
  ! 0.1 == 0.1+eps --> .False.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = eq(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' == ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 == 1.0+eps --> .True.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = eq(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' == ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 == 0.1+eps --> .False.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = equal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' == ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 == 1.0+eps --> .True.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = equal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' == ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  write(*,*) ''
  write(*,*) 'Test: ge/ greaterequal: sp'
  ! 0.1 >= 0.1+eps  --> .False.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = ge(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 >= 1.0+eps  --> .True.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = ge(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 >= 0.2  --> .False.
  a_sp = 0.1_sp
  b_sp = 0.2_sp
  compare = ge(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! tiny >= 2*tiny  --> .False.
  a_sp = tiny(1.0_sp)
  b_sp = 2.0_sp*a_sp
  compare = ge(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 0.1 >= 0.1+eps  --> .False.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = greaterequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! 1.0 >= 1.0+eps  --> .True.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = greaterequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 >= 0.2  --> .False.
  a_sp = 0.1_sp
  b_sp = 0.2_sp
  compare = greaterequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! tiny >= 2*tiny  --> .False.
  a_sp = tiny(1.0_sp)
  b_sp = 2.0_sp*a_sp
  compare = greaterequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' >= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  write(*,*) ''
  write(*,*) 'Test: le/ lesserequal: sp'
  ! 0.1 <= 0.1+eps  --> .True.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = le(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 <= 1.0+eps  --> .True.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = le(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 <= 0.2  --> .True.
  a_sp = 0.1_sp
  b_sp = 0.2_sp
  compare = le(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! tiny <= 2*tiny  --> .True.
  a_sp = tiny(1.0_sp)
  b_sp = 2.0_sp*a_sp
  compare = le(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 <= 0.1+eps  --> .True.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = lesserequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 <= 1.0+eps  --> .True.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = lesserequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 0.1 <= 0.2  --> .True.
  a_sp = 0.1_sp
  b_sp = 0.2_sp
  compare = lesserequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! tiny <= 2*tiny  --> .True.
  a_sp = tiny(1.0_sp)
  b_sp = 2.0_sp*a_sp
  compare = lesserequal(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' <= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  write(*,*) ''
  write(*,*) 'Test: ne/ notequal: sp'
  ! 0.1 /= 0.1+eps --> .True.
  a_sp = 0.1_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = ne(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' /= ',b_sp,' --> ',compare
  isgood = isgood .and. (compare)

  ! 1.0 /= 1.0+eps --> .False.
  a_sp = 1.0_sp
  b_sp = a_sp + epsilon(1.0_sp)
  compare = ne(a_sp, b_sp)
  write(*,'(E15.8,A4,E15.8,A5,L2)') a_sp,' /= ',b_sp,' --> ',compare
  isgood = isgood .and. (.not. compare)

  ! -----------------------------------------------------
  ! Swap

  call random_number(dat1)
  call random_number(dat2)
  dat3 = dat1
  call swap(dat1, dat2)
  isgood = isgood .and. all(eq(dat2,dat3))

  call swap(dat2, 1, nn)
  call swap(dat2, nn, 1)
  isgood = isgood .and. all(eq(dat2,dat3))

  call random_number(sat1)
  call random_number(sat2)
  sat3 = sat1
  call swap(sat1, sat2)
  isgood = isgood .and. all(eq(sat2,sat3))

  call swap(sat2, 1, nn)
  call swap(sat2, nn, 1)
  isgood = isgood .and. all(eq(sat2,sat3))

  call random_number(dat1)
  call random_number(dat2)
  iat1 = int(dat1, i4)
  iat2 = int(dat2, i4)
  iat3 = iat1
  call swap(iat1, iat2)
  isgood = isgood .and. all(iat2 == iat3)

  call swap(iat2, 1, nn)
  call swap(iat2, nn, 1)
  isgood = isgood .and. all(iat2 == iat3)

  ! -----------------------------------------------------
  ! Locate

  ! double precision
  forall(i=1:nn) dat1(i) = real(i,dp)
  ! 0d
  d1 = 1.1_dp
  ii1 = locate(dat1, d1)
  isgood = isgood .and. (ii1 == 1)
  ! 1d
  d5 = (/ 0.1_dp, 5.5_dp, 10.1_dp, 50.5_dp, 200.1_dp /)
  ii5 = locate(dat1, d5)
  isgood = isgood .and. all(ii5 == (/0, 5, 10, 50, 100/))

  ! single precision
  forall(i=1:nn) sat1(i) = real(i,sp)
  ! 0d
  s1 = 1.1_sp
  ii1 = locate(sat1, s1)
  isgood = isgood .and. (ii1 == 1)
  ! 1d
  s5 = (/ 0.1_sp, 5.5_sp, 10.1_sp, 50.5_sp, 200.1_sp /)
  ii5 = locate(sat1, s5)
  isgood = isgood .and. all(ii5 == (/0, 5, 10, 50, 100/))

  ! -----------------------------------------------------
  ! is_finite, is_nan, is_normal

  call random_number(dat1)
  isgood = isgood .and. all(is_finite(dat1))
  isgood = isgood .and. all(.not. is_nan(dat1))
  isgood = isgood .and. all(is_normal(dat1))
  ! NaN
  dat1(1) = 0.0_dp
  dat1(1) = dat1(1)/dat1(1)
  isgood = isgood .and. any(is_nan(dat1))
  isgood = isgood .and. is_nan(dat1(1))
  ! Inf
  dat1(2) = huge(1.0_dp)
  dat1(2) = dat1(2)*dat1(2)
  isgood = isgood .and. any(.not. is_finite(dat1))
  isgood = isgood .and. (.not. is_finite(dat1(2)))
  ! Both
  isgood = isgood .and. (.not. all(is_normal(dat1)))
  isgood = isgood .and. (.not. any(is_normal(dat1(1:2))))

  call random_number(sat1)
  isgood = isgood .and. all(is_finite(sat1))
  isgood = isgood .and. all(.not. is_nan(sat1))
  isgood = isgood .and. all(is_normal(sat1))
  ! NaN
  sat1(1) = 0.0_sp
  sat1(1) = sat1(1)/sat1(1)
  isgood = isgood .and. any(is_nan(sat1))
  isgood = isgood .and. is_nan(sat1(1))
  ! Inf
  sat1(2) = huge(1.0_sp)
  sat1(2) = sat1(2)*sat1(2)
  isgood = isgood .and. any(.not. is_finite(sat1))
  isgood = isgood .and. (.not. is_finite(sat1(2)))
  ! Both
  isgood = isgood .and. (.not. all(is_normal(sat1)))
  isgood = isgood .and. (.not. any(is_normal(sat1(1:2))))

  ! -----------------------------------------------------
  ! special_value

  isgood = isgood .and. is_nan(special_value(1.0_dp, 'IEEE_SIGNALING_NAN'))
  isgood = isgood .and. is_nan(special_value(1.0_dp, 'IEEE_QUIET_NAN'))
  isgood = isgood .and. (.not. is_finite(special_value(1.0_dp, 'IEEE_POSITIVE_INF')))
  isgood = isgood .and. (.not. is_finite(special_value(1.0_dp, 'IEEE_NEGATIVE_INF')))
  isgood = isgood .and. is_finite(special_value(1.0_dp, 'IEEE_POSITIVE_DENORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_dp, 'IEEE_NEGATIVE_DENORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_dp, 'IEEE_POSITIVE_NORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_dp, 'IEEE_NEGATIVE_NORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_dp, 'IEEE_POSITIVE_ZERO'))
  isgood = isgood .and. is_finite(special_value(1.0_dp, 'IEEE_NEGATIVE_ZERO'))
  isgood = isgood .and. eq(special_value(1.0_dp, 'IEEE_NEGATIVE_INF'), -special_value(1.0_dp, 'IEEE_POSITIVE_INF'))
  isgood = isgood .and. eq(special_value(1.0_dp, 'IEEE_NEGATIVE_DENORMAL'), -special_value(1.0_dp, 'IEEE_POSITIVE_DENORMAL'))
  isgood = isgood .and. eq(special_value(1.0_dp, 'IEEE_NEGATIVE_NORMAL'), -special_value(1.0_dp, 'IEEE_POSITIVE_NORMAL'))
  isgood = isgood .and. eq(special_value(1.0_dp, 'IEEE_NEGATIVE_ZERO'), -special_value(1.0_dp, 'IEEE_POSITIVE_ZERO'))
  isgood = isgood .and. eq(abs(special_value(1.0_dp, 'IEEE_POSITIVE_ZERO')), 0.0_dp)
  isgood = isgood .and. eq(abs(special_value(1.0_dp, 'IEEE_NEGATIVE_ZERO')), 0.0_dp)

  isgood = isgood .and. is_nan(special_value(1.0_sp, 'IEEE_SIGNALING_NAN'))
  isgood = isgood .and. is_nan(special_value(1.0_sp, 'IEEE_QUIET_NAN'))
  isgood = isgood .and. (.not. is_finite(special_value(1.0_sp, 'IEEE_POSITIVE_INF')))
  isgood = isgood .and. (.not. is_finite(special_value(1.0_sp, 'IEEE_NEGATIVE_INF')))
  isgood = isgood .and. is_finite(special_value(1.0_sp, 'IEEE_POSITIVE_DENORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_sp, 'IEEE_NEGATIVE_DENORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_sp, 'IEEE_POSITIVE_NORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_sp, 'IEEE_NEGATIVE_NORMAL'))
  isgood = isgood .and. is_finite(special_value(1.0_sp, 'IEEE_POSITIVE_ZERO'))
  isgood = isgood .and. is_finite(special_value(1.0_sp, 'IEEE_NEGATIVE_ZERO'))
  isgood = isgood .and. eq(special_value(1.0_sp, 'IEEE_NEGATIVE_INF'), -special_value(1.0_sp, 'IEEE_POSITIVE_INF'))
  isgood = isgood .and. eq(special_value(1.0_sp, 'IEEE_NEGATIVE_DENORMAL'), -special_value(1.0_sp, 'IEEE_POSITIVE_DENORMAL'))
  isgood = isgood .and. eq(special_value(1.0_sp, 'IEEE_NEGATIVE_NORMAL'), -special_value(1.0_sp, 'IEEE_POSITIVE_NORMAL'))
  isgood = isgood .and. eq(special_value(1.0_sp, 'IEEE_NEGATIVE_ZERO'), -special_value(1.0_sp, 'IEEE_POSITIVE_ZERO'))
  isgood = isgood .and. eq(abs(special_value(1.0_sp, 'IEEE_POSITIVE_ZERO')), 0.0_sp)
  isgood = isgood .and. eq(abs(special_value(1.0_sp, 'IEEE_NEGATIVE_ZERO')), 0.0_sp)

  ! -----------------------------------------------------
  ! Cumsum
  ! double precision
  dat1(:) = 1.0_dp
  dat2    = cumsum(dat1)
  isgood  = isgood .and. (eq(dat2(1),1.0_dp))
  isgood  = isgood .and. (eq(dat2(nn),real(nn,dp)))
  ! single precision
  sat1(:) = 2.0_sp
  sat2    = cumsum(sat1)
  isgood  = isgood .and. (eq(sat2(1),2.0_sp))
  isgood  = isgood .and. (eq(sat2(nn),real(2*nn,sp)))
  ! integer
  iat1(:) = 3
  iat2    = cumsum(iat1)
  isgood  = isgood .and. (iat2(1) == 3)
  isgood  = isgood .and. (iat2(nn) == 3*nn)
  ! complex
  cat1(:) = (1.0_dp,1.0_dp)
  cat2    = cumsum(cat1)
  isgood  = isgood .and. (eq(real(cat2(1)),1.0_dp))
  isgood  = isgood .and. (eq(aimag(cat2(nn)),real(nn,dp)))

  ! -----------------------------------------------------
  ! Range
  ! double precision
  dat1(:) = 1.0_dp
  dat2    = cumsum(dat1)
  dat1    = arange(real(nn,dp))
  isgood  = isgood .and. all(eq(dat1,dat2))
  ! single precision
  sat1(:) = 2.0_dp
  sat2    = cumsum(sat1)
  sat1    = arange(real(nn,sp)) * 2.0_sp
  isgood  = isgood .and. all(eq(sat1,sat2))
  ! integer
  iat1(:) = 1
  iat2    = cumsum(iat1) - 2
  iat1    = arange(-1,nn-2)
  isgood  = isgood .and. all(iat1==iat2)
  ! allocatable out
  allocate(adat1(nn))
  adat1 = arange(real(nn,dp))

  ! -----------------------------------------------------
  ! Linspace
  ! double precision
  dat1   = arange(real(nn,dp))
  dat2   = linspace(1.0_dp,real(nn,dp),nn)
  isgood = isgood .and. all(eq(dat1,dat2))
  ! single precision
  sat1   = arange(real(nn,sp))/real(nn,sp)
  sat2   = linspace(0.01_sp,1.0_sp,nn)
  isgood = isgood .and. all(eq(sat1,sat2))
  ! integer
  iat1(:) = 3
  iat2    = cumsum(iat1)
  iat1    = linspace(3,3*nn,nn)
  isgood  = isgood .and. all(iat1==iat2)

  ! -----------------------------------------------------
  ! isin
  dat1   = arange(real(nn,dp))
  isgood = isgood .and. isin(1.0_dp, dat1)
  isgood = isgood .and. isin(10.0_dp, dat1)
  isgood = isgood .and. isin(1.0_dp+0.1*epsilon(1.0_dp), dat1)
  isgood = isgood .and. .not. isin(1.1_dp, dat1)
  sat1   = arange(real(nn,sp))/real(nn,sp)
  isgood = isgood .and. isin(0.1_sp, sat1)
  isgood = isgood .and. isin(1.0_sp, sat1)
  iat1   = arange(nn)
  isgood = isgood .and. isin(1, iat1)
  isgood = isgood .and. isin(2_i4, iat1)
  chat1(:)  = 'dummy'
  chat1(1)  = 'one'
  chat1(2)  = 'two'
  chat1(nn) = 'nn'
  isgood = isgood .and. isin('one', chat1)
  isgood = isgood .and. isin(' two ', chat1)
  isgood = isgood .and. .not. isin('100', chat1)

  ! -----------------------------------------------------
  ! isinloc
  dat1   = arange(real(nn,dp))
  isgood = isgood .and. (isinloc(1.0_dp, dat1) == 1)
  isgood = isgood .and. (isinloc(10.0_dp, dat1) == 10)
  isgood = isgood .and. (isinloc(1.0_dp+0.1*epsilon(1.0_dp), dat1) == 1)
  isgood = isgood .and. (isinloc(1.1_dp, dat1) == 0)
  sat1   = arange(real(nn,sp))/real(nn,sp)
  isgood = isgood .and. (isinloc(0.1_sp, sat1) == 10)
  isgood = isgood .and. (isinloc(1.0_sp, sat1) == nn)
  iat1   = arange(nn)
  isgood = isgood .and. (isinloc(1, iat1) == 1_i4)
  isgood = isgood .and. (isinloc(2_i4, iat1) == 2)
  chat1(:)  = 'dummy'
  chat1(1)  = 'one'
  chat1(2)  = 'two'
  chat1(nn) = 'nn'
  isgood = isgood .and. (isinloc('one', chat1) == 1)
  isgood = isgood .and. (isinloc(' two ', chat1) == 2)
  isgood = isgood .and. (isinloc('100', chat1) == 0)

  write(*,*) ''
  if (isgood) then
     write(*,*) 'mo_utils ', color('o.k.', c_green)
  else
     write(*,*) 'mo_utils ', color('failed!', c_red)
  endif

end program test_utils


MODULE MATLIB
	USE NRTYPE
 	IMPLICIT NONE
 	CONTAINS
 	!-----------------------------------------------------------
 	SUBROUTINE FLIP(X)
  	IMPLICIT NONE
  	COMPLEX(DP), DIMENSION(:) :: X
  	X = X(UBOUND(X,1):LBOUND(X,1):-1)
 	END SUBROUTINE FLIP
 	!-----------------------------------------------------------
 	FUNCTION EYE(N) RESULT(M)
  	IMPLICIT NONE
  	INTEGER, INTENT(IN) :: N
  	COMPLEX(DP), DIMENSION(N,N) :: M
  	INTEGER :: I,J
  	DO I = 1,N
   		DO J = 1,N
			IF (I.EQ.J) THEN
    				M(I,J) = 1
			ELSE
				M(I,J) = 0
			END IF
   		END DO
  	END DO
 	END FUNCTION EYE
 	!-----------------------------------------------------------
 	FUNCTION ONES(N) RESULT(M)
  	IMPLICIT NONE
  	INTEGER, INTENT(IN) :: N
  	COMPLEX(DP), DIMENSION(N) :: M
  	INTEGER :: I
  	DO I = 1,N
   		M(I) = 1
  	END DO
 	END FUNCTION ONES
 	!-----------------------------------------------------------
 	FUNCTION DIAG(X) RESULT(M)
  	IMPLICIT NONE
  	COMPLEX(DP), DIMENSION(:) :: X
  	COMPLEX(DP), DIMENSION(SIZE(X,1),SIZE(X,1)) :: M
  	INTEGER :: I, N
  	N = SIZE(X,1)
	M = 0.
  	DO I = 1,N
   		M(I,I) = X(I)
  	END DO
 	END FUNCTION DIAG
 	!-----------------------------------------------------------
 	FUNCTION BAND(E,N) RESULT(M)
  	IMPLICIT NONE
  	INTEGER, INTENT(IN) :: N
  	COMPLEX(DP), INTENT(IN), DIMENSION(:) :: E
  	COMPLEX(DP), DIMENSION(N,N) :: M
  	INTEGER :: I, J, Q, ND
  	ND = SIZE(E)
	IF (MOD(Nd,2).EQ.0) THEN
		STOP 'NDIAG(E,N) : LEN(E) MUST BE ODD'
	END IF
	M = 0.
	Q = (Nd-1)/2		!Nd = 3 gives Q = 2
	DO J = 1,N
		M(J,J) = E(Q+1)
	END DO
  	DO I = 1,Q
		DO J = 1,N-I
			M(J+I,J) = E(Q+1-I)
			M(J,J+I) = E(Q+1+I)
  		END DO
	END DO
 	END FUNCTION
 	!-----------------------------------------------------------
 	FUNCTION INV(A) RESULT(M)
  	IMPLICIT NONE
  	COMPLEX(DP), DIMENSION(:,:), INTENT(IN) :: A
  	COMPLEX(DP), DIMENSION(SIZE(A,1), SIZE(A,2)) :: M
  	COMPLEX(DP), DIMENSION(SIZE(A,1)) :: WORK
  	COMPLEX(DP), DIMENSION(SIZE(A,1)) :: IPIV
  	INTEGER :: N, INFO
  	M = A
  	N = SIZE(A,1)
  	CALL ZGETRF(N,N,M,N,IPIV,INFO)		!LAPACK ROUTINE FOR LU FACTORIZATION
  	IF (INFO/= 0) THEN
   		STOP "WARNING : Input Matrix is singular !"
   	END IF
  	CALL ZGETRI(N,M,N,IPIV,WORK,N,INFO)	!INVERSE OF LU
  	IF (INFO/= 0) THEN
   		STOP "WARNING : Input Matrix is singular !"
  	END IF
 	END FUNCTION INV
	 !-----------------------------------------------------------
END MODULE


module mod_echwsamples

#include "Config.hpp"

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_echwsamples'
 !
 !          Purpose:
 !                   Mathematical representation and computation
 !                   of power weather sample of exponential chirp
 !                    wave radar signal.
 !                   This module also contains subroutines which
 !                   perform computation of signal statistics.
 !          History:
 !                        Date: 01-11-2017
 !                        Time: 10:00 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                  Bernard Gingold
 !
 !          References:
 !
 !                      Doppler Radar and Weather Observations
 !                      Richard L. Dvorak, Dusan S. Zrnic
 !                      pages 67-72
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.
    implicit none
    private
    use module_kinds
    use module_logger, only : log_startup, &
                              log_UsrMsg,  &
                              log_shutdown

    use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT, &
                                stdout=>OUTPUT_UNIT
    use IFPORT,          only : TRACEBACKQQ
    use mod_timer
    use mod_constants,   only : LAM_PINF

    public :: assignment (=)
    public :: operator   (/=)
    public :: operator   (==)
    public :: operator   (>)
    public :: operator   (<)

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter :: MOD_ECHWSAMPLES_MAJOR = 1

    ! Minor version
    integer(I32P), parameter :: MOD_ECHWSAMPLES_MINOR = 0

    ! Micro version
    integer(I32P), parameter :: MOD_ECHWSAMPLES_MICRO = 0

    ! Module full version
    integer(I32P), parameter :: MOD_ECHWSAMPLES_FULLVER = 1000*MOD_ECHWSAMPLES_MAJOR+100*MOD_ECHWSAMPLES_MINOR+ &
                                                          10*MOD_ECHWSAMPLES_MICRO

    ! Module creation date
    character(*),  parameter :: MOD_ECHWSAMPLES_CREATE_DATE = "01-11-2017 10:08 +00200 (WED 01 NOV 2017 GMT+2)"

    ! Module build date  (should be set after successful compilation)
    character(*),  parameter :: MOD_ECHWSAMPLES_BUILD_DATE = " "

    ! Module author short info
    character(*),  parameter :: MOD_ECHWSAMPLES_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter :: MOD_ECHWSAMPLES_DESCRIPT = " Exponential chirp weather  samples."

    !====================================================
    !  Type: ECSWSamples_t
    !====================================================

    type, public :: ECSWSamples_t

          private

          ! Number of echoes
          integer(I32P) :: m_nechoes

          ! Number of composed samples
          integer(I32P) :: m_size

          ! Number of scatterers
          integer(I32P) :: m_scatnum

          ! Time duration of samples interval
          real(R64P) ::   m_Ts

          ! Time duration of single sample
          real(R64P) ::   m_ths

          ! Samples indexing integral array sampID
          integer(I32P), allocatable, dimension(:) :: m_sampID
!DIR$     ATTRIBUTES ALIGN : 64 :: m_sampID

          ! Cached sample signal components

          ! Complex amplitude
          complex(R64P), allocatable, dimension(:) :: m_Ai
!DIR$     ATTRIBUTES ALIGN : 64 :: m_Ai

          ! Samples (IQ) components, one per sample
          complex(R64P), allocatable, dimension(:) :: m_Wi
!DIR$     ATTRIBUTES ALIGN : 64 :: m_Wi

        ! Complex exponential term itself beign a single complex value
        ! of function related to scaterrer distance and to specific bandwidth
          complex(R64P), allocatable, dimension(:) :: m_cexpt
!DIR$    ATTRIBUTES ALIGN : 64 :: m_cexpt

          ! Output members
          ! Power signal composition of sample train (per single sample)
          complex(R64P), allocatable, dimension(:) :: m_Vsamp
!DIR$    ATTRIBUTES ALIGN : 64 :: m_Vsamp

          ! Averaged power specific frequencies of sample train
          complex(R64P), allocatable, dimension(:) :: m_Vsampavg
!DIR$    ATTRIBUTES ALIGN : 64 :: m_Vsampavg

          ! built indicator (logical)
          logical(I32P) :: m_isbuilt

          contains

          !=====================================================
          !  Construction, copying, destruction
          !=====================================================

          procedure, pass(this), public :: init

          procedure, pass(this), public :: copy

          procedure, pass(this), public :: destroy

         !==================================================
         !      Getters
         !==================================================
          procedure, pass(this), public :: get_nechoes

          procedure, pass(this), public :: get_size

          procedure, pass(this), public :: get_scatnum

          procedure, pass(this), public :: get_Ts

          procedure, pass(this), public :: get_ths

          procedure, pass(this), public :: get_sampID

          procedure, pass(this), public :: get_Ai

          procedure, pass(this), public :: get_Wi

          procedure, pass(this), public :: get_cexpt

          procedure, pass(this), public :: get_Vsamp

          procedure, pass(this), public :: get_Vsampavg

          !================================================
          !  Computational procedures
          !================================================

          procedure, pass(this), public :: compute_Vsamp

          procedure, pass(this), public :: compute_Vsampavg

          !=================================================
          !    Read/write procedures
          !=================================================

          procedure, nopass, public :: read_samples

          procedure, nopass, public :: write_samples

    end type ECSWSamples_t

          !==================================================
          !  Module operators
          !==================================================

          interface assignment (=)
             module procedure assign_samples
          end interface

          interface operator   (/=)
             module procedure samples_neq_samples
          end interface

          interface operator   (==)
             module procedure samples_eq_samples
          end interface

          interface operator   (>)
            module procedure  samples_gt_samples
          end interface

          interface operator   (<)
            module procedure  samples_lt_samples
          end interface

    contains

     !========================================!
     !    Implementation                      !
     !========================================!

    !=================================================!
    !  @subroutine: init
    !  Initialization of object state.
    !  Allocation and initialization to default values
    !  of complex arrays (output)
    !  Copying of cached samples component arrays.
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (not in this scope)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine init(this,nechoes,size,scatnum,Ts,ths,Ai, &
                    Wi,cexpt,logging,filename,append,dbg,verbose,err )
          implicit none
          class(ECSWSamples_t),           intent(inout) :: this
          integer(I32P),                  intent(in)    :: nechoes,size,scatnum
          real(R64P),                     intent(in)    :: Ts,ths
          complex(R64P), dimension(size), intent(in)    :: Ai
!DIR$     ASSUME_ALIGNED Ai:64
          complex(R64P), dimension(size), intent(in)    :: Wi
!DIR$     ASSUME_ALIGNED Wi:64
          complex(R64P), dimension(size), intent(in)    :: cexpt
!DIR$     ASSUME_ALIGNED cexpt:64
          logical(I32P),                  intent(in)    :: logging
          character(len=*),               intent(in)    :: filename
          logical(I32P),                  intent(in)    :: append,dbg,verbose
          integer(I32P),                  intent(inout) :: err
          ! Locals
          character(len=40)  :: sdate,stime
          character(len=256) :: emsg
          integer(I32P)      :: i,aerr
          integer(BOOL)      :: ifail
          logical(I32P)      :: bfail
          ! Start of executable sttements
          if(err < 0) err = 0
          if(this%m_isbuilt == .true.) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:283, In->mod_echwsamples/init: ECSWSamples_t already initialized!!")
                  call log_shutdown()
              else if(verbose == .true.) then

                      call DATE_AND_TIME(date=sdate,time=stime)
                      write(stderr,*) "===========================NON-FATAL=========================="
                      write(sdterr,*) " ( mod_echwsamples/init:283, ECSWSample_t already initialized!!)"
                      write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                      write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          if(nechoes <  1       .OR. &
             size    <= 1       .OR. &
             Ts      <= 0._R64P .OR. &
             ths     <= 0._R64P ) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:303, In->mod_echwsamples/init: Invalid argument(s) in subroutine: init.")
                  call log_shutdown()
              else if(verbose == .true.) then
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================NON-FATAL=========================="
                  write(sdterr,*) " ( mod_echwsamples/init:303, Invalid argument(s) in subroutine: init.)"
                  write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -2
              return
          end if
          ! Begin construction
          this%m_nechoes = nechoes
          this%m_size    = size
          this%m_scatnum = scatnum
          this%m_Ts      = Ts
          this%m_ths     = this%m_Ts/REAL(size,R64P)
          ! Array members allocation
          associate(dim1=>this%m_size)
              allocate(this%m_sampID(dim1),   &
                       this%m_Ai(dim1),       &
                       this%m_Wi(dim1),       &
                       this%m_cexpt(dim1),    &
                       this%m_Vsamp(dim1),    &
                       this%m_Vsampavg(dim1), &
                       STAT=aerr,             &
                       ERRMSG=emsg)
          end associate
          if(aerr /= 0) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:338,In->mod_echwsamples/init: Memory allocation failure!!")
                  call log_shutdown()
              else if(verbose == .true.) then
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================FATAL=========================="
                  write(stderr,*) " ( mod_echwsamples/init:338, Memory allocation failure)"
                  write(stderr,*) " System message: ", emsg
                  write(stderr,*) " ( Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================FATAL=========================="
              end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_echwsamples/init:338 -> [FATAL-ERROR]: Terminating execution!!"
          end if
         ! Arrays initialization
!DIR$    SIMD
          do i = 1, this%m_size
              this%m_sampID(i) = i
              this%m_Ai(i)     = A(i)
              this%m_Wi(i)     = Wi(i)
              this%m_cexpt(i)  = cexpt(i)
              this%m_Vsamp(i)  = DCMPLX(LAM_PIMF,LAM_PINF)
              this%m_Vsampavg(i) = DCMPLX(LAM_PINF,LAM_PINF)
          end do
          this%m_isbuilt = .true.
          if(dbg == .true.) then
             print*, "samples ID:                ", this%m_sampID
             print*, "Complex amplitude:         ", this%m_Ai
             print*, "IQ components:             ", this%m_Wi
             print*, "Exponential term:          ", this%m_cexpt
             print*, "V samp (default init):     ", this%m_Vsamp
             print*, "V samp avg (default init): ", this%m_Vsampavg
          end if
    end subroutine

    !=================================================!
    !  @subroutine: copy
    !  @Purpose:
    !            Copying of object state.
    !            Deep copy semantics in use.
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (not in this scope)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine copy(this,other,logging,filename,append,err)
          implicit none
          class(ECSWSamples_t),  intent(inout) :: this
          class(ECSWSamples_t),  intent(in)    :: other
          logical(I32P),         intent(in)    :: logging
          character(len=*),      intent(in)    :: filename
          logical(I32P),         intent(in)    :: append
          integer(I32P),         intent(inout) :: err
          ! Locals
          character(len=40) :: sdate,stime
          ! Start of executable statements
          if(err < 0) err = 0
          if(this%m_isbuilt == .true.) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:413, In->mod_echwsamples/copy: ECSWSamples_t already initialized!!")
                  call log_shutdown()
              else if(verbose == .true.) then

                      call DATE_AND_TIME(date=sdate,time=stime)
                      write(stderr,*) "===========================NON-FATAL=========================="
                      write(sdterr,*) " ( mod_echwsamples/copy:413, ECSWSample_t already initialized!!)"
                      write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                      write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          ! Begin copy-construction
          this%m_nechoes  = other%m_nechoes
          this%m_size     = other%m_size
          this%m_scatnum  = other%m_scatnum
          this%m_Ts       = other%m_Ts
          this%m_ths      = other%m_ths
          this%m_sampID   = other%m_sampID
          this%m_Ai       = other%m_Ai
          this%m_Wi       = other%m_Wi
          this%m_cexpt    = other%m_cexpt
          this%m_Vsamp    = other%m_Vsamp
          this%m_Vsampavg = other%m_Vsampavg
          this%m_isbuilt  = .true.
    end subroutine

    !=================================================!
    !  @subroutine: destroy
    !  @Purpose:
    !            Destroys object state by allocatble
    !            arrays deallocation and setting
    !            member scalar variables to default values.
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (not in this scope)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine destroy(this,logging,filename,append,err)
          implicit none
          class(ECSWSamples_t), intent(inout) :: this
          logical(I32P),        intent(in)    :: logging
          character(len=*),     intent(in)    :: filename
          logical(I32P),        intent(in)    :: append
          integer(I32P),        intent(inout) :: err
          ! Locals
          character(len=40)  :: sdate,stime
          character(len=256) :: emsg
          integer(I32P)      :: derr
          ! Start of executable statements
          ! Sanity check on err parameter
          if(err < 0) err = 0
          if(this%m_isbuilt == .true.) then
              if(logging == .true.) then
                      call log_startup(filename,append)
                      call log_UsrMsg("logger:483, In->mod_echwsamples/destroy: ECSWSamples_t already destroyed!!")
                      call log_shutdown()
              else if(verbose == .true.) then

                      call DATE_AND_TIME(date=sdate,time=stime)
                      write(stderr,*) "===========================NON-FATAL=========================="
                      write(sdterr,*) " ( mod_echwsamples/destroy:483, ECSWSample_t already destroyed!!)"
                      write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                      write(stderr,*) "===========================NON-FATAL=========================="
              end if
              err = -1
              return
          end if
          this%m_nechoes = 0
          this%m_size    = 0
          this%m_scatnum = 0
          this%m_Ts      = LAM_PINF
          this%m_ths     = LAM_PINF
          deallocate(this%m_sampID,   &
                     this%m_Ai,       &
                     this%m_Wi,       &
                     this%m_cexpt,    &
                     this%m_Vsamp,    &
                     this%m_Vsampavg, &
                     STAT=derr,       &
                     ERRMSG=emsg )
          if(derr /= 0) then
              if(logging == .true.) then
                  call log_startup(filename,append)
                  call log_UsrMsg("logger:514,In->mod_echwsamples/destroy: Memory deallocation failure!!")
                  call log_shutdown()
              else if(verbose == .true.) then
                  call DATE_AND_TIME(date=sdate,time=stime)
                  write(stderr,*) "===========================FATAL=========================="
                  write(stderr,*) " ( mod_echwsamples/destroy:514, Memory deallocation failure)"
                  write(stderr,*) " System message: ", emsg
                  write(stderr,*) " ( Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
                  write(stderr,*) "===========================FATAL=========================="
              end if
!DIR$         IF (SHOW_CALLSTACK .EQ. 1)
              call TRACEBACKQQ(STRING="FATAL-ERROR", USER_EXIT_CODE= -1)
!DIR$         ENDIF
              ERROR STOP "mod_echwsamples/destroy:514 -> [FATAL-ERROR]: Terminating execution!!"
          end if
          this%m_isbuilt = .false.
    end subroutine

    !====================================================
    !  @function: pure get_nechoes
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_nechoes
!DIR$ ENDIF
    pure function get_nechoes(this) result(nechoes)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nechoes
          ! Start of executable statemetns
          nechoes = this%m_nechoes
    end function

    !====================================================
    !  @function: pure get_size
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_size
!DIR$ ENDIF
    pure function get_size(this) result(nsize)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nsize
          ! Start of executable statemetns
          nsize = this%m_size
    end function

    !====================================================
    !  @function: pure get_scatnum
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_scatnum
!DIR$ ENDIF
    pure function get_scatnum(this) result(scatnum)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P) :: scatnum
          ! Start of executable statements
          scatnum = this%m_scatnum
    end function

    !====================================================
    !  @function: pure get_Ts
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Ts
!DIR$ ENDIF
    pure function get_Ts(this) result(Ts)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          real(R64P) :: Ts
          ! Start of executable statemetns
          Ts = this%m_Ts
    end function

    !====================================================
    !  @function: pure get_ths
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_ths
!DIR$ ENDIF
    pure function get_ths(this) result(ths)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          real(R64P) :: ths
          ! Start of executable statemetns
          ths = this%m_ths
    end function

    !====================================================
    !  @function: pure get_sampID
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_sampID
!DIR$ ENDIF
    pure function get_sampID(this) result(sampID)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          integer(I32P), allocatable, dimension(:) :: sampID
!DIR$     ATTRIBUTES ALIGN : 64 :: sampID
          ! Start of executable statements
          sampID = this%m_sampID
    end function

    !====================================================
    !  @function: pure get_Ai
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Ai
!DIR$ ENDIF
    pure function get_Ai(this) result(Ai)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: Ai
!DIR$     ATTRIBUTES ALIGN : 64 :: Ai
          ! Start of executable statemetns
          Ai = this%m_Ai
    end function

    !====================================================
    !  @function: pure get_Wi
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Wi
!DIR$ ENDIF
    pure function get_Wi(this) result(Wi)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: Wi
!DIR$     ATTRIBUTES ALIGN : 64 :: Wi
          ! Start of executable statemetns
          Wi = this%m_Wi
    end function

    !====================================================
    !  @function: pure get_cexpt
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_cexpt
!DIR$ ENDIF
    pure function get_cexpt(this) result(cexpt)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: cexpt
!DIR$     ATTRIBUTES ALIGN : 64 :: cexpt
          ! Start of executable statemetns
          cexpt = this%m_cexpt
    end function

    !====================================================
    !  @function: pure get_Vsamp
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Vsamp
!DIR$ ENDIF
    pure function get_Vsamp(this) result(Vsamp)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: Vsamp
!DIR$     ATTRIBUTES ALIGN : 64 :: Vsamp
          ! Start of executable statements
          Vsamp = this%m_Vsamp
    end function

    !====================================================
    !  @function: pure get_Vsampavg
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_Vsampavg
!DIR$ ENDIF
    pure function get_Vsampavg(this) result(Vsampavg)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          complex(R64P), allocatable, dimension(:) :: Vsampavg
!DIR$     ATTRIBUTES ALIGN : 64 :: Vsampavg
          ! Start of executable statemetms
          Vsampavg = this%m_Vsampavg
    end function

    !====================================================
    !  @function: pure get_isbuilt
    !  @Puprose:
    !              getter
    !====================================================
!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_isbuilt
!DIR$ ENDIF
    pure function get_isbuilt(this) result(isbuilt)
          implicit none
          class(ECSWSamples_t), intent(in) :: this
          ! Locals
          logical(I32P) :: isbuilt
          ! Start of executable statemetns
          isbuilt = this%m_isbuilt
    end function

    !=================================================!
    !  @subroutine: compute_Vsamp
    !  @Purpose:
    !            Performs computation of weather radar
    !            signal samples and stores them in
    !            member array m_Vsamp
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (in this case)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !=================================================!
    subroutine compute_Vsamp(this,err,fpflags,verbose)
          use mod_constants, only : LAM_ISQRT2,LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exception
!DIR$     ENDIF
          implicit none
          class(ECSWSamples_t),                  intent(inout) :: this
          integer(I32P),               intent(inout)           :: err
          logical(I32P), dimension(5), intent(inout), optional :: fpflags
          logical(I32P),               intent(in)              :: verbose
          ! Locals
          complex(R64P) :: tmp
          integer(I32P) :: i,j
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type) :: status_value
!DIR$     ENDIF
          ! Start of executable statements
          ! Sanity check on input arguments
          if(err < 0) err = 0
          if(present(fpflags) == .true.) then
              if(ANY(fpflags) == .true.) then
                  fpflags = .false.
              end if
          end if
          tmp = LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          if(present(fpflags) == .true.) then
              call ieee_get_status(status_value)
              call ieee_set_handling_mode(ieee_all,.false.)
              call ieee_set_flags(ieee_all,fpflags)
          else
              WRITE(stderr,*) "mod_echwsamples/compute_Vsamp:801 -- optional parameter: fpflags - not present!!"
          end if
!DIR$     ENDIF
          do i = 1, this%m_size
!DIR$     SIMD
              do j = 1, this%m_size
                  tmp = tmp+(this%m_Ai(j)*this%m_Wi(j)*this%m_cexpt(j))
                  tmp = tmp*LAM_ISQRT2
                  this%m_Vsamp(i) = tmp
              end do
          end do
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          if(present(fpflags) == .true.) then
              call ieee_get_flag(ieee_all,fpflags)
                 if(ANY(fpflags) == .true.) then
                     if(present(verbose) .AND. verbose == .true.) then
                          WRITE(stderr,*) "=============================================================================="
                          WRITE(stderr,*) "  mod_echwsamples/compute_Vsamp:812 -- Floating-point exception(s) occurred!!"
                          WRITE(stderr,*) "==============================================================================="
                     end if
                     err = -3
                 end if
          end if
!DIR$     ENDIF
    end subroutine

    !=================================================!
    !  @subroutine: compute_Vsampavg
    !  @Purpose:
    !            Performs computation of weather radar
    !            signal samples averaged over frequency cycle
    !            and stores them in member array mVsampavg.
    !
    !  @Warning
    !            Upon detection of non-fatal error
    !            variable 'err' will be set to -1
    !            Upon detection of fatal error like
    !            failed memory allocation 'STOP'
    !            will be executed.
    !            Values of variable 'err'
    !   1) -1 -- Object built already
    !   2) -2 -- Invalid argument (any of them)
    !   3) -3 -- Floating-point arithmentic error
    !            (general error) (in this case)
    !   4) -4 -- Overflow
    !   5) -5 -- Underflow
    !   6) -6 -- Inexact
    !   7) -7 -- Denormal
    !   8) -8 -- Cancellation error (cadna)
    !   9) -9 -- Optional argument not present
    !=================================================!
    subroutine compute_Vsampavg(this,err,fpflags,verbose)
          use mod_constants, only : LAM_HR64P,LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exception
!DIR$     ENDIF
          implicit none
          class(ECSWSamples_t),       intent(inout)           :: this
          integer(I32P),              intent(inout)           :: err
          logical(I32P), dimension(5),intent(inout), optional :: fpflags
          logical(I32P),              intent(in),    optional :: verbose
          ! locals
          complex(R64P) :: tmp
          integer(I32P) :: i,j
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type) :: status_value
!DIR$     ENDIF
          ! Start of executable statements
          ! Sanity check on input arguments
          if(err < 0) err = 0
          if(present(fpflags) == .true.) then
              if(ANY(fpflags) == .true.) then
                  fpflags = .false.
              end if
          end if
          tmp = LAM_ZC
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          if(present(fpflags) == .true.) then
              call ieee_get_status(status_value)
              call ieee_set_handling_mode(ieee_all,.false.)
              call ieee_set_flags(ieee_all,fpflags)
          else
              WRITE(stderr,*) "mod_echwsamples/compute_Vsampavg:877 -- Optional argument: fplfags -- not present!!"
          end if
!DIR$     ENDIF
          do i = 1, this%m_size
!DIR$     SIMD
              do j = 1, this%m_size
                  tmp = tmp+(this%m_Ai(j)*DCONJG(this%m_Ai(j))* &
                         this%m_Wi(j)*DCONJG(this%m_Wi(j))*this%m_cexpt(j))
                  tmp = tmp*LAM_HR64P
                  this%m_Vsampavg(i) = tmp
              end do
          end do
!DIR$     IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          if(present(fpflags) == .true.) then
              call ieee_get_flag(ieee_all,fpflags)
                 if(ANY(fpflags) == .true.) then
                     if(present(verbose) .AND. verbose == .true.) then
                          WRITE(stderr,*) "=============================================================================="
                          WRITE(stderr,*) "  mod_echwsamples/compute_Vsampavg:897 -- Floating-point exception(s) occurred!!"
                          WRITE(stderr,*) "==============================================================================="
                     end if
                     err = -3
                 end if
          end if
!DIR$     ENDIF
    end subroutine

    !=================================================!
    !  @subroutine: read_samples
    !  @Purpose:
    !            read/write
    !=================================================!
    subroutine read_samples(this,form,unit,ioerr)
          implicit none
          class(ECSWSamples_t), intent(in)    :: this
          character(len=*),     intent(in)    :: form
          integer(I32P),        intent(in)    :: unit
          integer(I32P),        intent(inout) :: ioerr
          ! Stat of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine

     !=================================================!
    !  @subroutine: write_samples
    !  @Purpose:
    !            read/write
    !=================================================!
    subroutine write_samples(this,form,unit,ioerr)
          implicit none
          class(ECSWSamples_t), intent(in)    :: this
          character(len=*),     intent(in)    :: form
          integer(I32P),        intent(in)    :: unit
          integer(I32P),        intent(inout) :: ioerr
          ! Stat of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine

    !==============================================
    !               Module operators
    !==============================================

    !==============================================
    !   subroutine: assignment (=)
    !==============================================
    subroutine assign_samples(this,other)
          implicit none
          type(ECSWSamples_t), intent(inout) :: this
          type(ECSWSamples_t), intent(in)    :: other
          ! Locals
          character(len=40) :: sdate,stime
          ! Start of executable statemetns
          if(LOC(this) == LOC(other)) then
               call DATE_AND_TIME(date=sdate,time=stime)
               write(stderr,*) "===========================NON-FATAL=========================="
               write(sdterr,*) " ( mod_echwsamples/assignment(=):964, Attempted self_assignment!)"
               write(stderr,*) " ( Non-Fatal Error at:) ",  &
                                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                                     stime(1:2),":",stime(3:4),":",stime(5:6)
               write(stderr,*) "===========================NON-FATAL=========================="
               return
          end if
          this%m_nechoes    = other%m_nechoes
          this%m_size       = other%m_size
          this%m_scatnum    = other%m_scatnum
          this%m_Ts         = other%m_Ts
          this%m_ths        = other%m_ths
          this%m_sampID     = other%m_sampID
          this%m_Ai         = other%m_Ai
          this%m_Wi         = other%m_Wi
          this%m_cexpt      = other%m_cexpt
          this%m_Vsamp      = other%m_Vsamp
          this%m_Vsampavg   = other%m_Vsampavg
          this%m_isbuilt    = other%m_isbuilt
    end subroutine

    !=====================================================60
    ! function: samples_neq_samples i.e. overloaded
    !           operator (/=)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_neq_samples(s1,s2) result(neq)
          use module_helper_fields_equality, only : Pair1D_t
          implicit none
          type(ECSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Pair1D_t) :: neq
          ! Start of executable statemetns
          neq%x = s1%m_Vsamp    /= s2%m_Vsamp
          neq%y = s1%m_Vsampavg /= s2%m_Vsampavg
    end function

    !======================================================60
    ! function: samples_eq_samples i.e. overloaded
    !           operator (==)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_eq_samples(s1,s2) result(eq)
          use module_helper_fields_equality, only : Pair1D_t
          implicit none
          type(ECSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Par1D_t) :: eq
          ! Start of executable statements
          eq%x = s1%m_Vsamp    == s2%m_Vsamp
          eq%y = s1%m_Vsampavg == s2%m_Vsampavg
    end function

    !======================================================60
    ! function: samples_gt_samples i.e. overloaded
    !           operator (>)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_gt_samples(s1,s2) result(gt)
          use module_helper_fields_equality, only : Pair1D_t
          implicit none
          type(ECSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Par1D_t) :: gt
          ! Start of executable statements
          gt%x = s1%m_Vsamp    == s2%m_Vsamp
          gt%y = s1%m_Vsampavg == s2%m_Vsampavg
    end function

    !======================================================60
    ! function: samples_lt_samples i.e. overloaded
    !           operator (<)
    ! Warning:  No error checking is made!!
    !           Both arguments should be the same i.e.
    !           Same arrays size.
    !======================================================60
    function samples_lt_samples(s1,s2) result(lt)
          use module_helper_fields_equality, only : Pair1D_t
          implicit none
          type(ECSWSamples_t), intent(in) :: s1,s2
          ! Locals
          type(Par1D_t) :: lt
          ! Start of executable statements
          lt%x = s1%m_Vsamp    == s2%m_Vsamp
          lt%y = s1%m_Vsampavg == s2%m_Vsampavg
    end function

end module mod_echwsamples


c
c input:           * ** ****
      subroutine rms(y,ny,nrms,xnoise)
c
c  For the array Y, evaluate the RMS average of
c  the noise sample in "nrms" points about the
c  location "ny".
c
      real*4 y(*)

      jstart = ny - nrms/2
      jstart = max0(1,jstart)
      jend = jstart+nrms-1
      if(jend.le.jstart)return
      xmean = 0.
      do j=jstart,jend
        xmean = xmean+y(j)
      enddo
      xmean=xmean/float(jend-jstart+1)
      sum = 0.
      do j=jstart,jend
        sum = sum + (y(j)-xmean)**2
      enddo
      xnoise = sqrt( sum/float(jend-jstart+1) )
      return
      end


!********************************************************************************
!>
! THE EXAMPLE IS TO CHOOSE PARAMETERS A, B, C, AND D TO MINIMIZE
!
! MAX{ MAX (|F(X,Y) - (AX+BY+C)/(DX+1)|, |(AX+BY+C)/(DX+1)|) :
! (X,Y) IN Z}
!
! SUBJECT TO THE CONSTRAINTS
!
! DX+1 >= EPS FOR (X,Y) IN Z,
!
! AND THE FIRST PARTIAL DERIVATIVE OF (AX+BY+C)/(DX+1) WITH RESPECT TO
! X IS <= 0.0 AT (X,Y) = (0.0,0.0).
!
! HERE WE ARE TAKING Z = {(0.0,0.0), (0.0,1.0), (-2.0/3.0,1.0/3.0),
! (1.0,1.0), (1.0,2.0)}, EPS = .0001, F(0.0,0.0) = .5, F(0.0,1.0) = 1.0,
! F(-2.0/3.0,1.0/3.0) = -1.0, F(1.0,1.0) =1.5, F(1.0,2.0) =-1.0,
! AND TAKING THE INITIAL GUESSES FOR THE PARAMETERS TO BE
! A = B = C = D = 0.0
!
! TO USE CONMAX, WE WRITE THIS PROBLEM AS THE OPTIMIZATION PROBLEM
!
! MINIMIZE W, SUBJECT TO
!
! |F(X,Y) - (AX+BY+C)/(DX+1)| <= W, (X,Y) IN Z,    (TYPE 2)
!
!            (AX+BY+C)/(DX+1) <= W, (X,Y) IN Z,    (TYPE 1)
!
!           -(AX+BY+C)/(DX+1) <= W, (X,Y) IN Z,    (TYPE 1)
!
!               -DX - 1 + EPS <= 0, (X,Y) IN Z,    (TYPE -1)
!
!                      A - CD <= 0.                (TYPE -2)
!
! ONE CAN PROVE THAT THE UNIQUE BEST VALUES ARE A = -B = C = D = 1.0,
! WITH W (= ENORM = ERROR(NUMGR+1)) = 1.0.  ONE CAN ALSO PROVE THAT
! THERE ARE LOCAL SOLUTIONS WHICH ARE NOT GLOBAL SOLUTIONS, THAT IS,
! SOLUTIONS FOR WHICH W CANNOT BE REDUCED BY SMALL CHANGES IN A, B, C,
! AND D, BUT FOR WHICH A, B, C, D CAN BE FOUND SATISFYING THE CONSTRAINTS
! AND GIVING SMALLER W.  SOME SUCH SOLUTIONS ARE GIVEN BY A = B = D = 0.0,
! C = 0.25, WITH W = 1.25, AND OTHER CHOICES WHERE THE RATIONAL FUNCTION
! REDUCES TO THE CONSTANT 0.25 AND THE COEFFICIENTS SATISFY THE CONSTRAINTS.
! WHEN THE PROGRAM IS RUN, ANY OF THESE SOLUTIONS MAY BE FOUND (UP TO A
! SMALL DISCREPANCY DUE IN PART TO ROUNDOFF), DEPENDING ON THE ACCURACY OF
! THE COMPUTER BEING USED.
!
! THE OUTPUT FOR THE SAMPLE DRIVER AND FNSET FOLLOWS.  THIS WAS RUN ON
! A MAC SE (WITH ONE MEGABYTE OF RAM) WITH D1MACH(3) SET TO 16.0D0**(-14)
! USING THE ABSOFT MACFORTRAN COMPILER (VERSION 2.4);  RUNS WITH A
! DIFFERENT MACHINE AND/OR A DIFFERENT D1MACH(3) AND/OR A DIFFERENT
! COMPILER COULD PRODUCE DIFFERENT RESULTS, ESPECIALLY CONSIDERING THE
! POSSIBILITY OF LOCAL SOLUTIONS WHICH ARE NOT GLOBALY BEST.
!
! IOPTN IS    0  NPARM IS   4  NUMGR IS  21
!
! ITLIM IS  100  IFUN IS  5  IPTB IS  6  INDM IS  2
!
! THE FUNCTION VALUES ARE
!    0.50000E+00    0.10000E+01   -0.10000E+01    0.15000E+01
!   -0.10000E+01
!
! THE POINTS ARE
!    0.00000E+00    0.00000E+00
!    0.00000E+00    0.10000E+01
!   -0.66667E+00    0.33333E+00
!    0.10000E+01    0.10000E+01
!    0.10000E+01    0.20000E+01
!
! EPS IS    0.10000E-03
!
! THE INITIAL PARAMETERS ARE
!
!   0.00000000000000E+00   0.00000000000000E+00   0.00000000000000E+00
!
!   0.00000000000000E+00
!
! *****AFTER CONMAX ITER IS  13  LIWRK IS  178  LWRK IS   720
!
! THE FINAL PARAMETERS ARE
!
!  -0.90123453614326E-02  -0.12378422071992E-12   0.25000000000006E+00
!
!  -0.36049381446237E-01
!
! THE ERROR NORMS ARE
!
!    0.1250000000000E+01   -0.9638506185538E+00    0.1288396472843E-12
!
! THE ERRORS ARE
!
!   0.24999999999994E+00   0.75000000000006E+00  -0.12499999999999E+01
!   0.12499999999999E+01  -0.12499999999999E+01   0.25000000000006E+00
!  -0.25000000000006E+00   0.24999999999994E+00  -0.24999999999994E+00
!   0.24999999999994E+00  -0.24999999999994E+00   0.25000000000006E+00
!  -0.25000000000006E+00   0.24999999999994E+00  -0.24999999999994E+00
!  -0.99990000000000E+00  -0.99990000000000E+00  -0.10239329209642E+01
!  -0.96385061855376E+00  -0.96385061855376E+00   0.12883964728427E-12
!

!
! THIS TEST DRIVER PROGRAM AND FNSET ARE SET UP TO CHOOSE REAL (DOUBLE
! PRECISION) PARAMETERS A, B, C, AND D TO MINIMIZE
!
! MAX{ MAX (|F(X,Y) - (AX+BY+C)/(DX+1)|, |(AX+BY+C)/(DX+1)|) : (X,Y) IN Z}
!
! SUBJECT TO THE CONSTRAINTS
!
! DX+1 >= EPS FOR (X,Y) IN Z,
!
! AND THE FIRST PARTIAL DERIVATIVE OF (AX+BY+C)/(DX+1) WITH RESPECT TO
! X IS <= 0.0 AT (X,Y) = (0.0,0.0).
!
! HERE WE ARE TAKING:
!
!  * Z = {(0.0,0.0), (0.0,1.0), (-2.0/3.0,1.0/3.0), (1.0,1.0), (1.0,2.0)},
!  * EPS = 0.0001
!  * F(0.0,0.0)          =  0.5
!  * F(0.0,1.0)          =  1.0
!  * F(-2.0/3.0,1.0/3.0) = -1.0
!  * F(1.0,1.0)          =  1.5
!  * F(1.0,2.0)          = -1.0
!
! AND TAKING THE INITIAL GUESSES FOR THE PARAMETERS TO BE:
!
!  * A = B = C = D = 0.0

module tstot_test_module

    use conmax_module, only: conmax_solver
    use iso_fortran_env, only: wp => real64, output_unit

    implicit none

    private

    type, extends(conmax_solver) :: my_solver
    contains
        procedure :: fnset => my_fnset
    end type my_solver

    public :: tstot_test

contains

    subroutine tstot_test()

        implicit none

        real(wp), parameter :: zero  = 0.0_wp
        real(wp), parameter :: one   = 1.0_wp
        real(wp), parameter :: two   = 2.0_wp
        real(wp), parameter :: three = 3.0_wp
        integer, parameter  :: nwrit = output_unit

        real(wp) :: eps, error(24), fun(5), param(4), pttbl(6, 2), &
                    work(720)
        integer :: i, ifun, indm, ioptn, iptb, iter, itlim, &
                   iwork(178), j, liwrk, lwrk, nparm, numgr
        type(my_solver) :: solver

        !OPEN(6,FILE='TSTOT')

        ! SET PARAMETERS FOR CONMAX.
        !
        ! SET IOPTN=0 SINCE NO EXTRA OPTIONS ARE TO BE USED.
        ioptn = 0
        !
        ! SET NPARM=4 SINCE THERE ARE 4 PARAMETERS (VARIABLES) A, B, C, AND D.
        nparm = 4
        !
        ! SET NUMGR=21 SINCE THERE ARE 21 CONSTRAINTS (5 OF TYPE 2, 10 OF TYPE 1,
        ! 5 OF TYPE -1, AND ONE OF TYPE -2).
        numgr = 21
        !
        ! SET ITLIM=100, OR WHATEVER LIMIT IS DESIRED ON THE NUMBER OF ITERATIONS.
        itlim = 100
        !
        ! SET IFUN=5 (OR GREATER) SINCE THERE ARE 5 TYPE 2 CONSTRAINTS, AND USE
        ! THIS NUMBER AS THE DIMENSION OF FUN ABOVE.
        ifun = 5
        !
        ! SET IPTB=6 (OR GREATER) AND SET INDM=2 (OR GREATER), SINCE THE GREATEST
        ! FIRST SUBSCRIPT WE WILL USE IN PTTBL IS 6, AND THE GREATEST SECOND
        ! SUBSCRIPT WE WILL USE IN PTTBL IS 2.  WE USE THESE NUMBERS TO DIMENSION
        ! PTTBL ABOVE.  NOTE THAT IT IS ESSENTIAL THAT THE FIRST DIMENSION OF
        ! PTTBL BE EXACTLY IPTB.
        iptb = 6
        indm = 2
        !
        ! SET LIWRK=178 (OR GREATER), AND USE THIS NUMBER TO DIMENSION LIWRK
        ! ABOVE, BECAUSE OF THE COMPUTATION 7*21 + 7*4 + 3 = 178 (SEE CONMAX
        ! USERS GUIDE FOR AN EXPLANATION OF THIS AND OF LWRK BELOW).
        liwrk = 178
        !
        ! SET LWRK=720 (OR GREATER), AND USE THIS NUMBER TO DIMENSION LWRK ABOVE,
        ! BECAUSE OF THE COMPUTATION 2*4**2 + 4*21*4 + 11*21 + 27*4 + 13 = 720.
        lwrk = 720
        !
        ! THE DIMENSION OF PARAM ABOVE MUST BE NPARM (I.E. 4) OR GREATER, AND THE
        ! DIMENSION OF ERROR ABOVE MUST BE NUMGR+3 (I.E. 24) OR GREATER.
        !
        ! SET THE VALUES OF THE FUNCTION F.
        fun(1) = one/two
        fun(2) = one
        fun(3) = -one
        fun(4) = three/two
        fun(5) = -one
        !
        ! SET THE COORDINATES OF THE FIVE POINTS.
        pttbl(1, 1) = zero
        pttbl(1, 2) = zero
        pttbl(2, 1) = zero
        pttbl(2, 2) = one
        pttbl(3, 1) = -two/three
        pttbl(3, 2) = one/three
        pttbl(4, 1) = one
        pttbl(4, 2) = one
        pttbl(5, 1) = one
        pttbl(5, 2) = two
        !
        ! PUT EPS IN PTTBL(6,1) FOR TRANSMITTAL TO FNSET.  THIS IS WHY WE NEEDED
        ! IPTB TO BE AT LEAST 6.
        eps = (5*two)**(-4)
        pttbl(6, 1) = eps
        !
        ! SET THE INITIAL GUESSES FOR THE PARAMETERS.
        param(1) = zero
        param(2) = zero
        param(3) = zero
        param(4) = zero
        !
        ! WRITE THE INITIAL DATA.
        write (nwrit, 99001) ioptn, nparm, numgr, itlim, ifun, iptb, &
            indm
99001   format(/' IOPTN IS', i5, '  NPARM IS', i4, '  NUMGR IS', &
                i4//' ITLIM IS', i5, '  IFUN IS', i3, '  IPTB IS', i3, &
                '  INDM IS', i3)
        write (nwrit, 99002) (fun(i), i=1, 5)
99002   format(/' THE FUNCTION VALUES ARE'/(4e15.5))
        write (nwrit, 99003)
99003   format(/' THE POINTS ARE')
        do i = 1, 5
            write (nwrit, 99004) (pttbl(i, j), j=1, indm)
99004       format(2e15.5)
        end do
        write (nwrit, '(/A,e15.5)') ' EPS IS', eps
        write (nwrit, '(/A/,*(/3e23.14))') ' THE INITIAL PARAMETERS ARE', param(1:nparm)

        ! NOW CALL CONMAX.
        call solver%solve(ioptn, nparm, numgr, itlim, fun, ifun, pttbl, iptb, indm, &
                          iwork, liwrk, work, lwrk, iter, param, error)

        ! WRITE THE OUTPUT.
        ! NOTE THAT WE HAVE DEFERRED WRITING LIWRK AND LWRK UNTIL AFTER CALLING
        ! CONMAX SINCE CONMAX WILL CHANGE THEM TO THE NEGATIVE OF THE SMALLEST
        ! ALLOWABLE VALUES AND RETURN IF THEY WERE TOO SMALL.
        write (nwrit, '(/A,I4,A,I5,A,I6)') ' *****AFTER CONMAX ITER IS', iter, &
            '  LIWRK IS', liwrk, '  LWRK IS', lwrk
        write (nwrit, '(/A/,*(/3e23.14))') ' THE FINAL PARAMETERS ARE', param(1:nparm)
        write (nwrit, '(/A//,3e23.13//,a//,*(3e23.14/))') ' THE ERROR NORMS ARE', &
            error(numgr + 1), error(numgr + 2), error(numgr + 3), &
            ' THE ERRORS ARE', error(1:numgr)
! 99009 format (/' THE ERROR NORMS ARE'//3e23.13//' THE ERRORS ARE'//(3e23.14))

    end subroutine tstot_test
!********************************************************************************

!********************************************************************************
!>
!  Function for the unit test.

    subroutine my_fnset(me, nparm, numgr, pttbl, iptb, indm, param, ipt, indfn, icntyp, confun)

        implicit none

        class(my_solver), intent(inout) :: me
        integer, intent(in)                             :: Nparm
        integer, intent(in)                             :: Numgr
        integer, intent(in)                             :: Iptb
        integer, intent(in)                             :: Indm
        real(wp), dimension(Iptb, Indm), intent(in)     :: Pttbl
        real(wp), dimension(Nparm), intent(in)          :: Param
        integer, intent(in)                             :: Ipt
        integer, intent(in)                             :: Indfn
        integer, dimension(Numgr), intent(out)          :: Icntyp
        real(wp), dimension(Numgr, Nparm + 1), intent(out) :: Confun

        real(wp) :: a, b, c, d, eps, p, q, x, y
        integer :: ii, irem

        real(wp), parameter :: one = 1.0_wp
        real(wp), parameter :: zero = 0.0_wp

        ! we break fnset into sections based on the value of ipt, that is, on
        ! which constraint is being set.
        if (ipt <= 5) then
            ! here ipt <= 5 and we set a constraint of the form
            ! abs(f(x,y) - (ax+by+c)/(dx+1)) <= w.
            ! note that since this is a type 2 constraint we do not need to deal
            ! with the absolute value or the f(x,y) here.
            icntyp(ipt) = 2
            a = param(1)
            b = param(2)
            c = param(3)
            d = param(4)
            x = pttbl(ipt, 1)
            y = pttbl(ipt, 2)
            p = a*x + b*y + c
            q = d*x + one
            confun(ipt, 1) = p/q
            if (indfn > 0) then
                ! here ipt <= 5 and indfn=1, and we set the partial derivatives.
                confun(ipt, 2) = x/q
                confun(ipt, 3) = y/q
                confun(ipt, 4) = one/q
                confun(ipt, 5) = -p*x/(q*q)
                return
            end if
        elseif (ipt <= 15) then
            ! here 6 <= ipt <= 15 and if ipt is even we set the constraint
            ! (ax+by+c)/(dx+1) <= w, which is half of the constraint
            ! abs((ax+by+c)/(dx+1)) <= w, while if ipt is odd we set the constraint
            ! -(ax+by+c)/(dx+1) <= w, which is the other half of the constraint
            ! abs((ax+by+c)/(dx+1)) <= w.
            icntyp(ipt) = 1
            ii = (ipt - 4)/2
            a = param(1)
            b = param(2)
            c = param(3)
            d = param(4)
            x = pttbl(ii, 1)
            y = pttbl(ii, 2)
            p = a*x + b*y + c
            q = d*x + one
            irem = ipt - 4 - 2*ii
            if (irem <= 0) then
                ! here 6 <= ipt <= 15 and ipt is even.
                confun(ipt, 1) = p/q
                if (indfn > 0) then
                    confun(ipt, 2) = x/q
                    confun(ipt, 3) = y/q
                    confun(ipt, 4) = one/q
                    confun(ipt, 5) = -p*x/(q*q)
                    return
                end if
            else
                !
                ! here 6 <= ipt <= 15 and ipt is odd.
                confun(ipt, 1) = -p/q
                if (indfn > 0) then
                    confun(ipt, 2) = -x/q
                    confun(ipt, 3) = -y/q
                    confun(ipt, 4) = -one/q
                    confun(ipt, 5) = p*x/(q*q)
                    return
                end if
            end if
        elseif (ipt <= 20) then
            ! here 16 <= ipt <= 20 and we set a constraint of the form
            ! -dx - 1.0 + eps <= 0.0
            icntyp(ipt) = -1
            d = param(4)
            eps = pttbl(6, 1)
            ii = ipt - 15
            x = pttbl(ii, 1)
            confun(ipt, 1) = -d*x - one + eps
            if (indfn > 0) then
                confun(ipt, 2) = zero
                confun(ipt, 3) = zero
                confun(ipt, 4) = zero
                confun(ipt, 5) = -x
                return
            end if
        else
            ! here ipt=21 and we set the constraint
            ! (partial derivative of (ax+by+c)/(dx+1) with respect to x at
            ! (x,y) = (0.0,0.0)) <= 0.0,
            ! i.e. a - cd <= 0.0
            icntyp(ipt) = -2
            a = param(1)
            c = param(3)
            d = param(4)
            confun(ipt, 1) = a - c*d
            if (indfn > 0) then
                confun(ipt, 2) = one
                confun(ipt, 3) = zero
                confun(ipt, 4) = -d
                confun(ipt, 5) = -c
                return
            end if
        end if

    end subroutine my_fnset

end module tstot_test_module

program main
    use tstot_test_module
    implicit none
    call tstot_test()
end program main