!> \file physcons.f
!! This file contains module physcons

!  ==========================================================  !!!!!
!                 module  'physcons' description               !!!!!
!  ==========================================================  !!!!!
!                                                                      !
!   this module contains some the most frequently used math and        !
!   physics constatns for gcm models.                                  !
!                                                                      !
!   references:                                                        !
!     as set in NMC handbook from Smithsonian tables.                  !
!                                                                      !
!   modification history:                                              !
!                                                                      !
!     1990-04-30  g and rd are made consistent with NWS usage          !
!     2001-10-22  g made consistent with SI usage                      !
!     2005-04-13  added molecular weights for gases          - y-t hou !
!     2013-07-12  added temperature for homogen. nuc. for ice. - R.sun !
!                                                                      !
!   external modules referenced:                                       !
!                                                                      !
!       'module machine'                    in 'machine.f'             !
!                                                                      !
!                                                                      !
!!!!!  ==========================================================  !!!!!
!!!!!                       end descriptions                       !!!!!
!!!!!  ==========================================================  !!!!!

!> \ingroup RRTMG
!! \defgroup physcons physcons
!! This module contains some of the most frequently used math and physics
!! constants for GCM models.
!! @{
!========================================!
          module physcons                !
!........................................!
!
  use machine,      only : kind_phys
!
  implicit none
!
  public

!> \section arg_table_physcons
!! | local_name            | standard_name                                          | long_name                                               | units         | rank | type              |    kind   | intent | optional |
!! |-----------------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-------------------|-----------|--------|----------|
!! | con_cp                | specific_heat_of_dry_air_at_constant_pressure          | specific heat of dry air at constant pressure           | J kg-1 K-1    |    0 | real              | kind_phys | none   | F        |
!! | con_fvirt             | ratio_of_vapor_to_dry_air_gas_constants_minus_one      | rv/rd - 1 (rv = ideal gas constant for water vapor)     | none          |    0 | real              | kind_phys | none   | F        |
!! | con_g                 | gravitational_acceleration                             | gravitational acceleration                              | m s-2         |    0 | real              | kind_phys | none   | F        |
!! | con_pi                | pi                                                     | ratio of a circle's circumference to its diameter       | radians       |    0 | real              | kind_phys | none   | F        |
!! | con_rd                | gas_constant_dry_air                                   | ideal gas constant for dry air                          | J kg-1 K-1    |    0 | real              | kind_phys | none   | F        |
!! | con_rv                | gas_constant_water_vapor                               | ideal gas constant for water vapor                      | J kg-1 K-1    |    0 | real              | kind_phys | none   | F        |
!!

!> \name Math constants

!> pi
  real(kind=kind_phys),parameter:: con_pi     =3.1415926535897931
!> square root of 2
  real(kind=kind_phys),parameter:: con_sqrt2  =1.414214e+0
!> square root of 3
  real(kind=kind_phys),parameter:: con_sqrt3  =1.732051e+0

!> \name Geophysics/Astronomy constants

!> radius of earth (m)
  real(kind=kind_phys),parameter:: con_rerth  =6.3712e+6
!> gravity (\f$m/s^{2}\f$)
  real(kind=kind_phys),parameter:: con_g      =9.80665e+0
!> ang vel of earth (\f$s^{-1}\f$)
  real(kind=kind_phys),parameter:: con_omega  =7.2921e-5
!> std atms pressure (pa)
  real(kind=kind_phys),parameter:: con_p0     =1.01325e5
! real(kind=kind_phys),parameter:: con_solr   =1.36822e+3     ! solar constant    (W/m2)-aer(2001)
!> solar constant (\f$W/m^{2}\f$)-liu(2002)
  real(kind=kind_phys),parameter:: con_solr_old =1.3660e+3
!> solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008)
  real(kind=kind_phys),parameter:: con_solr   =1.3608e+3
! real(kind=kind_phys),parameter:: con_solr   =1.36742732e+3  ! solar constant    (W/m2)-gfdl(1989) - OPR as of Jan 2006

!> \name Thermodynamics constants

!> molar gas constant (\f$J/mol/K\f$)
  real(kind=kind_phys),parameter:: con_rgas   =8.314472
!> gas constant air (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_rd     =2.8705e+2
!> gas constant H2O (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_rv     =4.6150e+2
!> spec heat air at p (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_cp     =1.0046e+3
!> spec heat air at v (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_cv     =7.1760e+2
!> spec heat H2O gas (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_cvap   =1.8460e+3
!> spec heat H2O liq (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_cliq   =4.1855e+3
!> spec heat H2O ice (\f$J/kg/K\f$)
  real(kind=kind_phys),parameter:: con_csol   =2.1060e+3
!> lat heat H2O cond (\f$J/kg\f$)
  real(kind=kind_phys),parameter:: con_hvap   =2.5000e+6
!> lat heat H2O fusion (\f$J/kg\f$)
  real(kind=kind_phys),parameter:: con_hfus   =3.3358e+5
!> pres at H2O 3pt (Pa)
  real(kind=kind_phys),parameter:: con_psat   =6.1078e+2
!> temp at 0C (K)
  real(kind=kind_phys),parameter:: con_t0c    =2.7315e+2
!> temp at H2O 3pt (K)
  real(kind=kind_phys),parameter:: con_ttp    =2.7316e+2
!> temp freezing sea (K)
  real(kind=kind_phys),parameter:: con_tice   =2.7120e+2
!> joules per calorie
  real(kind=kind_phys),parameter:: con_jcal   =4.1855E+0
!> sea water reference density (\f$kg/m^{3}\f$)
  real(kind=kind_phys),parameter:: con_rhw0   =1022.0
!> min q for computing precip type
  real(kind=kind_phys),parameter:: con_epsq   =1.0E-12

!> \name Secondary constants

  real(kind=kind_phys),parameter:: con_rocp   =con_rd/con_cp
  real(kind=kind_phys),parameter:: con_cpor   =con_cp/con_rd
  real(kind=kind_phys),parameter:: con_rog    =con_rd/con_g
  real(kind=kind_phys),parameter:: con_fvirt  =con_rv/con_rd-1.
  real(kind=kind_phys),parameter:: con_eps    =con_rd/con_rv
  real(kind=kind_phys),parameter:: con_epsm1  =con_rd/con_rv-1.
  real(kind=kind_phys),parameter:: con_dldt   =con_cvap-con_cliq
  real(kind=kind_phys),parameter:: con_xpona  =-con_dldt/con_rv
  real(kind=kind_phys),parameter:: con_xponb  =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp)

!> \name Other Physics/Chemistry constants (source: 2002 CODATA)

!> speed of light (\f$m/s\f$)
  real(kind=kind_phys),parameter:: con_c      =2.99792458e+8
!> planck constant (\f$J/s\f$)
  real(kind=kind_phys),parameter:: con_plnk   =6.6260693e-34
!> boltzmann constant (\f$J/K\f$)
  real(kind=kind_phys),parameter:: con_boltz  =1.3806505e-23
!> stefan-boltzmann (\f$W/m^{2}/K^{4}\f$)
  real(kind=kind_phys),parameter:: con_sbc    =5.670400e-8
!> avogadro constant (\f$mol^{-1}\f$)
  real(kind=kind_phys),parameter:: con_avgd   =6.0221415e23
!> vol of ideal gas at 273.15K, 101.325kPa (\f$m^{3}/mol\f$)
  real(kind=kind_phys),parameter:: con_gasv   =22413.996e-6
! real(kind=kind_phys),parameter:: con_amd    =28.970         ! molecular wght of dry air (g/mol)
!> molecular wght of dry air (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amd    =28.9644
!> molecular wght of water vapor (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amw    =18.0154
!> molecular wght of o3 (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amo3   =47.9982
! real(kind=kind_phys),parameter:: con_amo3   =48.0           ! molecular wght of o3  (g/mol)
!> molecular wght of co2 (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amco2  =44.011
!> molecular wght of o2 (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amo2   =31.9999
!> molecular wght of ch4 (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amch4  =16.043
!> molecular wght of n2o (\f$g/mol\f$)
  real(kind=kind_phys),parameter:: con_amn2o  =44.013
!> temperature the H.G.Nuc. ice starts
  real(kind=kind_phys), parameter:: con_thgni  =-38.15

!> \name Miscellaneous physics related constants (Moorthi - Jul 2014)

! integer, parameter :: max_lon=16000, max_lat=8000, min_lon=192, min_lat=94
! integer, parameter :: max_lon=5000,  max_lat=2500, min_lon=192, min_lat=94 ! current opr
  integer, parameter :: max_lon=5000,  max_lat=2000, min_lon=192, min_lat=94 ! current opr
! real(kind=kind_phys), parameter:: rlapse  = 0.65e-2, rhc_max = 0.9999      ! current opr
  real(kind=kind_phys), parameter:: rlapse  = 0.65e-2, rhc_max = 0.9999999   ! new
! real(kind=kind_phys), parameter:: rlapse  = 0.65e-2, rhc_max = 0.9900
  real(kind=kind_phys), parameter:: cb2mb   = 10.0, pa2mb   = 0.01

  real(kind=kind_phys) :: dxmax, dxmin, dxinv

!........................................!
      end module physcons                !
!========================================!
!! @}


real, dimension(1000) :: a = (/ (i, i=1, 1000) /)
real, pointer, dimension(:) :: p => a(2:1)       ! pointer to zero-length array
real :: result, zresult

result = sum(a*a)    ! Multiply array by itself to get squares

result = sum(a**2)   ! Use exponentiation operator to get squares

zresult = sum(p*p)   ! P is zero-length; P*P is valid zero-length array expression; SUM(P*P) == 0.0 as expected


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     this subroutine solves iteratively the following equation
!     to determine the pressure for which section A2 is critical
!
!     author: Yannick Muller
!
      subroutine pt2_lim_calc (pt1,a2,a1,kappa,zeta,pt2_lim)
!
      implicit none
!
      integer i
!
      real*8 pt1,a2,a1,kappa,pt2_lim,x,zeta,f,df,expon1,
     &     expon2,expon3,cte,a2a1,kp1,km1,delta_x,fact1,fact2,term
!
      x=0.999d0
!
!     x belongs to interval [0;1]
!
!     modified 25.11.2007
!     since Pt1/Pt2=(1+0.5(kappa)-M)**(zeta*kappa)/(kappa-1)
!     and for zeta1 elements type M_crit=M1=1
!     and for zeta2 elements type M_crit=M2 =1
!     it is not necessary to iteratively solve the flow equation.
!     Instead the previous equation is solved to find pt2_crit
!
      if(zeta.ge.0d0) then
         kp1=kappa+1.d0
         km1=kappa-1.d0
         a2a1=a2/a1
         expon1=-0.5d0*kp1/(zeta*kappa)
         expon2=-0.5d0*kp1/km1
         cte=a2a1*(0.5d0*kp1)**expon2
         expon3=-km1/(zeta*kappa)
         i=0
!
!
         do
            i=i+1
!
            f=x**(-1.d0)-cte*x**(expon1)
     &           *(2.d0/km1*(x**expon3-1.d0))**-0.5d0
!
            df=-1.d0/X**2-cte*(x**expon1
     &           *(2.d0/km1*(x**expon3-1.d0))**-0.5d0)
     &           *(expon1/X-1.d0/km1*expon3*x**(expon3-1.d0)
     &           *(2.d0/km1*(x**expon3-1.d0))**-1.d0)

            delta_x=-f/df
!
            if(( dabs(delta_x/x).le.1.d-8)
     &           .or.(dabs(delta_x/1d0).le.1.d-10)) then
!
               pt2_lim=pt1*X
!
               exit
            endif
            if(i.gt.25)then
                pt2_lim=pt1/(1.d0+0.5d0*km1)**(zeta*kappa/km1)
                exit
             endif
!
            x=delta_x+x
!
         enddo
!
      else
!
         do
            kp1=kappa+1.d0
            km1=kappa-1.d0
            a2a1=a2/a1
            expon1=kp1/(zeta*kappa)
            expon2=km1/(zeta*kappa)
            expon3=kp1/km1
            cte=a2a1**2*(0.5d0*kp1)**-expon3*(2.d0/km1)**-1.d0
            fact1=x**-expon1
            fact2=x**-expon2
            term=fact2-1.d0
!
            f=x**(-2.d0)-cte*fact1*term**(-1.d0)
!
            df=-2.d0*x**(-3.d0)-cte*(x**(-expon1-1.d0)*term**-1.d0)
     &           *(-expon1+expon2*(X**-expon2)*fact2*term**-1.d0)
!
            delta_x=-f/df
!
            if(( dabs(delta_x/x).le.1.d-8)
     &           .or.(dabs(delta_x/1d0).le.1.d-10)) then
               pt2_lim=pt1*X
               exit
            endif
!
            x=delta_x+x
!
         enddo
!
      endif

      return
      end


      subroutine setrot(ang1,ang2,ang3,anis1,anis2,ind,MAXROT,rotmat)
c-----------------------------------------------------------------------
c
c              Sets up an Anisotropic Rotation Matrix
c              **************************************
c
c Sets up the matrix to transform cartesian coordinates to coordinates
c accounting for angles and anisotropy (see manual for a detailed
c definition):
c
c
c INPUT PARAMETERS:
c
c   ang1             Azimuth angle for principal direction
c   ang2             Dip angle for principal direction
c   ang3             Third rotation angle
c   anis1            First anisotropy ratio
c   anis2            Second anisotropy ratio
c   ind              matrix indicator to initialize
c   MAXROT           maximum number of rotation matrices dimensioned
c   rotmat           rotation matrices
c
c
c NO EXTERNAL REFERENCES
c
c
c-----------------------------------------------------------------------
      parameter(DEG2RAD=3.141592654/180.0,EPSLON=1.e-20)
      real*8    rotmat(MAXROT,3,3),afac1,afac2,sina,sinb,sint,
     +          cosa,cosb,cost
c
c Converts the input angles to three angles which make more
c  mathematical sense:
c
c         alpha   angle between the major axis of anisotropy and the
c                 E-W axis. Note: Counter clockwise is positive.
c         beta    angle between major axis and the horizontal plane.
c                 (The dip of the ellipsoid measured positive down)
c         theta   Angle of rotation of minor axis about the major axis
c                 of the ellipsoid.
c
      if(ang1.ge.0.0.and.ang1.lt.270.0) then
            alpha = (90.0   - ang1) * DEG2RAD
      else
            alpha = (450.0  - ang1) * DEG2RAD
      endif
      beta  = -1.0 * ang2 * DEG2RAD
      theta =        ang3 * DEG2RAD
c
c Get the required sines and cosines:
c
      sina  = dble(sin(alpha))
      sinb  = dble(sin(beta))
      sint  = dble(sin(theta))
      cosa  = dble(cos(alpha))
      cosb  = dble(cos(beta))
      cost  = dble(cos(theta))
c
c Construct the rotation matrix in the required memory:
c
      afac1 = 1.0 / dble(max(anis1,EPSLON))
      afac2 = 1.0 / dble(max(anis2,EPSLON))
      rotmat(ind,1,1) =       (cosb * cosa)
      rotmat(ind,1,2) =       (cosb * sina)
      rotmat(ind,1,3) =       (-sinb)
      rotmat(ind,2,1) = afac1*(-cost*sina + sint*sinb*cosa)
      rotmat(ind,2,2) = afac1*(cost*cosa + sint*sinb*sina)
      rotmat(ind,2,3) = afac1*( sint * cosb)
      rotmat(ind,3,1) = afac2*(sint*sina + cost*sinb*cosa)
      rotmat(ind,3,2) = afac2*(-sint*cosa + cost*sinb*sina)
      rotmat(ind,3,3) = afac2*(cost * cosb)
c
c Return to calling program:
c
      return
      end


subroutine calc_tidal_disruption(j)
  !***************************************
  ! Computes tidal disruption of embryo j
  !***************************************

  use stardata,   only: mstar
  use embryodata
  use eosdata,    only: G,pi
  implicit none

  integer,intent(in) :: j

  real :: r_hill, hillcore, rstrip, orb

  ! Recalculate Hill Radius of embryo

  r_hill = embryo(j)%a*(embryo(j)%m/(3.0*mstar))**0.333

  embryo(j)%itidal = 0

  ! Check if tidal disruption is occurring

  if(embryo(j)%r > r_hill .and.embryo(j)%itidal==0) embryo(j)%itidal = 1

  if(embryo(j)%itidal==1.and.embryo(j)%idiss==0) then
     ! If we are in the tidal disruption regime, strip off the upper layers of gas and update properties

     ! Calculate the hill radius for the core only

     hillcore = embryo(j)%a*(embryo(j)%mcore/(3.0*mstar))**0.333

     ! Strip the outer layers on an orbital timescale

     if(embryo(j)%r> hillcore.and.r_hill < embryo(j)%r) then
        orb = sqrt(G*mstar/embryo(j)%a**3)
        orb = 2.0*pi/orb

        rstrip = max(r_hill,hillcore)

        embryo(j)%r = embryo(j)%r - (embryo(j)%r - rstrip)*(1.0-exp(-dt/(1.0*orb))) ! Gradual depletion of envelope over one orbital period

     endif

     embryo(j)%M = 4.0*pi*embryo(j)%rhoc*embryo(j)%r**3*theta_grad

     if(embryo(j)%m < embryo(j)%mcore) then
        embryo(j)%r = embryo(j)%rcore
        embryo(j)%m = embryo(j)%mcore

     endif

  endif

end subroutine calc_tidal_disruption


c   program CSYS  --  Change SYStems

c  convert RA,Dec,Twist from B1950 to J2000 or vice versa

	implicit real*8 (a-h,o-z)
	real*8 cmat(3,3), cmat1(3,3)
	real*8 to1950(3,3)/
     1    0.9999256794956877, -0.0111814832204662, -0.0048590038153592,
     2    0.0111814832391717,  0.9999374848933135, -0.0000271625947142,
     3    0.0048590037723143, -0.0000271702937440,  0.9999881946023742/

	degrad = 180.d0/pi()	! degrees per radian

	print*,' Enter 1 to go to J2000, 2 to go to B1950:'
	read(5,*) mode
	if (mode.lt.1 .or. mode.gt.2) call exit

c  get the pointing:
1	print*,' enter RA (degrees) ... or -999 to quit:'
	read(5,*) ra
	if (ra.lt.-900.) call exit
	print*,' enter Dec (degrees):'
	read(5,*) dec
	print*,' enter Twist (degrees):'
	read(5,*) twt

	ra = ra/degrad		! convert to radians
	dec = dec/degrad
	twt = twt/degrad

	cdec = halfpi()-dec
	call eul2m( twt, cdec, ra, 3, 2, 3, cmat)	! make C-matrix

c  convert C-matrix by column vectors:
	do i=1,3
	  do j=1,3
	    cmat1(i,j) = 0.0
	    do k=1,3
	      if (mode.eq.1) then
		cmat1(i,j) = cmat1(i,j) + cmat(i,k)*to1950(k,j)
	      else
		cmat1(i,j) = cmat1(i,j) + cmat(i,k)*to1950(j,k)
	      endif
	    enddo
	  enddo
	enddo

		! convert back to angles
	call m2eul( cmat1, 3, 2, 3, twt, cdec, ra)
	dec = halfpi()-cdec
	if (ra.lt.0.) ra = ra+2.0*pi()
	if (twt.lt.0.) twt = twt+2.0*pi()

		! and list:
	write(6,1001) ra*degrad, dec*degrad, twt*degrad

	go to 1

1001	format(' RA =', f8.3,'  Dec =', f8.3,'  Twt =', f8.3)

	end


program dos
  !
  use libtetrabz, only : libtetrabz_polstat, libtetrabz_dos
  implicit none
  !
  integer :: ltetra, nb, ng, nge(3), ngw(3), i1, i2, i3, ik, iq, nq, &
  &          nke, nkw, ikvec(3), ne = 1
  real(8) :: bvec(3,3), ef, kvec(3), qvec(3), qmax, e0(1), VBZ, pi
  real(8),allocatable :: eig(:,:), eig1(:,:), eig2(:,:), wght(:,:,:), wght_dos(:,:,:)
  !
  write(*,'(a)', advance = "no") "Which tetrahedron method ?(1 = Linear, 2 = Optimized): "
  read(*,*) ltetra
  write(*,'(a)', advance = "no") "k-point mesh ?: "
  read(*,*) ng
  !
  pi = acos(-1d0)
  nb = 1
  nge(1:3) = ng
  ngw(1:3) = ng
  bvec(1:3,1) = (/3d0, 0d0, 0d0/)
  bvec(1:3,2) = (/0d0, 3d0, 0d0/)
  bvec(1:3,3) = (/0d0, 0d0, 3d0/)
  nke = product(nge(1:3))
  nkw = product(ngw(1:3))
  ef = 0.5d0
  nq = 30
  qmax = 4d0
  VBZ = bvec(1,1) * bvec(2,2) * bvec(3,3) + bvec(1,2) * bvec(2,3) * bvec(3,1) &
  &   + bvec(1,3) * bvec(2,1) * bvec(3,2) - bvec(1,3) * bvec(2,2) * bvec(3,1) &
  &   + bvec(1,2) * bvec(2,1) * bvec(3,3) - bvec(1,1) * bvec(2,3) * bvec(3,2)
  !
  allocate(eig1(nb,nke), eig2(nb,nke), wght(nb,nb,nkw), wght_dos(ne,nb,nkw))
  !
  open(10, file = "lindhard.dat")
  !
  do iq = 0, nq
     !
     qvec(1:3) = (/qmax * dble(iq) / dble(nq), 0d0, 0d0/)
     !
     ik = 0
     do i3 = 0, nge(3) - 1
        do i2 = 0, nge(2) - 1
           do i1 = 0, nge(1) - 1
              !
              ik = ik + 1
              !
              ikvec(1:3) = (/i1, i2, i3/)
              ikvec(1:3) = modulo(ikvec(1:3) + nge(1:3) / 2, nge(1:3)) - nge(1:3) / 2
              kvec(1:3) = dble(ikvec(1:3)) / dble(nge(1:3))
              kvec(1:3) = matmul(bvec(1:3,1:3), kvec(1:3))
              !
              eig1(1,ik) = 0.5d0 * dot_product(kvec(1:3), kvec(1:3)) - ef
              !
              kvec(1:3) = kvec(1:3) + qvec(1:3)
              eig2(1,ik) = 0.5d0 * dot_product(kvec(1:3), kvec(1:3)) - ef
              !
           end do
        end do
     end do
     !
     if(iq == 0) then
        e0(1) = 0d0
        call libtetrabz_dos(ltetra,bvec,nb,nge,eig1,ngw,wght_dos,ne,e0)
        write(10,*) 0d0, sum(wght_dos(1:ne,1:nb,1:nkw)) * VBZ / (4d0 * pi)
     else
        call libtetrabz_polstat(ltetra,bvec,nb,nge,eig1,eig2,ngw,wght)
        write(10,*) qvec(1), 2d0 * sum(wght(1:nb,1:nb,1:nkw)) * VBZ / (4d0 * pi)
     end if
     !
  end do ! iq
  !
  close(10)
  !
  write(*,*) "To compare with the analytical result, type below in gnuplot"
  write(*,*) ""
  write(*,*) 'plot "lindhard.dat" u 1:2 w p, 0.5+0.5/x*(1-0.25*x**2)*log(abs((x+2)/(x-2)))'
  write(*,*) ""
  !
end program dos


C  PROGRAM WIENER  --  APPLY WIENER FILTER TO A FOURIER TRANSFORM

c  Nov 1996  JJL
C  2-JAN-95 ..CRI..   MSTP S/W Conversion (VICAR Porting)
C        9-88  SP   MODIFIED BECAUSE DIV HAS BEEN RENAMED TO DIVV.
C  APR-85  ...LWK...  INITIIAL VERSION, FROM IBM PGM 'RESTORE'
C  MAY-85  ...LWK...  ADDED AP CODE, FROM IBM PGM 'GPFILT'

      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44

      IMPLICIT INTEGER (A-Z)
      parameter(maxsize=4096)
      INTEGER*4 IUN(3), OUN
      REAL*4 SN,rnorm,psfnor,outnor,mtf,factor
      complex im(maxsize),otf(maxsize),restor(maxsize)
      complex ratio
      CHARACTER*8 FMT
      logical xvptst

      CALL IFMESSAGE('WIENER version Nov 1996')

c open & check inputs
      CALL XVPCNT( 'INP', NIDS)
      DO I=1,NIDS
	CALL XVUNIT( IUN(I), 'INP', I, ISTAT,' ')
	CALL XVOPEN(IUN(I),ISTAT,'OPEN_ACT','SA','IO_ACT','SA',' ')
	CALL XVGET( IUN(I), STATUS, 'FORMAT', FMT, 'NL', NL1, 'NS',
     .	 NS1,' ')
	IF (FMT.NE.'COMPLEX' .AND. FMT.NE.'COMP') THEN
	  CALL XVMESSAGE('ALL INPUT FILES MUST BE COMPLEX',' ')
	  CALL ABEND
	ENDIF
	IF (I.EQ.1) THEN
	  NL = NL1
	  NS = NS1
	ELSEIF (NL1.NE.NL .OR. NS1.NE.NS) THEN
	  CALL XVMESSAGE('ALL INPUT FILES MUST BE SAME SIZE',' ')
	  CALL ABEND
	ENDIF
      ENDDO

c open outputs
      CALL XVUNIT( OUN, 'OUT', 1, ISTAT,' ')
      CALL XVOPEN( OUN, ISTAT, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA',
     . 'OP', 'WRITE',' ')

c get parameters
      CALL XVPARM( 'SN', SN, I, J,1)
      SN = 1./SN**2

      if(xvptst('wiener'))then
        factor=1.0/(1.0+sn)
        factor=1.0/factor
      endif

C process image
      DO L=1,NL
	CALL XVREAD( IUN(1), IM, I,' ')
	CALL XVREAD( IUN(2), OTF, I,' ')

	IF (L.EQ.1)then
           RNORM = REAL(OTF(1))
           psfnor=real(IM(i))
        endif

c       normalize the otf
        do i=1,ns
          otf(i)=otf(i)/rnorm
        enddo

c       Apply direct otf  filter
        if(xvptst('direct'))then
  	  DO I=1,NS
	    RESTOR(I)=OTF(I)*IM(I)
	  ENDDO
        endif

c       Apply wiener restoration filter
        if(xvptst('wiener'))then
  	  DO I=1,NS
	    RESTOR(I)=IM(i)*factor*CONJG(OTF(I))/
     +        ((REAL(OTF(I)))**2+(AIMAG(OTF(I)))**2+SN)
	  ENDDO
cccccc      if(L.eq.1)restor(1)=cmplx(psfnor,0.0)
        endif

c       Obtain ratio restoration filter
        if(xvptst('ratio'))then
  	  DO I=1,NS
            if((real(OTF(i)))**2+(aimag(OTF(i)))**2.ne.0.)then
              ratio=IM(i)/(psfnor*OTF(i))
       	      RESTOR(I)=CONJG(ratio)/
     +        ((REAL(ratio))**2+(AIMAG(ratio))**2+SN)
            else
              RESTOR(i)=cmplx(0.,0.)
            endif
	  ENDDO
        endif

c       Apply amplitude restoration filter
        if(xvptst('amplitude'))then
  	  DO I=1,NS
            mtf=sqrt((real(IM(i)))**2+(aimag(IM(i)))**2)/
     +         (psfnor*sqrt((real(OTF(i)))**2+(aimag(OTF(i)))**2+
     +         .00001))
	    RESTOR(I)=IM(i)*mtf/(mtf*mtf+SN)
	  ENDDO
          if(L.eq.1)restor(1)=cmplx(psfnor,0.0)
        endif

c       Optionally APPLY MTF OF DESIRED OUTPUT
	IF (NIDS.EQ.3) THEN
	  CALL XVREAD( IUN(3), OTF, I,' ')
	  IF (L.EQ.1) outnor = REAL(OTF(1))
	  DO I=1,NS
	    RESTOR(I)=RESTOR(I)*OTF(I)/outnor
	  ENDDO
          if(L.eq.1)restor(1)=cmplx(psfnor,0.0)
	ENDIF

	CALL XVWRIT( OUN, RESTOR, I,' ')
      ENDDO

      RETURN
      END


*DECK SINDG
      FUNCTION SINDG (X)
C***BEGIN PROLOGUE  SINDG
C***PURPOSE  Compute the sine of an argument in degrees.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      SINGLE PRECISION (SINDG-S, DSINDG-D)
C***KEYWORDS  DEGREES, ELEMENTARY FUNCTIONS, FNLIB, SINE, TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C SINDG(X) evaluates the single precision sine of X where
C X is in degrees.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  SINDG
C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
      SAVE RADDEG
      DATA RADDEG / .017453292519943296E0 /
C
C***FIRST EXECUTABLE STATEMENT  SINDG
      SINDG = SIN (RADDEG*X)
C
      IF (MOD(X,90.).NE.0.) RETURN
      N = ABS(X)/90.0 + 0.5
      N = MOD (N, 2)
      IF (N.EQ.0) SINDG = 0.
      IF (N.EQ.1) SINDG = SIGN (1.0, SINDG)
C
      RETURN
      END


      SUBROUTINE CGETRF_F95( A, IPIV, RCOND, NORM, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: LSAME, ERINFO
      USE F77_LAPACK, ONLY: GETRF_F77 => LA_GETRF, LANGE_F77 => LA_LANGE, &
                                          GECON_F77 => LA_GECON
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
      REAL(WP), INTENT( OUT ), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
      INTEGER, INTENT( OUT ), OPTIONAL, TARGET :: IPIV( : )
      COMPLEX(WP), INTENT( INOUT ) :: A( :, : )
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_GESV computes the solution to a real or complex linear system of
! equations A*X = B, where A is a square matrix and X and B are
! rectangular matrices or vectors. Gaussian elimination with row
! interchanges is used to factor A as A = P*L*U , where P is a permutation
! matrix, L is unit lower triangular, and U is upper triangular. The
! factored form of A is then used to solve the above system.
!
! =========
!
!       SUBROUTINE LA_GESV( A, B, IPIV=ipiv, INFO=info )
!          <type>(<wp>), INTENT(INOUT) :: A(:,:), <rhs>
!          INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:)
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! A      (input/output) REAL or COMPLEX square array, shape (:,:).
!        On entry, the matrix A.
!        On exit, the factors L and U from the factorization A = P*L*U;
!        the unit diagonal elements of L are not stored.
! B      (input/output) REAL or COMPLEX array, shape (:,:) with
!        size(B,1) = size(A,1) or shape (:) with size(B) = size(A,1).
!        On entry, the matrix B.
!        On exit, the solution matrix X .
! IPIV   Optional (output) INTEGER array, shape (:) with size(IPIV) =
!        size(A,1).
!        The pivot indices that define the permutation matrix P; row i of
!        the matrix was interchanged with row IPIV(i).
! INFO   Optional (output) INTEGER
!        = 0 : successful exit.
!        < 0 : if INFO = -i, the i-th argument has an illegal value.
!        > 0 : if INFO = i, then U(i,i) = 0. The factorization has been
!        completed, but the factor U is singular, so the solution could
!        not be computed.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!----------------------------------------------------------------------
!  .. PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GETRF'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LNORM
      INTEGER :: LINFO, M, N, LD, ISTAT, ISTAT1, MINMN, LWORK, SIPIV
      REAL(WP) :: LANORM
!  .. LOCAL POINTERS ..
      INTEGER, POINTER :: LIPIV(:)
      REAL(WP), POINTER :: RWORK(:)
      COMPLEX(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC PRESENT, MAX, MIN, SIZE, TINY
!  .. EXECUTABLE STATEMENTS ..
      M = SIZE(A,1); N = SIZE(A,2); LINFO = 0; ISTAT = 0; MINMN = MIN(M,N)
      LD = MAX(1,M)
      IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = MINMN; ENDIF
      IF ( PRESENT(NORM) ) THEN; LNORM = NORM; ELSE; LNORM = '1'; END IF
!  .. TEST THE ARGUMENTS
      IF( M < 0 .OR. N < 0 .OR. PRESENT(RCOND) .AND. M /= N )THEN; LINFO = -1
      ELSE IF( SIPIV /= MINMN )THEN; LINFO = -2
      ELSE IF( ( .NOT.PRESENT(RCOND) .AND. PRESENT(NORM) ) .OR. &
               ( .NOT.LSAME(LNORM,'I') .AND. .NOT.LSAME(LNORM,'O') &
                                       .AND. LNORM /= '1' ) ) THEN; LINFO = -4
      ELSE IF( M > 0 .AND. N > 0 ) THEN
         IF( PRESENT(RCOND) .AND. M == N ) THEN
!        .. COMPUTE THE NORM OF THE MATRIX A
            IF( LNORM == 'I' ) THEN; LWORK = MINMN; ELSE; LWORK = 1; END IF
            ALLOCATE( RWORK(LWORK), STAT=ISTAT )
            IF( ISTAT == 0 )THEN
               LANORM = LANGE_F77( LNORM, MINMN, MINMN, A, LD, RWORK )
            ELSE
               LINFO = -100
            END IF
            DEALLOCATE(RWORK, STAT=ISTAT1)
         END IF
         IF( LINFO == 0 ) THEN
            IF( PRESENT(IPIV) )THEN; LIPIV => IPIV
            ELSE; ALLOCATE( LIPIV( MINMN ), STAT=ISTAT ); ENDIF
            IF( ISTAT /= 0 )LINFO = -100
         END IF
         IF( LINFO == 0 ) THEN
!           .. COMPUTE THE LU FACTORS OF THE MATRIX A
            CALL GETRF_F77( M, N, A, LD, LIPIV, LINFO )
            IF( .NOT. PRESENT(IPIV) )DEALLOCATE( LIPIV, STAT=ISTAT )
            IF( PRESENT(RCOND) ) THEN
!              .. COMPUTE THE RECIPROCAL OF THE CONDITION NUMBER OF A
               IF( LANORM <= TINY(1.0_WP) .OR. M /= N .OR. LINFO /= 0 ) THEN
                  RCOND = 0.0_WP
               ELSE
                  ALLOCATE(WORK(2*MINMN), RWORK(2*MINMN), STAT=ISTAT)
                  IF( ISTAT == 0 )THEN
                     CALL GECON_F77( LNORM, MINMN, A, LD, LANORM, &
                                     RCOND, WORK, RWORK, LINFO )
                  ELSE
                     LINFO = -100
                  END IF
                  DEALLOCATE( WORK, RWORK, STAT=ISTAT1 )
               END IF
            END IF
         END IF
      ELSE IF( PRESENT(RCOND) ) THEN
         IF( M == N )THEN
            RCOND = 1.0_WP
         ELSE
            RCOND = 0.0_WP
         END IF
      END IF
      CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
      END SUBROUTINE CGETRF_F95


submodule(euler_interface_m) euler_prob_0024_m
    implicit none

contains

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

    integer(int64) function ans()
        integer(int64) :: factor_array(10)
        integer(int64), allocatable :: arr1(:), arr2(:)
        integer(int64) :: n, i, j, k, tmp

        factor_array = [1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880]
        allocate (arr1(10))
        arr1 = [(i, i=0, 9)]
        n = 999999
        tmp = 0

        do i = 10, 1, -1
            j = n/factor_array(i)
            n = mod(n, factor_array(i))
            k = arr1(j + 1)

            allocate (arr2(count(arr1 /= k)))
            arr2 = pack(arr1, arr1 /= k)
            deallocate (arr1)

            allocate (arr1(size(arr2)))
            arr1 = arr2
            deallocate (arr2)

            tmp = tmp + k*10**(i - 1)
        end do
        ans = tmp
    end function ans

end submodule euler_prob_0024_m