!Code for generating initial field for homogeneous isotropic turbulence
!Adapted from M. Shoeybi's code

!compilation
!export PATH=/usr/bin:$PATH
!gfortran -I/usr/local/Cellar/fftw/3.3.7/include/ -o generate_init_hit generate_init_hit.f90 -L/usr/local/Cellar/fftw/3.3.7/lib -lfftw3

! gfortran -I/usr/include/ -o generate_init_hit generate_init_hit.f90 -lfftw3

!ifort -I$WORKDIR/SRC/fftw/include -o generate_init_hit generate_init_hit.f90 -L$WORKDIR/SRC/fftw/lib -lfftw3

module rand_tools_m

contains

  subroutine randset(idum)

    implicit none

    integer :: idum

    real(8) :: r(97)
    integer :: ix1,ix2,ix3
    common /random_common/ r,ix1,ix2,ix3

    real(8) :: rm1,rm2
    integer :: m1,m2,m3,ia1,ia2,ia3,ic1,ic2,ic3
    parameter(m1=259200,ia1=7141,ic1=54773,rm1=1.d0/m1)
    parameter(m2=134456,ia2=8121,ic2=28441,rm2=1.d0/m2)
    parameter(m3=243000,ia3=4561,ic3=51349)

    integer :: j

    ix1 = mod(ic1 - idum , m1)
    ix1 = mod(ia1 * ix1 + ic1 , m1)
    ix2 = mod(ix1 , m2)
    ix1 = mod(ia1 * ix1 + ic1 , m1)
    ix3 = mod(ix1 , m3)

    do j = 1, 97
       ix1 = mod(ia1 * ix1 + ic1 , m1)
       ix2 = mod(ia2 * ix2 + ic2 , m2)
       r(j) = (dble(ix1) + dble(ix2) * rm2) * rm1
       if (r(j).gt.1.d0) r(j)=1.d0
       if (r(j).lt.0.d0) r(j)=0.d0
    enddo

  end subroutine randset

  subroutine randvec(ran,N)

    implicit none

    integer :: N
    real(8) :: ran(N)
    real(8) :: r(97)
    integer :: ix1,ix2,ix3
    common /random_common/ r,ix1,ix2,ix3

    real(8) :: rm1,rm2
    integer :: m1,m2,m3,ia1,ia2,ia3,ic1,ic2,ic3
    parameter(m1=259200,ia1=7141,ic1=54773,rm1=1.d0/m1)
    parameter(m2=134456,ia2=8121,ic2=28441,rm2=1.d0/m2)
    parameter(m3=243000,ia3=4561,ic3=51349)

    integer :: nombre,j

    do nombre=1,N
       ix1 = mod(ia1 * ix1 + ic1 , m1)
       ix2 = mod(ia2 * ix2 + ic2 , m2)
       ix3 = mod(ia3 * ix3 + ic3 , m3)

       j = 1 + mod(((97 * ix3) / m3),97)
       ran(nombre) = r(j)
       r(j) = (dble(ix1) + dble(ix2) * rm2) * rm1
       if (r(j).gt.1.d0) r(j)=1.d0
       if (r(j).lt.0.d0) r(j)=0.d0
    enddo

  end subroutine randvec

end module rand_tools_m

program generate_init_hit

  use rand_tools_m

  implicit none

  !include fftw header file
  include "fftw3.f"

  integer, parameter :: N_box = 129

  real(8), parameter :: k0 = 6.0_8

  integer, parameter :: divergence_flag = 0
  !            0: use the noraml construction which gives
  !               the divergecne free for spectral codes
  !            1: use modified wave numbers

  !constants
  real(8) :: pi, twopi

  ! grid information
  real(8) :: my_node_cc_min(3), my_node_cc_max(3), node_cc_min(3), node_cc_max(3)
  real(8) :: my_box_volume, box_volume
  real(8) :: length(3), dx(3)
  integer  :: N_total, num_node

  ! initial condition in Fourier space
  real(8) :: u0
  real(8) :: kx, ky, kz, kxyz, kmax, tolerance, kmin, kxy, kmax_m
  integer :: kx_max_i, ky_max_i, kz_max_i

  ! energy parameters
  real(8) :: Eq_n
  complex(8) :: a_ran, b_ran
  complex, parameter :: ima = (0.0_8,1.0_8)

  ! random number
  real(8), allocatable :: phi1(:,:,:), phi2(:,:,:), phi3(:,:,:)
  real(8) :: max_phi12, max_phi13, max_phi23, min_dphi

  ! Fourier ans velocity vectors
  real(8), allocatable :: u(:,:,:), u3(:,:,:,:), u3_ext(:,:,:,:)
  complex(8), allocatable :: uk(:,:,:)!,uk_div(:,:,:,:)
  integer*8 :: fftw_plan

  ! debug stuff
  real(8) :: my_max_u, my_min_u, my_mean_u(3)
  real(8) :: max_u, min_u, mean_u(3), max_divergence
  real(8) :: u_left(1:3), u_right(1:3)
  real(8), allocatable :: div(:,:,:)

  ! loop parameters
  integer :: i, j, k, i_u, ino, ierr, n_phi

  ! dump out file
  character(len=64) :: filename
  !-------------------------------------

  write(*,*) '     Generate initial condition for HIT'

  pi = 4.0_8 * atan(1.0_8)
  twopi = 2.0_8 * pi

  if ( divergence_flag.eq.0 ) then
     write(*,*) '       using spectral divergence free field'
  elseif ( divergence_flag.eq.1 ) then
     write(*,*) '       using modified wave number to get finite differecne divergence free field'
  else
     write(*,*) 'Error in in calc_init_for_hom_iso_tur: undefined divergence_flag'
     stop
  endif

  ! total number of grid points
  N_total = N_box * N_box * N_box

  ! check even number of points has been passed
  num_node = N_box - 1
  if ( mod(num_node,2).ne.0 ) then
     write(*,*) 'Error in calc_init_for_hom_iso_tur, pass odd number of points '
     stop
  endif

  ! get the grid information
  ! box length
  length(1:3) = twopi

  ! grid spacing
  dx(1:3) = length(1:3) / dble(N_box-1)

  ! write some data on the screen
  write(*,*) '*****************************************************************************'
  write(*,*) '  grid information'
  write(*,*) '     total number of grid points(cart)               =  ', N_total
  write(*,*) '     number of grid points in each direction(cart)   =  ', N_box
  write(*,*) '     length in x, y and z direction (should be 2*pi) =  ', length(1:3)
  write(*,*) '     grid spacing in x, y and z(cart)                =  ', dx(1:3)
  write(*,*) '*****************************************************************************'

  ! spectrum paprameters
  tolerance = 0.0001_8
  kmax = dble(N_box-1) / 2.0_8 - tolerance
  kmin = tolerance
  kx_max_i = idint( dble(N_box-1) / 2.0_8 + 0.1_8 ) + 1
  ky_max_i = N_box-1
  kz_max_i = N_box-1

  ! spectrum information
  ! write on the screen
  write(*,*) '*****************************************************************************'
  write(*,*) 'spectrum properties'
  write(*,*) '   wave number corresponding to most energetic wave =  ', k0
  write(*,*) '*****************************************************************************'
  write(*,*) 'wave number information'
  write(*,*) '   maximun wave number(for homogeniety) =  ', kmax
  write(*,*) '   min wave number                      =  ', kmin
  write(*,*) '   max wave number in x direction       = ',kx_max_i
  write(*,*) '   max wave number in y direction       = ',ky_max_i
  write(*,*) '   max wave number in z direction       = ',kz_max_i
  write(*,*) '*****************************************************************************'

  ! random numbers
  ! allocate memory
  allocate( phi1(kx_max_i,ky_max_i,kz_max_i) )
  allocate( phi2(kx_max_i,ky_max_i,kz_max_i) )
  allocate( phi3(kx_max_i,ky_max_i,kz_max_i) )

  ! call random number generator
  call randset(1)
  call randvec(phi1,kx_max_i*ky_max_i*kz_max_i)
  call randvec(phi2,kx_max_i*ky_max_i*kz_max_i)
  call randvec(phi3,kx_max_i*ky_max_i*kz_max_i)

  ! check the random numbers
  max_phi12 = maxval( abs( phi1(1:kx_max_i,1:ky_max_i,1:kz_max_i) -&
       phi2(1:kx_max_i,1:ky_max_i,1:kz_max_i) ) )
  max_phi13 = maxval( abs( phi1(1:kx_max_i,1:ky_max_i,1:kz_max_i) -&
       phi3(1:kx_max_i,1:ky_max_i,1:kz_max_i) ) )
  max_phi23 = maxval( abs( phi3(1:kx_max_i,1:ky_max_i,1:kz_max_i) -&
       phi2(1:kx_max_i,1:ky_max_i,1:kz_max_i) ) )

  min_dphi = min(max_phi12,max_phi13)
  min_dphi = min(min_dphi,max_phi23)

  if ( min_dphi.le.tolerance ) then
     write(*,*) 'Error in calc_init_cond_for_hom_iso_tu: random numbers are the same'
     stop
  endif

  ! allocate memory
  allocate( uk(kx_max_i,ky_max_i,kz_max_i) )
  allocate( u(ky_max_i,ky_max_i,kz_max_i) )
  allocate( u3(3,ky_max_i,ky_max_i,kz_max_i) )
  ! allocate( uk_div(3,kx_max_i,ky_max_i,kz_max_i) )

  ! modify the random numbers to get them in the
  ! interval(-pi,pi)
  do k = 1,kz_max_i
     do j = 1,ky_max_i
        do i = 1,kx_max_i
           phi1(i,j,k) = twopi * (phi1(i,j,k)-0.5_8)
           phi2(i,j,k) = twopi * (phi2(i,j,k)-0.5_8)
           phi3(i,j,k) = twopi * (phi3(i,j,k)-0.5_8)
        enddo
     enddo
  enddo

  ! main loop for the fourier transforms
  do i_u = 1,3
     uk(1:kx_max_i,1:ky_max_i,1:kz_max_i) = ( 0.0_8, 0.0_8)
     u(1:ky_max_i,1:ky_max_i,1:kz_max_i) = 0.0_8
     do k = 1,kz_max_i
        do j = 1,ky_max_i
           do i = 1,kx_max_i

              ! modify the waves to get them symmetric
              kx = dble(i-1)
              ky = dble(j-1)
              if ( j.gt.kx_max_i ) ky = -dble(ky_max_i-j+1)
              kz = dble(k-1)
              if ( k.gt.kx_max_i ) kz = -dble(kz_max_i-k+1)

              kmax_m = dsqrt( kx**2 + ky**2 + kz**2 )

              kxyz = dsqrt( kx**2 + ky**2 + kz**2 )
              kxy = dsqrt( kx**2 + ky**2 )

              ! enegry spectrum
              Eq_n = (kxyz/k0)**4 * dexp( -2.0_8*(kxyz/k0)**2 )

              a_ran = (0.0_8,0.0_8)
              b_ran = (0.0_8,0.0_8)

              if ( kxyz.gt.kmin .and. kxyz.le.kmax_m ) then
                 a_ran = dsqrt( Eq_n/(twopi* kxyz**2) ) *&
                      cdexp(ima*phi1(i,j,k)) * dcos(phi3(i,j,k))
                 b_ran = dsqrt( Eq_n/(twopi* kxyz**2) ) *&
                      cdexp(ima*phi2(i,j,k)) * dsin(phi3(i,j,k))
              endif

              if ( divergence_flag.eq.1 ) then
                 ! replace with modefied wave number
                 kx = sin( kx*twopi/dble(ky_max_i) ) / (twopi/dble(ky_max_i))
                 ky = sin( ky*twopi/dble(ky_max_i) ) / (twopi/dble(ky_max_i))
                 kz = sin( kz*twopi/dble(ky_max_i) ) / (twopi/dble(ky_max_i))
              endif

              kxyz = dsqrt( kx**2 + ky**2 + kz**2 )
              kxy = dsqrt( kx**2 + ky**2 )

              ! fourier coefficients
              uk(i,j,k) = (0.0_8,0.0_8)
              if ( kxyz.gt.kmin ) then

                 if ( i_u.eq.1 ) then

                    if ( kxy.gt.kmin ) then
                       uk(i,j,k) = (a_ran*kxyz*ky+b_ran*kx*kz)/(kxyz*kxy)
                    else
                       !uk(i,j,k) = a_ran
                       uk(i,j,k) = ( a_ran + b_ran ) / dsqrt(2.0_8)
                    endif

                 elseif ( i_u.eq.2 ) then

                    if ( kxy.gt.kmin ) then
                       uk(i,j,k) = (b_ran*ky*kz-a_ran*kxyz*kx)/(kxyz*kxy)
                    else
                       !uk(i,j,k) = b_ran
                       uk(i,j,k) = ( b_ran - a_ran ) / dsqrt(2.0_8)
                    endif

                 elseif ( i_u.eq.3 ) then

                    !if ( kxy.gt.kmin ) then
                    uk(i,j,k) = -b_ran * kxy / kxyz
                    !else
                    !   uk(i,j,k) = (0.0_8,0.0_8)
                    !endif

                 endif

              endif

           enddo
        enddo
     enddo

     ! at plane kx=0, the waves need to be complex conjugate
     do k = 2,kz_max_i
        do j = kx_max_i+1,ky_max_i
           uk(1,j,k) = dconjg(uk(1,ky_max_i-j+2,kz_max_i-k+2))
        enddo
     enddo
     do k = kx_max_i+1,kz_max_i
        uk(1,1,k) = dconjg(uk(1,1,kz_max_i-k+2))
     enddo
     do j = kx_max_i+1,ky_max_i
        uk(1,j,1) = dconjg(uk(1,ky_max_i-j+2,1))
     enddo

     ! remove odd-ball wave numbers
     uk(kx_max_i,1:ky_max_i,1:kz_max_i) = (0.0_8,0.0_8)
     uk(1:kx_max_i,kx_max_i,1:kz_max_i) = (0.0_8,0.0_8)
     uk(1:kx_max_i,1:ky_max_i,kx_max_i) = (0.0_8,0.0_8)

     ! remove mean
     uk(1,1,1) = (0.0_8,0.0_8)

     !take the fourier transform
     call dfftw_plan_dft_c2r_3d(fftw_plan, N_box-1, N_box-1, N_box-1, uk, u, 64)
     call dfftw_execute(fftw_plan)
     call dfftw_destroy_plan(fftw_plan)

     u3(i_u,1:N_box-1,1:N_box-1,1:N_box-1) = u(1:N_box-1,1:N_box-1,1:N_box-1)

  enddo

  ! deallocate memory
  deallocate(phi1); deallocate(phi2); deallocate(phi3)
  deallocate(uk); deallocate(u);

  !add the periodic points to the grid

  allocate( u3_ext(3,ky_max_i+1,ky_max_i+1,kz_max_i+1) )
  u3_ext(1:3,1:ky_max_i,1:ky_max_i,1:kz_max_i) = u3(1:3,1:ky_max_i,1:ky_max_i,1:kz_max_i)
  !periodic boundaries
  u3_ext(1:3,ky_max_i+1,1:ky_max_i,1:kz_max_i) = u3(1:3,1,1:ky_max_i,1:kz_max_i)
  u3_ext(1:3,1:ky_max_i,ky_max_i+1,1:kz_max_i) = u3(1:3,1:ky_max_i,1,1:kz_max_i)
  u3_ext(1:3,1:ky_max_i,1:ky_max_i,kz_max_i+1) = u3(1:3,1:ky_max_i,1:ky_max_i,1)

  u3_ext(1:3,ky_max_i+1,ky_max_i+1,1:kz_max_i) = u3(1:3,1,1,1:kz_max_i)
  u3_ext(1:3,ky_max_i+1,1:ky_max_i,kz_max_i+1) = u3(1:3,1,1:ky_max_i,1)
  u3_ext(1:3,1:ky_max_i,ky_max_i+1,kz_max_i+1) = u3(1:3,1:ky_max_i,1,1)
  u3_ext(1:3,ky_max_i+1,ky_max_i+1,kz_max_i+1) = u3(1:3,1,1,1)

  deallocate(u3)

  ! calculate divergence
  allocate(div(ky_max_i,ky_max_i,kz_max_i))

  do k = 1, kz_max_i
     do j = 1, ky_max_i
        do i = 1, kx_max_i

           if (i==1) then
              u_left(1) = u3_ext(1,ky_max_i,j,k)
           else
              u_left(1) = u3_ext(1,i-1,j,k)
           end if
           u_right(1) = u3_ext(1,i+1,j,k)

           if (j==1) then
              u_left(2) = u3_ext(2,i,ky_max_i,k)
           else
              u_left(2) = u3_ext(2,i,j-1,k)
           end if
           u_right(2) = u3_ext(2,i,j+1,k)

           if (k==1) then
              u_left(3) = u3_ext(3,i,j,kz_max_i)
           else
              u_left(3) = u3_ext(3,i,j,k-1)
           end if
           u_right(3) = u3_ext(3,i,j,k+1)

           div(i,j,k) = (u_right(1)-u_left(1))/2.0d0/dx(1) + &
                        (u_right(2)-u_left(2))/2.0d0/dx(2) + &
                        (u_right(3)-u_left(3))/2.0d0/dx(3)

        end do
     end do
  end do

  max_divergence = maxval(div)

  !dump the statistics on the screen
  write(*,*) '*****************************************************************************'
  write(*,*) 'initial condition'
  write(*,*) '   maximum mach number             =  ', max_u
  write(*,*) '   minimum mach number             =  ', min_u
  write(*,*) '   mean velocity                   =  ', mean_u(1:3)/box_volume
  write(*,*) '   mean velocity2                  =  ', mean_u(1:3)
  write(*,*) '   maximum divergence of velocity  =  ', max_divergence
  write(*,*) '*****************************************************************************'

  !write the velocity field
  write(filename,'(a)') './init_field_hit.dat'
  open(10, file=filename, form='formatted', action='write')
  write(10,'(a)') 'VARIABLES = "X" "Y" "Z" "U" "V" "W"'
  write(10,'(a,i4.4,a,i4.4,a,i4.4)') "ZONE I=", ky_max_i+1, ", J=", ky_max_i+1, " K=", kz_max_i+1
  do k = 1, kz_max_i+1
     do j = 1, ky_max_i+1
        do i = 1, ky_max_i+1
           write(10,'(6e24.16)') dble(i-1)*dx(1), dble(j-1)*dx(2), dble(k-1)*dx(3), u3_ext(1:3,i,j,k)
        end do
     end do
  end do
  close(10)

  !deallocate memory
  deallocate(div)
  deallocate(u3_ext)

end program generate_init_hit


MODULE mdl_num

! ----------------------------------------------------------------------
! Purpose:
!  Module for setting adopted "Numerical Standards" as global variables
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia             July 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE
      SAVE

! ----------------------------------------------------------------------
! Constants declaration
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GM: Earth Gravity Constant (m^3/sec^2)
! ----------------------------------------------------------------------
! GM value provided by the latest Gravity Field Models
       REAL (KIND = prec_q), PARAMETER :: GM_gfm = 0.39860044150D+15
! GM value adopted by the IERS Conventions 2010
       REAL (KIND = prec_q), PARAMETER :: GM_iers = 0.39860044180D+15
! GM value to be used as global variable here
       REAL (KIND = prec_q), PARAMETER :: GM_global = GM_gfm
!       REAL (KIND = prec_q) :: GM_global
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GMsun: Sun Gravity Constant (m^3/sec^2)
      REAL (KIND = prec_q)  :: GMsun_glb
! GMmoon: Moon Gravity Constant (m^3/sec^2)
      REAL (KIND = prec_q) :: GMmoon_glb
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth Radius (meters):
! radius value provided by the latest Gravity Field Models
       REAL (KIND = prec_q), PARAMETER :: Earth_radius = 0.6378136460D+07
       REAL (KIND = prec_q), PARAMETER :: Sun_radius = 696.0d+06
       REAL (KIND = prec_q), PARAMETER :: Moon_radius = 1738.0d+03
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! PI
! ----------------------------------------------------------------------
      REAL (KIND=prec_q), PARAMETER :: PI_global = 4D0 * ATAN(1D0)
      !REAL (KIND=prec_q), PARAMETER :: PI_global = 4Q0 * ATAN(1Q0)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Speed of light (m/sec)
      REAL (KIND = prec_q), PARAMETER :: cslight = 299792458.0D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Relativity parameters: beta and gama
! PPN (parameterized post-Newtonian) parameters
! PPN equal to 1 in General Relativity
      REAL (KIND = prec_q), PARAMETER :: ppn_beta = 1.0D0
      REAL (KIND = prec_q), PARAMETER :: ppn_gama = 1.0D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Other constants
! ---------------------------------------------------------------------
      REAL (KIND = prec_q), PARAMETER :: S0 =  1367.0D0 !solar constant
      REAL (KIND = prec_q), PARAMETER :: AU =  149597870691.D0 !earth-sun dist
      REAL (KIND = prec_q), PARAMETER :: TOA = 6371000.D0 + 30000.D0 !Top of troposphere
      REAL (KIND = prec_q), PARAMETER :: ALB = 0.3 ! Earth albedo
      REAL (KIND = prec_q), PARAMETER :: Ps = S0/cslight !solar radiation pressure
END


      double complex function tloop(s23,mtsq)
      implicit none
      include 'scale.f'
      include 'qlfirst.f'
      double precision s23,mtsq
      double complex qlI3,Bdiff

      if (qlfirst) then
      call qlinit
      qlfirst=.false.
      endif

      tloop=-1d0-2d0*mtsq/s23*(
     & 3d0*s23*qlI3(0d0,0d0,s23,mtsq,mtsq,mtsq,musq,0)
     & +6d0*Bdiff(s23,0d0,mtsq)+12d0)
      return
      end


      PROGRAM xbalanc
C     driver for routine balanc
      INTEGER NP
      PARAMETER(NP=5)
      INTEGER i,j
      REAL a(NP,NP),r(NP),c(NP)
      DATA a/1.0,1.0,1.0,1.0,1.0,100.0,1.0,100.0,1.0,100.0,
     *     1.0,1.0,1.0,1.0,1.0,100.0,1.0,100.0,1.0,100.0,
     *     1.0,1.0,1.0,1.0,1.0/
C     print norms
      do 12 i=1,NP
        r(i)=0.0
        c(i)=0.0
        do 11 j=1,NP
          r(i)=r(i)+abs(a(i,j))
          c(i)=c(i)+abs(a(j,i))
11      continue
12    continue
      write(*,*) 'Rows:'
      write(*,*) (r(i),i=1,NP)
      write(*,*) 'Columns:'
      write(*,*) (c(i),i=1,NP)
      write(*,'(/1x,a/)') '***** Balancing Matrix *****'
      call balanc(a,NP,NP)
C     print norms
      do 14 i=1,NP
        r(i)=0.0
        c(i)=0.0
        do 13 j=1,NP
          r(i)=r(i)+abs(a(i,j))
          c(i)=c(i)+abs(a(j,i))
13      continue
14    continue
      write(*,*) 'Rows:'
      write(*,*) (r(i),i=1,NP)
      write(*,*) 'Columns:'
      write(*,*) (c(i),i=1,NP)
      END

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


program hip_dscal

  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer, parameter :: N = 10240;
  integer, parameter :: bytes_per_element = 8 !double precision
  integer(c_size_t), parameter :: Nbytes = N*bytes_per_element

  double precision, parameter :: alpha = 10.d0

  type(c_ptr) :: dx = c_null_ptr

  double precision,allocatable,target,dimension(:) :: hx
  double precision,allocatable,dimension(:) ::hx_scaled

  double precision :: error
  double precision, parameter :: error_max = 10*epsilon(error_max)

  type(c_ptr) :: hip_blas_handle = c_null_ptr

  integer :: i

  write(*,"(a)",advance="no") "-- Running test 'dscal' (Fortran 2003 interfaces) - "
  allocate(hx(N))
  allocate(hx_scaled(N))

  hx(:) = 10.d0

  hx_scaled = alpha*hx

  call hipblasCheck(hipblasCreate(hip_blas_handle))

  call hipCheck(hipMalloc(dx,Nbytes))

   ! Transfer data from host to device memory
  call hipCheck(hipMemcpy(dx, c_loc(hx(1)), Nbytes, hipMemcpyHostToDevice))

  call hipblasCheck(hipblasDscal(hip_blas_handle, N, alpha, dx, 1))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(c_loc(hx(1)), dx, Nbytes, hipMemcpyDeviceToHost))

  call hipCheck(hipFree(dx))

  ! Verification
  do i = 1,N
     error = abs(hx(i) - hx_scaled(i) )
     if( error .gt. error_max ) then
        write(*,*) "FAILED! Error bigger than max! Error = ", error, " hx(i) = ", hx(i)
        call exit
     endif
  end do

  call hipblasCheck(hipblasDestroy(hip_blas_handle))

  deallocate(hx_scaled)
  deallocate(hx)

  write(*,*) "PASSED!"

end program hip_dscal


module mod_baselib

    use mod_param

    implicit none

    !Declaring parameters:
    integer, parameter :: dp1 = kind(0.0d0)
    integer   :: taxfunc
    real(dp1) :: lambda_entre, tau_entre, lambda_work, tau_work, tau_s, uncmean_eps
    real(dp1) :: b_work, p_work, s_work, b_entre, p_entre, s_entre, taxrate_work, taxrate_entre

    contains

FUNCTION linint(x,y,xi)
! linear interpolation of function y on grid x at interpolation point xi
	IMPLICIT NONE
	REAL(dp1), DIMENSION(:), INTENT(IN) :: x,y
	REAL(dp1), INTENT(IN) :: xi
	REAL(dp1) :: linint
	REAL(dp1) :: a,b,d
	INTEGER :: n,i
	n=size(x)
	IF (size(y)/=n) THEN
		PRINT *, 'linint: x and y must be of the same size'
		STOP 'program terminated by linint'
	END IF
	i=max(min(locate(x,xi),n-1),1)
	d=x(i+1)-x(i)
	IF (d == 0.0) STOP 'bad x input in splint'
	a=(x(i+1)-xi)/d
	b=(xi-x(i))/d
	linint=a*y(i)+b*y(i+1)
END FUNCTION linint
!******************************************************************************!

SUBROUTINE linintv(x,y,xi,yi)
! linear interpolation of function y on grid x at interpolation vector xi
	IMPLICIT NONE
	REAL(dp1), DIMENSION(:), INTENT(IN)  :: x,y,xi
	REAL(dp1), DIMENSION(:), INTENT(OUT) :: yi
	REAL(dp1) :: a,b,d
	INTEGER :: m,n,i,j
	n=size(x)
	IF (size(y)/=n) THEN
		PRINT *, 'linintv: x and y must be of the same size'
		STOP 'program terminated by linintv'
	END IF
	m=size(xi)
	IF (size(yi)/=m) THEN
		PRINT *, 'linintv: xi and yi must be of the same size'
		STOP 'program terminated by linintv'
	END IF
	DO j=1,m
		i=max(min(locate(x,xi(j)),n-1),1)
		d=x(i+1)-x(i)
		IF (d == 0.0) THEN
			STOP 'bad x input in linintv'
		END IF
		a=(x(i+1)-xi(j))/d
		b=(xi(j)-x(i))/d
		yi(j)=a*y(i)+b*y(i+1)
	END DO
END SUBROUTINE linintv
!******************************************************************************!

PURE FUNCTION locate(xx,x)
	IMPLICIT NONE
	REAL(dp1), DIMENSION(:), INTENT(IN) :: xx
	REAL(dp1), INTENT(IN) :: x
	INTEGER :: locate
	INTEGER :: n,il,im,iu
	n=size(xx)
	il=0
	iu=n+1
	do
		if (iu-il <= 1) exit
		im=(iu+il)/2
		if (x >= xx(im)) then
			il=im
		else
			iu=im
		end if
	end do
	if (x == xx(1)) then
		locate=1
	else if (x == xx(n)) then
		locate=n-1
	else
		locate=il
	end if
END FUNCTION locate
!******************************************************************************!

    !******************************************************************************!
    pure function interp1(x,y,xi) result(yi)
        ! original code by  John Burkardt
        real(dp1), intent(in), dimension(:) :: x, y, xi
        real(dp1), dimension(:), allocatable :: yi
        integer :: j, nx, l, r

        nx = size(xi)
        allocate(yi(nx))
        doj:do j = 1,nx
           call bracket (x, xi(j), l, r)
           yi(j)= y(l)+(y(r)-y(l))*(xi(j)-x(l))/(x(r)-x(l))
        end do doj
    end function interp1

    !******************************************************************************!
    pure function interp1h(x,y,xi) result(yi)
        ! original code by  John Burkardt
        real(dp1), intent(in), dimension(:) :: x, y
        real(dp1), intent(in) :: xi  ! it is a scalar!!
        real(dp1) :: yi
        integer :: j, nx, l, r

        call bracket (x, xi, l, r)
        yi = y(l)+(y(r)-y(l))*(xi-x(l))/(x(r)-x(l))

    end function interp1h

    !******************************************************************************!
    pure subroutine bracket(x, xval, l, r)
        ! original code by  John Burkardt
        real(dp1), intent(in), dimension(:) :: x
        real(dp1), intent(in) :: xval
        integer, intent(out) :: l, r
        integer :: i, n

        n=size(x)
        do i = 2, n - 1
           if ( xval < x(i) ) then
              l = i - 1
              r = i
              return
           end if
        end do
        l = n - 1
        r = n
    end subroutine bracket

    !******************************************************************************!
    pure function utilfun(c,l) result(F)
        ! NOTE: maybe write also a separate utilfun for entre
        implicit none

        !Declare inputs:
        real(dp1), intent(in) :: c, l ! consumption and labor
        !Declare outputs:
        real(dp1) :: F

        F = c**(1.0d0-sigma)/(1.0d0-sigma) - psi*l**(1.0d0+sigma2)/(1.0d0+sigma2)

    end function utilfun

    !******************************************************************************!
    pure function prodfun(k,le,n) result(F)
        ! NOTE: prodfun is defined without theta shock
        implicit none

        !Declare inputs:
        real(dp1), intent(in) :: k, le, n ! capital, labor supply, labor hirings
        !Declare outputs:
        real(dp1) :: F

        F = (k**gamma*(le+n)**(1-gamma))**vi

    end function prodfun
    !******************************************************************************!

    pure function cost_evasion(phi) result(F)
        ! NOTE: prodfun is defined without theta shock
        implicit none

        !Declare inputs:
        real(dp1), intent(in) :: phi ! capital, labor supply, labor hirings
        !Declare outputs:
        real(dp1) :: F

        if (phi>0d0) then
            F = cc0+cc1*phi+cc2*phi**2
        else
            F = 0d0
        endif

    end function cost_evasion

    !******************************************************************************!
    pure function prob_audit(phi,profit,theta,k,n,le,flag) result(pk)
        ! INPUTS
        ! phi: fraction of misreported business income
        ! profit: business income
        implicit none

        !Declare inputs:
        real(dp1), intent(in) :: phi, profit, theta, k, n, le
        integer, intent(in) :: flag
        !Declare outputs:
        real(dp1) :: pk
        ! Declare locals:
        real(dp1) :: temp !

        SELECT CASE (flag)

        CASE (1) !misreported income
            temp = phi*profit

        CASE (2) !f(theta,k,n)
            temp = theta*prodfun(k,le,n)

        CASE (3) !f(k,n)
            temp = prodfun(k,le,n)

        CASE (4) !k
            temp = k

        CASE (5) !n hired labor
            temp = n

        END SELECT

        pk   = pn_3 + (1.0d0-pn_3)/(1.0d0 + pn_1*exp(-pn_2*temp ))

    end function prob_audit

    !******************************************************************************!

    pure function tax_entre(income)
        implicit none

        !Declare inputs:
        real(dp1), intent(in) :: income ! income in levels !!!!!!
        !Declare outputs:
        real(dp1) :: tax_entre ! total taxes paid
        ! Declare locals:
        real(dp1) :: y ! normalized income !!!!!!

        SELECT CASE (taxfunc)

        CASE (1) ! HSV
            ! Impose normalization
            y = income /(w0*uncmean_eps)
            tax_entre = y - lambda_entre*y**(1.0d0-tau_entre) + tau_s

        CASE (2) ! GS
            tax_entre = income*(b_entre - b_entre*(s_entre*income**p_entre + 1)**(-1.0d0/p_entre)) + tau_s

        CASE (3) ! flat
            tax_entre = taxrate_entre*income + tau_s

        END SELECT

        return
    end function tax_entre
    !******************************************************************************!
    pure function tax_work(income)
        implicit none

        !Declare inputs:
        real(dp1), intent(in) :: income ! income in levels
        !Declare outputs:
        real(dp1) :: tax_work ! total taxes paid
        ! Declare locals:
        real(dp1) :: y

        SELECT CASE (taxfunc)

        CASE (1) ! HSV
            ! Impose normalization
            y = income /(w0*uncmean_eps)
            tax_work = y - lambda_work*y**(1.0d0-tau_work) + tau_s

        CASE (2) ! GS
            tax_work = income*(b_work - b_work*(s_work*income**p_work + 1)**(-1.0d0/p_work)) + tau_s

        CASE (3) ! flat
            tax_work = taxrate_work*income + tau_s

        END SELECT

        return
    end function tax_work
!******************************************************************************!

end module mod_baselib


      SUBROUTINE ZGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(*),INFO
      COMPLEX*16 A(LDA,*)
C
C     ZGEFA FACTORS A COMPLEX*16 MATRIX BY GAUSSIAN ELIMINATION.
C
C     ZGEFA IS USUALLY CALLED BY ZGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR ZGECO) = (1 + 9/N)*(TIME FOR ZGEFA) .
C
C     ON ENTRY
C
C        A       COMPLEX*16(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT ZGESL OR ZGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN ZGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS ZAXPY,ZSCAL,IZAMAX
C     FORTRAN DABS
C
C     INTERNAL VARIABLES
C
      COMPLEX*16 T
      INTEGER IZAMAX,J,K,KP1,L,NM1
C
      COMPLEX*16 ZDUM
      DOUBLE PRECISION CABS1
      DOUBLE PRECISION DREAL,DIMAG
      COMPLEX*16 ZDUMR,ZDUMI
      DREAL(ZDUMR) = ZDUMR
      DIMAG(ZDUMI) = (0.0D0,-1.0D0)*ZDUMI
      CABS1(ZDUM) = DABS(DREAL(ZDUM)) + DABS(DIMAG(ZDUM))
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IZAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (CABS1(A(L,K)) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -(1.0D0,0.0D0)/A(K,K)
            CALL ZSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL ZAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (CABS1(A(N,N)) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE ZPOFA(A,LDA,N,INFO)
      INTEGER LDA,N,INFO
      COMPLEX*16 A(LDA,*)
C
C     ZPOFA FACTORS A COMPLEX*16 HERMITIAN POSITIVE DEFINITE MATRIX.
C
C     ZPOFA IS USUALLY CALLED BY ZPOCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR ZPOCO) = (1 + 18/N)*(TIME FOR ZPOFA) .
C
C     ON ENTRY
C
C        A       COMPLEX*16(LDA, N)
C                THE HERMITIAN MATRIX TO BE FACTORED.  ONLY THE
C                DIAGONAL AND UPPER TRIANGLE ARE USED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX  R  SO THAT  A =
C                CTRANS(R)*R WHERE  CTRANS(R)  IS THE CONJUGATE
C                TRANSPOSE.  THE STRICT LOWER TRIANGLE IS UNALTERED.
C                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C
C        INFO    INTEGER
C                = 0  FOR NORMAL RETURN.
C                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
C                     OF ORDER  K  IS NOT POSITIVE DEFINITE.
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS ZDOTC
C     FORTRAN DCMPLX,DCONJG,DSQRT
C
C     INTERNAL VARIABLES
C
      COMPLEX*16 ZDOTC,T
      DOUBLE PRECISION S
      INTEGER J,JM1,K
      DOUBLE PRECISION DREAL,DIMAG
      COMPLEX*16 ZDUMR,ZDUMI
      DREAL(ZDUMR) = ZDUMR
      DIMAG(ZDUMI) = (0.0D0,-1.0D0)*ZDUMI
C     BEGIN BLOCK WITH ...EXITS TO 40
C
C
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - ZDOTC(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + DREAL(T*DCONJG(T))
   10       CONTINUE
   20       CONTINUE
            S = DREAL(A(J,J)) - S
C     ......EXIT
            IF (S .LE. 0.0D0 .OR. DIMAG(A(J,J)) .NE. 0.0D0) GO TO 40
            A(J,J) = DCMPLX(DSQRT(S),0.0D0)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
      SUBROUTINE ZGTSL(N,C,D,E,B,INFO)
      INTEGER N,INFO
      COMPLEX*16 C(*),D(*),E(*),B(*)
C
C     ZGTSL GIVEN A GENERAL TRIDIAGONAL MATRIX AND A RIGHT HAND
C     SIDE WILL FIND THE SOLUTION.
C
C     ON ENTRY
C
C        N       INTEGER
C                IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C        C       COMPLEX*16(N)
C                IS THE SUBDIAGONAL OF THE TRIDIAGONAL MATRIX.
C                C(2) THROUGH C(N) SHOULD CONTAIN THE SUBDIAGONAL.
C                ON OUTPUT C IS DESTROYED.
C
C        D       COMPLEX*16(N)
C                IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C                ON OUTPUT D IS DESTROYED.
C
C        E       COMPLEX*16(N)
C                IS THE SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX.
C                E(1) THROUGH E(N-1) SHOULD CONTAIN THE SUPERDIAGONAL.
C                ON OUTPUT E IS DESTROYED.
C
C        B       COMPLEX*16(N)
C                IS THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B       IS THE SOLUTION VECTOR.
C
C        INFO    INTEGER
C                = 0 NORMAL VALUE.
C                = K IF THE K-TH ELEMENT OF THE DIAGONAL BECOMES
C                    EXACTLY ZERO.  THE SUBROUTINE RETURNS WHEN
C                    THIS IS DETECTED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C     NO EXTERNALS
C     FORTRAN DABS
C
C     INTERNAL VARIABLES
C
      INTEGER K,KB,KP1,NM1,NM2
      COMPLEX*16 T
      COMPLEX*16 ZDUM
      DOUBLE PRECISION CABS1
      DOUBLE PRECISION DREAL,DIMAG
      COMPLEX*16 ZDUMR,ZDUMI
      DREAL(ZDUMR) = ZDUMR
      DIMAG(ZDUMI) = (0.0D0,-1.0D0)*ZDUMI
      CABS1(ZDUM) = DABS(DREAL(ZDUM)) + DABS(DIMAG(ZDUM))
C     BEGIN BLOCK PERMITTING ...EXITS TO 100
C
         INFO = 0
         C(1) = D(1)
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 40
            D(1) = E(1)
            E(1) = (0.0D0,0.0D0)
            E(N) = (0.0D0,0.0D0)
C
            DO 30 K = 1, NM1
               KP1 = K + 1
C
C              FIND THE LARGEST OF THE TWO ROWS
C
               IF (CABS1(C(KP1)) .LT. CABS1(C(K))) GO TO 10
C
C                 INTERCHANGE ROW
C
                  T = C(KP1)
                  C(KP1) = C(K)
                  C(K) = T
                  T = D(KP1)
                  D(KP1) = D(K)
                  D(K) = T
                  T = E(KP1)
                  E(KP1) = E(K)
                  E(K) = T
                  T = B(KP1)
                  B(KP1) = B(K)
                  B(K) = T
   10          CONTINUE
C
C              ZERO ELEMENTS
C
               IF (CABS1(C(K)) .NE. 0.0D0) GO TO 20
                  INFO = K
C     ............EXIT
                  GO TO 100
   20          CONTINUE
               T = -C(KP1)/C(K)
               C(KP1) = D(KP1) + T*D(K)
               D(KP1) = E(KP1) + T*E(K)
               E(KP1) = (0.0D0,0.0D0)
               B(KP1) = B(KP1) + T*B(K)
   30       CONTINUE
   40    CONTINUE
         IF (CABS1(C(N)) .NE. 0.0D0) GO TO 50
            INFO = N
         GO TO 90
   50    CONTINUE
C
C           BACK SOLVE
C
            NM2 = N - 2
            B(N) = B(N)/C(N)
            IF (N .EQ. 1) GO TO 80
               B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
               IF (NM2 .LT. 1) GO TO 70
               DO 60 KB = 1, NM2
                  K = NM2 - KB + 1
                  B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
   60          CONTINUE
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE ZPTSL(N,D,E,B)
      INTEGER N
      COMPLEX*16 D(*),E(*),B(*)
C
C     ZPTSL GIVEN A POSITIVE DEFINITE TRIDIAGONAL MATRIX AND A RIGHT
C     HAND SIDE WILL FIND THE SOLUTION.
C
C     ON ENTRY
C
C        N        INTEGER
C                 IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C        D        COMPLEX*16(N)
C                 IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C                 ON OUTPUT D IS DESTROYED.
C
C        E        COMPLEX*16(N)
C                 IS THE OFFDIAGONAL OF THE TRIDIAGONAL MATRIX.
C                 E(1) THROUGH E(N-1) SHOULD CONTAIN THE
C                 OFFDIAGONAL.
C
C        B        COMPLEX*16(N)
C                 IS THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B        CONTAINS THE SOULTION.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C     NO EXTERNALS
C     FORTRAN DCONJG,MOD
C
C     INTERNAL VARIABLES
C
      INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2
      COMPLEX*16 T1,T2
C
C     CHECK FOR 1 X 1 CASE
C
      IF (N .NE. 1) GO TO 10
         B(1) = B(1)/D(1)
      GO TO 70
   10 CONTINUE
         NM1 = N - 1
         NM1D2 = NM1/2
         IF (N .EQ. 2) GO TO 30
            KBM1 = N - 1
C
C           ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF
C           SUPERDIAGONAL
C
            DO 20 K = 1, NM1D2
               T1 = DCONJG(E(K))/D(K)
               D(K+1) = D(K+1) - T1*E(K)
               B(K+1) = B(K+1) - T1*B(K)
               T2 = E(KBM1)/D(KBM1+1)
               D(KBM1) = D(KBM1) - T2*DCONJG(E(KBM1))
               B(KBM1) = B(KBM1) - T2*B(KBM1+1)
               KBM1 = KBM1 - 1
   20       CONTINUE
   30    CONTINUE
         KP1 = NM1D2 + 1
C
C        CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER
C
         IF (MOD(N,2) .NE. 0) GO TO 40
            T1 = DCONJG(E(KP1))/D(KP1)
            D(KP1+1) = D(KP1+1) - T1*E(KP1)
            B(KP1+1) = B(KP1+1) - T1*B(KP1)
            KP1 = KP1 + 1
   40    CONTINUE
C
C        BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP
C        AND BOTTOM
C
         B(KP1) = B(KP1)/D(KP1)
         IF (N .EQ. 2) GO TO 60
            K = KP1 - 1
            KE = KP1 + NM1D2 - 1
            DO 50 KF = KP1, KE
               B(K) = (B(K) - E(K)*B(K+1))/D(K)
               B(KF+1) = (B(KF+1) - DCONJG(E(KF))*B(KF))/D(KF+1)
               K = K - 1
   50       CONTINUE
   60    CONTINUE
         IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1)
   70 CONTINUE
      RETURN
      END


program add_reals
! add numbers entered on command line
implicit none
character (len=100) :: text, arg
integer             :: i,narg
real                :: x,xsum
logical, parameter  :: echo_input = .true.
if (echo_input) then
   call get_command(text)
   print "(a)","command is '" // trim(text) // "'"
end if
narg = command_argument_count() ! # of command line arguments
xsum = 0.0
do i=1,narg ! loop over command line arguments
   call get_command_argument(i,arg) ! arg is i'th argument
   read (arg,*) x ! convert character arg to real
   xsum = xsum + x
end do
print "('sum of ',i0,' numbers = ',f0.4)", narg,xsum
end program add_reals
! sample run:
! command is 'a.exe 4.0 5.0 6.0'
! sum of 3 numbers = 15.0000


MODULE procs
CONTAINS
  SUBROUTINE extremes(a, n, maxval, pos_maxval, minval, pos_minval)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: n
  REAL, INTENT(IN), DIMENSION(n) :: a
  REAL, INTENT(OUT), OPTIONAL :: maxval
  INTEGER, INTENT(OUT), OPTIONAL :: pos_maxval
  REAL, INTENT(OUT), OPTIONAL :: minval
  INTEGER, INTENT(OUT), OPTIONAL :: pos_minval
  INTEGER :: i
  REAL :: real_max
  INTEGER :: pos_max
  REAL :: real_min
  INTEGER :: pos_min

  real_max = a(1)
  pos_max = 1
  real_min = a(1)
  pos_min = 1
  DO i = 2, n
    IF (a(i) > real_max) THEN
      real_max = a(i)
      pos_max = i
    ELSE IF (a(i) < real_min) THEN
      real_min = a(i)
      pos_min = i
    END IF
  END DO

  IF (PRESENT(maxval)) THEN
    maxval = real_max
  END IF
  IF (PRESENT(pos_maxval)) THEN
    pos_maxval = pos_max
  END IF
  IF (PRESENT(minval)) THEN
    minval =  real_min
  END IF
  IF (PRESENT(pos_minval)) THEN
    pos_minval = pos_min
  END IF

  END SUBROUTINE extremes
END MODULE procs

PROGRAM test_extremes
USE procs
IMPLICIT NONE
REAL, DIMENSION(5) :: arr
REAL :: arr_max, arr_min
INTEGER :: maxp, minp
arr = [3.,-0.1,17.5,0.,-4.5]
CALL extremes(arr, SIZE(arr), pos_maxval=maxp, minval=arr_min, maxval=arr_max, &
              pos_minval=minp)
WRITE(*, *) maxp, arr_max, minp, arr_min
END PROGRAM test_extremes


     program demo_M_calcomp
     use M_calcomp
     ! 07/30/69
     real              :: x(104), y(104)
     character(len=40) :: msg
     integer,parameter :: kin = 50
     equivalence(x(1),xl),(y(1),yl)
     9007 format(7(1X,F9.3),F7.1)
        call make_c_qa4()   ! create datafile
        f = 1.0
        ipn = 2
        call plots(0.0,10.0,0.0,10.0)
     !-----------------------------------------------------------------------
        open(unit=kin,file='qa4.dat',action="read")
        NEXTREAD: do
           read(kin,9001) nrec, msg
           9001 format(1X,I2,7X,A40)
           write(*,*)'NREC=',nrec,'MSG=',trim(msg)
           select case(adjustl(msg))
     !-----------------------------------------------------------------------
            case('DATA')
              do i = 1,nrec
                 read(kin,9007) x(1),y(1),x(2),y(2),x(3),y(3),x(4),y(4)
                 do j = 1,4
                    if(x(j).eq.0)then
                       if(y(j).eq.0)then
                          ipn = 3
                          cycle
                       endif
                    endif
                    call plot(x(j),y(j),ipn)
                    ipn = 2
                 enddo
              enddo
     !-----------------------------------------------------------------------
            case('CIRCL')
              do i = 1,nrec
                 read(kin,9007) xl,yl,tho,thf,ro,rf,di
                 call circl(xl,yl,tho,thf,ro,rf,di)
              enddo
     !-----------------------------------------------------------------------
            case('DASHL')
              do i = 1,nrec
                 read(kin,9009) x(1),y(1),npts,inc
                 9009 format(2(1X,F9.3),1X,I3,7X,I1)
                 j1 = inc+1
                 j2 = inc*npts+1-inc
                 do j = j1,j2,inc
                    read(kin,9007) x(j),y(j)
                 enddo
                 j = j2+inc
                 x(j) = 0.
                 y(j) = 0.
                 j = j+inc
                 x(j) = 1.
                 y(j) = 1.
                 call dashl(x,y,npts,inc)
              enddo
     !-----------------------------------------------------------------------
            case('DASHP')
              do i = 1,nrec
                 read(kin,9007) xl,yl,d
                 call dashp(xl,yl,d)
              enddo
     !-----------------------------------------------------------------------
            case('ELIPS')
              do i = 1,nrec
                 read(kin,9012) xl,yl,rma,rmi,a,th0,thf,ipen
                 9012 format(7(1X,F9.3),1X,I1)
                 call elips(xl,yl,rma,rmi,a,tho,thf,ipen)
              enddo
     !-----------------------------------------------------------------------
            case('FIT')
              do i = 1,nrec
                 read(kin,9007) x(1),y(1),x(2),y(2),x(3),y(3)
                 call fit(x(1),y(1),x(2),y(2),x(3),y(3))
              enddo
     !-----------------------------------------------------------------------
            case('GRID')
              do i = 1,nrec
                 read(kin,9014) xl,yl,dx,dy,nx,ny
                 9014 format(4(1X,F9.3),2(1X,I2,7X))
                 call grid(xl,yl,dx,dy,nx,ny)
              enddo
     !-----------------------------------------------------------------------
            case('POLY')
              do i = 1,nrec
                 read(kin,9007) xl,yl,sl,sn,a
                 call poly(xl,yl,sl,sn,a)
              enddo
     !-----------------------------------------------------------------------
            case('RECT')
              do i = 1,nrec
                 read(kin,9021) xl,yl,h,w,a,ipen
                 9021 format(5(1X,F9.3),1X,I2)
                 call rect(xl,yl,h,w,a,ipen)
              enddo
     !-----------------------------------------------------------------------
            case('SYMBOL')
              do i = 1,nrec
                 read(kin,9016) xl,yl,h,msg,inc
                 9016 format(3(1X,F9.3), A40,1X,I3)
                 read(kin,9017) a,nc
                 9017 format(1X,F9.3,1X,I2)
                 if(inc.lt.0)cycle NEXTREAD
                 call symbol(xl,yl,h,msg,inc,a,nc)
              enddo
     !-----------------------------------------------------------------------
            case('1100')
              do i = 1,nrec
                 read(kin,9007) xl,yl
                 call plot(xl,yl,-3)
              enddo
     !-----------------------------------------------------------------------
            case('FACTOR')
              do i = 1,nrec
                 read(kin,9007) f
                 call factor(f)
              enddo
     !-----------------------------------------------------------------------
            case('END')
              call factor(1.)
              call plot(20.,0.,999)
              exit NEXTREAD
     !-----------------------------------------------------------------------
            case default
              write(*,*)'unknown keyword ',trim(msg)
     !-----------------------------------------------------------------------
           end select
     !-----------------------------------------------------------------------
        enddo NEXTREAD
        close(unit=kin,status='delete')
     !-----------------------------------------------------------------------
     contains

     subroutine make_c_qa4()
     integer,parameter :: io=40
     open(unit=io,file='qa4.dat',action="write")
     write(io,'(a)')'  1                RECT'
     write(io,'(a)')' 1.        1.        9.         7.       0.         3'
     write(io,'(a)')'  7                SYMBOL'
     write(io,'(a)')' 1.5       9.5       .14      SAMPLE OF GENERAL SUBROUTINES PACKAGE    999'
     write(io,'(a)')' 0.        37'
     write(io,'(a)')' 2.25      9.        .105     CIRCL                                    999'
     write(io,'(a)')' 0.         6'
     write(io,'(a)')' 5.75      9.        .105     ELIPS                                    999'
     write(io,'(a)')' 0.         5'
     write(io,'(a)')' 2.25      6.5       .105     FIT, DASHP                               999'
     write(io,'(a)')' 0.        11'
     write(io,'(a)')' 5.75      6.5       .105     POLY                                     999'
     write(io,'(a)')' 0.         4'
     write(io,'(a)')' 3.75      4.25      .105     GRID, DASHL                              999'
     write(io,'(a)')' 0.        12'
     write(io,'(a)')' 2.        1.1       .07      THE BORDER IS DRAWN WITH RECT            999'
     write(io,'(a)')' 0.        29'
     write(io,'(a)')'  3                CIRCL'
     write(io,'(a)')' 3.25      8.        0.        720.      .75       .25       0.'
     write(io,'(a)')' 3.25      8.        0.        360.      .75       .25       1.'
     write(io,'(a)')' 3.35      8.        0.        360.      .85       .85       0.'
     write(io,'(a)')'  6                ELIPS'
     write(io,'(a)')' 6.5       8.        .5        .7        0.        0.        360.      3'
     write(io,'(a)')' 6.6       8.        .6        .6        0.        0.        360.      3'
     write(io,'(a)')' 6.7       8.        .7        .5        0.        0.        360.      3'
     write(io,'(a)')' 6.8       8.        .8        .4        0.        0.        360.      3'
     write(io,'(a)')' 6.9       8.        .9        .3        0.        0.        360.      3'
     write(io,'(a)')' 7.        8.        1.        .2        0.        0.        360.      3'
     write(io,'(a)')'  3                DATA'
     write(io,'(a)')' 0.        0.        1.5       5.        1.5       5.5       2.375     6.'
     write(io,'(a)')' 3.5       6.125     2.625     5.5       1.5       5.5       0.        0.'
     write(io,'(a)')' 1.5       5.        2.625     5.        3.5       5.625     0.        0.'
     write(io,'(a)')'  1                  DASHP'
     write(io,'(a)')' 2.375     5.625     .1'
     write(io,'(a)')'  1                  DATA'
     write(io,'(a)')' 1.5       5.        1.5       5.        1.5       5.        0.       0'
     write(io,'(a)')'  2                  DASHP'
     write(io,'(a)')' 2.375     5.625     .1'
     write(io,'(a)')' 2.375     6.125     .1'
     write(io,'(a)')'  2                FIT'
     write(io,'(a)')' 2.625     5.        2.5       5.25      2.625     5.5'
     write(io,'(a)')' 3.5       5.625     3.375     5.875     3.5       6.125'
     write(io,'(a)')' 10                  POLY'
     write(io,'(a)')' 5.75      5.        .35       3.        0.'
     write(io,'(a)')' 5.75      5.        .35       4.        0.'
     write(io,'(a)')' 5.75      5.        .35       5.        0.'
     write(io,'(a)')' 5.75      5.        .35       6.        0.'
     write(io,'(a)')' 5.75      5.        .35       7.        0.'
     write(io,'(a)')' 5.75      5.        .35       8.        0.'
     write(io,'(a)')' 5.75      5.        .35       9.        0.'
     write(io,'(a)')' 5.75      5.        .35       10.       0.'
     write(io,'(a)')' 5.75      5.        .35       11.       0.'
     write(io,'(a)')' 5.75      5.        .35       12.       0.'
     write(io,'(a)')'  2                GRID'
     write(io,'(a)')' 1.5       2.        .25       .25       24         8'
     write(io,'(a)')' 1.51      1.99      1.5       1.         4         2'
     write(io,'(a)')'  1                DASHL'
     write(io,'(a)')' 1.75      2.25       11       1'
     write(io,'(a)')' 2.5       3.75'
     write(io,'(a)')' 2.75      3.25'
     write(io,'(a)')' 3.        3.5'
     write(io,'(a)')' 3.5       2.75'
     write(io,'(a)')' 4.        2.5'
     write(io,'(a)')' 4.25      3.25'
     write(io,'(a)')' 5.25      2.75'
     write(io,'(a)')' 5.5       3.75'
     write(io,'(a)')' 6.5       2.5'
     write(io,'(a)')' 7.25      3.5'
     write(io,'(a)')'                    END'
     close(unit=io)
     end subroutine make_c_qa4

     end program demo_M_calcomp


subroutine setup()
!Sets up the global arrays, defines the shape of the object, and distributes the global
!arrays to the processes.

    use vars
    use parallel

    implicit none

    integer :: i,j

    real :: ysum, yhat
    integer :: nums

    !main process sets up global arrays
    if (irank .eq. 0) then

        !allocate global arrays
        call setup_global_arrays()

        ! generate x and y coordinates

        do i=1,nx_global
            x_global(i) = xrange(1) + (i-1)*dxx
        enddo

        do j=1,ny_global
            y_global(j) = yrange(1) + (j-1)*dyy
        enddo

        ! define shape of object. Save it to mask (1=object, 0 = not object)

        mask_global(:,:)=0

        do j=1,ny_global
            do i=1,nx_global
                if (shape .eq. 1) then
                    mask_global(i,j)=ellipse(x_global(i),y_global(j))
                else
                    mask_global(i,j)=aerofoil(x_global(i),y_global(j))
                endif
            enddo
        enddo

        !set up boundary array. Points on the edge of the object are set to ±1
        !(depending on whether they are on the top (+1) or bottom (-1) of the object)

        boundary_global(:,:)=0

        do i=1,nx_global
            !bottom boundary
            do j=1,ny_global
            if (mask_global(i,j) .eq. 1) then
                boundary_global(i,j) = boundary_global(i,j) - 1
                exit
                endif
            enddo
            !top boundary (don't do if the top boundary isn't found)
            if (j .ne. ny_global) then
                do j=ny_global,1,-1
                    if (mask_global(i,j) .eq. 1) then
                        boundary_global(i,j) = boundary_global(i,j) + 1
                        exit
                    endif
                enddo
            endif
        enddo

        !calculate the value of psi in the object

        yhat=0. !yhat is the value of psi in the object

        if (nose .eq. 1) then !We want the flow to diverge at the first part of the object it reaches

            ysum=0.
            nums=0

            do i=1,nx_global !skim along in the x direction looking for the first occurrance of the object
                do j=1,ny_global
                    if (mask_global(i,j) .eq. 1) then !found it! sum up all instances of it crossing this x=const line
                        nums=nums+1
                        ysum=ysum+real(j)
                    endif
                enddo

                if (nums .gt. 0) then !if we found the nose
                    yhat=ysum/real(nums) !find the mean location of the nose in the y coordinate
                    exit !we are done here. Leave the loop
                endif
            enddo

        else if (nose .eq. 0) then

            yhat=real((ny_global-1))/2+1 !set yhat to the centre value of psi

        else

            print *, "Error - invalid option (nose)"
            call MPI_Abort(comm,-1,ierr)
            stop

        endif

        ! now set the initial condition for psi, psi(x,y) = vx * y (unless in the object where its constant)

        do j=1,ny_global
            do i=1,nx_global
                if (mask_global(i,j) .eq. 1) then
                    psi_global(i,j)=yhat
                else
                    psi_global(i,j)=real(j)
                endif
            enddo
        enddo

        ! initialise vorticity to zero
        vort_global(:,:) = 0

    endif

    !allocate local arrays
    call setup_local_arrays()

    !farm out global arrays to processes
    call distribute_data()

    !fill in halos for psi
    call haloswap(psi)

    !boundary conditions for psi:
    !top/bottom
    if (up .eq. MPI_PROC_NULL) psi(:,ny+1) = psi(:,ny)+1
    if (down .eq. MPI_PROC_NULL) psi(:,0) = psi(:,1)-1

    !left/right
    psi(0,:) = psi(1,:)
    psi(nx+1,:) = 2.*psi(nx,:) - psi(nx-1,:)

end subroutine


module type_quadrature_new
#include <messenger.h>
    use mod_kinds,          only: rk, ik
    use mod_legendre_gauss, only: lg_nodes, lg_weights
    implicit none

    !>  An object for returning quadrature nodes and weights.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/14/2017
    !!
    !--------------------------------------------------------------------
    type, public :: quadrature_new_t

    contains

        procedure   :: nodes
        procedure   :: weights

    end type quadrature_new_t
    !********************************************************************

contains

    !>  Return a 1D quadrature node set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/14/2017
    !!
    !!  @param[in]  rule    String selecting the quadrature rule.
    !!  @param[in]  res     Number of nodes requested in the quadrature rule.
    !!
    !--------------------------------------------------------------------
    function nodes(self,rule,res) result(nodes_)
        class(quadrature_new_t),    intent(in)  :: self
        character(*),               intent(in)  :: rule
        integer(ik),                intent(in)  :: res

        real(rk)    :: nodes_(res)

        select case(trim(rule))
            case('Legendre-Gauss')
                nodes_ = lg_nodes(res)

            case default
                call chidg_signal_one(FATAL,"quadrature_new%nodes: We didn't find a quadrature rule that matched the selection.",trim(rule))

        end select

    end function nodes
    !*********************************************************************

    !>  Return a 1D quadrature weight set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/14/2017
    !!
    !!  @param[in]  rule    String selecting the quadrature rule.
    !!  @param[in]  res     Number of weights requested in the quadrature rule.
    !!
    !--------------------------------------------------------------------
    function weights(self,rule,res) result(weights_)
        class(quadrature_new_t),    intent(in)  :: self
        character(*),               intent(in)  :: rule
        integer(ik),                intent(in)  :: res

        real(rk)    :: weights_(res)

        select case(trim(rule))
            case('Legendre-Gauss')
                weights_ = lg_weights(res)

            case default
                call chidg_signal_one(FATAL,"quadrature_new%weights: We didn't find a quadrature rule that matched the selection.",trim(rule))

        end select

    end function weights
    !*********************************************************************

end module type_quadrature_new


PROGRAM main

  IMPLICIT NONE

  ! Number of items in the list (fixed)
  INTEGER, PARAMETER :: n = 10000
  ! I use a compile-time fixed array here. Could also use an ALLOCATABLE
  INTEGER, DIMENSION(n) :: dat
  INTEGER :: i, tmp_dat
  ! I use two flags for clarity. This is not necessary
  LOGICAL :: sorted, swapped

  ! Create reverse ordered data. This is the worst case for Bubble Sort
  ! and should take time proportional to n^2
  ! If I create ordered data, I should only take time proportional to n
  DO i = 1, n
    dat(i) = n-i + 1
  END DO

  ! Start assuming not sorted. For Bubble sort, the first pass through the data
  ! will show if it was already sorted, so we don't need to check
  sorted = .FALSE.

  DO WHILE (.NOT. sorted)
    ! swapped tracks if we swapped any items this time
    swapped = .FALSE.
    ! Pairwise comparision, so run to n-1
    DO i = 1, n-1
      ! If items are misordered:
      IF(dat(i) > dat(i+1)) THEN
        ! Exchange values using a temporary
        tmp_dat = dat(i+1)
        dat(i+1) = dat(i)
        dat(i) = tmp_dat
        swapped = .TRUE.
      END IF
    END DO
    ! When we made no swaps we know array is sorted!
    ! Don't need to do this, but it's clearer to me than
    ! setting sorted to .TRUE. on each go around
    sorted = .NOT. swapped
  END DO

  ! Print first and last elements. This just verifies we're no longer reversed

  PRINT*, "First and last elements of dat are :", dat(1), dat(n)

END PROGRAM


c     Fortran translation (Heh!) of test7 in quadpack-tests.lisp.
      program test7
      double precision alpha
      integer keyval(3)
      data keyval/1,3,6/

      print *, 'Test integral 7'
      print *
      print *, ' integrate(abs(x-1/3)^alpha, x, 0, 1)'
      print *, '   = ((2/3)^(alpha+1)+(1/3)^(alpha+1))/(alpha+1)'
      print *
      print *, 'QAGS'
      do 10 alpha = -0.8d0, 2.1d0, 0.1d0
         call qqags(alpha)
   10 continue
      print *
      print *, 'QAGP'
      do 20 alpha = -0.8d0, 2.1d0, 0.1d0
         call qqagp(alpha)
   20 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      double precision alpha
      double precision a1
      a1 = 1 + alpha
      soln = ((2d0/3d0)**a1 + (1d0/3d0)**a1)/a1
      return
      end

      double precision function f(x)
      double precision x
      double precision alfa
      common /param/ alfa
      f = abs(x - 1d0/3d0)**alfa
      return
      end

      subroutine qqags(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqags(f, 0d0, 1d0, 0d0, 1d-8, result, abserr, neval,
     $     ier, limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqagp(alpha)
      implicit none
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      double precision alfa
      common /param/alfa

      double precision points(3), alist(limit), blist(limit)
      double precision rlist(limit), elist(limit), pts(3)
      integer level(limit)
      integer ndin(3), iord(limit)
      data points/0.3333333333333333d0,
     $     0.3333333333333333d0,
     $     0.3333333333333333d0/

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqagpe(f, 0d0, 1d0, 3, points, 0d0, 1d-8, limit,
     $     result, abserr, neval, ier,
     $     alist, blist, rlist, elist, pts, iord, level, ndin, last)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


program cholspeedvec
  ! Tests the speed of modified Cholesky factorization (vector version)

  use flips

  implicit none

  integer :: n,i
  character(len=1) :: type

  real(4), dimension(:), allocatable :: samat,scmat
  real(8), dimension(:), allocatable :: damat,dcmat
  complex(4), dimension(:), allocatable :: camat,ccmat
  complex(8), dimension(:), allocatable :: zamat,zcmat

  real(8) :: stime, etime, ttime

  write(*,*) 'Give size:'
  read(*,*) n
  write(*,*) 'Give type:'
  read(*,*) type

!n=2000
!type='d'

  select case (type)

  case ('s')

     allocate(samat(n*(n+1)/2),scmat(n*(n+1)/2))

     ! We do not really have to care about the symmetry
     call random_number(samat)

     ! Just make sure that amat is positive definite
     do i = 1,n

        samat(rind(i,i,n)) = n
     end do

write(*,*) 'Start!'

     call cpu_time(stime)
     call modcholvec_s(n,n*(n+1)/2,samat,scmat)
     call cpu_time(etime)
     ttime = etime - stime

     deallocate(samat,scmat)

  case ('d')

     allocate(damat(n*(n+1)/2),dcmat(n*(n+1)/2))

     ! We do not really have to care about the symmetry
     call random_number(damat)

     ! Just make sure that amat is positive definite
     do i = 1,n

        damat(rind(i,i,n)) = n
     end do

write(*,*) 'Start!'

     call cpu_time(stime)
     call modcholvec_d(n,n*(n+1)/2,damat,dcmat)
     call cpu_time(etime)
     ttime = etime - stime

     deallocate(damat,dcmat)

  case ('c')

     allocate(camat(n*(n+1)/2),ccmat(n*(n+1)/2),samat(n*(n+1)/2),scmat(n*(n+1)/2))

     ! We do not really have to care about the symmetry
     call random_number(samat)
     call random_number(scmat)

     camat = samat + (0.0,1.0) * scmat

     ! Just make sure that amat is positive definite
     do i = 1,n
        camat(rind(i,i,n)) = n
     end do

write(*,*) 'Start!'

     call cpu_time(stime)
     call modcholvec_c(n,n*(n+1)/2,camat,ccmat)
     call cpu_time(etime)
     ttime = etime - stime

     deallocate(camat,ccmat,samat,scmat)

  case ('z')

     allocate(zamat(n*(n+1)/2),zcmat(n*(n+1)/2),damat(n*(n+1)/2),dcmat(n*(n+1)/2))

     ! We do not really have to care about the symmetry
     call random_number(damat)
     call random_number(dcmat)

     zamat = damat + (0.0,1.0) * dcmat

     ! Just make sure that amat is positive definite
     do i = 1,n
        zamat(rind(i,i,n)) = n
     end do

write(*,*) 'Start!'

     call cpu_time(stime)
     call modcholvec_z(n,n*(n+1)/2,zamat,zcmat)
     call cpu_time(etime)
     ttime = etime - stime

     deallocate(zamat,zcmat,damat,dcmat)

  case default

     write(*,*) 'Unknown type. Exiting'
     stop

  end select

  write(*,*) 'Size:',n
  write(*,*) 'Type:',type
  write(*,*) 'CPU Time:',ttime

end program cholspeedvec


*DECK DXLEGF
      SUBROUTINE DXLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  DXLEGF
C***PURPOSE  Compute normalized Legendre polynomials and associated
C            Legendre functions.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XLEGF-S, DXLEGF-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***DESCRIPTION
C
C   DXLEGF: Extended-range Double-precision Legendre Functions
C
C   A feature of the DXLEGF subroutine for Legendre functions is
C the use of extended-range arithmetic, a software extension of
C ordinary floating-point arithmetic that greatly increases the
C exponent range of the representable numbers. This avoids the
C need for scaling the solutions to lie within the exponent range
C of the most restrictive manufacturer's hardware. The increased
C exponent range is achieved by allocating an integer storage
C location together with each floating-point storage location.
C
C   The interpretation of the pair (X,I) where X is floating-point
C and I is integer is X*(IR**I) where IR is the internal radix of
C the computer arithmetic.
C
C   This subroutine computes one of the following vectors:
C
C 1. Legendre function of the first kind of negative order, either
C    a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or
C    b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X)
C 2. Legendre function of the second kind, either
C    a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or
C    b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X)
C 3. Legendre function of the first kind of positive order, either
C    a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or
C    b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X)
C 4. Normalized Legendre polynomials, either
C    a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or
C    b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X)
C
C where X = COS(THETA).
C
C   The input values to DXLEGF are DNU1, NUDIFF, MU1, MU2, THETA,
C and ID. These must satisfy
C
C    DNU1 is DOUBLE PRECISION and greater than or equal to -0.5;
C    NUDIFF is INTEGER and non-negative;
C    MU1 is INTEGER and non-negative;
C    MU2 is INTEGER and greater than or equal to MU1;
C    THETA is DOUBLE PRECISION and in the half-open interval (0,PI/2];
C    ID is INTEGER and equal to 1, 2, 3 or 4;
C
C and  additionally either NUDIFF = 0 or MU2 = MU1.
C
C   If ID=1 and NUDIFF=0, a vector of type 1a above is computed
C with NU=DNU1.
C
C   If ID=1 and MU1=MU2, a vector of type 1b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=2 and NUDIFF=0, a vector of type 2a above is computed
C with NU=DNU1.
C
C   If ID=2 and MU1=MU2, a vector of type 2b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=3 and NUDIFF=0, a vector of type 3a above is computed
C with NU=DNU1.
C
C   If ID=3 and MU1=MU2, a vector of type 3b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   If ID=4 and NUDIFF=0, a vector of type 4a above is computed
C with NU=DNU1.
C
C   If ID=4 and MU1=MU2, a vector of type 4b above is computed
C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1.
C
C   In each case the vector of computed Legendre function values
C is returned in the extended-range vector (PQA(I),IPQA(I)). The
C length of this vector is either MU2-MU1+1 or NUDIFF+1.
C
C   Where possible, DXLEGF returns IPQA(I) as zero. In this case the
C value of the Legendre function is contained entirely in PQA(I),
C so it can be used in subsequent computations without further
C consideration of extended-range arithmetic. If IPQA(I) is nonzero,
C then the value of the Legendre function is not representable in
C floating-point because of underflow or overflow. The program that
C calls DXLEGF must test IPQA(I) to ensure correct usage.
C
C   IERROR is an error indicator. If no errors are detected, IERROR=0
C when control returns to the calling routine. If an error is detected,
C IERROR is returned as nonzero. The calling routine must check the
C value of IERROR.
C
C   If IERROR=210 or 211, invalid input was provided to DXLEGF.
C   If IERROR=201,202,203, or 204, invalid input was provided to DXSET.
C   If IERROR=205 or 206, an internal consistency error occurred in
C DXSET (probably due to a software malfunction in the library routine
C I1MACH).
C   If IERROR=207, an overflow or underflow of an extended-range number
C was detected in DXADJ.
C   If IERROR=208, an overflow or underflow of an extended-range number
C was detected in DXC210.
C
C***SEE ALSO  DXSET
C***REFERENCES  Olver and Smith, Associated Legendre Functions on the
C                 Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518.
C               Smith, Olver and Lozier, Extended-Range Arithmetic and
C                 Normalized Legendre Polynomials, ACM Trans on Math
C                 Softw, v 7, n 1, March 1981, pp 93--105.
C***ROUTINES CALLED  DXPMU, DXPMUP, DXPNRM, DXPQNU, DXQMU, DXQNU, DXRED,
C                    DXSET, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C           CALLs to XERROR changed to CALLs to XERMSG.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXLEGF
      DOUBLE PRECISION PQA,DNU1,DNU2,SX,THETA,X,PI2
      DIMENSION PQA(*),IPQA(*)
C
C***FIRST EXECUTABLE STATEMENT  DXLEGF
      IERROR=0
      CALL DXSET (0, 0, 0.0D0, 0,IERROR)
      IF (IERROR.NE.0) RETURN
      PI2=2.D0*ATAN(1.D0)
C
C        ZERO OUTPUT ARRAYS
C
      L=(MU2-MU1)+NUDIFF+1
      DO 290 I=1,L
      PQA(I)=0.D0
  290 IPQA(I)=0
C
C        CHECK FOR VALID INPUT VALUES
C
      IF(NUDIFF.LT.0) GO TO 400
      IF(DNU1.LT.-.5D0) GO TO 400
      IF(MU2.LT.MU1) GO TO 400
      IF(MU1.LT.0) GO TO 400
      IF(THETA.LE.0.D0.OR.THETA.GT.PI2) GO TO 420
      IF(ID.LT.1.OR.ID.GT.4) GO TO 400
      IF((MU1.NE.MU2).AND.(NUDIFF.GT.0)) GO TO 400
C
C        IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X)
C        CANNOT BE CALCULATED.  IF DNU1 IS AN INTEGER AND
C        MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND
C        NORMALIZED P(MU,NU,X) WILL BE ZERO.
C
      DNU2=DNU1+NUDIFF
      IF((ID.EQ.3).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 295
      IF((ID.EQ.4).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 400
      IF((ID.EQ.3.OR.ID.EQ.4).AND.MU1.GT.DNU2) RETURN
  295 CONTINUE
C
      X=COS(THETA)
      SX=1.D0/SIN(THETA)
      IF(ID.EQ.2) GO TO 300
      IF(MU2-MU1.LE.0) GO TO 360
C
C        FIXED NU, VARIABLE MU
C        CALL DXPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X)
C
      CALL DXPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 380
C
  300 IF(MU2.EQ.MU1) GO TO 320
C
C        FIXED NU, VARIABLE MU
C        CALL DXQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X)
C
      CALL DXQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 390
C
C        FIXED MU, VARIABLE NU
C        CALL DXQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X)
C
  320 CALL DXQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 390
C
C        FIXED MU, VARIABLE NU
C        CALL DXPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X)
C
  360 CALL DXPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO
C        P(MU,NU,X) VECTOR.
C
  380 IF(ID.EQ.3) CALL DXPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO
C        NORMALIZED P(MU,NU,X) VECTOR.
C
      IF(ID.EQ.4) CALL DXPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
C
C        PLACE RESULTS IN REDUCED FORM IF POSSIBLE
C        AND RETURN TO MAIN PROGRAM.
C
  390 DO 395 I=1,L
      CALL DXRED(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
  395 CONTINUE
      RETURN
C
C        *****     ERROR TERMINATION     *****
C
  400 CALL XERMSG ('SLATEC', 'DXLEGF',
     +             'DNU1, NUDIFF, MU1, MU2, or ID not valid', 210, 1)
      IERROR=210
      RETURN
  420 CALL XERMSG ('SLATEC', 'DXLEGF', 'THETA out of range', 211, 1)
      IERROR=211
      RETURN
      END


program i
  integer, dimension(2, 2) :: array
  integer::b = 1 ** 2 / 1
  integer::c = 2 ** 1
  array(b, b) = b * b
  array(b, c) = b * c
  array(c*1, b**1) = b * c
  array(c**1, c) = b * array(b, c)

end program i


!:.............................................................................:
!:                                                                             :
!:               	     Random Number Generators                                :
!:                                                                             :
!:.............................................................................:

module Random

   implicit none

   ! Variables for the climate-specific RGN
   integer   :: clim_seed=0
   integer   :: rng_seed
   logical   :: reset_clim=.true.

   private      clim_seed, rng_seed, reset_clim

contains

   function urand(lb,ub,seed)
      real                            :: urand
      real, optional, intent(in)      :: lb,ub
      real, optional, intent(in)      :: seed

      integer, dimension(1)           :: seeder
      integer                         :: iseed
      real                            :: rnd
      real                            :: lower,upper

      ! Returns a uniformly-distributed random number in the range lb to ub.
      if ( present(seed) ) then
         iseed=int(seed)
         call set_random_seed(iseed)
      endif

      if ( present(lb) ) then
         lower=lb
      else
         lower=0.0
      endif

      if ( present(ub) ) then
         upper = ub
      else
         upper = 1.0
      endif

      call random_number(rnd)

      urand = lower+(upper-lower)*rnd

      return
   end function urand

   function nrand(mean,std,seed)
      real                             :: nrand
      real, optional, intent(in)       :: mean,std
      real, optional, intent(in)       :: seed

      real                             :: rnd
      integer                          :: iseed
      real                             :: mn, st
      real                             :: x1, y1, x2, y2, w

      ! Returns a normally-distributed random number with given mean and standard dev.
      if ( present(mean) ) then
         mn = mean
      else
         mn = 0.0
      endif

      if ( present(std) ) then
         st = std
      else
         st = 1.0
      endif

      ! Box-Muller polar method
      1 continue

      if ( present(seed) ) then
         iseed=int(seed)
         x1 = urand(-1.0,1.0,seed)
         x2 = urand(-1.0,1.0,seed)
      else
         x1 = urand(-1.0,1.0)
         x2 = urand(-1.0,1.0)
      endif

      w = x1**2 + x2**2
      if ( w .eq. 0.0 .or. w .gt. 1.0 ) go to 1
      w = sqrt( (-2.0 * log( w ) ) / w )
      y1 = x1*w
      y2 = x2*w

      ! Pick one, adjust its mean and std
      nrand = y1*st + mn

      return
   end function nrand

   function clim_urand(lb,ub)
      real                             :: clim_urand
      real, optional, intent(in)       :: lb,ub

      real                             :: lower,upper
      real                             :: ran1
      real                             :: rm1, rm2
      real, dimension(97)              :: r
      integer, parameter               :: m1=259200,ia1=7141,ic1=54773
      integer, parameter               :: m2=134456,ia2=8121,ic2=28411
      integer, parameter               :: m3=243000,ia3=4561,ic3=51349
      integer                          :: ix1, ix2, ix3
      integer                          :: j
      logical                          :: first=.true.
      save

      ! Used in order to have a separate RNG for climate data.
      ! Simple-minded but decent linear congruence with a shuffle, from the
      ! Yellow Peril (Numerical Recipes First Edition).  Passes "Runs" test
      ! but probably not DIEHARD.

      if ( present(lb) ) then
         lower=lb
      else
         lower=0.0
      endif

      if ( present(ub) ) then
         upper = ub
      else
         upper = 1.0
      endif

      rm1=1./m1
      rm2=1./m2

      if (first .or. reset_clim) then
         ix1=mod(abs(ic1-clim_seed),m1)
         ix1=mod(ia1*ix1+ic1,m1)
         ix2=mod(ix1,m2)
         ix1=mod(ia1*ix1+ic1,m1)
         ix3=mod(ix1,m3)
         do j=1,97
            ix1=mod(ia1*ix1+ic1,m1)
            ix2=mod(ia2*ix2+ic2,m2)
            r(j)=(real(ix1)+real(ix2)*rm2)*rm1
         enddo
         first=.false.
         reset_clim=.false.
      endif

      ix1=mod(ia1*ix1+ic1,m1)
      ix2=mod(ia2*ix2+ic2,m2)
      ix3=mod(ia3*ix3+ic3,m3)
      j=1+(97*ix3)/m3
      if ( j .gt. 97 .or. j .lt. 1 ) then
         j=97
         write(*,*) 'Error in climate RNG'
      else
         ran1=r(j)
         r(j)=(real(ix1)+real(ix2)*rm2)*rm1
      endif

      clim_urand=lower+(upper-lower)*ran1

      return
   end function clim_urand

   function clim_nrand(mean,std)
      real                             :: clim_nrand
      real, optional                   :: mean,std

      real                             :: rnd

      real                             :: mn, st
      real                             :: x1, y1, x2, y2, w

      ! Returns a normally-distributed random number with given mean and standard dev.
      if ( present(mean) ) then
         mn = mean
      else
         mn = 0.0
      endif

      if ( present(std) ) then
         st = std
      else
         st = 1.0
      endif

      ! Box-Muller polar method
      1 continue

      x1=clim_urand(-1.0,1.0)
      x2=clim_urand(-1.0,1.0)

      w = x1**2 + x2**2
      if ( w .eq. 0.0 .or. w .gt. 1.0 ) go to 1

      w = sqrt( (-2.0 * log( w ) ) / w )
      y1 = x1*w
      y2 = x2*w
      ! Pick one, adjust its mean and std
      clim_nrand = y1*st+mn

      return
   end function clim_nrand

   subroutine set_site_rng_seed(fixed_seed,seed)
      logical,        intent(in)      :: fixed_seed
      real, optional, intent(in)      :: seed

      integer                         :: idate(8)
      integer                         :: iseed
      integer, parameter              :: default_seed=2345678
      logical                         :: first=.true.
      real                            :: rnd

      ! Fixed seed is for debugging.  If true, set the seed to be the default
      ! seed each it is called.  If false, get a random seed (or optionally use
      ! a specified seed) on the first call.
      !
      ! If fixed_seed is true, reset the seed for each site.  This is done
      ! because if we ever parallelize the code, the only way to ensure
      ! reproducibility is to start each site from the same state. It's not
      ! so important for serial runs but it doesn't take all that much time.
      ! Even for serial runs, however, it means we can run the sites in any order.

      if ( .not. fixed_seed ) then
         if ( first ) then
            if ( .not. present(seed) ) then
               call date_and_time(values=idate)
               call get_random_seed(iseed)
               ! idate(8) contains millisecond
               if ( iseed .ne. 0 ) then
                  iseed = iseed * (idate(8))
               else
                  iseed = default_seed * (idate(8))
               endif
            else
               iseed=seed
            endif

            first=.false.
            rng_seed=iseed
            call set_random_seed(rng_seed)

         endif

      else

         if ( .not. present(seed) ) then
            iseed=default_seed
         else
            iseed=seed
         endif

         rng_seed=iseed

         call set_random_seed(rng_seed)
         call random_number(rnd)

      endif

   end subroutine set_site_rng_seed

   subroutine set_climate_rng_seed(same_climate,fixed_seed,seed)
      logical,           intent(in) :: same_climate,fixed_seed
      integer, optional, intent(in) :: seed

      integer                       :: idate(8)
      integer                       :: default_seed=2345678
      integer                       :: iseed
      logical                       :: first=.true.

      ! If not using fixed seed, initialize with some randomness.
      ! Otherwise use the default seeds.
      ! For the same climate we only set the seed on the first call, then we save
      ! it and re-initialize on later calls.
      ! As with the site-related RNG, for the fixed-seed case (debugging) we
      ! reinitialize for each new site to be independent of site ordering.

      if ( .not. fixed_seed ) then
            if ( first ) then
               if ( .not. present(seed) ) then
                  call date_and_time(values=idate)
                  call get_random_seed(iseed)
                  ! idate(7) is thousands of seconds, idate(8) contains milliseconds
                  iseed = idate(7) * (idate(8))
               else
                  iseed=seed
               endif

               first=.false.

               clim_seed=iseed
               reset_clim=.false.

            else if ( same_climate ) then
               reset_clim=.true.

            endif

      else

            if ( .not. present(seed) ) then
               iseed=default_seed
            else
               iseed=seed
            endif

            clim_seed=iseed

            if ( same_climate ) then
               reset_clim=.true.
            endif

      endif

   end subroutine set_climate_rng_seed

   subroutine get_random_seed(seed)
      integer, intent(out)                :: seed

      integer                             :: isize
      integer, dimension(:), allocatable  :: iseed

      call random_seed(size=isize)
      if (.not. allocated(iseed)) allocate(iseed(isize))

      iseed=seed
      call random_seed(get=iseed)
      seed=iseed(1)

   end subroutine get_random_seed

   subroutine set_random_seed(seed)
      integer, intent(in)                 :: seed

      integer                             :: isize
      integer, dimension(:), allocatable  :: iseed

      call random_seed(size=isize)
      if (.not. allocated(iseed)) allocate(iseed(isize))

      iseed=seed
      call random_seed(put=iseed)

   end subroutine set_random_seed

end module Random