subroutine helicity_amps

    implicit none

    include 'mpintp.inc'
    include 'spp.inc'

    real   root2, s, s2, c, c2
    real   theta_cm
    integer l

    data root2/1.41421/

    call cgln_amps

    theta_cm = acos(csthcm)

    s = sin(theta_cm)
    c = cos(theta_cm)
    s2 = sin(theta_cm / 2.0)
    c2 = cos(theta_cm / 2.0)

    hh1 = 0.0
    hh2 = 0.0
    hh3 = 0.0
    hh4 = 0.0
    hh5 = 0.0
    hh6 = 0.0

    if(method_helicity.eq.1) then
        !        hh1 = -s*(ff3 + ff4*c)/root2
        !        hh2 = -(2*ff1 - 2*ff2*c + ff4*s2)/root2
        !        hh3 = -ff4*s2/root2
        !        hh4 = s*(2*ff2 + ff3 + ff4*c)/root2
        !        hh5 = ff5 + ff6*c
        !        hh6 = ff6*s
        hh1 = -s * c2 * (ff3 + ff4) / root2
        hh2 = c2 * ((ff2 - ff1) + 0.5 * (1 - c) * (ff3 - ff4)) * root2
        hh3 = s * s2 * (ff3 - ff4) / root2
        hh4 = s2 * ((ff2 + ff1) + 0.5 * (1 + c) * (ff3 + ff4)) * root2
        hh5 = c2 * (ff5 + ff6)
        hh6 = s2 * (ff6 - ff5)

    else

        do l = 0, wave_L
            hh1 = hh1 + s * c2 * (bp(l) - bm(l + 1)) * (pol(l, 2) - pol(l + 1, 2)) / root2
            hh2 = hh2 + c2 * (ap(l) - am(l + 1)) * (pol(l, 1) - pol(l + 1, 1)) * root2
            hh3 = hh3 + s * s2 * (bp(l) + bm(l + 1)) * (pol(l, 2) + pol(l + 1, 2)) / root2
            hh4 = hh4 + s2 * (ap(l) + am(l + 1)) * (pol(l, 1) + pol(l + 1, 1)) * root2
            hh5 = hh5 - c2 * (cp(l) - cm(l + 1)) * (pol(l, 1) - pol(l + 1, 1))
            hh6 = hh6 - s2 * (cp(l) + cm(l + 1)) * (pol(l, 1) + pol(l + 1, 1))
        enddo

    endif

end


program EC_rotate
!  Rotate an input .ecs file

use constants
use anisotropy_ajn

real(rs)  :: C(6,6),rho,Ctemp(6,6),a,b,g
character(len=250) :: fname

if (command_argument_count() /= 4) then
   write(0,*) 'Usage: EC_rot3 [alpha] [beta] [gamma] [.ecs file] > [output file]'
   stop
endif

call get_command_argument(1,fname); read(fname,*) a
call get_command_argument(2,fname); read(fname,*) b
call get_command_argument(3,fname); read(fname,*) g

call get_command_argument(4,fname)

call CIJ_load(fname,C,rho)

call CIJ_rot3(C,a,b,g,Ctemp)

do i=1,6
   do j=i,6
      write(*,'(2i2,1x,d24.16)') i,j,Ctemp(i,j)
   enddo
enddo
write(*,'(2i2,1x,d24.16)') 7,7,rho

end program EC_rotate


subroutine diffuse_scalar3D (field,fluxb,fluxt,tkh,rho,rhow,flux)

use grid
use params, only: docolumn,dowallx,dowally,dosgs
use sgs, only: grdf_x,grdf_y,grdf_z
implicit none
! input
real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm)	! scalar
real tkh(0:nxp1,1-YES3D:nyp1,nzm)	! eddy conductivity
real fluxb(nx,ny)		! bottom flux
real fluxt(nx,ny)		! top flux
real rho(nzm)
real rhow(nz)
real flux(nz)
! local
real flx(0:nx,0:ny,0:nzm)
real dfdt(nx,ny,nz)
real rdx2,rdy2,rdz2,rdz,rdx5,rdy5,rdz5,tmp
real dxy,dxz,dyx,dyz,dzx,dzy,tkx,tky,tkz,rhoi
integer i,j,k,ib,ic,jb,jc,kc,kb

if(.not.dosgs) return

rdx2=1./(dx*dx)
rdy2=1./(dy*dy)
rdz2=1./(dz*dz)
rdz=1./dz
dxy=dx/dy
dxz=dx/dz
dyx=dy/dx
dyz=dy/dz
dzx=dz/dx
dzy=dz/dy

dfdt(:,:,:)=0.

!-----------------------------------------
if(dowallx) then

  if(mod(rank,nsubdomains_x).eq.0) then
    do k=1,nzm
     do j=1,ny
         field(0,j,k) = field(1,j,k)
     end do
    end do
  end if
  if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then
    do k=1,nzm
     do j=1,ny
         field(nx+1,j,k) = field(nx,j,k)
     end do
    end do
  end if

end if

if(dowally) then

  if(rank.lt.nsubdomains_x) then
    do k=1,nzm
       do i=1,nx
         field(i,1-YES3D,k) = field(i,1,k)
       end do
    end do
  end if
  if(rank.gt.nsubdomains-nsubdomains_x-1) then
    do k=1,nzm
       do i=1,nx
         field(i,ny+YES3D,k) = field(i,ny,k)
       end do
    end do
  end if

end if

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

!  Horizontal diffusion:

do k=1,nzm

 rdx5=0.5*rdx2  * grdf_x(k)
 rdy5=0.5*rdy2  * grdf_y(k)

 do j=1,ny
  do i=0,nx
    ic=i+1
    tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k))
    flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k))
  end do
  do i=1,nx
    ib=i-1
    dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k))
  end do
 end do

 do j=0,ny
  jc=j+1
  do i=1,nx
   tky=rdy5*(tkh(i,j,k)+tkh(i,jc,k))
   flx(i,j,k)=-tky*(field(i,jc,k)-field(i,j,k))
  end do
 end do
 do j=1,ny
  jb=j-1
  do i=1,nx
    dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(i,jb,k))
  end do
 end do

end do ! k

!  Vertical diffusion:

flux(1) = 0.
tmp=1./adzw(nz)
do j=1,ny
 do i=1,nx
   flx(i,j,0)=fluxb(i,j)*rdz*rhow(1)
   flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz)
   flux(1) = flux(1) + flx(i,j,0)
 end do
end do

do k=1,nzm-1
 kc=k+1
 flux(kc)=0.
 rhoi = rhow(kc)/adzw(kc)
 rdz5=0.5*rdz2 * grdf_z(k)
 do j=1,ny
  do i=1,nx
    tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc))
    flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi
    flux(kc) = flux(kc) + flx(i,j,k)
  end do
 end do
end do

do k=1,nzm
 kb=k-1
 rhoi = 1./(adz(k)*rho(k))
 do j=1,ny
  do i=1,nx
   dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi)
   field(i,j,k)=field(i,j,k)+dfdt(i,j,k)
  end do
 end do
end do

end subroutine diffuse_scalar3D


program reduce

implicit none
include 'mpif.h'

        integer :: ierr, rank, size
        integer, parameter :: iroot = 0
        integer :: data, result

        call MPI_INIT(ierr)
!-------------------------------------------------------------
        call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
        call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)

        data = rank + 1

        call MPI_REDUCE(data, result, 1, MPI_INTEGER, &
                   MPI_PROD, iroot, MPI_COMM_WORLD, &
                   ierr)

        print *, 'rank:', rank
        if (rank.eq.iroot) then
                print *, 'The number of procs:', size
                print *, 'Product result is:', result
        end if

!-------------------------------------------------------------
        call MPI_FINALIZE(ierr)

end program


       SUBROUTINE W3FB07(XI,XJ,ALAT1,ALON1,DX,ALONV,ALAT,ALON)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM:  W3FB07        GRID COORDS TO LAT/LON FOR GRIB
C   PRGMMR: STACKPOLE        ORG: NMC42       DATE:88-04-05
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN A
C   GRID COORDINATE SYSTEM OVERLAID ON A POLAR STEREOGRAPHIC MAP PRO-
C   JECTION TRUE AT 60 DEGREES N OR S LATITUDE TO THE
C   NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE
C   W3FB07 IS THE REVERSE OF W3FB06.
C   USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID
C
C PROGRAM HISTORY LOG:
C   88-01-01  ORIGINAL AUTHOR:  STACKPOLE, W/NMC42
C   90-04-12  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB07(XI,XJ,ALAT1,ALON1,DX,ALONV,ALAT,ALON)
C   INPUT ARGUMENT LIST:
C     XI       - I COORDINATE OF THE POINT  REAL*4
C     XJ       - J COORDINATE OF THE POINT  REAL*4
C     ALAT1    - LATITUDE  OF LOWER LEFT POINT OF GRID (POINT 1,1)
C                LATITUDE <0 FOR SOUTHERN HEMISPHERE; REAL*4
C     ALON1    - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT 1,1)
C                  EAST LONGITUDE USED THROUGHOUT; REAL*4
C     DX       - MESH LENGTH OF GRID IN METERS AT 60 DEG LAT
C                 MUST BE SET NEGATIVE IF USING
C                 SOUTHERN HEMISPHERE PROJECTION; REAL*4
C                   190500.0 LFM GRID,
C                   381000.0 NH PE GRID, -381000.0 SH PE GRID, ETC.
C     ALONV    - THE ORIENTATION OF THE GRID.  I.E.,
C                THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN
C                WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF
C                THE GRID) ALONG WHICH LATITUDE INCREASES AS
C                THE Y-COORDINATE INCREASES.  REAL*4
C                   FOR EXAMPLE:
C                   255.0 FOR LFM GRID,
C                   280.0 NH PE GRID, 100.0 SH PE GRID, ETC.
C
C   OUTPUT ARGUMENT LIST:
C     ALAT     - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMI.)
C     ALON     - EAST LONGITUDE IN DEGREES, REAL*4
C
C   REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES,
C     AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981
C     AFGWC/TN-79/003
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
         DATA  RERTH /6.3712E+6/,PI/3.1416/
         DATA  SS60  /1.86603/
C
C        PRELIMINARY VARIABLES AND REDIFINITIONS
C
C        H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
C
C        REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE
C        DRAWN THROUGH THE POLE AND TO THE RIGHT LIES
C        ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE
C        DIFFERENTLY IN EACH HEMISPHERE
C
         IF (DX.LT.0) THEN
           H      = -1.0
           DXL    = -DX
           REFLON = ALONV - 90.0
         ELSE
           H      = 1.0
           DXL    = DX
           REFLON = ALONV - 270.0
         ENDIF
C
         RADPD  = PI    / 180.0
         DEGPRD = 180.0 / PI
         REBYDX = RERTH / DXL
C
C        RADIUS TO LOWER LEFT HAND (LL) CORNER
C
         ALA1 =  ALAT1 * RADPD
         RMLL = REBYDX * COS(ALA1) * SS60/(1. + H * SIN(ALA1))
C
C        USE LL POINT INFO TO LOCATE POLE POINT
C
         ALO1 = (ALON1 - REFLON) * RADPD
         POLEI = 1. - RMLL * COS(ALO1)
         POLEJ = 1. - H * RMLL * SIN(ALO1)
C
C        RADIUS TO THE I,J POINT (IN GRID UNITS)
C
         XX =  XI - POLEI
         YY = (XJ - POLEJ) * H
         R2 =  XX**2 + YY**2
C
C        NOW THE MAGIC FORMULAE
C
         IF (R2.EQ.0) THEN
           ALAT = H * 90.
           ALON = REFLON
         ELSE
           GI2    = (REBYDX * SS60)**2
           ALAT   = DEGPRD * H * ASIN((GI2 - R2)/(GI2 + R2))
           ARCCOS = ACOS(XX/SQRT(R2))
           IF (YY.GT.0) THEN
             ALON = REFLON + DEGPRD * ARCCOS
           ELSE
             ALON = REFLON - DEGPRD * ARCCOS
           ENDIF
         ENDIF
         IF (ALON.LT.0) ALON = ALON + 360.
C
      RETURN
      END


subroutine fixaray(ierflag)

      use stel_kinds, only: dp
      use name0,      only: czero,   &
                            cp5,     &
                            c1p0,    &
                            c2p0,    &
                            c3p0,    &
                            c8p0
      use name1,      only: nzeta,   &
                            ntheta1, &
                            ntheta2, &
                            mpol1,   &
                            nmax,    &
                            nmax1
      use scalars,    only: twopi,   &
                            dnorm,   &
                            isigng
      use inputdat,   only: nfp, rb, zb
      use mnarray,    only: mscale,  &
                            nscale,  &
                            xmpq,    &
                            xrz3,    &
                            xrz4
      use spectra,    only: faccon
      use trignew,    only: cosmu,   &
                            sinmu,   &
                            cosmui,  &
                            cosmum,  &
                            sinmum,  &
                            cosmumi, &
                            cosnv,   &
                            sinnv,   &
                            cosnvn,  &
                            sinnvn

      implicit none

      ! TODO: more elegant definition of these BLAS functions
      real(kind=dp) :: dsum

      integer, intent(out) :: ierflag

      integer       :: i, j, m, n
      real(kind=dp) :: arg, argi, argj
      real(kind=dp) :: power
      real(kind=dp) :: t1
      real(kind=dp) :: rtest, ztest

      !         INDEX OF LOCAL VARIABLES
      !
      ! mscale  array for norming theta-trig functions (internal use only)
      ! nscale  array for norming zeta -trig functions (internal use only)

      ! COMPUTE TRIGONOMETRIC FUNCTION ARRAYS

      twopi = c8p0*atan(c1p0)
      dnorm = c1p0/real(nzeta*(ntheta2-1))

      do i = 1, ntheta2
        argi = twopi * real(i-1)/real(ntheta1)
        do m = 0, mpol1
          arg = argi * real(m)

          cosmu(i,m) = cos(arg)*mscale(m)
          sinmu(i,m) = sin(arg)*mscale(m)

          cosmui(i,m) = cosmu(i,m)
          if (i.eq.1 .or. i.eq.ntheta2) &
            cosmui(i,m) = cp5*cosmui(i,m)

          cosmum (i,m) =  cosmu (i,m)*real(m)
          sinmum (i,m) = -sinmu (i,m)*real(m)
          cosmumi(i,m) =  cosmui(i,m)*real(m)
        enddo
      enddo

      do j = 1, nzeta
        argj = twopi * real(j-1)/real(nzeta)
        do n = 0, nmax
          arg = argj * real(n)

          cosnv (j,n) = cos(arg)*nscale(n)
          sinnv (j,n) = sin(arg)*nscale(n)
          cosnvn(j,n) = cosnv(j,n)*real(n*nfp)
          sinnvn(j,n) =-sinnv(j,n)*real(n*nfp)
        enddo
      enddo

      do m = 0, mpol1
        power = -cp5*real(m) ! -m/2

        xmpq(m,1) = real(m*(m-1))
        xmpq(m,2) = real(m**4)
        xmpq(m,3) = real(m**5)

        ! later: 1/xpmq(m,1)**2 = 1/[m(m-1)]^2 = 1/{(m^2-m)^2} = 1/{m^4 - 2*m^3 + m^2}
        t1 = -cp5*real(isigng)*dnorm/real((1+m)**4) ! TODO: what is (1+m)^4 ???
        do n = 0, nmax

          faccon(n,m) = t1/(mscale(m)*nscale(n))**2
          if (m.eq.0 .or. n.eq.0) &
            faccon(n,m) = cp5*faccon(n,m)

          xrz3(n,m) = c2p0**(power + c1p0)
          xrz4(n,m) =-c3p0**power
        enddo
      enddo

      ! CHECK SIGN OF JACOBIAN (SHOULD BE SAME AS ISIGNG)
      rtest = sum(rb(0:nmax,1,1))
      ztest = sum(zb(0:nmax,1,2))
      print *, "rtest = ", rtest
      print *, "ztest = ", ztest
      if ((rtest*ztest*real(isigng)) .ge. czero) &
        ierflag = 5

      return

end


! cooling_Gnedin.f90 $Id: 87e885e42c6cff1bc93bae7e5bf8084992e568ec $
!-------------------------------------------------------------------------------
FUNCTION cooling_Gnedin (self, temp)
  implicit none
  class(cooling_t):: self
  real(kind=dp) cooling_Gnedin, temp, p
  integer i
  real, parameter:: dlgT=0.1, lgT0=1.0
  integer, parameter:: ntab=81
  real(kind=dp), parameter, dimension(ntab):: ln25 = (/ &
   -8.6450,-8.1238,-7.6490,-7.2158,-6.8207,-6.4650,-6.1428,-5.8379, &
   -5.5115,-5.1155,-4.6465,-4.1402,-3.6593,-3.2304,-2.8680,-2.5690, &
   -2.3228,-2.1203,-1.9505,-1.8042,-1.6724,-1.5460,-1.2870,-1.0269, &
   -0.7525,-0.4544,-0.1468, 0.1931, 0.5939, 1.1394, 2.0933, 3.9022, &
    6.1748, 6.5501, 6.2719, 6.2451, 6.4187, 6.7583, 7.2167, 7.6392, &
    7.7969, 7.7480, 7.7677, 7.8474, 7.8755, 7.4928, 7.2349, 7.1854, &
    6.9207, 6.6918, 6.6560, 6.5481, 6.3418, 5.9320, 5.4885, 5.1625, &
    4.9726, 4.9265, 4.9445, 4.9822, 4.9843, 4.9280, 4.8032, 4.6959, &
    4.6625, 4.6812, 4.7414, 4.8195, 4.9030, 5.0019, 5.0907, 5.1745, &
    5.2423, 5.2943, 5.3318, 5.3552, 5.3790, 5.3932, 5.4009, 5.4076, &
    5.4205 /)
!...............................................................................
  if (Temp < T_MC) then
    cooling_Gnedin=0.0
  else
    p=1.+(log10(temp)-lgT0)/dlgT
    i=min(max(int(p),1),ntab-1)
    p=p-i
    cooling_Gnedin=1e-25*exp((1-p)*ln25(i)+p*ln25(i+1))
  endif
END


subroutine p850_to_msl(lon,lat,time,zg_array,ta_array,output_array)
	implicit none
	integer, intent(in) :: lon,lat,time
	integer :: x,y,t
	double precision, intent(in) :: zg_array(lon,lat,time),ta_array(lon,lat,time)
	double precision, intent(out) :: output_array(lon,lat,time)
	do 20,t=1,time
	  do 10, x=1,lon
	   do 5, y=1,lat
	   output_array(x,y,t) = 85000*(1 - ((0.0065* zg_array(x,y,t))&
				/(ta_array(x,y,t)+(0.0065* zg_array(x,y,t)))))** (-5.257)

5          end do
10         end do
20	end do
	end subroutine p850_to_msl


       module calc_gmin
!       use math

       contains

         subroutine calc_gmin_subroutine(gmin_p,gmin_theta,gmin_etas,gmin_gmins,gmin_nfracs)
           real(kind=8), intent(in) :: gmin_p
           real(kind=8) :: gmin_lin_cons, gmin_lin_coeff, gmin_lin_power
           real(kind=8) :: gmin_inv_cons, gmin_inv_coeff, gmin_inv_power
           real(kind=8) :: gmin_inv_sin_coeff, gmin_inv_sin_freq, gmin_inv_sin_delay
           real(kind=8) :: gmin_lin_sin_coeff, gmin_lin_sin_freq, gmin_lin_sin_delay
           real(kind=8), dimension(:), intent(in) :: gmin_theta, gmin_etas
           real(kind=8), dimension(size(gmin_theta)) :: one
           real(kind=8), dimension(size(gmin_theta)) :: gmin_linear_constant, gmin_inverse_constant, gmin_atheta
           real(kind=8), dimension(size(gmin_theta)) :: gmin_raw_gmins
           real(kind=8) :: acenter, anormal, azero, astwo
!          intermediate variables
           real(kind=8), dimension(size(gmin_theta)), intent(out) :: gmin_gmins, gmin_nfracs
           one = 1d0
           acenter = 0.5668090982352612
           anormal = 0.52624783
           azero = 3d0 / sqrt(2d0)
           astwo = LOG(SQRT(2d0))

           if(gmin_p==3.5) then
              gmin_lin_power =0.276589155355
              gmin_lin_coeff =-13.5593749125
              gmin_lin_cons =16.0797900684
              gmin_inv_power =6.53997654139
              gmin_inv_coeff =151.597731214
              gmin_inv_cons =0.722506578136
              gmin_lin_sin_coeff =-0.143307918052
              gmin_lin_sin_freq =-0.143307918052
              gmin_lin_sin_delay =-0.143307918052
              gmin_lin_sin_coeff =0.121815691108
              gmin_lin_sin_freq =0.121815691108
              gmin_lin_sin_delay =0.121815691108

           else
              gmin_lin_cons = 21.38307186
              gmin_lin_coeff = -16.7811712
              gmin_lin_power = 0.15128533
!           gmin_inv_cons = 0.53189121
!           gmin_inv_coeff = 0.91485025
!           gmin_inv_power = 1.14368368
!           gmin_inv_sin_coeff = .0111806594
!           gmin_inv_sin_freq = -17.0100822
!           gmin_inv_sin_delay = 4.03979965
              gmin_inv_cons = 0.74798712
              gmin_inv_coeff = 0.62609462
              gmin_inv_power = 0.81567379
              gmin_inv_sin_coeff = .00638946501
              gmin_inv_sin_freq = -16.8034428
              gmin_inv_sin_delay = 3.72208398
              gmin_lin_sin_coeff = 0.
              gmin_lin_sin_freq = 0.
              gmin_lin_sin_delay = 0.
           endif

           gmin_linear_constant = gmin_lin_cons + gmin_lin_coeff*(gmin_etas**gmin_lin_power)&
                + gmin_lin_sin_coeff*SIN(gmin_etas*gmin_lin_sin_freq + gmin_lin_sin_delay)
           gmin_inverse_constant = gmin_inv_cons + gmin_inv_coeff*(gmin_etas**gmin_inv_power)&
                + gmin_inv_sin_coeff*SIN(gmin_etas*gmin_inv_sin_freq + gmin_inv_sin_delay)

           gmin_raw_gmins = gmin_theta* gmin_linear_constant + gmin_inverse_constant
           gmin_gmins = merge(gmin_raw_gmins,one,gmin_raw_gmins.ge.1d0)
!I decided to combine a(theta) *theta into a single function atheta
           gmin_atheta = gmin_theta * azero * EXP(astwo * TANH(anormal*LOG(gmin_theta / acenter)))
!azero is moving tanh down to the midpoint of 1.5 and 3.0
!astwo is scaling the amplitude of tanh in loglog space to sqrt(2)
!           gmin_atheta = -0.918344120 + 2.99892343*gmin_theta

           gmin_nfracs = gmin_etas*gmin_atheta*((gmin_p - 2.)/(gmin_p - 1.)) * (gmin_gmins**(gmin_p - 2.))

         end subroutine calc_gmin_subroutine
         end module calc_gmin


      SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW,
     $                   CS, TAU, RS, LDRS, T, LDT, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To form the triangular block factors R, S and T of a symplectic
C     block reflector SH, which is defined as a product of 2k
C     concatenated Householder reflectors and k Givens rotations,
C
C         SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C              diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                                ....
C              diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).
C
C     The upper triangular blocks of the matrices
C
C                                 [ S1 ]       [ T11 T12 T13 ]
C         R  = [ R1 R2 R3 ],  S = [ S2 ],  T = [ T21 T22 T23 ],
C                                 [ S3 ]       [ T31 T32 T33 ]
C
C     with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular,
C     are stored rowwise in the arrays RS and T, respectively.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DIRECT  CHARACTER*1
C             This is a dummy argument, which is reserved for future
C             extensions of this subroutine. Not referenced.
C
C     STOREV  CHARACTER*1
C             Specifies how the vectors which define the concatenated
C             Householder F(i) reflectors are stored:
C             = 'C':  columnwise;
C             = 'R':  rowwise.
C
C     STOREW  CHARACTER*1
C             Specifies how the vectors which define the concatenated
C             Householder H(i) reflectors are stored:
C             = 'C':  columnwise;
C             = 'R':  rowwise.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the Householder reflectors F(i) and H(i).
C             N >= 0.
C
C     K       (input) INTEGER
C             The number of Givens rotations.  K >= 1.
C
C     V       (input) DOUBLE PRECISION array, dimension
C                     (LDV,K) if STOREV = 'C',
C                     (LDV,N) if STOREV = 'R'
C             On entry with STOREV = 'C', the leading N-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector F(i).
C             On entry with STOREV = 'R', the leading K-by-N part of
C             this array must contain in its i-th row the vector
C             which defines the elementary reflector F(i).
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= MAX(1,N),  if STOREV = 'C';
C             LDV >= K,         if STOREV = 'R'.
C
C     W       (input) DOUBLE PRECISION array, dimension
C                     (LDW,K) if STOREW = 'C',
C                     (LDW,N) if STOREW = 'R'
C             On entry with STOREW = 'C', the leading N-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector H(i).
C             On entry with STOREV = 'R', the leading K-by-N part of
C             this array must contain in its i-th row the vector
C             which defines the elementary reflector H(i).
C
C     LDW     INTEGER
C             The leading dimension of the array W.
C             LDW >= MAX(1,N),  if STOREW = 'C';
C             LDW >= K,         if STOREW = 'R'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*K)
C             On entry, the first 2*K elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (K)
C             On entry, the first K elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i).
C
C     RS      (output) DOUBLE PRECISION array, dimension (K,6*K)
C             On exit, the leading K-by-6*K part of this array contains
C             the upper triangular matrices defining the factors R and
C             S of the symplectic block reflector SH. The (strictly)
C             lower portions of this array are not used.
C
C     LDRS    INTEGER
C             The leading dimension of the array RS.  LDRS >= K.
C
C     T       (output) DOUBLE PRECISION array, dimension (K,9*K)
C             On exit, the leading K-by-9*K part of this array contains
C             the upper triangular matrices defining the factor T of the
C             symplectic block reflector SH. The (strictly) lower
C             portions of this array are not used.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= K.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*K)
C
C     REFERENCES
C
C     [1] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K
C     + 43/6*K - 4 floating point operations.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAEST).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DIRECT, STOREV, STOREW
      INTEGER           K, LDRS, LDT, LDV, LDW, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), RS(LDRS,*), T(LDT,*),
     $                  TAU(*), V(LDV,*), W(LDW,*)
C     .. Local Scalars ..
      LOGICAL           LCOLV, LCOLW
      INTEGER           I, J, K2, PR1, PR2, PR3, PS1, PS2, PS3, PT11,
     $                  PT12, PT13, PT21, PT22, PT23, PT31, PT32, PT33
      DOUBLE PRECISION  CM1, TAUI, VII, WII
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DSCAL, DTRMV
C
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      LCOLV = LSAME( STOREV, 'C' )
      LCOLW = LSAME( STOREW, 'C' )
C
      K2  = K + K
      PR1 = 0
      PR2 = PR1 + K
      PR3 = PR2 + K
      PS1 = PR3 + K
      PS2 = PS1 + K
      PS3 = PS2 + K
C
      PT11 = 0
      PT12 = PT11 + K
      PT13 = PT12 + K
      PT21 = PT13 + K
      PT22 = PT21 + K
      PT23 = PT22 + K
      PT31 = PT23 + K
      PT32 = PT31 + K
      PT33 = PT32 + K
C
      DO 90  I = 1, K
         TAUI = TAU(I)
         VII = V(I,I)
         V(I,I) = ONE
         WII = W(I,I)
         W(I,I) = ONE
         IF ( WII.EQ.ZERO ) THEN
            DO 10  J = 1, I
               T(J,PT11+I) = ZERO
   10       CONTINUE
            DO 20  J = 1, I-1
               T(J,PT21+I) = ZERO
   20       CONTINUE
            DO 30  J = 1, I-1
               T(J,PT31+I) = ZERO
   30       CONTINUE
            DO 40  J = 1, I-1
               RS(J,PS1+I) = ZERO
   40       CONTINUE
         ELSE
C
C           Treat first Householder reflection.
C
            IF ( LCOLV.AND.LCOLW ) THEN
C
C              Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i).
C
               CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW,
     $                     W(I,I), 1, ZERO, DWORK, 1 )
C
C              Compute t2 = -wii * V(i:n,1:i-1)' * W(i:n,i).
C
               CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV,
     $                     W(I,I), 1, ZERO, DWORK(K+1), 1 )
            ELSE IF ( LCOLV ) THEN
C
C              Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'.
C
               CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I),
     $                     LDW, W(I,I), LDW, ZERO, DWORK, 1 )
C
C              Compute t2 = -wii * V(i:n,1:i-1)' * W(i,i:n)'.
C
               CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV,
     $                     W(I,I), LDW, ZERO, DWORK(K+1), 1 )
            ELSE IF ( LCOLW ) THEN
C
C              Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i).
C
               CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW,
     $                     W(I,I), 1, ZERO, DWORK, 1 )
C
C              Compute t2 = -wii * V(1:i-1,i:n) * W(i:n,i).
C
               CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I),
     $                     LDV, W(I,I), 1, ZERO, DWORK(K+1), 1 )
            ELSE
C
C              Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'.
C
               CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I),
     $                     LDW, W(I,I), LDW, ZERO, DWORK, 1 )
C
C              Compute t2 = -wii * V(1:i-1,i:n) * W(i,i:n)'.
C
               CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I),
     $                     LDV, W(I,I), LDW, ZERO, DWORK(K+1), 1 )
            END IF
C
C           T11(1:i-1,i) := T11(1:i-1,1:i-1)*t1 + T13(1:i-1,1:i-1)*t2
C
            CALL DCOPY( I-1, DWORK, 1, T(1,PT11+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT11+1), LDT, T(1,PT11+I), 1 )
            CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT13+1), LDT, T(1,PT13+I), 1 )
            CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, T(1,PT11+I), 1 )
            T(I,PT11+I) = -WII
C
            IF ( I.GT.1 ) THEN
C
C              T21(1:i-1,i) := T21(1:i-1,1:i-1)*t1 + T23(1:i-1,1:i-1)*t2
C
               CALL DCOPY( I-2, DWORK(2), 1, T(1,PT21+I), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2,
     $                     T(1,PT21+2), LDT, T(1,PT21+I), 1 )
               T(I-1, PT21+I) = ZERO
               CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                     T(1,PT23+1), LDT, T(1,PT23+I), 1 )
               CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, T(1,PT21+I), 1 )
C
C              T31(1:i-1,i) := T31(1:i-1,1:i-1)*t1 + T33(1:i-1,1:i-1)*t2
C
               CALL DCOPY( I-2, DWORK(2), 1, T(1,PT31+I), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2,
     $                     T(1,PT31+2), LDT, T(1,PT31+I), 1 )
               T(I-1, PT31+I) = ZERO
               CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                     T(1,PT33+1), LDT, T(1,PT33+I), 1 )
               CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, T(1,PT31+I), 1 )
C
C              S1(1:i-1,i) := S1(1:i-1,1:i-1)*t1 + S3(1:i-1,1:i-1)*t2
C
               CALL DCOPY( I-2, DWORK(2), 1, RS(1,PS1+I), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2,
     $                     RS(1,PS1+2), LDRS, RS(1,PS1+I), 1 )
               RS(I-1, PS1+I) = ZERO
               CALL DCOPY( I-1, DWORK(K+1), 1, RS(1,PS3+I), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                     RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 )
               CALL DAXPY( I-1, ONE, RS(1,PS3+I), 1, RS(1,PS1+I), 1 )
            END IF
         END IF
C
C        Treat Givens rotation.
C
         CM1 = CS(2*I-1) - ONE
         IF ( LCOLW ) THEN
            CALL DCOPY( I, W(I,1), LDW, DWORK, 1 )
         ELSE
            CALL DCOPY( I, W(1,I), 1, DWORK, 1 )
         END IF
         IF ( LCOLV ) THEN
            CALL DCOPY( I-1, V(I,1), LDV, DWORK(K+1), 1 )
         ELSE
            CALL DCOPY( I-1, V(1,I), 1, DWORK(K+1), 1 )
         END IF
C
C        R1(1:i,i) = T11(1:i,1:i) * dwork(1:i)
C                    + [ T13(1:i-1,1:i-1) * dwork(k+1:k+i-1); 0 ]
C
         CALL DCOPY( I, DWORK, 1, RS(1,PR1+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I,
     $               T(1,PT11+1), LDT, RS(1,PR1+I), 1 )
         CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               T(1,PT13+1), LDT, T(1,PT13+I), 1 )
         CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, RS(1,PR1+I), 1 )
C
C        R2(1:i-1,i) = T21(1:i-1,2:i) * W(i,2:i)
C                      + T23(1:i-1,1:i-1) * V(i,1:i-1)
C
         CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR2+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               T(1,PT21+2), LDT, RS(1,PR2+I), 1 )
         CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               T(1,PT23+1), LDT, T(1,PT23+I), 1 )
         CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, RS(1,PR2+I), 1 )
C
C        R3(1:i-1,i) = T31(1:i-1,2:i) * dwork(2:i)
C                      + T33(1:i-1,1:i-1) * dwork(k+1:k+i-1)
C
         CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR3+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               T(1,PT31+2), LDT, RS(1,PR3+I), 1 )
         CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               T(1,PT33+1), LDT, T(1,PT33+I), 1 )
         CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, RS(1,PR3+I), 1 )
C
C        S2(1:i-1,i) = S1(1:i-1,2:i) * dwork(2:i)
C                      + S3(1:i-1,1:i-1) * dwork(k+1:k+i-1)
C
         CALL DCOPY( I-1, DWORK(2), 1, RS(1,PS2+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               RS(1,PS1+2), LDRS, RS(1,PS2+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               RS(1,PS3+1), LDRS, DWORK(K+1), 1 )
         CALL DAXPY( I-1, ONE, DWORK(K+1), 1, RS(1,PS2+I), 1 )
         RS(I,PS2+I) = -CS(2*I)
C
C        T12(1:i,i) = [ R1(1:i-1,1:i-1)*S2(1:i-1,i); 0 ]
C                     + (c-1) * R1(1:i,i)
C
         CALL DCOPY( I-1, RS(1,PS2+I), 1, T(1,PT12+I), 1 )
         CALL DSCAL( I-1, CM1, RS(1,PS2+I), 1)
         CALL DSCAL( I-1, CS(2*I), T(1,PT12+I), 1 )
         CALL DCOPY( I-1, T(1,PT12+I), 1, T(1,PT22+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $               RS(1,PR1+1), LDRS, T(1,PT12+I), 1 )
         T(I,PT12+I) = ZERO
         CALL DAXPY( I, CM1, RS(1,PR1+I), 1, T(1,PT12+I), 1 )
C
C        T22(1:i-1,i) = R2(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R2(1:i-1,i)
C
         IF (I.GT.1)
     $      CALL DCOPY( I-2, T(2,PT22+I), 1, T(1,PT32+I), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Unit diagonal', I-1,
     $               RS(1,PR2+1), LDRS, T(1,PT22+I), 1 )
         CALL DAXPY( I-1, CM1, RS(1,PR2+I), 1, T(1,PT22+I), 1 )
         T(I,PT22+I) = CM1
C
C        T32(1:i-1,i) = R3(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R3(1:i-1,i)
C
         IF ( I.GT.1 ) THEN
            CALL DTRMV( 'Upper', 'No transpose', 'Non-Unit', I-2,
     $                  RS(1,PR3+2), LDRS, T(1,PT32+I), 1 )
            T(I-1,PT32+I) = ZERO
            CALL DAXPY( I-1, CM1, RS(1,PR3+I), 1, T(1,PT32+I), 1 )
         END IF
C
         IF ( TAUI.EQ.ZERO ) THEN
            DO 50  J = 1, I
               T(J,PT13+I) = ZERO
   50       CONTINUE
            DO 60  J = 1, I
               T(J,PT23+I) = ZERO
   60       CONTINUE
            DO 70  J = 1, I
               T(J,PT33+I) = ZERO
   70       CONTINUE
            DO 80  J = 1, I
               RS(J,PS3+I) = ZERO
   80       CONTINUE
         ELSE
C
C           Treat second Householder reflection.
C
            IF ( LCOLV.AND.LCOLW ) THEN
C
C              Compute t1 = -tau(i) * W(i:n,1:i)' * V(i:n,i).
C
               CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1),
     $                     LDW, V(I,I), 1, ZERO, DWORK, 1 )
C
C              Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i).
C
               CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1),
     $                     LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 )
            ELSE IF ( LCOLV ) THEN
C
C              Compute t1 = -tau(i) * W(1:i,i:n) * V(i:n,i).
C
               CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I),
     $                     LDW, V(I,I), 1, ZERO, DWORK, 1 )
C
C              Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i).
C
               CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1),
     $                     LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 )
            ELSE IF ( LCOLW ) THEN
C
C              Compute t1 = -tau(i) * W(i:n,1:i)' * V(i,i:n)'.
C
               CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1),
     $                     LDW, V(I,I), LDV, ZERO, DWORK, 1 )
C
C              Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'.
C
               CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I),
     $                     LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 )
            ELSE
C
C              Compute t1 = -tau(i) * W(1:i,i:n) * V(i,i:n)'.
C
               CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I),
     $                     LDW, V(I,I), LDV, ZERO, DWORK, 1 )
C
C              Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'.
C
               CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I),
     $                     LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 )
            END IF
C
C           T13(1:i,i) := T11(1:i,1:i)*t1 - tau(i)*T12(1:i,i)
C                                         + [T13(1:i-1,1:i-1)*t2;0]
C
            CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT13+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT13+1), LDT, T(1,PT13+I), 1 )
            T(I,PT13+I) = ZERO
            CALL DCOPY( I, DWORK, 1, DWORK(K+1), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I,
     $                  T(1,PT11+1), LDT, DWORK(K+1), 1 )
            CALL DAXPY( I, ONE, DWORK(K+1), 1, T(1,PT13+I), 1 )
            CALL DAXPY( I, -TAUI, T(1,PT12+I), 1, T(1,PT13+I), 1 )
C
C           T23(1:i,i) := T21(1:i,1:i)*t1 - tau(i)*T22(1:i,i)
C                                         + [T23(1:i-1,1:i-1)*t2;0]
C
            CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT23+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT23+1), LDT, T(1,PT23+I), 1 )
            T(I,PT23+I) = ZERO
            CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT21+2), LDT, DWORK(K+1), 1 )
            CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT23+I), 1 )
            CALL DAXPY( I, -TAUI, T(1,PT22+I), 1, T(1,PT23+I), 1 )
C
C           T33(1:i,i) := T31(1:i,1:i)*t1 - tau(i)*T32(1:i,i)
C                                         + [T33(1:i-1,1:i-1)*t2;0]
C
            CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT33+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT33+1), LDT, T(1,PT33+I), 1 )
            CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  T(1,PT31+2), LDT, DWORK(K+1), 1 )
            CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT33+I), 1 )
            CALL DAXPY( I-1, -TAUI, T(1,PT32+I), 1, T(1,PT33+I), 1 )
            T(I,PT33+I) = -TAUI
C
C           S3(1:i,i) := S1(1:i,1:i)*t1 - tau(i)*S2(1:i,i)
C                                       + [S3(1:i-1,1:i-1)*t2;0]
C
            CALL DCOPY( I-1, DWORK(K2+1), 1, RS(1,PS3+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 )
            CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1,
     $                  RS(1,PS1+2), LDRS, DWORK(2), 1 )
            CALL DAXPY( I-1, ONE, DWORK(2), 1, RS(1,PS3+I), 1 )
            RS(I,PS3+I) = ZERO
            CALL DAXPY( I, -TAUI, RS(1,PS2+I), 1, RS(1,PS3+I), 1 )
         END IF
         W(I,I) = WII
         V(I,I) = VII
   90 CONTINUE
C
      RETURN
C *** Last line of MB04QF ***
      END


! Linear algebra subroutines
module linalg_mod

    use math_mod

    implicit none

contains

subroutine matinv(n, a, ai)
      ! This sobroutine inverts a matrix "a" and returns the inverse in "ai"
      ! n  - Input by user, an integer specifying the size of the matrix to be inverted.
      ! a  - Input by user, an n by n real array containing the matrix to be inverted.
      ! ai - Returned by subroutine, an n by n real array containing the inverted matrix.
      ! d  - Work array, an n by 2n real array used by the subroutine.
      ! io - Work array, a 1-dimensional integer array of length n used by the subroutine.
      ! THIS FUNCTION SHOULD NEVER BE callED! NEVER INVERT A MARTIX EXPLICITLY!
      ! Unless you know what you're doing. Odds are you may not, so be careful.

      implicit none

      integer :: n,i,j,k,m,itmp
      real :: a(n,n),ai(n,n),tmp,r
      real,allocatable,dimension(:,:) :: d
      integer,allocatable,dimension(:) :: io

      allocate(d(n,2*n))
      allocate(io(n))

      d(:,:) = 0.0
      io(:) = 0

!     Fill in the "io" and "d" matrix.
!     ********************************
      do i=1,n
         io(i)=i
      end do
      do i=1,n
         do j=1,n
            d(i,j)=a(i,j)
            if(i.eq.j)then
               d(i,n+j)=1.
            else
               d(i,n+j)=0.
            endif
         end do
      end do

!     Scaling
!     *******
      do i=1,n
         m=1
         do k=2,n
            if(abs(d(i,k)).gt.abs(d(i,m))) m=k
         end do
         tmp=d(i,m)
         do k=1,2*n
            d(i,k)=d(i,k)/tmp
         end do
      end do

!     Lower Elimination
!     *****************
      do i=1,n-1
!        Pivoting
!        ********
         m=i
         do j=i+1,n
            if(abs(d(io(j),i)).gt.abs(d(io(m),i))) m=j
         end do
         itmp=io(m)
         io(m)=io(i)
         io(i)=itmp
!        Scale the Pivot element to unity
!        ********************************
         r=d(io(i),i)
         do k=1,2*n
            d(io(i),k)=d(io(i),k)/r
         end do
!        ********************************
         do j=i+1,n
            r=d(io(j),i)
            do k=1,2*n
               d(io(j),k)=d(io(j),k)-r*d(io(i),k)
            end do
         end do
      end do

!     Upper Elimination
!     *****************
      r=d(io(n),n)
      do k=1,2*n
         d(io(n),k)=d(io(n),k)/r
      end do
      do i=n-1,1,-1
         do j=i+1,n
            r=d(io(i),j)
            do k=1,2*n
               d(io(i),k)=d(io(i),k)-r*d(io(j),k)
            end do
         end do
      end do

!     Fill Out "ai" matrix
      do i=1,n
         do j=1,n
            ai(i,j)=d(io(i),n+j)
         end do
      end do

      ! Cleanup
      deallocate(d)
      deallocate(io)

end subroutine matinv

function matmul_lu(n, A, x) result(b)
  ! Gives the matrix product [L][U]x = b where A = [L\U] (Doolittle LU decomposition)
  ! NOT TESTED

  implicit none

  integer,intent(in) :: n
  real,dimension(n,n),intent(in) :: A
  real,dimension(n),intent(in) :: x

  real,dimension(n) :: b, d
  integer :: i, j

  d = 0.

  ! [U]x = d
  do i=1,n
    do j=i,n
      d(i) = d(i) + A(i,j)*x(j)
    end do
  end do

  ! [L]x = b
  do i=1,n
    do j=1,i-1
      b(i) = b(i) + A(i,j)*d(j)
    end do
    b(i) = b(i) + d(i) ! L(i,i) = 1.
  end do

end function matmul_lu

subroutine lu_solve(n, A, b, x)
  ! Solves a general [A]x=b on an nxn matrix
  ! This replaces A (in place) with its LU decomposition (permuted row-wise)

    implicit none

    integer,intent(in) :: n
    real,dimension(n),intent(in) :: b
    real,dimension(:),allocatable,intent(out) :: x
    real,dimension(n,n),intent(inout) :: A

    integer,allocatable,dimension(:) :: indx
    integer :: D, info

    allocate(indx(n))

    ! Compute decomposition
    call lu_decomp(A, n, indx, D, info)

    ! if the matrix is nonsingular, then backsolve to find X
    if (info == 1) then
        write(*,*) 'Subroutine lu_solve() failed. The given matrix is singular (i.e. no unique solution). Quitting...'
        stop
    else
        call lu_back_sub(A, n, indx, b, x)
    end if

    ! Cleanup
    deallocate(indx)

end subroutine lu_solve

!*******************************************************
!*    LU decomposition routines used by test_lu.f90    *
!*                                                     *
!*                 F90 version by J-P Moreau, Paris    *
!*    improved for F95 by Cory Goates, Logan, UT, USA  *
!* --------------------------------------------------- *
!* Reference:                                          *
!*                                                     *
!* "Numerical Recipes By W.H. Press, B. P. Flannery,   *
!*  S.A. Teukolsky and W.T. Vetterling, Cambridge      *
!*  University Press, 1986" [BIBLI 08].                *
!*                                                     *
!*******************************************************

subroutine lu_decomp(A, N, indx, D, code)
  ! Given an N x N matrix A, this routine replaces it by the LU
  ! decomposition of a rowwise permutation of itself. A and N
  ! are input. indx is an output vector which records the row
  ! permutation effected by the partial pivoting; D is output
  ! as -1 or 1, depending on whether the number of row inter-
  ! changes was even or odd, respectively. This routine is used
  ! in combination with LUBKSB to solve linear equations or to
  ! invert a matrix. Return code is 1 if matrix is singular.

  implicit none

  real,dimension(N,N),intent(inout) :: A
  integer,intent(in) :: N
  integer,dimension(N),intent(out) :: indx
  integer,intent(out) :: code, D

  real,dimension(N) :: VV
  real,parameter :: tiny=1.5e-20
  integer :: i, j, k, imax
  real :: amax, dum, sum

  ! Initialize
  D = 1
  code = 0
  imax = 0

  ! Loop over rows to get implicit scaling information
  do i=1,N

    ! Get largest element in this row
    amax=0.0
    do j=1,N
      if (abs(A(i,j)) > amax) then
        amax = abs(A(i,j))
      end if
    end do

    ! Check the largest element in this row is nonzero
    if (amax <= tiny) then
      code = 1 ! Singular matrix
      return
    end if

    ! Store implicit scaling
    vv(i) = 1.0 / amax

  end do

  ! Loop over columns of Crout's method
  do j=1,N
    do i=1,J-1
      sum = A(i,j)
      do k=1,i-1
        sum = sum - A(i,k)*A(k,j)
      end do
      A(i,j) = sum
    end do

    ! Initialize search for largest pivot element
    amax = 0.0
    do i=j,N

      sum = A(i,j)
      do k=1,j-1
        sum = sum - A(i,k)*A(k,j)
      end do
      A(i,j) = sum

      ! Determine figure of merit for the pivot
      dum = vv(i)*abs(sum)
      if (dum >= amax) then
        imax = i
        amax = dum
      end if

    end do

    ! Figure out if we need to interchange rows
    if (j /= imax) then

      ! Perform interchange
      do k=1,N
        dum = A(imax,k)
        A(imax,k) = A(j,k)
        A(j,k) = dum
      end do

      ! Update the sign of D since a row interchange has occurred
      D = -D

      ! Interchange the implicit scaling factor
      vv(imax) = vv(j)

    end if

    ! Store pivoting
    indx(j) = imax

    ! Replace zero pivot element with small parameter
    if (abs(A(j,j)) < tiny) then
      A(j,j) = tiny
    end if

    ! Divide by pivot element
    if (j /= N) then
      dum = 1.0 / A(j,j)
      do i=j+1,N
        A(i,j) = A(i,j)*dum
      end do
    end if

  end do

end subroutine lu_decomp

subroutine lu_back_sub(A, N, indx, b, x)
  ! Solves the set of N linear equations Ax = b.  Here A is
  ! input, not as the matrix A but rather as its LU decomposition,
  ! determined by the routine LUDCMP. indx is input as the permuta-
  ! tion vector returned by LUDCMP. b is input as the right-hand
  ! side vector b. The solution vector is x. A, N, b and
  ! indx are not modified by this routine and can be used for suc-
  ! cessive calls with different right-hand sides. This routine is
  ! also efficient for plain matrix inversion.

  implicit none

  integer,intent(in) :: N
  real,dimension(N,N),intent(in) :: A
  real,dimension(N),intent(in) :: b
  integer,dimension(N),intent(in) :: indx
  real,dimension(:),allocatable,intent(out) :: x

  real :: sum
  integer :: ii,i,j,ll

  ! Initialize solution
  allocate(x, source=b)

  ! Set tracker to ignore leading zeros in b
  ii = 0

  ! Forward substitution
  do i=1,N

    ! Untangle pivoting
    ll = indx(i)
    sum = x(ll)
    x(ll) = x(i)

    ! If a nonzero element of b has already been encountered
    if (ii /= 0) then
      do J=ii,i-1
        sum = sum - A(i,J)*x(J)
      end do

    ! Check for first nonzero element of b
    else if(sum /= 0.0) then
      ii = i
    end if

    x(i) = sum

  end do

  ! Back substitution
  do i=N,1,-1
    sum = x(i)
    do j=i+1,N
      sum = sum - A(i,j)*x(j)
    end do
    x(i) = sum / A(i,i)
  end do

end subroutine lu_back_sub

subroutine snyder_lu_decomp(a,n)
  ! Computes the LU decomposition for a diagonally dominant matrix (no pivoting is done).
  !   Inputs:  n = number of equations/unknowns
  !            a = nxn coefficient matrix
  !   Outputs: a = nxn matrix containing the LU matrices
  !
  ! Deryl Snyder, 10-16-98
  implicit none
  integer :: n,i,j,k
  real a(n,n),z

  do k=1,n-1
    do i=k+1,n
      z=a(i,k)/a(k,k)                     !compute gauss factor
      a(i,k)=z                            !store gauss factor in matrix
      do j=k+1,n
        a(i,j)=a(i,j)-z*a(k,j)            !apply row operation
      end do
    end do
  end do
end subroutine snyder_lu_decomp

subroutine snyder_lu_solve(a,b,x,n)
  ! Solves for the unknowns (x) given the LU matrix and the right hand side.                                    C
  !   Inputs:  n = number of equations/unknowns
  !            a = nxn matrix containing the L and U values
  !            b = n vector containing right hand side values
  !   Outputs: x = n vector containing solution
  !
  ! Deryl Snyder, 10-16-98

  implicit none

  integer :: n,i,j,k
  real a(n,n),b(n),x(n)

  do i=1,n
     x(i)=b(i)
  end do

  ! Forward substitution
  do k=1,n-1
    do i=k+1,n
      x(i)=x(i)-a(i,k)*x(k)
    enddo
  enddo

  ! Back substitution
  do i=n,1,-1
    do j=i+1,n
      x(i)=x(i)-a(i,j)*x(j)
    end do
    x(i)=x(i)/a(i,i)
  end do

end subroutine snyder_lu_solve

subroutine quadratic_fit(pts, a, b, c)
  ! Fits a parabola through three specified
  ! points and returns the coefficients a, b, c defining this parabola
  ! according to the equation y = a * x**2 + b * x + c
  !            pts = list of three (x, y) points
  !   Outputs: a, b, c = quadratic coefficients

  implicit none

  real,dimension(3, 2),intent(in) :: pts
  real,intent(out) :: a, b, c

  integer :: i
  real,dimension(3,3) :: m
  real,dimension(:),allocatable :: coeff

  do i = 1, 3
    m(i, 1) = pts(i, 1)**2
    m(i, 2) = pts(i, 1)
    m(i, 3) = 1.0
  end do

  call lu_solve(3, m, pts(:,2), coeff)

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

end subroutine quadratic_fit

end module linalg_mod


c	Driver and Transfer Function / Power Spectrum subroutines
c	       for Eisenstein & Hu astro-ph/97XXXXX.
c		3/5/98: typo in lambda age fixed 3/5/98
c		9/1/98: typo in normalization of open gravity wave models fixed
c		9/22/98:bug in sigmavtop (affecting for massive neutrinos) fixed
c
c	  Here is a sample input file that may be cut out and used
c
cX------------------------------------------------------------------------------
c 		1.0, 0.0, 0.0, 0.05	Omega_0,Omega_L,Omega_nu,Omega_b
c 		0.5, 2.726, 1.		h,T_cmb,N_nu
c 		0			z
c 		30,30			kmax,numk
c  		1			iz
c 	        1.0			n
c 		0			ipower
cX------------------------------------------------------------------------------
c
c       DRIVER Program Power
c
c	  INPUT:
c
c	    omega   --	matter density in critical units (no lambda)
c	    omega_l --  cosmological constant in critical units
c	    omega_nu--  massive neutrino density in critical units
c	    omega_b --  baryon density in critical units
c	    h       --  Hubble constant in 100 km/s/Mpc
c	    T_cmb   --  CMB Temperature
c	    N_nu    --  number of degenerate massive neutrinos
c	    z	    --  redshift at which to evaluate transfer function
c	    kmax    --  maximum k (h Mpc^{-1}) for transfer function tabulation
c	    numk    --  number of k's per decade for evaluation
c
c
c	    tilt    --  n (Power spectrum tilt)
c	    ipower  --  if (n<1) and omega or omegal=0, option to
c			normalize (0) with power law inflationary
c			gravity waves (1) no gravity wavesr; else
c			no gravity waves
c	    iz      --  (0) evaluate quantities at default redshifts
c	                (1) evaluate quantities at specified redshift
c
c
c	  COMMON/GLOBALVARIABLES:  Variables in transfer function
c				   evaluation
c 	    (all real*8)
c
c       *   omhh         --  Omega*h*h
c	*   f_nu         --  Omega_nu/Omega
c	*   f_baryon     --  Omega_b/Omega
c	*   N_nu         --  number of degenerate massive neutrinos
c	    y_d          --  (1+z_eq)/(1+z_d)
c	    alpha_nu     --  small scale suppression
c	    beta_c       --  logarithmic correction
c	    sound_horizon--  sound horizon in Mpc
c	    theta_cmb    --  T_cmb/2.7K
c	*   omega        --  matter density in critical units
c	*   omegal       --  cosmological constant in critical units
c	    z_equality   --  redshift of matter-radiation equality
c
c	* = must be defined before call to TFset_parameters
c
c	COMMON/PASSSIGMA: variables needed for mass fluctuation
c	                  evalutation
c
c	    scale  -- filter scale in Mpc
c	    tilt   -- n, power spectrum tilt
c	    z      -- redshift of evaluation
c	    ipower -- switch (0) P_cbnu (1) P_cb
c
c	OUTPUT
c
c	    delta_H   -- COBE normalization for horizon-scale
c		         fluctuation amplitude
c	  Examples of Top-hat and Gaussian window mass fluctuations
c
c	    sigma_8   -- delta M/M on 8  h^-1 Mpc (using P_cbnu)
c	    sigma_50  -- delta M/M on 50 h^-1 Mpc (using P_cbnu)
c	    sigma_Lya -- delta M/M on 1/(24 sqrt(0mega*h*h)) Mpc scale
c			 (using P_cb) at z=3
c	    sigma_DLA -- delta M/M on 50km/s scale
c			 (using P_cbnu) at z=4
c	    omega_gas -- Upper limit on Omega_gas (z=4) via
c			 Press-Schechter with gaussian filter at
c			 50 km/s deltac=1.33
c
c	  Extra Freebies
c
c	    sigmav_40  -- velocity on 40 h^-1 Mpc tophat spheres
c			 (using P_cb)
c
c	    age        -- age in Gyr at z
c	    tau	       -- Thomson optical depth for full ionization to z
c	    growth     -- D1(z=0)/D1(z) growth from z to 0
c	    suppression-- alpha_nu*D_1**(-p_cb) suppression in CDM baryon transfer function
c			  as k->Infty at z
c
c      TRANSFER FUNCTION SUBROUTINES/FUNCTIONS
c
c	TF_setparameters [subroutine]
c
c	  Uses COMMON/GLOBALVARIABLES (above)
c	  Sets unstarred variables in GLOBALVARIABLES list above
c
c	TF_master(k) [real*8 function]
c
c	  Argument: k wavenumber in Mpc^{-1} (IMPORTANT: no h)
c	  Uses COMMON/GLOBALVARIABLES (above)
c
c	Growth [subroutine]
c
c	  Arguments:
c
c	      z       -- redshift to evaluate growth
c	      k       -- wavenumber in Mpc^{-1} (IMPORTANT: no h)
c	      DD_cb   -- on exit set to D_cb(z)/D_1(z=0)
c	      DD_cbnu -- on exit set to D_cbnu(z)/D_1(z=0)
c	      DD0     -- on exit set to D_1(z=0)
c
c	  Uses COMMON/GLOBALVARIABLES (above)
c
c	sound_horizon [real*8 function]: approximate sound horizon
c	  [a convenient approximation that does not require the
c	   parameter set up of TF_setparameters; unnecessary if
c	   TF_setparameters is called.
c
c	  Arguments:
c
c	      omhh     -- Omega*h*h
c	      f_baryon -- Omega_b/Omega
c
c       sigmatop [real*8 function]: evaluates integrand of sigma for
c 	  a top hat filter (unnormalized)
c
c	  Arguments:
c
c	      kl       -- ln(k Mpc^{-1})  [real*8]
c
c	  Uses COMMON/PASSSIGMA
c
c       sigmagaus [real*8 function]: evaluates integrand of sigma for
c 	  a gaussian filter (unnormalized)
c
c	  Uses COMMON/PASSSIGMA
c
c	sigmavtop [real*8 function]: evaluates integrand of sigmav for
c	  a top hat filter (unnormalized)
c
c	  Uses COMMON/PASSSIGMA
c	       COMMON/GLOBALVARIABLES
c
c	  Arguments:
c
c	      kl       -- ln(k Mpc^{-1})  [real*8]
c
c	  Uses COMMON/PASSSIGMA
c
c	rhombint [real*8 function]: Rhomberg integration
c				    (taken from CMBfast)
c
c	  Arguments:
c
c	      f       -- integrand externally defined
c	      a       -- lower limit of integration [real*8]
c	      b       -- upper limit of integration [real*8]
c	      tol     -- tolerance [real*8]
c
c	erfcc [real*8 function]: complementary error function
c				 (taken from Numerical Recipes)
c
c	  Arguments:
c
c	      x       -- real*8
c

       program TFmdm

	implicit real*8 (a-h,k,o-z)
	external rombint,sigmatop,sigmagaus,sigmavtop
	real*8 N_nu
        common/GLOBALVARIABLES/omhh,f_nu,f_baryon,N_nu,y_d,alpha_nu,
     *     beta_c,sound_horizon,theta_cmb,omega,omegal,z_equality
	common/PASSSIGMA/scale,tilt,z,ipower

c      Input Cosmological Parameters

	write(6,*) 'Cosmological Parameters:'

	write(6,*) 'Omega_0, Omega_Lambda, Omega_nu, Omega_b'
	read*, omega,omegal,omeganu,omegab

	write(6,*) 'h, T_cmb, N_nu'
	read*, h,T_cmb,N_nu

c	Translate Parameters into forms GLOBALVARIABLES form

	f_nu = omeganu/omega
	f_baryon = omegab/omega
	if (f_nu.eq.0) f_nu=1E-10
	if (f_baryon.eq.0) f_baryon=1E-10
	if (T_cmb.le.0) T_cmb=2.726
	if (N_nu.lt.0) N_nu=0.
	if (h.gt.10) write(6,*) 'WARNING: H_0/100km/s/Mpc needed'
	theta_cmb=T_cmb/2.7
	omhh = omega*h*h

 	write(6,*) '  '
	write(6,*) 'Confirming Cosmological Parameters'

	write(6,31) omega,omegal,f_nu,f_baryon
31	FORMAT('   Omega_0=',F5.3,'  Omega_Lambda=',F5.3,
     *	       '  f_nu=',F5.3,'  f_baryon=',F5.3)
	write(6,32) h*100,T_cmb,N_nu
32	FORMAT('   H_0    =',F5.1,'  T_cmb       =',F5.3,' N_nu=',F4.2)

        call TFset_parameters

c	sound_horizon=sound_horizon_fit(omhh,f_baryon)
c  what redshift?

	write(6,*) '  '
	write(6,*) 'Redshift for Transfer Function'
	read*, z

        open(10,file='trans.dat')

        write(6,*) 'k_max (h Mpc^{-1}),#pts per decade (10,50)'
        read*,kmax,numk

        if (kmax.le.0) kmax=10.
        if (numk.le.0) numk=50

        kmin = 0.0001
        numk = numk*log10(kmax/kmin)

	write(6,*) '  '
	write(6,42) z
42	FORMAT('Writing  [k(h Mpc^-1), T_master, T_cb, T_cbnu](z=',
     *      F5.2,')  to file: trans.dat...')
	write(6,*) '  '
        do i=1,numk

         k=10.**(i*(log10(kmax/kmin)/numk))*kmin
	 call Growth(z,k*h,DD_cb,DD_cbnu,DD0)
	 T_master = TF_master(k*h)

	 write(10,50) k,T_master,T_master*DD_cb,T_master*DD_cbnu

	end do

50	FORMAT(1X,20E13.5)

c	Power Spectrum Statistics

	write(6,*) 'Calculating power spectrum statistics...'

	write(6,27) z
27	FORMAT(' Use redshift z=',F5.2,
     c	       ' globally (0) no, use defaults (1) yes')
	read*, iz

	write(6,*) 'spectral index?'

	if (((1.-omegal-omega)*omegal).gt.1E-5) then

c	  COBE normalization for general lambda + open universe
c	  available only for tilt=1

	  tilt = 1.

	else

	  read*,tilt

	end if

	if (abs(1-omega-omegal).lt.1E-5) then

	 if (tilt.lt.1) then
	  write(6,*) '  Gravity Waves (power law inflation)?',
     c			' (0) yes   (1) no'
	  read*,ipower
	 else
	  ipower=1
	  write(6,*) ' '
	 end if

	write(6,*) '     ----------------------------------------------'
	 if (ipower.eq.0) then
            anorm = 1.94E-5*omega**(-0.785-0.05*log(omega))
     *			*exp(1.*(tilt-1.)+1.97*(tilt-1.)**2)
	    write(6,35) anorm,tilt
            anorm = anorm**2*(2997.9/h)**(3.+tilt)
35	  FORMAT('delta_H:   ',E12.5,'    n=',F5.3,
     *		 ' (B&W, flat, gravity waves)')
	 else
            anorm = 1.94E-5*omega**(-0.785-0.05*log(omega))
     *                  *exp(-0.95*(tilt-1.)-0.169*(tilt-1.)**2)
	    write(6,36) anorm,tilt
36	  FORMAT('delta_H:   ',E12.5,'    n=',F5.3,
     *           ' (B&W, flat, no gravity waves)')
            anorm = anorm**2*(2997.9/h)**(3.+tilt)
	 end if

	else

         if (omegal.eq.0) then

	 if (tilt.lt.1) then
	  write(6,*) '  Gravity Waves (power law inflation)?',
     *                 '(0) yes   (1) no'
	  read*,ipower
	 else
	  ipower=1
	  write(6,*) ' '
	 end if
	write(6,*) '     ----------------------------------------------'

	 if (ipower.eq.0) then
            anorm = 1.95E-5*omega**(-0.35-0.19*log(omega)+0.15*(tilt-1))
     *			*exp(1.02*(tilt-1.)+1.70*(tilt-1.)**2)
	    write(6,37) anorm,tilt
37	  FORMAT('delta_H:   ',E12.5,'    n=',F5.3,
     *			' (H&W, open, min. gravity waves)')
            anorm = anorm**2*(2997.9/h)**(3.+tilt)
	 else
            anorm = 1.95E-5*omega**(-0.35-0.19*log(omega)-0.17*(tilt-1))
     *			*exp(-1.*(tilt-1.)-0.14*(tilt-1.)**2)
	    write(6,38) anorm,tilt
38	  FORMAT('delta_H:   ',E12.5,'    n=',F5.3,
     *		' (B&W, open, no gravity waves)')
            anorm = anorm**2*(2997.9/h)**(3.+tilt)
	 end if

	else

	anorm = 2.422-1.166*exp(omega)+0.800*exp(omegal)+3.780*omega
     *		-2.267*omega*exp(omegal)+0.487*omega**2+0.561*omegal
     *		+3.392*omegal*exp(omega)-8.568*omega*omegal
     *		+1.080*omegal**2
	anorm = 1.E-5*anorm
	    write(6,39) anorm,tilt
39	  FORMAT('delta_H:   ',E12.5,'    n=',F5.3,
     *		' (B&W, open, lambda, no gravity waves)')
            anorm = anorm**2*(2997.9/h)**(3.+tilt)

	end if
	end if

	tol = 1.E-6

c	Sigma_8: Mass fluctuations in a top hat of 8./h Mpc at
c	         redshift z=0; total mass: CDM+baryon+neutrino

	scale = 8./h
	if (iz.eq.0) z=0
	ipower=0

	sigma_8=
     *	    sqrt(anorm*(
     *	    rombint(sigmatop,dlog(0.001/scale),dlog(0.1d0/scale),tol)+
     *	    rombint(sigmatop,dlog(0.1d0/scale),dlog(1d0/scale),tol)+
     *	    rombint(sigmatop,dlog(1d0/scale),dlog(10.d0/scale),tol)+
     *	    rombint(sigmatop,dlog(10.d0/scale),dlog(100.d0/scale),tol)))

	write(6,51) sigma_8,z
51	FORMAT('sigma_8:   ',E12.5,
     *      '                                  z=',F5.2)

c	Sigma_50: Mass fluctuations in a top hat of 50./h Mpc at
c	         redshift z=0; total mass: CDM+baryon+neutrino

	scale = 50./h
	if (iz.eq.0) z=0
	ipower=0

	sigma_50=
     *	    sqrt(anorm*(
     *	    rombint(sigmatop,dlog(0.001/scale),dlog(0.1d0/scale),tol)+
     *	    rombint(sigmatop,dlog(0.1d0/scale),dlog(1d0/scale),tol)+
     *	    rombint(sigmatop,dlog(1d0/scale),dlog(10.d0/scale),tol)+
     *	    rombint(sigmatop,dlog(10.d0/scale),dlog(100.d0/scale),tol)))

	write(6,52) sigma_50,sigma_50/sigma_8,z
52	FORMAT('sigma_50:  ',E12.5,'    sigma_50/sigma_8:',E12.5,
     *		' z=',F5.2)

c	Sigma_DLA:  Mass fluctuations in a gaussian of
c	            scale corresponding to 50km/s at
c	            redshift z=4; total mass: CDM+baryon+neutrino mass

c	circular velocity cutoff
	vcirc = 50.
	if (iz.eq.0) z=4
	scale = 0.3834*(vcirc)/(h*100.)*(omega*(1.+z)**(3.)
     *		+(1.-omega-omegal)*(1.+z)**2+omegal)**(-1./6.)
	ipower=0

     	sigmadla=sqrt(anorm*(
     *	rombint(sigmagaus,dlog(0.001/scale),dlog(0.1d0/scale),tol)+
     *	rombint(sigmagaus,dlog(0.1d0/scale),dlog(1d0/scale),tol)+
     *	rombint(sigmagaus,dlog(1d0/scale),dlog(10.d0/scale),tol)+
     *	rombint(sigmagaus,dlog(10.d0/scale),dlog(20.d0/scale),tol)))

	write(6,54) sigmadla,scale*h,z
54	FORMAT('sigma_DLA: ',E12.5,'    at',E12.5,
     *		' h^-1 Mpc,      z=',F5.2)

c	Upper limit on Omega_gas via Press-Schecter
c	Press-Schechter threshold

	deltac = 1.33
	omegagas = omega*f_baryon*erfcc(deltac/(sqrt(2.)*sigmadla))

	write(6,55) omegagas,deltac,z
55	FORMAT('Omega_gas:<',E12.5,'    at ',F5.3,
     *		' gaus. deltac,        z=',F5.2)

c	Sigma_Lya:  Mass fluctuations in a gaussian of
c	            1/(24.04 sqrt(0mega h**2)) Mpc at
c	            redshift z=3; CDM+baryon mass

	scale = 1./(24.04*sqrt(omhh))

	if (iz.eq.0) z=3
	ipower=1

        sigma_Lya=
     *	    sqrt(anorm*(
     *	    rombint(sigmagaus,dlog(0.001/scale),dlog(0.1d0/scale),tol)+
     *	    rombint(sigmagaus,dlog(0.1d0/scale),dlog(1d0/scale),tol)+
     *	    rombint(sigmagaus,dlog(1d0/scale),dlog(10.d0/scale),tol)+
     *	    rombint(sigmagaus,dlog(10.d0/scale),dlog(20.d0/scale),tol)))
	write(6,53) sigma_Lya,scale*h,z
53	FORMAT('sigma_Lya: ',E12.5,'    at',E12.5,
     *		' h^-1 Mpc,      z=',F5.2)

c	Sigmav_40:  Rms velocity in top hat of 100h^{-1} Mpc, z=0
c		     default; CDM+baryon

	scale = 40./h
	if (iz.eq.0) z=0
	ipower=1

        sigmav_40=
     *	    sqrt(anorm*(
     *	    rombint(sigmavtop,dlog(0.001/scale),dlog(0.1d0/scale),tol)+
     *	    rombint(sigmavtop,dlog(0.1d0/scale),dlog(1d0/scale),tol)+
     *	    rombint(sigmavtop,dlog(1d0/scale),dlog(10.d0/scale),tol)+
     *	    rombint(sigmavtop,dlog(10.d0/scale),dlog(100.d0/scale),tol)))
	write(6,60) sigmav_40,scale*h,z
60	FORMAT('sigma_v:    ',F6.2,' km/s    at ',F6.2,
     *		' h^-1 Mpc,           z=',F5.2)

	write(6,*) '     ----------------------------------------------'
	write(6,*) 'Extras:'
	write(6,*) '  '

	if (iz.eq.0) z = 0.

c	  yp = primordial Helium mass fraction
	  yp = 0.24
c	  xe = ionization fraction 1                 = fully ionized
c			           (1-yp)/(1-yp/2)   = HeI
c			           (1-3yp/4)/(1-yp/2)= HeII
	  xe = (1.-yp)/(1.-yp/2)
c	  neutral helium
	  tau= 4.61E-2*(1.-yp/2.)*xe*omegab*h/omega**2

	if (omegal.eq.0) then
	  omegae= omega-1.d-6
	  arg = 2.d0*(1.d0-omegae)/omegae/(1.+z) + 1.d0
     	  age = 9.7778/h*(
     *	        sqrt(1.+omegae*z)/(1.-omegae)/(1.+z) -
     *          omegae/2./(1.-omegae)**(1.5)*dlog(
     *			arg + dsqrt(arg**2 - 1.d0)))
	  write(6,56) z,age

	  tau= tau*(2.-3.*omega+sqrt(1.+omega*z)*(omega*z+3.*omega-2.))

	  if (z.gt.0) write(6,57) z,tau

	else

	if (abs(1.-omega-omegal).lt.1E-10) then
	  g = sqrt(omega*(1.+z)**3+1.-omega)
	  omegaz = omega*(1.+z)**3/g**2

	  age = 2./3.*9.7778/h/g/sqrt(1.-omegaz)
     *  	*log((1.+sqrt(1.-omegaz))/sqrt(omegaz))
	  write(6,56) z,age

	  tau= tau*omega*(sqrt(1.-omega+omega*(1.+z)**3) -1.)

	  if (z.gt.0) write(6,57) z,tau

	end if

	end if

56 	FORMAT('Age(z=',F5.2,'):    ',F6.2,' Gyrs')
57 	FORMAT('tau(z=',F5.2,'):    ',F9.5,' (HeI)')

	if (z.gt.0) write(6,58) z,1./DD0

58	FORMAT('Growth(z=',F5.2,'-0):',F5.2)

	write(6,59) sound_horizon*h
59	FORMAT('sound_horizon:  ',F7.2,' h^-1 Mpc')

	call Growth(z,1.d5,dum1,dum2,dum3)
	write(6,61) alpha_nu*dum1,z
61	FORMAT('suppression:    ',F7.5,' z=',F5.2)
	end

       subroutine TFset_parameters
	implicit real*8 (a-h,k,o-z)

	real*8 N_nu
        common/GLOBALVARIABLES/omhh,f_nu,f_baryon,N_nu,y_d,alpha_nu,
     *     beta_c,sound_horizon,theta_cmb,omega,omegal,z_equality

c Auxiliary variable

        obhh = omhh*f_baryon
c Main variables

        z_equality = 2.50e4*omhh*theta_cmb**(-4.) - 1.D0
        k_equality = 0.0746*omhh*theta_cmb**(-2.)

          z_drag = 0.313*omhh**(-0.419)*(1.+0.607*omhh**(0.674))
          z_drag = 1e0 + z_drag*obhh**(0.238*omhh**(0.223))
        z_drag = 1291e0 * omhh**(0.251)/
     &           (1e0 + 0.659*omhh**(0.828)) * z_drag

	y_d = (1.+z_equality)/(1.+z_drag)

        R_drag = 31.5*obhh*theta_cmb**(-4.)*1000e0/(1e0 + z_drag)
        R_equality = 31.5*obhh*theta_cmb**(-4.)
     &               *1000e0/(1e0 + z_equality)

        sound_horizon = 2./3./k_equality*sqrt(6./R_equality)*
     &      log(( sqrt(1.+R_drag)+sqrt(R_drag+R_equality) )
     &       /(1.+sqrt(R_equality)))

	 p_c  = -(5.-sqrt(1.+24*(1.-f_nu-f_baryon)))/4.
	 p_cb = -(5.-sqrt(1.+24*(1.-f_nu)))/4.
	 f_c  = 1.-f_nu-f_baryon
	 f_cb = 1.-f_nu
	 f_nub= f_nu+f_baryon

	 alpha_nu= (f_c/f_cb)* (2.*(p_c+p_cb)+5.)/(4.*p_cb+5)
	 alpha_nu= alpha_nu*(1.-0.553*f_nub+0.126*f_nub**3)
	 alpha_nu= alpha_nu/(1.-0.193*sqrt(f_nu)+0.169*f_nu)
	 alpha_nu= alpha_nu*(1.+y_d)**(p_c-p_cb)
	 alpha_nu= alpha_nu*(1.+ (p_cb-p_c)/2. *
     *			(1.+1./(4.*p_c+3.)/(4.*p_cb+7.))/(1.+y_d))
	 beta_c=1./(1.-0.949*f_nub)

	 return

	end

	real*8 function TF_master(k)

	implicit real*8 (a-h,k,o-z)
	real*8 N_nu
        common/GLOBALVARIABLES/omhh,f_nu,f_baryon,N_nu,y_d,alpha_nu,
     *     beta_c,sound_horizon,theta_cmb,omega,omegal,z_equality

	 q = k*theta_cmb**2/omhh
	 gamma_eff=(sqrt(alpha_nu) + (1.-sqrt(alpha_nu))/
     *		(1.+(0.43*k*sound_horizon)**4))

	 q_eff = q/gamma_eff
	 TF_master= dlog(dexp(1.d0)+1.84*beta_c*sqrt(alpha_nu)*q_eff)
	 TF_master = TF_master/(TF_master + q_eff**2*
     *	             (14.4 + 325./(1.+60.5*q_eff**1.11)))

	 q_nu = 3.92*q*sqrt(N_nu/f_nu)
	 TF_master = TF_master*
     *     (1.+(1.2*f_nu**(0.64)*N_nu**(0.3+0.6*f_nu))/
     *	   (q_nu**(-1.6)+q_nu**(0.8)))

	 return

	end

	subroutine Growth(z,k,DD_cb,DD_cbnu,DD0)

	implicit real*8 (a-h,k,o-z)
	real*8 N_nu

        common/GLOBALVARIABLES/omhh,f_nu,f_baryon,N_nu,y_d,alpha_nu,
     *     beta_c,sound_horizon,theta_cmb,omega,omegal,z_equality

	 q = k*theta_cmb**2/omhh

	 y_fs = 17.2*f_nu*(1.+0.488*f_nu**(-7./6.))*(N_nu*q/f_nu)**2

	 oz=omega*(1.+z)**3
     *     /(omegal+(1.-omegal-omega)*(1.+z)**2+omega*(1.+z)**3)
         olz=omegal
     *     /(omegal+(1.-omegal-omega)*(1.+z)**2+omega*(1.+z)**3)

	 D = (1.+z_equality)/(1.+z)*5.*oz/2.*(oz**(4./7.)-olz+(1.+oz/2.)*
     *		(1.+olz/70.))**(-1.)

	 DD0= D/((1.+z_equality)*5.*omega/2.*(omega**(4./7.)-omegal+
     *          (1.+omega/2.)*(1.+omegal/70.))**(-1.))

	 p_cb = -(5.-sqrt(1.+24*(1.-f_nu)))/4.

	 DD_cb = (1.+(D/(1.+y_fs))**(0.7))**(-p_cb/0.7)*D**(p_cb)

	 DD_cbnu = ((1.-f_nu)**(-0.7/p_cb)
     *		+(D/(1.+y_fs))**(0.7))**(-p_cb/0.7)*D**(p_cb)

	return
	end

        real*8 function sound_horizon_fit(omhh,f_baryon)
	implicit real*8 (a-h,k,o-z)

         obhh = f_baryon*omhh
         sound_horizon_fit = 44.5*log(9.83/omhh)
     &                      /sqrt(1.+10.0*obhh**(0.75))

        return
        end

	real*8 function sigmatop(kl)

	implicit real*8 (a-h,k,o-z)
	common/PASSSIGMA/scale,tilt,z,ipower

	 k = exp(kl)
	 x = scale*k

         call Growth(z,k,DD_cb,DD_cbnu,DD0)

	if (ipower.eq.0) then
         sigmatop = k**(3.+tilt)*(DD0*DD_cbnu*TF_master(k))**2
     *                *(3.*(x*dcos(x) - dsin(x))/x**3)**2
	else

         sigmatop = k**(3.+tilt)*(DD0*DD_cb*TF_master(k))**2
     *                *(3.*(x*dcos(x) - dsin(x))/x**3)**2
	end if

	return
	end

	real*8 function sigmagaus(kl)

	implicit real*8 (a-h,k,o-z)
	common/PASSSIGMA/scale,tilt,z,ipower

	 k = exp(kl)
	 x = scale*k

         call Growth(z,k,DD_cb,DD_cbnu,DD0)

	if (ipower.eq.0) then
         sigmagaus = k**(3.+tilt)*(DD0*DD_cbnu*TF_master(k))**2
     *                *exp(-x**2.)
	else
         sigmagaus = k**(3.+tilt)*(DD0*DD_cb*TF_master(k))**2
     *                *exp(-x**2.)
	end if

	return
	end

	real*8 function sigmavtop(kl)

	implicit real*8 (a-h,k,o-z)
	real*8 N_nu
        common/GLOBALVARIABLES/omhh,f_nu,f_baryon,N_nu,y_d,alpha_nu,
     *     beta_c,sound_horizon,theta_cmb,omega,omegal,z_equality
	common/PASSSIGMA/scale,tilt,z,ipower

	 k = exp(kl)
	 x = scale*k
	 q = k*theta_cmb**2/omhh

         call Growth(z,k,DD_cb,DD_cbnu,DD0)
	 h = sqrt(omhh/omega)
	 g = sqrt(omega*(1.+z)**3+(1.-omega-omegal)*(1.+z)**2+
     *		omegal)
	 omegaz = omega*(1.+z)**3/g**2
	 omegalz = omegal/g**2
	 p_cb = -(5.-sqrt(1.+24*(1.-f_nu)))/4.
	 y_fs = 17.2*f_nu*(1.+0.488*f_nu**(-7./6.))*(N_nu*q/f_nu)**2
	 D = (1.+z_equality)/(1.+z)*5.*omegaz/2.*(omegaz**(4./7.)
     *	        -omegalz+(1.+omegaz/2.)*
     *		(1.+omegalz/70.))**(-1.)

	 f = omegaz**(0.6) + 1./70.*omegalz *(1.+omegaz/2.)

	if (ipower.eq.0) then

	 f = f*(1.+p_cb/((1.-f_nu)**(-0.7/p_cb)+(D/(1.+y_fs))**0.7))
         sigmavtop = k**(3.+tilt)*(DD0*DD_cbnu*TF_master(k))**2
     *                *(3.*(x*dcos(x) - dsin(x))/x**3)**2
	else
	 f = f*(1.+p_cb/(1.+(D/(1.+y_fs))**0.7))
         sigmavtop = k**(3.+tilt)*(DD0*DD_cb*TF_master(k))**2
     *                *(3.*(x*dcos(x) - dsin(x))/x**3)**2
	end if

	 sigmavtop = (f*100.*h*g/(1.+z)/k)**2*sigmavtop

	return
	end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        real*8 function rombint(f,a,b,tol)
c  Rombint returns the integral from a to b of using Romberg integration.
c  The method converges provided that f(x) is continuous in (a,b).
c  f must be double precision and must be declared external in the calling
c  routine.  tol indicates the desired relative accuracy in the integral.
c
c Taken from CMBFAST; Seljak & Zaldarriaga (1996)

        parameter (MAXITER=30,MAXJ=5)
        implicit real*8 (a-h,o-z)
        dimension g(MAXJ+1)
        real*8 f
        external f
c
        h=0.5d0*(b-a)
        gmax=h*(f(a)+f(b))
        g(1)=gmax
        nint=1
        error=1.0d20
        i=0
10        i=i+1
          if (i.gt.MAXITER.or.(i.gt.5.and.abs(error).lt.tol))
     2      go to 40
c  Calculate next trapezoidal rule approximation to integral.
          g0=0.0d0
            do 20 k=1,nint
            g0=g0+f(a+(k+k-1)*h)
20        continue
          g0=0.5d0*g(1)+h*g0
          h=0.5d0*h
          nint=nint+nint
          jmax=min(i,MAXJ)
          fourj=1.0d0
            do 30 j=1,jmax
c  Use Richardson extrapolation.
            fourj=4.0d0*fourj
            g1=g0+(g0-g(j))/(fourj-1.0d0)
            g(j)=g0
            g0=g1
30        continue
          if (abs(g0).gt.tol) then
            error=1.0d0-gmax/g0
          else
            error=gmax
          end if
          gmax=g0
          g(jmax+1)=g0
        go to 10
40      rombint=g0
        if (i.gt.MAXITER.and.abs(error).gt.tol)
     2    write(*,*) 'Rombint failed to converge; integral, error=',
     3    rombint,error
        return
        end

      real*8 FUNCTION erfcc(x)
c calculates the complimentary error function
c Taken from Numerical Recipes.
      implicit real*8 (a-h,o-z)

      REAL*8 x
      REAL*8 t,z
      z=abs(x)
      t=1./(1.+0.5*z)
      erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t*
     *(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t*
     *(1.48851587+t*(-.82215223+t*.17087277)))))))))
      if (x.lt.0.) erfcc=2.-erfcc
      return
      END


  subroutine skosgdr (photonEG, e, a0, sigkosgdr)

! ======================================================================
!
!   Giant dipole resonance cross section.
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    class(PhotonEventGenerator), intent(inout) :: photonEG
    real(real64),   intent(in   ) :: e
    real(real64),   intent(in   ) :: a0
    real(real64),   intent(  out) :: sigkosgdr

    real(real64) :: aln, g1, g2, g4,g8, r1, r2, r4, r8, s2, t1, t2, &
         & t4, t8, temp, z

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

    z = log(e)
    aln = log(a0)
    temp = a0
    if (temp < divZerLim .and. temp > -divZerLim) then
       temp = divZerLim
       write(photonEG%io%message,1000) "112"
       call photonEG%io%print(4, 3, photonEG%io%message)
    end if
    s2 = one + (two/temp)**4
    r1 = (3.2d0 + 0.75d0*aln)/s2
    r2 = (four   + 0.125d0*aln)/s2
    r4 = 3.8d0  + 0.05d0*aln
    r8 = 3.65d0 - 0.05d0*aln
    t1 = (6.6d0 - 0.5d0*aln)/s2
    t2 = 3.4d0/s2
    t4 = 3.8d0  - 0.25d0*aln
    t8 = 3.5d0  - 0.16d0*aln

    temp = one + exp(thr*one*(t1 - z))
    g1 = exp(one*(r1 - z))/(temp)

    temp = one + exp(thr*two*(t2 - z))
    g2 = exp(two*(r2 - z))/(temp)

    temp = one + exp(thr*four*(t4 - z))
    g4 = exp(four*(r4 - z))/(temp)

    temp = one + exp(thr*two*four*(t8 - z))
    g8 = exp(two*four*(r8 - z))/(temp)

    sigkosgdr = g1 + g2 + g4 + g8
    return

! ======================================================================
1000 format("Divide by zero error prevented in ", &
          & "'photoEventGenerator.f90' line(s) ", A)
! ======================================================================
  end subroutine skosgdr


C     PROGRAM No. 10: LINEAR STRENGTH DOUBLET POTENTIAL
C     ------------------------------------------------
C     THIS PROGRAM FINDS THE PRESSURE DISTRIBUTION ON AN ARBITRARY AIRFOIL
C        BY REPRESENTING THE SURFACE AS A FINITE NUMBER OF DOUBLET PANELS WITH
C        LINEAR STRENGTH (DIRICHLET B.C., PROGRAM BY STEVEN YON, 1989).
      REAL EP(400,2),EPT(400,2),PT1(400,2),PT2(400,2)
      REAL CO(400,2),A(400,400),B(400,400),G(400)
      REAL TH(400),DL(400)

      OPEN(8,FILE='CPLD.DAT',STATUS='NEW')
      OPEN(9,FILE='AFOIL2.DAT',STATUS='OLD')
      WRITE(6,*) 'ENTER NUMBER OF PANELS'
      READ(5,*) M
      N=M+1
      WRITE(6,*) 'ENTER ANGLE OF ATTACK IN DEGREES'
      READ(5,*) ALPHA
      AL=ALPHA/57.2958

C     READ IN THE PANEL END POINTS
      DO I=1,M+1
         READ(9,*) EPT(I,1), EPT(I,2)
      END DO

C     CONVERT PANELING TO CLOCKWISE
      DO I=1,N
         EP(I,1)=EPT(N-I+1,1)
         EP(I,2)=EPT(N-I+1,2)
      END DO

C     ESTABLISH COORDINATES OF PANEL END POINTS
      DO I=1,M
         PT1(I,1)=EP(I,1)
         PT2(I,1)=EP(I+1,1)
         PT1(I,2)=EP(I,2)
         PT2(I,2)=EP(I+1,2)
      END DO

C     FIND PANEL ANGLES TH(J)
      DO I=1,M
         DZ=PT2(I,2)-PT1(I,2)
         DX=PT2(I,1)-PT1(I,1)
         TH(I)=ATAN2(DZ,DX)
      END DO

C     ESTABLISH COLLOCATION POINTS
      DO I=1,M
         CO(I,1)=(PT2(I,1)-PT1(I,1))/2+PT1(I,1)
         CO(I,2)=(PT2(I,2)-PT1(I,2))/2+PT1(I,2)
      END DO

C     ESTABLISH INFLUENCE COEFFICIENTS
      DO I=1,M
         DO J=1,M
C           CONVERT COLLOCATION POINT TO LOCAL PANEL COORDS.
            XT=CO(I,1)-PT1(J,1)
            ZT=CO(I,2)-PT1(J,2)
            X2T=PT2(J,1)-PT1(J,1)
            Z2T=PT2(J,2)-PT1(J,2)

            X=XT*COS(TH(J))+ZT*SIN(TH(J))
            Z=-XT*SIN(TH(J))+ZT*COS(TH(J))
            X2=X2T*COS(TH(J))+Z2T*SIN(TH(J))
            Z2=0

C           SAVE PANEL LENGTHS
            IF(I.EQ.1) THEN
               DL(J)=X2
            END IF

C           FIND TH1, TH2, AND R1,R2
            R1=SQRT(X**2+Z**2)
            R2=SQRT((X-X2)**2+Z**2)
            TH1=ATAN2(Z,X)
            TH2=ATAN2(Z,X-X2)

C           COMPUTE THE POTENTIAL COMPONENTS AS
C           FUNCTIONS OF R, TH
            IF(I.EQ.J) THEN
               PH1=-0.5*(X/X2-1)
               PH2=0.5*(X/X2)
            ELSE
               PH1=0.15916*(X/X2*(TH2-TH1)+Z/X2*
     *            LOG(R2/R1)-(TH2-TH1))
               PH2=-0.15916*(X/X2*(TH2-TH1)+Z/X2*LOG(R2/R1))
            END IF

C           COMPUTE THE COEFFICIENTS IN THE INFLUENCE MATRIX
            IF(J.EQ.1) THEN
               A(I,1)=PH1
               HOLDA=PH2
            ELSE IF(J.EQ.M) THEN
               A(I,M)=HOLDA+PH1
               A(I,M+1)=PH2
            ELSE
               A(I,J)=HOLDA+PH1
               HOLDA=PH2
            END IF
         END DO

C     ADD INFLUENCE OF WAKE AS A(M+2)
         XW=CO(I,1)-PT2(M,1)
         ZW=CO(I,2)-PT2(M,2)
         DTHW=-ATAN(ZW/XW)
         A(I,M+2)=-0.15916*DTHW

         A(I,M+3)=(CO(I,1)*COS(AL)+CO(I,2)*SIN(AL))
      END DO

C     ADD THE DOUBLET GRADIENT CONDITION
      A(M+1,1)=-1
      A(M+1,2)=1
      A(M+1,M)=1
      A(M+1,M+1)=-1

C     ADD THE KUTTA CONDITION
      A(M+2,1)=-1
      A(M+2,M+1)=1
      A(M+2,M+2)=-1
      N=M+3

C     SOLVE FOR THE SOLUTION VECTOR OF DOUBLET STRENGTHS
      CALL MATRX(A,N,G)

C     CONVERT DOUBLET STRENGTHS INTO TANGENTIAL
C     VELOCITIES ALONG THE AIRFOIL SURFACE AND
C     CP'S ON EACH OF THE PANELS.
 200  CONTINUE

      DO I=1,M-1
         R=(DL(I)+DL(I+1))/2
         T1=(G(I)+G(I+1))/2
         T2=(G(I+1)+G(I+2))/2
         VEL=(T2-T1)/R
         CP=1-VEL**2
         WRITE(8,*) PT2(I,1),' ,',CP
      END DO

      WRITE(6,*) ' '
      WRITE(6,*) 'LIFT COEFFICIENT=', G(M+2)

      STOP
      END


subroutine main(km, p, ps, Cpd, Rd, lapse, g, T, theta)

! Emanuel hard adjustment scheme with tunable lapse rate
! J. L. Mitchell  6June2005

implicit none

integer               :: km, nl, k
real                  :: ps, Cpd, Rd, lapse, g, kap
real, dimension(km)   :: p, p1, T, T1, theta, theta1
real, dimension(km+1) :: ph, ph1

! Convert T ->  theta
theta = T / (p/ps)**(Rd/Cpd)

! lapse rate in K/m
kap = Rd/(g/lapse)

! Set interface pressures
ph(1)=0.5*p(1)
do k=2,km
 ph(k)=0.5*( p(k-1)+p(k) )
enddo
ph(km+1)=ps

! Invert profiles, as required my Emanuel scheme
p1  = p(km:1:-1)
ph1 = ph(km+1:1:-1)
t1  = t(km:1:-1)
theta1  = theta(km:1:-1)

! Do adiabatic adjustment
! set max level to which convection can penetrate
nl = km - 1
call adjust(km,nl,Cpd,ps,ph1,p1,t1,theta1,kap)

! Invert profiles
t     = t1(km:1:-1)
theta = theta1(km:1:-1)

end subroutine main