! { dg-do run }
!
! PR 44912: [OOP] Segmentation fault on TBP
!
! Contributed by Satish.BD <bdsatish@gmail.com>

module polynomial
implicit none

private

type, public :: polynom
   complex, allocatable, dimension(:) :: a
   integer :: n
 contains
   procedure :: init_from_coeff
   procedure :: get_degree
   procedure :: add_poly
end type polynom

contains
  subroutine init_from_coeff(self, coeff)
    class(polynom), intent(inout) :: self
    complex, dimension(:), intent(in) :: coeff
    self%n = size(coeff) - 1
    allocate(self%a(self%n + 1))
    self%a = coeff
    print *,"ifc:",self%a
  end subroutine init_from_coeff

  function get_degree(self)   result(n)
    class(polynom), intent(in) :: self
    integer :: n
    print *,"gd"
    n = self%n
  end function get_degree

  subroutine add_poly(self)
    class(polynom), intent(in) :: self
    integer :: s
    print *,"ap"
    s = self%get_degree()         !!!! fails here
  end subroutine

end module polynomial

program test_poly
   use polynomial, only: polynom

   type(polynom) :: p1

   call p1%init_from_coeff([(1,0),(2,0),(3,0)])
   call p1%add_poly()

end program test_poly


! { dg-do run }
program main
  implicit none
  integer, parameter :: n=5
  character(len=6,kind=4), dimension(n,n) :: a
  integer, dimension(n,n) :: v
  character(len=6,kind=4), dimension(n) :: r1, r2
  character(len=6,kind=4), dimension(:,:), allocatable :: a_alloc
  integer, dimension(:,:), allocatable :: v_alloc
  character(len=6,kind=4):: all_full
  integer :: i
  character(len=6,kind=4),dimension(1) :: ret
  logical, dimension(n,n) :: mask
  logical :: smask
  integer(kind=4), dimension(6) :: kmin

  kmin = -1
  all_full = transfer(kmin,all_full)
  v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v))
  write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n)

  r1 =  minval(a,dim=1)
  write (unit=r2,fmt='(I6.6)') minval(v,dim=1)
  if (any (r1 /= r2)) STOP 1
  r1 = 4_'x'
  write (unit=r1,fmt='(I6.6)') minval(v,dim=1)
  if (any (r1 /= r2)) STOP 2

  r1 = 4_'y'
  r1 =  minval(a,dim=2)
  write (unit=r2,fmt='(I6.6)') minval(v,dim=2)
  if (any (r1 /= r2)) STOP 3
  r1 = 4_'z'
  write (unit=r1,fmt='(I6.6)') minval(v,dim=2)
  if (any (r1 /= r2)) STOP 4

  allocate (a_alloc(0,1), v_alloc(0,1))
  ret = 4_'what'
  ret = minval(a_alloc,dim=1)
  if (ret(1) /= all_full) STOP 5

  r1 = 4_'qq'
  r1 = minval(a, dim=1, mask=a>4_"000200");
  if (any(r1 /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) STOP 6
  if (any(minval(a, dim=1, mask=a>4_"000200") /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) STOP 7

  r1 = 4_'rr'
  r1 = minval(a, dim=2, mask=a>4_"000200");
  if (any(r1 /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) STOP 8
  if (any(minval(a, dim=2, mask=a>4_"000200") /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) STOP 9

  mask = .true.
  forall (i=1:n)
     mask(i,i) = .false.
  end forall

  r1 = 4_'aa'
  r1 = minval(a, dim=1, mask=mask)
  write(unit=r2,fmt='(I6.6)') minval(v,dim=1, mask=mask)
  if (any(r1 /= r2)) STOP 10

  r1 = 4_'xyz'
  smask = .true.
  r1 = minval(a, dim=1, mask=smask)
  write (unit=r2,fmt='(I6.6)') minval(v,dim=1)
  if (any (r1 /= r2)) STOP 11

  smask = .false.
  r1 = 4_'foobar'
  r1 = minval(a, dim=1, mask=smask)
  if (any(r1 /= all_full)) STOP 12
end program main


program intrinsics_15
  real, parameter :: x1 = 3.3
  integer, parameter :: x2 = 7
  integer, parameter :: y1 = int(x1)
  integer, parameter :: y2 = int(x2)
  print*, y1, y2
end program


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FIT
      IMPLICIT NONE
C
C Purpose: General purpose background fitting routine.
C
      INCLUDE 'COMMON.FOR'
C
C Calls   5: GETHDR , OPNFIL , APLOT  , DAWRT , GETVAL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    SLOPE,CONST,XPOS,YPOS,VALUE(10)
      INTEGER ICALL,IAXIS,IAUTO,IPLOT,IWINDO,ISYMB,ICOL(8)
      INTEGER ICLO,JOP,IRC,IFRAME,IHFMAX,IFRMAX,IMEM,NCHAN,NFRAME
      INTEGER KREC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,NVAL
      INTEGER JCH1,JCH2,ICH1,ICH2,NPOINT,NDATA,KCHAR,I,J,K,L
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM,XFNAM
      CHARACTER*6  TITLE,XANOT,YANOT
      LOGICAL SAVE,ASKYES
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C KREC   : Output file record
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NCHAN  : Nos. of data points in spectrum
C NFRAME : Nos. of time frames
C ISYMB  : GHOST symbol
C
      DATA IMEM/1/
      DATA IAUTO/0/ , IPLOT/2/ , IWINDO/0/ , ICOL/0,0,0,0,0,0,0,0/
      DATA XANOT/'X-AXIS'/ , YANOT/'Y-AXIS'/, TITLE/' '/
C
C-----------------------------------------------------------------------
10    ICLO=0
      JOP=0
      KREC=0
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     1             ILFR,IFINC,IHFMAX,IFRMAX,NCHAN,IRC)
      IF (IRC.NE.0) GOTO 999
C
      CALL GETCHN (ITERM,IPRINT,NCHAN,ICH1,ICH2,IRC)
      IF (IRC.NE.0) GOTO 10
C
C========FIND AXIS TYPE
C
25    IAXIS=1
      WRITE (IPRINT,1020)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 10
      IF (IRC.EQ.2) GOTO 25
      IF (NVAL.GE.1) IAXIS=INT(VALUE(1))
      IF (IAXIS.LT.1.OR.IAXIS.GT.2) THEN
         CALL ERRMSG ('Error: Invalid option selected')
         GOTO 25
      ENDIF
C
      IFRAME=IHFMAX+IFRMAX-1
      DO 40 I=1,IHFMAX
C
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHAN,NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 30 J=1,IFRMAX
               READ (JUNIT,REC=IFFR) (SP1(K),K=1,NCHAN)
               IFFR=IFFR+IFINC
               KREC=KREC+1
C
               ICALL=0
               DO 12 K=1,NCHAN
                  XAX(K)=REAL(K)
12             CONTINUE
               NPOINT=ICH2-ICH1+1
               CALL FRPLOT (ITERM,IPRINT,XAX(ICH1),SP1(ICH1),NPOINT,
     &                      ICALL,IAXIS,IAUTO,IPLOT,IWINDO,ISYMB,
     &                       ICOL,XANOT,YANOT,TITLE)
               NDATA=0
20             CALL CURSOR (XPOS,YPOS,KCHAR)
               IF (KCHAR.NE.83.AND.KCHAR.NE.115.AND.KCHAR.NE.109) THEN
                  NDATA=NDATA+1
                  SP3(NDATA)=YPOS
                  SP4(NDATA)=REAL(INT(XPOS))
                  GOTO 20
               ENDIF
               CALL trmode
               IF (NDATA.GE.2) THEN
                  IF (KREC.EQ.1) THEN
                     WRITE (IPRINT,1010)
                     SAVE=ASKYES (ITERM,IRC)
                     IF (IRC.NE.0) GOTO 50
                  ENDIF
                  IF (SAVE) THEN
                     CALL FILL (SP2,NCHAN,0.0)
                     DO 70 K=1,NDATA-1
                        SLOPE=(SP3(K)-SP3(K+1))/(SP4(K)-SP4(K+1))
                        CONST=(SP4(K)*SP3(K+1)-SP4(K+1)*SP3(K))/
     1                        (SP4(K)-SP4(K+1))
                        JCH1=INT(SP4(K))
                        JCH2=INT(SP4(K+1))
                        DO 80 L=JCH1,JCH2
                           SP2(L)=SLOPE*REAL(L)+CONST
80                      CONTINUE
70                   CONTINUE
                     CALL FILL (SP6,NCHAN,0.0)
                     JCH1=INT(SP4(1))
                     JCH2=INT(SP4(NDATA))
                     DO 85 L=JCH1,JCH2
                        SP6(L)=SP1(L)-SP2(L)
85                   CONTINUE
                     IF (IFRAME.EQ.1) CALL APLOT (ITERM,IPRINT,SP6,
     1                                            NCHAN)
                     IF (KREC.GE.IFRAME) ICLO=1
                     IF (KREC.EQ.1) THEN
                        CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                        IF (IRC.NE.0) GOTO 50
                     ENDIF
                     CALL DAWRT (KUNIT,OFNAM,IMEM,NCHAN,IFRAME,HEAD1,
     1                           HEAD2,SP6,KREC,JOP,ICLO,IRC)
                     IF (IRC.NE.0) GOTO 50
                  ELSE
                     IF (KREC.GE.IFRAME) ICLO=1
                     IF (KREC.EQ.1) THEN
                        CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                        IF (IRC.NE.0) GOTO 50
                        XFNAM=OFNAM
                     ENDIF
                     CALL DAWRT (KUNIT,OFNAM,IMEM,NDATA,IFRAME,HEAD1,
     1                           HEAD2,SP3,KREC,JOP,ICLO,IRC)
                     IF (IRC.NE.0) GOTO 50
                     XFNAM(10:10)='X'
                     IF (KREC.EQ.1) JOP=0
                     CALL DAWRT (LUNIT,XFNAM,IMEM,NDATA,IFRAME,HEAD1,
     1                           HEAD2,SP4,KREC,JOP,ICLO,IRC)
                     IF (IRC.NE.0) GOTO 50
                  ENDIF
               ENDIF
30          CONTINUE
            CLOSE (UNIT=JUNIT)
         ENDIF
40    CONTINUE
50    CLOSE (UNIT=JUNIT)
      GOTO 10
999   RETURN
C
1010  FORMAT (' Do you want to interpolate & save data [Y/N] [Y]: ',$)
1020  FORMAT (' Enter (1) linear or (2) log plot [1]: ',$)
      END


program test_loadtxt
use types, only: dp
use utils, only: loadtxt, savetxt, assert
implicit none

real(dp) :: d(3, 2), e(2, 3)
real(dp), allocatable :: d2(:, :)
d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt("tmp.dat", d)
call loadtxt("tmp.dat", d2)
call assert(all(shape(d2) == [3, 2]))
call assert(all(abs(d-d2) < epsilon(1._dp)))

e = reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt("tmp.dat", e)
call loadtxt("tmp.dat", d2)
call assert(all(shape(d2) == [2, 3]))
call assert(all(abs(e-d2) < epsilon(1._dp)))

end program


C     exit_test.f
C     A simple example of cycle with break within the loop.

      program odd_number
      implicit none
      integer :: n, k, day, x
      n = 19
      k = 0
      do 20 day=1,31
        k = k + 1
        if (k > n) exit
        x = k*2
        write(*,10) k, n, x
 20   enddo

 10   format('k = ', i3, '; n = ', i3, '; x = ', i4)
      end program odd_number


MODULE rkmod

  USE prms
  USE data
  USE stokes

  IMPLICIT none

  real                       :: fac_3,fac_6,fac_2

CONTAINS

  SUBROUTINE initRK

    fac_3 = 1./3.*dt
    fac_2 = .5*dt
    fac_6 = 1./6.*dt

  END SUBROUTINE initRK

  SUBROUTINE rk2(time,lt)

    real,dimension(2,Np)    :: dXac,dXcf,dXmc,Xc,UU
    real                    :: time_local
    real                    :: time
    integer                 :: lt

    character(50)           :: fn

! temporary
    integer :: i

        time_local = time
 !     print*, "call rhs"
    call rhs(X,dXac,time_local,lt)
 !    print*, "call meanu"
    call meanU(X,dXmc,time_local)
    Xc = X + 0.5*dt*(dXac+dXmc)

    !open(1,file='CellVel.xdir.rk',form='FORMATTED')
    !Do i = 1, Np
        !write(1,*) dXac(1,i)+dXmc(1,i)
    !End Do

    close(1)
    time_local = time + dt/2.
    call rhs(Xc,dXac,time_local,lt)
    call meanU(Xc,dXmc,time_local)
    X = X + dt*(dXac+dXmc)

    time = time + dt

    !time_local = time
    !call rhs(X,dXac,time_local,lt)
    !Xc = X + 0.5*dt*dXac
    !!call meanU(X,dXmc)
    !!Xc = X + 0.5*dt*(dXac+dXmc)

    !time_local = time + dt/2.
    !call rhs(Xc,dXac,time_local,lt)
    !X = X + dt*dXac
    !!call meanU(Xc,dXmc)
    !!X = X + dt*(dXac+dXmc)

!time = time + dt

        !open(1,file='CellVel.xdir.rk',form='FORMATTED')
    !Do i = 1, Np
        !write(1,*) UU(1,i)
    !End Do

    !close(1)

  END SUBROUTINE rk2

END MODULE rkmod


module ArrayOperationClass
    use MathClass
    implicit none

    interface MergeArray
        module procedure MergeArrayInt, MergeArrayReal
    end interface MergeArray

    interface CopyArray
        module procedure CopyArrayInt, CopyArrayReal,CopyArrayIntVec, CopyArrayRealVec
    end interface CopyArray

    interface TrimArray
        module procedure TrimArrayInt, TrimArrayReal
    end interface TrimArray

    interface ImportArray
        module procedure ImportArrayInt, ImportArrayReal
    end interface ImportArray

    interface ExportArray
        module procedure ExportArrayInt, ExportArrayReal
    end interface ExportArray

    interface ExportArraySize
        module procedure ExportArraySizeInt, ExportArraySizeReal
    end interface ExportArraySize

    interface InOrOut
            module procedure InOrOutReal,InOrOutInt
    end interface

    interface ShowArray
        module procedure ShowArrayInt, ShowArrayReal
    end interface ShowArray

    interface ShowArraySize
        module procedure    ShowArraySizeInt, ShowArraySizeReal
        module procedure    ShowArraySizeIntvec, ShowArraySizeRealvec
        module procedure    ShowArraySizeIntThree, ShowArraySizeRealThree
    end interface ShowArraySize

    interface ExtendArray
        module procedure  :: ExtendArrayReal,ExtendArrayInt
    end interface ExtendArray

    interface insertArray
        module procedure :: insertArrayInt, insertArrayReal
    end interface insertArray

    interface removeArray
        module procedure :: removeArrayReal,removeArrayInt
    end interface removeArray
contains

! ############## Elementary Entities ##############

!=====================================
subroutine MergeArrayInt(a,b,c)
    integer,intent(in)::a(:,:)
    integer,intent(in)::b(:,:)
    integer,allocatable,intent(out)::c(:,:)
    integer i,j,an,am,bn,bm

    if(allocated(c)) deallocate(c)
    an=size(a,1)
    am=size(a,2)

    bn=size(b,1)
    bm=size(b,2)

    if(am/=bm)then
        print *, "ERROR :: MergeArray, size(a,2)/= size(b,2)"
        return
    endif
    allocate(c(an+bn,am) )
    do i=1,an
        c(i,:)=a(i,:)
    enddo
    do i=1,bn
        c(i+an,:)=b(i,:)
    enddo

end subroutine
!=====================================

!=====================================
subroutine MergeArrayReal(a,b,c)
    real(8),intent(in)::a(:,:)
    real(8),intent(in)::b(:,:)
    real(8),allocatable,intent(out)::c(:,:)
    integer i,j,an,am,bn,bm
    if(allocated(c)) deallocate(c)
    an=size(a,1)
    am=size(a,2)

    bn=size(b,1)
    bm=size(b,2)

    if(am/=bm)then
        print *, "ERROR :: MergeArray, size(a,2)/= size(b,2)"
        return
    endif
    allocate(c(an+bn,am) )
    do i=1,an
        c(i,:)=a(i,:)
    enddo
    do i=1,bn
        c(i+an,:)=b(i,:)
    enddo

end subroutine
!=====================================

!=====================================
subroutine CopyArrayInt(a,ac)
    integer,allocatable,intent(inout)::a(:,:)
    integer,allocatable,intent(inout)::ac(:,:)
    integer i,j,n,m

    if(.not.allocated(a) )then
        if(allocated(ac) )then
            deallocate(ac)
            return
        endif
    endif
    n=size(a,1)
    m=size(a,2)
    if(allocated(ac) ) deallocate(ac)

    allocate(ac(n,m) )
    ac(:,:)=a(:,:)

end subroutine
!=====================================

!=====================================
subroutine CopyArrayReal(a,ac)
    real(8),allocatable,intent(inout)::a(:,:)
    real(8),allocatable,intent(inout)::ac(:,:)
    integer i,j,n,m

    if(.not.allocated(a) )then
        if(allocated(ac) )then
            deallocate(ac)
            return
        endif
    endif
    n=size(a,1)
    m=size(a,2)

    if(allocated(ac) ) deallocate(ac)
    allocate(ac(n,m) )
    ac(:,:)=a(:,:)

end subroutine
!=====================================

!=====================================
subroutine CopyArrayIntVec(a,ac)
    integer,allocatable,intent(inout)::a(:)
    integer,allocatable,intent(inout)::ac(:)
    integer i,j,n,m

    if(.not.allocated(a) )then
        if(allocated(ac) )then
            deallocate(ac)

        endif
        return
    endif
    n=size(a,1)
    if(allocated(ac) ) deallocate(ac)

    allocate(ac(n) )
    ac(:)=a(:)

end subroutine
!=====================================

!=====================================
subroutine CopyArrayRealVec(a,ac)
    real(8),allocatable,intent(inout)::a(:)
    real(8),allocatable,intent(inout)::ac(:)
    integer i,j,n,m

    if(.not.allocated(a) )then
        if(allocated(ac) )then
            deallocate(ac)

        endif
        return
    endif
    n=size(a,1)
    if(allocated(ac) ) deallocate(ac)

    allocate(ac(n) )
    ac(:)=a(:)

end subroutine
!=====================================

!=====================================
subroutine TrimArrayInt(a,k)
    integer,allocatable,intent(inout)::a(:,:)
    integer,intent(in)::k
    integer,allocatable::ac(:,:)
    integer :: i,j,n,m

    n=size(a,1)
    m=size(a,2)
    allocate(ac(k,m ))

    do i=1,k
        ac(i,:) = a(i,:)
    enddo
    deallocate(a)
    allocate(a(k,m) )
    a(:,:)=ac(:,:)
    return

end subroutine
!=====================================

!=====================================
subroutine TrimArrayReal(a,k)
    real(8),allocatable,intent(inout)::a(:,:)
    integer,intent(in)::k
    real(8),allocatable::ac(:,:)
    integer :: i,j,n,m

    n=size(a,1)
    m=size(a,2)
    allocate(ac(k,m ))

    do i=1,k
        ac(i,:) = a(i,:)
    enddo

    deallocate(a)
    allocate(a(k,m) )
    a(:,:)=ac(:,:)
    return

end subroutine
!=====================================

!##################################################
subroutine ImportArrayInt(Mat,OptionalFileHandle,OptionalSizeX,OptionalSizeY)
    integer,allocatable,intent(inout)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle,OptionalSizeX,OptionalSizeY

    integer i,j,n,m,fh

    if(present(OptionalSizeX) )then
        n=OptionalSizeX
    elseif(allocated(Mat) )then
        n=size(Mat,1)
    else
        n=1
        print *, "Caution :: ArrayOperationClass/ImportArray >> No size_X is set"
    endif

    if(present(OptionalSizeY) )then
        m=OptionalSizeY
    elseif(allocated(Mat) )then
        m=size(Mat,2)
    else
        m=1
        print *, "Caution :: ArrayOperationClass/ImportArray >> No size_Y is set"
    endif

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(.not.allocated(Mat))then
        allocate(Mat(n,m) )
    endif

    if(size(Mat,1)/=n .or. size(Mat,2)/=m  )then
        deallocate(Mat)
        allocate(Mat(n,m) )
    endif

    do i=1,size(Mat,1)
        read(fh,*) Mat(i,:)
    enddo

    !include "./ImportArray.f90"

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

!##################################################
subroutine ImportArrayReal(Mat,OptionalFileHandle,OptionalSizeX,OptionalSizeY)
    real(8),allocatable,intent(inout)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle,OptionalSizeX,OptionalSizeY

    !include "./ImportArray.f90"

    integer i,j,n,m,fh

    if(present(OptionalSizeX) )then
        n=OptionalSizeX
    elseif(allocated(Mat) )then
        n=size(Mat,1)
    else
        n=1
        print *, "Caution :: ArrayOperationClass/ImportArray >> No size_X is set"
    endif

    if(present(OptionalSizeY) )then
        m=OptionalSizeY
    elseif(allocated(Mat) )then
        m=size(Mat,2)
    else
        m=1
        print *, "Caution :: ArrayOperationClass/ImportArray >> No size_Y is set"
    endif

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(.not.allocated(Mat))then
        allocate(Mat(n,m) )
    endif

    if(size(Mat,1)/=n .or. size(Mat,2)/=m  )then
        deallocate(Mat)
        allocate(Mat(n,m) )
    endif

    do i=1,size(Mat,1)
        read(fh,*) Mat(i,:)
    enddo

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

!##################################################
subroutine ExportArraySizeInt(Mat,RankNum,OptionalFileHandle)
    integer,intent(in)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle
    integer,intent(in)::RankNum

    !#include "./ExportArraySize.f90"
    integer :: fh
    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    endif

    write(fh,*) size(Mat,RankNum)

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

!##################################################
subroutine ExportArraySizeReal(Mat,RankNum,OptionalFileHandle)
    real(8),intent(in)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle
    integer,intent(in)::RankNum

    !#include "./ExportArraySize.f90"
    integer :: fh
    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    endif

    write(fh,*) size(Mat,RankNum)

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

!##################################################
subroutine ExportArrayInt(Mat,OptionalFileHandle)
    integer,intent(in)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    do i=1,size(Mat,1)
        write(fh,*) Mat(i,:)
    enddo

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

!##################################################
subroutine ExportArrayReal(Mat,OptionalFileHandle)
    real(8),intent(in)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    do i=1,size(Mat,1)
        write(fh,*) Mat(i,:)
    enddo

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

!##################################################
subroutine ShowArrayInt(Mat,IndexArray,FileHandle,Name)
    integer,intent(in)::Mat(:,:)
    integer,optional,intent(in) :: IndexArray(:,:)
    integer,optional,intent(in)::FileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i,j,k

    if(present(FileHandle) )then
        fh=FileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(present(IndexArray))then

        do i=1,size(IndexArray,1)
            do j=1,size(IndexArray,2)
                k = IndexArray(i,j)
                if(k <= 0)then
                    cycle
                endif

                if(present(FileHandle) .or. present(Name) )then
                    write(fh,*) Mat(k,:)
                else
                    print *, Mat(k,:)
                endif
            enddo
        enddo
    else

        do j=1,size(Mat,1)

            if(present(FileHandle) .or. present(Name) )then
                write(fh,*) Mat(j,:)
            else
                print *, Mat(j,:)
            endif

        enddo

    endif

    if(present(FileHandle) .or. present(Name) )then
        flush(fh)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
subroutine ShowArrayReal(Mat,IndexArray,FileHandle,Name)
    real(8),intent(in)::Mat(:,:)
    integer,optional,intent(in) :: IndexArray(:,:)
    integer,optional,intent(in)::FileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i,j,k

    if(present(FileHandle) )then
        fh=FileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(present(IndexArray))then

        do i=1,size(IndexArray,1)
            do j=1,size(IndexArray,2)
                k = IndexArray(i,j)
                if(k <= 0)then
                    cycle
                endif

                if(present(FileHandle) .or. present(Name) )then
                    write(fh,*) Mat(k,:)
                else
                    print *, Mat(k,:)
                endif
            enddo
        enddo
    else

        do j=1,size(Mat,1)

            if(present(FileHandle) .or. present(Name) )then
                write(fh,*) Mat(j,:)
            else
                print *, Mat(j,:)
            endif

        enddo

    endif

    if(present(FileHandle) .or. present(Name) )then
        flush(fh)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
subroutine ShowArraySizeInt(Mat,OptionalFileHandle,Name)
    integer,allocatable,intent(in)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(.not. allocated(Mat) )then
        print *, "Not allocated!"
        if(present(OptionalFileHandle) )then
            write(fh,*) "Not allocated!"
        endif
    endif
    print *, size(Mat,1), size(Mat,2)
    if(present(OptionalFileHandle) .or. present(Name) )then
        write(fh,*) size(Mat,1), size(Mat,2)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
subroutine ShowArraySizeReal(Mat,OptionalFileHandle,Name)
    real(8),allocatable,intent(in)::Mat(:,:)
    integer,optional,intent(in)::OptionalFileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(.not. allocated(Mat) )then
        print *, "Not allocated!"
        if(present(OptionalFileHandle) )then
            write(fh,*) "Not allocated!"
        endif
    endif
    print *, size(Mat,1), size(Mat,2)
    if(present(OptionalFileHandle).or. present(Name) )then
        write(fh,*) size(Mat,1), size(Mat,2)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
subroutine ShowArraySizeIntvec(Mat,OptionalFileHandle,Name)
    integer,allocatable,intent(in)::Mat(:)
    integer,optional,intent(in)::OptionalFileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(.not. allocated(Mat) )then
        print *, "Not allocated!"
        if(present(OptionalFileHandle).or. present(Name) )then
            write(fh,*) "Not allocated!"
        endif
    endif
    print *, size(Mat,1)
    if(present(OptionalFileHandle).or. present(Name) )then
        write(fh,*) size(Mat,1)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
subroutine ShowArraySizeRealvec(Mat,OptionalFileHandle,Name)
    real(8),allocatable,intent(in)::Mat(:)
    integer,optional,intent(in)::OptionalFileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(.not. allocated(Mat) )then
        print *, "Not allocated!"
        if(present(OptionalFileHandle).or. present(Name) )then
            write(fh,*) "Not allocated!"
        endif
    endif
    print *, size(Mat,1)
    if(present(OptionalFileHandle) .or. present(Name))then
        write(fh,*) size(Mat,1)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
subroutine ShowArraySizeIntThree(Mat,OptionalFileHandle,Name)
    integer,allocatable,intent(in)::Mat(:,:,:)
    integer,optional,intent(in)::OptionalFileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(.not. allocated(Mat) )then
        print *, "Not allocated!"
        if(present(OptionalFileHandle) .or. present(Name))then
            write(fh,*) "Not allocated!"
        endif
    endif
    print *, size(Mat,1), size(Mat,2) , size(Mat,3)
    if(present(OptionalFileHandle) .or. present(Name))then
        write(fh,*) size(Mat,1), size(Mat,2), size(Mat,3)
    endif

    if(present(Name) )then
        close(fh)
    endif
end subroutine
!##################################################

!##################################################
subroutine ShowArraySizeRealThree(Mat,OptionalFileHandle,Name)
    real(8),allocatable,intent(in)::Mat(:,:,:,:)
    integer,optional,intent(in)::OptionalFileHandle
    character(*),optional,intent(in)::Name

    !#include "./ExportArray.f90"
    integer :: fh,i

    if(present(OptionalFileHandle) )then
        fh=OptionalFileHandle
    else
        fh=10
    endif

    if(present(Name) )then
        open(fh,file=Name)
    endif

    if(.not. allocated(Mat) )then
        print *, "Not allocated!"
        if(present(OptionalFileHandle) .or. present(Name))then
            write(fh,*) "Not allocated!"
        endif
    endif
    print *, size(Mat,1), size(Mat,2) , size(Mat,3)
    if(present(OptionalFileHandle).or. present(Name) )then
        write(fh,*) size(Mat,1), size(Mat,2), size(Mat,3)
    endif

    if(present(Name) )then
        close(fh)
    endif

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

!##################################################
function InOrOutReal(x,xmax,xmin,DimNum) result(Inside)
    real(8),intent(in)::x(:)
    real(8),intent(in)::xmax(:),xmin(:)
    integer,optional,intent(in)::DimNum
    integer :: dim_num
    logical ::Inside
    integer :: i,j,n,cout

    cout=0
    if(present(DimNum) )then
        dim_num=DimNum
    else
        dim_num=size(x)
    endif

    do i=1,dim_num
        if(xmin(i) <= x(i) .and. x(i)<=xmax(i) )then
            cout=cout+1
        else
            cycle
        endif
    enddo

    if(cout==dim_num)then
        Inside = .true.
    else
        Inside = .false.
    endif

end function

!##################################################

!##################################################
function InOrOutInt(x,xmax,xmin,DimNum) result(Inside)
    integer,intent(in)::x(:)
    integer,intent(in)::xmax(:),xmin(:)
    integer,optional,intent(in)::DimNum
    integer :: dim_num
    logical ::Inside
    integer :: i,j,n,cout

    cout=0
    if(present(DimNum) )then
        dim_num=DimNum
    else
        dim_num=size(x)
    endif

    do i=1,dim_num
        if(xmin(i) <= x(i) .and. x(i)<=xmax(i) )then
            cout=cout+1
        else
            cycle
        endif
    enddo

    if(cout==dim_num)then
        Inside = .true.
    else
        Inside = .false.
    endif

end function

!##################################################

!##################################################
subroutine ExtendArrayReal(mat,extend1stColumn,extend2ndColumn,DefaultValue)
    real(8),allocatable,intent(inout)::mat(:,:)
    real(8),allocatable :: buffer(:,:)
    logical,optional,intent(in) :: extend1stColumn,extend2ndColumn
    real(8),optional,intent(in) :: DefaultValue
    real(8) :: val
    integer :: n,m

    if( present(DefaultValue) )then
        val = DefaultValue
    else
        val = 0.0d0
    endif

    n=size(mat,1)
    m=size(mat,2)
    if(present(extend1stColumn) )then
        if(extend1stColumn .eqv. .true.)then
            allocate(buffer(n+1, m ) )
            buffer(:,:)=val
            buffer(1:n,1:m)=mat(1:n,1:m)
            deallocate(mat)
            call copyArray(buffer,mat)
            deallocate(buffer)
        endif
    endif

    n=size(mat,1)
    m=size(mat,2)
    if(present(extend2ndColumn) )then
        if(extend2ndColumn .eqv. .true.)then
            allocate(buffer(n, m+1 ) )
            buffer(:,:)=val
            buffer(1:n,1:m)=mat(1:n,1:m)
            deallocate(mat)
            call copyArray(buffer,mat)
            deallocate(buffer)
        endif
    endif

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

!##################################################
subroutine ExtendArrayInt(mat,extend1stColumn,extend2ndColumn,DefaultValue)
    integer,allocatable,intent(inout)::mat(:,:)
    integer,allocatable :: buffer(:,:)
    logical,optional,intent(in) :: extend1stColumn,extend2ndColumn
    integer,optional,intent(in) :: DefaultValue
    integer :: val
    integer :: i,j,k,n,m

    if( present(DefaultValue) )then
        val = DefaultValue
    else
        val = 0
    endif

    n=size(mat,1)
    m=size(mat,2)
    if(present(extend1stColumn) )then
        if(extend1stColumn .eqv. .true.)then
            allocate(buffer(n+1, m ) )
            buffer(:,:)=val
            buffer(1:n,1:m)=mat(1:n,1:m)
            deallocate(mat)
            call copyArray(buffer,mat)
            deallocate(buffer)
        endif
    endif

    n=size(mat,1)
    m=size(mat,2)
    if(present(extend2ndColumn) )then
        if(extend2ndColumn .eqv. .true.)then
            allocate(buffer(n, m+1 ) )
            buffer(:,:)=val
            buffer(1:n,1:m)=mat(1:n,1:m)
            deallocate(mat)
            call copyArray(buffer,mat)
            deallocate(buffer)
        endif
    endif

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

!##################################################
subroutine insertArrayInt(mat,insert1stColumn,insert2ndColumn,DefaultValue,NextOf)
    integer,allocatable,intent(inout)::mat(:,:)
    integer,allocatable :: buffer(:,:)
    logical,optional,intent(in) :: insert1stColumn,insert2ndColumn
    integer,optional,intent(in) :: DefaultValue,NextOf
    integer :: val
    integer :: i,nof

    call extendArray(mat,insert1stColumn,insert2ndColumn,DefaultValue)

    if(present(DefaultValue))then
        val =DefaultValue
    else
        val =0
    endif

    if(present(NextOf))then
        nof=NextOf
    else
        if( present(insert1stColumn ))then
            if( insert1stColumn .eqv. .true. )then
                nof=size(mat,1)-1
            endif
        endif

        if( present(insert2ndColumn ))then
            if( insert2ndColumn .eqv. .true. )then
                nof=size(mat,2)-1
            endif
        endif

    endif

    if( present(insert1stColumn ))then
        if( insert1stColumn .eqv. .true. )then
            do i=size(mat,1)-1,nof,-1
                mat(i+1,:)=mat(i,:)
            enddo
            mat(nof+1,:)=val
        endif
    endif
    if( present(insert2ndColumn ))then
        if( insert2ndColumn .eqv. .true. )then
            do i=size(mat,1)-1,nof,-1
                mat(:,i+1)=mat(:,i)
            enddo
            mat(:,nof+1)=val
        endif
    endif
end subroutine
!##################################################

!##################################################
subroutine insertArrayReal(mat,insert1stColumn,insert2ndColumn,DefaultValue,NextOf)
    real(8),allocatable,intent(inout)::mat(:,:)
    real(8),allocatable :: buffer(:,:)
    logical,optional,intent(in) :: insert1stColumn,insert2ndColumn

    integer,optional,intent(in) :: NextOf
    real(8),optional,intent(in) :: DefaultValue
    real(8) :: val
    integer :: i,nof

    call extendArray(mat,insert1stColumn,insert2ndColumn,DefaultValue)

    if(present(DefaultValue))then
        val =DefaultValue
    else
        val =0
    endif

    if(present(NextOf))then
        nof=NextOf
    else
        if( present(insert1stColumn ))then
            if( insert1stColumn .eqv. .true. )then
                nof=size(mat,1)-1
            endif
        endif

        if( present(insert2ndColumn ))then
            if( insert2ndColumn .eqv. .true. )then
                nof=size(mat,2)-1
            endif
        endif

    endif

    if( present(insert1stColumn ))then
        if( insert1stColumn .eqv. .true. )then
            do i=size(mat,1)-1,nof,-1
                mat(i+1,:)=mat(i,:)
            enddo
            mat(nof+1,:)=val
        endif
    endif
    if( present(insert2ndColumn ))then
        if( insert2ndColumn .eqv. .true. )then
            do i=size(mat,1)-1,nof,-1
                mat(:,i+1)=mat(:,i)
            enddo
            mat(:,nof+1)=val
        endif
    endif
end subroutine
!##################################################

!##################################################
subroutine removeArrayInt(mat,remove1stColumn,remove2ndColumn,NextOf)
    integer,allocatable,intent(inout)::mat(:,:)
    integer,allocatable :: buffer(:,:)
    logical,optional,intent(in) :: remove1stColumn,remove2ndColumn

    integer,optional,intent(in) :: NextOf

    integer :: i,nof

    if( present(remove1stColumn ))then
        if( remove1stColumn .eqv. .true. )then
            nof=size(mat,1)
        endif
    endif

    if( present(remove2ndColumn ))then
        if( remove2ndColumn .eqv. .true. )then
            nof=size(mat,2)
        endif
    endif

    if(present(NextOf) )then
        if(NextOf >= nof)then
            return
        endif
    endif
    call copyArray(mat,buffer)

    if(present(NextOf))then
        nof=NextOf
    else
        if( present(remove1stColumn ))then
            if( remove1stColumn .eqv. .true. )then
                nof=size(mat,1)-1
            endif
        endif

        if( present(remove2ndColumn ))then
            if( remove2ndColumn .eqv. .true. )then
                nof=size(mat,2)-1
            endif
        endif
    endif

    deallocate(mat)

    if( present(remove1stColumn ))then
        if( remove1stColumn .eqv. .true. )then
            if(size(buffer,1)-1 == 0)then
                print *, "Array is deleted"
                return
            endif
            allocate(mat(size(buffer,1)-1,size(buffer,2)) )
            mat(:,:)=0.0d0
            do i=1,nof
                mat(i,:)=buffer(i,:)
            enddo

            do i=nof+1,size(buffer,1)-1
                mat(i,:)=buffer(i+1,:)
            enddo

        endif
    endif
    if( present(remove2ndColumn ))then
        if( remove2ndColumn .eqv. .true. )then

            if(size(buffer,2)-1 == 0)then
                print *, "Array is deleted"
                return
            endif
            allocate(mat(size(buffer,1),size(buffer,2)-1) )
            mat(:,:)=0.0d0
            do i=1,nof
                mat(:,i)=buffer(:,i)
            enddo

            do i=nof+1,size(buffer,2)-1
                mat(:,i)=buffer(:,i+1)
            enddo
        endif
    endif

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

!##################################################
subroutine removeArrayReal(mat,remove1stColumn,remove2ndColumn,NextOf)
    real(8),allocatable,intent(inout)::mat(:,:)
    real(8),allocatable :: buffer(:,:)
    logical,optional,intent(in) :: remove1stColumn,remove2ndColumn

    integer,optional,intent(in) :: NextOf

    integer :: i,nof

    if( present(remove1stColumn ))then
        if( remove1stColumn .eqv. .true. )then
            nof=size(mat,1)
        endif
    endif

    if( present(remove2ndColumn ))then
        if( remove2ndColumn .eqv. .true. )then
            nof=size(mat,2)
        endif
    endif

    if(present(NextOf) )then
        if(NextOf >= nof)then
            return
        endif
    endif

    call copyArray(mat,buffer)

    if(present(NextOf))then
        nof=NextOf
    else
        if( present(remove1stColumn ))then
            if( remove1stColumn .eqv. .true. )then
                nof=size(mat,1)-1
            endif
        endif

        if( present(remove2ndColumn ))then
            if( remove2ndColumn .eqv. .true. )then
                nof=size(mat,2)-1
            endif
        endif
    endif

    deallocate(mat)

    if( present(remove1stColumn ))then
        if( remove1stColumn .eqv. .true. )then
            if(size(buffer,1)-1 == 0)then
                print *, "Array is deleted"
                return
            endif
            allocate(mat(size(buffer,1)-1,size(buffer,2)) )
            mat(:,:)=0.0d0
            do i=1,nof
                mat(i,:)=buffer(i,:)
            enddo

            do i=nof+1,size(buffer,1)-1
                mat(i,:)=buffer(i+1,:)
            enddo

        endif
    endif
    if( present(remove2ndColumn ))then
        if( remove2ndColumn .eqv. .true. )then

            if(size(buffer,2)-1 == 0)then
                print *, "Array is deleted"
                return
            endif
            allocate(mat(size(buffer,1),size(buffer,2)-1) )
            mat(:,:)=0.0d0
            do i=1,nof
                mat(:,i)=buffer(:,i)
            enddo

            do i=nof+1,size(buffer,2)-1
                mat(:,i)=buffer(:,i+1)
            enddo
        endif
    endif

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

end module ArrayOperationClass


      SUBROUTINE CLATM4( ITYPE, N, NZ1, NZ2, RSIGN, AMAGN, RCOND,
     $                   TRIANG, IDIST, ISEED, A, LDA )
*
*  -- LAPACK auxiliary test routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      LOGICAL            RSIGN
      INTEGER            IDIST, ITYPE, LDA, N, NZ1, NZ2
      REAL               AMAGN, RCOND, TRIANG
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      COMPLEX            A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  CLATM4 generates basic square matrices, which may later be
*  multiplied by others in order to produce test matrices.  It is
*  intended mainly to be used to test the generalized eigenvalue
*  routines.
*
*  It first generates the diagonal and (possibly) subdiagonal,
*  according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND.
*  It then fills in the upper triangle with random numbers, if TRIANG is
*  non-zero.
*
*  Arguments
*  =========
*
*  ITYPE   (input) INTEGER
*          The "type" of matrix on the diagonal and sub-diagonal.
*          If ITYPE < 0, then type abs(ITYPE) is generated and then
*             swapped end for end (A(I,J) := A'(N-J,N-I).)  See also
*             the description of AMAGN and RSIGN.
*
*          Special types:
*          = 0:  the zero matrix.
*          = 1:  the identity.
*          = 2:  a transposed Jordan block.
*          = 3:  If N is odd, then a k+1 x k+1 transposed Jordan block
*                followed by a k x k identity block, where k=(N-1)/2.
*                If N is even, then k=(N-2)/2, and a zero diagonal entry
*                is tacked onto the end.
*
*          Diagonal types.  The diagonal consists of NZ1 zeros, then
*             k=N-NZ1-NZ2 nonzeros.  The subdiagonal is zero.  ITYPE
*             specifies the nonzero diagonal entries as follows:
*          = 4:  1, ..., k
*          = 5:  1, RCOND, ..., RCOND
*          = 6:  1, ..., 1, RCOND
*          = 7:  1, a, a^2, ..., a^(k-1)=RCOND
*          = 8:  1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
*          = 9:  random numbers chosen from (RCOND,1)
*          = 10: random numbers with distribution IDIST (see CLARND.)
*
*  N       (input) INTEGER
*          The order of the matrix.
*
*  NZ1     (input) INTEGER
*          If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
*          be zero.
*
*  NZ2     (input) INTEGER
*          If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
*          be zero.
*
*  RSIGN   (input) LOGICAL
*          = .TRUE.:  The diagonal and subdiagonal entries will be
*                     multiplied by random numbers of magnitude 1.
*          = .FALSE.: The diagonal and subdiagonal entries will be
*                     left as they are (usually non-negative real.)
*
*  AMAGN   (input) REAL
*          The diagonal and subdiagonal entries will be multiplied by
*          AMAGN.
*
*  RCOND   (input) REAL
*          If abs(ITYPE) > 4, then the smallest diagonal entry will be
*          RCOND.  RCOND must be between 0 and 1.
*
*  TRIANG  (input) REAL
*          The entries above the diagonal will be random numbers with
*          magnitude bounded by TRIANG (i.e., random numbers multiplied
*          by TRIANG.)
*
*  IDIST   (input) INTEGER
*          On entry, DIST specifies the type of distribution to be used
*          to generate a random matrix .
*          = 1: real and imaginary parts each UNIFORM( 0, 1 )
*          = 2: real and imaginary parts each UNIFORM( -1, 1 )
*          = 3: real and imaginary parts each NORMAL( 0, 1 )
*          = 4: complex number uniform in DISK( 0, 1 )
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          On entry ISEED specifies the seed of the random number
*          generator.  The values of ISEED are changed on exit, and can
*          be used in the next call to CLATM4 to continue the same
*          random number sequence.
*          Note: ISEED(4) should be odd, for the random number generator
*          used at present.
*
*  A       (output) COMPLEX array, dimension (LDA, N)
*          Array to be computed.
*
*  LDA     (input) INTEGER
*          Leading dimension of A.  Must be at least 1 and at least N.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND, KLEN
      REAL               ALPHA
      COMPLEX            CTEMP
*     ..
*     .. External Functions ..
      REAL               SLARAN
      COMPLEX            CLARND
      EXTERNAL           SLARAN, CLARND
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLASET
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, CMPLX, EXP, LOG, MAX, MIN, MOD, REAL
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.0 )
     $   RETURN
      CALL CLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
*
*     Insure a correct ISEED
*
      IF( MOD( ISEED( 4 ), 2 ).NE.1 )
     $   ISEED( 4 ) = ISEED( 4 ) + 1
*
*     Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
*     and RCOND
*
      IF( ITYPE.NE.0 ) THEN
         IF( ABS( ITYPE ).GE.4 ) THEN
            KBEG = MAX( 1, MIN( N, NZ1+1 ) )
            KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
            KLEN = KEND + 1 - KBEG
         ELSE
            KBEG = 1
            KEND = N
            KLEN = N
         END IF
         ISDB = 1
         ISDE = 0
         GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
     $           180, 200 )ABS( ITYPE )
*
*        |ITYPE| = 1: Identity
*
   10    CONTINUE
         DO 20 JD = 1, N
            A( JD, JD ) = CONE
   20    CONTINUE
         GO TO 220
*
*        |ITYPE| = 2: Transposed Jordan block
*
   30    CONTINUE
         DO 40 JD = 1, N - 1
            A( JD+1, JD ) = CONE
   40    CONTINUE
         ISDB = 1
         ISDE = N - 1
         GO TO 220
*
*        |ITYPE| = 3: Transposed Jordan block, followed by the identity.
*
   50    CONTINUE
         K = ( N-1 ) / 2
         DO 60 JD = 1, K
            A( JD+1, JD ) = CONE
   60    CONTINUE
         ISDB = 1
         ISDE = K
         DO 70 JD = K + 2, 2*K + 1
            A( JD, JD ) = CONE
   70    CONTINUE
         GO TO 220
*
*        |ITYPE| = 4: 1,...,k
*
   80    CONTINUE
         DO 90 JD = KBEG, KEND
            A( JD, JD ) = CMPLX( JD-NZ1 )
   90    CONTINUE
         GO TO 220
*
*        |ITYPE| = 5: One large D value:
*
  100    CONTINUE
         DO 110 JD = KBEG + 1, KEND
            A( JD, JD ) = CMPLX( RCOND )
  110    CONTINUE
         A( KBEG, KBEG ) = CONE
         GO TO 220
*
*        |ITYPE| = 6: One small D value:
*
  120    CONTINUE
         DO 130 JD = KBEG, KEND - 1
            A( JD, JD ) = CONE
  130    CONTINUE
         A( KEND, KEND ) = CMPLX( RCOND )
         GO TO 220
*
*        |ITYPE| = 7: Exponentially distributed D values:
*
  140    CONTINUE
         A( KBEG, KBEG ) = CONE
         IF( KLEN.GT.1 ) THEN
            ALPHA = RCOND**( ONE / REAL( KLEN-1 ) )
            DO 150 I = 2, KLEN
               A( NZ1+I, NZ1+I ) = CMPLX( ALPHA**( I-1 ) )
  150       CONTINUE
         END IF
         GO TO 220
*
*        |ITYPE| = 8: Arithmetically distributed D values:
*
  160    CONTINUE
         A( KBEG, KBEG ) = CONE
         IF( KLEN.GT.1 ) THEN
            ALPHA = ( ONE-RCOND ) / REAL( KLEN-1 )
            DO 170 I = 2, KLEN
               A( NZ1+I, NZ1+I ) = CMPLX( REAL( KLEN-I )*ALPHA+RCOND )
  170       CONTINUE
         END IF
         GO TO 220
*
*        |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1):
*
  180    CONTINUE
         ALPHA = LOG( RCOND )
         DO 190 JD = KBEG, KEND
            A( JD, JD ) = EXP( ALPHA*SLARAN( ISEED ) )
  190    CONTINUE
         GO TO 220
*
*        |ITYPE| = 10: Randomly distributed D values from DIST
*
  200    CONTINUE
         DO 210 JD = KBEG, KEND
            A( JD, JD ) = CLARND( IDIST, ISEED )
  210    CONTINUE
*
  220    CONTINUE
*
*        Scale by AMAGN
*
         DO 230 JD = KBEG, KEND
            A( JD, JD ) = AMAGN*REAL( A( JD, JD ) )
  230    CONTINUE
         DO 240 JD = ISDB, ISDE
            A( JD+1, JD ) = AMAGN*REAL( A( JD+1, JD ) )
  240    CONTINUE
*
*        If RSIGN = .TRUE., assign random signs to diagonal and
*        subdiagonal
*
         IF( RSIGN ) THEN
            DO 250 JD = KBEG, KEND
               IF( REAL( A( JD, JD ) ).NE.ZERO ) THEN
                  CTEMP = CLARND( 3, ISEED )
                  CTEMP = CTEMP / ABS( CTEMP )
                  A( JD, JD ) = CTEMP*REAL( A( JD, JD ) )
               END IF
  250       CONTINUE
            DO 260 JD = ISDB, ISDE
               IF( REAL( A( JD+1, JD ) ).NE.ZERO ) THEN
                  CTEMP = CLARND( 3, ISEED )
                  CTEMP = CTEMP / ABS( CTEMP )
                  A( JD+1, JD ) = CTEMP*REAL( A( JD+1, JD ) )
               END IF
  260       CONTINUE
         END IF
*
*        Reverse if ITYPE < 0
*
         IF( ITYPE.LT.0 ) THEN
            DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
               CTEMP = A( JD, JD )
               A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
               A( KBEG+KEND-JD, KBEG+KEND-JD ) = CTEMP
  270       CONTINUE
            DO 280 JD = 1, ( N-1 ) / 2
               CTEMP = A( JD+1, JD )
               A( JD+1, JD ) = A( N+1-JD, N-JD )
               A( N+1-JD, N-JD ) = CTEMP
  280       CONTINUE
         END IF
*
      END IF
*
*     Fill in upper triangle
*
      IF( TRIANG.NE.ZERO ) THEN
         DO 300 JC = 2, N
            DO 290 JR = 1, JC - 1
               A( JR, JC ) = TRIANG*CLARND( IDIST, ISEED )
  290       CONTINUE
  300    CONTINUE
      END IF
*
      RETURN
*
*     End of CLATM4
*
      END


program optkind

  real x, y
  integer :: i, j = 10
  real :: r, s = 1.5
  complex :: c = ( 1.1, 2 )

  x = real(4)
  x = real(y,4)
  x = real(kind=4,y)            !need keyword on 2nd arg
  x = real(8,kind=4)
  r = real(a = s, kind = 8)

  ! correct
  s = aint(s, kind = 4)
  s = anint(kind = 8, a = s)
  i = int(kind = 8, a = j)
  i = ceiling(kind = 4, a = s)
! CMPLX tests
  c = cmplx(x,y)                ! OK
  c = cmplx(x,y,4)              ! mixed concrete, default
  c = cmplx(c, kind = 4)        ! ditto
  c = cmplx(kind = 4, x = c)    ! ditto
  c = cmplx(x=1,y=0)            ! OK

  i = floor(r, kind = 4)
  i = ceiling(kind=4, a=2.5_2)

  ! incorrect keywords
  i = floor(r, kin = 4)
  i = int(a = j, kin = 4)

end program optkind


        subroutine iddp_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                        matvec,p1,p2,p3,p4,krank,u,v,s,ier,
     2                        list,proj,col,work)
c
c       routine iddp_rsvd serves as a memory wrapper
c       for the present routine (please see routine iddp_rsvd
c       for further documentation).
c
        implicit none
        integer m,n,krank,list(n),ier
        real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank),
     1         s(krank),proj(krank,n-krank),col(m*krank),
     2         work((krank+1)*(m+3*n)+26*krank**2)
        external matvect,matvec
c
c
c       Collect together the columns of a indexed by list into col.
c
        call idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work)
c
c
c       Convert the ID to an SVD.
c
        call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work)
c
c
        return
        end


program scatter_gather
use mpi_f08
use, intrinsic :: iso_fortran_env, only : dp => REAL64, error_unit
implicit none
integer, parameter :: root = 0
integer :: rank, size, i, stat, type_size
type(MPI_Datatype) :: real_type
real(kind=dp), dimension(:), allocatable :: root_buffer
real(kind=dp) :: val_buffer

call MPI_Init()
call MPI_Comm_size(MPI_COMM_WORLD, size)
call MPI_Comm_rank(MPI_COMM_WORLD, rank)

! determine MPI type of real data dynamically
call MPI_Sizeof(val_buffer, type_size)
call MPI_Type_match_size(MPI_TYPECLASS_REAL, type_size, real_type)

! allocate buffer in root, initialize, and scatter
if (rank == root) then
    allocate(root_buffer(size), stat=stat)
    if (stat /= 0) then
        write (error_unit, "(A)") "### error: can not allocate"
    end if
    do i = 1, size
        root_buffer(i) = real(i - 1, kind=dp)
    end do
end if
call MPI_Scatter(root_buffer, 1, real_type, &
                 val_buffer, 1, real_type, &
                 root, MPI_COMM_WORLD)
! print received value and do complicated computation
print "(A, I2, A, F5.1)", "rank ", rank, " received ", val_buffer
val_buffer = val_buffer**2

! gather and root prints results
call MPI_Gather(val_buffer, 1, real_type, &
                root_buffer, 1, real_type, &
                root, MPI_COMM_WORLD)
if (rank == root) then
    print "(A)", "root received:"
    print "(F5.1)", root_buffer
end if
call MPI_Finalize()

end program scatter_gather


        INTEGER: i, temp, b
        result = 0
        b = 1
        DO i = 0 , n - (1) , 1
            temp = result
            result = b
            b = temp + b
        END DO


C
C	$Id: msbsf1.f,v 1.5 2008-07-27 00:17:30 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MSBSF1 (M,N,XMIN,XMAX,YMIN,YMAX,Z,IZ,ZP,TEMP,SIGMA)
C
      DIMENSION Z(IZ,N),ZP(M,N,3),TEMP(1)
C
C ---------------------------------------------------------------------
C Note:  This routine comes from a proprietary package called FITPACK.
C It is used in the NCAR graphics package by permission of the author,
C Alan Cline.
C ---------------------------------------------------------------------
C
C                                            CODED BY ALAN KAYLOR CLINE
C                                         FROM FITPACK -- JUNE 22, 1986
C                                   A CURVE AND SURFACE FITTING PACKAGE
C                                 A PRODUCT OF PLEASANT VALLEY SOFTWARE
C                             8603 ALTUS COVE, AUSTIN, TEXAS 78759, USA
C
C ---------------------------------------------------------------------
C
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO
C COMPUTE AN INTERPOLATORY SURFACE PASSING THROUGH A RECT-
C ANGULAR GRID OF FUNCTIONAL VALUES. THE X AND Y VALUES ARE
C ASSUMED EQUALLY SPACED IN THE GRID. THE SURFACE DETERMINED
C CAN BE REPRESENTED AS THE TENSOR PRODUCT OF SPLINES UNDER
C TENSION. FOR ACTUAL INTERPOLATION AT A GRID OF POINTS
C EQUALLY SPACED IN BOTH X AND Y COORDINATES IT IS NECESSARY
C TO CALL SUBROUTINE MSBSF2.
C
C ON INPUT--
C
C   M IS THE NUMBER OF GRID LINES IN THE X-DIRECTION, I. E.
C   LINES PARALLEL TO THE Y-AXIS (M .GE. 2).
C
C   N IS THE NUMBER OF GRID LINES IN THE Y-DIRECTION, I. E.
C   LINES PARALLEL TO THE X-AXIS (N .GE. 2).
C
C   XMIN AND XMAX ARE THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE GRID IN THE X-DIRECTION. XMAX
C   SHOULD BE GREATER THAN XMIN.
C
C   YMIN AND YMAX ARE THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE GRID IN THE Y-DIRECTION. YMAX
C   SHOULD BE GREATER THAN YMIN.
C
C   Z IS AN ARRAY OF THE M * N FUNCTIONAL VALUES AT THE GRID
C   POINTS, I. E. Z(I,J) CONTAINS THE FUNCTIONAL VALUE AT
C   (X(I),Y(J)) FOR I = 1,...,M AND J = 1,...,N, WHERE X(I)
C   REPRESENTS THE I-TH EQUISPACED X VALUE, AND Y(J)
C   REPRESENTS THE J-TH EQUISPACED Y VALUE.
C
C   IZ IS THE ROW DIMENSION OF THE MATRIX Z USED IN THE
C   CALLING PROGRAM (IZ .GE. M).
C
C   ZP IS AN ARRAY OF AT LEAST 3*M*N LOCATIONS.
C
C   TEMP IS AN ARRAY OF AT LEAST N+N+M LOCATIONS WHICH IS
C   USED FOR SCRATCH STORAGE.
C
C   SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES
C   THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO
C   (E. G. .001) THE RESULTING SURFACE IS APPROXIMATELY THE
C   TENSOR PRODUCT OF CUBIC SPLINES. IF ABS(SIGMA) IS LARGE
C   (E. G. 50.) THE RESULTING SURFACE IS APPROXIMATELY
C   BI-LINEAR. IF SIGMA EQUALS ZERO TENSOR PRODUCTS OF
C   CUBIC SPLINES RESULT. A STANDARD VALUE FOR SIGMA IS
C   APPROXIMATELY 1. IN ABSOLUTE VALUE.
C
C ON OUTPUT--
C
C   ZP CONTAINS THE VALUES OF THE XX-, YY-, AND XXYY-PARTIAL
C   DERIVATIVES OF THE SURFACE AT THE GIVEN NODES.
C
C   M, N, XMIN, XMAX, YMIN, YMAX, Z, IZ, AND SIGMA ARE
C   UNALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES MSCEEZ, MSTRMS,
C AND MSSHCH.
C
C-----------------------------------------------------------
C
      MM1 = M-1
      MP1 = M+1
      NM1 = N-1
      NP1 = N+1
      NPM = N+M
C
C DENORMALIZE TENSION FACTOR IN Y-DIRECTION
C
      SIGMAY = ABS(SIGMA)*REAL(N-1)/(YMAX-YMIN)
C
C OBTAIN Y-PARTIAL DERIVATIVES ALONG Y = YMIN
C
      DELY1 = (YMAX-YMIN)/REAL(N-1)
      DELY2 = DELY1+DELY1
      CALL MSCEEZ (DELY1,DELY2,SIGMAY,C1,C2,C3,N)
      DO 1 I = 1,M
    1   ZP(I,1,1) = C1*Z(I,1)+C2*Z(I,2)
      IF (N .EQ. 2) GO TO 3
      DO 2 I = 1,M
    2   ZP(I,1,1) = ZP(I,1,1)+C3*Z(I,3)
C
C OBTAIN Y-PARTIAL DERIVATIVES ALONG Y = YMAX
C
    3 C1 = -C1
      C2 = -C2
      IF (N .GT. 2) C3 = -C3
      DO 4 I = 1,M
        NPI = N+I
    4   TEMP(NPI) = C1*Z(I,N)+C2*Z(I,NM1)
      IF (N .EQ. 2) GO TO 6
      DO 5 I = 1,M
        NPI = N+I
    5   TEMP(NPI) = TEMP(NPI)+C3*Z(I,N-2)
C
C DENORMALIZE TENSION FACTOR IN X-DIRECTION
C
    6 SIGMAX = ABS(SIGMA)*REAL(M-1)/(XMAX-XMIN)
C
C OBTAIN X-PARTIAL DERIVATIVES ALONG X = XMIN
C
      DELX1 = (XMAX-XMIN)/REAL(M-1)
      DELX2 = DELX1+DELX1
      CALL MSCEEZ (DELX1,DELX2,SIGMAX,C1,C2,C3,M)
      DO 7 J = 1,N
    7   ZP(1,J,2) = C1*Z(1,J)+C2*Z(2,J)
      IF (M .EQ. 2) GO TO 9
      DO 8 J = 1,N
    8   ZP(1,J,2) = ZP(1,J,2)+C3*Z(3,J)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (XMIN,YMIN)
C
    9 ZP(1,1,3) = C1*ZP(1,1,1)+C2*ZP(2,1,1)
      IF (M .GT. 2) ZP(1,1,3) = ZP(1,1,3)+C3*ZP(3,1,1)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (XMIN,YMAX)
C
      ZXY1NS = C1*TEMP(N+1)+C2*TEMP(N+2)
      IF (M .GT. 2) ZXY1NS = ZXY1NS+C3*TEMP(N+3)
C
C OBTAIN X-PARTIAL DERIVATIVE ALONG X = XMAX
C
      C1 = -C1
      C2 = -C2
      IF (M .GT. 2) C3 = -C3
      DO 10 J = 1,N
        NPMPJ = NPM+J
   10   TEMP(NPMPJ) = C1*Z(M,J)+C2*Z(MM1,J)
      IF (M .EQ. 2) GO TO 12
      DO 11 J = 1,N
        NPMPJ = NPM+J
   11   TEMP(NPMPJ) = TEMP(NPMPJ)+C3*Z(M-2,J)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (XMAX,YMIN)
C
   12 ZP(M,1,3) = C1*ZP(M,1,1)+C2*ZP(MM1,1,1)
      IF (M .GT. 2) ZP(M,1,3) = ZP(M,1,3)+C3*ZP(M-2,1,1)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (XMAX,YMAX)
C
      ZXYMNS = C1*TEMP(NPM)+C2*TEMP(NPM-1)
      IF (M .GT. 2) ZXYMNS = ZXYMNS+C3*TEMP(NPM-2)
C
C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR Y-GRID
C PERFORM FORWARD ELIMINATION
C
      DEL1 = DELY1
      DELI = 1./DEL1
      DO 13 I = 1,M
   13   ZP(I,2,1) = DELI*(Z(I,2)-Z(I,1))
      ZP(1,2,3) = DELI*(ZP(1,2,2)-ZP(1,1,2))
      ZP(M,2,3) = DELI*(TEMP(NPM+2)-TEMP(NPM+1))
      CALL MSTRMS (DIAG1,SDIAG1,SIGMAY,DEL1)
      DIAGI = 1./DIAG1
      DO 14 I = 1,M
   14   ZP(I,1,1) = DIAGI*(ZP(I,2,1)-ZP(I,1,1))
      ZP(1,1,3) = DIAGI*(ZP(1,2,3)-ZP(1,1,3))
      ZP(M,1,3) = DIAGI*(ZP(M,2,3)-ZP(M,1,3))
      TEMP(1) = DIAGI*SDIAG1
      IF (N .EQ. 2) GO TO 18
      DO 17 J = 2,NM1
        JM1 = J-1
        JP1 = J+1
        NPMPJ = NPM+J
        DO 15 I = 1,M
   15     ZP(I,JP1,1) = DELI*(Z(I,JP1)-Z(I,J))
        ZP(1,JP1,3) = DELI*(ZP(1,JP1,2)-ZP(1,J,2))
        ZP(M,JP1,3) = DELI*(TEMP(NPMPJ+1)-TEMP(NPMPJ))
        DIAGIN = 1./(DIAG1+DIAG1-SDIAG1*TEMP(JM1))
        DO 16 I = 1,M
   16     ZP(I,J,1) = DIAGIN*(ZP(I,JP1,1)-ZP(I,J,1)-
     *                        SDIAG1*ZP(I,JM1,1))
        ZP(1,J,3) = DIAGIN*(ZP(1,JP1,3)-ZP(1,J,3)-
     *                      SDIAG1*ZP(1,JM1,3))
        ZP(M,J,3) = DIAGIN*(ZP(M,JP1,3)-ZP(M,J,3)-
     *                      SDIAG1*ZP(M,JM1,3))
   17   TEMP(J) = DIAGIN*SDIAG1
   18 DIAGIN = 1./(DIAG1-SDIAG1*TEMP(NM1))
      DO 19 I = 1,M
        NPI = N+I
   19   ZP(I,N,1) = DIAGIN*(TEMP(NPI)-ZP(I,N,1)-
     *                      SDIAG1*ZP(I,NM1,1))
      ZP(1,N,3) = DIAGIN*(ZXY1NS-ZP(1,N,3)-
     *                    SDIAG1*ZP(1,NM1,3))
      TEMP(N) = DIAGIN*(ZXYMNS-ZP(M,N,3)-
     *                  SDIAG1*ZP(M,NM1,3))
C
C PERFORM BACK SUBSTITUTION
C
      DO 21 J = 2,N
        JBAK = NP1-J
        JBAKP1 = JBAK+1
        T = TEMP(JBAK)
        DO 20 I = 1,M
   20     ZP(I,JBAK,1) = ZP(I,JBAK,1)-T*ZP(I,JBAKP1,1)
        ZP(1,JBAK,3) = ZP(1,JBAK,3)-T*ZP(1,JBAKP1,3)
   21   TEMP(JBAK) = ZP(M,JBAK,3)-T*TEMP(JBAKP1)
C
C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR X-GRID
C PERFORM FORWARD ELIMINATION
C
      DEL1 = DELX1
      DELI = 1./DEL1
      DO 22 J = 1,N
        ZP(2,J,2) = DELI*(Z(2,J)-Z(1,J))
   22   ZP(2,J,3) = DELI*(ZP(2,J,1)-ZP(1,J,1))
      CALL MSTRMS (DIAG1,SDIAG1,SIGMAX,DEL1)
      DIAGI = 1./DIAG1
      DO 23 J = 1,N
        ZP(1,J,2) = DIAGI*(ZP(2,J,2)-ZP(1,J,2))
   23   ZP(1,J,3) = DIAGI*(ZP(2,J,3)-ZP(1,J,3))
      TEMP(N+1) = DIAGI*SDIAG1
      IF (M  .EQ. 2) GO TO 27
      DO 26 I = 2,MM1
        IM1 = I-1
        IP1 = I+1
        NPI = N+I
        DO 24 J = 1,N
          ZP(IP1,J,2) = DELI*(Z(IP1,J)-Z(I,J))
   24     ZP(IP1,J,3) = DELI*(ZP(IP1,J,1)-ZP(I,J,1))
        DIAGIN = 1./(DIAG1+DIAG1-SDIAG1*TEMP(NPI-1))
        DO 25 J = 1,N
          ZP(I,J,2) = DIAGIN*(ZP(IP1,J,2)-ZP(I,J,2)-
     *                        SDIAG1*ZP(IM1,J,2))
   25     ZP(I,J,3) = DIAGIN*(ZP(IP1,J,3)-ZP(I,J,3)-
     *                        SDIAG1*ZP(IM1,J,3))
   26   TEMP(NPI) = DIAGIN*SDIAG1
   27 DIAGIN = 1./(DIAG1-SDIAG1*TEMP(NPM-1))
      DO 28 J = 1,N
        NPMPJ = NPM+J
        ZP(M,J,2) = DIAGIN*(TEMP(NPMPJ)-ZP(M,J,2)-
     *                      SDIAG1*ZP(MM1,J,2))
   28   ZP(M,J,3) = DIAGIN*(TEMP(J)-ZP(M,J,3)-
     *                      SDIAG1*ZP(MM1,J,3))
C
C PERFORM BACK SUBSTITUTION
C
      DO 29 I = 2,M
        IBAK = MP1-I
        IBAKP1 = IBAK+1
        NPIBAK = N+IBAK
        T = TEMP(NPIBAK)
        DO 29 J = 1,N
          ZP(IBAK,J,2) = ZP(IBAK,J,2)-T*ZP(IBAKP1,J,2)
   29     ZP(IBAK,J,3) = ZP(IBAK,J,3)-T*ZP(IBAKP1,J,3)
      RETURN
C
      END


program tpslq1

!   Test program for PSLQ1 -- a one-level implementation of the standard
!   PSLQ algorithm for finding integer relations.  Fortran-90 ARPREC version.

!   David H. Bailey     2004-11-23

!   These parameters are set in the parameter statement below.  Some other
!   parameters are set in other routines.

!     idb = Debug level (0 - 3).
!     itr = Number of trials when KQ = 1, 2 or 3.
!     gam = Gamma, the PSLQ algorithm parameter.  Must be set to at least
!           Sqrt (4/3) = 1.154700538d0.
!     n   = Integer relation vector length.
!     kq  = 0 for the algebraic case [1, al, al^2, ... al^(n-1)], where
!           al = 3^(1/kr) - 2^(1/ks).  Set n = kr * ks + 1 and itr = 1.
!         = 1 for testing algebraic relations of a number read from a file.
!         = 2 for testing additive relations of numbers read from a file.
!         = 3 for testing multiplicative relations of numbers read from a file.
!         = 4 for custom input.
!     kr  = Degree of root of 3 when kq = 0.
!     ks  = Degree of root of 2 when kq = 0.
!     ndp = No. digits of pecision.  Must not exceed mpipl in mpmod90.f.
!           It is recommended that this be set to at least 30 digits more
!           than the expected detection level of the relation.
!     nep = Log10 of epsilon for detections.  Normally set to 10 - ndp or so.
!           Must not exceed the accuracy of input data.
!     rb  = Log10 of max size (Euclidean norm) of acceptable relation.

use mpmodule
implicit none
double precision d1, d2, drand, gam, rb, rm, second, tm, tm0, tm1
integer i, idb, iq, itr, j, k, kps, kcs, kq, kr, ks, kss, n, ndp, nep
parameter (gam = 1.154700538d0, idb = 2, itr = 1, kq = 0, kr = 5, ks = 5, &
  n = kr * ks + 1, ndp = 180, nep = -170, rb = 100.d0)
integer lnm(n)
character*1 chr1(100)
character*40 nam(n), namx
double precision dr(n), r1(n)
type (mp_real) al, t1, t2, r(n), x(n)

!   This is scratch space for pslq1.  See below.

integer is0(n)
double precision s1(n)
type (mp_real) s2(2*n*n+2*n)
save

call mpinit (ndp)
mpoud = 100
mpeps = mpreal (10) ** nep
write (6, 1) itr, gam, n, kq, kr, ks, rb, ndp, nep
1 format ('PSLQ1 Test Program'/'No. trials = ',i3,3x,'Gamma =',f12.9, &
  3x,'n =',i4,3x,'kq =',i2/'kr =',i2,3x,'ks =',i2,3x,'rb =',1p,d12.4/ &
  'Precision level ndp =',i6,' digits',3x,'Epsilon level nep = ',i6)
tm = 0.d0
kps = 0
kcs = 0
if (kq .eq. 1 .or. kq .eq. 2 .or. kq .eq. 3) then
  open (11, file = 'pslq.inp')
  rewind 11
endif

do k = 1, itr
  write (6, 2) k
2 format (/'Start trial', i3)

  if (kq .eq. 0) then

!   This code generates al = 3^(1/kr) - 2^(1/ks).  al is algebraic of degree
!   kr * ks.  Set n = kr * ks + 1 to recover the polynomial satisfied by al.

    al = mpnrtf (mpreal (3.d0), kr) - mpnrtf (mpreal (2.d0), ks)
  elseif (kq .eq. 1) then

!   Read an algebraic constant from a file.

    call mpread (11, al)
  elseif (kq .eq. 2) then

!   Read constants from a file for additive test.

    do i = 1, n
      call mpread (11, al)
      x(i) = al
      write (namx, '(''con'',i3.3)') i
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  elseif (kq .eq. 3) then

!   Read constants from a file for multiplicative test.

    do i = 1, n
      call mpread (11, al)
      x(i) = log (al)
      write (namx, '(''log(con'',i3.3,'')'')') i
      nam(i) = namx(1:11)
      lnm(i) = 11
    enddo
  elseif (kq .eq. 4) then

!   Produce X vector by a custom scheme.

  endif

!   If kq is 0 or 1, generate x = [1, al, al^2, ..., al^(n-1)].

  if (kq .eq. 0 .or. kq .eq. 1) then
    x(1) = 1.d0
    nam(1) = '1'
    lnm(1) = 1

    do i = 2, n
      x(i) = al * x(i-1)
      write (namx, '(''al^'',i3)') i - 1
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  endif

!   Perform relation search.

  tm0 = second ()
  call pslq1 (idb, gam, n, rb, x, is0, s1, s2, iq, r)
  tm1 = second ()

!   Output relation, if one was found.

  if (iq .ne. 0) then
    tm = tm + (tm1 - tm0)
    write (6, 4)
4   format ('Recovered relation: 0 =')

    do i = 1, n
      if (r(i) .ne. 0.d0) then
        call mpfform (r(i), 24, 0, chr1)
        write (6, '(''+'',24a1,'' * '',a)') (chr1(j), j = 1, 24), &
          nam(i)(1:lnm(i))
      endif
    enddo

!   Check if original relation was recovered.

    if (kq .ge. 1) then
      d1 = 0.d0
      d2 = 0.d0

      do i = 1, n
        d1 = d1 + abs (dble (r(i)) - r1(i))
        d2 = d2 + abs (dble (r(i)) + r1(i))
      enddo

      if (d1 .eq. 0.d0 .or. d2 .eq. 0.d0) then
        kcs = kcs + 1
        write (6, 5)
5       format ('Original relation recovered.')
      else
        kps = kps + 1
      endif
    endif
  endif
  write (6, 6) tm1 - tm0
6 format ('CPU Time =',f12.4)
enddo

if (itr .gt. 1) then
  write (6, 7) kps, kcs
7 format (/'No. partial successes =',i5/'No. complete successes =',i5)
  kss = kps + kcs
  if (kss .ne. 0) then
    tm = tm / kss
    write (6, 8) tm
8   format ('Ave. CPU time of PS or CS runs =',f10.4)
  endif
endif
stop
end

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

!   The following code performs the one-level, standard PSLQ algorithm.
!   David H. Bailey     2004-06-10

subroutine pslq1 (idb, gam, n, rb, x, is0, s1, s2, iq, r)

!   This routine allocates the scratch space arrays is0, s1 and s2.  Handling
!   scratch space in this manner is not really necessary in Fortran-90, but
!   this design facilitates straightforward translation to Fortran-77.

!   Arguments are as follows:
!     idb = Debug flag (0-3).
!     gam = PSLQ gamma parameter, normally set to sqrt(4/3).
!     n   = Dimension of input vector.
!     rb  = Maximum size (Euclidean norm) of acceptable relation (type DP).
!     x   = Input real vector (type mp_real).
!     is0 = Scratch array (type integer -- see size below).
!     s1  = Scratch array (type double precision -- see size below).
!     s2  = Scratch array (type mp_real -- see size below).
!     iq  = Output flag: 0 (unsuccessful) or 1 (successful).
!     r   = Output integer coefficient vector (type mp_real).

use mpmodule
implicit none
integer idb, iq, n
double precision gam, rb
integer is0(n)
double precision s1(n)
type (mp_real) s2(2*n*n+2*n), x(n), r(n)

call pslq1x (idb, gam, n, rb, x, is0(1), s1(1), s2(1), s2(n*n+1), &
  s2(2*n*n+1), s2(2*n*n+n+1), iq, r)
return
end

subroutine pslq1x (idb, gam, n, rb, x, ix, dx, b, h, s, y, iq, r)

!   The following parameters are set in this routine:
!     ipi = Iteration print interval when idb >= 2.
!     ipm = Iteration check interval for MP iterations.
!     itm = Maximum iteration count.  Run is aborted when this is exceeded.

use mpmodule
implicit none
integer i, idb, ipi, ipm, iq, it, itm, izm, j, j1, n, n1, n2, n3, n4
parameter (ipi = 100, ipm = 500, itm = 100000)
double precision d1, d2, d3, d4, dplog10, gam, rb, second, tm0, tm1, times(2)
integer ix(n)
double precision dx(n)
type (mp_real) b(n,n), h(n,n), s(n), r(n), x(n), y(n), bound, rn, t1, t2, &
  t3, t4
external bound, dplog10, second

!   Initialize.

if (idb .ge. 2) write (6, 1) n
1 format ('PSLQ1 integer relation detection: n =',i5)
iq = 0
it = 0
rn = 0.d0

do i = 1, 2
  times(i) = 0.d0
enddo

if (idb .ge. 2) write (6, 2) it
2 format ('Iteration',i7,3x,'MP initialization')
tm0 = second ()
call initmp (idb, n, ix, dx, b, h, s, x, y, izm)
tm1 = second ()
times(1) = tm1 - tm0
if (izm .ne. 0) goto 110

!   Perform MP iterations.

if (idb .ge. 2) write (6, 3) it
3 format ('Iteration',i7,3x,'Start MP iterations')

100 continue

it = it + 1
if (idb .eq. 3 .or. idb .ge. 2 .and. mod (it, ipi) .eq. 0) write (6, 4) it
4 format ('Iteration',i7)
tm0 = second ()
call itermp (idb, gam, it, n, ix, dx, b, h, y, izm)
tm1 = second ()
times(2) = times(2) + (tm1 - tm0)

if (mod (it, ipm) .eq. 0) then

!   Find min and max absolute value of y vector.

  t1 = 1.d300
  t2 = 0.d0

  do i = 1, n
    t1 = min (t1, abs (y(i)))
    t2 = max (t2, abs (y(i)))
  enddo

  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    call decmd (t2, d2, n2)
    write (6, 5) it, d1, n1, d2, n2
5   format ('Iteration',i7,3x,'Min, max of y =',f11.6,'D',i5, &
      f11.6,'D',i5)
  endif

!   Compute norm bound.

  t1 = bound (n, h)
  rn = max (rn, t1)
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    call decmd (rn, d2, n2)
    write (6, 6) it, d1, n1, d2, n2
6   format ('Iteration',i7,3x,'Norm bound =',f11.6,'D',i5,4x,'Max. bound =', &
      f11.6,'D',i5)
  endif
  if (it .gt. itm) then
    if (idb .ge. 1) write (6, 7) itm
7   format ('Iteration limit exceeded',i7)
    goto 120
  endif
  if (dplog10 (rn) .gt. rb) then
    if (idb .ge. 1) write (6, 8) rb
8   format ('Norm bound limit exceeded.',1p,d15.6)
    goto 120
  endif
endif

if (izm .eq. 0) then
  goto 100
elseif (izm .eq. 1) then
  goto 110
elseif (izm .eq. 2) then
  goto 120
endif

110 continue

!   A relation has been detected.

tm0 = second ()
t1 = 1.d300
t2 = 0.d0
t3 = 0.d0

!   Select the relation corresponding to the smallest y entry and compute norm.

do j = 1, n
  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
  t2 = max (t2, abs (y(j)))
enddo

do i = 1, n
  r(i) = b(i,j1)
  t3 = t3 + r(i) ** 2
enddo

t3 = sqrt (t3)
call decmd (t3, d3, n3)
d3 = d3 * 10.d0 ** n3

!   Output the final norm bound and other info.

if (idb .ge. 1) then
  t4 = bound (n, h)
  call decmd (t1, d1, n1)
  call decmd (t2, d2, n2)
  call decmd (t3, d3, n3)
  call decmd (t4, d4, n4)
  write (6, 9) it, d1, n1, d2, n2, d4, n4
9 format ('Iteration',i7,3x,'Relation detected'/ &
  'Min, max of y =',0p,f11.6,'D',i5,f11.6,'D',i5/'Max. bound =',f11.6,'D',i5)
  write (6, 10) j1, d3, n3, d1, n1
10 format ('Index of relation =',i4,3x,'Norm =',f11.6,'D',i5,3x, &
  'Residual =',f11.6,'D',i5)
endif

if (dplog10 (t3) .le. rb) then
  iq = 1
else
  if (idb .ge. 2) write (6, 11)
11 format ('Relation is too large.')
endif

120 continue

if (idb .ge. 2) write (6, 12) times
12 format ('CPU times:'/(5f12.2))

return
end

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

!   First-level subroutines.

subroutine initmp (idb, n, ix, dx, b, h, s, x, y, izm)

!   This initializes MP arrays at the beginning.

use mpmodule
implicit none
integer i, idb, izm, j, k, n, n1
double precision d1
integer ix(n)
double precision dx(n)
type (mp_real) b(n,n), h(n,n), s(n), x(n), y(n), t1

if (idb .ge. 3) then
  write (6, 1)
1 format ('initmp: Input x vector:')
  call matoutmd (1, n, ix, dx, x)
endif
izm = 0

!   Set b to the identity matrix.

do j = 1, n
  do i = 1, n
    b(i,j) = 0.d0
  enddo

  b(j,j) = 1.d0
enddo

t1 = 0.d0

!   Compute the x vector, the square root of the partial sum of squares of x,
!   and the y vector, which is the normalized x vector.

do i = n, 1, -1
  t1 = t1 + x(i) ** 2
  s(i) = sqrt (t1)
enddo

t1 = 1.d0 / s(1)

do i = 1, n
  y(i) = t1 * x(i)
  s(i) = t1 * s(i)
enddo

!   Compute the initial h matrix.

do j = 1, n - 1
  do i = 1, j - 1
    h(i,j) = 0.d0
  enddo

  h(j,j) = s(j+1) / s(j)
  t1 = y(j) / (s(j) * s(j+1))

  do i = j + 1, n
!      t1 = y(i) * t1
      h(i,j) = - y(i) * t1
  enddo
enddo

!  Perform reduction on h, updating y, b and h.

do i = 2, n
  do j = i - 1, 1, -1
    t1 = anint (h(i,j) / h(j,j))
    if (t1 .ne. 0.d0) then
      y(j) = y(j) + t1 * y(i)

      do k = i, n
        b(k,j) = b(k,j) + t1 * b(k,i)
      enddo

      do k = 1, j
        h(i,k) = h(i,k) - t1 * h(j,k)
      enddo
    endif
  enddo
enddo

t1 = 1.d300

do i = 1, n
  t1 = min (t1, abs (y(i)))
enddo

if (t1 .le. mpeps) then
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    write (6, 2) 0, d1, n1
2   format ('Iteration',i8,3x,'initmp: Small value in y =',f11.6,'D',i5)
  endif
  izm = 1
endif

if (idb .ge. 3) then
  write (6, 3)
3 format ('initmp: Initial y vector:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 4)
4 format ('initmp: Initial h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

subroutine itermp (idb, gam, it, n, ix, dx, b, h, y, izm)

!   This performs one iteration of the PSLQ algorithm using MP arithmetic.

use mpmodule
implicit none
integer i, idb, im, im1, it, izm, j, j1, k, n, n1, ntl
parameter (ntl = 72)
double precision d1, d2, gam
integer ix(n)
double precision dx(n)
type (mp_real) b(n,n), h(n,n), y(n)
type (mp_real) t1, t2, t3, t4, teps

teps = 2.d0 ** ntl * mpeps
izm = 0
t1 = 0.d0

!   Find  im = i  such that  gam^i * |h(i,i)|  is maximized.

do i = 1, n - 1
  t2 = gam ** i * abs (h(i,i))
  if (t2 .gt. t1) then
    im = i
    t1 = t2
  endif
enddo

im1 = im + 1

! Exchange the im and im+1 entries of y, rows of h, and columns of b.

t1 = y(im)
y(im) = y(im1)
y(im1) = t1

do i = 1, n
  t1 = b(i,im)
  b(i,im) = b(i,im1)
  b(i,im1) = t1
enddo

do i = 1, n - 1
  t1 = h(im,i)
  h(im,i) = h(im1,i)
  h(im1,i) = t1
enddo

!  Update h with permutation produced above.

if (im .le. n - 2) then
  t1 = h(im,im)
  t2 = h(im,im1)
  t3 = sqrt (t1 ** 2 + t2 ** 2)
  t1 = t1 / t3
  t2 = t2 / t3

  do i = im, n
    t3 = h(i,im)
    t4 = h(i,im1)
    h(i,im) = t1 * t3 + t2 * t4
    h(i,im1) = - t2 * t3 + t1 * t4
  enddo
endif

t2 = 0.d0

!  Perform reduction on h, updating y, a, b and h.

do i = im1, n
  j1 = min (i - 1, im1)

  do j = j1, 1, -1
    t1 = anint (h(i,j) / h(j,j))
    if (t1 .ne. 0.d0) then
      y(j) = y(j) + t1 * y(i)

      do k = 1, n
        b(k,j) = b(k,j) + t1 * b(k,i)
      enddo

      do k = 1, j
        h(i,k) = h(i,k) - t1 * h(j,k)
      enddo
    endif
  enddo
enddo

!   Find the min of y.

t1 = 1d300

do j = 1, n
  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
enddo

!  Find the largest entry of b in the same column as the smallest y.

t2 = 0.d0

do i = 1, n
  t2 = max (t2, abs (b(i,j1)))
enddo

if (t1 .le. t2 * teps) then
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'itermp: Small value in y =',f11.6,'D',i5)
  endif
  if (t1 .le. t2 * mpeps) then
    izm = 1
  else
    if (idb .ge. 1) write (6, 2) it
2   format ('Iteration',i7,3x,'itermp: Precision exhausted.')
    izm = 2
  endif
endif

if (idb .ge. 3) then
  write (6, 4)
4 format ('itermp: Updated y:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 5)
5 format ('itermp: Updated b matrix:')
  call matoutmd (n, n, ix, dx, b)
  write (6, 6)
6 format ('itermp: Updated h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

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

!   Second- and third-level subroutines.

function bound (n, h)

!   This computes the norm bound using DP arithmetic.

use mpmodule
implicit none
integer i, n
type (mp_real) bound, h(n,n), t1, t2

t1 = 0.d0

do i = 1, n - 1
  t1 = max (t1, abs (h(i,i)))
enddo

bound = 1.d0 / t1

return
end

function dplog10 (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
double precision da, dplog10, t1
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .le. 0.d0) then
  dplog10 = -1d300
else
  dplog10 = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmd (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end

function drand ()

!   This routine returns a pseudorandom DP floating number nearly uniformly
!   distributed between 0 and 1 by means of a linear congruential scheme.
!   2^28 pseudorandom numbers with 30 bits each are returned before repeating.

double precision drand, f7, r30, sd, t1, t2, t30
parameter (f7 = 78125.d0, r30 = 0.5d0 ** 30, t30 = 2.d0 ** 30)
save sd
data sd/314159265.d0/

t1 = f7 * sd
t2 = aint (r30 * t1)
sd = t1 - t30 * t2
drand = r30 * sd

return
end

subroutine matoutmd (n1, n2, ix, dx, a)

!   This outputs the MP matrix a as a DP matrix.

use mpmodule
implicit none
integer i, j, n1, n2
integer ix(n2)
double precision dx(n2)
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call decmd (a(i,j), dx(j), ix(j))
  enddo

  write (6, 2) (dx(j), ix(j), j = 1, n2)
2 format (4(f13.8,'D',i5))
enddo

return
end

subroutine matoutmp (n1, n2, a)

!   This outputs the MP matrix a.  It may be used in place of calls to matoutmd
!   in the code above if greater accuracy is desired in debug output.

use mpmodule
implicit none
integer i, j, n1, n2
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call mpwrite (6, a(i,j))
  enddo
enddo

return
end


CHARACTER*8 S
S='FizzBuzz'
DO I=1,100
IF(MOD(I,3)==0) PRINT '(A4)',S
IF(MOD(I,5)==0) PRINT '(A)',S(5:)
IF(MOD(I,3)==0 .OR. MOD(I,5)==0)THEN
PRINT '(A)',S
ELSE
PRINT'(I0)',I
ENDIF
ENDDO
END


use cudafor

interface
  subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc) bind(c,name='cublasDgemm')
   use iso_c_binding
   integer(c_int), value :: m, n, k, lda, ldb, ldc
   real(c_double), device, dimension(m,n) :: a, b, c
   real(c_double), value :: alpha, beta
   character(kind=c_char), value :: transa, transb
  end subroutine dgemm

  subroutine cublasinit() bind(c,name='cublasInit')
  end subroutine cublasinit

end interface

real(8), dimension(1000,1000) :: a, b, c
real(8), device, dimension(1000,1000) :: dA, dB, dC
real(8) :: alpha, beta
integer :: m,n,k,lda,ldb,ldc

m = 100
n = 100
k = 100
lda = 100
ldb = 100
ldc = 1000
alpha = 1.0d0
beta = 0.0d0

call cublasinit()

dA = a
dB = b
call dgemm('n','n',m,n,k,alpha,dA,lda,dB,ldb,beta,dC,ldc)
c = dC

stop
end


      subroutine gpj0(dpj0,d2pj0,pj0,x)
c
c     This subroutine evaluates the function J0(x) (pj0) and its
c     first and second derivatives with respect to x (dpj0 and
c     d2pj0). The evaluation here uses an approximation given by
c     Pitzer (1975, eq. 47). Most modern usage of Pitzer's equations
c     is consistent with the later approximation of Harvie (1981).
c
c     These functions are used to compute E-lambda and E-theta
c     coefficients and their derivatives with respect to ionic
c     strength. They describe the higher-order electrostatic effects
c     in Pitzer's equations.
c
c     It is important to note that the tabulation of J(x) and J'(x)
c     in Table II of Pitzer (1975) is not for the approximation
c     represented by eq. 47. Pitzer (1975) does not provide such a
c     table for the eq. 47 approximation.
c
c                            References
c
c     Harvie, C. E. 1981. Theoretical Investigations in Geochemistry
c       and Atom Surface Scattering. Ph.D. dissertation, University
c       of California, San Diego (Available as #8203026 from
c       University Microfilms International, Ann Arbor, Michigan).
c
c     Pitzer, K.S. 1975. Thermodynamics of electrolytes. V. Effects
c       of higher-order electrostatic terms. Journal of Solution
c       Chemistry, v. 4, p. 249-265.
c
c     This subroutine is called by:
c
c       EQLIBG/elmdd.f
c       EQLIBG/cwrpjt.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       x      = independent variable
c
c     Output:
c
c       dpj0   = the derivative dJ0(x)/dx
c       d2pj0  = the derivative d2 J0(x)/dx2
c       pj0    = the function J0(x)
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      real(8) dpj0,d2pj0,pj0,x
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      real(8) alx,bk2,bk3,c1,c2,c3,c4,xc2,c3xc4,ec3xc4,t,xc2p
c
c-----------------------------------------------------------------------
c
c     These parameters are those for eq. 47 given in Table III of
c     Pitzer (1975).
c
      data c1,c2,c3,c4 /4.581,0.7237,0.0120,0.528/
c
c-----------------------------------------------------------------------
c
      pj0 = 0.
      dpj0 = 0.
      d2pj0 = 0.
c
      if (x .le. 0.) go to 999
c
      alx = log(x)
c
      xc2 = exp(-c2 * alx)
      c3xc4 = c3*exp(c4 * alx)
      ec3xc4 = exp(-c3xc4)
c
      pj0 = x / (4. + c1*xc2*ec3xc4)
c
      t = c4*c3xc4
      xc2p = exp((-c2 - 1.)*alx)
      bk2 = c1*xc2p *(c2 + t)*ec3xc4
c
      dpj0 = (pj0 / x)*(1. + pj0*bk2)
c
      bk3 = (t/x)*((c4 / (c2 + t)) - (c2 + 1.) / t)
      d2pj0 = ((dpj0 / pj0) - 1. / x)*(2.*dpj0 + pj0*bk3)
c
  999 continue
      end


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_UPDT_TBUV

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_FIELD_VARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_UPDT_TBUV

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:,  :  ) :: UV_MOD
    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: TBUV_MOD , TBFUV_MOD
    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: HKS , HDKS

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_UPDT_TBUV

    USE MR_MOD_FUNC_HKS
    USE MR_MOD_FUNC_TBUV

    USE MR_MOD_OPERATOR_SS
    USE MR_MOD_OPERATOR_UV

    IMPLICIT NONE

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM

    ALLOCATE( UV_MOD(1:NI1(NI,FDRD_KIND),1:NJ,1:1) )

    UV_MOD(:,:, 1 ) = .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. UV(:,:,1:2, 1 ) ) )

      IF( NKS == 0 ) THEN

        ALLOCATE( TBUV_MOD(1:NI1(NI,FDRD_KIND),1:NJ) , HKS(1:NI1(NI,FDRD_KIND),1:NJ) )

          TBUV_MOD = .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBUV ) )
          !BLOCK
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                HKS( I , J ) = D0(1) / ZR
              END DO
            END DO
          !END BLOCK
          DO DIM = 1 , 2
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                TBUV( I , J ,DIM) = MR_FUNC_TBUV_COMP( SIGMA( 1 ) ,   &
                & H( I , J ) , HKS( I , J ) ,   &
                & HKS( I , J ) , TBUV_MOD( I , J ) ,   &
                & UV_MOD( I , J , 1 ) , UV( I , J ,DIM, 1 ) )
              END DO
            END DO
          END DO

          DO DIM = 1 , 2
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                TBFUV( I , J ,DIM) = TBUV( I , J ,DIM)
              END DO
            END DO
          END DO

        DEALLOCATE( TBUV_MOD , HKS )

      ELSE

        ALLOCATE( TBUV_MOD(1:NI1(NI,FDRD_KIND),1:NJ) , HKS(1:NI1(NI,FDRD_KIND),1:NJ) ,   &
        & TBFUV_MOD(1:NI1(NI,FDRD_KIND),1:NJ) , HDKS(1:NI1(NI,FDRD_KIND),1:NJ) )

          TBFUV_MOD = .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBFUV ) )
          TBUV_MOD = .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBUV ) )
          !BLOCK
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                HDKS( I , J ) = MR_FUNC_HDKS( DS(1) )
              END DO
            END DO
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                HKS( I , J ) = MR_FUNC_HKS( DS(1) , TCRS(1) , H( I , J ) , TBFUV_MOD( I , J ) )
              END DO
            END DO
          !END BLOCK
          DO DIM = 1 , 2
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                TBFUV( I , J ,DIM) = MR_FUNC_TBUV_COMP( SIGMA( 1 ) ,   &
                & H( I , J ) , HDKS( I , J ) ,   &
                & HKS( I , J ) , TBUV_MOD( I , J ) ,   &
                & UV_MOD( I , J , 1 ) , UV( I , J ,DIM, 1 ) )
              END DO
            END DO
          END DO

          TBFUV_MOD = .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBFUV ) )
          !BLOCK
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                HKS( I , J ) = MR_FUNC_HKS( DS(1) , TCRS(1) , H( I , J ) , TBFUV_MOD( I , J ) )
              END DO
            END DO
          !END BLOCK
          DO DIM = 1 , 2
            DO J = 1 , NJ
             !DIR$ VECTOR ALIGNED
              DO I = 1 , NI
                TBUV( I , J ,DIM) = MR_FUNC_TBUV_COMP( SIGMA( 1 ) ,   &
                & H( I , J ) , HKS( I , J ) ,   &
                & HKS( I , J ) , TBUV_MOD( I , J ) ,   &
                & UV_MOD( I , J , 1 ) , UV( I , J ,DIM, 1 ) )
              END DO
            END DO
          END DO

        DEALLOCATE( TBUV_MOD , TBFUV_MOD , HKS , HDKS )

      END IF

    DEALLOCATE( UV_MOD )

  END SUBROUTINE MR_UPDT_TBUV

  END MODULE MR_MOD_UPDT_TBUV


     subroutine fort_estdt(u,u_l1,u_l2,u_l3,u_h1,u_h2,u_h3,lo,hi,dx,dt,a_old) &
        bind(C, name = "fort_estdt")

     use amrex_fort_module, only : rt => amrex_real
     use eos_module
     use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEINT
     use  eos_params_module

     implicit none
     !
     ! NOTE: for comoving coordinates, the factor of "a" is multiplied *outside* this routine
     !
     integer          :: u_l1,u_l2,u_l3,u_h1,u_h2,u_h3
     integer          :: lo(3), hi(3)
     real(rt) :: u(u_l1:u_h1,u_l2:u_h2,u_l3:u_h3,NVAR)
     real(rt) :: dx(3), dt
     real(rt) :: a_old

     real(rt) :: e, c
     real(rt) :: rhoInv,ux,uy,uz,dt1,dt2,dt3
     real(rt) :: sqrtK,grid_scl,dt4
     integer          :: i,j,k

     real(rt), parameter :: onethird = 1.d0/3.d0

     grid_scl = (dx(1)*dx(2)*dx(3))**onethird
     !
     ! Translate to primitive variables, compute sound speed
     !
     do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)

               rhoInv = 1.d0 / u(i,j,k,URHO)
               ux     = u(i,j,k,UMX)*rhoInv
               uy     = u(i,j,k,UMY)*rhoInv
               uz     = u(i,j,k,UMZ)*rhoInv

               ! Use internal energy for calculating dt
               e  = u(i,j,k,UEINT)*rhoInv

               ! Protect against negative e
               if (e .gt. 0.d0) then
                  call nyx_eos_soundspeed(c,u(i,j,k,URHO),e)
               else
                  c = 0.d0
               end if

               dt1 = dx(1)/(c + abs(ux))
               dt2 = dx(2)/(c + abs(uy))
               dt3 = dx(3)/(c + abs(uz))
               dt  = min(dt,dt1,dt2,dt3)
            enddo
         enddo
     enddo

     end subroutine fort_estdt


      SUBROUTINE NEWSYS(X,XD,M,NP,ENERGY,GAM)
*
*
*       Total energy of subsystem.
*       --------------------------
*
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  M(*),X(*),XD(*)
*
*
*       Calculate total energy in physical units.
      T = 0.0D0
      V = 0.0D0
      DO 10 I = 1,NP
          K1 = 3*(I - 1) + 1
          K2 = K1 + 1
          K3 = K2 + 1
          T = T + 0.5D0*M(I)*(XD(K1)**2 + XD(K2)**2 + XD(K3)**2)
          IF (I.EQ.NP) GO TO 10
          J1 = I + 1
          DO 9 J = J1,NP
              KI = 3*(I - 1)
              KJ = 3*(J - 1)
              R2 = 0.0D0
              DO 8 K = 1,3
                  KI = KI + 1
                  KJ = KJ + 1
                  R2 = R2 + (X(KI) - X(KJ))**2
    8         CONTINUE
              V = V - M(I)*M(J)/SQRT(R2)
    9     CONTINUE
   10 CONTINUE
*
      ENERGY = T + V
      GAM = T - V
*
      RETURN
*
      END


      do ep=-2,0
      S00i(1,ep)=-2d0*Csum0(ep)+2d0*m1*Dv(dd1+N0,ep)
      S00i(2,ep)=+2d0*Cv(cc1+C234,ep)+2d0*m1*Dv(dd2+N0,ep)
      S00i(3,ep)=+2d0*Cv(cc2+C234,ep)+2d0*m1*Dv(dd3+N0,ep)
      enddo


      subroutine MATL02(eps,trace,td,d,ud,hn,h1,nh,sig,dd,isw)

c      * * F E A P * * A Finite Element Analysis Program

c     Michael Scott
c     CE 233

c-----[--.----+----.----+----.-----------------------------------------]
c     Purpose: Linear Viscoelastic Material Model

c     Input:
c          eps(*)  -  Current strains at point
c          trace   -  Trace of strain at point
c          td      -  Temperature change
c          d(*)    -  Program material parameters (ndd)
c          ud(*)   -  User material parameters (nud)
c          hn(nh)  -  History terms at point: t_n
c          h1(nh)  -  History terms at point: t_n+1
c          nh      -  Number of history terms
c          isw     -  Solution option from element

c     Output: (N.B. Arrays are set to zero before call)
c          sig(6)  -  Stresses at point.
c          dd(6,6) -  Current material tangent moduli
c-----[--.----+----.----+----.-----------------------------------------]

      implicit none

      include  'iofile.h'
      include  'tdata.h'

      integer  nh, isw
      real*8   trace, td
      real*8   K,G,muK,muG,lamK,lamG,theta
      real*8   eps(6),d(*),ud(7),hn(nh),h1(nh),sig(6),dd(6,6)

      integer  i,j
      real*8   tmp1,tmp2
      real*8   qvn,evn,qvn1,evn1
      real*8   pn1
      real*8   qn(6),en(6),qn1(6),en1(6)
      real*8   sn1(6)
      real*8   Kve,Gve
      real*8   one3,two3

c     // Compute useful constants
      one3 = 1.d0/3.d0
      two3 = 2.d0*one3

c     // Read in material parameters
      K = ud(1)
      G = ud(2)
      muK = ud(3)
      muG = ud(4)
      lamK = ud(5)
      lamG = ud(6)
      theta = ud(7)

c     // Get the strain trace
      evn1 = trace

c     // If there is a bulk viscoelastic effect
      if (muK.gt.0.d0) then

c       // Put strain trace in trial history
         h1(7) = evn1

c       // Get volumetric strain and internal variable from committed history
         evn = hn(7)
         qvn = hn(14)

c       // Compute temporary quantities for integrating rate equation
         tmp1 = 1.d0 + theta*dt/lamK
         tmp2 = 1.d0 - (1.d0-theta)*dt/lamK

c       // Compute q_{v,n+1} and put in trial history
         qvn1 = (tmp2*qvn + evn1 - evn) / tmp1
         h1(14) = qvn1

c       // Compute pressure p_{n+1}
         pn1 = K*((1.d0-muK)*evn1 + muK*qvn1)

c       // Compute bulk viscoelastic tangent term
         Kve = K*((1.d0-muK) + muK/tmp1)

c     // Otherwise, no bulk viscoelastic effect
      else

         Kve = K
         pn1 = Kve*evn1

      end if

c     // Add pressure contribution to material stress
c     // \sigma += m p
      do i = 1,3
         sig(i) = pn1
      end do

c     // Add bulk term to material tangent
c     // D_t += Kve * mm^T
      do i = 1,3
         do j = 1,3
            dd(i,j) = Kve
         end do
      end do

c     // Compute trial deviatoric strains
c     // e = I_{dev} \epsilon = (I - 1/3 mm^T) \epsilon
      evn1 = evn1*one3
      en1(1) = eps(1) - evn1
      en1(2) = eps(2) - evn1
      en1(3) = eps(3) - evn1
      en1(4) = eps(4)
      en1(5) = eps(5)
      en1(6) = eps(6)

c     // If there is a shear viscoelastic effect
      if (muG.gt.0.d0) then

c       // Put deviatoric strains into trial history
         do i = 1,6
            h1(i) = en1(i)
         end do

c       // Compute temporary quantities for integrating rate equation
         tmp1 = 1.d0 + theta*dt/lamG
         tmp2 = 1.d0 - (1.d0-theta)*dt/lamG

c       // Get deviatoric strains and internal variables from committed history
         do i = 1,6
            en(i) = hn(i)
            qn(i) = hn(i+7)
         end do

c       // Compute internal variables and put in trial history
c       // q_{n+1} = \frac{tmp2*q_n + e_{n+1} - e_n}{tmp1}
         do i = 1,6
            qn1(i) = (tmp2*qn(i) + en1(i) - en(i)) / tmp1
            h1(i+7) = qn1(i)
         end do

c       // Compute deviatoric stress
c       // s_{n+1} = 2 G I_o (\mu_0 e_{n+1} + \mu_1 q_{n+1})
c       // Do the bulk terms ...
         do i = 1,3
            sn1(i) = G*(1.d0-muG)*2.d0*en1(i)
            sn1(i) = sn1(i) + G*muG*2.d0*qn1(i)
         end do

c       // ... and now do the shear terms
         do i = 4,6
            sn1(i) = G*(1.d0-muG)*en1(i)
            sn1(i) = sn1(i) + G*muG*qn1(i)
         end do

c       // Compute shear viscoelastic tangent term
         Gve = G*((1.d0-muG) + muG/tmp1)

c     // Otherwise, no shear viscoelastic effect
      else

         Gve = G

c       // Do the bulk terms ...
         do i = 1,3
	    sn1(i) = G*2.d0*en1(i)
         end do

c       // ... and now do the shear terms
         do i = 4,6
	    sn1(i) = G*en1(i)
         end do

      end if

c     // Add deviatoric stress to total stress
      do i = 1,6
         sig(i) = sig(i) + sn1(i)
      end do

c     // Add deviatoric quantities to material tangent
c     // D_t += 2 G^{ve} I_o (I - 1/3 mm^T)
c     // Do the bulk terms ...
      do i = 1,3
         dd(i,i) = dd(i,i) + 2.d0*Gve*two3
      end do

c     // ... and do the deviatoric terms ...
      do i = 4,6
         dd(i,i) = dd(i,i) + Gve
      end do

c     // ... and finally do the off-diagonal terms
      Gve = Gve*two3            ! Gve = 2.d0*Gve*one3
      dd(1,2) = dd(1,2) - Gve
      dd(1,3) = dd(1,3) - Gve
      dd(2,3) = dd(2,3) - Gve
      dd(2,1) = dd(2,1) - Gve
      dd(3,1) = dd(3,1) - Gve
      dd(3,2) = dd(3,2) - Gve

      end