program sqrtPoly
  implicit none
  != unit m :: x
  real :: x
  != unit s :: y
  real :: y
  != unit J :: z
  real :: z
  integer :: a
  integer :: b
  integer :: c
  x = sqrt(a)
  y = sqrt(sqrt(b))
  z = sqrt(square(sqrt(c)))
contains
  real function square(n)
    real :: n
    square = n * n
  end function square
end program sqrtPoly


program P8370
    implicit none
    integer :: business_rows, business_cols
    integer :: economic_rows, economic_cols
    read *, business_rows, business_cols, economic_rows, economic_cols
    write (*, '(I0)') business_rows * business_cols + economic_rows * economic_cols
end program P8370


SUBROUTINE RKSUM(N1,N2,N3,localInterval,h,K1,K2,K3,K4,stateData)

  INTEGER(KIND=8), INTENT(IN)    :: N1, N2, N3, localInterval(6)
  REAL(KIND=8),    INTENT(IN)    :: h
  REAL(KIND=8),    INTENT(IN)    :: K1(N1*N2*N3)
  REAL(KIND=8),    INTENT(IN)    :: K2(N1*N2*N3)
  REAL(KIND=8),    INTENT(IN)    :: K3(N1*N2*N3)
  REAL(KIND=8),    INTENT(IN)    :: K4(N1*N2*N3)
  REAL(KIND=8),    INTENT(INOUT) :: stateData(N1*N2*N3)

  INTEGER(KIND=8) :: I, J, K, LI, LIK, LIJ, IS1, IE1
  INTEGER(KIND=8) :: xyPlane
  INTEGER(KIND=8) :: S1,E1,S2,E2,S3,E3
  REAL(KIND=8)    :: fac1,fac2

  fac1 = h/6.0_8
  fac2 = h/3.0_8

  S1 = localInterval(1)
  E1 = localInterval(2)
  S2 = localInterval(3)
  E2 = localInterval(4)
  S3 = localInterval(5)
  E3 = localInterval(6)

  xyPlane = (N1*N2)

  DO K = S3, E3
     LIK = (K-1)*xyPlane
     DO J = S2, E2
        LIJ = (J-1)*N1 + LIK
        DO I = S1, E1
           LI = LIJ + I
           stateData(LI) = fac1*(K1(LI)+K4(LI)) + fac2*(K2(LI) + K3(LI)) + stateData(LI)
        END DO
     END DO
  END DO

END SUBROUTINE RKSUM


! Fortran subroutines to be compiled with f2py for fast and efficient LB2D code
! that can be called from a python wrapper. This is my first attempt with fortran
! Created by Joshua Larsen

subroutine f_rho(f, ylen, xlen, rho)
  ! function calculates density at each node from the LB-distribution function
  integer, intent(in)             				:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in)  	:: f
  real, dimension(ylen, xlen), intent(out)     	:: rho

  rho = SUM(f, DIM=1)
end subroutine f_rho

subroutine f_u(f, rho, ylen, xlen, uy, ux)
  ! function calculates velocity arrays where up and right are positive
  integer, intent(in)							:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in)	:: f
  real, dimension(ylen, xlen), intent(in)    	:: rho
  real, dimension(ylen, xlen), intent(out)      :: uy, ux

  uy = (SUM(f((/2,3,4/),:,:), DIM=1) - SUM(f((/6,7,8/),:,:), DIM=1))/rho
  ! ux = (SUM(f((/1,2,8/),:,:), DIM=1) - SUM(f((/4,5,6/),:,:), DIM=1))/rho
  ux = (SUM(f((/4,5,6/),:,:), DIM=1) - SUM(f((/1,2,8/),:,:), DIM=1))/rho
end subroutine f_u

subroutine f_usqr(uy, ux, ylen, xlen, usqr)
  ! function to calculate velocity squared
  integer, intent(in)							:: ylen, xlen
  real, dimension(ylen, xlen), intent(in)  		:: uy, ux
  real, dimension(ylen, xlen), intent(out)	    :: usqr

  usqr = uy*uy + ux*ux
end subroutine f_usqr

subroutine f_eu(uy, ux, tau, g, ylen, xlen, eu)
  ! function to apply eigenvectors to LB velocities in calculating eq. distribution
  integer, intent(in)							:: ylen, xlen
  real, intent(in)							:: tau, g
  real, dimension(ylen, xlen), intent(in)				:: uy, ux
  real, dimension(9, ylen, xlen), intent(out)				:: eu
  real, dimension(ylen, xlen)						:: duy
  duy = uy - (tau*g)
  eu(1, :, :) = ux
  eu(2, :, :) = ux + duy
  eu(3, :, :) = duy
  eu(4, :, :) = duy - ux
  eu(5, :, :) = -ux
  eu(6, :, :) = -ux - duy
  eu(7, :, :) = -duy
  eu(8, :, :) = ux - duy
  eu(9, :, :) = ux * 0.

end subroutine f_eu

subroutine f_feq(eu, rho, usqr, wi, csqr, ylen, xlen, feq)
  ! function to calculate the LB equilibrium distribution function
  integer, intent(in)							:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in)	:: eu
  real, dimension(ylen, xlen), intent(in)    	:: rho
  real, dimension(ylen, xlen), intent(in)		:: usqr
  real, intent(in)								:: csqr
  real, dimension(9), intent(in)				:: wi
  real, dimension(9, ylen, xlen), intent(out)	:: feq

  feq(1, :, :) = wi(1)*rho*(1 + eu(1, :, :)/csqr + 0.5*(eu(1, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(2, :, :) = wi(2)*rho*(1 + eu(2, :, :)/csqr + 0.5*(eu(2, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(3, :, :) = wi(3)*rho*(1 + eu(3, :, :)/csqr + 0.5*(eu(3, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(4, :, :) = wi(4)*rho*(1 + eu(4, :, :)/csqr + 0.5*(eu(4, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(5, :, :) = wi(5)*rho*(1 + eu(5, :, :)/csqr + 0.5*(eu(5, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(6, :, :) = wi(6)*rho*(1 + eu(6, :, :)/csqr + 0.5*(eu(6, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(7, :, :) = wi(7)*rho*(1 + eu(7, :, :)/csqr + 0.5*(eu(7, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(8, :, :) = wi(8)*rho*(1 + eu(8, :, :)/csqr + 0.5*(eu(8, :, :)/csqr)**2 - usqr/(2*csqr))
  feq(9, :, :) = wi(9)*rho*(1 + eu(9, :, :)/csqr + 0.5*(eu(9, :, :)/csqr)**2 - usqr/(2*csqr))
end subroutine f_feq

subroutine f_collision(f, feq, tau, ylen, xlen, fcol)
  !function to calculate the LB collosion operator
  integer, intent(in)							:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in)	:: f, feq
  real, intent(in)								:: tau
  real, dimension(9, ylen, xlen), intent(out)	:: fcol

  fcol = f - ((f - feq)/tau)
end subroutine f_collision

subroutine f_zhohe(f, rho, ylen, xlen, fzhe)
  ! function to calculate the zho-he pressure boundary conditions of LB
  integer, intent(in)							:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in) 	:: f
  real, dimension(ylen, xlen), intent(in)		:: rho
  real, dimension(9, ylen, xlen), intent(out)	:: fzhe
  real, dimension(ylen, xlen)					:: vy_lb, vy_ub, f2, f3, f4, f6, f7, f8
  integer										:: j, k

  vy_lb = 1 - (f(9, :, :) + f(1, :, :) + f(5, :, :) + 2*(f(6, :, :) + f(7, :, :) + f(8, :, :))/rho)

  vy_ub = -(1 - (f(9, :, :) + f(1, :, :) + f(5, :, :) + 2*(f(2, :, :) + f(3, :, :) + f(4, :, :))/rho))

  ! compute the unkown distribution values on the lower boundary
  f2 = (1/6) * rho * vy_lb + (f(5, :, :) - f(1, :, :))/2 + f(6, :, :)
  f3 = (2/3) * rho * vy_lb + f(7, :, :)
  f4 = (1/6) * rho * vy_lb + (f(1, :, :) - f(5, :, :))/2 + f(8, :, :)

  ! compute the unkown distribution values on the upper boundary
  f6 = -(1/6) * rho * vy_ub + (f(1, :, :) - f(5, :, :))/2 + f(2, :, :)
  f7 = -(2/3) * rho * vy_ub + f(3, :, :)
  f8 = -(1/6) * rho * vy_ub + (f(5, :, :) - f(1, :, :))/2 + f(4, :, :)

  !$OMP PARALLEL DO
  do k=1, xlen
    do j=1, ylen

      if (j.eq.ylen) then
        fzhe(2, j, k) = f(2, j, k)
        fzhe(3, j, k) = f(3, j, k)
        fzhe(4, j, k) = f(4, j, k)
        fzhe(6, j, k) = f6(j, k)
        fzhe(7, j, k) = f7(j, k)
        fzhe(8, j, k) = f8(j, k)
        fzhe(1, j, k) = f(1, j, k)
        fzhe(5, j, k) = f(5, j, k)
        fzhe(9, j, k) = f(9, j, k)
      else if (j.eq.1) then
        ! flipped 1 and ylen
        fzhe(2, j, k) = f2(j, k)
        fzhe(3, j, k) = f3(j, k)
        fzhe(4, j, k) = f4(j, k)
        fzhe(6, j, k) = f(6, j, k)
        fzhe(7, j, k) = f(7, j, k)
        fzhe(8, j, k) = f(8, j, k)
        fzhe(1, j, k) = f(1, j, k)
        fzhe(5, j, k) = f(5, j, k)
        fzhe(9, j, k) = f(9, j, k)
      else
        fzhe(2, j, k) = f(2, j, k)
        fzhe(3, j, k) = f(3, j, k)
        fzhe(4, j, k) = f(4, j, k)
        fzhe(6, j, k) = f(6, j, k)
        fzhe(7, j, k) = f(7, j, k)
        fzhe(8, j, k) = f(8, j, k)
        fzhe(1, j, k) = f(1, j, k)
        fzhe(5, j, k) = f(5, j, k)
        fzhe(9, j, k) = f(9, j, k)
      endif

    enddo
  enddo
  !$OMP END PARALLEL DO

end subroutine f_zhohe

subroutine f_bounceback(f, fcol, image, ylen, xlen, fbounce)
  ! function to apply lattice boltzmann bounceback/no slip boundaries
  integer, intent(in)							:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in)	:: f
  real, dimension(9, ylen, xlen), intent(in) 	:: fcol
  logical, dimension(ylen, xlen), intent(in)	:: image
  real, dimension(9, ylen, xlen), intent(out)	:: fbounce
  integer 										:: j, k

  !$OMP PARALLEL DO
  do k=1, xlen
    do j=1, ylen

      if (image(j,k)) then
        fbounce(1, j, k) = f(5, j, k)
        fbounce(2, j, k) = f(6, j, k)
        fbounce(3, j, k) = f(7, j, k)
        fbounce(4, j, k) = f(8, j, k)
        fbounce(5, j, k) = f(1, j, k)
        fbounce(6, j, k) = f(2, j, k)
        fbounce(7, j, k) = f(3, j, k)
        fbounce(8, j, k) = f(4, j, k)
        fbounce(9, j, k) = f(9, j, k)
      else
        fbounce(1, j, k) = fcol(1, j, k)
        fbounce(2, j, k) = fcol(2, j, k)
        fbounce(3, j, k) = fcol(3, j, k)
        fbounce(4, j, k) = fcol(4, j, k)
        fbounce(5, j, k) = fcol(5, j, k)
        fbounce(6, j, k) = fcol(6, j, k)
        fbounce(7, j, k) = fcol(7, j, k)
        fbounce(8, j, k) = fcol(8, j, k)
        fbounce(9, j, k) = fcol(9, j, k)

      endif
    enddo
  enddo
  !$OMP END PARALLEL DO

end subroutine f_bounceback

subroutine f_streaming(fcol, ylen, xlen, fstream)
  ! function to complete the LB streaming step
  integer, intent(in)							:: ylen, xlen
  real, dimension(9, ylen, xlen), intent(in) 	:: fcol
  real, dimension(9, ylen, xlen), intent(out)   :: fstream
  integer										:: j, k, jp, jn, kp, kn

  !$OMP PARALLEL DO
  do k=1, xlen
    do j=1, ylen

      if (k.eq.1) then
        kp = k + 1
        kn = xlen
      else if (k.eq.xlen) then
        kp = 1
        kn = k - 1
      else
        kp = k + 1
        kn = k - 1
      endif

      if (j.eq.1) then
        jp = j + 1
        jn = ylen
      else if (j.eq.ylen) then
        jp = 1
        jn = j - 1
      else
        jp = j + 1
        jn = j - 1
      endif

      fstream(1, j, kp)  = fcol(1, j, k)
      fstream(2, jp, kp) = fcol(2, j, k)
      fstream(3, jp, k)  = fcol(3, j, k)
      fstream(4, jp, kn) = fcol(4, j, k)
      fstream(5, j, kn)  = fcol(5, j, k)
      fstream(6, jn, kn) = fcol(6, j, k)
      fstream(7, jn, k)  = fcol(7, j, k)
      fstream(8, jn, kp) = fcol(8, j, k)
      fstream(9, j, k)   = fcol(9, j, k)
    enddo
  enddo
  !$OMP END PARALLEL DO

end subroutine f_streaming


c=======================================================================
c
c     subroutine APTVOL
c
c     Robusts alpha and beta (APT method) vectors of an universe for
c     a given set of factors and volatility of regression error
c
c-----------------------------------------------------------------------
      SUBROUTINE aptvol ( n, p, q, Y, X, iwork, dwork,
     &                    alpha, beta, vol, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of value(s) (n >= 1)                integer
c            p      : number of asset(s)                         integer
c            q      : number of factors                          integer
c            Y      : asset(s) values (n*p)                       double
c            X      : factor(s) values (n*q)                      double
c
c     WORKSPACE
c            iwork  : q + 1                                      integer
c            dwork  : (q + 1)*( n + 2*p + q + 2 ) + n*p           double
c
c     OUTPUT
c            alpha  : alpha coefficient(s) (p)                    double
c            beta   : beta coefficent(s) (q*p)                    double
c            vol    : std of errors (p)                           double
c            info   : diagnostic argument                        integer
c
c     CALL
c            CALAPT : robusts APT method
c            RHAPT  : historical assets values as a function
c                     of values of factors with the APT regression
c            DM     :
c            HVOLAT :
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, q, info
      DOUBLE PRECISION X(*), Y(*), alpha(*), beta(q,*), vol(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pdw, pdrs
c
c     external subroutines
      EXTERNAL calapt, RHAPT, DM, HVOLAT
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for CALAPT workspace who needs (q+1)
c
c     Total size of iwork array = q + 1
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdrs = 1
c     pdrs : pointer for matrix of simulated returns, so ( n*p ) more
      pdw = pdrs + ( n*p )
c     pdw  : pointer for CALAPT workspace who needs
c            (q + 1)*(n + 2*p + q + 2)
c
c     Total size of dwork array = (q + 1)*( n + 2*p + q + 2 ) + n*p
c
c-----------------------------------------------------------------------
c
c     construction of matrix F
      CALL calapt ( n, p, q, Y, X, iwork(piw), dwork(pdw),
     &              alpha, beta, info )
      IF (info .lt. 0) RETURN
c
c     simulated history of returns and alpha/beta
      CALL RHAPT ( n, p, q, X, alpha, beta, dwork(pdrs) )
c
c     regression error
      CALL DM ( n, p, Y, dwork(pdrs), dwork(pdrs) )
c
c     regression std error (for each asset)
      CALL HVOLAT ( n, p, dwork(pdrs), vol, info )
c
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 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.
!
      subroutine deuldlag(xi,et,ze,xlag,xeul,xj,xs)
!
!     calculation of the coefficients of the linearization
!     of J:=det(dx/dX)=1 at (xi,et,ze) for a 20-node quadratic
!     isoparametric brick element, -1<=xi,et,ze<=1
!     xlag are Lagrangian coordinates, xeul are Eulerian coordinates
!
      implicit none
!
      integer i,j,k
!
      real*8 xs(3,3),xlag(3,20),shpe(4,20),dd1,dd2,dd3,xeul(3,20)
!
      real*8 xi,et,ze,xj,omg,omh,omr,opg,oph,opr,
     &  tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr,
     &  omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr
!
!     shape functions and their glocal derivatives
!
      omg=1.d0-xi
      omh=1.d0-et
      omr=1.d0-ze
      opg=1.d0+xi
      oph=1.d0+et
      opr=1.d0+ze
      tpgphpr=opg+oph+ze
      tmgphpr=omg+oph+ze
      tmgmhpr=omg+omh+ze
      tpgmhpr=opg+omh+ze
      tpgphmr=opg+oph-ze
      tmgphmr=omg+oph-ze
      tmgmhmr=omg+omh-ze
      tpgmhmr=opg+omh-ze
      omgopg=omg*opg/4.d0
      omhoph=omh*oph/4.d0
      omropr=omr*opr/4.d0
      omgmopg=(omg-opg)/4.d0
      omhmoph=(omh-oph)/4.d0
      omrmopr=(omr-opr)/4.d0
!
!     local derivatives of the shape functions: xi-derivative
!
      shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0
      shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0
      shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0
      shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0
      shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0
      shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0
      shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0
      shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0
      shpe(1, 9)=omgmopg*omh*omr
      shpe(1,10)=omhoph*omr
      shpe(1,11)=omgmopg*oph*omr
      shpe(1,12)=-omhoph*omr
      shpe(1,13)=omgmopg*omh*opr
      shpe(1,14)=omhoph*opr
      shpe(1,15)=omgmopg*oph*opr
      shpe(1,16)=-omhoph*opr
      shpe(1,17)=-omropr*omh
      shpe(1,18)=omropr*omh
      shpe(1,19)=omropr*oph
      shpe(1,20)=-omropr*oph
!
!     local derivatives of the shape functions: eta-derivative
!
      shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0
      shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0
      shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0
      shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0
      shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0
      shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0
      shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0
      shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0
      shpe(2, 9)=-omgopg*omr
      shpe(2,10)=omhmoph*opg*omr
      shpe(2,11)=omgopg*omr
      shpe(2,12)=omhmoph*omg*omr
      shpe(2,13)=-omgopg*opr
      shpe(2,14)=omhmoph*opg*opr
      shpe(2,15)=omgopg*opr
      shpe(2,16)=omhmoph*omg*opr
      shpe(2,17)=-omropr*omg
      shpe(2,18)=-omropr*opg
      shpe(2,19)=omropr*opg
      shpe(2,20)=omropr*omg
!
!     local derivatives of the shape functions: zeta-derivative
!
      shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0
      shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0
      shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0
      shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0
      shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0
      shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0
      shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0
      shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0
      shpe(3, 9)=-omgopg*omh
      shpe(3,10)=-omhoph*opg
      shpe(3,11)=-omgopg*oph
      shpe(3,12)=-omhoph*omg
      shpe(3,13)=omgopg*omh
      shpe(3,14)=omhoph*opg
      shpe(3,15)=omgopg*oph
      shpe(3,16)=omhoph*omg
      shpe(3,17)=omrmopr*omg*omh
      shpe(3,18)=omrmopr*opg*omh
      shpe(3,19)=omrmopr*opg*oph
      shpe(3,20)=omrmopr*omg*oph
!
!     computation of the derivative of the global
!     material coordinates w.r.t. the local coordinates
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,20
            xs(i,j)=xs(i,j)+xlag(i,k)*shpe(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant of the local
!     coordinates w.r.t. the global material coordinates
!
      dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)
      dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3)
      dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)
      xj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3
      xj=1.d0/xj
!
!     computation of the derivative of the global
!     spatial coordinates w.r.t. the local coordinates
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,20
            xs(i,j)=xs(i,j)+xeul(i,k)*shpe(j,k)
          enddo
        enddo
      enddo
!
      return
      end


      SUBROUTINE lcalc
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE Vnamecl2
      USE dkes_realspace, ONLY: diagl
      USE dkes_input, ONLY: lalpha
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      INTEGER, PARAMETER :: l1 = 2
      REAL(rprec), PARAMETER :: half = 0.5_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: l, ll
      REAL(rprec) :: ap, am
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: cinv
C-----------------------------------------------
c  This SUBROUTINE calculates l (degree of pitch-angle Legendre
c  polynomial) arrays that are stored once and reused each cmul,efield run.
      lap1 = lalpha + 1
      lam1 = lalpha - 1
      lam3 = lalpha - 3
      lam6 = lalpha - 6

      ALLOCATE (omgl(0:lap1), cols(lalpha), al1(lalpha), al2(lalpha),
     1   al3(lalpha), al4(lalpha), bl1(lalpha), bl2(lalpha),
     2   bl3(lalpha), bl4(lalpha), cl1(lalpha), cl2(lalpha),
     3   cl3(lalpha), cl4(lalpha), cols0(lap1), al01(lalpha),
     4   al02(lalpha), al03(lalpha), al04(lalpha), bl01(lalpha),
     5   bl02(lalpha), bl03(lalpha), bl04(lalpha), cl01(lalpha),
     6   cl02(lalpha), cl03(lalpha), cl04(lalpha), cinv(0:lap1),
     9   stat=l)
      IF (l .ne. 0) STOP 'allocation error in LCALC'

      omgl(0) = 0;   omgl(1) = 0;   cols0(1) = 0
      cinv(0) = 0;   cinv(1) = 0
      DO l = 2, lap1
         ll = l - 1
         omgl(l)  = half*ll/SQRT(4*ll*ll - one)
         cols0(l) = half*ll*l                                            !.5*l*(l+1)
         cinv(l)  = one/cols0(l)                                         !1/nu(l), l>0
      END DO

      DO l = 1, lalpha
         ll = l - 1
         ap = cinv(l+1)*omgl(l+1)**2
         am = cinv(l-1)*omgl(l)**2
!
!        coefficients of BMAT1 - BMAT6 comprising A(l) [multiplies f(l)]
!
         al01(l) = 4*(ap + am)
         al02(l) = ap*ll**2 + am*l**2
         al03(l) = cinv(l)
         al04(l) = 2*(am*l - ap*ll)
         bl01(l) = 2*cinv(l-1)*omgl(l)
         bl02(l) = 2*cinv(l)*omgl(l)
         bl03(l) = cinv(l-1)*l*omgl(l)
         bl04(l) =-cinv(l)*(ll - 1)*omgl(l)
         cl01(l) = cinv(l-1)*omgl(l-1)*omgl(l)                           !w(l) * w(l-1) /-nu(l-1)
!
!        coefficients of BMAT1 - BMAT6 comprising C-(l) [multiplies f(l-2)]
!
         cl02(l) =-(ll - 2)*l*cl01(l)
         cl03(l) = 2*l*cl01(l)
         cl04(l) =-2*(ll - 2)*cl01(l)

         cl01(l) = 4*cl01(l)

      END DO

      DEALLOCATE (cinv)

c   Matrix elements for particle conservation. These are the coefficients
c   of Vf(l=0) (l=0,1 contributions), and are related by -TRANSPOSE to V(l=0) f
c   RecALL that -efield (Bsubv d/du - Bsubu d/dv) is the electric drift term

      diagl(:,:,1)  =-2*omgl(l1) * diagl(:,:,1)
      diagl(:,:,2)  = 2*omgl(l1) * diagl(:,:,2)

      END SUBROUTINE lcalc


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

SUBROUTINE Ylm_sub(xx,yy,zz,lm,Ylm)
!$ use omp_lib

real(8),intent(IN) :: xx,yy,zz
integer,intent(IN) :: lm
real(8) :: rrrr
real(8) :: Ylm

select case( lm )

case(1)  ; Ylm=1.d0
case(2)  ; Ylm=yy
case(3)  ; Ylm=zz
case(4)  ; Ylm=xx
case(5)  ; Ylm=sqrt(3.d0)*xx*yy                         ! lm=5  (2 -2)
case(6)  ; Ylm=sqrt(3.d0)*yy*zz                         ! lm=6  (2 -1)
case(7)  ; Ylm=(2*zz*zz-xx*xx-yy*yy)/2.d0               ! lm=7  (2 0)
case(8)  ; Ylm=sqrt(3.d0)*xx*zz                         ! lm=8  (2 1)
case(9)  ; Ylm=sqrt(3.d0/4.d0)*(xx*xx-yy*yy)            ! lm=9  (2 2)
case(10) ; Ylm=sqrt(5.d0/8.d0)*yy*(3*xx*xx-yy*yy)       ! lm=10 (3 -3)
case(11) ; Ylm=sqrt(15.d0)*xx*yy*zz                     ! lm=11 (3 -2)
case(12) ; Ylm=sqrt(3.d0/8.d0)*yy*(4*zz*zz-xx*xx-yy*yy) ! lm=12 (3 -1)
case(13) ; Ylm=zz*(2*zz*zz-3*xx*xx-3*yy*yy)/2.d0        ! lm=13 (3 0)
case(14) ; Ylm=sqrt(3.d0/8.d0)*xx*(4*zz*zz-xx*xx-yy*yy) ! lm=14 (3 1)
case(15) ; Ylm=sqrt(15.d0/4.d0)*zz*(xx*xx-yy*yy)        ! lm=15 (3 2)
case(16) ; Ylm=sqrt(5.d0/8.d0)*xx*(xx*xx-3*yy*yy)       ! lm=16 (3 3)

! for Hartree routine

case(17)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(35.d0)/2.d0*xx*yy*(xx**2-yy**2)
case(18)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(35.d0/8.d0)*yy*zz*(3*xx**2-yy**2)
case(19)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(5.d0)/2.d0*xx*yy*(7*zz**2-1)
case(20)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(5.d0/8.d0)*yy*(7*zz**3-3*zz)
case(21)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*(35*zz**4-30*zz**2+3.d0)/8.d0
case(22)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(5.d0/8.d0)*xx*(7*zz**3-3*zz)
case(23)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(5.d0)/4.d0*(7*zz**2-1)*(xx**2-yy**2)
case(24)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(35.d0/8.d0)*zz*xx*(xx**2-3*yy**2)
case(25)
   rrrr=(xx**2+yy**2+zz**2)**2
   Ylm=rrrr*sqrt(35.d0)/8.d0*(xx**4+yy**4-6*xx**2*yy**2)

end select

END SUBROUTINE Ylm_sub


module random
! module provides an interface to call random_numbers and various other random distributions
!
!
    use vector_class
    use constants, only : wp

    implicit none

    private
    public  :: ran2, ranu, rang, randint, init_rng

    contains

        subroutine init_rng(input_seed, fwd)
        ! initiate RNG state with reproducable state

            implicit none

            integer, optional, intent(IN) :: input_seed(:)
            logical, optional, intent(IN) :: fwd

            integer, allocatable :: seed(:)
            integer              :: n, i
            logical              :: ffwd
            real(kind=wp)        :: a

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

            if(present(input_seed))then
                seed = 0
                seed = input_seed
            else
                seed = 1234567
            end if

            if(present(fwd))then
                ffwd = fwd
            else
                ffwd = .true.
            end if

            call random_seed(put=seed)

            !fast forward rng state 100 times to avoid any potential bad seeds
            if(ffwd)then
                call random_seed(get=seed)
                do i = 1, 100
                    a = ran2()
                    call random_seed(get=seed)
                end do
            end if
        end subroutine init_rng

        function ran2() result(res)
        !wrapper for call random number

            implicit none

            real(kind=wp) :: res

            call random_number(res)

        end function ran2

        function ranu(a, b) result(res)
        !uniformly sample in range[a, b)

            implicit none

            real(kind=wp) :: res
            real(kind=wp), intent(IN) :: a, b

            res = a + ran2() * (b - a)

        end function ranu

        subroutine rang(x, y, avg, sigma)
        ! sample a 2D Guassian distribution

            implicit none

            real(kind=wp), intent(IN)  :: avg, sigma
            real(kind=wp), intent(OUT) :: x,y

            real(kind=wp) :: s, tmp

            s = 1._wp

            do while(s >= 1._wp)
                x = ranu(-1._wp, 1._wp)
                y = ranu(-1._wp, 1._wp)
                s = y**2 + x**2
            end do

            tmp = x*sqrt(-2._wp*log(s)/s)
            x = avg + sigma*tmp

            tmp = y*sqrt(-2._wp*log(s)/s)
            y = avg + sigma*tmp

        end subroutine rang

        integer function randint(a, b)

            implicit none

            integer, intent(IN) :: a, b

            randint = a + floor((b + 1 - a)*ran2())

        end function randint

end module random

! Program test

!     use random, only : randint

!     implicit none

!     integer :: i

!     do i = 1, 100
!         print*,randint(0, 5)
!     end do

! end program test


! Demonstrates parametric polymorphism through functions-calling-functions.
program squarePoly
  implicit none
  real :: x
  real :: y
  != unit(m) :: a
  real :: a
  != unit(s) :: b
  real :: b
  x = squareP(a)
  y = squareP(b)
  contains
  real function square(n)
    real :: n
    square = n * n
  end function
  real function squareP(m)
    real :: m
    squareP = square(m)
  end function
end program


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_LSTR_test_deck
   USE GALAHAD_LSTR_DOUBLE                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, zero = 0.0_working
   INTEGER, PARAMETER :: n = 50, m = 2 * n            ! problem dimensions
   INTEGER, PARAMETER :: m2 = 50, n2 = 2 * m2         ! 2nd problem dimensions
   INTEGER :: i, pass, problem, nn
   REAL ( KIND = working ), DIMENSION( n ) :: X, V
   REAL ( KIND = working ), DIMENSION( m ) :: U
   REAL ( KIND = working ), DIMENSION( n2 ) :: X2, V2
   REAL ( KIND = working ), DIMENSION( m2 ) :: U2
   REAL ( KIND = working ), DIMENSION( 0 ) :: X0, V0, U0
   REAL ( KIND = working ) :: radius

   TYPE ( LSTR_data_type ) :: data
   TYPE ( LSTR_control_type ) :: control
   TYPE ( LSTR_inform_type ) :: inform

!  ==============
!  Normal entries
!  ==============

   WRITE( 6, "( /, ' ==== normal exits ====== ', / )" )

! Initialize control parameters

   OPEN( UNIT = 23, STATUS = 'SCRATCH' )
   DO problem = 1, 2
     DO pass = 1, 10
       IF ( pass /= 4 .AND. pass /= 7 .AND. pass /= 8 .AND. pass /= 9 )         &
       CALL LSTR_initialize( data, control )
       control%steihaug_toint = .FALSE.
!      control%steihaug_toint = .TRUE.
!      control%print_level = 1
!      control%itmax = 50
!      control%extra_vectors = 100
       control%error = 23 ; control%out = 23 ; control%print_level = 10
       inform%status = 1
       radius = one
       IF ( pass == 2 ) radius = 10.0_working
       IF ( pass == 3 ) radius = 0.0001_working
       IF ( pass == 4 ) THEN
         control%fraction_opt = 0.99_working
       END IF
       IF ( pass == 5 ) THEN
         control%fraction_opt = 0.99_working
         control%extra_vectors = 1
       END IF
       IF ( pass == 6 ) THEN
         control%fraction_opt = 0.99_working
         control%extra_vectors = 100
       END IF
       IF ( pass == 7 ) THEN
         control%fraction_opt = 0.99_working
         control%extra_vectors = 100
       END IF
       IF ( pass == 8 ) THEN
         control%fraction_opt = 0.99_working
         control%itmax_on_boundary = 1
       END IF
       IF ( pass == 9 ) THEN
         inform%status = 5
         radius = 0.0001_working
         control%prefix = '"LSTR: "     '
!        control%error = 6 ; control%out = 6 ; control%print_level = 1
!        radius = 10.0_working
       END IF
       IF ( pass == 10 ) THEN
         control%prefix = '"LSTR: "     '
!        control%error = 6 ; control%out = 6 ; control%print_level = 1
!        radius = 10.0_working
       END IF

       IF ( problem == 1 ) THEN
         U = one
         DO
           CALL LSTR_solve( m, n, radius, X, U, V, data, control, inform )

           SELECT CASE( inform%status )  ! Branch as a result of inform%status
           CASE( 2 )                     !  Form u <- u + A * v
             U( : n ) = U( : n ) + V
             DO i = 1, n
               U( n + i ) = U( n + i ) + i * V( i )
             END DO
           CASE( 3 )                     !  Form v <- v + A^T * u
             V = V + U( : n )            !  A^T = ( I : diag(1:n) )
             DO i = 1, n
               V( i ) = V( i ) + i * U( n + i )
             END DO
           CASE ( 4 )                    ! Restart
              U = one
           CASE DEFAULT
              EXIT
           END SELECT
         END DO
       ELSE
         U2 = one
         DO
           CALL LSTR_solve( m2, n2, radius, X2, U2, V2, data, control, inform )

           SELECT CASE( inform%status )  ! Branch as a result of inform%status
           CASE( 2 )                     !  Form u <- u + A * v
             U2 = U2 + V2( : n )         !  A = ( I : diag(1:n) )
             DO i = 1, n
               U2( i ) = U2( i ) + i * V2( n + i )
             END DO
           CASE( 3 )                     !  Form v <- v + A^T * u
             V2( : n ) = V2( : n ) + U2
             DO i = 1, n
               V2( n + i ) = V2( n + i ) + i * U2( i )
             END DO
           CASE ( 4 )                    ! Restart
              U2 = one
           CASE DEFAULT
              EXIT
           END SELECT
         END DO
       END IF
       WRITE( 6, "( ' problem ', I1, ' pass ', I3,                              &
      &     ' LSTR_solve exit status = ', I6 )" ) problem, pass, inform%status
!      WRITE( 6, "( ' its, solution and Lagrange multiplier = ', I6, 2ES12.4 )")&
!                inform%iter + inform%iter_pass2, f, inform%multiplier
      IF ( pass /= 8 )                                                          &
        CALL LSTR_terminate( data, control, inform ) ! delete internal workspace
     END DO
   END DO

!  =============
!  Error entries
!  =============

   WRITE( 6, "( /, ' ==== error exits ====== ', / )" )

! Initialize control parameters

   DO pass = 1, 5
      radius = one
      CALL LSTR_initialize( data, control )
      control%steihaug_toint = .FALSE.
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      inform%status = 1
      U = one
      IF ( pass == 1 ) control%steihaug_toint = .TRUE.
      IF ( pass == 2 ) control%itmax = 0
      IF ( pass == 3 ) inform%status = 0
      IF ( pass == 4 ) nn = 0
      IF ( pass == 5 ) radius = - one

!  Iteration to find the minimizer

      DO
        IF ( pass /= 4 ) THEN
          CALL LSTR_solve( m, n, radius, X, U, V, data, control, inform )
        ELSE
          CALL LSTR_solve( 0, nn, radius, X0, U0, V0, data, control, inform )
        END IF

        SELECT CASE( inform%status )  ! Branch as a result of inform%status
        CASE( 2 )                     !  Form u <- u + A * v
          U( : n ) = U( : n ) + V
          DO i = 1, n
            U( n + i ) = U( n + i ) + i * V( i )
          END DO
        CASE( 3 )                     !  Form v <- v + A^T * u
          V = V + U( : n )            !  A^T = ( I : diag(1:n) )
          DO i = 1, n
            V( i ) = V( i ) + i * U( n + i )
          END DO
        CASE ( 4 )                    ! Restart
           U = one
        CASE DEFAULT
           EXIT
        END SELECT
      END DO
      WRITE( 6, "( ' pass ', I3, ' LSTR_solve exit status = ', I6 )" )         &
             pass, inform%status
      CALL LSTR_terminate( data, control, inform ) !  delete internal workspace
   END DO
   CLOSE( unit = 23 )

   END PROGRAM GALAHAD_LSTR_test_deck


module random

  implicit none (type, external)

contains

impure elemental integer function randint(lo, hi)
integer, intent(in) :: lo, hi
real :: r

call random_number(r)

randint = floor(r * (hi + 1 - lo)) + lo

end function randint

end module random


module mod_julfort

    use iso_fortran_env

    implicit none

contains

    function dot(n, arrx, arry)
        ! arguments
        integer(int64), intent(in) :: n
        real(real64), intent(in) :: arrx(n), arry(n)

        ! returns
        real(real64) :: arrz(n), dot

        arrz(:) = arrx(:)*arry(:)
        dot = sum(arrz)

    end function dot

    subroutine mult_arr(n, arr, x)
        ! arguments
        integer(int64), intent(in) :: n
        real(real64), intent(in out) :: arr(n)
        real(real64), intent(in) :: x

        arr(:) = arr(:) * x + x

    end subroutine mult_arr

end module

module mod_julfort_wrapper

    use iso_c_binding

    use :: mod_julfort

    implicit none

contains

    subroutine mult_arr_wrapper(n, arr, x) bind(C, name="mult_arr")
        ! arguments
        integer(c_long), intent(in) :: n
        real(c_double), intent(in out) :: arr(n)
        real(c_double), intent(in) :: x

        call mult_arr(n, arr, x)

    end subroutine mult_arr_wrapper

end module


!----------------------------------------------------------------------
! Module: handy_mod
!> Purpose: handy module variables
!>

!> Author: Benjamin Menetrier
!>

!> Licensing: this code is distributed under Apache License 2.0
!----------------------------------------------------------------------
module handy_mod

implicit none

! Namelist variables
character(1024) :: society !< Society type
character(1024) :: config  !< Configuration
character(1024) :: scheme  !< Numerical scheme
integer :: nt              !< Integration time (years)
integer :: dtrat           !< Integration step ratio (per years)
integer :: lpos            !< Positivity option (0: nothing to do, 1: stop when negative, 2: force to 0 when negative)
namelist/handy_param/society,config,scheme,nt,dtrat,lpos

! Handy state type
type statetype
   ! Variable
   real :: xc  !< Commoners
   real :: xe  !< Elite
   real :: y   !< Nature
   real :: w   !< Accumulated wealth
end type statetype

! Handy parameters type
type partype
   ! Variable
   real :: alpham
   real :: alphamax
   real :: betac
   real :: betae
   real :: s
   real :: rho
   real :: gamma
   real :: lambda
   real :: kappa
   real :: delta
   logical :: nature_switch
end type partype

interface operator (+)
   module procedure add
end interface

interface operator (*)
   module procedure mul
end interface

interface operator (/)
   module procedure div
end interface

contains

!----------------------------------------------------------------------
! Function: add
!> Purpose: add states
!----------------------------------------------------------------------
type(statetype) function add(state1,state2)

implicit none

! Passed arguments
type(statetype),intent(in) :: state1 !< First state
type(statetype),intent(in) :: state2 !< Second state

! Add data
add%xc = state1%xc + state2%xc
add%xe = state1%xe + state2%xe
add%y = state1%y + state2%y
add%w = state1%w + state2%w

end function add

!----------------------------------------------------------------------
! Function: add
!> Purpose: multiply state by a real
!----------------------------------------------------------------------
type(statetype) function mul(r,state)

implicit none

! Passed arguments
real,intent(in) :: r !< Real factor
type(statetype),intent(in) :: state !< State

! Multiply data
mul%xc = r*state%xc
mul%xe = r*state%xe
mul%y = r*state%y
mul%w = r*state%w

end function mul

!----------------------------------------------------------------------
! Function: div
!> Purpose: divide state by a real
!----------------------------------------------------------------------
type(statetype) function div(state,d)

implicit none

! Passed arguments
type(statetype),intent(in) :: state !< State
real,intent(in) :: d !< Real divider

! Divide data
div%xc = state%xc/d
div%xe = state%xe/d
div%y = state%y/d
div%w = state%w/d

end function div

end module handy_mod


program bits_01
use iso_fortran_env, only: int32, int64
implicit none

if (ibclr(3_int32, 0) /= 2_int32) error stop
if (ibclr(4_int64, 1) /= 4_int64) error stop

if (ibset(1_int32, 2) /= 5_int32) error stop
if (ibset(2_int64, 3) /= 10_int64) error stop

if (ieor(16_int32, 2_int32) /= 18_int32) error stop
if (ieor(31_int64, 3_int64) /= 28_int64) error stop

end program


        subroutine idz_sfrmi(l,m,n,w)
c
c       initializes data for the routine idz_sfrm.
c
c       input:
c       l -- length of the transformed (output) vector
c       m -- length of the vector to be transformed
c
c       output:
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m
c       w -- initialization array to be used by routine idz_sfrm
c
c
c       glossary for the fully initialized w:
c
c       w(1) = m
c       w(2) = n
c       w(3) is unused
c       w(4:3+m) stores a permutation of m objects
c       w(4+m:3+m+l) stores the indices of the l outputs which idz_sfft
c                    calculates
c       w(4+m+l) = address in w of the initialization array
c                  for idz_random_transf
c       w(5+m+l:int(w(4+m+l))-1) stores the initialization array
c                                for idz_sfft
c       w(int(w(4+m+l)):19*m+70) stores the initialization array
c                                for idz_random_transf
c
c
c       _N.B._: n is an output of the present routine;
c               this routine changes n.
c
c
        implicit none
        integer l,m,n,idummy,nsteps,keep,lw,ia
        complex*16 w(21*m+70)
c
c
c       Find the greatest integer less than or equal to m
c       which is a power of two.
c
        call idz_poweroftwo(m,idummy,n)
c
c
c       Store m and n in w.
c
        w(1) = m
        w(2) = n
        w(3) = 0
c
c
c       Store random permutations of m and n objects in w.
c
        call id_randperm(m,w(4))
        call id_randperm(n,w(4+m))
c
c
c       Store the address within w of the idz_random_transf_init
c       initialization data.
c
        ia = 5+m+l+2*l+15+3*n
        w(4+m+l) = ia
c
c
c       Store the initialization data for idz_sfft in w.
c
        call idz_sffti(l,w(4+m),n,w(5+m+l))
c
c
c       Store the initialization data for idz_random_transf_init in w.
c
        nsteps = 3
        call idz_random_transf_init(nsteps,m,w(ia),keep)
c
c
c       Calculate the total number of elements used in w.
c
        lw = 4+m+l+2*l+15+3*n + 3*nsteps*m+2*m+m/4+50
c
        if(19*m+70 .lt. lw) then
          call prinf('lw = *',lw,1)
          call prinf('19m+70 = *',19*m+70,1)
          stop
        endif
c
c
        return
        end
c
c
c
c


      SUBROUTINE ERO (ROTANG, XFRMT)

      REAL XFRMT (3,3), SN, CS, ROTANG

      CALL IDMAT (3, XFRMT)
      SN = SIN(ROTANG)
      CS = COS(ROTANG)
      XFRMT (1,1) =  CS
      XFRMT (2,2) =  CS
      XFRMT (1,2) = -SN
      XFRMT (2,1) =  SN

      END


module fqs_conversions

    use fqs_types,        only: wp
    use fqs_vector,       only: vect_t
    use fqs_quaternion,   only: quat_t
    use fqs_euler_angle,  only: euler_t
    use fqs_axis_angle,   only: axis_angle_t
    use fqs_constants,    only: pi
    use fqs_utility,      only: check_division

    implicit none
    private

    public :: quat_from_vect
    public :: quat_from_euler
    public :: quat_from_axis_angle
    public :: vect_from_quat
    public :: axis_angle_from_quat
    public :: axis_angle_from_euler
    public :: euler_from_quat
    public :: euler_from_axis_angle

contains

    elemental function quat_from_vect(v) result(q)
        type(vect_t), intent(in) :: v
        type(quat_t)             :: q
        q % w = 0
        q % x = v % x
        q % y = v % y
        q % z = v % z
    end function quat_from_vect

    elemental function vect_from_quat(q) result(v)
        type(quat_t), intent(in) :: q
        type(vect_t)             :: v
        v % x = q % x
        v % y = q % y
        v % z = q % z
    end function vect_from_quat

    elemental function quat_from_euler(angles) result(q)
        type(euler_t), intent(in) :: angles
        type(quat_t)              :: q

        ! Local variables
        real(wp)                  :: ch, ca, cb
        real(wp)                  :: sh, sa, sb
        ch = cos(0.5_wp * (angles % heading))
        ca = cos(0.5_wp * (angles % attitude))
        cb = cos(0.5_wp * (angles % bank))
        sh = sin(0.5_wp * (angles % heading))
        sa = sin(0.5_wp * (angles % attitude))
        sb = sin(0.5_wp * (angles % bank))
        q % w = (ch * ca * cb) - (sh * sa * sb)
        q % x = (sh * sa * cb) + (ch * ca * sb)
        q % y = (sh * ca * cb) + (ch * sa * sb)
        q % z = (ch * sa * cb) - (sh * ca * sb)
    end function quat_from_euler

    elemental function quat_from_axis_angle(axis_angle) result(q)
        type(axis_angle_t), intent(in) :: axis_angle
        type(quat_t)                   :: q

        q % w = cos( 0.5_wp * (axis_angle % angle) )
        q % x = (axis_angle % axis % x) * sin(0.5_wp * (axis_angle % angle))
        q % y = (axis_angle % axis % y) * sin(0.5_wp * (axis_angle % angle))
        q % z = (axis_angle % axis % z) * sin(0.5_wp * (axis_angle % angle))
    end function quat_from_axis_angle

    elemental function axis_angle_from_quat(q) result(axis_angle)
        type(quat_t), intent(in)  :: q
        type(axis_angle_t)        :: axis_angle

        ! Local variables
        real(wp)     :: norm
        real(wp)     :: denom
        type(quat_t) :: qnorm

        norm = q % norm()
        if ( check_division(q, norm) ) then
            qnorm = q / norm
            axis_angle % angle = 2.0_wp*acos(qnorm % w)
            axis_angle % axis = vect_from_quat(qnorm)
            denom = sqrt(1.0_wp - (qnorm % w)*(qnorm % w))
            if ( check_division(axis_angle % axis, denom) ) then
                axis_angle % axis = ( (axis_angle % axis) ) / denom
            else
                axis_angle % axis = vect_t(1.0_wp, 0.0_wp, 0.0_wp)
            end if
        else
            axis_angle % angle = 0.0_wp
            axis_angle % axis = vect_t(1.0_wp, 0.0_wp, 0.0_wp)
        end if
    end function axis_angle_from_quat

    elemental function axis_angle_from_euler(euler) result(axis_angle)
        type(euler_t), intent(in) :: euler
        type(axis_angle_t)        :: axis_angle

        ! Local variables
        type(quat_t) :: q

        q = quat_from_euler(euler)
        axis_angle = axis_angle_from_quat(q)
    end function axis_angle_from_euler

    elemental function euler_from_quat(q,thresh_input) result(angles)
        type(quat_t), intent(in)       :: q
        real(wp), intent(in), optional :: thresh_input
        type(euler_t)                  :: angles

        ! Local variables
        real(wp), parameter            :: thresh_default = 0.4999_wp
        real(wp)                       :: thresh
        real(wp)                       :: test
        real(wp)                       :: sum2
        real(wp)                       :: qww
        real(wp)                       :: qwx
        real(wp)                       :: qwy
        real(wp)                       :: qwz
        real(wp)                       :: qxx
        real(wp)                       :: qxy
        real(wp)                       :: qxz
        real(wp)                       :: qyy
        real(wp)                       :: qyz
        real(wp)                       :: qzz

        if (.not. present(thresh_input)) then
            thresh = thresh_default
        end if

        ! Compute products
        qww = (q % w) * (q % w)
        qwx = (q % w) * (q % x)
        qwy = (q % w) * (q % y)
        qwz = (q % w) * (q % z)
        qxx = (q % x) * (q % x)
        qxy = (q % x) * (q % y)
        qxz = (q % x) * (q % z)
        qyy = (q % y) * (q % y)
        qyz = (q % y) * (q % z)
        qzz = (q % z) * (q % z)

        ! Values for checking for sigularity at north or south pole
        sum2 = qww + qxx + qyy + qzz
        test = qxy + qwz

        if ( abs(test) > ( thresh * sum2 ) ) then
            ! Sigularity at north/south poles
            angles % heading  = 2.0_wp * sign( 1.0_wp, test ) * atan2( q % x, q % w )
            angles % attitude = 0.5_wp * sign( 1.0_wp, test ) * pi
            angles % bank     = 0.0_wp
        else
            angles % heading  = atan2( 2.0_wp * (qwy - qxz), qxx - qyy - qzz + qww )
            angles % attitude = asin(( 2.0_wp * test) / sum2)
            angles % bank     = atan2( 2.0_wp * (qwx - qyz), -qxx + qyy - qzz + qww )
        end if
    end function euler_from_quat

    elemental function euler_from_axis_angle(axis_angle) result(euler)
        type(axis_angle_t), intent(in) :: axis_angle
        type(euler_t)                  :: euler

        !Local variables
        type(quat_t) :: q

        q = quat_from_axis_angle(axis_angle)
        euler = euler_from_quat(q)
    end function euler_from_axis_angle

end module fqs_conversions


*     SB08ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DAMAX
      PARAMETER        ( DAMAX = 10 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 5*DAMAX+5 )
*     .. Local Scalars ..
      DOUBLE PRECISION RES
      INTEGER          DA, I, INFO
      CHARACTER*1      ACONA
*     .. Local Arrays ..
      DOUBLE PRECISION A(DAMAX+1), DWORK(LDWORK), E(DAMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB08ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      READ ( NIN, FMT = '()' )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = * ) DA, ACONA
      IF ( DA.LE.-1 .OR. DA.GT.DAMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) DA
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,DA+1 )
*        Compute the spectral factorization of the given polynomial.
         CALL SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( LSAME( ACONA, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 0, DA
                  WRITE ( NOUT, FMT = 99995 ) I, A(I+1)
   20          CONTINUE
               WRITE ( NOUT, FMT = * )
            END IF
            WRITE ( NOUT, FMT = 99996 )
            DO 40 I = 0, DA
               WRITE ( NOUT, FMT = 99995 ) I, E(I+1)
   40       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) RES
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' SB08ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08ND = ',I2)
99997 FORMAT (' The coefficients of the polynomial B(z) are ',//' powe',
     $       'r of z     coefficient ')
99996 FORMAT (' The coefficients of the spectral factor E(z) are ',
     $       //' power of z     coefficient ')
99995 FORMAT (2X,I5,9X,F9.4)
99994 FORMAT (/' RES = ',1P,E8.1)
99993 FORMAT (/' DA is out of range.',/' DA = ',I5)
      END


program main

        ! Written by: Pratanu Roy
        ! Start Date: Dec 22, 2013
        ! Last Modified : Aug 22, 2017
        ! This program solves the 2D Navier-Stokes equations
        ! Domain = [0, Lx] x [0, Ly]
        ! Use multigrid technique with parallelization

        use global_variables
        use parameters
        use multigrid_levels
        use parallel_variables
        use kind_parameters
        implicit none
        include "mpif.h"

        integer:: ilevel
        real(kind=dp) :: total_cpu_time

        alphapc = 1.0d0
        alpha_mg = 0.8d0

        call cpu_time(tstart)

        call MPI_INIT(ierr)

        if (ierr .ne. MPI_SUCCESS) print *, 'Error Initializing ...'

        call MPI_COMM_SIZE(MPI_COMM_WORLD, numtasks, ierr)

        if (ierr .ne. MPI_SUCCESS) print *, 'Error in number of processors ...'

        call MPI_COMM_RANK(MPI_COMM_WORLD, taskid, ierr)

        if (ierr .ne. MPI_SUCCESS) print *, 'Error in taskid ...'

        if (taskid .eq. root) write(*,*) 'Number of processor = ', numtasks

        ! Read data by root processor (processor no. 0)

        call read_data

        ! Set Lx and Ly from the input file

        xmin = prob_lo(1)
        xmax = prob_hi(1)

        ymin = prob_lo(2)
        ymax = prob_hi(2)

        Lx = xmax - xmin
        Ly = ymax - ymin

        ! Broadcast input data to all the processors

        call broadcast_data

        ! Set the max indices for u, v, p, t

        ipmax = icv + 2
        jpmax = jcv + 2

        call setup_mg_variables(ipmax, jpmax, num_level)
        call setup_mg_geometry

        ! For non-periodic or regular boundary condition set the boundary processor index

        inextid = taskid + 1
        iprevid = taskid - 1

        start_x = mg_level(num_level)%xi
        end_x = mg_level(num_level)%xf

        !! For periodic boundary condition
        !! The leftmost processor sends the left boundary values to the right boundary value of rightmost procesor and vice versa
        !
        !if ( taskid .eq. root) then
        !
        ! iprevid = numtasks-1
        !
        !else if (taskid .eq. numtasks - 1) then
        !
        ! inextid = 0
        !
        !end if
        !
        ! For usual boundary condition
        ! The leftmost processor has no left neighbour and the rightmost processor has no right neighbour

        if ( taskid .eq. root) then

                iprevid = MPI_PROC_NULL

        else if (taskid .eq. numtasks-1) then

                inextid = MPI_PROC_NULL

        end if

        if (parallel_debug .and. taskid .eq. root) write(*,*) 'start_x ', start_x
        if (parallel_debug .and. taskid .eq. root) write(*,*) 'end_x ', end_x
        if (parallel_debug .and. taskid .eq. root) write(*,*) 'taskid = ', taskid, 'iprevid =', iprevid, 'inextid = ', inextid

        call initial_conditions(num_level)

        if (taskid .eq. root) then

                call prelim_data

        end if

        !tcounter = 0
        total_cpu_time  = 0.0d0

        !do time = 0.0d0, max_time, time_step

        tstart = MPI_WTime()

        residualu = 1.0d0
        residualv = 1.0d0
        residualp = 1.0d0
        residualt = 0.0d0

        is_converged = 0

        do ilevel = 1,num_level

        !!!! This part is for unsteady simulations. Currently turned off
        !!!! ------------------------------------------------------------
        if (1 .eq. 0) then

        mg_level(ilevel)%u0(:,:) = mg_level(ilevel)%u(:,:)
        mg_level(ilevel)%v0(:,:) = mg_level(ilevel)%v(:,:)
        !mg_level(ilevel)%t0(:,:) = mg_level(ilevel)%t(:,:)
        !    mg_level(ilevel)%Tprev(:,:) = mg_level(ilevel)%T(:,:)
        mg_level(ilevel)%uf0(:,:) = mg_level(ilevel)%uf(:,:)
        mg_level(ilevel)%vf0(:,:) = mg_level(ilevel)%vf(:,:)

        call unsteady_functions(mg_level(ilevel)%ap_zero, &
                mg_level(ilevel)%u0,      &
                mg_level(ilevel)%v0,      &
                mg_level(ilevel)%f_uvel,      &
                mg_level(ilevel)%f_vvel,      &
                mg_level(ilevel)%aw,      &
                mg_level(ilevel)%ae,      &
                mg_level(ilevel)%as,      &
                mg_level(ilevel)%an,      &
                mg_level(ilevel)%p_uf,      &
                mg_level(ilevel)%p_vf,      &
                mg_level(ilevel)%su,      &
                mg_level(ilevel)%sv,      &
                mg_level(ilevel)%fu,      &
                mg_level(ilevel)%fv,      &
                mg_level(ilevel)%rho,      &
                mg_level(ilevel)%dx,      &
                mg_level(ilevel)%dy,      &
                mg_level(ilevel)%nx,      &
                mg_level(ilevel)%ny,      &
                mg_level(ilevel)%xi,      &
                mg_level(ilevel)%xf       )
        end if
        !!!!------------------------------------------------------------
        call properties( mg_level(ilevel)%T,    &
                mg_level(ilevel)%rho,    &
                mg_level(ilevel)%mu,    &
                mg_level(ilevel)%rho_uf,    &
                mg_level(ilevel)%rho_vf,    &
                mg_level(ilevel)%mu_uf,    &
                mg_level(ilevel)%mu_vf,    &
                mg_level(ilevel)%kcond,    &
                mg_level(ilevel)%cp,   &
                mg_level(ilevel)%gammat,   &
                mg_level(ilevel)%nx,   &
                mg_level(ilevel)%ny,   &
                mg_level(ilevel)%xi,     &
                mg_level(ilevel)%xf      )

        end do

        ! Start from the coarses grid for Full Multigrid (FMG) method.

        ilevel = 1

        do iteration = 1,itermax

        call steady_solver_mg(ilevel)
        call monitor_residuals

        call check_convergence

        if (is_converged) exit

        !    call steady_solver_sg

        end do

        tcounter = tcounter + 1

        if (taskid .eq. root) then

                write(*,*) 'time step = ', time

        end if

        tend = MPI_WTime()
        if (parallel_debug) write(*,*) 'Total time = ', tend-tstart, 'secs'
        total_cpu_time = total_cpu_time + (tend-tstart)

        !end do

        call write_data(num_level)

        if (taskid .eq. root .and. debug) then

                call print_results(ipmax, jpmax, start_x, end_x, u, v, p, uf, vf, xp, yp)

        end if

        call deallocate_mg_variables()

        if (taskid .eq. root) then
                write(*,*) 'taskid = ', taskid, 'End of program'
                write(*,*) 'total CPU time = ', total_cpu_time

                !write(*,*) 'Communication time = ', communication_time, 'secs'
                !write(*,*) 'Computation time = ', (tend-tstart) - communication_time, 'secs'

        end if

        call MPI_FINALIZE(ierr)

end program main


c     prog4
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   demonstrate singular value analysis.
c
      dimension a(15,5),b(15),sing(15)
      data names/1h /
c
      read (5,10) ((a(i,j),j=1,5),b(i),i=1,15)
      write (6,20)
      write (6,30) ((a(i,j),j=1,5),b(i),i=1,15)
      write (6,40)
c
      call sva (a,15,15,5,15,b,sing,names,1,d)
c
      stop
   10 format (6f12.0)
   20 format (46h1prog4.    demonstrate singular value analysis/53h list
     1ing of input matrix, a, and vector, b, follows..)
   30 format (1h /(5f12.8,f20.4))
   40 format (1h1)
      end


	include 'VICMAIN_FOR'
	subroutine main44

c  NIMSR2IOF:   convert a NIMS radiance cube to IOF ( = pi * I / F(Solar) ),
c  using the solar flux in the label.

c   2mar98 -lwk- initial version
c  27mar98 -lwk- fix processing of "special values"
c  15nov00 -lwk- check NS against buffer size
c  14nov02 -lwk- added FORMAT to xlget call for unix port

	parameter (maxl = 10000)		! max. line length
	parameter (ntasks=3)		! # of valid TASKs for label
	character*3 org
	character*4 fmt
	character*132 pbuf
	character*8 tasks(ntasks)/ 'NIMSCMM2', 'VISIS2', 'NIMSCMM'/,
	1 task
	real*4 wav(408), sflux(408), obuf(maxl)
	real*8 xpi/3.1415926536/
	real*4 valid_min/-1.7014101e38/
	logical nosv, xvptst

	call xvmessage('NIMSR2IOF version 2019-11-05',' ')

c  open input cube and check format:
	call xvunit( inp, 'INP', 1, i,' ')
	call xvopen( inp, i, 'OPEN_ACT', 'SA', 'IO_ACT', 'SA',' ')
	call xvget( inp, i, 'NL', nl, 'NS', ns, 'NB', nb, 'ORG', org,
	1 'FORMAT', fmt,' ')
	if (fmt.ne.'REAL') call mabend(' ** input cube must be Real **')
	if (org.ne.'BSQ') call mabend(' ** only BSQ is supported **')
	if (ns.gt.maxl) call mabend(' ** NS exceeds buffer size **')

c  get the Solar Flux from the label:
	do i=1,ntasks
	  task = tasks(i)
	  call xlget( inp, 'HISTORY', 'SOLAR_F', sflux, ist, 'NELEMENT',
	1  -1, 'NRET', nb0, 'FORMAT', 'REAL', 'HIST', task, ' ')
	  if (ist.eq.1) go to 10
	enddo
	if (ist.ne.1) call mabend(' ** no Solar Flux in label **')
10	if (nb0.ne.nb) call mabend(' ** Solar Flux has wrong length **')

c  open the output file
	call xvunit( iout, 'OUT', 1, i,' ')
	call xvopen( iout, i, 'U_NL', nl, 'U_NS', ns, 'U_NB', nb, 'OP',
	1  'WRITE', 'O_FORMAT', 'REAL', 'U_FORMAT', 'REAL', 'OPEN_ACT', 'SA',
	2  'IO_ACT', 'SA',' ')

	nosv = xvptst('NOSPCVAL')

c  main processing:
	do ib = 1,nb
	  do il = 1,nl
	    call xvread( inp, obuf, i, ' ')
	    do is = 1,ns
	      if (obuf(is).lt.valid_min) then
		if (nosv) obuf(is) = 0.0
	      else
		obuf(is) = obuf(is)*xpi/sflux(ib)
	      endif
	    enddo
	    call xvwrit( iout, obuf, i, ' ')
	  enddo
	enddo

	call xvclose( inp, i,' ')
	call xvclose( iout, i,' ')

	return
	end


! written by jxzou at 20180406: construct part of or all virtual orbitals using the PAO (projected atomic orbitals)
! updated by jxzou at 20191215: simplify code

! This subroutine is designed to be imported as a module by Python.
!
! For GNU compiler, use
! --------------------------------------------------------------
!  f2py -m construct_vir -c construct_vir.f90 --link-lapack_opt
! --------------------------------------------------------------
!
! For Intel compiler, use
! -----------------------------------------------------------------------------------------------------
!  f2py -m construct_vir -c construct_vir.f90 --link-lapack_opt --fcompiler=intelem --compiler=intelem
! -----------------------------------------------------------------------------------------------------
!
!  to compile this file (a construct_vir.so file will be generated). Then in Python
!  you can import the construct_vir module.

subroutine construct_vir(nbf, nif, idx, coeff, ovlp, new_coeff)
 implicit none
 integer, parameter :: iout = 6
 integer :: i, j, nvir
 integer :: nbf, nif, idx
!f2py intent(in) :: nbf, nif, idx
 ! nbf: the number of basis functions
 ! nif: the number of MOs
 ! idx: the beginning index (Fortran convention) of the virtual MOs

 real(kind=8) :: coeff(nbf,nif), ovlp(nbf,nbf), new_coeff(nbf,nif)
!f2py depend(nbf,nif) coeff, new_coeff
!f2py depend(nbf) ovlp
!f2py intent(in) :: ovlp
!f2py intent(in,copy) :: coeff
!f2py intent(out) :: new_coeff

 real(kind=8), allocatable :: p(:,:), v(:,:), sv(:,:)
 real(kind=8), allocatable :: s1(:,:), ev(:), x(:,:)
 ! V: projected atomic orbitals (PAO)
 ! P: density matrix of atomic basis functions, sigma_i(Cui*Cvi)
 ! Note that the index i can be larger than nocc, in which case we only
 !  construct part of virtual orbitals.

 if(idx == nif+1) then
  write(iout,'(/,A)') 'Warning in subroutine construct_vir: idx=nif+1 found.'
  write(iout,'(A)') 'No need to construct virtual MOs.'
  new_coeff = coeff
  return
 end if
 ! Step 1: P = sigma_i(Cui*Cvi)
 ! ?gemm: Computes a matrix-matrix product with general matrices
 ! Syntax FORTRAN 77:
 ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
 allocate(p(nbf,nbf), source=0d0)
 call dgemm('N', 'T', nbf, nbf, idx-1, 1d0, coeff(1:nbf,1:idx-1), nbf, coeff(1:nbf,1:idx-1), nbf, 0d0, p, nbf)

 ! Step 2: V = 1 - PS
 ! ?symm: Computes a matrix-matrix product where one input matrix is symmetric
 ! Syntax FORTRAN 77:
 ! call dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
 allocate(v(nbf, nbf), source=0d0)
 forall(i = 1:nbf) v(i,i) = 1d0
 call dsymm('R', 'U', nbf, nbf, -1d0, ovlp, nbf, p, nbf, 1d0, v, nbf)
 deallocate(p)

 ! Step 3: S1 = (VT)SV
 allocate(sv(nbf,nbf), source=0d0)
 allocate(s1(nbf,nbf), source=0d0)
 call dsymm('L', 'U', nbf, nbf, 1d0, ovlp, nbf, v, nbf, 0d0, sv, nbf)
 call dgemm('T', 'N', nbf, nbf, nbf, 1d0, v, nbf, sv, nbf, 0d0, s1, nbf)
 deallocate(sv)

 ! Step 4: diagonalize S1 (note that S1 is symmetric) and get X
 allocate(ev(nbf))
 call diag_get_e_and_vec(nbf, s1, ev)
 nvir = nif - idx + 1
 forall(i = nbf-nvir+1:nbf) ev(i) = 1d0/DSQRT(ev(i))
 allocate(x(nbf,nvir), source=0d0)
 forall(i=1:nbf, j=1:nvir) x(i,j) = s1(i,nbf-nvir+j)*ev(nbf-nvir+j)
 deallocate(ev, s1)

 ! Step 5: get new virtual MO coefficients
 call dgemm('N', 'N', nbf, nvir, nbf, 1d0, v, nbf, x, nbf, 0d0, coeff(:,idx:nif), nbf)
 deallocate(x, v)
 new_coeff = coeff

 ! Step 6: check orthonormality
 allocate(s1(nbf,nif), source=0d0)
 allocate(x(nif,nif), source=0d0)
 call dsymm('L', 'U', nbf, nif, 1d0, ovlp, nbf, coeff, nbf, 0d0, s1, nbf)
 call dgemm('T', 'N', nif, nif, nbf, 1d0, coeff, nbf, s1, nbf, 0d0, x, nif)
 deallocate(s1)
 forall(i = 1:nif) x(i,i) = x(i,i) - 1.0d0
 x = DABS(x)
 write(iout,'(/,A)') 'The orthonormality of Alpha MO after PAO construction:'
 write(iout,'(A,F16.10)') 'maxv=', MAXVAL(x)
 write(iout,'(A,F16.10)') 'abs_mean=', SUM(x)/DBLE(nif*nif)
 deallocate(x)

 return
end subroutine construct_vir


      SUBROUTINE gser(gamser,a,x,gln)
      INTEGER ITMAX
      REAL a,gamser,gln,x,EPS
      PARAMETER (ITMAX=100,EPS=3.e-7)
CU    USES gammln
      INTEGER n
      REAL ap,del,sum,gammln
      gln=gammln(a)
      if(x.le.0.)then
        if(x.lt.0.)pause 'x < 0 in gser'
        gamser=0.
        return
      endif
      ap=a
      sum=1./a
      del=sum
      do 11 n=1,ITMAX
        ap=ap+1.
        del=del*x/ap
        sum=sum+del
        if(abs(del).lt.abs(sum)*EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gser'
1     gamser=sum*exp(-x+a*log(x)-gln)
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software D041&0(9p#3.


module matrix_module
  implicit none

  public :: zeros
  public :: identity
  public :: random

  type matrix
     integer :: shape(2)
     real, allocatable :: data(:,:)
   contains
     procedure :: construct => matrix_construct
     procedure :: destruct => matrix_destruct
     procedure :: norm => matrix_norm
  end type matrix

  type vector
     integer :: length
     real, allocatable :: data(:)
   contains
     procedure :: construct => vector_construct
     procedure :: destruct => vector_destruct
     procedure :: norm => vector_norm
  end type vector

  ! assignments
  interface assignment(=)
     procedure vec_num_assign, vec_vec_assign, mat_num_assign, mat_mat_assign
  end interface assignment(=)

  ! operations
  interface operator(+)
     procedure vec_vec_sum, mat_mat_sum
  end interface operator(+)

  interface operator(-)
     procedure vec_vec_diff, mat_mat_diff
  end interface operator(-)

  interface operator(*)
     procedure num_vec_prod, num_mat_prod, mat_vec_prod, mat_mat_prod
  end interface operator(*)

  interface operator(/)
     procedure vec_num_quot, mat_num_quot
  end interface operator(/)

  interface operator(**)
     procedure mat_pow
  end interface operator(**)

  ! functions
  interface norm
     procedure vector_norm, matrix_norm
  end interface norm

  ! structured vectors/matrices
  interface zeros
     procedure zeros_vector, zeros_matrix
  end interface zeros

  interface random
     procedure random_vector, random_matrix
  end interface random

contains

  subroutine matrix_construct(this, m, n)
    class(matrix) :: this
    integer :: m,n
    this%shape = [m,n]
    allocate(this%data(m,n))
  end subroutine matrix_construct

  subroutine vector_construct(this, n)
    class(vector) :: this
    integer :: n
    this%length = n
    allocate(this%data(n))
  end subroutine vector_construct

  subroutine matrix_destruct(this)
    class(matrix) :: this
    deallocate(this%data)
  end subroutine matrix_destruct

  subroutine vector_destruct(this)
    class(vector) :: this
    deallocate(this%data)
  end subroutine vector_destruct

  ! assignment
  subroutine vec_num_assign(vec,num)
    type(vector), intent(inout) :: vec
    real, intent(in) :: num
    vec%data = num
  end subroutine vec_num_assign

  subroutine vec_vec_assign(vec1,vec2)
    type(vector), intent(inout) :: vec1
    type(vector), intent(in) :: vec2
    vec1%data = vec2%data
  end subroutine vec_vec_assign

  subroutine mat_num_assign(mat,num)
    type(matrix), intent(inout) :: mat
    real, intent(in) :: num
    mat%data = num
  end subroutine mat_num_assign

  subroutine mat_mat_assign(mat1,mat2)
    type(matrix), intent(inout) :: mat1
    type(matrix), intent(in) :: mat2
    mat1%data = mat2%data
  end subroutine mat_mat_assign

  ! operations
  function vec_vec_sum(vec1,vec2) result(s)
    type(vector), intent(in) :: vec1, vec2
    type(vector) :: s
    call s%construct(vec1%length)
    s%data = vec1%data + vec2%data
  end function vec_vec_sum

  function mat_mat_sum(mat1,mat2) result(s)
    type(matrix), intent(in) :: mat1, mat2
    type(matrix) :: s
    call s%construct(mat1%shape(1),mat1%shape(2))
    s%data = mat1%data+mat2%data
  end function mat_mat_sum

  function vec_vec_diff(vec1,vec2) result(diff)
    type(vector), intent(in) :: vec1, vec2
    type(vector) :: diff
    call diff%construct(vec1%length)
    diff%data = vec1%data-vec2%data
  end function vec_vec_diff

  function mat_mat_diff(mat1,mat2) result(diff)
    type(matrix), intent(in) :: mat1, mat2
    type(matrix) :: diff
    call diff%construct(mat1%shape(1),mat1%shape(2))
    diff%data = mat1%data-mat2%data
  end function mat_mat_diff

  function num_vec_prod(num,vec) result(prod)
    real, intent(in) :: num
    type(vector), intent(in) :: vec
    type(vector) :: prod
    call prod%construct(vec%length)
    prod%data = num*vec%data
  end function num_vec_prod

  function num_mat_prod(num,mat) result(prod)
    real, intent(in) :: num
    type(matrix), intent(in) :: mat
    type(matrix) :: prod
    call prod%construct(mat%shape(1),mat%shape(2))
    prod%data = num*mat%data
  end function num_mat_prod

  function mat_vec_prod(mat,vec) result(prod)
    type(matrix), intent(in) :: mat
    type(vector), intent(in) :: vec
    type(vector) :: prod
    call prod%construct(mat%shape(1))
    prod%data = matmul(mat%data,vec%data)
  end function mat_vec_prod

  function mat_mat_prod(mat1,mat2) result(prod)
    type(matrix), intent(in) :: mat1, mat2
    type(matrix) :: prod
    call prod%construct(mat1%shape(1),mat2%shape(2))
    prod%data = matmul(mat1%data,mat2%data)
  end function mat_mat_prod

  function vec_num_quot(vec,num) result(quot)
    type(vector), intent(in) :: vec
    real, intent(in) :: num
    type(vector) :: quot
    call quot%construct(vec%length)
    quot%data = vec%data/num
  end function vec_num_quot

  function mat_num_quot(mat,num) result(quot)
    type(matrix), intent(in) :: mat
    real, intent(in) :: num
    type(matrix) :: quot
    call quot%construct(mat%shape(1),mat%shape(2))
    quot%data = mat%data/num
  end function mat_num_quot

  function mat_pow(mat1,pow) result(mat2)
    type(matrix), intent(in) :: mat1
    integer, intent(in) :: pow
    type(matrix) :: mat2
    integer :: i
    mat2 = mat1
    do i = 2,pow
       mat2 = mat1*mat2
    end do
  end function mat_pow

  ! functions
  function vector_norm(this,p) result(mag)
    class(vector), intent(in) :: this
    integer, intent(in) :: p
    real :: mag
    integer :: i
    ! inf-norm
    if (p==0) then
       mag = 0.0
       do i = 1,this%length
          mag = max(mag,abs(this%data(i)))
       end do
    ! p-norm
    else if (p>0) then
       mag = (sum(abs(this%data)**p))**(1./p)
    end if
  end function vector_norm

  function matrix_norm(this, p) result(mag)
    class(matrix), intent(in) :: this
    integer, intent(in) :: p
    real ::  mag, tol = 1e-6
    integer :: m, n, row, col, iter, max_iters = 1000
    type(vector) :: vec, last_vec
    m = size(this%data(:,1)); n = size(this%data(1,:))

    ! entry-wise norms
    if (p<0) then
       mag = (sum(abs(this%data)**(-p)))**(-1./p)
    ! inf-norm
    else if (p==0) then
       mag = 0.0
       do row = 1,m
          mag = max(mag,sum(abs(this%data(row,:))))
       end do
    ! 1-norm
    else if (p==1) then
       mag = 0.0
       do col = 1,n
          mag = max(mag,sum(abs(this%data(:,col))))
       end do
    ! p-norm
    else if (p>0) then
       vec = random(n)
       vec = vec/vec%norm(p)
       last_vec = zeros(n)
       mag = 0.0
       do iter = 1,max_iters
          last_vec = vec
          vec = this*last_vec
          vec = vec/vec%norm(p)
          if (vector_norm(vec-last_vec,p)<tol) exit
       end do
       mag = vector_norm(this*vec,p)
    end if
  end function matrix_norm

  ! structured vectors/matrices
  function random_matrix(m,n) result(mat)
    integer :: m,n
    type(matrix) :: mat
    call mat%construct(m,n)
    call random_seed()
    call random_number(mat%data)
  end function random_matrix

  function random_vector(n) result(vec)
    integer :: n
    type(vector) :: vec
    call vec%construct(n)
    call random_seed()
    call random_number(vec%data)
  end function random_vector

  function zeros_vector(n) result(vec)
    integer :: n
    type(vector) :: vec
    call vec%construct(n)
    vec = 0.0
  end function zeros_vector

  function zeros_matrix(m,n) result(mat)
    integer :: m,n
    type(matrix) :: mat
    call mat%construct(m,n)
    mat = 0.0
  end function zeros_matrix

  function identity(m,n) result(mat)
    integer :: m,n,i
    type(matrix) :: mat
    call mat%construct(m,n)
    do i = 1,min(m,n)
       mat%data(i,i) = 1.0
    end do
  end function identity

end module matrix_module


! surface_integral.f90
! author: sunder

!-----------------------------------------------------------------------
! Find the surface integral
!-----------------------------------------------------------------------

subroutine surface_integral(lduh, lFl, lFr, lGb, lGt)

    use ader_dg
    implicit none
    ! Argument list
    real, intent(in)    :: lFl(nVar,nDOF(2)), lFr(nVar,nDOF(2)), lGb(nVar,nDOF(1)), lGt(nVar,nDOF(1))
    real, intent(inout) :: lduh(nVar, nDOF(1), nDOF(2)) ! Spatial degrees of freedom

    ! Local variables
    integer           :: i,j,iVar

    ! Now multiply the numerical fluxes on the surfaces with the test functions and compute the surface integrals

    ! x faces

    do j = 1, nDOF(2)
        do iVar = 1, nVar
            lduh(iVar,:,j) = lduh(iVar,:,j) - &
                wGPN(j)/dx(1)*( lFr(iVar,j)*FRCoeff - lFl(iVar,j)*FLCoeff )      ! left flux minus right flux
        end do
    end do

    ! y faces

    do i = 1, nDOF(1)
        do iVar = 1, nVar
            lduh(iVar,i,:) = lduh(iVar,i,:) - &
            wGPN(i)/dx(2)*( lGt(iVar,i)*FRCoeff - lGb(iVar,i)*FLCoeff )         ! bottom flux minus top flux
        end do
    end do

end subroutine surface_integral


      subroutine filtr1(a,b,idm,ii,jj)
c
c --- a: array to be smoothed
c --- b: work space
c
      real a(idm,1),b(idm,1)
      data wgt1/.5/,wgt2/.25/
      data flag/-.03125/
      cvmgp(aa,bb,cc)=aa*(.5+sign(.5,cc))+bb*(.5-sign(.5,cc))
      cvmgz(aa,bb,cc)=cvmgp(aa,bb,-1.*abs(cc))
c
      do 3 j=1,jj
      ja=max0( 1,j-1)
      jb=min0(jj,j+1)
      do 3 i=1,ii
      qja=cvmgz(a(i,j),a(i,ja),a(i,ja)-flag)
      qjb=cvmgz(a(i,j),a(i,jb),a(i,jb)-flag)
 3    b(i,j)=cvmgz(a(i,j),wgt1*a(i,j)+wgt2*(qja+qjb),a(i,j)-flag)
c
      do 4 i=1,ii
      ia=max0( 1,i-1)
      ib=min0(ii,i+1)
      do 4 j=1,jj
      qia=cvmgz(b(i,j),b(ia,j),b(ia,j)-flag)
      qib=cvmgz(b(i,j),b(ib,j),b(ib,j)-flag)
 4    a(i,j)=cvmgz(b(i,j),wgt1*b(i,j)+wgt2*(qia+qib),b(i,j)-flag)
c
      return
      end


! PR libfortran/20755
! { dg-do run }
! { dg-options "-std=legacy" }
!
      character*30 s

      write (s,2000) 0.0, 0.02
      if (s .ne. "    0.00       2.000E-02") call abort
      write (s,2000) 0.01, 0.02
      if (s .ne. "   1.000E-02   2.000E-02") call abort
 2000 format (1PG12.3,G12.3)
      end


module FEMeshClass
    use iso_fortran_env
    use plantfem
    implicit none

    type::FEMesh_
        private
        real(real64),allocatable :: NodCoord(:,:)
        integer(int32),allocatable  :: ElemNod(:,:)
        integer(int32),allocatable :: ElemMat(:)
    contains
        procedure, public :: create => createFEMesh
        procedure, public :: changeMaterialID => changeMaterialIDFEMesh
        procedure, public :: show => showFEMesh
    end type

contains

! ###############################################################
subroutine createFEMesh(this,xn, yn, lx, ly)
    class(FEMesh_),intent(inout) :: this

    integer(int32),intent(in) :: xn ! 要素分割数　for X方向
    integer(int32),intent(in) :: yn ! 要素分割数　for Y方向

    real(real64),intent(in) :: lx ! x方向長さ
    real(real64),intent(in) :: ly ! y方向長さ

    real(real64) :: unitx, unity

    integer(int32) :: i,j,n

    unitx=lx/dble(xn)
    unity=ly/dble(yn)

    ! creating rectangular mesh
    allocate(this%NodCoord( (xn+1)*(yn+1) , 2 ))
    allocate(this%ElemNod( xn*yn,4) )
    allocate(this%ElemMat(xn*yn) )

    n=0
    do j=1, yn+1
        do i=1, xn+1
            n=n+1
            this%NodCoord(n,1)=lx/dble(xn)*dble(i-1)
            this%NodCoord(n,2)=ly/dble(yn)*dble(j-1)
        enddo
    enddo

    n=1
    this%ElemNod(1,1)=1
    this%ElemNod(1,2)=2
    this%ElemNod(1,3)=yn+3
    this%ElemNod(1,4)=yn+2
    this%ElemNod(2,1)=2
    this%ElemNod(2,2)=3
    this%ElemNod(2,3)=yn+4
    this%ElemNod(2,4)=yn+3

    n=0
    do j=1, yn
        do i=1, xn
            n=n+1
            this%ElemNod(n,1)=i + (j-1)*(xn+1)
            this%ElemNod(n,2)=i+1 + (j-1)*(xn+1)
            this%ElemNod(n,3)=xn+2+i+ (j-1)*(xn+1)
            this%ElemNod(n,4)=xn+1+i + (j-1)*(xn+1)
            this%ElemMat(n)=1
        enddo
    enddo

end subroutine createFEMesh
! ###############################################################

subroutine changeMaterialIDFEMesh(this,ElementID,MaterialID)
    class(FEMesh_),intent(inout) :: this
    integer(int32),intent(in) :: ElementID,MaterialID

    this%ElemMat(ElementID) = MaterialID

end subroutine changeMaterialIDFEMesh
! ###############################################################

! ###############################################################
subroutine showFEMesh(this)
    class(FEMesh_),intent(in) :: this

    call print(this%Nodcoord)
    call print(this%ElemNod)
    call print(this%ElemMat)

end subroutine
! ###############################################################

end module

program main
    use iso_fortran_env
    use plantfem
    use FEMeshClass
    implicit none

    type(FEMesh_) :: mesh

    ! 引数sと操作sをまとめて1つのクラスにすると、少しすっきりする。
    call mesh%create(xn=2, yn=2, lx=2.0d0, ly=2.0d0)

    ! 材料番号のみ修正
    call mesh%changeMaterialID(ElementID=4, MaterialID=2)

    ! メッシュ情報をチェック
    call mesh%show()

    ! export
    ! ...略

end program main


!
! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
module dot_m
contains
  subroutine dot(A, B, C, m, n)
    implicit none
    real, intent(in) :: A(m,n)
    real, intent(in) :: B(m,n)
    real, intent(inout) :: C(m)
    integer, intent(in) :: m, n

    integer :: i, j

    do j = 1,m
       C(j) = 0.0
       do i = 1,m
          C(j) = C(j) + A(i,j) * B(i,j)
       end do
    end do
  end subroutine dot
end module dot_m


!! R472 ac-value
!    is expr
!    or ac-implied-do

! Test of expr in ac_value_list
x = [ REAL :: 3.1, 4.1, 5.9265 ]

! Test of ac-implied-do
A = (/ (I, I = 1, 1075) /)
B = [ TYPE(Z) :: 3.6, (3.6 / I, I = 1, N, 2) ]

end


! https://www.codewars.com/kata/50654ddff44f800200000004

module Solution
  implicit none
contains
  function multiply(a, b)
    integer :: a, b, multiply
    multiply = a * b
  end function multiply
end module Solution


! { dg-do run }

  use, intrinsic :: ieee_features
  use, intrinsic :: ieee_exceptions
  use, intrinsic :: ieee_arithmetic
  implicit none

  interface check_equal
    procedure check_equal_float, check_equal_double
  end interface

  interface check_not_equal
    procedure check_not_equal_float, check_not_equal_double
  end interface

  real :: sx1, sx2, sx3
  double precision :: dx1, dx2, dx3
  type(ieee_round_type) :: mode

  ! Test IEEE_COPY_SIGN
  sx1 = 1.3
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 1
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 2
  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 3
  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 4
  sx1 = huge(sx1)
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 5
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 6
  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 7
  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 8
  sx1 = ieee_value(sx1, ieee_positive_inf)
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 9
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 10
  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 11
  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 12
  sx1 = tiny(sx1)
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 13
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 14
  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 15
  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 16
  sx1 = tiny(sx1)
  sx1 = sx1 / 101
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 17
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 18
  if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 19
  if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 20

  sx1 = -1.3
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 21
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 22
  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 23
  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 24
  sx1 = -huge(sx1)
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 25
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 26
  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 27
  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 28
  sx1 = ieee_value(sx1, ieee_negative_inf)
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 29
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 30
  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 31
  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 32
  sx1 = -tiny(sx1)
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 33
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 34
  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 35
  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 36
  sx1 = -tiny(sx1)
  sx1 = sx1 / 101
  if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 37
  if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 38
  if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 39
  if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 40

  if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero) STOP 41
  if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero) STOP 42
  if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero) STOP 43
  if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero) STOP 44

  sx1 = ieee_value(0., ieee_quiet_nan)
  if (ieee_class(ieee_copy_sign(sx1, 1.)) /= ieee_quiet_nan) STOP 45
  if (ieee_class(ieee_copy_sign(sx1, -1.)) /= ieee_quiet_nan) STOP 46

  dx1 = 1.3
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 47
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 48
  if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 49
  if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 50
  dx1 = huge(dx1)
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 51
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 52
  if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 53
  if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 54
  dx1 = ieee_value(dx1, ieee_positive_inf)
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 55
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 56
  if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 57
  if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 58
  dx1 = tiny(dx1)
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 59
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 60
  if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 61
  if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 62
  dx1 = tiny(dx1)
  dx1 = dx1 / 101
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 63
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 64
  if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 65
  if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 66

  dx1 = -1.3d0
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 67
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 68
  if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 69
  if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 70
  dx1 = -huge(dx1)
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 71
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 72
  if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 73
  if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 74
  dx1 = ieee_value(dx1, ieee_negative_inf)
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 75
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 76
  if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 77
  if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 78
  dx1 = -tiny(dx1)
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 79
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 80
  if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 81
  if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 82
  dx1 = -tiny(dx1)
  dx1 = dx1 / 101
  if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 83
  if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 84
  if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 85
  if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 86

  if (ieee_class(ieee_copy_sign(0.d0, -1.)) /= ieee_negative_zero) STOP 87
  if (ieee_class(ieee_copy_sign(-0.d0, -1.)) /= ieee_negative_zero) STOP 88
  if (ieee_class(ieee_copy_sign(0.d0, 1.)) /= ieee_positive_zero) STOP 89
  if (ieee_class(ieee_copy_sign(-0.d0, 1.)) /= ieee_positive_zero) STOP 90

  dx1 = ieee_value(0.d0, ieee_quiet_nan)
  if (ieee_class(ieee_copy_sign(dx1, 1.d0)) /= ieee_quiet_nan) STOP 91
  if (ieee_class(ieee_copy_sign(dx1, -1.)) /= ieee_quiet_nan) STOP 92

  ! Test IEEE_LOGB

  if (ieee_logb(1.17) /= exponent(1.17) - 1) STOP 93
  if (ieee_logb(-1.17) /= exponent(-1.17) - 1) STOP 94
  if (ieee_logb(huge(sx1)) /= exponent(huge(sx1)) - 1) STOP 95
  if (ieee_logb(-huge(sx1)) /= exponent(-huge(sx1)) - 1) STOP 96
  if (ieee_logb(tiny(sx1)) /= exponent(tiny(sx1)) - 1) STOP 97
  if (ieee_logb(-tiny(sx1)) /= exponent(-tiny(sx1)) - 1) STOP 98

  if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf) STOP 99
  if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf) STOP 100

  sx1 = ieee_value(sx1, ieee_positive_inf)
  if (ieee_class(ieee_logb(sx1)) /= ieee_positive_inf) STOP 101
  if (ieee_class(ieee_logb(-sx1)) /= ieee_positive_inf) STOP 102

  sx1 = ieee_value(sx1, ieee_quiet_nan)
  if (ieee_class(ieee_logb(sx1)) /= ieee_quiet_nan) STOP 103

  if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) STOP 104
  if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) STOP 105
  if (ieee_logb(huge(dx1)) /= exponent(huge(dx1)) - 1) STOP 106
  if (ieee_logb(-huge(dx1)) /= exponent(-huge(dx1)) - 1) STOP 107
  if (ieee_logb(tiny(dx1)) /= exponent(tiny(dx1)) - 1) STOP 108
  if (ieee_logb(-tiny(dx1)) /= exponent(-tiny(dx1)) - 1) STOP 109

  if (ieee_class(ieee_logb(0.d0)) /= ieee_negative_inf) STOP 110
  if (ieee_class(ieee_logb(-0.d0)) /= ieee_negative_inf) STOP 111

  dx1 = ieee_value(dx1, ieee_positive_inf)
  if (ieee_class(ieee_logb(dx1)) /= ieee_positive_inf) STOP 112
  if (ieee_class(ieee_logb(-dx1)) /= ieee_positive_inf) STOP 113

  dx1 = ieee_value(dx1, ieee_quiet_nan)
  if (ieee_class(ieee_logb(dx1)) /= ieee_quiet_nan) STOP 114

  ! Test IEEE_NEXT_AFTER

  if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) STOP 115
  if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) STOP 116

  sx1 = 0.12
  if (ieee_next_after(sx1, sx1) /= sx1) STOP 117
  sx1 = -0.12
  if (ieee_next_after(sx1, sx1) /= sx1) STOP 118
  sx1 = huge(sx1)
  if (ieee_next_after(sx1, sx1) /= sx1) STOP 119
  sx1 = tiny(sx1)
  if (ieee_next_after(sx1, sx1) /= sx1) STOP 120
  sx1 = 0
  if (ieee_next_after(sx1, sx1) /= sx1) STOP 121
  sx1 = ieee_value(sx1, ieee_negative_inf)
  if (ieee_next_after(sx1, sx1) /= sx1) STOP 122
  sx1 = ieee_value(sx1, ieee_quiet_nan)
  if (ieee_class(ieee_next_after(sx1, sx1)) /= ieee_quiet_nan) STOP 123

  if (ieee_next_after(0., 1.0) <= 0) STOP 124
  if (ieee_next_after(0., -1.0) >= 0) STOP 125
  sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_negative_inf))
  if (.not. sx1 < huge(sx1)) STOP 126
  sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_positive_inf))
  if (ieee_class(sx1) /= ieee_positive_inf) STOP 127
  sx1 = ieee_next_after(-tiny(sx1), 1.0)
  if (ieee_class(sx1) /= ieee_negative_denormal) STOP 128

  if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) STOP 129
  if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) STOP 130

  dx1 = 0.12
  if (ieee_next_after(dx1, dx1) /= dx1) STOP 131
  dx1 = -0.12
  if (ieee_next_after(dx1, dx1) /= dx1) STOP 132
  dx1 = huge(dx1)
  if (ieee_next_after(dx1, dx1) /= dx1) STOP 133
  dx1 = tiny(dx1)
  if (ieee_next_after(dx1, dx1) /= dx1) STOP 134
  dx1 = 0
  if (ieee_next_after(dx1, dx1) /= dx1) STOP 135
  dx1 = ieee_value(dx1, ieee_negative_inf)
  if (ieee_next_after(dx1, dx1) /= dx1) STOP 136
  dx1 = ieee_value(dx1, ieee_quiet_nan)
  if (ieee_class(ieee_next_after(dx1, dx1)) /= ieee_quiet_nan) STOP 137

  if (ieee_next_after(0.d0, 1.0) <= 0) STOP 138
  if (ieee_next_after(0.d0, -1.0d0) >= 0) STOP 139
  dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_negative_inf))
  if (.not. dx1 < huge(dx1)) STOP 140
  dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_positive_inf))
  if (ieee_class(dx1) /= ieee_positive_inf) STOP 141
  dx1 = ieee_next_after(-tiny(dx1), 1.0d0)
  if (ieee_class(dx1) /= ieee_negative_denormal) STOP 142

  ! Test IEEE_REM

  if (ieee_rem(4.0, 3.0) /= 1.0) STOP 143
  if (ieee_rem(-4.0, 3.0) /= -1.0) STOP 144
  if (ieee_rem(2.0, 3.0d0) /= -1.0d0) STOP 145
  if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) STOP 146
  if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) STOP 147
  if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) STOP 148

  if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan), 1.0)) &
      /= ieee_quiet_nan) STOP 149
  if (ieee_class(ieee_rem(1.0, ieee_value(0.d0, ieee_quiet_nan))) &
      /= ieee_quiet_nan) STOP 150

  if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf), 1.0)) &
      /= ieee_quiet_nan) STOP 151
  if (ieee_class(ieee_rem(ieee_value(0.d0, ieee_negative_inf), 1.0)) &
      /= ieee_quiet_nan) STOP 152
  if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf)) &
      /= -1.0) STOP 153
  if (ieee_rem(1.0, ieee_value(0.d0, ieee_negative_inf)) &
      /= 1.0) STOP 154

  ! Test IEEE_RINT

  if (ieee_support_rounding (ieee_nearest, sx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_nearest)
    sx1 = 7 / 3.
    sx1 = ieee_rint (sx1)
    call ieee_set_rounding_mode (mode)
    if (sx1 /= 2) STOP 155
  end if

  if (ieee_support_rounding (ieee_up, sx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_up)
    sx1 = 7 / 3.
    sx1 = ieee_rint (sx1)
    call ieee_set_rounding_mode (mode)
    if (sx1 /= 3) STOP 156
  end if

  if (ieee_support_rounding (ieee_down, sx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_down)
    sx1 = 7 / 3.
    sx1 = ieee_rint (sx1)
    call ieee_set_rounding_mode (mode)
    if (sx1 /= 2) STOP 157
  end if

  if (ieee_support_rounding (ieee_to_zero, sx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_to_zero)
    sx1 = 7 / 3.
    sx1 = ieee_rint (sx1)
    call ieee_set_rounding_mode (mode)
    if (sx1 /= 2) STOP 158
  end if

  if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero) STOP 159
  if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero) STOP 160

  if (ieee_support_rounding (ieee_nearest, dx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_nearest)
    dx1 = 7 / 3.d0
    dx1 = ieee_rint (dx1)
    call ieee_set_rounding_mode (mode)
    if (dx1 /= 2) STOP 161
  end if

  if (ieee_support_rounding (ieee_up, dx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_up)
    dx1 = 7 / 3.d0
    dx1 = ieee_rint (dx1)
    call ieee_set_rounding_mode (mode)
    if (dx1 /= 3) STOP 162
  end if

  if (ieee_support_rounding (ieee_down, dx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_down)
    dx1 = 7 / 3.d0
    dx1 = ieee_rint (dx1)
    call ieee_set_rounding_mode (mode)
    if (dx1 /= 2) STOP 163
  end if

  if (ieee_support_rounding (ieee_to_zero, dx1)) then
    call ieee_get_rounding_mode (mode)
    call ieee_set_rounding_mode (ieee_to_zero)
    dx1 = 7 / 3.d0
    dx1 = ieee_rint (dx1)
    call ieee_set_rounding_mode (mode)
    if (dx1 /= 2) STOP 164
  end if

  if (ieee_class(ieee_rint(0.d0)) /= ieee_positive_zero) STOP 165
  if (ieee_class(ieee_rint(-0.d0)) /= ieee_negative_zero) STOP 166

  ! Test IEEE_SCALB

  sx1 = 1
  if (ieee_scalb(sx1, 2) /= 4.) STOP 167
  if (ieee_scalb(-sx1, 2) /= -4.) STOP 168
  if (ieee_scalb(sx1, -2) /= 1/4.) STOP 169
  if (ieee_scalb(-sx1, -2) /= -1/4.) STOP 170
  if (ieee_class(ieee_scalb(sx1, huge(0))) /= ieee_positive_inf) STOP 171
  if (ieee_class(ieee_scalb(-sx1, huge(0))) /= ieee_negative_inf) STOP 172
  if (ieee_class(ieee_scalb(sx1, -huge(0))) /= ieee_positive_zero) STOP 173
  if (ieee_class(ieee_scalb(-sx1, -huge(0))) /= ieee_negative_zero) STOP 174

  sx1 = ieee_value(sx1, ieee_quiet_nan)
  if (ieee_class(ieee_scalb(sx1, 1)) /= ieee_quiet_nan) STOP 175
  sx1 = ieee_value(sx1, ieee_positive_inf)
  if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_positive_inf) STOP 176
  sx1 = ieee_value(sx1, ieee_negative_inf)
  if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_negative_inf) STOP 177

  dx1 = 1
  if (ieee_scalb(dx1, 2) /= 4.d0) STOP 178
  if (ieee_scalb(-dx1, 2) /= -4.d0) STOP 179
  if (ieee_scalb(dx1, -2) /= 1/4.d0) STOP 180
  if (ieee_scalb(-dx1, -2) /= -1/4.d0) STOP 181
  if (ieee_class(ieee_scalb(dx1, huge(0))) /= ieee_positive_inf) STOP 182
  if (ieee_class(ieee_scalb(-dx1, huge(0))) /= ieee_negative_inf) STOP 183
  if (ieee_class(ieee_scalb(dx1, -huge(0))) /= ieee_positive_zero) STOP 184
  if (ieee_class(ieee_scalb(-dx1, -huge(0))) /= ieee_negative_zero) STOP 185

  dx1 = ieee_value(dx1, ieee_quiet_nan)
  if (ieee_class(ieee_scalb(dx1, 1)) /= ieee_quiet_nan) STOP 186
  dx1 = ieee_value(dx1, ieee_positive_inf)
  if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_positive_inf) STOP 187
  dx1 = ieee_value(dx1, ieee_negative_inf)
  if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_negative_inf) STOP 188

contains

  subroutine check_equal_float (x, y)
    real, intent(in) :: x, y
    if (x /= y) then
      print *, x, y
      STOP 189
    end if
  end subroutine

  subroutine check_equal_double (x, y)
    double precision, intent(in) :: x, y
    if (x /= y) then
      print *, x, y
      STOP 190
    end if
  end subroutine

  subroutine check_not_equal_float (x, y)
    real, intent(in) :: x, y
    if (x == y) then
      print *, x, y
      STOP 191
    end if
  end subroutine

  subroutine check_not_equal_double (x, y)
    double precision, intent(in) :: x, y
    if (x == y) then
      print *, x, y
      STOP 192
    end if
  end subroutine

end