! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program test_corr

! test of twod_gaussian distribution, and two different numerical
! methods of computing the variance and correlation.  one is more
! stable in the face of 8 byte reals being redefined as 4 byte values.

use      types_mod, only : r8
use  utilities_mod, only : check_namelist_read, find_namelist_in_file, &
                           register_module, error_handler, E_ERR,      &
                           nmlfileunit, do_nml_file, do_nml_term,      &
                           initialize_utilities, finalize_utilities
use random_seq_mod, only : random_seq_type, init_random_seq, twod_gaussians

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
real(r8), allocatable :: rnum(:, :)
real(r8) :: c(2, 2), mean(2)
integer :: i, j, iunit, io

real(r8) :: mean_correlA, varA, meanA, meanc_2A, sample_correlA
real(r8) :: mean_correlB, varB, meanB, meanc_2B, sample_correlB

! namelist variables
integer  :: n_pairs = 10
integer  :: n_cycles = 100
real(r8) :: desired_correl = 0.75_r8

namelist /test_corr_nml/ n_pairs, desired_correl, n_cycles

! start of program

call initialize_utilities('test_corr')
call register_module(source, revision, revdate)

! Read the namelist entry
call find_namelist_in_file("input.nml", "test_corr_nml", iunit)
read(iunit, nml = test_corr_nml, iostat = io)
call check_namelist_read(iunit, io, "test_corr_nml")

! Write the namelist values to the log file
if (do_nml_file()) write(nmlfileunit, nml=test_corr_nml)
if (do_nml_term()) write(     *     , nml=test_corr_nml)

if (n_cycles < 2 .or. n_pairs < 2) then
   call error_handler(E_ERR, 'test_corr', 'both n_pairs and n_cycles must be >= 2', &
      source, revision, revdate)
endif

mean_correlA = 0.0
mean_correlB = 0.0
varA = 0.0
varB = 0.0

! Allocate space for the pairs of data
allocate(rnum(2, n_pairs))

call init_random_seq(r)

! Mean for generated
mean = 0.0
meanc_2A = 0.0
meanc_2B = 0.0

! Generate the covariance matrix
c(1, 1) = 1.0
c(2, 2) = 1.0
c(1, 2) = desired_correl
c(2, 1) = desired_correl

do j = 1, n_cycles

   do i = 1, n_pairs
      call twod_gaussians(r, mean, c, rnum(:, i))
   end do

   ! Compute the correlation of the random numbers two different ways
   call comp_correlA(rnum, n_pairs, sample_correlA)
   call comp_correlB(rnum, n_pairs, sample_correlB)

   mean_correlA = mean_correlA + sample_correlA
   meanc_2A = meanc_2A + sample_correlA**2
   varA = varA + (sample_correlA - desired_correl) ** 2

   mean_correlB = mean_correlB + sample_correlB
   meanc_2B = meanc_2B + sample_correlB**2
   varB = varB + (sample_correlB - desired_correl) ** 2
end do

mean_correlA = mean_correlA / n_cycles
mean_correlB = mean_correlB / n_cycles

write(*, *) ''
write(*, *) 'target mean correl is                ', desired_correl
write(*, *) 'computed mean correl, version A, is  ', mean_correlA
write(*, *) 'computed mean correl, version B, is  ', mean_correlB

write(*, *) ''
write(*, *) 'predicted variance is                ', (1.0_r8 - desired_correl**2)**2 / (n_pairs - 1._r8)
write(*, *) 'computed variance, version A, is     ', (meanc_2A - n_cycles * mean_correlA**2) / (n_cycles - 1._r8)
write(*, *) 'computed variance, version B, is     ', (meanc_2B - n_cycles * mean_correlB**2) / (n_cycles - 1._r8)

call finalize_utilities('test_corr')

contains

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

subroutine comp_correlA(ens, n, correl)

integer,  intent(in)  :: n
real(r8), intent(in)  :: ens(2, n)
real(r8), intent(out) :: correl

real(r8) :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x = sum(ens(2, :))
sum_y = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

! debug:
!print *, 'x,y,xy,x2,y2: ', sum_x, sum_y, sum_xy, sum_x2, sum_y2

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correlA

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

subroutine comp_correlB(ens, n, correl)

! alternative way to comput covariance and variance - more numerically
! stable in the face of 4 byte floats:

integer,  intent(in)  :: n
real(r8), intent(in)  :: ens(2, n)
real(r8), intent(out) :: correl

real(r8) :: sum_x, sum_y
real(r8) :: x_mean, y_mean, x_var, y_var, cov

sum_x = sum(ens(2, :))
sum_y = sum(ens(1, :))

x_mean = sum_x / n
y_mean = sum_y / n
x_var = sum((ens(2, :) - x_mean)**2) / (n - 1)
y_var = sum((ens(1, :) - y_mean)**2) / (n - 1)
cov = sum((ens(2, :) - x_mean) * (ens(1, :) - y_mean)) / (n - 1)
correl = cov / sqrt(x_var * y_var)

! debug:
!print *, x_mean, y_mean, x_var, y_var, cov, abs(x_var * y_var), sqrt(x_var*y_var), correl

end subroutine comp_correlB

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

end program test_corr

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


      PROGRAM xrlft3
C     driver for routine rlft3
      INTEGER NX,NY,NZ
      REAL EPS
      PARAMETER(NX=16,NY=8,NZ=32,EPS=0.0008)
      INTEGER icompare,idum,i,j,k,ierr
      REAL data1(NX,NY,NZ),data2(NX,NY,NZ),fnorm,ran1
      COMPLEX speq1(NY,NZ)
      INTEGER nn1,nn2,nn3
      idum=-3
      nn1=NX
      nn2=NY
      nn3=NZ
      fnorm=float(nn1)*float(nn2)*float(nn3)/2.
      do 13 i=1,nn1
        do 12 j=1,nn2
          do 11 k=1,nn3
            data1(i,j,k)=2.*ran1(idum)-1.
            data2(i,j,k)=data1(i,j,k)*fnorm
11        continue
12      continue
13    continue
      call rlft3(data1,speq1,nn1,nn2,nn3,1)
C     here would be any processing in Fourier space
      call rlft3(data1,speq1,nn1,nn2,nn3,-1)
      ierr=icompare('data',data1,data2,nn1*nn2*nn3,EPS)
      if (ierr.eq.0) then
        write(*,*) 'Data compares OK to tolerance',EPS
      else
        write(*,*) 'Comparison errors occured at tolerance',EPS
        write(*,*) 'Total number of errors is',ierr
      endif
      END
      INTEGER FUNCTION icompare(string,arr1,arr2,len,eps)
      INTEGER IPRNT
      PARAMETER(IPRNT=20)
      CHARACTER*(*) string
      INTEGER j,len
      REAL eps,arr1(len),arr2(len)
      write(*,*) string
      icompare=0
      do 11 j=1,len
        if ((arr2(j).eq.0.and.abs(arr1(j)-arr2(j)).gt.eps).or.
     *       (abs((arr1(j)-arr2(j))/arr2(j)).gt.eps)) then
          icompare=icompare+1
          if (icompare.le.IPRNT) write(*,*) j,arr1(j),arr2(j)
        endif
11    continue
      return
      END

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


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my, &
     xlower,ylower,dx,dy,q,maux,aux)
  !!     =====================================================
  !!
  !!     # Set initial conditions for q.
  !!
  !!      # Data is piecewise constant with 4 values in 4 quadrants
  !!      # 2D Riemann problem from Figure 4 of
  !!        @article{csr-col-glaz,
  !!          author="C. W. Schulz-Rinne and J. P. Collins and H. M. Glaz",
  !!          title="Numerical Solution of the {R}iemann Problem for
  !!                 Two-Dimensional Gas Dynamics",
  !!          journal="SIAM J. Sci. Comput.",
  !!          volume="14",
  !!          year="1993",
  !!          pages="1394-1414" }

  IMPLICIT DOUBLE PRECISION (a-h,o-z)
  DIMENSION q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DIMENSION rpp(4),rpr(4),rpu(4),rpv(4)
  COMMON /cparam/  gamma,gamma1

  !! # First quadrant:
  rpp(1) = 1.5d0
  rpr(1) = 1.5d0
  rpu(1) = 0.d0
  rpv(1) = 0.d0

  !! # Second quadrant:
  rpp(2) = 0.3d0
  rpr(2) = 0.532258064516129d0
  rpu(2) = 1.206045378311055d0
  rpv(2) = 0.0d0

  !! # Third quadrant:
  rpp(3) = 0.029032258064516d0
  rpr(3) = 0.137992831541219d0
  rpu(3) = 1.206045378311055d0
  rpv(3) = 1.206045378311055d0

  !! # Fourth quadrant:
  rpp(4) = 0.3d0
  rpr(4) = 0.532258064516129d0
  rpu(4) = 0.0d0
  rpv(4) = 1.206045378311055d0

!! # location of four corners:
  xs = .8d0
  ys = .8d0

  DO i = 1-mbc,mx+mbc
     xcell = xlower + (i-0.5d0)*dx
     DO j = 1-mbc,my+mbc
        ycell = ylower + (j-0.5d0)*dy
        IF (xcell.GE.xs .AND. ycell.GE.ys) iq = 1
        IF (xcell.LT.xs .AND. ycell.GE.ys) iq = 2
        IF (xcell.LT.xs .AND. ycell.LT.ys) iq = 3
        IF (xcell.GE.xs .AND. ycell.LT.ys) iq = 4
        q(1,i,j) = rpr(iq)
        q(2,i,j) = rpr(iq)*rpu(iq)
        q(3,i,j) = rpr(iq)*rpv(iq)
        q(4,i,j) = rpp(iq)/gamma1 + 0.5d0*rpr(iq)*(rpu(iq)**2 + &
             rpv(iq)**2)
     ENDDO
  ENDDO
  RETURN
END SUBROUTINE clawpack5_qinit


      PROGRAM LA_SGELSY_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GELSY
    !  USE F77_LAPACK, ONLY: GEESX_F77 => LA_GEESX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, M, N, NRHS, RANK
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: JPVT(:)
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GELSY Example Program Results'
      M=6; N = 4; NRHS = 3
      WRITE(*,'(5H M = , I4, 5H N = , I4, 9H; NRHS = , I4)') M, N, NRHS
      ALLOCATE( A(M,N), AA(M,N), B(MAX(M,N),NRHS), BB(MAX(M,N),NRHS), JPVT(N) )

      OPEN(UNIT=21,FILE='gelss.ma',STATUS='UNKNOWN')
      DO I=1,M
         DO J=1,N
            READ(21,'(F2.0)') A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A :'
      DO I=1,M;
         WRITE(*,"(24(F9.5))") A(I,:);
      ENDDO

      OPEN(UNIT=22,FILE='gelss.mb',STATUS='UNKNOWN')
      DO I=1,MAX(M,N)
         DO J=1,NRHS
            READ(22,'(F3.0)') B(I,J)
         ENDDO
      ENDDO
      CLOSE(22)

      WRITE(*,*)'Matrix B :'
      DO I=1,M;
         WRITE(*,"(3(F9.5))") B(I,:);
      ENDDO

      AA=A
      BB=B

      JPVT(1)=0; JPVT(2)=0; JPVT(3)=1; JPVT(4)=0;

      WRITE(*,*) 'CALL LA_GELSY( A, B, RANK, JPVT, 1.0E-5_WP )'

      CALL LA_GELSY( A, B, RANK, JPVT, 1.0E-5_WP )

      WRITE(*,*) 'The matrix B on exit :'
      DO I=1,M;
         WRITE(*,"(3(E15.7),1X)") B(I,:);
      ENDDO

      WRITE(*,*)'RANK = ', RANK
      WRITE(*,*)'JPVT = ', JPVT

      END PROGRAM LA_SGELSY_EXAMPLE


! Copyright 2018 Timothy Hume
!
! Permission to use, copy, modify, and/or distribute this software for any
! purpose with or without fee is hereby granted, provided that the above
! copyright notice and this permission notice appear in all copies.
!
! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
! REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
! INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
! LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
! OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
! PERFORMANCE OF THIS SOFTWARE.

program mandelbrot
    use, intrinsic  :: iso_fortran_env
    use mbtypes
    use setup
    use image
    use mbmath
    implicit none

    !
    ! Variables read from the command line.
    !
    character(len=1024)         :: imgfile  ! Name of image file to create
    character(len=128)          :: cpt      ! Name of colour palette to use
    integer(int32)              :: nx       ! Width of image
    integer(int32)              :: ny       ! Height of image
    integer(int64)              :: itermax  ! Maximimum number of iterations
    real(real128)               :: zoom     ! Zoom factor
    real(real128)               :: cr       ! Real part of centre point
    real(real128)               :: ci       ! Imaginary part of centre point

    real(real64), allocatable   :: niter(:,:) ! Results array

    !
    ! Read the command line.
    !
    call read_cmd(cr, ci, nx, ny, zoom, itermax, cpt, imgfile)

    !
    ! Allocate memory for the niter array.
    !
    allocate(niter(nx, ny))

    !
    ! Compute the Mandelbrot set for the points of interest.
    !
    call fillplane(real(cr, realmb), real(ci, realmb), nx, ny, real(zoom, realmb), itermax, niter)
    !call mbplane(cr, ci, nx, ny, zoom, itermax, niter)

    !
    ! Colorise the set.
    !
    call colourise(niter, nx, ny, cpt, imgfile)

    deallocate(niter)

end program


      double precision function psi(xp,yp,zp,t)
      implicit none

      double precision xp,yp,zp,t
      double precision r2, pi2, revs_per_s

      double precision pi
      common /compi/ pi

      revs_per_s = 0.5d0

      pi2 = 2*pi

c     # annulus : Solid body rotation
      r2 = xp**2 + yp**2
      psi = 0.5d0*pi2*revs_per_s*r2

      psi = -psi

      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3),t) -
     &      psi(xd2(1),xd2(2),xd2(3),t))/ds

      end


      SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR,
     $                   VALI, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute exp(A*delta) where A is a real N-by-N non-defective
C     matrix with real or complex eigenvalues and delta is a scalar
C     value. The routine also returns the eigenvalues and eigenvectors
C     of A as well as (if all eigenvalues are real) the matrix product
C     exp(Lambda*delta) times the inverse of the eigenvector matrix
C     of A, where Lambda is the diagonal matrix of eigenvalues.
C     Optionally, the routine computes a balancing transformation to
C     improve the conditioning of the eigenvalues and eigenvectors.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     BALANC  CHARACTER*1
C             Indicates how the input matrix should be diagonally scaled
C             to improve the conditioning of its eigenvalues as follows:
C             = 'N':  Do not diagonally scale;
C             = 'S':  Diagonally scale the matrix, i.e. replace A by
C                     D*A*D**(-1), where D is a diagonal matrix chosen
C                     to make the rows and columns of A more equal in
C                     norm. Do not permute.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     DELTA   (input) DOUBLE PRECISION
C             The scalar value delta of the problem.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A of the problem.
C             On exit, the leading N-by-N part of this array contains
C             the solution matrix exp(A*delta).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,N).
C
C     V       (output) DOUBLE PRECISION array, dimension (LDV,N)
C             The leading N-by-N part of this array contains the
C             eigenvector matrix for A.
C             If the k-th eigenvalue is real the k-th column of the
C             eigenvector matrix holds the eigenvector corresponding
C             to the k-th eigenvalue.
C             Otherwise, the k-th and (k+1)-th eigenvalues form a
C             complex conjugate pair and the k-th and (k+1)-th columns
C             of the eigenvector matrix hold the real and imaginary
C             parts of the eigenvectors corresponding to these
C             eigenvalues as follows.
C             If p and q denote the k-th and (k+1)-th columns of the
C             eigenvector matrix, respectively, then the eigenvector
C             corresponding to the complex eigenvalue with positive
C             (negative) imaginary value is given by
C                                       2
C             p + q*j (p - q*j), where j  = -1.
C
C     LDV     INTEGER
C             The leading dimension of array V.  LDV >= max(1,N).
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
C             The leading N-by-N part of this array contains an
C             intermediate result for computing the matrix exponential.
C             Specifically, exp(A*delta) is obtained as the product V*Y,
C             where V is the matrix stored in the leading N-by-N part of
C             the array V. If all eigenvalues of A are real, then the
C             leading N-by-N part of this array contains the matrix
C             product exp(Lambda*delta) times the inverse of the (right)
C             eigenvector matrix of A, where Lambda is the diagonal
C             matrix of eigenvalues.
C
C     LDY     INTEGER
C             The leading dimension of array Y.  LDY >= max(1,N).
C
C     VALR    (output) DOUBLE PRECISION array, dimension (N)
C     VALI    (output) DOUBLE PRECISION array, dimension (N)
C             These arrays contain the real and imaginary parts,
C             respectively, of the eigenvalues of the matrix A. The
C             eigenvalues are unordered except that complex conjugate
C             pairs of values appear consecutively with the eigenvalue
C             having positive imaginary part first.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and if N > 0, DWORK(2) returns the reciprocal
C             condition number of the triangular matrix used to obtain
C             the inverse of the eigenvector matrix.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= max(1,4*N).
C             For good performance, LDWORK must generally be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = i:  if INFO = i, the QR algorithm failed to compute all
C                   the eigenvalues; no eigenvectors have been computed;
C                   elements i+1:N of VALR and VALI contain eigenvalues
C                   which have converged;
C             = N+1:  if the inverse of the eigenvector matrix could not
C                   be formed due to an attempt to divide by zero, i.e.,
C                   the eigenvector matrix is singular;
C             = N+2:  if the matrix A is defective, possibly due to
C                   rounding errors.
C
C     METHOD
C
C     This routine is an implementation of "Method 15" of the set of
C     methods described in reference [1], which uses an eigenvalue/
C     eigenvector decomposition technique. A modification of LAPACK
C     Library routine DGEEV is used for obtaining the right eigenvector
C     matrix. A condition estimate is then employed to determine if the
C     matrix A is near defective and hence the exponential solution is
C     inaccurate. In this case the routine returns with the Error
C     Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or
C     MB05OD are the preferred alternative routines to be used.
C
C     REFERENCES
C
C     [1] Moler, C.B. and Van Loan, C.F.
C         Nineteen dubious ways to compute the exponential of a matrix.
C         SIAM Review, 20, pp. 801-836, 1978.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB05AD by M.J. Denham, Kingston
C     Polytechnic, March 1981.
C
C     REVISIONS
C
C     V. Sima, June 13, 1997, April 25, 2003, Feb. 15, 2004.
C
C     KEYWORDS
C
C     Eigenvalue, eigenvector decomposition, matrix exponential.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         BALANC
      INTEGER           INFO, LDA, LDV, LDWORK, LDY, N
      DOUBLE PRECISION  DELTA
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), V(LDV,*), VALI(*), VALR(*),
     $                  Y(LDY,*)
C     .. Local Scalars ..
      LOGICAL           SCALE
      INTEGER           I
      DOUBLE PRECISION  RCOND, TEMPI, TEMPR, WRKOPT
C     .. Local Arrays ..
      DOUBLE PRECISION  TMP(2,2)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEBAK, DGEMM, DLACPY, DSCAL, DSWAP, DTRCON,
     $                  DTRMM, DTRSM, MB05MY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         COS, EXP, MAX, SIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      SCALE = LSAME( BALANC, 'S' )
      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDY.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB05MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of workspace needed at that point in the code,
C     as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
C     Compute the eigenvalues and right eigenvectors of the real
C     nonsymmetric matrix A; optionally, compute a balancing
C     transformation.
C     Workspace:  need: 4*N.
C
      CALL MB05MY( BALANC, N, A, LDA, VALR, VALI, V, LDV, Y, LDY,
     $             DWORK, LDWORK, INFO )
C
      IF ( INFO.GT.0 )
     $   RETURN
      WRKOPT = DWORK(1)
      IF ( SCALE ) THEN
         DO 10 I = 1, N
            DWORK(I) = DWORK(I+1)
   10    CONTINUE
      END IF
C
C     Exit with INFO = N + 1 if V is exactly singular.
C
      DO 20 I = 1, N
         IF ( V(I,I).EQ.ZERO ) THEN
            INFO = N + 1
            RETURN
         END IF
   20 CONTINUE
C
C     Compute the reciprocal condition number of the triangular matrix.
C
      CALL DTRCON( '1-norm', 'Upper', 'Non unit', N, V, LDV, RCOND,
     $             DWORK(N+1), IWORK, INFO )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN
         DWORK(2) = RCOND
         INFO = N + 2
         RETURN
      END IF
C
C     Compute the right eigenvector matrix (temporarily) in A.
C
      CALL DLACPY( 'Full', N, N, Y, LDY, A, LDA )
      CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non unit', N, N,
     $            ONE, V, LDV, A, LDA )
      IF ( SCALE )
     $   CALL DGEBAK( BALANC, 'Right', N, 1, N, DWORK, N, A, LDA, INFO )
C
C     Compute the inverse of the right eigenvector matrix, by solving
C     a set of linear systems, V * X = Y' (if BALANC = 'N').
C
      DO 40 I = 2, N
         CALL DSWAP( I-1, Y(I,1), LDY, Y(1,I), 1 )
   40 CONTINUE
C
      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non unit', N, N,
     $            ONE, V, LDV, Y, LDY )
      IF( SCALE ) THEN
C
         DO 60 I = 1, N
            TEMPR = ONE / DWORK(I)
            CALL DSCAL( N, TEMPR, Y(1,I), 1 )
   60    CONTINUE
C
      END IF
C
C     Save the right eigenvector matrix in V.
C
      CALL DLACPY( 'Full', N, N, A, LDA, V, LDV )
C
C     Premultiply the inverse eigenvector matrix by the exponential of
C     quasi-diagonal matrix Lambda * DELTA, where Lambda is the matrix
C     of eigenvalues.
C     Note that only real arithmetic is used, taking the special storing
C     of eigenvalues/eigenvectors into account.
C
      I = 0
C     REPEAT
   80 CONTINUE
      I = I + 1
      IF ( VALI(I).EQ.ZERO ) THEN
         TEMPR = EXP( VALR(I)*DELTA )
         CALL DSCAL( N, TEMPR, Y(I,1), LDY )
      ELSE
         TEMPR = VALR(I)*DELTA
         TEMPI = VALI(I)*DELTA
         TMP(1,1) = COS( TEMPI )*EXP( TEMPR )
         TMP(1,2) = SIN( TEMPI )*EXP( TEMPR )
         TMP(2,1) = -TMP(1,2)
         TMP(2,2) =  TMP(1,1)
         CALL DLACPY( 'Full', 2, N, Y(I,1), LDY, DWORK, 2 )
         CALL DGEMM( 'No transpose', 'No transpose', 2, N, 2, ONE,
     $               TMP, 2, DWORK, 2, ZERO, Y(I,1), LDY )
         I = I + 1
      END IF
      IF ( I.LT.N ) GO TO 80
C     UNTIL I = N.
C
C     Compute the matrix exponential as the product V * Y.
C
      CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, V, LDV,
     $            Y, LDY, ZERO, A, LDA )
C
C     Set optimal workspace dimension and reciprocal condition number.
C
      DWORK(1) = WRKOPT
      DWORK(2) = RCOND
C
      RETURN
C *** Last line of MB05MD ***
      END


C
C
       real*4 function ct_standard( rgb, ci, cimin, cimax )
C      ----------------------------------------------------
C
C Function defining an standard colour-scale.
C
C defining:
C             x = (ci-cimin)/(cimax-cimin)
C then:
C                red   = sin(power(red)*x)**2,
C                green = sin(power(green)*x)**2,
C                blue  = sin(power(blue)*x)**2
*-

       include '../include/tv_modify.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x

       x  = (float(ci-cimin)/float(cimax-cimin))
       ct_standard = (sin( col_index(rgb)*x ))**2
       end


      SUBROUTINE rotate(r,qt,n,np,i,a,b)
      INTEGER n,np,i
      REAL a,b,r(np,np),qt(np,np)
      INTEGER j
      REAL c,fact,s,w,y
      if(a.eq.0.)then
        c=0.
        s=sign(1.,b)
      else if(abs(a).gt.abs(b))then
        fact=b/a
        c=sign(1./sqrt(1.+fact**2),a)
        s=fact*c
      else
        fact=a/b
        s=sign(1./sqrt(1.+fact**2),b)
        c=fact*s
      endif
      do 11 j=i,n
        y=r(i,j)
        w=r(i+1,j)
        r(i,j)=c*y-s*w
        r(i+1,j)=s*y+c*w
11    continue
      do 12 j=1,n
        y=qt(i,j)
        w=qt(i+1,j)
        qt(i,j)=c*y-s*w
        qt(i+1,j)=s*y+c*w
12    continue
      return
      END

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


      PROGRAM TB2D

C This program computes the pressure distribution and several derived
C quantities for a finite tilting thrust bearing of rectangular shape.
C Calculations can be performed for different L/B ratios.

C X(I)     = position along x-axis (ie. x coordinate)
C Y(J)     = position along y-axis (ie. y coordinate)
C NX       = number of mesh points along x-axis
C NY       = number of mesh points along y-axis
C P(I,J)   = Pressure at node i,j at latest iteration level
C PPI(I,J) = Pressure at node i,j at the previous iteration
C H(I)     = film thickness at node i,j
C LB       = L/B ratio
C K        = H1/H0-1
C H1       = leading edge (maximum) film thickness
C H0       = trailing edge (minimum) film thickness
C NDLOAD   = Non-dimensional load capacity
C QX       = Flow-rate per unit length in the x-direction
C QY       = Flow-rate per unit breadth in the y-directon
C QE       = End-leakage (evaluated at the trailing edge)
C QS       = Side-leakage (evaluated at y* = 0.0)
C DPDX     = Pressure gradient in the x-direction
C DPDY     = Pressure gradient in the y-direction
C TORX0    = Shear stress on the lower surface in the x-direction
C TORXH    = Shear stress on the upper surface in the x-direction
C FF0      = Friction force on the lower surface
C FFH      = Friction force on the upper surface
C XBAR     = Location of the pivot point
C FOR      = Successive over-relaxation factor

C     Declaration of variables
      PARAMETER (N = 501, NTOTAL=N*N, PI=3.141592654, FOR=1.5)
      DOUBLE PRECISION K, LB, DX, DY, DX2, DY2, BL2
      DOUBLE PRECISION X(N), Y(N), H(N), PPI(N,N), P(N,N)
      DOUBLE PRECISION A(N), B(N), C(N), D(N)
      DOUBLE PRECISION NDLOAD, SGLINT, DBLINT
      DOUBLE PRECISION QX(N), QY(N), QE, QS
      DOUBLE PRECISION DPDX(N,N), DPDY(N,N), TORX0(N,N), TORXH(N,N)
      DOUBLE PRECISION XP(N,N), XBAR, FF0, FFH
      INTEGER NX, NXM1, NXM2, NY, NYM1, NYM2, ITER
      LOGICAL FLAG

C     Initialise variables
      DATA P /NTOTAL*0.0D0/, PPI /NTOTAL*0.0D0/
      DATA FLAG /.FALSE./, ITER /1/

C     Open results file
      OPEN (UNIT=1, FILE='tb2d_output.dat', STATUS='UNKNOWN')
      OPEN (UNIT=2, FILE='tb2d_plot.dat',   STATUS='UNKNOWN')
      OPEN (UNIT=3, FILE='tb2d_script.m',   STATUS='UNKNOWN')

C     Prompt user for input values
      WRITE(*,*) 'Enter value of L/B ratio'
      READ (*,*) LB
      WRITE(*,*) 'Enter value of K=(h1/h0)-1'
      READ (*,*) K
      WRITE(*,*) 'Enter value of NX'
      READ (*,*) NX
      WRITE(*,*) 'Enter value of NY'
      READ (*,*) NY

C     Dependent variables
      NXM1 = NX-1
      NXM2 = NX-2
      NYM1 = NY-1
      NYM2 = NY-2
      DX  = 1.0/NXM1
      DY  = 1.0/NYM1
      DX2 = DX**2
      DY2 = DY**2
      BL2 = (1/LB)**2

C     Initialise discrete grid points in the
C     (a) x-direction
      X(1)=0.0
      DO 5,I=2,NX
        X(I)=X(I-1)+DX
    5 CONTINUE

C     (b) y-direction
      Y(1)=0.0
      DO 10,J=2,NY
        Y(J)=Y(J-1)+DY
   10 CONTINUE

C     Initialise film thickness
      DO 15,I=1,NX
        H(I) = 1.0+K*(1-X(I))
   15 CONTINUE

C ---------------  ITERATION PROCESS  ---------------

      DO WHILE(FLAG .EQV. (.FALSE.))

C       Provide user feedback during iteration process
        WRITE(*,'(10X,A12,I5)') 'Iteration = ', ITER
        ITER = ITER + 1

C       Sweep all rows j=2,3,...,J-1
        DO 50,J=2,NYM1
          DO 35,I=2, NXM1
            A(I-1) = (1.0/DX2)+(1.5*K)/(DX*H(I))
            B(I-1) = -2.0*((1.0/DX2)+(BL2/DY2))
            C(I-1) = (1.0/DX2)-(1.5*K)/(DX*H(I))
            D(I-1) = -K/(H(I)**3)-(BL2/DY2)*(P(I,J-1)+P(I,J+1))
   35     CONTINUE

C         Use Thomas algorithm to solve tridiagonal system of algebraic equations
          CALL THOMAS(NXM2,A,B,C,D,N)

C         Capture solution from Thomas and apply SOR factor, For
          DO 40,I=2,NXM1
            P(I,J)   = PPI(I,J)+FOR*(D(I-1)-PPI(I,J))
            PPI(I,J) = P(I,J)
   40     CONTINUE

   50   CONTINUE

C       Sweep all columns i=2,3,...,I-1
        DO 65,I=2,NXM1
          DO 55,J=2, NYM1
            A(J-1) = (BL2/DY2)
            B(J-1) = -2.0*((1.0/DX2)+(BL2/DY2))
            C(J-1) = (BL2/DY2)
            D(J-1) = -K/(H(I)**3)
     +               -((1.0/DX2)+(1.5*K)/(DX*H(I)))*P(I-1,J)
     +               -((1.0/DX2)-(1.5*K)/(DX*H(I)))*P(I+1,J)
   55     CONTINUE

C         Use Thomas algorithm to solve tridiagonal system of algebraic equations
          CALL THOMAS(NYM2,A,B,C,D,N)

C         Capture solution from Thomas and apply SOR factor, For
          DO 60,J=2,NYM1
            P(I,J) = PPI(I,J)+FOR*(D(J-1)-PPI(I,J))
   60     CONTINUE

   65   CONTINUE

C       Convergence test
        CALL CVERGE(NX,NY,P,PPI,FLAG,N)

      END DO

C ---------------  END ITERATION PROCESS  ---------------

C     Calculate the non-dimensional load
      NDLOAD = DBLINT(P,DX,DY,NXM1,NYM1,N)

C     Calculate location of the pivot point, XBAR
      DO 75,J=1,NY
        DO 70,I=1,NX
          XP(I,J)=X(I)*P(I,J)
   70   CONTINUE
   75 CONTINUE
      XBAR = DBLINT(XP,DX,DY,NXM1,NYM1,N)/NDLOAD

C     Calculate the pressure gradients
C     (a) in the x-direction
      DO 85,J=1,NY
        DPDX(1,J)  = (-3.0*P(1,J)+4.0*P(2,J)-P(3,J))/(2.0*DX)
        DPDX(NX,J) = (3.0*P(NX,J)-4.0*P(NXM1,J)+P(NXM2,J))/(2.0*DX)
        DO 80,I=2,NXM1
          DPDX(I,J) = (P(I+1,J)-P(I-1,J))/(2.0*DX)
   80   CONTINUE
   85 CONTINUE

C     (b) in the y-direction
      DO 90,I=1,NX
        DPDY(I,1) = (-3.0*P(I,1)+4.0*P(I,2)-P(I,3))/(2.0*DY)
   90 CONTINUE

C     Calculate the friction force by integration of the shear
C     stress over the bearing area.  The friction force on the
C     lower surface is FFH, whereas that on the lower surface is FF0
      DO 100,J=1,NY
        DO 95,I=1,NX
          TORX0(I,J) = -3.0*H(I)*DPDX(I,J)-1.0/H(I)
          TORXH(I,J) =  3.0*H(I)*DPDX(I,J)-1.0/H(I)
   95   CONTINUE
  100 CONTINUE
      FF0 = DBLINT(TORX0,DX,DY,NXM1,NYM1,N)
      FFH = DBLINT(TORXH,DX,DY,NXM1,NYM1,N)

C     Calculate the side leakage, Qs
      DO 105,I=1,NX
        QY(I) = -H(I)**3/LB*DPDY(I,1)
  105 CONTINUE
      QS = -SGLINT(QY,DX,NXM1,N)

C     Calculate the end leakage, Qe
      DO 110,J=1,NY
        QX(J) = 0.5*LB*(H(NX)-(H(NX)**3)*DPDX(NX,J))
  110 CONTINUE
      QE = SGLINT(QX,DY,NYM1,N)

C --------------- PRINT RESULTS ---------------

C     Write results to end of existing results file
  115 READ(1,*,END=120)
      GO TO 115
  120 CONTINUE
      WRITE(1,125) LB,K,6*NDLOAD,XBAR,FF0,FFH,QS,QE
  125 FORMAT(2F10.2,6F10.5)

C     Write the pressure profile and pressure gradient
C     along the midplane to results file
      J=(NY+1)/2
      DO 130,I=1,NX
        WRITE(2,'(3F10.6)') X(I), P(I,J), DPDX(I,J)
  130 CONTINUE

C     Create Matlab script file to plot the non-dimensional film
C     thickness and the pressure distribution over the bearing
      WRITE(3,140) 'x=['
      DO 135,J=1,NY
        WRITE(3,145) (X(I),I=1,NX)
  135 CONTINUE
  140 FORMAT(A3)
  145 FORMAT(101F10.5)
      WRITE(3,*) '];'
      WRITE(3,*)

      WRITE(3,140) 'y=['
      DO 150,J=1,NY
        WRITE(3,145) (Y(J),I=1,NX)
  150 CONTINUE
      WRITE(3,*) '];'
      WRITE(3,*)

      WRITE(3,140) 'h=['
      DO 155,J=1,NY
        WRITE(3,145) (H(I),I=1,NX)
  155 CONTINUE
      WRITE(3,*) '];'
      WRITE(3,*)

      WRITE(3,140) 'p=['
      DO 160,J=1,NY
        WRITE(3,145) (P(I,J),I=1,NX)
  160 CONTINUE
      WRITE(3,*) '];'
      WRITE(3,*)

C     3D plot of the film thickness
      WRITE(3,*) 'figure(1);'
      WRITE(3,*) 'hold on;'
      WRITE(3,*) 'surf(x,y,h);'
      WRITE(3,*) 'view(-30,30);'
      WRITE(3,*) 'grid on;'
      WRITE(3,*) 'box on;'
      WRITE(3,*) 'axis([-Inf Inf -Inf Inf 0 Inf]);'
      WRITE(3,*) 'xlabel(''x^*'');'
      WRITE(3,*) 'ylabel(''y^*'');'
      WRITE(3,*) 'zlabel(''h^*'');'

C     3D plot of the pressure distribution
      WRITE(3,*) 'figure(2);'
      WRITE(3,*) 'hold on;'
      WRITE(3,*) 'surf(x,y,p);'
      WRITE(3,*) 'view(30,30);'
      WRITE(3,*) 'grid on;'
      WRITE(3,*) 'box on;'
      WRITE(3,*) 'xlabel(''x^*'');'
      WRITE(3,*) 'ylabel(''y^*'');'
      WRITE(3,*) 'zlabel(''p^*'');'

C     Contour plot of the pressure distribution
      WRITE(3,*) 'figure(3);'
      WRITE(3,*) 'hold on;'
      WRITE(3,*) 'contourf(x,y,p,10,''k'');'
      WRITE(3,*) 'box on;'
      WRITE(3,*) 'xlabel(''x^*'');'
      WRITE(3,*) 'ylabel(''y^*'');'

C     Close results files
      END FILE (UNIT=1)
      END FILE (UNIT=2)
      END FILE (UNIT=3)
      CLOSE (UNIT=1)
      CLOSE (UNIT=2)
      CLOSE (UNIT=3)

      STOP
      END

C ======================================================================

      SUBROUTINE THOMAS(NN,A,B,C,D,N)

C     This subroutine uses the Thomas algorithm for solving tri-diagonal
C     systems of algebraic equations with Dirichlet boundary conditions.
C     It is used in iterative line-by-line sweeps to determine the pressure
C     distribution over the bearing surfaces.

      DOUBLE PRECISION A(N),B(N),C(N),D(N)
      INTEGER N, NN

      B(1)=1.0/B(1)

      DO 5,I=2,NN
        B(I)=1.0/( B(I)-A(I)*B(I-1)*C(I-1) )
        D(I)=D(I)-A(I)*B(I-1)*D(I-1)
    5 CONTINUE

      D(NN)=D(NN)*B(NN)

      DO 10,I=NN-1,1,-1
        D(I)=( D(I)-D(I+1)*C(I) )*B(I)
   10 CONTINUE

      RETURN
      END

C ======================================================================

      SUBROUTINE CVERGE(NX,NY,P,PPI,FLAG,N)

C     This subroutine tests for convergence of the solution. If the
C     residual is less than or equal to RESLIM then the solution is
C     converged.  If the residual is greater than RESMAX, the solution
C     is diverging and the program is stopped.  Otherwise, an over -
C     relaxation factor is applied to speed up the iterative process
C     (This is performed in subroutines TB and CJB)

      PARAMETER (RESLIM=1.0D-6, RESMAX=1.0D2)
      DOUBLE PRECISION P(N,N), PPI(N,N), RESID
      LOGICAL FLAG

      RESID=0.0D0
      DO 10,J=1,NY
        DO 5,I=1,NX
          RESID = MAX(RESID,ABS(P(I,J)-PPI(I,J)))
    5 CONTINUE
   10 CONTINUE
      IF (RESID .LE. RESLIM) THEN
        FLAG = .TRUE.
      ELSE IF (RESID .GE. RESMAX) THEN
        STOP 'Solution not converging'
      ELSE
        DO 20,J=2,NY-1
          DO 15,I=2,NX-1
            PPI(I,J) = P(I,J)
   15     CONTINUE
   20   CONTINUE
      END IF

      RETURN
      END

C ======================================================================

      DOUBLE PRECISION FUNCTION SGLINT(FX,DX,NXM1,N)

C     This subroutine performs a single integration using the
C     trapezoidal rule of integration.

      DOUBLE PRECISION SUM, DX, FX(N)
      INTEGER I, NXM1, N

      SUM = 0.0
      DO 5,I=1,NXM1
        SUM = SUM + FX(I) + FX(I+1)
    5 CONTINUE

      SGLINT = 0.5*DX*SUM
      END

C ======================================================================

      DOUBLE PRECISION FUNCTION DBLINT(FXY,DX,DY,NXM1,NYM1,N)

C     This subroutine performs a double integration using the
C     trapezoidal rule of integration.

      DOUBLE PRECISION SUM, DX, DY, FXY(N,N)
      INTEGER NXM1, NYM1, N

      SUM=0.0
      DO 10,J=1,NYM1
        DO 5,I=1,NXM1
          SUM = SUM + FXY(I,J) + FXY(I,J+1) +
     +          FXY(I+1,J) + FXY(I+1,J+1)
    5   CONTINUE
   10 CONTINUE

      DBLINT = 0.25*DX*DY*SUM
      END


module module_random

use module_types, only: dp
use module_constants

implicit none

interface randn
  module procedure randn_r,randn_v,randn_a
end interface randn

contains
! ...
! =====================================================================
! ...
function randn_r () result(ff)

  real(dp)                                   :: ff

  ! ... Local variables
  ! ...
  real(dp), parameter                    :: s  =  0.449871D0
  real(dp), parameter                    :: t  = -0.386595D0
  real(dp), parameter                    :: a  =  0.19600D0
  real(dp), parameter                    :: b  =  0.25472D0
  real(dp), parameter                    :: r1 =  0.27597D0
  real(dp), parameter                    :: r2 =  0.27846D0
  real(dp) u,v,x,y,q

  do
    call RANDOM_NUMBER(u)  ! GNU RANDOM GENERATOR
    call RANDOM_NUMBER(v)  ! GNU RANDOM GENERATOR
    v = 1.7156D0 * (v - 0.5D0)

    ! ... Evaluate the quadratic form
    ! ...
    x = u - s
    y = ABS(v) - t
    q = x*x + y*(a*y - b*x)

    if (q .lt. r1) exit
    if (q .gt. r2) cycle
    if (v**2 .LT. -4D0*LOG(u)*u*u) exit
  enddo
  ff = v/u

end function randn_r
! ...
! =====================================================================
! ...
function randn_v (m) result(ff)

  integer, intent(in)                        :: m
  real(dp), dimension(m)                     :: ff

  ! ... Local variables
  ! ...
  integer i
  real(dp), parameter                    :: s  =  0.449871D0
  real(dp), parameter                    :: t  = -0.386595D0
  real(dp), parameter                    :: a  =  0.19600D0
  real(dp), parameter                    :: b  =  0.25472D0
  real(dp), parameter                    :: r1 =  0.27597D0
  real(dp), parameter                    :: r2 =  0.27846D0
  real(dp) u,v,x,y,q

  do i=1,m
    do
      call RANDOM_NUMBER(u)  ! GNU RANDOM GENERATOR
      call RANDOM_NUMBER(v)  ! GNU RANDOM GENERATOR
      v = 1.7156D0 * (v - 0.5D0)

      ! ... Evaluate the quadratic form
      ! ...
      x = u - s
      y = ABS(v) - t
      q = x*x + y*(a*y - b*x)

      if (q .lt. r1) exit
      if (q .gt. r2) cycle
      if (v**2 .LT. -4D0*LOG(u)*u*u) exit
    enddo
    ff(i) = v/u
  enddo

end function randn_v
! ...
! =====================================================================
! ...
function randn_a (m,n) result(ff)

  integer, intent(in)                        :: m
  integer, intent(in)                        :: n
  real(dp), dimension(:,:), pointer          :: ff

  ! ... Local variables
  ! ...
  integer i,j
  real(dp), parameter                    :: s  =  0.449871D0
  real(dp), parameter                    :: t  = -0.386595D0
  real(dp), parameter                    :: a  =  0.19600D0
  real(dp), parameter                    :: b  =  0.25472D0
  real(dp), parameter                    :: r1 =  0.27597D0
  real(dp), parameter                    :: r2 =  0.27846D0
  real(dp) u,v,x,y,q

  if (.not.associated(ff)) allocate(ff(m,n))

  do j=1,n
  do i=1,m
    do
      call RANDOM_NUMBER(u)  ! GNU RANDOM GENERATOR
      call RANDOM_NUMBER(v)  ! GNU RANDOM GENERATOR
      v = 1.7156D0 * (v - 0.5D0)

      ! ... Evaluate the quadratic form
      ! ...
      x = u - s
      y = ABS(v) - t
      q = x*x + y*(a*y - b*x)

      if (q .lt. r1) exit
      if (q .gt. r2) cycle
      if (v**2 .LT. -4D0*LOG(u)*u*u) exit
    enddo
    ff(i,j) = v/u
  enddo
  enddo

end function randn_a
! ...
! =====================================================================
! ...
function rndname(len,iseed) result(name)

integer, intent(in)            :: len
integer, optional              :: iseed
character(len=len)             :: name

! ... Local variables
integer i,io,il,j,n
integer, dimension(:), allocatable :: seed
real(dp) r

if (present(iseed)) then
  call random_seed(size=n)
  allocate(seed(n))
  seed(:) = iseed
  call random_seed(put=seed)
endif

io = ichar('A')
il = ichar('Z') - io

do i=1,len
  call random_number(r)
  j = int(io + il*r)
  name(i:i) = char(j)
enddo

return
end function rndname
! ...
! =====================================================================
! ...
function randseries(n,dlag,periodic) result(g)

integer, intent(in)             :: n
integer, intent(in), optional   :: dlag
logical, intent(in), optional   :: periodic
real(dp), dimension(n)          :: g

! ... Local variables
! ...
logical lper
integer nn,i,iter,im,ip
real(dp) xsum
real(dp), dimension(:), allocatable  :: v,f

lper = .false.
if (present(periodic)) then
  if (periodic) lper = .true.
endif

if (lper) then

  if (present(dlag)) then
    allocate(f(n))

    g = randn(n)
    g(n) = g(1)

    print*, dlag, g(n), g(1)
    do iter=1,6*abs(dlag)
      do i=1,n
        im = i - 1
        if (im.eq.0) im = n
        ip = i + 1
        if (ip.gt.n) ip = 1
        f(i) = 0.25D0*(g(im)+2*g(i)+g(ip))
      enddo
      g(:) = f(:)
    enddo
    deallocate(f)
    xsum = SUM(g)/n
    g(:) = g(:) - xsum
    xsum = sqrt(DOT_PRODUCT(g,g)/n)
    g(:) = g(:) / xsum

  else
    g = randn(n)
    g(n) = g(1)
  endif
else
  if (present(dlag)) then

    ! ... Buffering time series
    ! ...
    nn = n + 20*abs(dlag)
    allocate(v(nn))
    allocate(f(nn))

    v = randn(nn)
    do iter=1,6*abs(dlag)
      f(1) = v(1)
      f(nn) = v(nn)
      do i=2,nn-1
        f(i) = 0.25D0*(v(i-1)+2*v(i)+v(i+1))
      enddo
      v = f
    enddo

    ! ... Extracting far from boundary
    ! ...
    i = 10*abs(dlag)
    g(:) = f(i+1:i+n)

    xsum = SUM(g)/n
    g(:) = g(:) - xsum
    xsum = sqrt(DOT_PRODUCT(g,g)/n)
    g(:) = g(:) / xsum

    deallocate(f)
    deallocate(v)

  else

    g = randn(n)

  endif
endif

end function randseries
! ...
! =====================================================================
! ...
end module module_random


      subroutine shapefunctions(psi,eta,N,ShpFcnDeriv,maxint)
      integer maxint
      real*8 eta(maxint),psi(maxint)
      real*8 N(maxint,4), ShpFcnDeriv(maxint,2,4)

      do i=1,maxint
      N(i,1)=1./4.*(1.-psi(i))*(1.-eta(i))
      N(i,2)=1./4.*(1.+psi(i))*(1.-eta(i))
      N(i,3)=1./4.*(1.+psi(i))*(1.+eta(i))
      N(i,4)=1./4.*(1.-psi(i))*(1.+eta(i))
      ShpFcnDeriv(i,1,1)=-(1-eta(i))/4.
      ShpFcnDeriv(i,1,2)=(1-eta(i))/4.
      ShpFcnDeriv(i,1,3)=(1+eta(i))/4.
      ShpFcnDeriv(i,1,4)=-(1+eta(i))/4.
      ShpFcnDeriv(i,2,1)=-(1-psi(i))/4.
      ShpFcnDeriv(i,2,2)=-(1+psi(i))/4.
      ShpFcnDeriv(i,2,3)=(1+psi(i))/4.
      ShpFcnDeriv(i,2,4)=(1-psi(i))/4.
      enddo

      return
      end


      PROGRAM main
      IMPLICIT none
      REAL*8 pi,d2r,pi2,const
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2,pi2=pi*0.5d0,
     1        const=1.0d0/dsqrt(2.0d0))
      REAL*8 s,d,r
      REAL*8 normal(3),slip(3),tmp(3),alpha
      REAL*8 p(3),n(3),t(3),fth,fss,fno
      INTEGER i
  101 read (*,*,END=102) s,d,r
          s = s*d2r
          d = d*d2r
          r = r*d2r
          normal(1) =  0.0d0
          normal(2) = -dsin(d)
          normal(3) =  dcos(d)
          alpha = pi2 - s
          tmp(1) = dcos(alpha)*normal(1) - dsin(alpha)*normal(2)
          tmp(2) = dsin(alpha)*normal(1) + dcos(alpha)*normal(2)
          normal(1) = tmp(1)
          normal(2) = tmp(2)
          slip(1) = dcos(r)
          slip(2) = dsin(r)*dcos(d)
          slip(3) = dsin(r)*dsin(d)
          tmp(1) = dcos(alpha)*slip(1) - dsin(alpha)*slip(2)
          tmp(2) = dsin(alpha)*slip(1) + dcos(alpha)*slip(2)
          slip(1) = tmp(1)
          slip(2) = tmp(2)
          do 103 i = 1,3
              t(i) = const*(normal(i)+slip(i))
              p(i) = const*(normal(i)-slip(i))
  103     continue
          n(1) = normal(2)*slip(3) - normal(3)*slip(2)
          n(2) = normal(3)*slip(1) - normal(1)*slip(3)
          n(3) = normal(1)*slip(2) - normal(2)*slip(1)
          !print *,'p',p(1),p(2),p(3)
          !print *,'n',n(1),n(2),n(3)
          !print *,'t',t(1),t(2),t(3)
          fno = datan(p(3)/dsqrt(p(1)*p(1)+p(2)*p(2)))
          fss = datan(n(3)/dsqrt(n(1)*n(1)+n(2)*n(2)))
          fth = datan(t(3)/dsqrt(t(1)*t(1)+t(2)*t(2)))
          fno = dsin(fno)*dsin(fno)
          fss = dsin(fss)*dsin(fss)
          fth = dsin(fth)*dsin(fth)
          write(*,'(3F10.4)') fno,fss,fth
          goto 101
  102 continue
      END


! TO FIND THE MAXIMA AND MINIMA OF AN ALGEBRIC FUNCTION USING SECOND DERIVATIVE TEST FROM THE GIVEN VALUES

program maxima_minima
    implicit none
    real::ddy
    integer::i
    real,dimension(2)::x
    x(1)=-0.6
    x(2)=0.3
    do i=1,2
        if(ddy(x(i)) > 0) then
            print*,x(i),"is the Local Minimum"
        end if
        if(ddy(x(i)) < 0) then
            print*,x(i),"is the Local Maximum"
        end if
    end do
end program

function y(x)   !Defining Algebric Function
    implicit none
    real :: y   !Dummy Argument
    real :: x   !Local Variable
    y=5*(x**3)+2*(x**2)-3*x
end function

function ddy(x) !Second Derivative of above Algebric function
    implicit none
    real :: ddy   !Dummy Argument
    real :: x   !Local Variable
    ddy=30*x+4
end function


! Objetivo: Gerar um grafico da posicao media, da dispersao e do logaritmo
! da dispersão versus logaritmo de N.

PROGRAM caminhadas_aleatorias2

    USE nrtype
    USE ran_state, ONLY: ran_seed
    USE nr, ONLY: ran0

    IMPLICIT none
    INTEGER :: iseed = 1234
    INTEGER, PARAMETER :: passos_total = 200, total_caminhantes = 100000
    INTEGER :: passo, caminhante_n, posicao, passos_validos, posi_array
    INTEGER, PARAMETER :: dados_caminhada_aleatoria = 7
    REAL :: aleatorio
    INTEGER, PARAMETER :: dados_media = 7, dados_dispersao = 8, dados_log = 9
    INTEGER, PARAMETER :: num_pontos = 20, intervalo_passo = 10
    INTEGER, DIMENSION( num_pontos ) :: soma_posicao=0, soma_posicao_quad = 0
    REAL media, dispersao
    REAL, PARAMETER :: caminhantes_real = REAL(total_caminhantes)
! Iniciar semente
    CALL RAN_SEED (SEQUENCE = iseed)
    DO caminhante_n = 1, total_caminhantes
        posicao = 0
        DO passo = 1, num_pontos
            passos_validos = 0
            DO
                IF (passos_validos==intervalo_passo)EXIT
! Chamar numero aleatorio uniformemente distribuido entre 0. e 1.
! excluindo os extremos
                CALL ran0(aleatorio)
! A subrotina retorna um numero aleatorio uniformemente distribuido entre 0. e
! 1. (excluindo os extremos). Para termos chances iguais de movimentacao
! (direita e esquerda) assumimos que para aleatorio menor que 0.5 (passo para
! esquerda) para aleatorio maior que 0.5 (passo para direita) e para 0.5
! (nao anda).
                IF(aleatorio < 0.5)THEN
                    posicao = posicao-1
                    passos_validos = passos_validos+1
                ELSE
                    IF(aleatorio > 0.5) THEN
                        posicao = posicao+1
                        passos_validos = passos_validos+1
                    END IF
                END IF
            END DO
            soma_posicao(passo) = soma_posicao(passo) + posicao
            soma_posicao_quad(passo) = soma_posicao_quad(passo) + &
                                                            posicao*posicao
        END DO
    END DO

    OPEN(dados_media, file="dados_media.dat")
    OPEN(dados_dispersao, file="dados_dispersao.dat")
    OPEN(dados_log, file="dados_log.dat")
        DO passo=10, passos_total, intervalo_passo
            posi_array = passo/intervalo_passo
            media = soma_posicao(posi_array)/caminhantes_real
            dispersao = sqrt(soma_posicao_quad(posi_array)/&
                                    caminhantes_real - media*media)
            WRITE(dados_media, *) passo, media
            WRITE(dados_dispersao, *) passo, dispersao
            WRITE(dados_log, *) log(REAL(passo)), log(dispersao)
        END DO
    CLOSE(dados_media)
    CLOSE(dados_dispersao)
    CLOSE(dados_log)

END PROGRAM caminhadas_aleatorias2


MODULE Phys_consts
    Use nrtype
    !Frequently used mathematical constants (with precision to spare):
    REAL(DP), PARAMETER :: k_B         = 1.38064852D-23  ! Boltzman constant (SI units)
    REAL(DP), PARAMETER :: AvogNu      = 6.02214086D+23  ! Avogadro's number
    REAL(DP), PARAMETER :: perm0       = 8.85418782D-12  ! permittivity of free space (SI units)
    REAL(DP), PARAMETER :: perm0x4pi   = 1.11265006D-10  ! permittivity of free space times 4pi (SI units)

    REAL(DP), PARAMETER :: Debye_to_Cm = 3.33564D-30     ! convert Debye units to Coulomb times meter
    REAL(DP), PARAMETER :: Ang_to_m    = 1.D-10          ! convert Angstrom units to meters
END MODULE Phys_consts


      subroutine sols33(a,b)
      implicit none
      real*8 ,intent(in):: a(3,3)
      real*8 ,intent(out):: b(3,3)
      real*8 r,c,s,a11,a12,a32,a13,a33,a22,a23,rr
      r=hypot(a(1,1),a(3,1))
      c=a(1,1)/r
      s=a(3,1)/r
      a11=r
      a12= a(2,1)*c+a(3,2)*s
      a32=-a(2,1)*s+a(3,2)*c
      a13= a(3,1)*c+a(3,3)*s
      a33=-a(3,1)*s+a(3,3)*c
      rr=b(1,1)
      b(1,1)= rr*c+b(3,1)*s
      b(3,1)=-rr*s+b(3,1)*c
      rr=b(1,2)
      b(1,2)= rr*c+b(3,2)*s
      b(3,2)=-rr*s+b(3,2)*c
      rr=b(1,3)
      b(1,3)= rr*c+b(3,3)*s
      b(3,3)=-rr*s+b(3,3)*c
      r=hypot(a11,a(2,1))
      c=a11/r
      s=a(2,1)/r
      a11=r
      rr=a12
      a12= rr*c+a(2,2)*s
      a22=-rr*s+a(2,2)*c
      rr=a13
      a13= rr*c+a(3,2)*s
      a23=-rr*s+a(3,2)*c
      rr=b(1,1)
      b(1,1)= rr*c+b(2,1)*s
      b(2,1)=-rr*s+b(2,1)*c
      rr=b(1,2)
      b(1,2)= rr*c+b(2,2)*s
      b(2,2)=-rr*s+b(2,2)*c
      rr=b(1,3)
      b(1,3)= rr*c+b(2,3)*s
      b(2,3)=-rr*s+b(2,3)*c
      r=hypot(a22,a32)
      c=a22/r
      s=a32/r
      a22=r
      rr=a23
      a23= rr*c+a33*s
      a33=-rr*s+a33*c
      rr=b(2,1)
      b(2,1)= rr*c+b(3,1)*s
      b(3,1)=-rr*s+b(3,1)*c
      rr=b(2,2)
      b(2,2)= rr*c+b(3,2)*s
      b(3,2)=-rr*s+b(3,2)*c
      rr=b(2,3)
      b(2,3)= rr*c+b(3,3)*s
      b(3,3)=-rr*s+b(3,3)*c
      b(3,1)=b(3,1)/a33
      b(3,2)=b(3,2)/a33
      b(3,3)=b(3,3)/a33
      b(2,1)=(b(2,1)-a23*b(3,1))/a22
      b(2,2)=(b(2,2)-a23*b(3,2))/a22
      b(2,3)=(b(2,3)-a23*b(3,3))/a22
      b(1,1)=(b(1,1)-a13*b(3,1)-a12*b(2,1))/a11
      b(1,2)=(b(1,2)-a13*b(3,2)-a12*b(2,2))/a11
      b(1,3)=(b(1,3)-a13*b(3,3)-a12*b(2,3))/a11
      return
      end


      subroutine dtblok ( bloks, integs, nbloks, ipivot, iflag,
     *			  detsgn, detlog )
c  computes the determinant of an almost block diagonal matrix whose
c  plu factorization has been obtained previously in fcblok.
c  *** the logarithm of the determinant is computed instead of the
c  determinant itself to avoid the danger of overflow or underflow
c  inherent in this calculation.
c
c parameters
c    bloks, integs, nbloks, ipivot, iflag  are as on return from fcblok.
c	     in particular, iflag = (-1)**(number of interchanges dur-
c	     ing factorization) if successful, otherwise iflag = 0.
c    detsgn  on output, contains the sign of the determinant.
c    detlog  on output, contains the natural logarithm of the determi-
c	     nant if determinant is not zero. otherwise contains 0.
c
      integer nbloks, index, nrow
      integer integs(3,nbloks),ipivot(1),iflag, i,indexp,ip,k,last
      real bloks(1),detsgn,detlog
c
      detsgn = iflag
      detlog = 0.
      if (iflag .eq. 0) 		return
      index = 0
      indexp = 0
      do 2 i=1,nbloks
	 nrow = integs(1,i)
	 last = integs(3,i)
	 do 1 k=1,last
	    ip = index + nrow*(k-1) + ipivot(indexp+k)
	    detlog = detlog + alog(abs(bloks(ip)))
    1	    detsgn = detsgn*sign(1.,bloks(ip))
	 index = nrow*integs(2,i) + index
    2	 indexp = indexp + nrow
					return
      end


      FUNCTION dfridr(func,x,h,err)
      INTEGER NTAB
      REAL dfridr,err,h,x,func,CON,CON2,BIG,SAFE
      PARAMETER (CON=1.4,CON2=CON*CON,BIG=1.E30,NTAB=10,SAFE=2.)
      EXTERNAL func
CU    USES func
      INTEGER i,j
      REAL errt,fac,hh,a(NTAB,NTAB)
      if(h.eq.0.) pause 'h must be nonzero in dfridr'
      hh=h
      a(1,1)=(func(x+hh)-func(x-hh))/(2.0*hh)
      err=BIG
      do 12 i=2,NTAB
        hh=hh/CON
        a(1,i)=(func(x+hh)-func(x-hh))/(2.0*hh)
        fac=CON2
        do 11 j=2,i
          a(j,i)=(a(j-1,i)*fac-a(j-1,i-1))/(fac-1.)
          fac=CON2*fac
          errt=max(abs(a(j,i)-a(j-1,i)),abs(a(j,i)-a(j-1,i-1)))
          if (errt.le.err) then
            err=errt
            dfridr=a(j,i)
          endif
11      continue
        if(abs(a(i,i)-a(i-1,i-1)).ge.SAFE*err)return
12    continue
      return
      END

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


!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine ylmr2 (lmax2, ng, g, gg, ylm)
  !-----------------------------------------------------------------------
  !
  !     Real spherical harmonics ylm(G) up to l=lmax
  !     lmax2 = (lmax+1)^2 is the total number of spherical harmonics
  !     Numerical recursive algorithm based on the one given in Numerical
  !     Recipes but avoiding the calculation of factorials that generate
  !     overflow for lmax > 11
  !
  USE kinds, ONLY : DP
  USE constants, ONLY : pi, fpi
  implicit none
  !
  integer, intent(in) :: lmax2, ng
  real(DP), intent(in) :: g (3, ng), gg (ng)
  !
  ! BEWARE: gg = g(1)^2 + g(2)^2 +g(3)^2  is not checked on input
  !         incorrect results will ensue if the above does not hold
  !
  real(DP), intent(out) :: ylm (ng,lmax2)
  !
  ! local variables
  !
  real(DP), parameter :: eps = 1.0d-9
  real(DP), allocatable :: cost (:), sent(:), phi (:), Q(:,:,:)
  real(DP) :: c, gmod
  integer :: lmax, ig, l, m, lm
  !
  if (ng < 1 .or. lmax2 < 1) return
  do lmax = 0, 25
     if ((lmax+1)**2 == lmax2) go to 10
  end do
  call errore (' ylmr', 'l > 25 or wrong number of Ylm required',lmax2)
10 continue

  !
  if (lmax == 0) then
     ylm(:,1) =  sqrt (1.d0 / fpi)
     return
  end if
  !
  !  theta and phi are polar angles, cost = cos(theta)
  !
  allocate(cost(ng), sent(ng), phi(ng), Q(ng,0:lmax,0:lmax) )
  !
!$omp parallel default(shared), private(ig,gmod,lm,l,c,m)

!$omp do
  do ig = 1, ng
     gmod = sqrt (gg (ig) )
     if (gmod < eps) then
        cost(ig) = 0.d0
     else
        cost(ig) = g(3,ig)/gmod
     endif
     !
     !  beware the arc tan, it is defined modulo pi
     !
     if (g(1,ig) > eps) then
        phi (ig) = atan( g(2,ig)/g(1,ig) )
     else if (g(1,ig) < -eps) then
        phi (ig) = atan( g(2,ig)/g(1,ig) ) + pi
     else
        phi (ig) = sign( pi/2.d0,g(2,ig) )
     end if
     sent(ig) = sqrt(max(0d0,1.d0-cost(ig)**2))
  enddo
  !
  !  Q(:,l,m) are defined as sqrt ((l-m)!/(l+m)!) * P(:,l,m) where
  !  P(:,l,m) are the Legendre Polynomials (0 <= m <= l)
  !
  lm = 0
  do l = 0, lmax
     c = sqrt (DBLE(2*l+1) / fpi)
     if ( l == 0 ) then
!$omp do
        do ig = 1, ng
           Q (ig,0,0) = 1.d0
        end do
     else if ( l == 1 ) then
!$omp do
        do ig = 1, ng
           Q (ig,1,0) = cost(ig)
           Q (ig,1,1) =-sent(ig)/sqrt(2.d0)
        end do
     else
        !
        !  recursion on l for Q(:,l,m)
        !
        do m = 0, l - 2
!$omp do
           do ig = 1, ng
              Q(ig,l,m) = cost(ig)*(2*l-1)/sqrt(DBLE(l*l-m*m))*Q(ig,l-1,m) &
                       - sqrt(DBLE((l-1)*(l-1)-m*m))/sqrt(DBLE(l*l-m*m))*Q(ig,l-2,m)
           end do
        end do
!$omp do
        do ig = 1, ng
           Q(ig,l,l-1) = cost(ig) * sqrt(DBLE(2*l-1)) * Q(ig,l-1,l-1)
        end do
!$omp do
        do ig = 1, ng
           Q(ig,l,l)   = - sqrt(DBLE(2*l-1))/sqrt(DBLE(2*l))*sent(ig)*Q(ig,l-1,l-1)
        end do
     end if
     !
     ! Y_lm, m = 0
     !
     lm = lm + 1
!$omp do
     do ig = 1, ng
        ylm(ig, lm) = c * Q(ig,l,0)
     end do
     !
     do m = 1, l
        !
        ! Y_lm, m > 0
        !
        lm = lm + 1
!$omp do
        do ig = 1, ng
           ylm(ig, lm) = c * sqrt(2.d0) * Q(ig,l,m) * cos (m*phi(ig))
        end do
        !
        ! Y_lm, m < 0
        !
        lm = lm + 1
!$omp do
        do ig = 1, ng
           ylm(ig, lm) = c * sqrt(2.d0) * Q(ig,l,m) * sin (m*phi(ig))
        end do
     end do
  end do
  !
!$omp end parallel
  !
  deallocate(cost, sent, phi, Q)
  !
  return
end subroutine ylmr2


module utils_mod

use constants_mod

interface kronproduct
    procedure kronproduct_matmat
    procedure kronproduct_diagMat
end interface

interface pp
    procedure vp
    procedure mp
    procedure bp
    procedure tp
    procedure tp5
end interface

contains

!! pure elemental function logmean(uL,uR) result(r)
!!     real(dp), intent(in)    :: uL,uR
!!     real(dp)                :: r
!!
!!     r = (uL-uR+TOL)/(log(uL)-log(uR)+TOL)
!! end function

pure function calc_dist(a,b) result(dist)

    real(dp), intent(in)    :: a(N_DIMS),b(N_DIMS)
    real(dp)                :: dist
    real(dp)                :: v(N_DIMS)

    v = b-a
    dist = SQRT(SUM(v*v))

end function

pure elemental function logmean(aL,aR) result(r)

    real, intent(in)         :: aL, aR
    real(dp)                     :: x,u,r
    real(dp),parameter           :: eps = 1.0e-02_dp

    x = al/ar
    u = (x*(x-2.0_dp)+1.0_dp)/(x*(x+2.0_dp)+1.0_dp)
    r = merge((aL+aR)*52.50_dp/(105.0_dp + u*(35.0_dp + u*(21.0_dp +u*15.0_dp))), (aL-aR)/log(x), u < eps)

end function

!! subroutine write_headers(outputfp, buflen, buffer)
!!
!!     character(len=*), intent(in)    :: outputfp
!!     integer,intent(in)                 :: buflen
!!     character(len=*), intent(in)    :: buffer(:)
!!
!!     integer :: ioUnit
!!     integer :: openStat
!!
!!     character(range(buflen)+2) :: countStr
!!
!!     OPEN(NEWUNIT  = ioUnit             , &
!!          FILE     = TRIM(outputfp)     , &
!!          FORM     = 'FORMATTED'        , &
!!          STATUS   = 'UNKNOWN'          , &
!!          POSITION = 'REWIND'           , &
!!          RECL     = 50000              , &
!!          IOSTAT   = openStat             )
!!
!!     IF(openStat.NE.0) THEN
!!         CALL abort('ERROR: cannot open '// TRIM(outputfp))
!!     END IF
!!
!!     !! write nr. of columns to string
!!     write(countStr,'(i0)') buflen+1
!!     WRITE(ioUnit, '('// trim(countStr) //'(A))') "# ", buffer(1:buflen)
!!     CLOSE(ioUnit)
!!
!! end subroutine
!!

! This is a simple function to search for an available unit.
! LUN_MIN and LUN_MAX define the range of possible LUNs to check.
! The UNIT value is returned by the function, and also by the optional
! argument. This allows the function to be used directly in an OPEN
! statement, and optionally save the result in a local variable.
! If no units are available, -1 is returned.
function utils_get_newunit(unit) result(newunit)

    integer, intent(out), optional :: unit

    integer, parameter :: LUN_MIN=10, LUN_MAX=1000
    logical :: opened
    integer :: lun

    integer :: newunit

    newunit=-1

    do lun=LUN_MIN,LUN_MAX
        inquire(unit=lun,opened=opened)
        if (.not. opened) then
            newunit=lun
            exit
        end if
    end do

    if (present(unit)) unit = newunit

end function

subroutine write2file(outputfp, buflen, buffer)

    character(len=*), intent(in)    :: outputfp
    integer,intent(in) :: buflen
    real(dp),intent(in) :: buffer(:)

    integer :: ioUnit
    integer :: openStat

    character(range(buflen)+2) :: countStr

    !OPEN(NEWUNIT  = ioUnit             , &
    OPEN(UNIT     = utils_get_newunit(ioUnit), &
         FILE     = TRIM(outputfp)     , &
         FORM     = 'FORMATTED'        , &
         STATUS   = 'UNKNOWN'          , &
         POSITION = 'APPEND'           , &
         RECL     = 50000              , &
         IOSTAT   = openStat             )

    IF(openStat.NE.0) THEN
        !CALL abort('ERROR: cannot open '// TRIM(outputfp))
        write (*,*) 'ERROR: cannot open '// TRIM(outputfp)
        return
    END IF

    !! write nr. of columns to string
    write(countStr,'(i0)') buflen
    WRITE(ioUnit, '('// trim(countStr) //'(ES32.23,1x))') buffer(1:buflen)
    CLOSE(ioUnit)

end subroutine write2file

function incr(n)

    implicit none

    integer, intent(inout) :: n
    integer :: incr

    n = n + 1
    incr = n

end function

pure function krondelta(i,j) result(k)

    integer, intent(in) :: i,j
    integer :: k

    if (i == j) then
        k = 1
    else
        k = 0
    end if

end function

pure function isintegerdivisible(a,b) result(c)

    integer, intent(in) :: a,b
    integer :: c

    if (mod(a,b) == 0) then
        c = 1
    else
        c = 0
    end if

end function

function kronproduct_matmat(A,B) result(C)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: B(:,:)

    real(dp) :: C(size(A,1)*size(B,1),size(A,2)*size(B,2))

    integer     :: i,j
    integer     :: bn(2),cn(2)

    bn = shape(B)
    cn = shape(A)*shape(B)

    do i = 1,cn(1); do j = 1,cn(2)
        C(i,j) = A((i-1)/bn(1)+1,(j-1)/bn(2)+1) * B(mod(i-1,bn(1))+1, mod(j-1,bn(2))+1)
    end do; end do

end function

function kronproduct_diagMat(A,B) result(C)

    real(dp), intent(in) :: A(:)
    real(dp), intent(in) :: B(:,:)

    real(dp) :: C(size(A)*size(B,1),size(A)*size(B,2))

    integer     :: i,j, iA, jA
    integer     :: bn(2),cn(2)

    bn = shape(B)
    cn = size(A)*shape(B)

    do i = 1,cn(1); do j = 1,cn(2)
        iA = (i-1)/bn(1)+1
        jA = (j-1)/bn(2)+1

        if (iA == jA) then
            C(i,j) = A(iA) * B(mod(i-1,bn(1))+1, mod(j-1,bn(2))+1)
        else
            C(i,j) = 0.0_dp
        end if
    end do; end do

end function

function eyeproduct(N,B) result(C)

    integer, intent(in)     :: N
    real(dp), intent(in)    :: B(:,:)

    real(dp) :: C(N*size(B,1),N*size(B,2))

    integer     :: i,j, iA, jA
    integer     :: bn(2),cn(2)

    bn = shape(B)
    cn = N*shape(B)

    C = 0.0_dp

    do i = 1,cn(1); do j = 1,cn(2)
        iA = (i-1)/bn(1)+1
        jA = (j-1)/bn(2)+1

        if (iA == jA) then
            C(i,j) = B(mod(i-1,bn(1))+1, mod(j-1,bn(2))+1)
        end if
    end do; end do

end function

pure function calc_index_window(nelems,nranks,rankid) result(window)

    integer(kind=8), intent(in) :: nelems
    integer(kind=4), intent(in) :: nranks,rankid
    integer(kind=8)             :: window(2)

    integer(kind=8) :: a,b,NelemsPerRank,NelemsResidual

    NelemsPerRank = nelems / nranks
    NelemsResidual = mod(nelems,INT(nranks,kind=8))

    if (rankid < NelemsResidual) then
        a = rankid * NelemsPerRank + mod(INT(rankid,kind=8),NelemsResidual) + 1
        b = a + NelemsPerRank
    else
        a = rankid * NelemsPerRank + NelemsResidual + 1
        b = a + NelemsPerRank - 1
    end if

    window = (/a,b/)

end function

pure elemental function vmin(a,b) result(c)

    real(dp), intent(in)    :: a,b
    real(dp)                :: c

    c = min(a,b)

end function

pure elemental function vmax(a,b) result(c)

    real(dp), intent(in)    :: a,b
    real(dp)                :: c

    c = max(a,b)

end function

function tostr(num) result(str)

    integer, intent(in) :: num
    character(len=16)   :: str

    write(str,'(i0)') num

end function

subroutine tp5(title,blk)

    character(len=*), intent(in)    :: title
    real(dp), intent(in)            :: blk(:,:,:,:,:)

    integer :: i,k,l,q

    do q = 1,size(blk,5)
        do l = 1,size(blk,4)
            do k = 1,size(blk,3)
                write (*,'((a12),(a6),(i3),(a6),(i3),(a6),(i3))') trim(title),' | q = ', q, ' | w = ', l, ' | z = ', k
                do i = 1,size(blk,1)
                    write (*,'(99(ES12.4))') blk(i,:,k,l,q)
                end do
                write (*,*)
            end do
            write (*,*)
        end do
        write (*,*)
    end do
    write (*,*)

end subroutine

subroutine tp(title,blk)

    character(len=*), intent(in)    :: title
    real(dp), intent(in)            :: blk(:,:,:,:)

    integer :: i,k,l

    do l = 1,size(blk,4)
        do k = 1,size(blk,3)
            write (*,'((a12),(a6),(i3),(a6),(i3))') trim(title),' | w = ', l, ' | z = ', k
            do i = 1,size(blk,1)
                write (*,'(99(ES12.4))') blk(i,:,k,l)
            end do
            write (*,*)
        end do
        write (*,*)
    end do
    write (*,*)

end subroutine

subroutine bp(title,blk)

    character(len=*), intent(in)    :: title
    real(dp), intent(in)            :: blk(:,:,:)

    integer :: i,k

    do k = 1,size(blk,3)
        write (*,*) trim(title) // ' | z = ' // tostr(k)
        do i = 1,size(blk,1)
            write (*,'(99(ES12.4))') blk(i,:,k)
        end do
        write (*,*)
    end do
    write (*,*)

end subroutine

subroutine mp(title,mat)

    character(len=*), intent(in)    :: title
    real(dp), intent(in)            :: mat(:,:)

    integer :: i

    write (*,*) trim(title)
    do i = 1,size(mat,1)
        write (*,'(99(ES12.4))') mat(i,:)
    end do
    write (*,*)

end subroutine

subroutine vp(title,vec)

    character(len=*), intent(in)    :: title
    real(dp), intent(in)            :: vec(:)

    integer :: i

    write (*,*) trim(title)
    write (*,'(99(ES12.4))') vec
    write (*,*)

end subroutine

end module


MODULE evaluate
IMPLICIT NONE
PRIVATE
PUBLIC eval3, initl

! Declare shared data.
REAL, SAVE :: a, b, c, d

! Declare procedures
CONTAINS
   SUBROUTINE eval3 ( x, result )
   !
   !     Evaluates a third order polynomial of the form:
   !        RESULT = A + B*X + C*X**2 + D*X**3
   !
   ! Declare calling arguments
   REAL, INTENT(IN) :: x
   REAL, INTENT(OUT) :: result

   ! Calculate result
   result = a + b**x + c*x**2 + d*x**3

   END SUBROUTINE eval3

   SUBROUTINE initl (a1, b1, c1, d1 )
   !
   ! Subroutine INITL specifies the values of a, b, c, and d
   ! to be used when evaluating the polynomial.
   !
   REAL, INTENT(IN) :: a1, b1, c1, d1
   a = a1
   b = b1
   c = c1
   d = d1
   END SUBROUTINE initl
END MODULE evaluate

PROGRAM test
USE evaluate
REAL :: a = 1., b = 2., c = 1., d = 2.
CALL initl ( a, b, c, d )
DO i = 1, 10
   CALL eval3 ( REAL(i), result )
   WRITE (*,*) 'EVAL3(', i, ') = ', result
END DO
END PROGRAM test_noentry


program hilbert2

    implicit none
    integer :: n
    real(kind=8) :: cond

    open(21, file='cond.txt',status='unknown')

    do n=2,20
        cond = hilbert_condition(n)
        !print *, "cond = ",cond
        write(21, 210) n,cond
 210    format(i4,e16.6)
        enddo

    print *, "Created cond.txt"

contains

    real(kind=8) function hilbert_condition(n)

    implicit none
    integer, intent(in) :: n
    real(kind=8), dimension(:),allocatable :: x,b,work
    real(kind=8), dimension(:,:),allocatable :: a
    real(kind=8) :: errnorm, xnorm, rcond, anorm, colsum
    integer :: i, info, lda, ldb, nrhs, j
    integer, dimension(:), allocatable :: ipiv
    integer, allocatable, dimension(:) :: iwork
    character, dimension(1) :: norm

    allocate(a(n,n))
    allocate(b(n))
    allocate(x(n))
    allocate(ipiv(n))

    nrhs = 1 ! number of right hand sides in b
    lda = n  ! leading dimension of a
    ldb = n  ! leading dimension of b

    do j=1,n
        do i=1,n
            a(i,j) = 1.d0 / (i+j-1.d0)
            enddo
        enddo

    x = 1.d0
    b = matmul(a,x)

    ! do not need to solve a system, but do need to do factorization:
    call dgetrf(n, n, a, lda, ipiv, info)

    ! compute 1-norm needed for condition number

    anorm = 0.d0
    do j=1,n
        colsum = 0.d0
        do i=1,n
            colsum = colsum + abs(a(i,j))
            enddo
        anorm = max(anorm, colsum)
        enddo

    ! compute condition number of matrix:
    ! note: uses A returned from dgesv with L,U factors:

    allocate(work(4*n))
    allocate(iwork(n))
    norm = '1'  ! use 1-norm
    call dgecon(norm,n,a,lda,anorm,rcond,work,iwork,info)

    if (info /= 0) then
        print *, "*** Error in dgecon: info = ",info
        endif

    hilbert_condition = 1.d0 / rcond

    deallocate(a,b,ipiv)
    deallocate(work,iwork)

    end function hilbert_condition

end program hilbert2


program vin
  print *, mod(10,3)
end program vin


program Example
  implicit none

  integer :: num
  character(32) :: str

  str = "0123459"
  read(str, "(i10)") num   ! Decimal
  write(*,*) num           ! Prints 123459

  str = "abcf123"
  read(str, "(z8)") num    ! Hexadecimal
  write(*,*) num           ! Prints 180154659

  str = "7651"
  read(str, "(o11)") num   ! Octal
  write(*,*) num           ! Prints 4009

  str = "1010011010"
  read(str, "(b32)") num   ! Binary
  write(*,*) num           ! Prints 666

end program


program ASA

implicit none
real,allocatable,dimension(:,:)::A,L,U,C,inv
real,allocatable,dimension(:)::sol,B,D,X
real:: det
integer::n,m,f,i

call matriz(A,n,n) !ingresar una matriz nxm
call matcof(A,n,C,inv)  !matriz de cofactores

allocate(B(n))

write(*,*) 'hoa'

do i=1,n
read(*,*) B(i)
end do
call solcof(B,A,n,D)

 write(*,*) 'yea'
do i=1,n
 write(*,*) D(i)
end do

 write(*,*) 'yea'

call kramer(A,n,B,X)
do i=1,n
write(*,*) X(i)
end do
!-----------------------------------------------------------------------
contains
! ----------------------------------------------------------------------
subroutine  matlu(A,n,m,L,U)

! esta subrutina come una matriz A con n filas y m columnas y devuelve una matriz L y una matriz U

implicit none
real,allocatable,dimension(:,:)::A,L,U,D
integer:: k,h,j,n,m

allocate(L(n,m),U(n,m),D(n,m))
D=A
U=A
do h= 1,m
 do j= 1,n
! j filas, h columnas
if (j>h) then
   do k=1,m
  	U(j,k)=A(j,k)-(A(j,h)/A(h,h))*A(h,k)
   end do
   L(j,h)=(A(j,h)*(1/A(h,h)))
else if (j==h) then
 L(j,h)=1
else
  L(j,h)=0
end if
 end do
A=U
end do
A=D
return
end subroutine
!--------------------------------------------------------------

subroutine matdet(A,n,det)
! esta matriz calcula determinante de una matriz A nxn

implicit none
real,allocatable,dimension(:,:)::A,L,U
integer:: i,n
real::det

if (n==1) then
 det=A(1,1)
else
call matlu(A,n,n,L,U)
det=1
do i=1,n
det=U(i,i)*det
end do
end if
return
end subroutine

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

subroutine matcof(A,n,C,inv)
! esta subrutina come una matriz A con n filas y m columnas y devuelve una matriz C de cofactores

implicit none
real,allocatable,dimension(:,:)::A,C,L,U,C2,inv
integer:: k,h,j,n,i,z
real::det
allocate(C(n,n),C2(n-1,n-1))

!h=f,k=c,i=f,j=c
do h=1,n
do k=1,n

do i=1,n
do j=1,n

!ME ARMO UNA MATRIZ SIN ESA FILA Y COLUMNA Y LE HAGO EL DETERMINANTE
if (j/=k.and.i/=h) then

   if (i<h.and.j<k) then
      C2(i,j)=A(i,j)
   else if (i<h.and.j>k) then
      C2(i,j-1)=A(i,j)
   else if (i>h.and.j<k) then
      C2(i-1,j)=A(i,j)
   else if (i>h.and.j>k) then
      C2(i-1,j-1)=A(i,j)
      else
   end if

end if

end do
end do
  call matdet(C2,(n-1),det)
  C(h,k)=det*((-1)**(h+k))
end do

end do

call matdet(A,n,det)

allocate(inv(n,n))

do i=1,n
do j=1,n
 inv(i,j)=C(j,i)/det
end do
end do

deallocate(C2)
return

end subroutine
!--------------------------------------------------------------
subroutine matriz(mat,fila,colum)
!esta subrutina te genera una matriz mat de fila y columna ingresada
real,allocatable,dimension(:,:)::mat
integer:: fila,colum,fila2,colum2,i

Write(*,*) "Ingrese las dimenciones de la matriz"
Write(*,*) "Filas"
read(*,*) fila
Write(*,*) "Columnas"
read(*,*) colum

allocate(mat(fila,colum))

write(*,*) "Ingrese los elementos de la matriz"
fila2=1
colum2=1

do while(fila2<=fila)
 do while(fila2<=fila.and.colum2<=colum)
 Write(*,*)"Ingrese el elemento de la matriz",fila2,",",colum2
 read(*,*)mat(fila2,colum2)
 colum2=colum2+1
end do
fila2=fila2+1
colum2=1
enddo
Write(*,*)"La matriz ingresada fue :"
do i=1,fila,1
write(*,*) mat(i,:)
end do
return
end subroutine

!---------------------------------------------
!error en la division. reveer
subroutine solveLU(L,U,n,B,solu)
! esta subrutina come una matriz L y U de la descomposicion LU, un vector B
! que es el resultado, donde todas tiene n filas y devuelve el vector solucion

implicit none
real,allocatable,dimension(:,:)::L,U
real,allocatable,dimension(:)::solu,B,sol2
integer:: j,i,n,k
real::suma,suma2

allocate(sol2(n),solu(n))
sol2(:)=1.0d0
solu(:)=1.0d0

do i=1,n

if (i==1) then
 sol2(1)=B(1)/L(1,1)
else
suma=0
do k=1,(i-1)
suma=L(i,k)*sol2(k)+suma
end do
sol2(i)=(1./(L(i,i)))*(B(i)-suma)
end if

end do

solu(n)=sol2(n)/U(n,n)

do i=1,(n-1)
suma2=0
do k=(n-i+1),n
suma2=U(n-i,k)*solu(k)+suma2
end do
solu(n-i)=(1./(U(n-i,n-i)))*(sol2(n-i)-suma2)
end do

deallocate (sol2)
return
end subroutine
!------------------------------
subroutine solcof(B,A,n,D)

implicit none
real,allocatable,dimension(:,:)::A,inv,C
real,allocatable,dimension(:)::D,B
integer:: n

call matcof(A,n,C,inv)
allocate(D(n))
D=matmul(inv,B)

return
end subroutine
!----------------------------
subroutine kramer(A,n,B,X)
implicit none
real, allocatable, dimension(:,:)::A,G,F
real, allocatable, dimension(:)::B,X
integer:: n,k,j,i
real:: det,deter

call matdet(A,n,det)

allocate(X(n))

do k=1,n
allocate(F(n,n))

do i=1,n
do j=1,n

if (k==j) then
F(i,j)=B(i)
else
F(i,j)=A(i,j)
end if
end do
end do
deter=0
call matdet(F,n,deter)
X(k)=deter/det
deallocate(F)

end do
return
end subroutine

!--------------------------------
end program


#include "macros.h"
program main
    ! modules:
    use numbers
    use openmpi
    use io
    use parameters
    use fftw
    use diffops
    use vfield
    use rhs
    use timestep
    use run

    integer(i4) :: d, iter
    real(dp) :: local_error, relative_error, norm_velfield, norm_test_fieldk, max_error
    complex(dpc), allocatable :: velfieldk(:, :, :, :), div_velfield(:, :, :), test_fieldk(:, :, :, :)
    real(dp), allocatable :: test_fieldxx(:, :, :, :)

    _indices

    ! initialization:
    call openmpi_init
    call io_init
    call parameters_init
    call fftw_init

    write(out, '(79(''=''))')
    write(out, *) "# Tests begin."

    allocate(div_velfield(nx_perproc, ny_half, nz), stat=ierr)
    allocate(velfieldk(nx_perproc, ny_half, nz, 3), stat=ierr)
    allocate(test_fieldk(nx_perproc, ny_half, nz, 3), stat=ierr)
    allocate(test_fieldxx(nyy, nzz_perproc, nxx, 3), stat=ierr)

    if (ierr/=0) then
        write(out,*) "Cannot allocate test variables, stopping."
        flush(out)
        error stop
    end if

    relative_error = 0
    test_fieldxx = 0
    test_fieldk = 0

    ! initialize from a random field with no symmetries [gokhan 21-06-24]
    call vfield_random(velfieldk, .false.)

    call vfield_norm(velfieldk, norm_velfield, .true.)

    ! write(out, *) "Random state generator relative_error = ", relative_error / norm_velfield

    write(out, '(79(''=''))')
    write(out, *) "Testing forward-backward Fourier transforms ..."

    call fftw_vk2x(velfieldk, test_fieldxx)
    call fftw_vx2k(test_fieldxx, test_fieldk)
    call vfield_norm(test_fieldk, norm_test_fieldk, .true.)
    call vfield_norm(velfieldk - test_fieldk, relative_error, .true.)
    relative_error = relative_error / norm_velfield

    write(out, *) "norm_velfield = ", norm_velfield
    write(out, *) "norm_test_fieldk = ", norm_test_fieldk
    write(out, *) "Relative error after k2x and x2k transforms = ",  relative_error

    if(relative_error < epsilon) then
        write(out, *) "forward-backward Fourier transform -- Pass"
    else
        write(out, *) "forward-backward Fourier transform -- Fail"
        flush(out)
        error stop
    end if

    write(out, '(79(''=''))')
    write(out, *) "Computing the velocity field's divergence ..."

    call diffops_div(velfieldk, div_velfield)
    max_error = maxval(abs(div_velfield))
    write(out, *) "max_error = ", max_error

    if(max_error < epsilon) then
        write(out, *) "divergence test -- Pass"
    else
        write(out, *) "divergence test -- Fail"
        flush(out)
        error stop
    end if

    write(out, '(79(''=''))')
    write(out, *) "# Tests over. -- Passed all."
    write(out, '(79(''=''))')
    call run_exit

end program main


MODULE MATLIB
 USE NRTYPE
 IMPLICIT NONE
 CONTAINS
 !-----------------------------------------------------------
 SUBROUTINE FLIP(X)
 IMPLICIT NONE
 COMPLEX(DP), DIMENSION(:) :: X
 X = X(UBOUND(X,1):LBOUND(X,1):-1)
 END SUBROUTINE
 !-----------------------------------------------------------
 FUNCTION EYE(N) RESULT(M)
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: N
 COMPLEX(DP), DIMENSION(N,N) :: M
 INTEGER :: I,J
 DO I = 1,N
  DO J = 1,N
   IF (I.EQ.J) THEN
    M(I,J) = 1._DP
   ELSE
    M(I,J) = 0._DP
   END IF
  END DO
 END DO
 END FUNCTION
 !-----------------------------------------------------------
 FUNCTION ONES(N) RESULT(X)
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: N
 COMPLEX(DP), DIMENSION(N) :: X
 INTEGER :: I
 DO I = 1,N
  X(I) = 1._DP
 END DO
 END FUNCTION
 !-----------------------------------------------------------
 FUNCTION DIAG(X,N) RESULT(M)
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: N
 COMPLEX(DP), DIMENSION(:) :: X
 COMPLEX(DP), DIMENSION(N,N) :: M
 INTEGER :: I
 M = 0._DP
 DO I = 1,N
  M(I,I) = X(I)
 END DO
 END FUNCTION
 !-----------------------------------------------------------
 FUNCTION BAND(E,N,KL,KU) RESULT(M)
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: N, KL, KU
 COMPLEX(DP), INTENT(IN), DIMENSION(:) :: E
 COMPLEX(DP), DIMENSION(N,N) :: M
 INTEGER :: I, J
 M = 0._DP
 DO J = 1,N
  DO I = MAX(1,J-KU),MIN(N,J+KL)
   M(I,J) = E(I)
  END DO
 END DO
 END FUNCTION
 !-----------------------------------------------------------
 FUNCTION DENSE2BAND(M,N,KL,KU) RESULT(MB)
 IMPLICIT NONE
 INTEGER, INTENT(IN) :: N, KL, KU
 COMPLEX(DP), INTENT(IN), DIMENSION(:,:) :: M
 COMPLEX(DP), DIMENSION(KL+KU+1,N) :: MB
 INTEGER :: I, J
 DO J = 1,N
  DO I = MAX(1,J-KU),MIN(N,J+KL)
   MB(KU+1+I-J,J) = M(I,J)
  END DO
 END DO
 END FUNCTION
 !-----------------------------------------------------------
 !SUBROUTINE D2SP(M,N)
 !END SUBROUTINE
 !-----------------------------------------------------------
 FUNCTION INV(A) RESULT(M)
 IMPLICIT NONE
 COMPLEX(DP), DIMENSION(:,:), INTENT(IN) :: A
 COMPLEX(DP), DIMENSION(SIZE(A,1), SIZE(A,2)) :: M
 COMPLEX(DP), DIMENSION(SIZE(A,1)) :: WORK
 COMPLEX(DP), DIMENSION(SIZE(A,1)) :: IPIV
 INTEGER :: N, INFO
 M = A
 N = SIZE(A,1)
 CALL ZGETRF(N,N,M,N,IPIV,INFO)          !LAPACK ROUTINE FOR LU FACTORIZATION
 IF (INFO/= 0) THEN
  STOP "WARNING : Input Matrix is singular !"
 END IF
 CALL ZGETRI(N,M,N,IPIV,WORK,N,INFO)     !INVERSE OF LU
 IF (INFO/= 0) THEN
  STOP "WARNING : Input Matrix is singular !"
 END IF
 END FUNCTION
 !-----------------------------------------------------------
END MODULE


! { dg-do run }
! Test constructors of nested derived types with allocatable components(PR 20541).
!
! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
!            and Paul Thomas  <pault@gcc.gnu.org>
!
  type :: thytype
    integer(4), allocatable :: h(:)
  end type thytype

  type :: mytype
    type(thytype), allocatable :: q(:)
  end type mytype

  type (mytype) :: x
  type (thytype) :: w(2)
  integer :: y(2) =(/1,2/)

  w = (/thytype(y), thytype (2*y)/)
  x = mytype (w)
  if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) call abort ()

  x = mytype ((/thytype(3*y), thytype (4*y)/))
  if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) call abort ()

end


! Module for performing an anti-transpose.
! An anti-transpose is a transpose along the anti-diagonal.
module antitr_module
    implicit none

    public :: antitr

contains

    ! Performs anti-transpose.
    function antitr (a, n) result (at)
        ! a is input matrix, at is anti-transposed matrix.
        integer, dimension (n, n), intent (in) :: a
        integer, intent (in) :: n
        integer, dimension (n, n) :: at

        integer :: i

        do i = 1, n
            at(:, n - i + 1) = a(i, n:1:-1)
        end do

    end function antitr

end module antitr_module

! Driver code.
program main
    use antitr_module
    implicit none

    ! Size of the matrix.
    integer, parameter :: n = 5

    ! Declarations.
    integer, dimension (n, n) :: a
    integer, dimension (n) :: temp
    integer :: i

    ! Constructing the matrix to anti-transpose.
    ! Just filling out the values to be 1 through n^2.
    do i = 1, n
        temp(i) = i
    end do

    do i = 1, n
        a(i, :) = temp
        temp = temp + n
    end do

    ! Perform anti-transposes and prints results.
    print '(a)', 'Perform an anti-traspose.'
    print '(a)', 'Before:'
    call print_mat(a, n)

    a = antitr(a, n)

    print '(2a)', new_line('a'), 'After:'
    call print_mat(a, n)

contains

    ! Helper subroutine for printing the matrix nicely.
    subroutine print_mat (a, n)
        integer, dimension (n, n), intent (in) :: a
        integer, intent (in) :: n
        integer :: i, j

        do i = 1, n
            do j = 1, n
                write (*, '(i3, x)', advance='no') a(i, j)
            end do
            print *, ''
        end do

    end subroutine print_mat

end program main


program problem45
  implicit none
  integer*8 :: n,temp

  do n=286,huge(n)
     temp=T(n)
     if (is_P(temp) .and. is_H(temp)) exit
  end do

  print *, n, T(n)

contains

  pure function T(n)
    implicit none
    integer*8, intent(in) :: n
    integer               :: T
    T=n*(n+1)/2
  end function T

  pure function is_P(P)
    implicit none
    integer*8, intent(in) :: P
    double precision      :: n
    logical               :: is_P
    n = (sqrt(dble(24*P + 1)) + 1)/6
    is_P = (whole(n))
  end function is_P

  pure function is_H(H)
    implicit none
    integer*8, intent(in) :: H
    double precision      :: n
    logical               :: is_H
    n = (sqrt(dble(8*H + 1)) + 1)/4
    is_H = (whole(n))
  end function is_H

  pure function whole(x)
    implicit none
    double precision, intent(in) :: x
    logical                      :: whole
    whole = (mod(x,1.0) == 0.0)
  end function whole

end program problem45