module tensor_mod

use constants_mod, only: dp

interface blockmulXYZ
    procedure blockmulXYZ_single_op
    procedure blockmulXYZ_triple_op
end interface

interface blockmulXY
    procedure blockmulXY_single_op
    procedure blockmulXY_double_op
end interface

interface blockmulXZ
    procedure blockmulXZ_single_op
    procedure blockmulXZ_double_op
end interface

interface blockmulYZ
    procedure blockmulYZ_single_op
    procedure blockmulYZ_double_op
end interface

contains

pure function blockdotX(vect,cube) result(prod)

    real(dp), intent(in) :: vect(:)
    real(dp), intent(in) :: cube(:,:,:)

    real(dp) :: prod(size(cube,2),size(cube,3))

    integer :: i,j,q

    do i = 1,size(cube,2); do j = 1,size(cube,3);
        prod(i,j) = sum(vect*cube(:,i,j))
    end do; end do;

end function

pure function blockdotY(vect,cube) result(prod)

    real(dp), intent(in) :: vect(:)
    real(dp), intent(in) :: cube(:,:,:)

    real(dp) :: prod(size(cube,1),size(cube,3))

    integer :: i,j,q

    do i = 1,size(cube,1); do j = 1,size(cube,3);
        prod(i,j) = sum(vect*cube(i,:,j))
    end do; end do;

end function

pure function blockdotZ(vect,cube) result(prod)

    real(dp), intent(in) :: vect(:)
    real(dp), intent(in) :: cube(:,:,:)

    real(dp) :: prod(size(cube,1),size(cube,2))

    integer :: i,j,q

    do i = 1,size(cube,1); do j = 1,size(cube,2);
        prod(i,j) = sum(vect*cube(i,j,:))
    end do; end do;

end function

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

pure function blockmulX(matrix,incube) result(excube)

    real(dp), intent(in) :: matrix(:,:)
    real(dp), intent(in) :: incube(:,:,:)

    real(dp) :: excube(size(matrix,1),size(incube,2),size(incube,3))

    integer :: i,j,q

    do q = 1,size(matrix,1); do i = 1,size(incube,2); do j = 1,size(incube,3);
        excube(q,i,j) = sum(matrix(q,:) * incube(:,i,j))
    end do; end do; end do;

end function

pure function blockmulY(matrix,incube) result(excube)

    real(dp), intent(in) :: matrix(:,:)
    real(dp), intent(in) :: incube(:,:,:)

    real(dp) :: excube(size(incube,1),size(matrix,1),size(incube,3))

    integer :: i,j,q

    do q = 1,size(matrix,1); do i = 1,size(incube,1); do j = 1,size(incube,3);
        excube(i,q,j) = sum(matrix(q,:) * incube(i,:,j))
    end do; end do; end do;

end function

pure function blockmulZ(matrix,incube) result(excube)

    real(dp), intent(in) :: matrix(:,:)
    real(dp), intent(in) :: incube(:,:,:)

    real(dp) :: excube(size(incube,1),size(incube,2),size(matrix,1))

    integer :: i,j,q

    do q = 1,size(matrix,1); do i = 1,size(incube,1); do j = 1,size(incube,2);
        excube(i,j,q) = sum(matrix(q,:) * incube(i,j,:))
    end do; end do; end do;

end function

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

pure function blockmulXYZ_single_op(matrix,incube) result(excube)

    real(dp), intent(in) :: matrix(:,:)
    real(dp), intent(in) :: incube(:,:,:)

    real(dp) :: excube(size(matrix,1),size(matrix,1),size(matrix,1))

    excube = blockmulXYZ(matrix,matrix,matrix,incube)

end function

pure function blockmulXYZ_triple_op(matrA,matrB,matrC,cube0) result(cubeC)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: matrB(:,:)
    real(dp), intent(in) :: matrC(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(matrA,1),size(cube0,2),size(cube0,3))
    real(dp) :: cubeB(size(matrA,1),size(matrB,1),size(cube0,3))
    real(dp) :: cubeC(size(matrA,1),size(matrB,1),size(matrC,1))

    cubeA = blockmulX(matrA,cube0)
    cubeB = blockmulY(matrB,cubeA)
    cubeC = blockmulZ(matrC,cubeB)

end function

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

pure function blockmulXY_double_op(matrA,matrB,cube0) result(cubeB)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: matrB(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(matrA,1),size(cube0,2),size(cube0,3))
    real(dp) :: cubeB(size(matrA,1),size(matrB,1),size(cube0,3))

    cubeA = blockmulX(matrA,cube0)
    cubeB = blockmulY(matrB,cubeA)

end function

pure function blockmulXZ_double_op(matrA,matrB,cube0) result(cubeB)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: matrB(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(matrA,1),size(cube0,2),size(cube0,3))
    real(dp) :: cubeB(size(matrA,1),size(cube0,2),size(matrB,1))

    cubeA = blockmulX(matrA,cube0)
    cubeB = blockmulZ(matrB,cubeA)

end function

pure function blockmulYZ_double_op(matrA,matrB,cube0) result(cubeB)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: matrB(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(cube0,1),size(matrA,1),size(cube0,3))
    real(dp) :: cubeB(size(cube0,1),size(matrA,1),size(matrB,1))

    cubeA = blockmulY(matrA,cube0)
    cubeB = blockmulZ(matrB,cubeA)

end function

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

pure function blockmulXY_single_op(matrA,cube0) result(cubeA)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(matrA,1),size(matrA,1),size(cube0,3))

    cubeA = blockmulXY_double_op(matrA,matrA,cube0)

end function

pure function blockmulXZ_single_op(matrA,cube0) result(cubeA)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(matrA,1),size(cube0,2),size(matrA,1))

    cubeA = blockmulXZ_double_op(matrA,matrA,cube0)

end function

pure function blockmulYZ_single_op(matrA,cube0) result(cubeA)

    real(dp), intent(in) :: matrA(:,:)
    real(dp), intent(in) :: cube0(:,:,:)

    real(dp) :: cubeA(size(cube0,1),size(matrA,1),size(matrA,1))

    cubeA = blockmulYZ_double_op(matrA,matrA,cube0)

end function

end module


      program ffrtest
      implicit none
      real*8,dimension(0:2000) :: F ! np波函数
      real*8 ::b(0:2000,2)
      real*8 :: FFR4 ! interpolation function
      real*8 :: Y
      integer :: i,j

      open(11,file='fort.7',status='old')
      do i=0,2000
      read(11,*)(b(i,j),j=1,2)
      F(i)=b(i,2)
      end do
      Y=4.5
      write(*,*)FFR4(Y,F,2001)

      end program ffrtest

      FUNCTION FFR4(Y,F,N)
            IMPLICIT REAL*8(A-H,O-Z)
            REAL*8 F(N),P,P1,P2,Q,X,FFR4
            REAL*8 Y
            PARAMETER(X=.16666666666667)
            P=Y
            I=P
            write(*,*)I
            IF(I.LE.0) GO TO 2
            IF(I.GE.N-2) GO TO 4
  1         P=P-I
            P1=P-1.
            P2=P-2.
            Q=P+1.
            FFR4=(-P2*F(I)+Q*F(I+3))*P*P1*X+(P1*F(I+1)-P*F(I+2))*Q*P2*.5
            RETURN
  2         IF(I.LT.0) GO TO 3
            I=1
            GO TO 1
  3         FFR4=F(1)
            RETURN
  4         IF(I.GT.N-2) GO TO 5
            I=N-3
            GO TO 1
  5         FFR4=F(N)
            RETURN
            END function


!****************************************************
!*                 SCLEAN
!*  Simultaneous Iterative Sine Wave Fitting
!*
!*  Description:
!*    Cleans a timeseries for coherent signals,
!*    taking into account the influences of the
!*    frequencies on each other.
!*
!*  Input:
!*    sclean [options] [inputfile] [outputfile]
!*
!*  Options:
!*    -tday      Treat times as days (default).
!*    -tsec      Treat times as seconds.
!*    -version   Print program version information.
!*
!*  Written by
!*    Rasmus Handberg
!*    Department of Physics and Astronomy
!*    Aarhus University
!****************************************************

program sclean
	use kind_defs
	use timeseries
	use FindMax
	implicit none
	character(200) :: buffer, inputfile = '', outputfile = ''
	logical :: bolUseWeights
	integer :: i, j, err, N, Nclean, k, Nspectra, total_spectra
	real(dbl), allocatable :: alpha(:), beta(:), nu(:)
	real(dbl) :: nu_min, nu_max, fmean
	integer :: TimeType = 1 ! Default time type is days
   	real(dbl) :: t1, t2
   	real(dbl) :: nu_low, nu_high, dF, Pmax, phase, nyquist
	integer :: nargs, iargc

	print *, "--------------------------------------------"
	print *, "                  SCLEAN                    "
	print *, "  Simultaneous Iterative Sine Wave Fitting  "
	print *, "--------------------------------------------"

	! Extract parameters from command-line:
	nargs = iargc()
	do j = 1,nargs
		call getarg(j, buffer)
		select case (trim(buffer))
			case ("-tsec")
				TimeType = 0
			case ("-tday")
				TimeType = 1
			case ("-version")
				print *, "Current version:"
				print *, "$Revision: 119 $"
				print *, "$Date: 2016-02-09 09:57:56 +0100 (ti, 09 feb 2016) $"
				stop

			case default
				if (.not. buffer(1:1) == "-" .and. inputfile == "") then
					inputfile = trim(buffer)
				elseif (.not. buffer(1:1) == "-" .and. outputfile == "") then
					outputfile = trim(buffer)
				else
					print *, "UNKNOWN ARGUMENT: " // trim(buffer)
					stop
				endif
		end select
	enddo
	! If no files were given, ask for input and make output:
	if (inputfile == "") then
        print *, 'Enter input-file:'
        read '(a50)', inputfile
	endif
	if (outputfile == '') then
		j = scan(inputfile, '/', back=.true.)
		if (j /= 0) then
			outputfile = trim(inputfile(j+1:))
		else
			outputfile = trim(inputfile)
		endif
		j = scan(outputfile, '.', back=.true.)
		if (j > 1) then
			outputfile = trim(outputfile(1:j-1)) // '.clean'
		else
			outputfile = trim(outputfile) // '.clean'
		endif
	endif

    print *, "Reading data..."
    open(50, file=inputfile, status='old', action='read')
        ! New count:
        call CountData(50, N, bolUseWeights, 0)

        ! Allocate the data:
    	allocate(t(1:N), f(1:N), w(1:N), stat=err)
    	if (err /= 0) stop "Couldn''t allocate memory!"

        ! Import the data:
        call ImportData(50, bolUseWeights, t, f, w, 0)
    close(50)

	! Convert time vector to seconds, based on the selected input:
	if (TimeType == 1) then
		t = t*86400_dbl
	endif

    ! Print information about series:
	! Get fundamental frequency resolution in case of equividistant points.
	! A good measure of the resolution in the spectrum.
    call print_info(t, nyquist, dF)

    ! Select frequencies:
    print *, ""
    print *, 'min-frequency (microHz):'
    read *, nu_min
    print *, 'max-frequency (microHz):'
    read *, nu_max

    ! Number of points to clean:
    print *, ""
    print *, "Number of frequencies to clean:"
    read *, Nclean
    print *, ""

	! Subtract mean:
	call cpu_time(t1)
	fmean = mean(f,w)
	f = f - fmean

	! Allocate space for the results:
   	allocate(alpha(1:Nclean), beta(1:Nclean), nu(1:Nclean), stat=err)
    if (err /= 0) stop "Couldn''t allocate memory!"

	! Calculate the total number of spectra needed to be calculated:
	total_spectra = Nclean-1 + Nclean*(Nclean+1)/2.0

	print '("  A total of ",i3," spectra needed.")', total_spectra
	print *, "--------------------------------------------"

	Nspectra = 0
	do i = 1,Nclean
		! Find the maximum in the spectrum and subtract it:
		call FindSpectrumMax(t, f, w, nu_min, nu_max, alpha(i), beta(i), nu(i))
		f = f - alpha(i)*sin(twopi_micro*nu(i)*t) - beta(i)*cos(twopi_micro*nu(i)*t)
		Nspectra = Nspectra+1
		print '("  Spectrum ",i3,"/",i3," done.")', Nspectra, total_spectra

		if (i /= 1) then
			do j = 1,i
				! Add the oscillation:
				f = f + alpha(j)*sin(twopi_micro*nu(j)*t) + beta(j)*cos(twopi_micro*nu(j)*t)

				! Narrow search (nu_min,nu_max) to area arround nu(j)
				nu_low  = max(nu_min, nu(j)-5*dF)
				nu_high = min(nu_max, nu(j)+5*dF)

				! Find the maximum:
				call FindSpectrumMax(t, f, w, nu_low, nu_high, alpha(j), beta(j), nu(j))
				Nspectra = Nspectra+1
				print '("  Spectrum ",i3,"/",i3," done.")', Nspectra, total_spectra

				! Remove the oscillation again:
				f = f - alpha(j)*sin(twopi_micro*nu(j)*t) - beta(j)*cos(twopi_micro*nu(j)*t)
			enddo
		endif
	enddo
	print *, '--------------------------------------------'

	! Add the mean again and convert the time back to original format:
	f = f + fmean
	if (TimeType == 1) then
		t = t/86400_dbl
	endif

	! Write the found frequencies and amplitudes to file:
	open(51, file='clean.log', action='write', position='append')
	! Write header to clean.dat file:
	write(51, '(a)') '#----------------------------------'
	write(51, '(a)') '# SCLEAN'
	write(51, '(a)') '# ' // trim(inputfile)
	write(51, "('# min: ',f10.2,' microHz')") nu_min
	write(51, "('# max: ',f10.2,' microHz')") nu_max
	write(51, "('# Nclean: ',i7)") Nclean
	write(51, '(a)') '# Number, Power, Frequencies (microHz), Phase'
	write(51, '(a)') '#----------------------------------'
	do i = 1,Nclean
		Pmax = alpha(i)**2 + beta(i)**2
		phase = atan2(alpha(i),beta(i))
		write(51,'(i5,3ES26.16E3)') i, Pmax, nu(i), phase
		print '(i5,3f14.4)', i, Pmax, nu(i), phase
	enddo
	close(51)

	! Save in file:
	open(52, file=outputfile, status='replace', action='write')
	do i = 1,N
		write(52, '(3ES26.16E3)') t(i), f(i), 1.0_dbl/sqrt(w(i))
	enddo
	close(52)

	! Clean up the memory:
	deallocate(t, f, w, alpha, beta, nu)

	call cpu_time(t2)
	print *, '--------------------------------------------'
    call print_time(t2-t1)
end program


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_orthfact_deflationcheck
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks for deflations in an orthogonal upper hessenberg
! matrix that is stored as a product of givens rotations and a complex
! diagonal matrix. When a deflation occurs the corresponding rotation
! is set to the identity matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (N)
!                    array of generators for complex diagonal matrix
!                    entries must be +/-1
!
! OUTPUT VARIABLES:
!
!  ZERO            INTEGER
!                     index of the last known deflation
!                     on output contains index of newest deflation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_orthfact_deflationcheck(N,Q,D,ZERO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(inout) :: Q(2*(N-1)), D(N)
  integer, intent(inout) :: ZERO

  ! compute variables
  integer :: ii
  real(8), parameter :: tol = EISCOR_DBL_EPS

  ! initialize ZERO
  ZERO = 0

  ! check for deflation
  do ii=1,(N-1)

    ! deflate if subdiagonal is small enough
    if(abs(Q(2*(N-ii))) < tol)then

      ! update D
      D(N-ii) = sign(1d0,Q(2*(N-ii)-1)*D(N-ii))
      D(N-ii+1) = sign(1d0,Q(2*(N-ii)-1)*D(N-ii+1))

      ! update subsequent Q
      if (ii > 1) then
        Q(2*(N-ii+1)) = sign(1d0,Q(2*(N-ii)-1))*Q(2*(N-ii+1))
      end if

      ! set Q to identity
      Q(2*(N-ii)-1) = 1d0
      Q(2*(N-ii)) = 0d0

      ! set ZERO
      ZERO = max(0,N-ii)

      ! exit loop
      exit

    end if

  end do

end subroutine d_orthfact_deflationcheck


      PROGRAM DAWTST
C------------------------------------------------------------------
C FORTRAN 77 program to test DAW
C
C  Method:
C
C     Accuracy test compare function values against a local
C     Taylor's series expansion.  Derivatives are generated
C     from the recurrence relation.
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C         information on the floating-point arithmetic
C         system.  Note that the call to MACHAR can
C         be deleted provided the following five
C         parameters are assigned the values indicated
C
C              IBETA  - the radix of the floating-point system
C              IT     - the number of base-IBETA digits in the
C                       significant of a floating-point number
C              XMIN   - the smallest positive floating-point number
C              XMAX   - the largest floating-point number
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  Reference: "The use of Taylor series to test accuracy of
C              function programs", W. J. Cody and L. Stoltz,
C              submitted for publication.
C
C  Latest modification: March 9, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,II,IOUT,IRND,IT,J,JT,K1,
     1    K2,K3,MACHEP,MAXEXP,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
      DOUBLE PRECISION
     1    A,AIT,ALBETA,B,BETA,CONV,DAW,DEL,DELTA,EPS,EPSNEG,
     2    FORTEN,HALF,ONE,P,REN,R6,R7,SIXTEN,TWO,T1,W,X,
     3    XBIG,XKAY,XL,XMAX,XMIN,XN,X1,X99,Y,Z,ZERO,ZZ
      DIMENSION P(0:14)
C------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE,TWO/0.0E0,0.5E0,1.0E0,2.0E0/,
CS   1   FORTEN,SIXTEN,X99,DELTA/14.0E0,1.6E1,-999.0E0,6.25E-2/
      DATA ZERO,HALF,ONE,TWO/0.0D0,0.5D0,1.0D0,2.0D0/,
     1   FORTEN,SIXTEN,X99,DELTA/14.0D0,1.6D1,-999.0D0,6.25D-2/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Define statement functions for conversions
C------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
      CONV(NDUM) = DBLE(NDUM)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      AIT = CONV(IT)
      ALBETA = LOG(BETA)
      A = DELTA
      B = ONE
      JT = 0
C-----------------------------------------------------------------
C  Random argument accuracy tests based on local Taylor expansion.
C-----------------------------------------------------------------
      DO 300 J = 1, 4
         N = 2000
         XN = CONV(N)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C------------------------------------------------------------------
C  Purify arguments
C------------------------------------------------------------------
            Y = X - DELTA
            W = SIXTEN * Y
            T1 = W + Y
            Y = T1 - W
            X = Y + DELTA
C------------------------------------------------------------------
C  Use Taylor's Series Expansion
C------------------------------------------------------------------
            P(0) = DAW(Y)
            Z = Y + Y
            P(1) = ONE - Z * P(0)
            XKAY = TWO
            DO 100 II = 2, 14
               P(II) = -(Z*P(II-1)+XKAY*P(II-2))
               XKAY = XKAY + TWO
  100       CONTINUE
            ZZ = P(14)
            XKAY = FORTEN
            DO 110 II = 1, 14
               ZZ = ZZ*DELTA/XKAY + P(14-II)
               XKAY = XKAY - ONE
  110       CONTINUE
            Z = DAW(X)
C------------------------------------------------------------------
C  Accumulate Results
C------------------------------------------------------------------
            W = (Z - ZZ) / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K1 - K3
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = X99
         IF (R6 .NE. ZERO) W = LOG(R6)/ALBETA
         WRITE (IOUT,1021) R6,IBETA,W,X1
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = X99
         IF (R7 .NE. ZERO) W = LOG(R7)/ALBETA
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         A = B
         B = B + B
         IF (J .EQ. 1) B = B + HALF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests.  First check values for negative arguments.
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1030) IBETA
      DO 350 I = 1, 10
         X = REN(J)*(TWO+TWO)
         B = DAW(X)
         A = B + DAW(-X)
         IF (A*B .NE. ZERO) A = AIT + LOG(ABS(A/B))/ALBETA
         WRITE (IOUT,1031) X,A
         X = X + DEL
  350 CONTINUE
C-----------------------------------------------------------------
C  Next, test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      Z = XMIN
      ZZ = DAW(Z)
      WRITE (IOUT,1041) ZZ
C-----------------------------------------------------------------
C  Test of error return for arguments > xmax.  First, determine
C    xmax
C-----------------------------------------------------------------
      IF (HALF .LT. XMIN*XMAX ) THEN
            XBIG = HALF/XMIN
         ELSE
            XBIG = XMAX
      END IF
      WRITE (IOUT,1050)
      Z = XBIG*(ONE-DELTA*DELTA)
      WRITE (IOUT,1052) Z
      ZZ = DAW(Z)
      WRITE (IOUT,1062) ZZ
      Z = XBIG
      WRITE (IOUT,1053) Z
      ZZ = DAW(Z)
      WRITE (IOUT,1062) ZZ
      W = ONE + DELTA*DELTA
      IF (W .LT. XMAX/XBIG ) THEN
            Z = XBIG*W
            WRITE (IOUT,1053) Z
            ZZ = DAW(Z)
            WRITE (IOUT,1062) ZZ
      END IF
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of Dawson''s Integral vs Taylor expansion'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval ',
     1    '(',F5.2,',',F5.2,')'//)
 1011 FORMAT('  F(X) was larger',I6,' times,'/
     1    10X,' agreed',I6,' times, and'/
     1    6X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1030 FORMAT(7X,'Estimated loss of base',i3,' significant digits in'//
     1       8X,'X',10X,'F(x)+F(-x)'/)
 1031 FORMAT(3X,F7.3,F16.2)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT('  F(XMIN) = ',E24.17E3/)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' DAW will be called with the argument',E13.6E3,/
     1    ' This should not underflow'//)
 1053 FORMAT(' DAW will be called with the argument',E13.6E3,/
     1    ' This may underflow'//)
 1062 FORMAT(' DAW returned the value',E13.6E3///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of DAW test program ----------
      END


*DECK QZIT
      SUBROUTINE QZIT (NM, N, A, B, EPS1, MATZ, Z, IERR)
C***BEGIN PROLOGUE  QZIT
C***PURPOSE  The second step of the QZ algorithm for generalized
C            eigenproblems.  Accepts an upper Hessenberg and an upper
C            triangular matrix and reduces the former to
C            quasi-triangular form while preserving the form of the
C            latter.  Usually preceded by QZHES and followed by QZVAL
C            and QZVEC.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B3
C***TYPE      SINGLE PRECISION (QZIT-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is the second step of the QZ algorithm
C     for solving generalized matrix eigenvalue problems,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART,
C     as modified in technical note NASA TN D-7305(1973) by WARD.
C
C     This subroutine accepts a pair of REAL matrices, one of them
C     in upper Hessenberg form and the other in upper triangular form.
C     It reduces the Hessenberg matrix to quasi-triangular form using
C     orthogonal transformations while maintaining the triangular form
C     of the other matrix.  It is usually preceded by  QZHES  and
C     followed by  QZVAL  and, possibly,  QZVEC.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real upper Hessenberg matrix.  A is a two-
C          dimensional REAL array, dimensioned A(NM,N).
C
C        B contains a real upper triangular matrix.  B is a two-
C          dimensional REAL array, dimensioned B(NM,N).
C
C        EPS1 is a tolerance used to determine negligible elements.
C          EPS1 = 0.0 (or negative) may be input, in which case an
C          element will be neglected only if it is less than roundoff
C          error times the norm of its matrix.  If the input EPS1 is
C          positive, then an element will be considered negligible
C          if it is less than EPS1 times the norm of its matrix.  A
C          positive value of EPS1 may result in faster execution,
C          but less accurate results.  EPS1 is a REAL variable.
C
C        MATZ should be set to .TRUE. if the right hand transformations
C          are to be accumulated for later use in computing
C          eigenvectors, and to .FALSE. otherwise.  MATZ is a LOGICAL
C          variable.
C
C        Z contains, if MATZ has been set to .TRUE., the transformation
C          matrix produced in the reduction by  QZHES, if performed, or
C          else the identity matrix.  If MATZ has been set to .FALSE.,
C          Z is not referenced.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C     On Output
C
C        A has been reduced to quasi-triangular form.  The elements
C          below the first subdiagonal are still zero, and no two
C          consecutive subdiagonal elements are nonzero.
C
C        B is still in upper triangular form, although its elements
C          have been altered.  The location B(N,1) is used to store
C          EPS1 times the norm of B for later use by  QZVAL  and  QZVEC.
C
C        Z contains the product of the right hand transformations
C          (for both steps) if MATZ has been set to .TRUE.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if neither A(J,J-1) nor A(J-1,J-2) has become
C                     zero after a total of 30*N iterations.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  QZIT
C
      INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1
      INTEGER ENM2,IERR,LOR1,ENORN
      REAL A(NM,*),B(NM,*),Z(NM,*)
      REAL R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI
      REAL A11,A12,A21,A22,A33,A34,A43,A44,BNI,B11
      REAL B12,B22,B33,B34,B44,EPSA,EPSB,EPS1,ANORM,BNORM
      LOGICAL MATZ,NOTLAS
C
C***FIRST EXECUTABLE STATEMENT  QZIT
      IERR = 0
C     .......... COMPUTE EPSA,EPSB ..........
      ANORM = 0.0E0
      BNORM = 0.0E0
C
      DO 30 I = 1, N
         ANI = 0.0E0
         IF (I .NE. 1) ANI = ABS(A(I,I-1))
         BNI = 0.0E0
C
         DO 20 J = I, N
            ANI = ANI + ABS(A(I,J))
            BNI = BNI + ABS(B(I,J))
   20    CONTINUE
C
         IF (ANI .GT. ANORM) ANORM = ANI
         IF (BNI .GT. BNORM) BNORM = BNI
   30 CONTINUE
C
      IF (ANORM .EQ. 0.0E0) ANORM = 1.0E0
      IF (BNORM .EQ. 0.0E0) BNORM = 1.0E0
      EP = EPS1
      IF (EP .GT. 0.0E0) GO TO 50
C     .......... COMPUTE ROUNDOFF LEVEL IF EPS1 IS ZERO ..........
      EP = 1.0E0
   40 EP = EP / 2.0E0
      IF (1.0E0 + EP .GT. 1.0E0) GO TO 40
   50 EPSA = EP * ANORM
      EPSB = EP * BNORM
C     .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE
C                KEEPING B TRIANGULAR ..........
      LOR1 = 1
      ENORN = N
      EN = N
      ITN = 30*N
C     .......... BEGIN QZ STEP ..........
   60 IF (EN .LE. 2) GO TO 1001
      IF (.NOT. MATZ) ENORN = EN
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
   70 ISH = 2
C     .......... CHECK FOR CONVERGENCE OR REDUCIBILITY.
C                FOR L=EN STEP -1 UNTIL 1 DO -- ..........
      DO 80 LL = 1, EN
         LM1 = EN - LL
         L = LM1 + 1
         IF (L .EQ. 1) GO TO 95
         IF (ABS(A(L,LM1)) .LE. EPSA) GO TO 90
   80 CONTINUE
C
   90 A(L,LM1) = 0.0E0
      IF (L .LT. NA) GO TO 95
C     .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED ..........
      EN = LM1
      GO TO 60
C     .......... CHECK FOR SMALL TOP OF B ..........
   95 LD = L
  100 L1 = L + 1
      B11 = B(L,L)
      IF (ABS(B11) .GT. EPSB) GO TO 120
      B(L,L) = 0.0E0
      S = ABS(A(L,L)) + ABS(A(L1,L))
      U1 = A(L,L) / S
      U2 = A(L1,L) / S
      R = SIGN(SQRT(U1*U1+U2*U2),U1)
      V1 = -(U1 + R) / R
      V2 = -U2 / R
      U2 = V2 / V1
C
      DO 110 J = L, ENORN
         T = A(L,J) + U2 * A(L1,J)
         A(L,J) = A(L,J) + T * V1
         A(L1,J) = A(L1,J) + T * V2
         T = B(L,J) + U2 * B(L1,J)
         B(L,J) = B(L,J) + T * V1
         B(L1,J) = B(L1,J) + T * V2
  110 CONTINUE
C
      IF (L .NE. 1) A(L,LM1) = -A(L,LM1)
      LM1 = L
      L = L1
      GO TO 90
  120 A11 = A(L,L) / B11
      A21 = A(L1,L) / B11
      IF (ISH .EQ. 1) GO TO 140
C     .......... ITERATION STRATEGY ..........
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10) GO TO 155
C     .......... DETERMINE TYPE OF SHIFT ..........
      B22 = B(L1,L1)
      IF (ABS(B22) .LT. EPSB) B22 = EPSB
      B33 = B(NA,NA)
      IF (ABS(B33) .LT. EPSB) B33 = EPSB
      B44 = B(EN,EN)
      IF (ABS(B44) .LT. EPSB) B44 = EPSB
      A33 = A(NA,NA) / B33
      A34 = A(NA,EN) / B44
      A43 = A(EN,NA) / B33
      A44 = A(EN,EN) / B44
      B34 = B(NA,EN) / B44
      T = 0.5E0 * (A43 * B34 - A33 - A44)
      R = T * T + A34 * A43 - A33 * A44
      IF (R .LT. 0.0E0) GO TO 150
C     .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A ..........
      ISH = 1
      R = SQRT(R)
      SH = -T + R
      S = -T - R
      IF (ABS(S-A44) .LT. ABS(SH-A44)) SH = S
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS OF A.
C                FOR L=EN-2 STEP -1 UNTIL LD DO -- ..........
      DO 130 LL = LD, ENM2
         L = ENM2 + LD - LL
         IF (L .EQ. LD) GO TO 140
         LM1 = L - 1
         L1 = L + 1
         T = A(L,L)
         IF (ABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L)
         IF (ABS(A(L,LM1)) .LE. ABS(T/A(L1,L)) * EPSA) GO TO 100
  130 CONTINUE
C
  140 A1 = A11 - SH
      A2 = A21
      IF (L .NE. LD) A(L,LM1) = -A(L,LM1)
      GO TO 160
C     .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A ..........
  150 A12 = A(L,L1) / B22
      A22 = A(L1,L1) / B22
      B12 = B(L,L1) / B22
      A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11)
     1     / A21 + A12 - A11 * B12
      A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11)
     1     + A43 * B34
      A3 = A(L1+1,L1) / B22
      GO TO 160
C     .......... AD HOC SHIFT ..........
  155 A1 = 0.0E0
      A2 = 1.0E0
      A3 = 1.1605E0
  160 ITS = ITS + 1
      ITN = ITN - 1
      IF (.NOT. MATZ) LOR1 = LD
C     .......... MAIN LOOP ..........
      DO 260 K = L, NA
         NOTLAS = K .NE. NA .AND. ISH .EQ. 2
         K1 = K + 1
         K2 = K + 2
         KM1 = MAX(K-1,L)
         LL = MIN(EN,K1+ISH)
         IF (NOTLAS) GO TO 190
C     .......... ZERO A(K+1,K-1) ..........
         IF (K .EQ. L) GO TO 170
         A1 = A(K,KM1)
         A2 = A(K1,KM1)
  170    S = ABS(A1) + ABS(A2)
         IF (S .EQ. 0.0E0) GO TO 70
         U1 = A1 / S
         U2 = A2 / S
         R = SIGN(SQRT(U1*U1+U2*U2),U1)
         V1 = -(U1 + R) / R
         V2 = -U2 / R
         U2 = V2 / V1
C
         DO 180 J = KM1, ENORN
            T = A(K,J) + U2 * A(K1,J)
            A(K,J) = A(K,J) + T * V1
            A(K1,J) = A(K1,J) + T * V2
            T = B(K,J) + U2 * B(K1,J)
            B(K,J) = B(K,J) + T * V1
            B(K1,J) = B(K1,J) + T * V2
  180    CONTINUE
C
         IF (K .NE. L) A(K1,KM1) = 0.0E0
         GO TO 240
C     .......... ZERO A(K+1,K-1) AND A(K+2,K-1) ..........
  190    IF (K .EQ. L) GO TO 200
         A1 = A(K,KM1)
         A2 = A(K1,KM1)
         A3 = A(K2,KM1)
  200    S = ABS(A1) + ABS(A2) + ABS(A3)
         IF (S .EQ. 0.0E0) GO TO 260
         U1 = A1 / S
         U2 = A2 / S
         U3 = A3 / S
         R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1)
         V1 = -(U1 + R) / R
         V2 = -U2 / R
         V3 = -U3 / R
         U2 = V2 / V1
         U3 = V3 / V1
C
         DO 210 J = KM1, ENORN
            T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J)
            A(K,J) = A(K,J) + T * V1
            A(K1,J) = A(K1,J) + T * V2
            A(K2,J) = A(K2,J) + T * V3
            T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J)
            B(K,J) = B(K,J) + T * V1
            B(K1,J) = B(K1,J) + T * V2
            B(K2,J) = B(K2,J) + T * V3
  210    CONTINUE
C
         IF (K .EQ. L) GO TO 220
         A(K1,KM1) = 0.0E0
         A(K2,KM1) = 0.0E0
C     .......... ZERO B(K+2,K+1) AND B(K+2,K) ..........
  220    S = ABS(B(K2,K2)) + ABS(B(K2,K1)) + ABS(B(K2,K))
         IF (S .EQ. 0.0E0) GO TO 240
         U1 = B(K2,K2) / S
         U2 = B(K2,K1) / S
         U3 = B(K2,K) / S
         R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1)
         V1 = -(U1 + R) / R
         V2 = -U2 / R
         V3 = -U3 / R
         U2 = V2 / V1
         U3 = V3 / V1
C
         DO 230 I = LOR1, LL
            T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K)
            A(I,K2) = A(I,K2) + T * V1
            A(I,K1) = A(I,K1) + T * V2
            A(I,K) = A(I,K) + T * V3
            T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K)
            B(I,K2) = B(I,K2) + T * V1
            B(I,K1) = B(I,K1) + T * V2
            B(I,K) = B(I,K) + T * V3
  230    CONTINUE
C
         B(K2,K) = 0.0E0
         B(K2,K1) = 0.0E0
         IF (.NOT. MATZ) GO TO 240
C
         DO 235 I = 1, N
            T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K)
            Z(I,K2) = Z(I,K2) + T * V1
            Z(I,K1) = Z(I,K1) + T * V2
            Z(I,K) = Z(I,K) + T * V3
  235    CONTINUE
C     .......... ZERO B(K+1,K) ..........
  240    S = ABS(B(K1,K1)) + ABS(B(K1,K))
         IF (S .EQ. 0.0E0) GO TO 260
         U1 = B(K1,K1) / S
         U2 = B(K1,K) / S
         R = SIGN(SQRT(U1*U1+U2*U2),U1)
         V1 = -(U1 + R) / R
         V2 = -U2 / R
         U2 = V2 / V1
C
         DO 250 I = LOR1, LL
            T = A(I,K1) + U2 * A(I,K)
            A(I,K1) = A(I,K1) + T * V1
            A(I,K) = A(I,K) + T * V2
            T = B(I,K1) + U2 * B(I,K)
            B(I,K1) = B(I,K1) + T * V1
            B(I,K) = B(I,K) + T * V2
  250    CONTINUE
C
         B(K1,K) = 0.0E0
         IF (.NOT. MATZ) GO TO 260
C
         DO 255 I = 1, N
            T = Z(I,K1) + U2 * Z(I,K)
            Z(I,K1) = Z(I,K1) + T * V1
            Z(I,K) = Z(I,K) + T * V2
  255    CONTINUE
C
  260 CONTINUE
C     .......... END QZ STEP ..........
      GO TO 70
C     .......... SET ERROR -- NEITHER BOTTOM SUBDIAGONAL ELEMENT
C                HAS BECOME NEGLIGIBLE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
C     .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC ..........
 1001 IF (N .GT. 1) B(N,1) = EPSB
      RETURN
      END


program GenKingMatrix
	implicit none
	integer, parameter :: rows = 100
	integer, parameter :: cols = 100
	real, parameter :: pi = 3.1415927
	integer ierr
	real :: time
	COMPLEX*8 m (rows, cols)
	DOUBLE PRECISION ima (rows, cols)
	DOUBLE PRECISION rea (rows, cols)
	DOUBLE PRECISION ieig (cols)
	DOUBLE PRECISION reig (cols)
	DOUBLE PRECISION fv1 (cols)
	DOUBLE PRECISION fv2 (cols)
	DOUBLE PRECISION fv3 (cols)
	DOUBLE PRECISION reiv (rows, cols)
	DOUBLE PRECISION ieiv (rows, cols)
	DOUBLE COMPLEX eig (cols)
	integer i, j
	integer count, count_rate, count_max
	COMPLEX*16 :: sum
	REAL(8) :: s

	call SYSTEM_CLOCK (count, count_rate, count_max)
	call srand(count)

	do i=1, 1000
		call genkmatrix (m, rows, cols)
		call getreal (m, rea, rows, cols)
		call getimag (m, ima, rows, cols)
		call cg (rows, cols, rea, ima, reig, ieig, 0, reiv, ieiv, fv1, fv2, fv3, ierr)
		call getcmplx (eig, reig, ieig, cols)

		sum = CMPLX(0.0, 0.0)
		do j=1, cols
			sum = sum + eig (j)
		end do

		s = REALPART (sum) / cols
		print *, s
		if (s .lt. (pi / 2)) then
			print *, 'Generated a king matrix...'
			stop 0
		end if
	end do

	print *, 'No king matrix was generated...'
	stop 1
end program GenKingMatrix

! Subroutine -- Zero --
!
! Initializes the members of the Matrix
! ``m'' with zeros
subroutine zero (m, rows, cols)
	integer rows
	integer cols
	COMPLEX*16 m (rows, cols)
	integer i, j

	do i=1,rows
		do j=1,cols
			m (i, j) = CMPLX(0.0, 0.0)
		end do
	end do
end subroutine zero

! Subroutine -- random --
!
! Initializes the Matrix m with random values
subroutine random (m, rows, cols)
	integer rows
	integer cols
	COMPLEX*16 m (rows, cols)
	integer i, j

	do i=1,rows
		do j=1,cols
			m (i, j) = CMPLX(rand () * 1000.0, rand() * 1000.0)
		end do
	end do
end subroutine random

! Subroutine genkmatrix
!
! Generates a king matrix m
subroutine genkmatrix (m, rows, cols)
	real, parameter :: pi = 3.1415927
	integer rows
	integer cols
	COMPLEX*8 m(rows, cols)
	integer i, j

	do i=1,rows
		do j=1,cols
			m (i, j) = CMPLX (rand () * pi, rand () * pi)
		end do
	end do
end subroutine genkmatrix

subroutine getreal (m, rea, rows, cols)
	integer rows
	integer cols
	COMPLEX*8 m (rows, cols)
	DOUBLE PRECISION rea (rows, cols)
	integer i, j

	do i=1,rows
		do j=1,cols
			rea (i, j) = REALPART (m (i, j))
		end do
	end do
end subroutine getreal

subroutine getimag (m, imag, rows, cols)
	integer rows
	integer cols
	COMPLEX*8 m (rows, cols)
	DOUBLE PRECISION imag (rows, cols)
	integer i, j

	do i=1,rows
		do j=1,cols
			imag (i, j) = IMAGPART (m (i, j))
		end do
	end do
end subroutine getimag

subroutine getcmplx (d, r, im, n)
	integer n
	double complex d (n)
	double precision r(n)
	double precision im(n)
	integer i

	do i=1,n
		d (i) = CMPLX (r (i), im(i))
	end do
end subroutine getcmplx

double precision function getsum (vec, n)
	integer n
	DOUBLE PRECISION vec (n)
	integer i

	getsum = 0.0
	do i=1,n
		getsum = getsum + vec (i)
	end do
end function getsum


program initparam

  integer :: iarg
  character :: arg*10,outf*100

  outf='fieldinfo.f90'
  open(2,file=outf,status='unknown')

  write(2,'(a17)') 'MODULE fieldinfo_'
  write(*,*) 'Grid number of each side (e.g., 512)'
  read(*,*) arg

  write(2,*) 'integer, parameter :: ni='//arg(1:len_trim(arg))//',nj=ni'
  write(*,*) 'Side length [arcmin] (e.g., 300)'
  read(*,*) arg
  write(2,*) 'real, parameter ::  leni='//arg(1:len_trim(arg))//',lenj=leni'
  write(2,*) 'real, parameter :: pi=3.14159265358979'
  write(2,*) 'real, parameter :: rad1=leni/10800.*pi, rad2=rad1'
  write(2,*) 'real, parameter :: amin2grid=float(ni)/leni'
  write(*,*) 'binning of power spectrum'
  write(*,*) '1. linear  2. logarithmic'
  read(*,*) iarg
  if (iarg==1) then
     arg='lin'
  else
     arg='log'
  endif
  write(2,*) 'character(3), parameter :: bkind="'//arg(1:len_trim(arg))//'"'
  write(*,*) 'lowest wavenumber [unit:fundamental mode 2pi/l] (e.g, 1.)'
  read(*,*)  arg
  write(2,*) 'real, parameter :: lmin=2.*pi/rad1*'//arg(1:len_trim(arg))
  write(*,*) 'highest wavenumber [unit:Nyquist freq. (2pi/l)*(ngrid/2)] &
       (e.g., 0.8)'
  read(*,*)  arg
  write(2,*)  'real, parameter :: lmax=2.*pi/rad1*(ni/2)*'//arg(1:len_trim(arg))
  write(*,*) 'number of bins (e.g., 30)'
  read(*,*)  arg
  write(2,*) 'integer, parameter :: npmax='//arg(1:len_trim(arg))//',&
       npmax2=npmax*2,npmax3=npmax*3'
  write(*,*) 'number density of source galaxies per square arcmin (e.g., 30)'
  read(*,*) arg
  write(2,*) 'real, parameter :: rhoasec='//arg(1:len_trim(arg))
  write(2,*) 'integer, parameter :: ntot=nint(rhoasec*leni*lenj)'
  write(*,*) 'intrinsic shear (e.g., 0.22)'
  read(*,*) arg
  write(2,*) 'real, parameter :: intshear='//arg(1:len_trim(arg))
  write(2,*) 'real :: lbin(npmax),dlbin(npmax),llowbin(npmax+1)'
  write(2,'(a21)') 'end module fieldinfo_'

  close(2)

end program initparam


c       this file contains the following user-callable routines:
c
c
c       routine iddp_rid computes the ID, to a specified precision,
c       of a matrix specified by a routine for applying its transpose
c       to arbitrary vectors. This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine iddp_rid(lproj,eps,m,n,matvect,p1,p2,p3,p4,
     1                      krank,list,proj,ier)
c
c       computes the ID of a, i.e., lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon dimensioned epsilon(m,n-krank)
c       such that the greatest singular value of epsilon
c       <= the greatest singular value of a * eps.
c
c       input:
c       lproj -- maximum usable length (in real*8 elements)
c                of the array proj
c       eps -- precision to which the ID is to be computed
c       m -- first dimension of a
c       n -- second dimension of a
c       matvect -- routine which applies the transpose
c                  of the matrix to be ID'd to an arbitrary vector;
c                  this routine must have a calling sequence
c                  of the form
c
c                  matvect(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvect
c       p2 -- parameter to be passed to routine matvect
c       p3 -- parameter to be passed to routine matvect
c       p4 -- parameter to be passed to routine matvect
c
c       output:
c       krank -- numerical rank
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               the present routine uses proj as a work array, too, so
c               proj must be at least m+1 + 2*n*(krank+1) real*8
c               elements long, where krank is the rank output
c               by the present routine
c       ier -- 0 when the routine terminates successfully;
c              -1000 when lproj is too small
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least m+1 + 2*n*(krank+1) real*8
c               elements long, where krank is the rank output
c               by the present routine.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,list(n),krank,lw,iwork,lwork,ira,kranki,lproj,
     1          lra,ier,k
        real*8 eps,p1,p2,p3,p4,proj(*)
        external matvect
c
c
        ier = 0
c
c
c       Allocate memory in proj.
c
        lw = 0
c
        iwork = lw+1
        lwork = m+2*n+1
        lw = lw+lwork
c
        ira = lw+1
c
c
c       Find the rank of a.
c
        lra = lproj-lwork
        call idd_findrank(lra,eps,m,n,matvect,p1,p2,p3,p4,
     1                    kranki,proj(ira),ier,proj(iwork))
        if(ier .ne. 0) return
c
c
        if(lproj .lt. lwork+2*kranki*n) then
          ier = -1000
          return
        endif
c
c
c       Transpose ra.
c
        call idd_rtransposer(n,kranki,proj(ira),proj(ira+kranki*n))
c
c
c       Move the tranposed matrix to the beginning of proj.
c
        do k = 1,kranki*n
          proj(k) = proj(ira+kranki*n+k-1)
        enddo ! k
c
c
c       ID the transposed matrix.
c
        call iddp_id(eps,kranki,n,proj,krank,list,proj(1+kranki*n))
c
c
        return
        end
c
c
c
c
        subroutine idd_findrank(lra,eps,m,n,matvect,p1,p2,p3,p4,
     1                          krank,ra,ier,w)
c
c       estimates the numerical rank krank of a matrix a to precision
c       eps, where the routine matvect applies the transpose of a
c       to an arbitrary vector. This routine applies the transpose of a
c       to krank random vectors, and returns the resulting vectors
c       as the columns of ra.
c
c       input:
c       lra -- maximum usable length (in real*8 elements) of array ra
c       eps -- precision defining the numerical rank
c       m -- first dimension of a
c       n -- second dimension of a
c       matvect -- routine which applies the transpose
c                  of the matrix whose rank is to be estimated
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvect(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvect
c       p2 -- parameter to be passed to routine matvect
c       p3 -- parameter to be passed to routine matvect
c       p4 -- parameter to be passed to routine matvect
c
c       output:
c       krank -- estimate of the numerical rank of a
c       ra -- product of the transpose of a and a matrix whose entries
c             are pseudorandom realizations of i.i.d. random numbers,
c             uniformly distributed on [0,1];
c             ra must be at least 2*n*krank real*8 elements long
c       ier -- 0 when the routine terminates successfully;
c              -1000 when lra is too small
c
c       work:
c       w -- must be at least m+2*n+1 real*8 elements long
c
c       _N.B._: ra must be at least 2*n*krank real*8 elements long.
c               Also, the algorithm used by this routine is randomized.
c
        implicit none
        integer m,n,lw,krank,ix,lx,iy,ly,iscal,lscal,lra,ier
        real*8 eps,p1,p2,p3,p4,ra(n,*),w(m+2*n+1)
        external matvect
c
c
        lw = 0
c
        ix = lw+1
        lx = m
        lw = lw+lx
c
        iy = lw+1
        ly = n
        lw = lw+ly
c
        iscal = lw+1
        lscal = n+1
        lw = lw+lscal
c
c
        call idd_findrank0(lra,eps,m,n,matvect,p1,p2,p3,p4,
     1                     krank,ra,ier,w(ix),w(iy),w(iscal))
c
c
        return
        end
c
c
c
c
        subroutine idd_findrank0(lra,eps,m,n,matvect,p1,p2,p3,p4,
     1                           krank,ra,ier,x,y,scal)
c
c       routine idd_findrank serves as a memory wrapper
c       for the present routine. (Please see routine idd_findrank
c       for further documentation.)
c
        implicit none
        integer m,n,krank,ifrescal,k,lra,ier
        real*8 x(m),ra(n,2,*),p1,p2,p3,p4,scal(n+1),y(n),eps,residual,
     1         enorm
        external matvect
c
c
        ier = 0
c
c
        krank = 0
c
c
c       Loop until the relative residual is greater than eps,
c       or krank = m or krank = n.
c
 1000   continue
c
c
          if(lra .lt. n*2*(krank+1)) then
            ier = -1000
            return
          endif
c
c
c         Apply the transpose of a to a random vector.
c
          call id_srand(m,x)
          call matvect(m,x,n,ra(1,1,krank+1),p1,p2,p3,p4)
c
          do k = 1,n
            y(k) = ra(k,1,krank+1)
          enddo ! k
c
c
          if(krank .eq. 0) then
c
c           Compute the Euclidean norm of y.
c
            enorm = 0
c
            do k = 1,n
              enorm = enorm + y(k)**2
            enddo ! k
c
            enorm = sqrt(enorm)
c
          endif ! krank .eq. 0
c
c
          if(krank .gt. 0) then
c
c           Apply the previous Householder transformations to y.
c
            ifrescal = 0
c
            do k = 1,krank
              call idd_houseapp(n-k+1,ra(1,2,k),y(k),
     1                          ifrescal,scal(k),y(k))
            enddo ! k
c
          endif ! krank .gt. 0
c
c
c         Compute the Householder vector associated with y.
c
          call idd_house(n-krank,y(krank+1),
     1                   residual,ra(1,2,krank+1),scal(krank+1))
          residual = abs(residual)
c
c
          krank = krank+1
c
c
        if(residual .gt. eps*enorm
     1   .and. krank .lt. m .and. krank .lt. n)
     2   goto 1000
c
c
c       Delete the Householder vectors from the array ra.
c
        call idd_crunch(n,krank,ra)
c
c
        return
        end
c
c
c
c
        subroutine idd_crunch(n,l,a)
c
c       removes every other block of n entries from a vector.
c
c       input:
c       n -- length of each block to remove
c       l -- half of the total number of blocks
c       a -- original array
c
c       output:
c       a -- array with every other block of n entries removed
c
        implicit none
        integer j,k,n,l
        real*8 a(n,2*l)
c
c
        do j = 2,l
          do k = 1,n
c
            a(k,j) = a(k,2*j-1)
c
          enddo ! k
        enddo ! j
c
c
        return
        end
c
c
c
c
        subroutine idd_rtransposer(m,n,a,at)
c
c       transposes a to obtain at.
c
c       input:
c       m -- first dimension of a, and second dimension of at
c       n -- second dimension of a, and first dimension of at
c       a -- matrix to be transposed
c
c       output:
c       at -- transpose of a
c
        implicit none
        integer m,n,j,k
        real*8 a(m,n),at(n,m)
c
c
        do k = 1,n
          do j = 1,m
c
            at(k,j) = a(j,k)
c
          enddo ! j
        enddo ! k
c
c
        return
        end


	SUBROUTINE	SET_GPROJ ( clat, clon, nhxs, dhorz, iret )

	REAL	clat, clon, dhorz
	INTEGER	nhxs
	CHARACTER	proj*4
	LOGICAL	angflg

C
C*	Set projection for cartesian grid centered on Radar location
C
        proj  = 'CED'
        angl1 = clat
        angl2 = clon
        angl3 = 0.0
        angflg = .true.
C
C*      Compute the lat/lon of LL, UR points.
C
        alat = clat - ( ( nhxs - 1 ) * dhorz / 2.0) / 111.111
        alon = clon - ( ( nhxs - 1 ) * dhorz / 2.0) /
     +                          (111.111*COS(DTR*clat))
        blat = clat + ( ( nhxs - 1 ) * dhorz / 2.0) / 111.111
        blon = clon + ( ( nhxs - 1 ) * dhorz / 2.0) /
     +                          (111.111*COS(DTR*clat))

C
C*      Set the GRID projection.
C
        CALL GSGPRJ(proj, angl1, angl2, angl3,
     +              nhxs, nhxs, alat, alon, blat, blon, iret)
C
	IF ( iret .ne. 0 ) THEN
	    CALL ER_WMSG ( 'SET_GPROJ', iret, ' ', ier )
	END IF

	RETURN
	END

	SUBROUTINE	SET_CXSTNS ( cxstns )

	INCLUDE	'GEMPRM.PRM'

	CHARACTER*(*) 	cxstns
	CHARACTER	endpts*(LLMXLN)

	COMMON  / DCCMN /
     +		endpts

	endpts = cxstns

	RETURN
	END

	SUBROUTINE	GET_CXPTS ( rgx, rgy, rlt, rln, iret )

	INCLUDE 'GEMPRM.PRM'

	REAL	rgx(*), rgy(*), rlt(*), rln(*)
	CHARACTER	endpts*(LLMXLN), cxpts(2)*(LLMXLN)
        COMMON  / DCCMN /
     +          endpts

	iret = 0

	igt = INDEX ( endpts, '>' )
        IF ( igt .eq. 0 ) THEN
            iret = -4
            CALL ER_WMSG  ( 'NEXR2RHI', iret, ' ', ier )
        ELSE
            CALL ST_CLST ( endpts, '>', ' ', 2, cxpts, nums, ier )
            DO i = 1, 2
                CALL GR_PLOC ( cxpts (i), rgx(i), rgy(i), rlt(i),
     +			rln(i), iret )

                IF ( iret .ne. 0 ) THEN
                    CALL ER_WMSG('GR', iret, ' ', ierr)
                END IF
            END DO
        END IF

	RETURN
	END


!
!   FnXSH.f90
!
!
!   Created by Kurt Mitman on 19/03/15.
!   Copyright 2015 __MyCompanyName__. All rights reserved.
!

DOUBLE PRECISION FUNCTION FnXSdemand(pph)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: pph(2)
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

CALL  BiLinInterp2(ngpPhh,GridPh,ngpPhr,GridPrPh,XSdemand,pph(1),pph(2),FnXSdemand)
!FnXSdemand = (pph(1)-0.50)**2+(pph(2)-0.10d0)**2

END FUNCTION FnXSdemand


cdis
cdis    Open Source License/Disclaimer, Forecast Systems Laboratory
cdis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
cdis
cdis    This software is distributed under the Open Source Definition,
cdis    which may be found at http://www.opensource.org/osd.html.
cdis
cdis    In particular, redistribution and use in source and binary forms,
cdis    with or without modification, are permitted provided that the
cdis    following conditions are met:
cdis
cdis    - Redistributions of source code must retain this notice, this
cdis    list of conditions and the following disclaimer.
cdis
cdis    - Redistributions in binary form must provide access to this
cdis    notice, this list of conditions and the following disclaimer, and
cdis    the underlying source code.
cdis
cdis    - All modifications to this software must be clearly documented,
cdis    and are solely the responsibility of the agent making the
cdis    modifications.
cdis
cdis    - If significant modifications or enhancements are made to this
cdis    software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
cdis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
cdis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
cdis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
cdis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
cdis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
cdis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
cdis
cdis

	function ept(t,td,p)
c
c   this function returns the equivalent potential temperature ept
c   (celsius) for a parcel of air initially at temperature t (celsius),
c   dew point td (celsius) and pressure p (millibars).
c
c	baker,schlatter	17-may-1982	original version
c
c	the formula used
c   is eq.(43) in bolton, david, 1980: "the computation of equivalent
c   potential temperature," monthly weather review, vol. 108, no. 7
c   (july), pp. 1046-1053. the maximum error in ept in 0.3c.  in most
c   cases the error is less than 0.1c.
c
c   compute the mixing ratio (grams of water vapor per kilogram of
c   dry air).
	w = wmr(p,td)
c   compute the temperature (celsius) at the lifting condensation level.
	tlcl = tcon(t,td)
	tk = t+273.16
	tl = tlcl+273.16
	pt = tk*(1000./p)**(0.2854*(1.-0.00028*w))
	eptk = pt*exp((3.376/tl-0.00254)*w*(1.+0.00081*w))
	ept= eptk-273.16
	return
	end


!==============================================================================!
  real function Turb_Mod_Prandtl_Number(turb, c)
!------------------------------------------------------------------------------!
!   Computes turbulent Prandtl number according to Kays, W. M. and             !
!   Crawford, M. E., Convective Heat and Mass Transfer,                        !
!   3rd edn. McGraw-Hill, New York, 1993.                                      !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type), target :: turb
  integer                 :: c
  real                    :: pr, pr_t_inf, pe_t
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type), pointer :: flow
!==============================================================================!

  ! Take alias to the flow to access its properties
  flow => turb % pnt_flow

  pr = Field_Mod_Prandtl_Number(flow, c)
  pr_t_inf = 0.85
  pe_t     = max(pr * turb % vis_t(c) / flow % viscosity(c), TINY)

  Turb_Mod_Prandtl_Number =                                             &
    1.0 / (   1.0/(2.0*pr_t_inf)                                        &
           +  0.3*pe_t * sqrt(1.0/pr_t_inf)                             &
           - (0.3*pe_t)**2 * (1.0-exp(-1.0/(0.3*pe_t*sqrt(pr_t_inf))))  &
          )

  end function


module usermodule1

  implicit none

  real(8) :: factor = 2.0d0

contains

  function userfunc(x, y) result(func)

    implicit none

    real(8) :: x, y, func

    func = factor * sin(x + y)**2

  end function userfunc

end module usermodule1


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

program test_euler

    use util
    use euler
    use constants

    implicit none

    real, dimension(3,3) :: rot
    real, dimension(3,3) :: sys = reshape( (/ 1,0,0, 0,1,0, 0,0,1 /), (/3,3/) )
    real, dimension(3,3) :: rotsys, rotalpha, rotbeta, rotgamma
    real :: eps = 0.001
    integer :: i

    call test_begin("test_euler")

    ! expected results for pi/2 rotations
    rotbeta = reshape( (/ 0,1,0, -1,0,0, 0,0,1 /), (/3,3/) )
    rotalpha = reshape( (/ 1,0,0, 0,0,1, 0,-1,0 /), (/3,3/) )
    rotgamma = reshape( (/ 0,1,0, -1,0,0, 0,0,1 /), (/3,3/) )

    call init_euler( pi/2., 0., 0., rot )
    do i=1,3
        rotsys(:,i) = matmul(rot,sys(:,i))
    end do
    if (any( .not. near(rotsys,rotalpha,eps) )) call test_fail("alpha")

    call init_euler( 0., pi/2., 0., rot )
    do i=1,3
        rotsys(:,i) = matmul(rot,sys(:,i))
    end do
    if (any( .not. near(rotsys,rotbeta,eps) )) call test_fail("beta")

    call init_euler( 0., 0., pi/2., rot )
    do i=1,3
        rotsys(:,i) = matmul(rot,sys(:,i))
    end do
    if (any( .not. near(rotsys,rotgamma,eps) )) call test_fail("gamma")

    call test_end()

    call cleanup()

contains

    elemental logical function near( a,b, eps )
        real, intent(in) :: a,b,eps
        near = abs(a-b) < eps
    end function

end program


module sphericaldfMod

 private
 public :: initdf,maxE,distf,gasRfromq,rho,rhofromfi, &
  &         fifromr,totalmass,rmax,rmin,setparameters

 integer,parameter :: ngrid=6000
 real, parameter :: pi=3.1415926535897932385
 real :: r(0:ngrid),dens(0:ngrid),ddensdr(0:ngrid)
 real :: cmass(0:ngrid),fi(0:ngrid),df(0:ngrid)
 real :: ddrhodfi2(0:ngrid)
 real :: extdens(0:ngrid),extmass(0:ngrid),tmass(0:ngrid)

 real, parameter :: F_ZERO_R_LIMIT=0.

 integer, parameter :: ntheta=50

! density parameters
 real :: rs, rvir,rhos
 real :: rcut,cnorm,rmax,rmin

 contains

 real function rho(r)
  real :: r
  if(r.LE.rvir) then
   rho=rhos*rs**3/r/(rs+r)**2
  else
   rho=rhos*cnorm*rs**2/(rs+r)**2*exp(-r**2/rcut**2)
  endif
 end function

 real function drhodr(r)
  real :: r
  if(r.LE.rvir) then
   drhodr=-rho(r)*(1/r+2/(rs+r))
  else
   drhodr=-rho(r)*(2*r/rcut**2+2/(rs+r))
  endif
 end function

 real function ddrhodr2(r)
  real :: r
  if(r.LE.rvir) then
   ddrhodr2=-drhodr(r)*(1/r+2/(rs+r))+rho(r)*(1/r**2+2/(rs+r)**2)
  else
   ddrhodr2=-drhodr(r)*(2*r/rcut**2+2/(rs+r))+rho(r)*(2/(rs+r)**2-2/rcut**2)
  endif
 end function

 function maxE()
  real maxE
  maxE=fi(0)
 end function

 function totalmass()
  real totalmass
  totalmass=tmass(ngrid)
 end function

 function totalcmass()
  real totalcmass
  totalcmass=cmass(ngrid)
 end function

 function distf(e) result(f)
  real :: f,e
  f=invertcumul(ngrid+1,df,fi,e)
 end function

 function gasRfromq(q) result(gasr)
  real :: gasr,q,cm
  cm=q*cmass(ngrid)
  gasr=invertcumul(ngrid+1,r,cmass,cm)
 end function

 function fifromr(rad) result (lfi)
  real :: rad,lfi
  lfi=invertcumul(ngrid+1,fi,r,rad)
 end function

 function rhofromfi(rad) result (lrho)
  real :: rad,lrho
  lrho=invertcumul(ngrid+1,dens,fi,rad)
 end function

 function int_theta(densfunc,r) result(s)
 real,external :: densfunc
 real :: dctheta,s,r
 integer :: is
  s=0
  dctheta=1.0/ntheta
  s=s+densfunc(0.,r)+densfunc(r,0.)
  do is=1,ntheta-1,2
    ctheta=is*dctheta
    s=s+4*densfunc(r*sqrt(1-ctheta**2),r*ctheta)
  enddo
  do is=2,ntheta-2,2
    ctheta=is*dctheta
    s=s+2*densfunc(r*sqrt(1-ctheta**2),r*ctheta)
  enddo
  s=s*dctheta/3.
  s=s
 end function

 subroutine setparameters(rscale,virR,rho0)
  real, optional :: rscale,virR,rho0

  if(present(rscale)) then
   rs=rscale
  else
   print*,'NFW scale length?'
   read*,rs
  endif

  if(present(virR)) then
   rvir=virR
  else
   print*,'NFW virial radius?'
   read*,rvir
  endif

  if(present(rho0)) then
   rhos=rho0
  else
   print*,'NFW density constant?'
   read*,rhos
  endif

  rcut=SQRT(2.)*rvir
  cnorm=exp(rvir**2/rcut**2)/(rvir/rs)
  rmin=1.e-4*rcut
  rmax=6*rcut

 end subroutine

 subroutine initdf(densfunc)
  integer :: i,j
  real :: fac,int
  real, external :: densfunc

  fac=exp(log(rmax/rmin)/(1.*(ngrid-1)))
!  fac=(rmax-rmin)/(ngrid-1.)

  r(1)=rmin
  dens(1)=rho(rmin)
  ddensdr(1)=drhodr(rmin)
  do i=2,ngrid-1
   r(i)=r(i-1)*fac
!   r(i)=r(i-1)+fac
   dens(i)=rho(r(i))
   ddensdr(i)=drhodr(r(i))
  enddo
  r(ngrid)=rmax
  dens(ngrid)=rho(rmax)
  ddensdr(ngrid)=drhodr(rmax)
  r(0)=0.
  dens(0)=dens(1) ! assumption !
  ddensdr(0)=0.
!  dens(0)=(4*dens(1)-dens(2))/3.
!  ddensdr(0)=(dens(1)-dens(0))/r(1)

! external density  averaged over theta
  extdens(0)=1/3.*densfunc(0.,rmin)+2./3.*densfunc(rmin,0.)
  do i=1,ngrid
   extdens(i)=int_theta(densfunc,r(i))
  enddo

  cmass(0)=0.
  cmass(1)=4/3.*Pi*r(1)**3*dens(0)
  do i=2,ngrid
   cmass(i)=cmass(i-1)+4*Pi*(r(i)-r(i-1))*(r(i)**2*dens(i)+r(i-1)**2*dens(i-1))/2.
  enddo

  extmass(0)=0.
  extmass(1)=4/3.*Pi*r(1)**3*extdens(0)
  do i=2,ngrid
   extmass(i)=extmass(i-1)+4*Pi*(r(i)-r(i-1))*(r(i)**2*extdens(i)+r(i-1)**2*extdens(i-1))/2.
  enddo

  write(0,*) 'halo reports a mass of:', cmass(ngrid)
  write(0,*) 'and an external mass of:', extmass(ngrid)

  tmass=cmass+extmass

  fi(ngrid)=0
  do i=ngrid-1,1,-1
   fi(i)=fi(i+1)+(r(i+1)-r(i))*(tmass(i)/r(i)**2+tmass(i+1)/r(i+1)**2)/2.
  enddo
  fi(0)=fi(1)+r(1)*(F_ZERO_R_LIMIT+tmass(1)/r(1)**2)/2.

  do i=1,ngrid
   ddrhodfi2(i)=(r(i)**2/tmass(i))**2* &
    ((2/r(i)-4*Pi*r(i)**2*(dens(i)+extdens(i))/tmass(i))*ddensdr(i)+ddrhodr2(r(i)))
  enddo
  ddrhodfi2(0)=ddrhodfi2(1)

  df(ngrid)=0.
  do i=ngrid-1,1,-1
   int=0
   do j=ngrid-1,i+1,-1
   int=int+(fi(j)-fi(j+1))* &
       (ddrhodfi2(j)/sqrt(fi(i)-fi(j))+ddrhodfi2(j+1)/sqrt(fi(i)-fi(j+1)))/2.
   enddo
   int=int+2./3.*Sqrt((fi(i)-fi(i+1)))*(2*ddrhodfi2(i)+ddrhodfi2(i+1))
   df(i)=1/sqrt(8.)/pi**2*(int-1/sqrt(fi(i))*ddensdr(ngrid)*r(ngrid)**2/cmass(ngrid))
  enddo
  df(0)=df(1)

  open(unit=1,file='halo.df',status='UNKNOWN')
  do i=1,ngrid
  write(1,*) fi(i),df(i)
  enddo
  close(1)

! print*,'rmax,fi0,cmass:', rmax,fi(0),cmass(ngrid)

 end subroutine

  function invertcumul(n,xlist,ylist,y) result(x)
  integer :: n,bin,up,low
  real :: xlist(n),ylist(n),x,y,u,s

  if(ylist(1).LT.ylist(n)) then
   s=1
  else
   s=-1
  endif

  if(s*y.LE.s*ylist(1)) then
   x=xlist(1)
   return
  endif
  if(s*y.GE.s*ylist(n)) then
   x=xlist(n)
   return
  endif
  up=n
  low=1
  do while((up-low).GT.1)
   bin=(low+up)/2
   if(s*y.LT.s*ylist(bin)) then
    up=bin
   else
    low=bin
   endif
  enddo
  bin=up
  u=(y-ylist(bin-1))/(ylist(bin)-ylist(bin-1))
  x=(1-u)*xlist(bin-1)+u*xlist(bin)
  return
  end function

end module sphericaldfMod

 real function zerofunc(r,z)
  zerofunc=0.
 end function

subroutine sethalodf(rscl,rv,rhs)
 use sphericaldfMod
 real rscl,rv,rhs
 call setparameters(rscl,rv,rhs)
end subroutine

subroutine inithalodf(densfunc)
 use sphericaldfMod
 real, external :: zerofunc
 real, external, optional :: densfunc
 if(present(densfunc)) then
  call initdf(densfunc)
 else
  call initdf(zerofunc)
 endif
end subroutine

function halodfpsi00()
 use sphericaldfMod
 real halodfpsi00
 halodfpsi00=-maxE()
end function

function halodffi(r)
 use sphericaldfMod
 real halodffi,r
! r>rmax??
 if(r.LT.rmax) then
  halodffi=-fifromr(r)
 else
  halodffi=totalmass()*(1/rmax-1/r)
 endif
end function

function Fhalo3(E)
 use sphericaldfMod
 real Fhalo3,E,nE
 Fhalo3=0
 if(E.LT.-maxE()) then
  write(0,*)  'E error'
  write(0,*)  E, -maxE()
  stop
 endif
 nE=-E ! note: E is expected always to be > psi0!!
 if(nE.LE.0) return
 Fhalo3=distf(nE)
end function

function halodfdenspsi(psi,psi0)
 use sphericaldfMod
  real halodfdenspsi,psi,psi0,npsi
 halodfdenspsi=0
 npsi=-(psi-psi0+halodfpsi00())
 if(npsi.LE.0) return
 halodfdenspsi=rhofromfi(npsi)
end function

function halodfdens(r,z) result(x)
 use sphericaldfMod
  real r,z,x
  x=rho(sqrt(r*r+z*z))
end function

function halormax()
 use sphericaldfMod
 real halormax
 halormax=rmax
end function

function halormin()
 use sphericaldfMod
 real halormin
 halormin=rmin
end function

 function sdens(r,z)
  real r,z,sdens
  real rmdisk,zdisk,outdisk,drtrunc,erfarg,truncfac,con,diskconst,rdisk
  zdisk=0.5
  rdisk=3
  rmdisk=50.
  diskconst=rmdisk/(4.0*3.1415*rdisk**2*zdisk)
  outdisk=12
  drtrunc=.5
  sdens = 0
  if( abs(z/zdisk) .gt. 30.) return
   erfarg=(r-outdisk)/1.4142136/drtrunc
  if (erfarg.gt.4.) return
  if (erfarg.lt.-4) then
   trunfac=1
  else
   trunfac=0.5*erfc(erfarg)
  endif
  if (z.eq.0.) then
   con=1
  else
   con = exp(-abs(z/zdisk))
   con = (2.0*con/(1.0 + con*con))**2
  endif
  sdens = diskconst*exp(-r/rdisk)*con*trunfac
  end function

! program test
!  use sphericaldfMod
!  implicit none
!    integer i,j,np,count
!    real, external ::sdens,zerofunc
!
!  call initdf(sdens,6.,72.,0.04)
!
!  do i=0,ngrid-1
!   print*,r(i),dens(i),ddensdr(i)
!   print*,r(i),extdens(i),extmass(i)
!   print*,r(i),fi(i),df(i)
!  enddo
! end program


! hilbert transform

use MathClass
use ArrayClass
use IOClass
implicit none

type(Math_) :: math
type(IO_)   :: f
type(Random_) :: random
complex(complex64),allocatable :: t(:), wave(:), h_top_wave(:)&
    ,h_bottom_wave(:),spectre(:),t_w(:,:)
real(real64),allocatable :: hz(:)
real(real64) :: omega_1
real(real64) :: omega_2

integer(int32),parameter :: window_size = 4096*2

omega_1=0.10d0/math%pi
omega_2=0.3d0/math%pi

!t = linspace([0.0d0,1000.0d0],1024)
!wave = sin(omega_1*t(:)) * 0.30d0*sin(omega_2*t(:) +2.0d0)* exp(-omega_1/10.0d0*t(:) ) +0.40d0*sin(omega_1*20.0d0*t(:))
!wave(500:550) = wave(500:550)  +0.80d0*sin(omega_1*80.0d0*t(500:550))
!
!do i_i=500,510
!    wave(i_i) = wave(i_i)  + random%gauss(mu=0.0d0,sigma=0.300d0)
!enddo
!wave(400:450) = wave(400:450)*2.0d0
t    = loadtxt("input_file.txt",column=1)
wave = loadtxt("input_file.txt",column=2)
hz   = linspace([0.0d0,100.0d0],window_size)

call f%open("input_wave.txt")
call f%write(abs(t),real(wave) )
call f%close()
call f%plot(option="with lines")

t_w = short_time_FFT(wave(1:size(wave)/2 ),window_size)

call f%open("result.txt")
do i_i=1,size(t_w,1)

    if(i_i < window_size/2) cycle

    if(mod(i_i,100)/=0 ) cycle

    do j_j=1,size(t_w,2)/2
        write(f%fh,*) dble(t(i_i)),hz(j_j),abs(t_w(i_i,j_j))
    enddo
    write(f%fh,*) " "
enddo
call f%close()
call f%splot(option="with lines")

end


!    Determines average energy.  Calls
!    ..  rme
!======================================================================
   MODULE av_energy
!======================================================================

      REAL(KIND=8), DIMENSION(10) :: CCA
      REAL(KIND=8), DIMENSION(35) :: CCB

   CONTAINS

      !======================================================================
      SUBROUTINE init
         !======================================================================
         !
         !    This routine initializes arrays for the average energy
         USE factorial
         IMPLICIT NONE

         !
         CALL FACTRL(32)
         !
         !  *****  AVERAGE INTERACTIONS FOR EQUIVALENT ELECTRONS
         !
         !  *****  P - P
         !
         CCA(1) = 2.D0/25.D0
         !
         !  *****  D - D
         !
         CCA(2) = 2.D0/63.D0
         CCA(3) = 2.D0/63.D0
         !
         !  *****  F - F
         !
         CCA(4) = 4.D0/195.D0
         CCA(5) = 2.D0/143.D0
         CCA(6) = 100.D0/5577.D0
         !
         !  *****  G - G
         !
         CCA(7) = 20.D0/1309.D0
         CCA(8) = 162.D0/17017.D0
         CCA(9) = 20.D0/2431.D0
         CCA(10) = 4410.D0/371943.D0
         !
         !
         !  ***** AVERAGE INTERACTIONS FOR NON-EQUIVALENT ELECTRONS
         !
         !  *****  S - ( S, P, D, F, G )
         !
         CCB(1) = 1.D0/2.D0
         CCB(2) = 1.D0/6.D0
         CCB(3) = 1.D0/10.D0
         CCB(4) = 1.D0/14.D0
         CCB(5) = 1.D0/18.D0
         !
         !  *****  P - ( P, D, F, G )
         !
         CCB(6) = 1.D0/6.D0
         CCB(7) = 1.D0/15.D0
         CCB(8) = 1.D0/15.D0
         CCB(9) = 3.D0/70.D0
         CCB(10) = 3.D0/70.D0
         CCB(11) = 2.D0/63.D0
         CCB(12) = 2.D0/63.D0
         CCB(13) = 5.D0/198.D0
         !
         !  *****  D - ( D, F, G )
         !
         CCB(14) = 1.D0/10.D0
         CCB(15) = 1.D0/35.D0
         CCB(16) = 1.D0/35.D0
         CCB(17) = 3.D0/70.D0
         CCB(18) = 2.D0/105.D0
         CCB(19) = 5.D0/231.D0
         CCB(20) = 1.D0/35.D0
         CCB(21) = 10.D0/693.D0
         CCB(22) = 5.D0/286.D0
         !
         !  *****  F - ( F, G )
         !
         CCB(23) = 1.D0/14.D0
         CCB(24) = 2.D0/105.D0
         CCB(25) = 1.D0/77.D0
         CCB(26) = 50.D0/3003.D0
         CCB(27) = 2.D0/63.D0
         CCB(28) = 1.D0/77.D0
         CCB(29) = 10.D0/1001.D0
         CCB(30) = 35.D0/2574.D0
         !
         !  *****  G - ( G )
         !
         CCB(31) = 1.D0/18.D0
         CCB(32) = 10.D0/693.D0
         CCB(33) = 9.D0/1001.D0
         CCB(34) = 10.D0/1287.D0
         CCB(35) = 245.D0/21879.D0
         RETURN
      END SUBROUTINE INIT

      !======================================================================
      REAL(KIND=8) FUNCTION CA(l, k)
         !======================================================================
         !
         !    Computes the average-energy direct contribution from a pair of
         !    l orbitals
         !----------------------------------------------------------------------
         IMPLICIT NONE
         INTEGER, EXTERNAL :: rme
         INTEGER, INTENT(IN) :: l, k
         !-----------------------------------------------
         !
         IF (L <= 4) THEN
            CA = CCA((L*(L - 1) + K)/2)
         ELSE
            ! corrected according to Prof. P. Bogdanovich 1996.03.18
            CA = RME(L, L, K)**2/real(((2*L + 1)*(4*L + 1)), 8)
         ENDIF

      END FUNCTION CA

      !======================================================================
      REAL(KIND=8) FUNCTION CB(l, lp, k)
         !======================================================================
         !
         !    Computes the average-energy exchange contribution from a pair of
         !    l and lp orbitals
         !----------------------------------------------------------------------
         IMPLICIT NONE
         INTEGER, EXTERNAL :: rme
         INTEGER, INTENT(IN) :: l, lp, k
         INTEGER, DIMENSION(0:4) :: ICBPTR
         INTEGER :: L1, L2
         !-----------------------------------------------
         DATA ICBPTR/1, 6, 14, 23, 31/
         !
         IF (L <= LP) THEN
            L1 = L
            L2 = LP
         ELSE
            L1 = LP
            L2 = L
         ENDIF

         IF (L2 <= 4) THEN
            CB = CCB(ICBPTR(L1) + (K + L1 - L2)/2 + (L1 + 1)*(L2 - L1))
         ELSE
            CB = RME(L, LP, K)**2/real((2*(2*L + 1)*(2*LP + 1)), 8)
         ENDIF

      END FUNCTION CB

   END MODULE av_energy
!======================================================================
   FUNCTION RME(L, LP, K)
!======================================================================
!
!--- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP)  -  SEE FANO
!    AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81
!
!
!------------------------------------------------------------------
      USE factorial
      IMPLICIT NONE
      REAL(KIND=8) :: RME
      INTEGER, INTENT(IN) :: L
      INTEGER, INTENT(IN) :: LP
      INTEGER, INTENT(IN) :: K
      INTEGER :: I2G, IG, I1, I2, I3
      REAL(KIND=8) :: QUSQRT

      IF (MIN0(L, LP) == 0) THEN
         RME = 1.D0
      ELSE IF (K == 0) THEN
         RME = 2*L + 1
         RME = DSQRT(RME)
      ELSE
         I2G = L + LP + K
         IG = I2G/2
         IF (I2G - 2*IG /= 0) THEN
            RME = 0.D0
         ELSE
            I1 = IG - L
            I2 = IG - LP
            I3 = IG - K
            QUSQRT = (2*L + 1)*(2*LP + 1)
            RME = DSQRT(QUSQRT)*DEXP((GAM(2*I1 + 1) + GAM(2*I2 + 1) + GAM(2*I3 + 1) - GAM( &
                                      I2G + 2))/2.D0 + GAM(IG + 1) - GAM(I1 + 1) - GAM(I2 + 1) - GAM(I3 + 1))
         ENDIF
      ENDIF

   END FUNCTION RME


!> \brief \b DZNRM2
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       DOUBLE COMPLEX X(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DZNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!>    DZNRM2 := sqrt( x**H*x )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension (N)
!>         complex vector with N elements
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER, storage spacing between elements of X
!>          If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!>          If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!>          If INCX = 0, x isn't a vector so there is no need to call
!>          this subroutine.  If you call it anyway, it will count x(1)
!>          in the vector norm N times.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup single_blas_level1
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
!  =====================================================================
function DZNRM2( n, x, incx )
   integer, parameter :: wp = kind(1.d0)
   real(wp) :: DZNRM2
!
!  -- Reference BLAS level1 routine (version 3.9.1) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     March 2021
!
!  .. Constants ..
   real(wp), parameter :: zero = 0.0_wp
   real(wp), parameter :: one  = 1.0_wp
   real(wp), parameter :: maxN = huge(0.0_wp)
!  ..
!  .. Blue's ccaling constants ..
   real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
       (minexponent(0._wp) - 1) * 0.5_wp)
   real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
       (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
   real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
       (minexponent(0._wp) - 1) * 0.5_wp))
   real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
       (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp))
!  ..
!  .. Scalar Arguments ..
   integer :: incx, n
!  ..
!  .. Array Arguments ..
   complex(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
!
!  Quick return if possible
!
   DZNRM2 = zero
   if( n <= 0 ) return
!
   scl = one
   sumsq = zero
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(real(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ax = abs(aimag(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range
!
      scl = one
      sumsq = amed
   end if
   DZNRM2 = scl*sqrt( sumsq )
   return
end function


C$Procedure      RECRAD ( Rectangular coordinates to RA and DEC )

      SUBROUTINE RECRAD ( RECTAN, RANGE, RA, DEC )

C$ Abstract
C
C     Convert rectangular coordinates to range, right ascension,
C     and declination.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   RECTAN ( 3 )
      DOUBLE PRECISION   RANGE
      DOUBLE PRECISION   RA
      DOUBLE PRECISION   DEC

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RECTAN     I   Rectangular coordinates of a point.
C     RANGE      O   Distance of the point from the origin.
C     RA         O   Right ascension in radians.
C     DEC        O   Declination in radians.
C
C$ Detailed_Input
C
C     RECTAN     The rectangular coordinates of a point.
C
C$ Detailed_Output
C
C     RANGE      is the distance of the point from the origin.
C
C                The units associated with RANGE are those
C                associated with the input RECTAN.
C
C
C     RA         is the right ascension of RECTAN.  This is the angular
C                distance measured toward the east from the prime
C                meridian to the meridian containing the input point.
C                The direction of increasing right ascension is from
C                the +X axis towards the +Y axis.
C
C                RA is output in radians.  The range of RA is [0, 2*pi].
C
C
C     DEC        is the declination of RECTAN.  This is the angle from
C                the XY plane of the ray from the origin through the
C                point.
C
C                DEC is output in radians.  The range of DEC is
C                [-pi/2, pi/2].
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the X and Y components of RECTAN are both zero, the
C        right ascension is set to zero.
C
C     2) If RECTAN is the zero vector, right ascension and declination
C        are both set to zero.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the range, right ascension, and declination
C     of a point specified in rectangular coordinates.
C
C     The output is defined by a distance from a central reference
C     point, an angle from a reference meridian, and an angle above
C     the equator of a sphere centered at the central reference
C     point.
C
C$ Examples
C
C     The following code fragment converts right ascension and
C     declination from the B1950 reference frame to the J2000 frame.
C
C        C
C        C     Convert RA and DEC to a 3-vector expressed in
C        C     the B1950 frame.
C        C
C              CALL RADREC ( 1.D0, RA, DEC, V1950 )
C        C
C        C     We use the SPICELIB routine PXFORM to obtain the
C        C     transformation  matrix for converting vectors between
C        C     the B1950 and J2000 reference frames.  Since
C        C     both frames are inertial, the input time value we
C        C     supply to PXFORM is arbitrary.  We choose zero
C        C     seconds past the J2000 epoch.
C        C
C              CALL PXFORM ( 'B1950', 'J2000', 0.D0, MTRANS )
C        C
C        C     Transform the vector to the J2000 frame.
C        C
C              CALL MXV ( MTRANS, V1950, V2000 )
C        C
C        C     Find the RA and DEC of the J2000-relative vector.
C        C
C              CALL RECRAD ( V2000, R, RA, DEC )
C
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 30-JUL-2003 (NJB) (CHA)
C
C        Various header changes were made to improve clarity.  Some
C        minor header corrections were made.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (HAN)
C
C-&

C$ Index_Entries
C
C     rectangular coordinates to ra and dec
C     rectangular to right_ascension and declination
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      TWOPI

C
C     Call the subroutine RECLAT to convert the rectangular coordinates
C     into latitudinal coordinates.  In RECLAT, the longitude ( which
C     is returned to this subroutine as RA ) ranges from - pi to pi
C     radians.   Because the right ascension ranges from zero to
C     two pi radians, whenever RA is negative two pi must be added to
C     it.
C
      CALL RECLAT ( RECTAN, RANGE, RA, DEC )

      IF ( RA .LT. 0 ) THEN
         RA = RA + TWOPI()
      END IF

      RETURN
      END


c  rilooks -  average real,imaginary looks
      complex a(131072),b(131072)
      real b1(131072),b2(131072)
      character*120 fin,fout
      integer ierr

      print '(a,$)',' Input file? '
      read(*,'(a)') fin
      print '(a,$)',' Output file? '
      read(*,'(a)') fout

      print '(a,$)',' Complex pixels across, down in input: '
      read *,na,nd
      print '(a,$)',' Looks across, down: '
      read *,la,ld

      open(21,file=fin,form='unformatted',access='direct',recl=na*8)
      open(22,file=fout,form='unformatted',access='direct',recl=na/la*8)

      lineout=0
      do line=1,nd,ld
         if(mod(line,4096).eq.1)print *,line
         lineout=lineout+1
         do j=1,na
            b1(j)=0.
            b2(j)=0.
         end do

c  take looks down
         do i=0,ld-1
            read(21,rec=line+i,iostat=ierr)(a(k),k=1,na)
            if(ierr .ne. 0) go to 99
            do j=1,na
               b1(j)=b1(j)+real(a(j))**2
               b2(j)=b2(j)+aimag(a(j))**2
            end do
         end do
c  take looks across
         jpix=0
         do j=1,na,la
            jpix=jpix+1
            sum1=0.
            sum2=0.
            do k=0,la-1
               sum1=sum1+b1(j+k)
               sum2=sum2+b2(j+k)
            end do
c            b(jpix)=cmplx(sqrt(sum1),sqrt(sum2))/la/ld
            b(jpix)=cmplx(sqrt(sum1),sqrt(sum2))
         end do
         write(22,rec=lineout)(b(k),k=1,na/la)
      end do
 99   end
CPOD
CPOD=pod
CPOD
CPOD=head1 USAGE
CPOD
CPOD rilooks: takes real and imaginary looks of a complex input rater file
CPOD
CPOD usage: rilooks prompts for the following inputs:
CPOD        Input file / Output file / Complex pixels across, down in input/ Looks across, down
CPOD
CPOD=head1 FUNCTION
CPOD
CPOD FUNCTIONAL DESCRIPTION: takes <re>,<im> looks
CPOD
CPOD=head1 ROUTINES CALLED
CPOD
CPOD ROUTINES CALLED:
CPOD
CPOD=head1 CALLED BY
CPOD
CPOD=head1 FILES USED
CPOD
CPOD reads in a binary complex/c*8 input file (width/length)
CPOD
CPOD=head1 FILES CREATED
CPOD
CPOD write a binary complex/c*8 output file (width/#across looks)(Length/#down looks)
CPOD
CPOD=head1 DIAGNOSTIC FILES
CPOD
CPOD=head1 HISTORY
CPOD
CPOD DATE WRITTEN:
CPOD
CPOD PROGRAMMER: ??
CPOD
CPOD=head1 LAST UPDATE
CPOD  Date Changed        Reason Changed
CPOD  ------------       ----------------
CPOD
CPOD: CPOD comments V0.1: trm Feb 13th '04
CPOD
CPOD=cut


      SUBROUTINE LUDCMP(A,N,NP,INDX,D)
      PARAMETER (NMAX=100,TINY=1.0E-20)
      DIMENSION A(NP,NP),INDX(N),VV(NMAX)
      D=1.
      DO 12 I=1,N
        AAMAX=0.
        DO 11 J=1,N
          IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
11      CONTINUE
        IF (AAMAX.EQ.0.) PAUSE 'Singular matrix.'
        VV(I)=1./AAMAX
12    CONTINUE
      DO 19 J=1,N
        IF (J.GT.1) THEN
          DO 14 I=1,J-1
            SUM=A(I,J)
            IF (I.GT.1)THEN
              DO 13 K=1,I-1
                SUM=SUM-A(I,K)*A(K,J)
13            CONTINUE
              A(I,J)=SUM
            ENDIF
14        CONTINUE
        ENDIF
        AAMAX=0.
        DO 16 I=J,N
          SUM=A(I,J)
          IF (J.GT.1)THEN
            DO 15 K=1,J-1
              SUM=SUM-A(I,K)*A(K,J)
15          CONTINUE
            A(I,J)=SUM
          ENDIF
          DUM=VV(I)*ABS(SUM)
          IF (DUM.GE.AAMAX) THEN
            IMAX=I
            AAMAX=DUM
          ENDIF
16      CONTINUE
        IF (J.NE.IMAX)THEN
          DO 17 K=1,N
            DUM=A(IMAX,K)
            A(IMAX,K)=A(J,K)
            A(J,K)=DUM
17        CONTINUE
          D=-D
          VV(IMAX)=VV(J)
        ENDIF
        INDX(J)=IMAX
        IF(J.NE.N)THEN
          IF(A(J,J).EQ.0.)A(J,J)=TINY
          DUM=1./A(J,J)
          DO 18 I=J+1,N
            A(I,J)=A(I,J)*DUM
18        CONTINUE
        ENDIF
19    CONTINUE
      IF(A(N,N).EQ.0.)A(N,N)=TINY
      RETURN
      END