! !Solve a self-consistent problem using different
! !iteration mixing schemes.
! MODULE MIXING
!   USE CONSTANTS
!   USE MATRIX
!   implicit none
!   private

!   interface simple_mix
!      module procedure simple_mix_s,simple_mix_v
!   end interface simple_mix

!   public :: simple_mix
!   public :: broyden_mix
!   public :: broyden_mix_scalar
! contains

!   subroutine simple_mix_s(vout,vin,alpha)
!     real(8),intent(inout) :: vout
!     real(8),intent(in)    :: vin
!     real(8),intent(in)    :: alpha
!     real(8)               :: f,vout_(1),vin_(1)
!     vout_(1)=vout;vin_(1)=vin
!     call simple_mix_v(vout_,vin_,alpha)
!     vout=vout_(1)
!   end subroutine simple_mix_s

!   subroutine simple_mix_v(vout,vin,alpha)
!     real(8),intent(inout) :: vout(:)
!     real(8),intent(in)    :: vin(size(vout))
!     real(8),intent(in)    :: alpha
!     real(8)               :: f(size(vout))
!     F=vout-vin
!     vout=vin+alpha*F
!   end subroutine simple_mix_v

!   subroutine broyden_mix_scalar(vout,vin,alpha,M,w0)
!     real(8),intent(inout)                   :: vout
!     real(8),intent(in)                      :: vin
!     real(8),intent(in)                      :: alpha
!     real(8)                                 :: amix
!     integer,intent(in)                      :: M
!     real(8),optional                        :: w0
!     real(8),save                            :: w0_
!     real(8),dimension(1) :: vout_,vin_
!     integer  :: N
!     w0_=0.01d0;if(present(w0))w0_=w0
!     N=1
!     vout_(1)=vout;vin_(1)=vin
!     call broyden_mix(N,vout_,vin_,alpha,M,w0_)
!     vout=vout_(1)
!   end subroutine broyden_mix_scalar

!   subroutine broyden_mix(N,vout,vin,alpha,M,w0)
!     integer,intent(in)                      :: N
!     ! real(8),intent(inout)                   :: vout(N)
!     ! real(8),intent(in)                      :: vin(N)
!     real(8)                   :: vout(N)
!     real(8)                      :: vin(N)
!     real(8),intent(in)                      :: alpha
!     real(8)                                 :: amix
!     integer,intent(in)                      :: M
!     real(8),optional                        :: w0
!     real(8),save                            :: w0_
!     integer,save                            :: iter=1
!     integer                                 :: iter_used,ipos,inext
!     real(8),allocatable,dimension(:,:),save :: Df,Dv,Beta
!     real(8),allocatable,dimension(:),save   :: Curv,work
!     real(8)                                 :: norm,gamma,curvature
!     integer                                 :: i,j
!     !Save alpha mixing:
!     amix=alpha
!     !Get f=vout-vin
!     vout = vout-vin
!     !linear mixing if M=0 or first iteration
!     if(iter==1.OR.M==0)then
!        vout=vin+amix*vout
!        return
!     endif
!     !Get broyden mixing pointer
!     iter_used=min(iter-1,M)
!     ipos     = iter-1-((iter-2)/M)*M
!     inext    = iter-((iter-1)/M)*M
!     !allocate aux arrays and define the
!     !DeltaF^(n) = F^(n+1)-F^(n)/|F^(n+1)-F^(n)|
!     !DeltaV^(n) = V^(n+1)-V^(n)/|F^(n+1)-F^(n)|
!     if(iter==1)then
!        w0_=0.01d0;if(present(w0))w0_=w0
!        if(allocated(Df))deallocate(Df)
!        if(allocated(Dv))deallocate(Dv)
!        if(allocated(beta))deallocate(beta)
!        if(allocated(curv))deallocate(curv)
!        if(allocated(work))deallocate(work)
!        allocate(Df(M,N),Dv(M,N),Beta(M,M),Curv(N),work(M))
!     else
!        Df(ipos,:) = Vout - Df(ipos,:)
!        Dv(ipos,:) = Vin  - Dv(ipos,:)
!        norm = 1.d0/sqrt(dot_product(Df(ipos,:),Df(ipos,:)))
!        Df(ipos,:)=Df(ipos,:)/norm
!        Dv(ipos,:)=Dv(ipos,:)/norm
!     endif
!     !Build
!     !we are assuming w(i)=w(j)=1
!     !beta = [w(0)*w(0)*delta(i,j) + w(i)*w(j)*a(i,j)]^-1
!     do i=1,iter_used
!        do j=1+1,iter_used
!           beta(i,j) = dot_product(Df(i,:),Df(j,:))
!        enddo
!        beta(i,i) = 1.d0+w0_*w0_!ACTHUNG I SUSPECT AN ERROR HERE!!!
!     enddo
!     call matrix_inverse(beta)
!     !vector(2) = vold + amix*f - sum_i sum_j cm(j)*b(j,i)*w(j)*u(i)*w(i)
!     do i=1,iter_used
!        do j=i+1,iter_used
!           beta(j,i)=beta(i,j)
!        enddo
!        work(i) = dot_product(Df(i,:),vout)
!     enddo
!     curv = amix*vout
!     do i=1,iter_used
!        gamma=0.d0
!        do j=i+1,iter_used
!           gamma = gamma+beta(j,i)*work(j)
!        enddo
!        curv(:) = curv(:) - gamma*(Dv(i,:)+amix*Df(i,:))
!     enddo
!     Df(inext,:)=vout
!     Dv(inext,:)=vin
!     curvature=dot_product(vout,curv)
!     if(curvature>-1.d0)then
!        vout = vin + curv
!     else
!        vout = vin + amix*0.5d0*vout
!     endif
!   end subroutine broyden_mix

! END MODULE MIXING


PROGRAM mfcszo

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

!     ===========================================================
!     Purpose : This program computes the complex zeros of the
!     Fresnel integral C(z) or S(z) using subroutine
!     FCSZO
!     Input :   KF  --- Function code
!     KF=1 for C(z) or KF=2 for S(z)
!     NT  --- Total number of zeros
!     Output:   ZO(L) --- L-th zero of C(z) or S(z)
!     Example:  NT=10

!     n     Complex zeros of C(z)        Complex zeros of S(z)
!     ------------------------------------------------------------
!     1    1.7436675 + i .30573506      2.0092570 + i .28854790
!     2    2.6514596 + i .25290396      2.8334772 + i .24428524
!     3    3.3203593 + i .22395346      3.4675331 + i .21849268
!     4    3.8757345 + i .20474747      4.0025782 + i .20085103
!     5    4.3610635 + i .19066973      4.4741893 + i .18768859
!     6    4.7976077 + i .17970801      4.9006784 + i .17732036
!     7    5.1976532 + i .17081930      5.2929467 + i .16884418
!     8    5.5690602 + i .16339854      5.6581068 + i .16172492
!     9    5.9172173 + i .15706585      6.0011034 + i .15562108
!     10    6.2460098 + i .15156826      6.3255396 + i .15030246
!     ===========================================================

IMPLICIT DOUBLE PRECISION (e,p,w)
IMPLICIT COMPLEX *16 (c,z)
DIMENSION zo(100)
WRITE(*,*)'Please Enter KF and NT '
!     READ(*,*)KF,NT
kf=2
nt=10
WRITE(*,20)kf,nt
WRITE(*,*)' *****     Please Wait !     *****'
CALL fcszo(kf,nt,zo)
WRITE(*,*)
IF (kf == 1) WRITE(*,*)'  n        Complex zeros of C(z)'
IF (kf == 2) WRITE(*,*)'  n        Complex zeros of S(z)'
WRITE(*,*)'-----------------------------------'
DO  i=1,nt
  WRITE(*,30) i,zo(i)
END DO
20   FORMAT(2X,'KF=',i2,',     ','NT=',i3)
30   FORMAT(1X,i3,f13.8,2X,2H+i,f13.8)
END PROGRAM mfcszo

SUBROUTINE fcszo(kf,nt,zo)

!     ===============================================================
!     Purpose: Compute the complex zeros of Fresnel integral C(z)
!     or S(z) using modified Newton's iteration method
!     Input :  KF  --- Function code
!     KF=1 for C(z) or KF=2 for S(z)
!     NT  --- Total number of zeros
!     Output:  ZO(L) --- L-th zero of C(z) or S(z)
!     Routines called:
!     (1) CFC for computing Fresnel integral C(z)
!     (2) CFS for computing Fresnel integral S(z)
!     ==============================================================

INTEGER, INTENT(IN)                      :: kf
INTEGER, INTENT(IN)                      :: nt
COMPLEX, INTENT(IN OUT)                  :: zo(nt)
IMPLICIT DOUBLE PRECISION (e,p,w)
IMPLICIT COMPLEX *16 (c,z)

w=0.0
pi=3.141592653589793D0
DO  nr=1,nt
  IF (kf == 1) psq=DSQRT(4.0D0*nr-1.0D0)
  IF (kf == 2) psq=2.0D0*nr**(0.5)
  px=psq-DLOG(pi*psq)/(pi*pi*psq**3.0)
  py=DLOG(pi*psq)/(pi*psq)
  z=CMPLX(px,py)
  IF (kf == 2) THEN
    IF (nr == 2) z=(2.8334,0.2443)
    IF (nr == 3) z=(3.4674,0.2185)
    IF (nr == 4) z=(4.0025,0.2008)
  END IF
  it=0
  DO
    15     it=it+1
    IF (kf == 1) CALL cfc(z,zf,zd)
    IF (kf == 2) CALL cfs(z,zf,zd)
    zp=(1.0D0,0.0D0)
    DO  i=1,nr-1
      zp=zp*(z-zo(i))
    END DO
    zfd=zf/zp
    zq=(0.0D0,0.0D0)
    DO  i=1,nr-1
      zw=(1.0D0,0.0D0)
      DO  j=1,nr-1
        IF (.NOT.(j == i)) zw=zw*(z-zo(j))
      END DO
      zq=zq+zw
    END DO
    zgd=(zd-zq*zfd)/zp
    z=z-zfd/zgd
    w0=w
    w=CDABS(z)
    IF (.NOT.(it <= 50.AND.DABS((w-w0)/w) > 1.0D-12)) EXIT
  END DO
  zo(nr)=z
END DO
RETURN
END SUBROUTINE fcszo

SUBROUTINE cfc(z,zf,zd)

!     =========================================================
!     Purpose: Compute complex Fresnel integral C(z) and C'(z)
!     Input :  z --- Argument of C(z)
!     Output:  ZF --- C(z)
!     ZD --- C'(z)
!     =========================================================

COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: zf
COMPLEX, INTENT(OUT)                     :: zd
IMPLICIT DOUBLE PRECISION (e,p,w)
IMPLICIT COMPLEX *16 (c,s,z)

eps=1.0D-14
pi=3.141592653589793D0
w0=CDABS(z)
zp=0.5D0*pi*z*z
zp2=zp*zp
z0=(0.0D0,0.0D0)
IF (z == z0) THEN
  c=z0
ELSE IF (w0 <= 2.5) THEN
  cr=z
  c=cr
  igoon=1
  DO k=1,80
    cr=-.5D0*cr*(4.0D0*k-3.0D0)/k/(2.0D0*k-1.0D0) /(4.0D0*k+1.0D0)*zp2
    c=c+cr
    wa=CDABS(c)
    IF (DABS((wa-wa0)/wa) < eps.AND.k > 10) igoon=0
    IF (igoon == 1) THEN
      wa0=wa
    ELSE
      EXIT
    END IF
  END DO
ELSE IF (w0 > 2.5.AND.w0 < 4.5) THEN
  m=85
  c=z0
  cf1=z0
  cf0=(1.0D-100,0.0D0)
  DO  k=m,0,-1
    cf=(2.0D0*k+3.0D0)*cf0/zp-cf1
    IF (k == INT(k/2)*2) c=c+cf
    cf1=cf0
    cf0=cf
  END DO
  c=CDSQRT(2.0D0/(pi*zp))*CDSIN(zp)/cf*c
ELSE
  cr=(1.0D0,0.0D0)
  cf=(1.0D0,0.0D0)
  DO  k=1,20
    cr=-.25D0*cr*(4.0D0*k-1.0D0)*(4.0D0*k-3.0D0)/zp2
    cf=cf+cr
  END DO
  cr=1.0D0/(pi*z*z)
  cg=cr
  DO  k=1,12
    cr=-.25D0*cr*(4.0D0*k+1.0D0)*(4.0D0*k-1.0D0)/zp2
    cg=cg+cr
  END DO
  c=.5D0+(cf*CDSIN(zp)-cg*CDCOS(zp))/(pi*z)
END IF
30   zf=c
zd=CDCOS(0.5*pi*z*z)
RETURN
END SUBROUTINE cfc

SUBROUTINE cfs(z,zf,zd)

!     =========================================================
!     Purpose: Compute complex Fresnel Integral S(z) and S'(z)
!     Input :  z  --- Argument of S(z)
!     Output:  ZF --- S(z)
!     ZD --- S'(z)
!     =========================================================

COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: zf
COMPLEX, INTENT(OUT)                     :: zd
IMPLICIT DOUBLE PRECISION (e,p,w)
IMPLICIT COMPLEX *16 (c,s,z)

wb0=0.0
eps=1.0D-14
pi=3.141592653589793D0
w0=CDABS(z)
zp=0.5D0*pi*z*z
zp2=zp*zp
z0=(0.0D0,0.0D0)
IF (z == z0) THEN
  s=z0
ELSE IF (w0 <= 2.5) THEN
  s=z*zp/3.0D0
  cr=s
  igoon=1
  DO k=1,80
    cr=-.5D0*cr*(4.0D0*k-1.0D0)/k/(2.0D0*k+1.0D0) /(4.0D0*k+3.0D0)*zp2
    s=s+cr
    wb=CDABS(s)
    IF (DABS(wb-wb0) < eps.AND.k > 10) igoon=1
    IF (igoon == 1) THEN
      wb0=wb
    ELSE
      EXIT
    END IF
  END DO
ELSE IF (w0 > 2.5.AND.w0 < 4.5) THEN
  m=85
  s=z0
  cf1=z0
  cf0=(1.0D-100,0.0D0)
  DO  k=m,0,-1
    cf=(2.0D0*k+3.0D0)*cf0/zp-cf1
    IF (k /= INT(k/2)*2) s=s+cf
    cf1=cf0
    cf0=cf
  END DO
  s=CDSQRT(2.0D0/(pi*zp))*CDSIN(zp)/cf*s
ELSE
  cr=(1.0D0,0.0D0)
  cf=(1.0D0,0.0D0)
  DO  k=1,20
    cr=-.25D0*cr*(4.0D0*k-1.0D0)*(4.0D0*k-3.0D0)/zp2
    cf=cf+cr
  END DO
  cr=1.0D0/(pi*z*z)
  cg=cr
  DO  k=1,12
    cr=-.25D0*cr*(4.0D0*k+1.0D0)*(4.0D0*k-1.0D0)/zp2
    cg=cg+cr
  END DO
  s=.5D0-(cf*CDCOS(zp)+cg*CDSIN(zp))/(pi*z)
END IF
30   zf=s
zd=CDSIN(0.5*pi*z*z)
RETURN
END SUBROUTINE cfs


*
*
*     ------------------------------------------------------------------
*	L U L U
*     ------------------------------------------------------------------
*
      SUBROUTINE LULU(A,L,U,NDIM)
C
C LU DECOMPOSITION OF MATRIX A
C
C     A = L * U
C
C WHERE L IS A LOWER TRIANGULAR MATRIX WITH A
C UNIT DIAGONAL AND U IS AN UPPER DIAGONAL
C
C L AND U ARE STORED AS ONE DIMENSIONAL ARRAYS
C
C   L(I,J) = L(I*(I-1)/2 + J ) ( I .GE. J )
C
C   U(I,J) = U(J*(J-1)/2 + I ) ( J .GE. I )
C
C THIS ADRESSING SCHEMES SUPPORTS VECTORIZATION OVER COLUMNS
C FOR L AND  OVER ROWS FOR U .
C
C
C NO PIVOTING IS DONE HERE , SO THE SCHEME GOES :
C
C     LOOP OVER R=1, NDIM
C        LOOP OVER J = R, NDIM
C          U(R,J) = A(R,J) - SUM(K=1,R-1) L(R,K) * U(K,J)
C        END OF LOOP OVER J
C
C        LOOP OVER I = R+1, NDIM
C          L(I,R) = (A(I,R) - SUM(K=1,R-1)L(I,K) * U(K,R) ) /U(R,R)
C        END OF LOOP OVER I
C     END OF LOOP OVER R
C
C JEPPE OLSEN , OCTOBER 1988
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NDIM,NDIM)
      DOUBLE PRECISION  L(*),U(*)
      REAL * 8  INPROD
      INTEGER R
C
C
      DO 1000 R = 1, NDIM
C
        DO 100 J = R, NDIM
         U(J*(J-1)/2 + R ) = A(R,J) -
     &   INPROD(L(R*(R-1)/2+1),U(J*(J-1)/2+1),R-1)
  100   CONTINUE
C
        XFACI = 1.0D0/ U(R*(R+1)/2)
        L(R*(R+1)/2 ) = 1.0D0
        DO 200 I = R+1, NDIM
          L(I*(I-1)/2 + R) = (A(I,R) -
     &   INPROD(L(I*(I-1)/2+1),U(R*(R-1)/2+1),R-1) ) * XFACI
  200  CONTINUE
C
 1000 CONTINUE
C
      NTEST = 0
      IF ( NTEST .NE. 0 ) THEN
         WRITE(6,*) ' L MATRIX '
         CALL PRSYM(L,NDIM)
         WRITE(6,*) ' U MATRIX ( TRANSPOSED ) '
         CALL PRSYM(U,NDIM)
      END IF
C
      RETURN
      END


program yeval

   use omp_lib

   implicit none

   integer(kind=8), parameter :: n = 2**16
   integer(kind=4) :: i, nthreads
   real(kind=8), dimension(n) :: y
   real(kind=8) :: dx, x

   ! Specify number of threads to use:
   !$ print *, "How many threads to use? "
   !$ read *, nthreads
   !$ call omp_set_num_threads(nthreads)
   !$ print "('Using OpenMP with ',i3,' threads')", nthreads

   dx = 1.d0 / (n+1.d0)

   !$omp parallel do private(x)
   do i=1, n
      x = i * dx
      y(i) = exp(x) * cos(x) * sin(x) * sqrt(5.d0 * x + 6.d0)
   enddo
   !$omp end parallel do

   print *, "Filled vector y of length", n

end program yeval


module chem
	implicit none
	integer, parameter :: dp=kind(0.d0)
	real(dp) :: PI = 4*ATAN(1.d0)

	private
	public altitude, projection_onto_plane, normal_to_plane, discriminant, cross_product, distance, compute_length, &
	compute_angle, compute_dihedral, compute_improper

	contains
		function altitude(A, B, C)
			! computes altitude of triangle abc with respect to base bc
			real(dp), dimension(:), intent(in) :: A, B, C
			real(dp), dimension(3) :: altitude, v, M
			real(dp) :: ba, altitude_norm, bm

			ba = NORM2(B-A)
			v = C - B
			altitude_norm = NORM2(cross_product( (A-C), v))/NORM2(v)

			bm = SQRT( ba**2 - altitude_norm**2 )
			M = B + (bm/NORM2(v))*v

			altitude = A - M
		end function

		function projection_onto_plane(v, n)
			real(dp), dimension(:), intent(in) :: v, n
			real(dp), dimension(3) :: pvector
			real(dp) :: projection_onto_plane

			pvector = v - ( DOT_PRODUCT(v,n)/NORM2(n)**2 )*n
			projection_onto_plane = NORM2(pvector)**2
		end function

		function normal_to_plane(a, b, c)
			real(dp), dimension(:), intent(in) :: a, b, c
			real(dp), dimension(3) :: normal_to_plane, u, v

			u = a - b
			v = c - b

			normal_to_plane = cross_product(u,v)
			normal_to_plane = normal_to_plane/NORM2(normal_to_plane)

		end function

		function discriminant(a, b, c, d)
			real(dp) :: a, b, c, d
			real(dp) :: discriminant

			discriminant = 18*a*b*c*d - 4*(b**3)*d + (b**2)*(c**2) - 4*a*(c**3) - 27*(a**2)*(d**2)
		end function

		function cross_product(u, v)
			real(dp), dimension(3) :: u, v, cross_product

			cross_product(1) = u(2)*v(3) - u(3)*v(2)
			cross_product(2) = -u(1)*v(3) + u(3)*v(1)
			cross_product(3) = u(1)*v(2) - u(2)*v(1)

		end function

		function distance(b, c)
			real(dp) :: distance
			real(dp), dimension(3), intent(in) :: b, c
			integer :: i

			distance = 0
			do i=1,3
				distance = distance + (c(i)-b(i))**2
			enddo
			!distance = sqrt(distance)
		end function

		function compute_length(u, v)
			real(dp), dimension(:) :: u, v
			real(dp) :: compute_length

			compute_length = NORM2( v - u )
		end function

		function compute_angle(u, v, w)
			real(dp), dimension(:) :: u, v, w
			real(dp) :: compute_angle

			compute_angle = ACOS( DOT_PRODUCT((u - v), (w - v))/(NORM2(u-v)*NORM2(w-v)) )

		end function

		function compute_dihedral(u, v, w, x)
			real(dp), dimension(:) :: u, v, w, x
			real(dp), dimension(3) :: n1, n2, m
			real(dp) :: compute_dihedral, s, t

			n1 = cross_product( (u-v), (w-v) )
			n1 = n1/NORM2(n1)
			n2 = cross_product( (v-w), (x-w) )
			n2 = n2/NORM2(n2)

			m = (w-v)/NORM2(w-v)
			m = cross_product(n1,m)

			s = DOT_PRODUCT(n1,n2)
			t = DOT_PRODUCT(m,n2)

			compute_dihedral = -ATAN2(t,s)

		end function

		function compute_improper(u,v,w,x)
			real(dp), dimension(:) :: u, v, w, x
			real(dp), dimension(3) :: n1, n2, m
			real(dp) :: compute_improper, s, t

			n1 = cross_product( (v-u), (w-u) )
			n1 = n1/NORM2(n1)

			n2 = cross_product( (w-v), (x-v) )
			n2 = n2/NORM2(n2)

			compute_improper = ACOS( DOT_PRODUCT(n1,n2) )
		end function

end module chem


FUNCTION radext(idoy,bmalat)
!
IMPLICIT NONE
!
INCLUDE 'p1const.inc'
INCLUDE 'p1unconv.inc'
INCLUDE 'p1solar.inc'
!
! PARAMETER definitions
!
REAL,PARAMETER :: gsc = 0.08202
!
! Function arguments
!
REAL :: bmalat
INTEGER :: idoy
REAL :: radext
!
! Local variables
!
REAL :: dec,dr,ra1,ra2,rdec,rlat,ws
REAL :: declination,hourangle
!
!     + + + purpose + + +
!     this subroutine estimates the incoming extraterrestial radiation
!     for a given location (mj/m^2/day)

!     + + + key words + + +
!     radiation, solar, extraterrestrial

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy     - julian day of year, 1-366
!     bmalat   - latitude of the site, degrees

!     + + + common block + + +

!     + + + local variables + + +

!     + + + local definitions + + +
!     dec    - declination of the earth with respect to the sun (degrees)
!     dr     - direct radiation variation with distance from sun of earth orbit
!     ra1, ra2 - intermediate calculations
!     rlat   - latitude (radians)
!     rdec   - declination (radians)
!     ws     - sunset hour angle (radians)

!     + + + parameters + + +

!     gsc - solar_constant in mj/m^2-min (0.08202 mj/m^2-min = 1367 w/m^2)

!     + + + data initialization + + +

!     + + + function declarations + + +

!     + + + end specifications + + +

!     convert to radians for trig functions
rlat = bmalat*degtorad
dec = declination(idoy)
rdec = dec*degtorad

!     compute factor for variable distance from sun along orbital path
dr = 1 + 0.033*cos(2*pi*idoy/365)

ws = hourangle(bmalat,dec,beamrise)*degtorad
ra1 = ((24.0*60.0)/pi)*gsc*dr
ra2 = (ws*sin(rlat)*sin(rdec)) + (cos(rlat)*cos(rdec)*sin(ws))
radext = ra1*ra2
!
END FUNCTION radext

Project Documents/Source Code Original/Radext.f90


module m_parameters
  !! Module contains user defined parameters for consistent use
use variableKind
implicit none
real(r64), parameter :: inf = huge(0.d0)
real(r64),parameter :: NaN = transfer((/ Z'00000000', Z'7FF80000' /),1.0_r64)
real(r64),parameter :: pi = dacos(-1.d0)
end module


           program demo_conjg
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
           complex :: z = (2.0, 3.0)
           complex(kind=real64) :: dz = (&
           &  1.2345678901234567_real64, &
           & -1.2345678901234567_real64)
               z= conjg(z)
               print *, z
               dz = conjg(dz)
               print *, dz
           end program demo_conjg


integer n
write "Give fibonacci n = "
read n
write "The fibonacci of ",n
write " is ",fibonacci(n)
end

integer function fibonacci(integer number)
    if(number .eq. 0) fibonacci = 0
    if(number .eq. 1) fibonacci = 1
    fibonacci = fibonacci(number - 1) + fibonacci(number-2)
end


! Copyright 2015-2016 Andrew Dawson, Peter Dueben
!
! 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 lorenz63
! A Lorenz '63 model capable of using reduced floating-point precision.
!

    USE rp_emulator
    USE cliargs_mod, ONLY : cliargs

    IMPLICIT NONE

    ! Time-stepping parameters.
    REAL(KIND=RPE_REAL_KIND) :: t
    REAL(KIND=RPE_REAL_KIND) :: time_start = 0
    REAL(KIND=RPE_REAL_KIND) :: time_stop = 5
    REAL(KIND=RPE_REAL_KIND) :: dt = 0.01

    ! Lorenz 63 system parameters.
    TYPE(rpe_var) :: sigma
    TYPE(rpe_var) :: rho
    TYPE(rpe_var) :: beta

    ! Array to store the 3d coordinate of the current system state.
    TYPE(rpe_var), DIMENSION(3) :: x

    ! Runge-Kutta parameters.
    TYPE(rpe_var), DIMENSION(3) :: k1, k2, k3, k4
    TYPE(rpe_var), DIMENSION(3) :: x2, x3, x4, xd

    ! Handle command line arguments.
    CALL cliargs (RPE_ACTIVE, RPE_DEFAULT_SBITS, RPE_IEEE_HALF)

    ! Set the model parameters.
    sigma = 10
    rho = 28
    beta = 8.0_RPE_REAL_KIND / 3.0_RPE_REAL_KIND

    ! Set the initial state.
    t = time_start
    x = (/ 1.508870_RPE_REAL_KIND, -1.531271_RPE_REAL_KIND, 25.46091_RPE_REAL_KIND /)

    ! Loop over time evaluating the model state (x).
    WRITE (*, '(F19.15, "    ", F19.15, "    ", F19.15)') x%val
    DO WHILE (t <= time_stop)
        k1 = f(x, sigma, rho, beta)
        x2 = x + rpe_literal(0.5) * dt * k1
        k2 = f(x2, sigma, rho, beta)
        x3 = x + rpe_literal(0.5) * dt * k2
        k3 = f(x3, sigma, rho, beta)
        x4 = x + dt * k3
        k4 = f(x4, sigma, rho, beta)
        x = x + dt * (k1 + 2 * (k2 + k3) + k4) / rpe_literal(6.)
        t = t + dt
        WRITE (*, '(F19.15, "    ", F19.15, "    ", F19.15)') x%val
    END DO

CONTAINS

    FUNCTION f (x, sigma, rho, beta)
    ! Update the Runge-Kutta parameters.
    !
        IMPLICIT NONE
        TYPE(rpe_var), DIMENSION(3), INTENT(IN) :: x
        TYPE(rpe_var),               INTENT(IN) :: sigma
        TYPE(rpe_var),               INTENT(IN) :: rho
        TYPE(rpe_var),               INTENT(IN) :: beta
        TYPE(rpe_var), DIMENSION(3) :: f
        f(1) = sigma * (x(2) - x(1))
        f(2) = x(1) * (rho - x(3)) - x(2)
        f(3) = x(1) * x(2) - beta * x(3)
    END FUNCTION f

END PROGRAM


module integration

! This module contains the routines for the time integration and the computation
! of numerical fluxes (Rusanov or HLL in this example).

  use pde
  use global_module

  implicit none

  real(kind=8), dimension(Neq,Nx,Ny) :: U_new ! Working variable

  contains

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

  subroutine forward_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_N, F_S, F_W, F_E, Src
    real(kind=8) :: y_j, y_jmhalf, y_jphalf

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator - INTERNAL CELLS only
    do j = 3, Ny-2
      do i = 3, Nx-2

        ! call compute_fluxes_Rusanov(U, i, j, F_N, F_S, F_W, F_E)
        call compute_fluxes_HLL(U, i, j, F_N, F_S, F_W, F_E)

        ! Symmetry BC
        if (j.eq.3) then
          call compute_flux_y_SYM(U(:,i,j), F_S)
        end if

        ! Compute geometrical source term (basically, the pressure)
        call compute_source_term(U,i,j, Src)

        y_j      = y_min + dy/2.0d0 + (real(j)-3.0d0)*dy
        y_jmhalf = y_j - dy/2.0d0
        y_jphalf = y_j + dy/2.0d0

        U_new(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/(dy*y_j)*(F_N*y_jphalf - F_S*y_jmhalf) + dt*Src

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U_new(eqID,i,j))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            stop
          end if
        end do

      end do
    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,3:Nx-2,3:Ny-2) = U_new(:,3:Nx-2,3:Ny-2)

  end subroutine

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

  subroutine compute_fluxes_HLL(U, i, j, F_N, F_S, F_W, F_E)

    ! Computes HLL numerical fluxes for the cell (i,j)

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
    real(kind=8), dimension(Neq),       intent(out) :: F_N, F_S, F_W, F_E
    integer, intent(in) :: i, j

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R

    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_min, ws_max ! wave speeds

    ! ------ North interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i,j-1), U(:,i,j), U(:,i,j+1), U(:,i,j+2), U_L, U_R)

    call compute_flux_ws_y(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_y(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_N = F_L
    else if (ws_max .lt. 0.0) then
      F_N = F_R
    else
      F_N = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! ------ South interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i,j-2), U(:,i,j-1), U(:,i,j), U(:,i,j+1), U_L, U_R)

    call compute_flux_ws_y(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_y(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_S = F_L
    else if (ws_max .lt. 0.0) then
      F_S = F_R
    else
      F_S = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)
    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! ------ East interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i-1,j), U(:,i,j), U(:,i+1,j), U(:,i+2,j), U_L, U_R)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_E = F_L
    else if (ws_max .lt. 0.0) then
      F_E = F_R
    else
      F_E = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)
    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! ------ West interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i-2,j), U(:,i-1,j), U(:,i,j), U(:,i+1,j), U_L, U_R)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_W = F_L
    else if (ws_max .lt. 0.0) then
      F_W = F_R
    else
      F_W = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)
    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

  end subroutine

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

  subroutine compute_fluxes_Rusanov(U, i, j, F_N, F_S, F_W, F_E)

    ! Computes Rusanov numerical fluxes for the cell (i,j)

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
    real(kind=8), dimension(Neq),       intent(out) :: F_N, F_S, F_W, F_E
    integer, intent(in) :: i, j

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R

    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_max ! wave speeds

    ! ------ North interface
    U_L = U(:,i,j)
    U_R = U(:,i,j+1)

    call compute_flux_ws_y(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_y(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_N = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ------ South interface
    U_L = U(:,i,j-1)
    U_R = U(:,i,j)

    call compute_flux_ws_y(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_y(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_S = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ------ East interface
    U_L = U(:,i,j)
    U_R = U(:,i+1,j)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_E = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ------ West interface
    U_L = U(:,i-1,j)
    U_R = U(:,i,j)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_W = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

  end subroutine

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

  subroutine reconstruct_sol_interface(U_m2, U_m1, U_p1, U_p2, U_L, U_R)

  ! Takes the four points around an interface (minus_1, minus_2, plus_1, plus_2) and
  ! computes the left and right states using first order or MUSCL TVD-limited reconstruction

    real(kind=8), dimension(Neq), intent(in)  :: U_m2, U_m1, U_p1, U_p2
    real(kind=8), dimension(Neq), intent(out) :: U_L, U_R

    ! Working variables
    integer      :: eID              ! equation ID
    real(kind=8) :: theta_L, theta_R ! ratio of consecutive gradients
    real(kind=8), dimension(Neq) :: P_m2, P_m1, P_p1, P_p2, P_L, P_R ! primitive variables

    if (bool_MUSCL .EQV. .FALSE.) then
    ! ***** First order solution *****

      U_L = U_m1
      U_R = U_p1

    else
      ! ***** Second order solution *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)

      do eID = 1, Neq ! Loop on the quantities

        ! Compute ratio of consecutive gradients
        theta_L = (P_p1(eID) - P_m1(eID))/(P_m1(eID) - P_m2(eID) + 1.0d-15) ! Add a small tolerance
        theta_R = (P_p2(eID) - P_p1(eID))/(P_p1(eID) - P_m1(eID) + 1.0d-15) ! Add a small tolerance

        ! Limited linear reconstruction
        P_L(eID) = P_m1(eID) + phi_limiter(theta_L)*(P_m1(eID) - P_m2(eID))/2.0
        P_R(eID) = P_p1(eID) - phi_limiter(1.0d0/(theta_R+1.0d-15))*(P_p2(eID) - P_p1(eID))/2.0

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    end if

  end subroutine

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

  real(kind=8) function phi_limiter(theta)

    real(kind=8), intent(in) :: theta ! ratio of consecutive gradients

    phi_limiter = (theta*theta + theta)/(theta*theta + 1.0) ! van Albada symmetric limiter
    ! phi_limiter = (theta + abs(theta))/(1.0 + abs(theta)) ! van Leer limiter

  end function

end module


Module m_refsor
Integer, Parameter :: kdp = selected_real_kind(15)
public :: refsor
private :: kdp
private :: R_refsor, I_refsor, D_refsor
private :: R_inssor, I_inssor, D_inssor
private :: R_subsor, I_subsor, D_subsor
interface refsor
  module procedure d_refsor, r_refsor, i_refsor
end interface refsor
contains

Subroutine D_refsor (XDONT)
!  Sorts XDONT into ascending order - Quicksort
! __________________________________________________________
!  Quicksort chooses a "pivot" in the set, and explores the
!  array from both ends, looking for a value > pivot with the
!  increasing index, for a value <= pivot with the decreasing
!  index, and swapping them when it has found one of each.
!  The array is then subdivided in 2 ([3]) subsets:
!  { values <= pivot} {pivot} {values > pivot}
!  One then call recursively the program to sort each subset.
!  When the size of the subarray is small enough, one uses an
!  insertion sort that is faster for very small sets.
!  Michel Olagnon - Apr. 2000
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
!
!
      Call D_subsor (XDONT, 1, Size (XDONT))
      Call D_inssor (XDONT)
      Return
End Subroutine D_refsor
Recursive Subroutine D_subsor (XDONT, IDEB1, IFIN1)
!  Sorts XDONT from IDEB1 to IFIN1
! __________________________________________________________
      Real(kind=kdp), dimension (:), Intent (InOut) :: XDONT
      Integer, Intent (In) :: IDEB1, IFIN1
! __________________________________________________________
      Integer, Parameter :: NINS = 16 ! Max for insertion sort
      Integer :: ICRS, IDEB, IDCR, IFIN, IMIL
      Real(kind=kdp) :: XPIV, XWRK
!
      IDEB = IDEB1
      IFIN = IFIN1
!
!  If we don't have enough values to make it worth while, we leave
!  them unsorted, and the final insertion sort will take care of them
!
      If ((IFIN - IDEB) > NINS) Then
         IMIL = (IDEB+IFIN) / 2
!
!  One chooses a pivot, median of 1st, last, and middle values
!
         If (XDONT(IMIL) < XDONT(IDEB)) Then
            XWRK = XDONT (IDEB)
            XDONT (IDEB) = XDONT (IMIL)
            XDONT (IMIL) = XWRK
         End If
         If (XDONT(IMIL) > XDONT(IFIN)) Then
            XWRK = XDONT (IFIN)
            XDONT (IFIN) = XDONT (IMIL)
            XDONT (IMIL) = XWRK
            If (XDONT(IMIL) < XDONT(IDEB)) Then
               XWRK = XDONT (IDEB)
               XDONT (IDEB) = XDONT (IMIL)
               XDONT (IMIL) = XWRK
            End If
         End If
         XPIV = XDONT (IMIL)
!
!  One exchanges values to put those > pivot in the end and
!  those <= pivot at the beginning
!
         ICRS = IDEB
         IDCR = IFIN
         ECH2: Do
            Do
               ICRS = ICRS + 1
               If (ICRS >= IDCR) Then
!
!  the first  >  pivot is IDCR
!  the last   <= pivot is ICRS-1
!  Note: If one arrives here on the first iteration, then
!        the pivot is the maximum of the set, the last value is equal
!        to it, and one can reduce by one the size of the set to process,
!        as if XDONT (IFIN) > XPIV
!
                  Exit ECH2
!
               End If
               If (XDONT(ICRS) > XPIV) Exit
            End Do
            Do
               If (XDONT(IDCR) <= XPIV) Exit
               IDCR = IDCR - 1
               If (ICRS >= IDCR) Then
!
!  The last value < pivot is always ICRS-1
!
                  Exit ECH2
               End If
            End Do
!
            XWRK = XDONT (IDCR)
            XDONT (IDCR) = XDONT (ICRS)
            XDONT (ICRS) = XWRK
         End Do ECH2
!
!  One now sorts each of the two sub-intervals
!
         Call D_subsor (XDONT, IDEB1, ICRS-1)
         Call D_subsor (XDONT, IDCR, IFIN1)
      End If
      Return
   End Subroutine D_subsor
   Subroutine D_inssor (XDONT)
!  Sorts XDONT into increasing order (Insertion sort)
! __________________________________________________________
      Real(kind=kdp), dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
      Integer :: ICRS, IDCR
      Real(kind=kdp) :: XWRK
!
      Do ICRS = 2, Size (XDONT)
         XWRK = XDONT (ICRS)
         If (XWRK >= XDONT(ICRS-1)) Cycle
         XDONT (ICRS) = XDONT (ICRS-1)
         Do IDCR = ICRS - 2, 1, - 1
            If (XWRK >= XDONT(IDCR)) Exit
            XDONT (IDCR+1) = XDONT (IDCR)
         End Do
         XDONT (IDCR+1) = XWRK
      End Do
!
      Return
!
End Subroutine D_inssor
!
Subroutine R_refsor (XDONT)
!  Sorts XDONT into ascending order - Quicksort
! __________________________________________________________
!  Quicksort chooses a "pivot" in the set, and explores the
!  array from both ends, looking for a value > pivot with the
!  increasing index, for a value <= pivot with the decreasing
!  index, and swapping them when it has found one of each.
!  The array is then subdivided in 2 ([3]) subsets:
!  { values <= pivot} {pivot} {values > pivot}
!  One then call recursively the program to sort each subset.
!  When the size of the subarray is small enough, one uses an
!  insertion sort that is faster for very small sets.
!  Michel Olagnon - Apr. 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
!
!
      Call R_subsor (XDONT, 1, Size (XDONT))
      Call R_inssor (XDONT)
      Return
End Subroutine R_refsor
Recursive Subroutine R_subsor (XDONT, IDEB1, IFIN1)
!  Sorts XDONT from IDEB1 to IFIN1
! __________________________________________________________
      Real, dimension (:), Intent (InOut) :: XDONT
      Integer, Intent (In) :: IDEB1, IFIN1
! __________________________________________________________
      Integer, Parameter :: NINS = 16 ! Max for insertion sort
      Integer :: ICRS, IDEB, IDCR, IFIN, IMIL
      Real :: XPIV, XWRK
!
      IDEB = IDEB1
      IFIN = IFIN1
!
!  If we don't have enough values to make it worth while, we leave
!  them unsorted, and the final insertion sort will take care of them
!
      If ((IFIN - IDEB) > NINS) Then
         IMIL = (IDEB+IFIN) / 2
!
!  One chooses a pivot, median of 1st, last, and middle values
!
         If (XDONT(IMIL) < XDONT(IDEB)) Then
            XWRK = XDONT (IDEB)
            XDONT (IDEB) = XDONT (IMIL)
            XDONT (IMIL) = XWRK
         End If
         If (XDONT(IMIL) > XDONT(IFIN)) Then
            XWRK = XDONT (IFIN)
            XDONT (IFIN) = XDONT (IMIL)
            XDONT (IMIL) = XWRK
            If (XDONT(IMIL) < XDONT(IDEB)) Then
               XWRK = XDONT (IDEB)
               XDONT (IDEB) = XDONT (IMIL)
               XDONT (IMIL) = XWRK
            End If
         End If
         XPIV = XDONT (IMIL)
!
!  One exchanges values to put those > pivot in the end and
!  those <= pivot at the beginning
!
         ICRS = IDEB
         IDCR = IFIN
         ECH2: Do
            Do
               ICRS = ICRS + 1
               If (ICRS >= IDCR) Then
!
!  the first  >  pivot is IDCR
!  the last   <= pivot is ICRS-1
!  Note: If one arrives here on the first iteration, then
!        the pivot is the maximum of the set, the last value is equal
!        to it, and one can reduce by one the size of the set to process,
!        as if XDONT (IFIN) > XPIV
!
                  Exit ECH2
!
               End If
               If (XDONT(ICRS) > XPIV) Exit
            End Do
            Do
               If (XDONT(IDCR) <= XPIV) Exit
               IDCR = IDCR - 1
               If (ICRS >= IDCR) Then
!
!  The last value < pivot is always ICRS-1
!
                  Exit ECH2
               End If
            End Do
!
            XWRK = XDONT (IDCR)
            XDONT (IDCR) = XDONT (ICRS)
            XDONT (ICRS) = XWRK
         End Do ECH2
!
!  One now sorts each of the two sub-intervals
!
         Call R_subsor (XDONT, IDEB1, ICRS-1)
         Call R_subsor (XDONT, IDCR, IFIN1)
      End If
      Return
   End Subroutine R_subsor
   Subroutine R_inssor (XDONT)
!  Sorts XDONT into increasing order (Insertion sort)
! __________________________________________________________
      Real, dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
      Integer :: ICRS, IDCR
      Real :: XWRK
!
      Do ICRS = 2, Size (XDONT)
         XWRK = XDONT (ICRS)
         If (XWRK >= XDONT(ICRS-1)) Cycle
         XDONT (ICRS) = XDONT (ICRS-1)
         Do IDCR = ICRS - 2, 1, - 1
            If (XWRK >= XDONT(IDCR)) Exit
            XDONT (IDCR+1) = XDONT (IDCR)
         End Do
         XDONT (IDCR+1) = XWRK
      End Do
!
      Return
!
End Subroutine R_inssor
!
Subroutine I_refsor (XDONT)
!  Sorts XDONT into ascending order - Quicksort
! __________________________________________________________
!  Quicksort chooses a "pivot" in the set, and explores the
!  array from both ends, looking for a value > pivot with the
!  increasing index, for a value <= pivot with the decreasing
!  index, and swapping them when it has found one of each.
!  The array is then subdivided in 2 ([3]) subsets:
!  { values <= pivot} {pivot} {values > pivot}
!  One then call recursively the program to sort each subset.
!  When the size of the subarray is small enough, one uses an
!  insertion sort that is faster for very small sets.
!  Michel Olagnon - Apr. 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (InOut)  :: XDONT
! __________________________________________________________
!
!
      Call I_subsor (XDONT, 1, Size (XDONT))
      Call I_inssor (XDONT)
      Return
End Subroutine I_refsor
Recursive Subroutine I_subsor (XDONT, IDEB1, IFIN1)
!  Sorts XDONT from IDEB1 to IFIN1
! __________________________________________________________
      Integer, dimension (:), Intent (InOut) :: XDONT
      Integer, Intent (In) :: IDEB1, IFIN1
! __________________________________________________________
      Integer, Parameter :: NINS = 16 ! Max for insertion sort
      Integer :: ICRS, IDEB, IDCR, IFIN, IMIL
      Integer :: XPIV, XWRK
!
      IDEB = IDEB1
      IFIN = IFIN1
!
!  If we don't have enough values to make it worth while, we leave
!  them unsorted, and the final insertion sort will take care of them
!
      If ((IFIN - IDEB) > NINS) Then
         IMIL = (IDEB+IFIN) / 2
!
!  One chooses a pivot, median of 1st, last, and middle values
!
         If (XDONT(IMIL) < XDONT(IDEB)) Then
            XWRK = XDONT (IDEB)
            XDONT (IDEB) = XDONT (IMIL)
            XDONT (IMIL) = XWRK
         End If
         If (XDONT(IMIL) > XDONT(IFIN)) Then
            XWRK = XDONT (IFIN)
            XDONT (IFIN) = XDONT (IMIL)
            XDONT (IMIL) = XWRK
            If (XDONT(IMIL) < XDONT(IDEB)) Then
               XWRK = XDONT (IDEB)
               XDONT (IDEB) = XDONT (IMIL)
               XDONT (IMIL) = XWRK
            End If
         End If
         XPIV = XDONT (IMIL)
!
!  One exchanges values to put those > pivot in the end and
!  those <= pivot at the beginning
!
         ICRS = IDEB
         IDCR = IFIN
         ECH2: Do
            Do
               ICRS = ICRS + 1
               If (ICRS >= IDCR) Then
!
!  the first  >  pivot is IDCR
!  the last   <= pivot is ICRS-1
!  Note: If one arrives here on the first iteration, then
!        the pivot is the maximum of the set, the last value is equal
!        to it, and one can reduce by one the size of the set to process,
!        as if XDONT (IFIN) > XPIV
!
                  Exit ECH2
!
               End If
               If (XDONT(ICRS) > XPIV) Exit
            End Do
            Do
               If (XDONT(IDCR) <= XPIV) Exit
               IDCR = IDCR - 1
               If (ICRS >= IDCR) Then
!
!  The last value < pivot is always ICRS-1
!
                  Exit ECH2
               End If
            End Do
!
            XWRK = XDONT (IDCR)
            XDONT (IDCR) = XDONT (ICRS)
            XDONT (ICRS) = XWRK
         End Do ECH2
!
!  One now sorts each of the two sub-intervals
!
         Call I_subsor (XDONT, IDEB1, ICRS-1)
         Call I_subsor (XDONT, IDCR, IFIN1)
      End If
      Return
   End Subroutine I_subsor
   Subroutine I_inssor (XDONT)
!  Sorts XDONT into increasing order (Insertion sort)
! __________________________________________________________
      Integer, dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
      Integer :: ICRS, IDCR
      Integer :: XWRK
!
      Do ICRS = 2, Size (XDONT)
         XWRK = XDONT (ICRS)
         If (XWRK >= XDONT(ICRS-1)) Cycle
         XDONT (ICRS) = XDONT (ICRS-1)
         Do IDCR = ICRS - 2, 1, - 1
            If (XWRK >= XDONT(IDCR)) Exit
            XDONT (IDCR+1) = XDONT (IDCR)
         End Do
         XDONT (IDCR+1) = XWRK
      End Do
!
      Return
!
End Subroutine I_inssor
!
end module m_refsor


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!================================================================================================
! Functions to generate noise.
!
! Vitaliy Ogarko, UWA, CET, Australia, 2015-2016.
!================================================================================================
module noise

  use global_typedefs

  implicit none

  private

  public :: init_random_seed
  public :: generate_Gaussian_noise
  public :: generate_uniform_noise

contains

!==================================================================================
! Initializes a random seed from the system clock at every run (fortran 95 code).
! http://stackoverflow.com/questions/18754438/generating-random-numbers-in-a-fortran-module
!==================================================================================
subroutine init_random_seed()
  integer :: i, n, clock
  integer, allocatable :: seed(:)

  call RANDOM_SEED(size = n)
  allocate(seed(n))

  call SYSTEM_CLOCK(COUNT=clock)

  seed = clock + 37 * (/ (i - 1, i = 1, n) /)
  call RANDOM_SEED(PUT = seed)

  deallocate(seed)

end subroutine init_random_seed

!============================================================================
! Generates Gaussian noise.
!============================================================================
function generate_Gaussian_noise(sigma, mu) result(noise)
  double precision, intent(in) :: sigma, mu

  double precision :: rand1, rand2
  double precision :: gaussian1, gaussian2
  double precision :: noise

  call random_number(rand1)
  call random_number(rand2)

  ! Uncorrelated Gaussian (normal) random numbers (by Box & Muller method).
  gaussian1 = sqrt(- 2.d0 * log(rand1)) * cos(2.d0 * PI * rand2)
  gaussian2 = sqrt(- 2.d0 * log(rand1)) * sin(2.d0 * PI * rand2)

  noise = gaussian1 * sigma + mu

end function generate_Gaussian_noise

!============================================================================
! Generates uniform noise.
!============================================================================
function generate_uniform_noise(scale) result(noise)
  double precision, intent(in) :: scale

  double precision :: rand
  double precision :: noise

  call random_number(rand)

  noise = (rand - 0.5d0) * scale

end function generate_uniform_noise

end module noise


PROGRAM shell_model
IMPLICIT NONE
  REAL,ALLOCATABLE,DIMENSION(:,:)::E
  INTEGER::i,j,N,l,k
  REAL::C,D
  C=0.05
  D=0.0225
!To input the value of Quantum Number N
  PRINT*,"Enter the value of N:"
  READ*,N
  ALLOCATE(E(0:N,0:N+1))
  DO i=0,N
    E(i,0)=i+1.5  !contains energy values of SHO
    j=1
    DO l=i,0,-2
      IF(l.NE.0) THEN
!For Energy level splitting with j=l+1/2 and j=l-1/2 respectively
        E(i,j)=(i+1.5)-(C*l)-(D*l*(l+1))
        j=j+1
        E(i,j)=(i+1.5)+(C*(l+1))-(D*l*(l+1))
        j=j+1
      END IF
      IF(l.EQ.0) THEN
!For no splitting in energy levels
        E(i,j)=i+1.5
      END IF
    END DO
    PRINT*,(E(i,j),j=0,i+1)
  END DO
  PRINT*,"HEY"

  OPEN(10,FILE="single_particle_Shell_model.dat")
  DO i=0,N
    DO j=1,i+1
      DO k=0,3
        WRITE(10,*) k,E(i,0)
      END DO
      DO k=4,7
        WRITE(10,*) k,E(i,j)
      END DO
      WRITE(10,*)
    END DO
  END DO
  CLOSE(10)
  PRINT*,"HEY"
END PROGRAM shell_model


C     LAST UPDATE 30/03/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FLORENTZ(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is Lorentzian. The amplitude. centre and width of the
C           Lorentzian are stored in consecutive locations of A:
C           A(1) = H,  A(2) = P,  A(3) = FWHM
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      DOUBLE PRECISION TINY
      PARAMETER(TINY=1.0D-10)
C
C Arguments:
C
      DOUBLE PRECISION A(10),DYDA(10)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      DOUBLE PRECISION  ARG,EX,FAC,W
C
C-----------------------------------------------------------------------
      IF(A(3).LT.TINY)A(3) = TINY
      W = A(3)/2.0D0
      ARG = (X-A(2))/W
      FAC = (1.0D0+ARG*ARG)
      Y = A(1)/FAC
      EX = 2.0D0*ARG*A(1)/(FAC*FAC)
      DYDA(1) = 1.0D0/FAC
      DYDA(2) = EX/W
      DYDA(3) = 2.0D0*ARG*EX/W
C
      RETURN
      END


      PROGRAM xbcucof
C     driver for routine bcucof
      INTEGER i,j
      REAL d1,d2,ee,x1x2
      REAL c(4,4),y(4),y1(4),y2(4)
      REAL y12(4),x1(4),x2(4)
      DATA x1/0.0,2.0,2.0,0.0/
      DATA x2/0.0,0.0,2.0,2.0/
      d1=x1(2)-x1(1)
      d2=x2(4)-x2(1)
      do 11 i=1,4
        x1x2=x1(i)*x2(i)
        ee=exp(-x1x2)
        y(i)=x1x2*ee
        y1(i)=x2(i)*(1.0-x1x2)*ee
        y2(i)=x1(i)*(1.0-x1x2)*ee
        y12(i)=(1.0-3.0*x1x2+x1x2**2)*ee
11    continue
      call bcucof(y,y1,y2,y12,d1,d2,c)
      write(*,*) 'Coefficients for bicubic interpolation'
      do 12 i=1,4
        write(*,'(1x,4e15.6)') (c(i,j),j=1,4)
12    continue
      END

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


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the main program supplied by the user.
! This version illustrates an eigenvalue problem, the Schroedinger
! Equation for a simple harmonic oscillator.
!----------------------------------------------------

!       ------------
program phaml_master
!       ------------

!----------------------------------------------------
! This is the main program.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Local variables:

integer :: nvert,num_eval,nproc
real(my_real) :: lambda0
type(phaml_solution_type) :: pde1
real(my_real) :: evals(3), mlsresid, alsresid, el2resid(3), errest, &
                 eval_errest(3)
integer :: aiter, anconv, anumop, anumopb, anumreo, ainfo

!----------------------------------------------------
! Begin executable code

nvert = 1000
lambda0 = -huge(0.0_my_real)
num_eval = 3
nproc=4
call phaml_create(pde1,nproc,eq_type=EIGENVALUE)
call phaml_solve_pde(pde1,                     &
                     max_vert=nvert,             &
                     sequential_vert=250,        &
                     num_eval=num_eval,          &
                     lambda0=lambda0,            &
                     print_error_when=FINAL,     &
                     print_error_who=MASTER,     &
                     print_errest_what=LINF_ERREST, &
                     mg_tol=MG_NO_TOL,           &
                     mg_cycles=10)
call phaml_query(pde1, &
                 eigenvalues=evals, &
                 eigenvalue_error_estimate=eval_errest, &
                 error_estimator=LOCAL_PROBLEM_H, &
                 max_linsys_resid=mlsresid, &
                 ave_linsys_resid=alsresid, &
                 eigen_l2_resid=el2resid, &
                 arpack_iter=aiter, &
                 arpack_nconv=anconv, &
                 arpack_numop=anumop, &
                 arpack_numopb=anumopb, &
                 arpack_numreo=anumreo, &
                 arpack_info=ainfo)
call phaml_query(pde1,linf_error_estimate=errest,eigen=2)
write(6,102) "eigenvalues ",evals
write(6,102) "error estimates ",eval_errest
write(6,101) "max linear system residual ",mlsresid
write(6,101) "ave linear system residual ",alsresid
write(6,102) "eigensystem residuals ",el2resid
write(6,103) "arpack iterations ",aiter
write(6,103) "arpack number converged ",anconv
write(6,103) "arpack number of OP*x ",anumop
write(6,103) "arpack number of B*x ",anumopb
write(6,103) "arpack number of reorthogonalizatons ",anumreo
write(6,103) "arpack error flag ",ainfo
write(6,101) "error estimate for evec 2 ",errest
101 format(A,SS,1P,E19.12E2)
102 format(A,SS,1P,3E19.12E2)
103 format(A,I11)
call phaml_destroy(pde1)

end program phaml_master


SUBROUTINE gser(gamser,a,x,gln)
INTEGER*4 ITMAX
REAL*8 a,gamser,gln,x,EPS
PARAMETER (ITMAX=100,EPS=3.d-7)
!CU    USES gammln
INTEGER*4 n
REAL*8 ap,del,sum,gammln
EXTERNAL gammln
gln=gammln(a)
if(x.le.0.)then
	if(x.lt.0.)pause 'x < 0 in gser'
	gamser=0.
	return
endif
ap=a
sum=1./a
del=sum
do n=1,ITMAX
	ap=ap+1.
	del=del*x/ap
	sum=sum+del
	if(abs(del).lt.abs(sum)*EPS)goto 1
end do
pause 'a too large, ITMAX too small in gser'
1     gamser=sum*exp(-x+a*log(x)-gln)
return
END


      SUBROUTINE INIFFT

C     Initialize FFTs

      include "atparam.h"

      COMMON /FFTCOM/ COEFFT(IX+15)

      CALL DZFFTM1DUI (IX,COEFFT)

      RETURN
      END

*********************************************************************

      SUBROUTINE GRIDX(VARM,VORG,KCOS)

C     From Fourier coefficients to grid-point data

      include "atparam.h"

      PARAMETER (IMAX=IX+2 )

      include "com_spectral.h"

      COMMON /FFTCOM/ COEFFT(IX+15)

      REAL VORG(IX,IL), VARM(MX2,IL)
      REAL FVAR(IMAX,IL)

C     Copy Fourier coefficients into working array

      MX3=MX2+1
      DO J=1,IL
        DO I=1,MX2
          FVAR(I,J)=VARM(I,J)
        ENDDO
        DO I=MX3,IMAX
          FVAR(I,J)=0.
        ENDDO
      ENDDO

C     Inverse FFT

      CALL ZDFFTM1DU (+1,IX,IL,FVAR,1,IMAX,COEFFT)

C     Copy output into grid-point field, scaling by cos(lat) if needed

      IF (KCOS.EQ.1) THEN

        DO J=1,IL
          DO I=1,IX
            VORG(I,J)=FVAR(I,J)
          ENDDO
        ENDDO

      ELSE

        DO J=1,IL
          DO I=1,IX
            VORG(I,J)=FVAR(I,J)*COSGR(J)
          ENDDO
        ENDDO

      ENDIF

      RETURN
      END

******************************************************************

      SUBROUTINE SPECX(VORG,VARM)

C     From grid-point data to Fourier coefficients

      include "atparam.h"

      PARAMETER (IMAX=IX+2 )

      COMMON /FFTCOM/ COEFFT(IX+15)

      REAL VORG(IX,IL), VARM(MX2,IL)
      REAL FVAR(IMAX,IL)

C     Copy grid-point data into working array

      IM1=IX+1
      DO J=1,IL
        DO I=1,IX
          FVAR(I,J)=VORG(I,J)
        ENDDO
        FVAR(IM1 ,J)=0.
        FVAR(IMAX,J)=0.
      ENDDO

C     Direct FFT

      CALL DZFFTM1DU (-1,IX,IL,FVAR,1,IMAX,COEFFT)

C     Copy output into spectral field, dividing by no. of long.

      SCALE=1./FLOAT(IX)

      DO J=1,IL
        DO M=1,MX2
          VARM(M,J)=FVAR(M,J)*SCALE
        ENDDO
      ENDDO

      RETURN
      END


module mBoard
    implicit none

    contains

    function createBoard(rows, cols)

        logical, dimension(:,:), allocatable :: createBoard
        integer, intent(in) :: rows, cols
        integer :: r,c

        allocate( createBoard(rows, cols) )

        do c = 1,cols
            do r = 1,rows
                createBoard(r,c) = (nint(rand(0)) .eq. 0)
            end do
        end do

    end function createBoard

    function stepBoard(board)
    ! stepBoard - Determines the next sequence in the board
    !
    ! Inputs:
    !   board - 2D array of logicals that represents the state of the game.

        logical, dimension(:,:), intent(inout), allocatable :: board
        logical, dimension(:,:), allocatable :: stepBoard
        integer :: i, j, livingNeighbors, x, y, rows, cols, a, b

        rows = ubound(board,1)
        cols = ubound(board,2)

        allocate(stepBoard(rows,cols))

        ! Iterate through board to determine next state
        do i=1,rows
            do j = 1,cols
                ! Determine how many neighbors a cell has
                livingNeighbors = 0

                do x = -1,1
                    do y = -1, 1
                        if ((x .eq. 0) .and. (y .eq. 0)) then
                            continue
                        else
                            ! mod can wrap around on the high side
                            ! need to figure out how to wrap around on the low side
                            if (i+x .eq. 0) then
                                a = rows
                            else
                                a = mod(i+x,rows)
                            end if

                            if (j+y .eq. 0) then
                                b = cols
                            else
                                b = mod(j+y,cols)
                            end if

                            if (board(a,b)) then
                                livingNeighbors = livingNeighbors + 1
                            end if
                            !if (board(mod(i+x, rows), mod(j+y, cols))) then
                            !    livingNeighbors = livingNeighbors + 1
                            !end if
                        end if
                    end do
                end do

                !write(*,*) livingNeighbors

                ! Determine which cells 'live' or 'die' based on the rules
                if (board(i,j) .and. livingNeighbors < 2) then
                    stepBoard(i,j) = .false.
                else if (board(i,j) .and. livingNeighbors < 4) then
                    stepBoard(i,j) = .true.
                else if (board(i,j)) then
                    stepBoard(i,j) = .false.
                else if ((.not. board(i,j)) .and. (livingNeighbors .eq. 3)) then
                    stepBoard(i,j) = .true.
                else
                    stepBoard(i,j) = .false.
                end if
            end do
        end do

        ! clean up input board before returning
        deallocate(board)

    end function stepBoard

    subroutine printBoard(board)
    ! printBoard - Clears terminal screen and then prints board
    !
    ! Inputs:
    !   board - 2D array of logicals that represents state of game.

        logical, dimension(:,:), intent(in) :: board
        integer :: i, j

        ! Clear Screen
        !call system('clear')
        write(*,"(A)") "==========================="

        ! Print Board
        do i = lbound(board,1), ubound(board,1)
            do j = lbound(board,2), ubound(board,2)
                if (board(i,j)) then
                    write(*,"(A)", advance="no") '*' ! Life Cell is *
                else
                    write(*,"(A)", advance="no") ' ' ! Dead cell is blank
                end if
            end do
            write(*,*) '' ! Line feed after current row
        end do

    end subroutine printBoard
end module

program life
!
! Purpose:
!   Implementation of Conway's Game of Life in Fortran 90.
!
! Record of revisions:
!   Date        Programer       Description of change
!   ====        =========       =====================
!   2019-11-27  cchillen        Original Code
use mBoard
use, intrinsic :: iso_c_binding, only: c_int

implicit none

integer :: rows, cols           ! Board size
integer :: i
logical, dimension (:, :), allocatable :: board ! Actual Board

! Basic Algorithm:
! 1. Prompt user to input board size
! 2. Initialize Board
! 3. Display Board
! 4. Step Board
! 5. Loop at step 3 or quit

! Functions: createBoard(), stepBoard(), printBoard()
rows = 45
cols = 80

board = createBoard(rows, cols)

!call printBoard(board)

do i = 1,1000
    call printBoard(board)

    board = stepBoard(board)

    call sleep(1)

end do

end program life


    Program zhpevd_example

!     ZHPEVD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: zhpevd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, ifail, info, j, k, ldz, liwork, lrwork, lwork, n
      Character (1) :: job, uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: rwork(:), w(:)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZHPEVD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      liwork = 5*n + 3
      lrwork = 2*n*n + 5*n + 1
      lwork = 2*n
      Allocate (ap(n*(n+1)/2), work(lwork), z(ldz,n), rwork(lrwork), w(n), &
        iwork(liwork))
      Read (nin, *) uplo

!     Read A from data file

      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

      Read (nin, *) job

!     Calculate all the eigenvalues and eigenvectors of A

      Call zhpevd(job, uplo, n, ap, w, z, ldz, work, lwork, rwork, lrwork, &
        iwork, liwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Do i = 1, n
          Write (nout, 100) i, w(i)
        End Do
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
        Do i = 1, n
          rwork(1:n) = abs(z(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(z(k,i))/abs(z(k,i))/dznrm2(n, z(1,i), 1)
          z(1:n, i) = z(1:n, i)*scal
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, I5, 5X, 2F8.4)
    End Program


*DECK CHFEV
      SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
C***BEGIN PROLOGUE  CHFEV
C***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an
C            array of points.  While designed for use by PCHFE, it may
C            be useful directly as an evaluator for a piecewise cubic
C            Hermite function in applications, such as graphing, where
C            the interval is known in advance.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      SINGLE PRECISION (CHFEV-S, DCHFEV-D)
C***KEYWORDS  CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION,
C             PCHIP
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          CHFEV:  Cubic Hermite Function EValuator
C
C     Evaluates the cubic polynomial determined by function values
C     F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points
C     XE(J), J=1(1)NE.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        INTEGER  NE, NEXT(2), IERR
C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE)
C
C        CALL  CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR)
C
C   Parameters:
C
C     X1,X2 -- (input) endpoints of interval of definition of cubic.
C           (Error return if  X1.EQ.X2 .)
C
C     F1,F2 -- (input) values of function at X1 and X2, respectively.
C
C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
C
C     NE -- (input) number of evaluation points.  (Error return if
C           NE.LT.1 .)
C
C     XE -- (input) real array of points at which the function is to be
C           evaluated.  If any of the XE are outside the interval
C           [X1,X2], a warning error is returned in NEXT.
C
C     FE -- (output) real array of values of the cubic function defined
C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
C
C     NEXT -- (output) integer array indicating number of extrapolation
C           points:
C            NEXT(1) = number of evaluation points to left of interval.
C            NEXT(2) = number of evaluation points to right of interval.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -1  if NE.LT.1 .
C              IERR = -2  if X1.EQ.X2 .
C                (The FE-array has not been changed in either case.)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811019  DATE WRITTEN
C   820803  Minor cosmetic changes for release 1.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890703  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  CHFEV
C  Programming notes:
C
C     To produce a double precision version, simply:
C        a. Change CHFEV to DCHFEV wherever it occurs,
C        b. Change the real declaration to double precision, and
C        c. Change the constant ZERO to double precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  NE, NEXT(2), IERR
      REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I
      REAL  C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
      SAVE ZERO
      DATA  ZERO /0./
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  CHFEV
      IF (NE .LT. 1)  GO TO 5001
      H = X2 - X1
      IF (H .EQ. ZERO)  GO TO 5002
C
C  INITIALIZE.
C
      IERR = 0
      NEXT(1) = 0
      NEXT(2) = 0
      XMI = MIN(ZERO, H)
      XMA = MAX(ZERO, H)
C
C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
C
      DELTA = (F2 - F1)/H
      DEL1 = (D1 - DELTA)/H
      DEL2 = (D2 - DELTA)/H
C                                           (DELTA IS NO LONGER NEEDED.)
      C2 = -(DEL1+DEL1 + DEL2)
      C3 = (DEL1 + DEL2)/H
C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
C
C  EVALUATION LOOP.
C
      DO 500  I = 1, NE
         X = XE(I) - X1
         FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
C          COUNT EXTRAPOLATION POINTS.
         IF ( X.LT.XMI )  NEXT(1) = NEXT(1) + 1
         IF ( X.GT.XMA )  NEXT(2) = NEXT(2) + 1
C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
  500 CONTINUE
C
C  NORMAL RETURN.
C
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     NE.LT.1 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'CHFEV',
     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     X1.EQ.X2 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR,
     +   1)
      RETURN
C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------
      END


      subroutine rotampspc(nyq,ampspc,freqhz,expon)
c
c  subroutine to differentiate or integrate an amplitude spectrum.
c
c  inputs:
c    nyq     - number of frequency points
c    ampspec - amplitude spectrum
c    freqhz  - frequencies in hertz
c    exp     - exponent to rotate spectrum
c              -2 integrate twice
c              -1 integrate once
c              +1 differentiate once
c              +2 differentiate twice
c
c
      dimension ampspc(1),freqhz(1)
      logical lzero
      parameter (pi=3.14159265,tpi=2.*pi)
      data lzero/.false./
c
      if (expon .eq. 0.) return
      nstart = 1
      if (freqhz(1).eq.0.) then
        nstart = 2
        lzero  = .true.
      end if
      do 100 ifrq = nstart,nyq
        factor = expon * log( tpi * freqhz(ifrq))
        ampspc(ifrq) =  factor + log(ampspc(ifrq))
        ampspc(ifrq) =  exp(ampspc(ifrq))
  100 continue
      if (.not.lzero) return
      if (expon.gt.0) ampspc(1) = ampspc(2)
      if (expon.lt.0) ampspc(1) = 0.
      return
      end

c $Id$


      SUBROUTINE polcof(xa,ya,n,cof)
      INTEGER n,NMAX
      REAL cof(n),xa(n),ya(n)
      PARAMETER (NMAX=15)
CU    USES polint
      INTEGER i,j,k
      REAL dy,xmin,x(NMAX),y(NMAX)
      do 11 j=1,n
        x(j)=xa(j)
        y(j)=ya(j)
11    continue
      do 14 j=1,n
        call polint(x,y,n+1-j,0.,cof(j),dy)
        xmin=1.e38
        k=0
        do 12 i=1,n+1-j
          if (abs(x(i)).lt.xmin)then
            xmin=abs(x(i))
            k=i
          endif
          if(x(i).ne.0.)y(i)=(y(i)-cof(j))/x(i)
12      continue
        do 13 i=k+1,n+1-j
          y(i-1)=y(i)
          x(i-1)=x(i)
13      continue
14    continue
      return
      END

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


      subroutine cylinder_setprob()
      implicit none

      double precision arc

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

      integer example
      common /example_comm/ example

      integer initchoice
      common /initchoice_comm/ initchoice

      integer refine_pattern
      common /refine_comm/ refine_pattern

      integer mapping
      common /mapping_comm/ mapping

      double precision r_cyl, h_cyl
      common /cylinder_comm/ r_cyl, h_cyl

      double precision r_latlong, phi0, phi1
      common /latlong_comm/ r_latlong, phi0, phi1

      integer exact_metric
      common /metric_comm/ exact_metric

      double precision xc0, yc0, r0
      common /cylinder_init_comm/ xc0, yc0, r0

      double precision revs_per_s, v_speed
      common /stream_comm/ revs_per_s, v_speed

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

c     !! These are written out in cylinder_user.cpp
      open(10,file='setprob.data')
      read(10,*) example
      read(10,*) initchoice
      read(10,*) refine_pattern
      read(10,*) r_cyl
      read(10,*) h_cyl
      read(10,*) xc0
      read(10,*) yc0
      read(10,*) r0
      read(10,*) revs_per_s
      read(10,*) v_speed
      read(10,*) exact_metric
      read(10,*) mapping
      close(10)

      r_latlong = sqrt((h_cyl/2)**2 + r_cyl**2)
      arc = asin(h_cyl/(2*r_latlong))
c     # Want phi = phi0 + (phi1-phi0)*y for y in [0,1]
c     # and phi in [-pi/2, pi/2]
      phi0 = -0.5*arc/(pi/2);
      phi1 = -phi0;

c      h_cyl = 2*pi*r_cyl

      end


submodule(euler_interface_m) euler_prob_0016_m
    implicit none

contains

    module character(len=20) function euler0016()
        write (euler0016, "(i20)") ans(1000)
    end function euler0016

    integer function ans(n)
        integer, intent(in) :: n
        integer, allocatable :: iarr(:)
        integer :: i, j, l

        l = floor(real(n)*log10(2.0) + 1.0)
        allocate (iarr(l))
        iarr = 0
        iarr(l) = 1

        do i = 1, n
            iarr = iarr*2

            do j = l, 2, -1
                iarr(j - 1) = iarr(j - 1) + iarr(j)/10
                iarr(j) = mod(iarr(j), 10)
            end do
        end do

        ans = sum(iarr, dim=1)
    end function ans

end submodule euler_prob_0016_m


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mncual : cualde test program                       cc
cc         evaluation of a closed planar spline curve                 cc
cc                    x = sx(u) , y = sy(u)                           cc
cc            through its polynomial representation                   cc
cc                    in each knot interval.                          cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real t(20),c(40),u(20),sp(40),d(12),cof(2,6)
      integer i,idim,ier,ii,ip,i1,i2,j,jj,jn,j1,j2,j3,j4,k,kk,k1,
     * l,l1,m,n,nc,nd,nk,nk1
      real ai,aj,arg,fac,per,pol,tt,uu
c  we have a planar curve
      idim = 2
c  set up the dimension information
      nc = 40
      nd = 12
c  set up the points where the curve will be evaluated.
      m = 20
      do 10 i=1,m
        ai = i-1
        u(i) = ai*0.5e-01
  10  continue
c  main loop for the different spline degrees.
      do 120 k=3,5,2
c  the order of the spline.
        k1 = k+1
c  n denotes the total number of knots.
        n = 2*k1+4
c  set up the knots of the spline
        t(k1) = 0.
        t(k1+1) = 0.1e0
        t(k1+2) = 0.3e0
        t(k1+3) = 0.4e0
        t(k1+4) = 0.8e0
        t(k1+5) = 0.1e+01
c  fetch the b-spline coefficients for sx(u)
        c(1) = 0.1e+01
        c(2) = 0.3e+01
        c(3) = 0.4e+01
        c(4) = 0.5e+01
        c(5) = -0.1e+01
c  fetch the b-spline coefficients for sy(u)
        c(n+1) = 0.1e+01
        c(n+2) = 0.2e+01
        c(n+3) = -0.3e+01
        c(n+4) = 0.2e+01
        c(n+5) = 0.4e+01
c  incorporate the boundary conditions for periodic splines
        nk = n-k
        per = t(nk)-t(k1)
        do 20 j=1,k
c  the boundary knots
          i1 = nk+j
          i2 = nk-j
          j1 = k1+j
          j2 = k1-j
          t(i1) = t(j1)+per
          t(j2) = t(i2)-per
c  the boundary coefficients
          jn = j+n
          c(j+5) = c(j)
          c(jn+5) = c(jn)
  20    continue
c  print the data for the spline.
        write(6,900) k
        write(6,905)
        write(6,910) (t(i),i=1,n)
        write(6,915)
        nk1 = n-k1
        write(6,920) (c(i),i=1,nk1)
        write(6,925)
        i1 = n+1
        i2 = n+nk1
        write(6,920) (c(i),i=i1,i2)
        l = k
        l1 = k1
        kk = k1*idim
c  main loop for the different points of evaluation.
        ip = 0
        do 100 i=1,m
          arg = u(i)
c  search for knot interval t(l)<=u(i)<t(l+1).
  40      if(arg.lt.t(l1) .or. l.eq.nk1) go to 70
c  a new knot interval.
          l = l1
          l1 = l+1
          if(t(l).eq.t(l1)) go to 40
          write(6,930) t(l),t(l1)
c  calculate the spline derivatives at the midpoint tt of the interval
          tt = (t(l)+t(l1))*0.5e0
          call cualde(idim,t,n,c,nc,k1,tt,d,nd,ier)
          write(6,935)
          write(6,940) (d(j),j=1,kk)
c  calculate the coefficients cof in the polynomial representation of
c  the spline curve in the current knot interval,i.e.
c    sx(u) = cof(1,1)+cof(1,2)*(u-tt)+...+cof(1,k1)*(u-tt)**k
c    sy(u) = cof(2,1)+cof(2,2)*(u-tt)+...+cof(2,k1)*(u-tt)**k
          fac = 0.1e01
          jj = 0
          do 60 j=1,k1
            do 50 ii=1,idim
              jj = jj+1
              cof(ii,j) = d(jj)/fac
  50        continue
            aj = j
            fac = fac*aj
  60      continue
          write(6,945)
          write(6,950) (cof(1,j),j=1,k1)
          write(6,955)
          write(6,950) (cof(2,j),j=1,k1)
          go to 40
c  evaluate the polynomial curve
  70      uu = arg-tt
          do 90 ii=1,idim
            pol = cof(ii,k1)
            jj = k1
            do 80 j=1,k
              jj = jj-1
              pol = pol*uu+cof(ii,jj)
  80        continue
            ip = ip+1
            sp(ip) = pol
  90      continue
 100    continue
        write(6,960)
        i2 = 0
        j4 = 0
        do 110 j=1,10
          i1 = i2+1
          i2 = i1+1
          j1 = j4+1
          j2 = j1+1
          j3 = j2+1
          j4 = j3+1
          write(6,965) i1,u(i1),sp(j1),sp(j2),i2,u(i2),sp(j3),sp(j4)
 110    continue
 120  continue
      stop
c  format statements.
 900  format(31h0degree of the spline curve k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,12f6.1)
 915  format(1x,30hb-spline coefficients of sx(u))
 920  format(5x,14f5.0)
 925  format(1x,30hb-spline coefficients of sy(u))
 930  format(16h0knot interval (,f4.1,1h,,f4.1,1h))
 935  format(1x,49hcurve derivatives at the midpoint of the interval)
 940  format(1x,3(1x,2e12.4))
 945  format(1x,50hcoefficients in the polynomial represent. of sx(u))
 950  format(2x,6e13.5)
 955  format(1x,50hcoefficients in the polynomial represent. of sy(u))
 960  format(1x,2(5x,1hi,3x,4hu(i),4x,8hsx(u(i)),4x,8hsy(u(i))))
 965  format(1x,2(i6,f7.2,2f12.5))
      end


      SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     Given a complex valued rational function of frequency (transfer
C     function) G(jW) this routine will calculate its complex value or
C     its magnitude and phase for a specified frequency value.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UNITF   CHARACTER*1
C             Indicates the choice of frequency unit as follows:
C             = 'R':  Input frequency W in radians/second;
C             = 'H':  Input frequency W in hertz.
C
C     OUTPUT  CHARACTER*1
C             Indicates the choice of co-ordinates for output as folows:
C             = 'C':  Cartesian co-ordinates (output real and imaginary
C                     parts of G(jW));
C             = 'P':  Polar co-ordinates (output magnitude and phase
C                     of G(jW)).
C
C     Input/Output Parameters
C
C     NP1     (input) INTEGER
C             The order of the denominator + 1, i.e. N + 1.  NP1 >= 1.
C
C     MP1     (input) INTEGER
C             The order of the numerator + 1, i.e. M + 1.  MP1 >= 1.
C
C     W       (input) DOUBLE PRECISION
C             The frequency value W for which the transfer function is
C             to be evaluated.
C
C     A       (input) DOUBLE PRECISION array, dimension (NP1)
C             This array must contain the vector of denominator
C             coefficients in ascending order of powers. That is, A(i)
C             must contain the coefficient of (jW)**(i-1) for i = 1,
C             2,...,NP1.
C
C     B       (input) DOUBLE PRECISION array, dimension (MP1)
C             This array must contain the vector of numerator
C             coefficients in ascending order of powers. That is, B(i)
C             must contain the coefficient of (jW)**(i-1) for i = 1,
C             2,...,MP1.
C
C     VALR    (output) DOUBLE PRECISION
C             If OUTPUT = 'C', VALR contains the real part of G(jW).
C             If OUTPUT = 'P', VALR contains the magnitude of G(jW)
C                              in dBs.
C
C     VALI    (output) DOUBLE PRECISION
C             If OUTPUT = 'C', VALI contains the imaginary part of
C                              G(jW).
C             If OUTPUT = 'P', VALI contains the phase of G(jW) in
C                              degrees.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the frequency value W is a pole of G(jW), or all
C                   the coefficients of the A polynomial are zero.
C
C     METHOD
C
C     By substituting the values of A, B and W in the following
C     formula:
C
C            B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1)
C     G(jW) = ---------------------------------------------------.
C            A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1)
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0(N+M) operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TD01AD by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom, March 1981.
C
C     REVISIONS
C
C     February 1997.
C     February 22, 1998 (changed the name of TD01MD).
C
C     KEYWORDS
C
C     Elementary polynomial operations, frequency response, matrix
C     fraction, polynomial matrix, state-space representation, transfer
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0,
     $                    TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0,
     $                    THRE60=360.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         OUTPUT, UNITF
      INTEGER           INFO, MP1, NP1
      DOUBLE PRECISION  VALI, VALR, W
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
C     .. Local Scalars ..
      LOGICAL           LOUTPU, LUNITF
      INTEGER           I, IPHASE, M, M2, N, N2, NPZERO, NZZERO
      DOUBLE PRECISION  BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC
      COMPLEX*16        ZTEMP
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAPY2
      COMPLEX*16        ZLADIV
      EXTERNAL          DLAPY2, LSAME, ZLADIV
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD,
     $                  SIGN
C     .. Executable Statements ..
C
      INFO = 0
      LUNITF = LSAME( UNITF,  'H' )
      LOUTPU = LSAME( OUTPUT, 'P' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF,  'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN
         INFO = -2
      ELSE IF( NP1.LT.1 ) THEN
         INFO = -3
      ELSE IF( MP1.LT.1 ) THEN
         INFO = -4
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TD05AD', -INFO )
         RETURN
      END IF
C
      M = MP1 - 1
      N = NP1 - 1
      WC = W
      TWOPI = EIGHT*ATAN( ONE )
      IF ( LUNITF ) WC = WC*TWOPI
      W2 = WC**2
C
C     Determine the orders z (NZZERO) and p (NPZERO) of the factors
C     (jW)**k in the numerator and denominator polynomials, by counting
C     the zero trailing coefficients.  The value of G(jW) will then be
C     computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n.
C
      I = 0
C
   10 CONTINUE
      I = I + 1
      IF ( I.LE.M ) THEN
         IF ( B(I).EQ.ZERO ) GO TO 10
      END IF
C
      NZZERO = I - 1
      I = 0
C
   20 CONTINUE
      I = I + 1
      IF ( I.LE.N ) THEN
         IF ( A(I).EQ.ZERO ) GO TO 20
      END IF
C
      NPZERO = I - 1
      IPHASE = NZZERO - NPZERO
C
      M2 = MOD( M - NZZERO, 2 )
C
C     Add real parts of the numerator m(jW).
C
      TREAL = B(MP1-M2)
C
      DO 30 I = M - 1 - M2, NZZERO + 1, -2
         TREAL = B(I) - W2*TREAL
   30 CONTINUE
C
C     Add imaginary parts of the numerator m(jW).
C
      IF ( M.EQ.0 ) THEN
         TIMAG = ZERO
      ELSE
         TIMAG = B(M+M2)
C
         DO 40 I = M + M2 - 2, NZZERO + 2, -2
            TIMAG = B(I) - W2*TIMAG
   40    CONTINUE
C
         TIMAG = TIMAG*WC
      END IF
C
      N2 = MOD( N - NPZERO, 2 )
C
C     Add real parts of the denominator n(jW).
C
      BREAL = A(NP1-N2)
C
      DO 50 I = N - 1 - N2, NPZERO + 1, -2
         BREAL = A(I) - W2*BREAL
   50 CONTINUE
C
C     Add imaginary parts of the denominator n(jW).
C
      IF ( N.EQ.0 ) THEN
         BIMAG = ZERO
      ELSE
         BIMAG = A(N+N2)
C
         DO 60 I = N + N2 - 2, NPZERO + 2, -2
            BIMAG = A(I) - W2*BIMAG
   60    CONTINUE
C
         BIMAG = BIMAG*WC
      END IF
C
      IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR.
     $     ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN
C
C        Error return:  The specified frequency W is a pole of G(jW),
C              or all the coefficients of the A polynomial are zero.
C
         INFO = 1
      ELSE
C
C        Evaluate the complex number W**(z-p)*m(jW)/n(jW).
C
         ZTEMP =
     $      ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) )
         VALR = DBLE(  ZTEMP )*WC**IPHASE
         VALI = DIMAG( ZTEMP )*WC**IPHASE
C
         IF ( .NOT.LOUTPU ) THEN
C
C           Cartesian co-ordinates: Update the result for j**(z-p).
C
            I = MOD( ABS( IPHASE ), 4 )
            IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR.
     $           ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN
               VALR = -VALR
               VALI = -VALI
            END IF
C
            IF ( MOD( I, 2 ).NE.0 ) THEN
               G    =  VALR
               VALR = -VALI
               VALI =  G
            END IF
C
         ELSE
C
C           Polar co-ordinates: Compute the magnitude and phase.
C
            G = DLAPY2( VALR, VALI )
C
            IF ( VALR.EQ.ZERO ) THEN
               VALI = SIGN( NINETY, VALI )
            ELSE
               VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60
               IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N
     $                           .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO )
     $            VALI = ONE80
            END IF
C
            VALR = TWENTY*LOG10( G )
C
            IF ( IPHASE.NE.0 )
     $         VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY
         END IF
C
      END IF
C
      RETURN
C *** Last line of TD05AD ***
      END