SUBROUTINE p67(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.7 Plane strain bearing capacity analysis of an elastic-plastic
!             (von Mises) material using 8-node rectangular quadrilaterals.
!             Consistent tangent stiffness. Closest Point Projection
!             Method (CPPM). No global stiffness matrix assembly.
!             Diagonally preconditioned conjugate gradient solver.
!-------------------------------------------------------------------------
 USE main
 USE geom
  IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file

 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,cg_tot,i,iel,incs,iters,iy,k,limit,           &
   loaded_nodes,ndim=2,ndof=16,nels,neq,nip=4,nlen,nn,nod=8,nodof=2,      &
   nprops=3,np_types,nst=4,nxe,nye
 REAL(iwp)::alpha,beta,bot,cg_tol,det,dlam,dsbar,dslam,d3=3.0_iwp,        &
   end_time,fnew,lode_theta,ltol,one=1.0_iwp,ptot,sigm,start_time,tol,up, &
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::cg_converged,converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),nf(:,:),node(:),  &
   num(:)
 REAL(iwp),ALLOCATABLE::acat(:,:),bee(:,:),bdylds(:),caflow(:),coord(:,:),&
   d(:),daatd(:,:),ddylds(:),dee(:,:),der(:,:),deriv(:,:),diag_precon(:), &
   dl(:,:),dload(:),dsigma(:),eld(:),eload(:),eps(:),g_coord(:,:),        &
   jac(:,:),km(:,:),loads(:),loadsr(:),p(:),points(:,:),prop(:,:),qinc(:),&
   qinva(:),qinvr(:),qmat(:,:),ress(:),rmat(:,:),trial(:),sigma(:),       &
   storkm(:,:,:),stress(:),tensor(:,:,:),tensorl(:,:,:),totd(:),totdl(:), &
   u(:),val(:,:),vmfl(:),vmfla(:),vmflq(:),weights(:),x(:),xnew(:),       &
   x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 CALL CPU_TIME(start_time)
 READ(10,*)nxe,nye,cg_tol,cg_limit,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   x_coords(nxe+1),y_coords(nye+1),num(nod),dee(nst,nst),                 &
   tensor(nst,nip,nels),g_g(ndof,nels),coord(nod,ndim),jac(ndim,ndim),    &
   der(ndim,nod),deriv(ndim,nod),g_num(nod,nels),bee(nst,ndof),           &
   km(ndof,ndof),eld(ndof),eps(nst),sigma(nst),eload(ndof),g(ndof),       &
   vmfl(nst),qinvr(nst),stress(nst),dload(ndof),caflow(nst),dsigma(nst),  &
   ress(nst),rmat(nst,nst),acat(nst,nst),qmat(nst,nst),qinva(nst),        &
   daatd(nst,nst),vmflq(nst),vmfla(nst),prop(nprops,np_types),etype(nels),&
   tensorl(nst,nip,nels),trial(nst),storkm(ndof,ndof,nels),dl(nip,nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 CALL bc_rect(nxe,nye,nf,'y')
 neq=MAXVAL(nf)
 ALLOCATE(loads(0:neq),bdylds(0:neq),totd(0:neq),ddylds(0:neq),           &
   loadsr(0:neq),totdl(0:neq),p(0:neq),xnew(0:neq),x(0:neq),              &
   diag_precon(0:neq),d(0:neq),u(0:neq))
!-----------------------loop to set up global arrays-----------------------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 WRITE(11,'(A,I7,A)')" There are",neq," equations"
 WRITE(11,'(/A)')                                                         &
 "  step   load        disp      iters    cg iters/plastic iter"
 totd=zero
 p=zero
 xnew=zero
 tensor=zero
 tensorl=zero
 dl=zero
 diag_precon=zero
 CALL sample(element,points,weights)
!--------------starting element stiffness integration and assembly--------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(2,etype(iel)),prop(3,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
   END DO gauss_pts_1
   storkm(:,:,iel)=km
   DO k=1,ndof
     diag_precon(g(k))=diag_precon(g(k))+km(k,k)
   END DO
 END DO elements_2
 diag_precon(1:)=one/diag_precon(1:)
 diag_precon(0)=zero
!-----------------------read load weightings------------------------------
 READ(10,*)loaded_nodes
 ALLOCATE(node(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(node(i),val(i,:),i=1,loaded_nodes)
!-----------------------load increment loop-------------------------------
 READ(10,*)ltol,tol,limit,incs
 ALLOCATE(qinc(incs))
 READ(10,*)qinc
 ptot=zero
 load_increments: DO iy=1,incs
   ptot=ptot+qinc(iy)
   totdl=zero
   loads=zero
   loadsr=zero
   bdylds=zero
   cg_tot=0
   iters=0
!-----------------------load increment loop-------------------------------
   DO i=1,loaded_nodes
     loads(nf(:,node(i)))=val(i,:)*qinc(iy)   ! load increment
     loadsr(nf(:,node(i)))=val(i,:)*ptot      ! total load
   END DO
!-----------------------plastic iteration loop----------------------------
   iterations: DO
     iters=iters+1
     WRITE(*,'(A,F8.2,A,I4)')"  load",ptot,"  iteration",iters
     IF(iters/=1)loads=zero
     loads=loads+bdylds
     d=diag_precon*loads
     p=d
!-----------------------pcg equation solution-----------------------------
     x=zero
     cg_iters=0
     pcg: DO
       cg_iters=cg_iters+1
       u=zero
       elements_3: DO iel=1,nels
         g=g_g(:,iel)
         km=storkm(:,:,iel)
         u(g)=u(g)+MATMUL(km,p(g))
       END DO elements_3
       up=DOT_PRODUCT(loads,d)
       alpha=up/DOT_PRODUCT(p,u)
       xnew=x+p*alpha
       loads=loads-u*alpha
       d=diag_precon*loads
       beta=DOT_PRODUCT(loads,d)/up
       p=d+p*beta
       call checon(xnew,x,cg_tol,cg_converged)
       IF(cg_converged.OR.cg_iters==cg_limit)EXIT
     END DO pcg
     cg_tot=cg_tot+cg_iters
     loads=xnew
     loads(0)=zero
     totdl=totdl+loads
     ddylds=zero
     diag_precon=zero
!-----------------------go round the Gauss Points ------------------------
     elements_4: DO iel=1,nels
       dload=zero
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       km=zero
       eld=totdl(g)
       gauss_pts_2: DO i=1,nip
         CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         CALL deemat(dee,prop(2,etype(iel)),prop(3,etype(iel)))
         sigma=MATMUL(dee,eps)
         stress=sigma+tensorl(:,i,iel)
         trial=stress
         CALL invar(stress,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         fnew=dsbar-SQRT(d3)*prop(1,etype(iel))
         IF(fnew>=zero)THEN
           dlam=zero
           iterate_on_fnew: DO
             CALL vmflow(stress,dsbar,vmfl)
             caflow=MATMUL(dee,vmfl)
             ress=stress-trial+caflow*dlam
             CALL fmacat(vmfl,acat)
             acat=acat/dsbar
             qmat=dlam*MATMUL(dee,acat)
             DO k=1,4
               qmat(k,k)=qmat(k,k)+one
             END DO
             CALL invert(qmat)
             vmflq=MATMUL(vmfl,qmat)
             vmfla=MATMUL(vmflq,dee)
             dslam=(fnew-DOT_PRODUCT(vmflq,ress))/DOT_PRODUCT(vmfla,vmfl)
             dsigma=-MATMUL(qmat,ress)-MATMUL(MATMUL(qmat,dee),vmfl)*dslam
             stress=stress+dsigma
             CALL invar(stress,sigm,dsbar,lode_theta)
             fnew=dsbar-SQRT(d3)*prop(1,etype(iel))
             dlam=dlam+dslam
             IF(fnew<ltol)EXIT
           END DO iterate_on_fnew
           CALL vmflow(stress,dsbar,vmfl)
           CALL fmrmat(vmfl,dsbar,dlam,dee,rmat)
           caflow=MATMUL(rmat,vmfl)
           bot=DOT_PRODUCT(vmfl,caflow)
           CALL formaa(vmfl,rmat,daatd)
           dee=rmat-daatd/bot
         END IF
         km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
!-----------------------update the Gauss Point stresses-------------------
         tensor(:,i,iel)=stress
         eload=MATMUL(stress,bee)
         dload=dload+eload*det*weights(i)
       END DO gauss_pts_2
!-----------------------compute the total bodyloads vector----------------
       ddylds(g)=ddylds(g)+dload
       ddylds(0)=zero
       storkm(:,:,iel)=km
       DO k=1,ndof
         diag_precon(g(k))=diag_precon(g(k))+km(k,k)
       END DO
     END DO elements_4
     diag_precon(1:neq)=one/diag_precon(1:neq)
     diag_precon(0)=zero
     bdylds=loadsr-ddylds
     bdylds(0)=zero
     IF(norm(bdylds(1:))/norm(loadsr(1:))<tol)converged=.TRUE.
     IF(iters==1)converged=.FALSE.
     IF(converged.OR.iters==limit)EXIT
   END DO iterations
   tensorl=tensor
   totd=totd+totdl
   WRITE(11,'(I5,2E12.4,I5,F17.2)')                                       &
         iy,ptot,totd(nf(2,node(1))),iters,REAL(cg_tot)/REAL(iters)
   IF(iters==limit)EXIT
 END DO load_increments
 CALL dismsh(totd,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(totd,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)
 CALL CPU_TIME(end_time)
 WRITE(11,'(A,F12.4)')" Time taken = ",end_time-start_time

END SUBROUTINE p67


program vinay
  print *,(3  - 2 * (2 - 3 + ( 10 * (-5)) ** 2 + (-100)))  - 1000
end program vinay


      MODULE kinds
       IMPLICIT NONE

       PUBLIC :: real_4, real_8, real_4_size, real_8_size

       INTEGER, PARAMETER :: real_4 = SELECTED_REAL_KIND(6, 30)
       INTEGER, PARAMETER :: real_8 = SELECTED_REAL_KIND(14, 200)
       INTEGER, PARAMETER :: real_4_size = 4
       INTEGER, PARAMETER :: real_8_size = 8
      END MODULE

      module fpga_sgemm_mod
        use, intrinsic :: iso_c_binding
       interface
         subroutine multiply_c(m,n,k,A,B,C,test) bind(c,name="multiply")
            use, intrinsic :: iso_c_binding
            integer( kind=c_int32_t), value :: m,n,k,test
            REAL(KIND=c_float) :: A(m,k)
            REAL(KIND=c_float) :: B(k,n)
            REAL(KIND=c_float) :: C(m,n)
          end subroutine multiply_c
        end interface
      contains
        subroutine sgemm_fpga(TRANSA,TRANSB,M,N,K,alpha,A,LDA,B,ldb,beta,C,ldc)
        use kinds
        use omp_lib
        implicit none
        CHARACTER,intent(in) :: TRANSA,TRANSB
        integer,intent(in)    :: M,N,K,lda,ldb,ldc
        real(KIND=real_4),intent(in),target      :: A(m,k)
        real(KIND=real_4),intent(in),target      :: B(k,n)
        real(KIND=real_8),intent(in)      :: alpha,beta
        real(KIND=real_4),intent(inout),target   :: C(m,n)
        real(KIND=real_4),target   :: D(m,n)
        real(kind=8)    :: t1,t2,t3,t4

        integer :: test=0
        t1=omp_get_wtime()

        if(TRANSA.eq.'t'.or.transa.eq.'T')then
          print*,"TransA=t/T not implemented"
          stop
        endif

        if(TRANSB.eq.'t'.or.transB.eq.'T')then
          print*,"TransB=t/T not implemented"
          stop
        endif

        if(LDA.ne.m)then
          print*,"LDA!=M not implemented"
          stop
        endif

        if(LDB.ne.k)then
          print*,"LDB!=k not implemented"
          stop
        endif

        if(LDC.ne.m)then
          print*,"LDC!=m not implemented"
          stop
        endif
        t2=omp_get_wtime()
        call multiply_c(m,n,k,A,B,D,test)
        t3=omp_get_wtime()

        call saxpby(m*k,real(alpha,kind=4),D,1,real(beta,kind=4),C,1)
!        C=real(beta,kind=4)*C+real(alpha,kind=4)*D
        t4=omp_get_wtime()

        print*,"TFlops_sgemm_fpga=",2.0D0*real(m,kind=8)**3*1d-12/(t3-t2),2.0D0*real(m,kind=8)**3*1d-12/(t4-t1)
        end subroutine sgemm_fpga
      end module

      program test
      use kinds
      use omp_lib
      implicit none
      integer(4)            :: n,maxiter,i,bs,col=1,n2
      real(8),allocatable   :: A(:,:),S(:,:),Ascaled(:,:),S2(:,:)
      real(8)               :: conv,Eref,INV,work,frob_matrix,gersh_matrix
      CHARACTER(len=32) :: arg
      REAL(KIND=8), EXTERNAL                            :: dlange

      CALL get_command_argument(1, arg)
      read(arg,*) n
      CALL get_command_argument(2, arg)
      read(arg,*) bs
      CALL get_command_argument(3, arg)
      read(arg,*) conv
      CALL get_command_argument(4, arg)
      read(arg,*)maxiter

      print*,"Matrix size=",n
      print*,"Block size=",bs
      print*,"convergence crit=",conv

      allocate(A(n,n))

!      call makerandommat(n,A)
      OPEN(10,file="ksmat.bin",access='stream')
      READ(10)A
      CLOSE(10)

      if(modulo(n,8).eq.0)then
        n2=n
      else
        n2=n+8-modulo(n,8)
      endif
      print*,"padded size",n2

      allocate(Ascaled(n2,n2))
      allocate(S(n2,n2))
      Ascaled=0
      do i=1,n2
        Ascaled(i,i)=Ascaled(i,i)+1.0D0
      enddo
      Ascaled(1:n,1:n)=A(1:n,1:n)
      call scalemat(n2,Ascaled)

      !one iteration for gpu init
      call sign_fpga(n2,Ascaled,S,conv,1)

      call sign_fpga(n2,Ascaled,S,conv,maxiter)

      allocate(S2(n2,n2))
      CALL dgemm('N', 'N', n2, n2, n2, 1.0D0, S, n2, S, n2, 0.0D0,S2, n2)
      do i=1,N2
        S2(i,i)=S2(i,i)-1.0D0
      enddo
      frob_matrix  = dlange('F', n2, n2, S2, n2, work) !dbcsr_frobenius_norm(matrix_sign)
      gersh_matrix = dlange('1', n2, n2, S2, n2, work) !dbcsr_gershgorin_norm(matrix_sign)

      !from sign function to density matrix
      S=-0.5D0*S
      do i=1,n
        S(i,i)=S(i,i)+0.5D0
      enddo

      Eref=sum(S(1:n,(col-1)*bs+1:col*bs)*A(1:n,(col-1)*bs+1:col*bs))
      print*,"E=",col,Eref
      print*,"INV=",col,frob_matrix,gersh_matrix

      end program

      subroutine makerandommat(n,A)
      implicit none
      integer(4),intent(in)        :: n
      real(8),intent(inout)        :: A(n,n)
      integer(4)                   :: i,j
      real(8)                      :: svar

      do i=1,n
        call random_number(svar)
        A(i,i)=2.0*svar-1.0
        do j=i+1,n
          call random_number(svar)
          A(i,j)=2.0*svar-1.0
          A(j,i)=A(i,j)

        enddo
      enddo
      call scalemat(n,A)
      end subroutine

      subroutine scalemat(n,A)
      implicit none
      integer(4),intent(in)   :: N
      real(8),intent(inout)   :: A(N,N)
      real(8)                 :: work
      real(8)                      :: frob_matrix,gersh_matrix,scaling_factor
      REAL(KIND=8), EXTERNAL                            :: dlange

      frob_matrix  = dlange('F', n, n, A, n, work) !dbcsr_frobenius_norm(matrix_sign)
      gersh_matrix = dlange('1', n, n, A, n, work) !dbcsr_gershgorin_norm(matrix_sign)
      scaling_factor = 1/MIN(frob_matrix, gersh_matrix)
      !print*,"norms",sz,frob_matrix,gersh_matrix,scaling_factor
      A = A * scaling_factor

      end subroutine

      subroutine sign_fpga(n,Xin,S,conv,maxiter)
      use kinds
      use fpga_sgemm_mod
      use omp_lib
      implicit none
      integer(4),intent(in)   :: n,maxiter
      real(kind=real_8),intent(in) :: Xin(n,n)
      real(kind=real_8),intent(out) :: S(n,n)
      real(kind=8),intent(in)   :: conv
      integer(4)    :: i,j,nmult,iter
      real(4)   :: alpha=1.0D0,beta=0.0D0
      real(kind=real_8) :: diff,t1,t2,e0,e1
      real(kind=4),allocatable    :: X(:,:),Y1(:,:),Y2(:,:)
      REAL(KIND=4), EXTERNAL                            :: snrm2

      allocate(X(n,n))
      allocate(Y1(n,n))
      allocate(Y2(n,n))
      X=Xin

      t1=omp_get_wtime()
      nmult=0

      !third-order Pade sign iteration
      do iter=1,maxiter
        !call multiplication on fpga

        call sgemm_fpga('N','N',n,n,n,1.0D0,X,n,X,n,0.0D0,Y1,n)
        nmult=nmult+1

        call scopy(N*N,X,1,Y2,1)
        call sgemm_fpga('N','N',n,n,n,3.0D0,X,n,Y1,n,-10.0D0,Y2,n)
        nmult=nmult+1

        call sgemm_fpga('N','N',n,n,n,1.0D0/8.0D0,Y2,n,Y1,n,15.0D0/8.0D0,X,n)
        nmult=nmult+1

        e0=snrm2(n*n,Y1,1)
        do i=1,n
          Y1(i,i)=Y1(i,i)-1.0D0
        enddo
        e1=snrm2(n*n,Y1,1)
        print*,"iter",iter,e0,e1
        if(e1*e1.lt.e0*e0*conv)then
          exit
        endif

      enddo
      t2=omp_get_wtime()
      print*,"TFlops_sign=",2.0D0*real(n,kind=8)**3*nmult*1d-12/(t2-t1)
      S=X

      end subroutine


! This routine will perform a coordinates conversion. It takes the
! heliocentric angle (theta), the local magnetic inclination (Gamma) and
! azimuth (Chi) and returns the line-of-sight inclination (Gamma_p) and
! azimuth (Chi_p). All of these angles are real arrays of size npoints.
!
! It is assumed that the heliocentriz azimuth is zero, which means that
! the observed point is on the E-W line that crosses the solar disk center.
! If that is not the case, the azimuth obtained is uncalibrated by an
! additive constant.
!
! navarro@hao.ucar.edu , Mar 2000
!
Subroutine local_to_los(npoints, Theta, Gamma, Chi, Gamma_p, Chi_p)
  Implicit None
  Integer :: npoints
  Real :: Theta
  Real, parameter :: Pi = 3.14159265389793D0, Deg_to_rad = Pi/180.
  Real, dimension (npoints) :: Gamma, Chi, Gamma_p, Chi_p
!
! Do NOT convert!
!
  Chi_p=Chi
  Gamma_p=Gamma
  Return
!
! Piece of cake
!
  Chi_p=Chi
  Gamma_p=Acos(Cos(Gamma*Deg_to_rad)*Cos(Theta*Deg_to_rad) - &
       Sin(Gamma*Deg_to_rad)*Cos(Chi*Deg_to_rad)*Sin(Theta*Deg_to_rad)) / &
       Deg_to_rad
!
! Done!
!
  Return
End Subroutine local_to_los


FUNCTION FPROBDEP(TAUDDD,TAUBBB)

  !**********************************************************************C
  !
  ! **  FPROBDEP CALCULATES PROBABILITY OF DEPOSITION USING PROBABILITY
  ! **  INTEGRAL
  !
  ! **  THIS SUBROUTINE IS PART OF  EFDC-FULL VERSION 1.0a
  !
  ! **  LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
  !
  !----------------------------------------------------------------------C
  !
  ! CHANGE RECORD
  ! DATE MODIFIED     BY                 DATE APPROVED    BY
  !
  !----------------------------------------------------------------------C
  !
  !**********************************************************************C
  !

  IMPLICIT NONE

  INTEGER :: INEG
  REAL   :: FPROBDEP,YVAL,XVAL,POLYX,EXPY,FUNY,TMPVAL
  REAL, INTENT(IN) :: TAUDDD,TAUBBB

  ! *** EVALUATION ASSUMES TAUBBB > TAUDDD
  YVAL=2.04*LOG(0.25*((TAUBBB/TAUDDD)-1.)*EXP(1.27*TAUDDD))
  INEG=0
  IF( YVAL < 0.0 )THEN
    INEG=1
    YVAL=ABS(YVAL)
  ENDIF
  XVAL=1.0/(1.0+0.3327*YVAL)
  POLYX=XVAL*(0.4632-0.1202*XVAL+0.9373*XVAL*XVAL)
  EXPY=-0.5*YVAL*YVAL
  FUNY=0.3989*EXP(EXPY)
  TMPVAL=1.0-FUNY*POLYX
  IF( INEG == 1 ) TMPVAL=1.0-TMPVAL
  FPROBDEP=1.0-TMPVAL

  ! **  NOTES
  !     0.3989=1/SQRT(2*PI)

END FUNCTION


! test speed of Laplace 3D kernel eval in Fortran 90.
! Barnett 9/26/18 - 10/1/18
! ntest>1 added 3/4/20

! Issues: why is run time so variable, compared to other language versions??

! real*8:
! gfortran-7 lap3dpottest.f90 -O3 -fopenmp -funroll-loops -march=native; ./a.out
! 1.1 Gpair/s,    @ 8 thr, or often at 4 thr too.
! or 1.3 if use _sep ordering (slightly better)
! This is same as numba jit in python3 intel version.

! -----------All this was single (real*4, which is real): ---------------------
! gfortran-8 lap3dpottest.f90 -O3 -fopenmp -march=native; ./a.out
! around 1.9 @ 8 thr

! gfortran-8 lap3dpottest.f90 -O3 -fopenmp; ./a.out
! only 0.7   @ 8 threads

! gfortran-8 lap3dpottest.f90 -Ofast -fopenmp -funroll-loops; ./a.out
! 1.2     @ 8 thr

! gfortran-8 lap3dpottest.f90 -O3 -funroll-loops; ./a.out
! gfortran-8 lap3dpottest.f90 -O3; ./a.out
! 0.5 Gpair/s

! gfortran lap3dpottest.f90 -O3 -funroll-loops; ./a.out
! 0.17

! gfortran-7 lap3dpottest.f90 -O3 -funroll-loops; ./a.out
! 0.25

! gfortran-7 lap3dpottest.f90 -O3; ./a.out
! 0.1

program lap3dpottest

  !use omp_lib

  implicit none
  integer :: ns=10000, nt=10000, ntest=20, i
  real*8, allocatable :: x(:,:), y(:,:), q(:), pot(:)
  real*8 :: t0,t1
  real :: t
  real*8 :: tot,omp_get_wtime

  print *,'ns=',ns,'   nt=',nt

  allocate(x(3,nt))
  allocate(pot(nt))
  allocate(y(3,ns))
  allocate(q(ns))

  call random_number(x)
  call random_number(y)
  call random_number(q)

  !call cpu_time(t0)             ! use if no openmp
  !print *,'timer tick : ',omp_get_wtick()    ! 1 ns resolution
  print *,'ntest = ',ntest,' ...'
  t0 =omp_get_wtime()
  do i=1,ntest
     call lap3dpot(pot,y,q,x,ns,nt)
  end do
  !call cpu_time(t1)
  t1 = omp_get_wtime()
  t = t1-t0
  tot = 0.D0
  do i=1,nt
     tot = tot + pot(i)
  end do
  print *,'tot=',tot
  print *,ns*nt,'src-targ pairs in',t,'s:',ntest*ns*nt/t/1.E9,'Gpair/s'

  ! Amazingly, gfortran -Wall doesn't complain if we fail to flip the arrays
  ! but call a routine expecting flipped arrays! ... shameful ...

  if (0.eq.1) then
     t0 =omp_get_wtime()
     do i=1,ntest
        call lap3dpot_tr(pot,y,q,x,ns,nt)
     end do
     t = omp_get_wtime()-t0
     tot = 0.D0
     do i=1,nt
        tot = tot + pot(i)
     end do
     print *,'tot=',tot
     print *,'tr:',ns*nt,'src-targ pairs in',t,'s:',ntest*ns*nt/t/1.E9,'Gpair/s'
  endif

  deallocate(x)
  deallocate(y)
  deallocate(q)
  deallocate(pot)

end program lap3dpottest

! ----------------------------------------------------------------------
subroutine lap3dpot(pot, y,q,x,ns,nt)
  ! writes to pot the potential at targets x due to sources at y
  ! with charges q

  implicit none
  integer ns, nt, i, j
  real*8 :: x(3,nt), y(3,ns), q(ns), pot(nt)
  real*8 :: prefac, r2ij
  real*8 :: pi = 4*atan(1.D0)

  prefac = 1.D0/(4*pi)
  !$omp parallel
  !$omp do private(i,j,r2ij)
  do i=1,nt
     pot(i) = 0.0
     do j=1,ns
        r2ij = (x(1,i)-y(1,j))**2+(x(2,i)-y(2,j))**2+(x(3,i)-y(3,j))**2
        pot(i) = pot(i) + prefac * q(j) / sqrt(r2ij)
     end do
  end do
  !$omp end do
  !$omp end parallel

end subroutine lap3dpot

! ----------------------------------------------------------------------
subroutine lap3dpot_tr(pot, y,q,x,ns,nt)
  ! writes to pot the potential at targets x due to sources at y
  ! with charges q. Transposed arrays with x,y,z separated (n*3 not 3*n)

  implicit none
  integer ns, nt, i, j
  real*8 :: x(nt,3), y(ns,3), q(ns), pot(nt)
  real*8 :: prefac, r2ij
  real*8 :: pi = 4*atan(1.D0)

  prefac = 1.D0/(4*pi)
  !$omp parallel
  !$omp do private(i,j,r2ij)
  do i=1,nt
     pot(i) = 0.0
     do j=1,ns
        r2ij = (x(i,1)-y(j,1))**2+(x(i,2)-y(j,2))**2+(x(i,3)-y(j,3))**2
        pot(i) = pot(i) + prefac * q(j) / sqrt(r2ij)
     end do
  end do
  !$omp end do
  !$omp end parallel

end subroutine lap3dpot_tr


C     SUBROUTINE CFFTB(N,C,WSAVE)
C
C     SUBROUTINE CFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , CFFTB COMPUTES
C     A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     A CALL OF CFFTF FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE
C     SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTB MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES.
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS CFFTB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
C
      SUBROUTINE CFFTB(N,C,WSAVE)
      DOUBLE PRECISION C
      DOUBLE PRECISION WSAVE
      DIMENSION C(*),WSAVE(*)
C
      IF (N.EQ.1) RETURN
      IW1 = N + N + 1
      IW2 = IW1 + N + N
      CALL CFFTB1(N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END


************************************************************************
*
*     Subroutine MATMLT                     Called by: MLELOAD2, MLEVAR
*
*     matrix multiplication for XO * XTXINV * XT (for mean) or
*     XO * XTXINV * XJT (for variance), where:
*
*     XT       explanatory variables for a single population value,
*              transposed
*     XJT      Jth set of explanatory variables for which a predicted
*              value is desired, transposed
*
************************************************************************
      SUBROUTINE MATMLT(V,XO,XTXINV,NPAR,I,JJ,NOBSE)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,I,JJ,NOBSE
      DOUBLE PRECISION V,XO(NOBSE,*),XTXINV(MAXPARMS,*)
*
*     local vars
*
      INTEGER*4 J,K
      DOUBLE PRECISION B(MAXPARMS)
*
*     multiply XO and XTXINV, storing intermediate result in B, then
*     multiply B and XO.  (XO in the second of these two operations
*     is equal to XT or XJT (?)).
*
      V = 0.D0
      DO 20 J=1,NPAR
         B(J) = 0.D0
         DO 10 K=1,NPAR
            B(J) = B(J) + XO(I,K)*XTXINV(K,J)
 10      CONTINUE
         V = V + B(J)*XO(JJ,J)
 20   CONTINUE

      RETURN
      END


!***********************************************************************
! Computes the potential evapotranspiration using the Jensen-Haise
! formulation (Jensen and others, 1970)
!     Potet = Coef_t_mean*(Tavgf-Temp_x_mean)*Swrad/elh
!***********************************************************************
      MODULE PRMS_POTET_JH
        IMPLICIT NONE
        ! Local Variable
        CHARACTER(LEN=8), SAVE :: MODNAME
        ! Declared Parameters
        REAL, SAVE, ALLOCATABLE :: Jh_coef(:, :), Jh_coef_hru(:)
      END MODULE PRMS_POTET_JH

      INTEGER FUNCTION potet_jh()
      USE PRMS_POTET_JH
      USE PRMS_MODULE, ONLY: Process, Nhru
      USE PRMS_BASIN, ONLY: Basin_area_inv, Active_hrus, Hru_area, Hru_route_order
      USE PRMS_CLIMATEVARS, ONLY: Basin_potet, Potet, Tavgc, Tavgf, Swrad
      USE PRMS_SET_TIME, ONLY: Nowmonth
      IMPLICIT NONE
! Functions
      INTRINSIC DBLE
      INTEGER, EXTERNAL :: declparam, getparam
      EXTERNAL read_error, print_module
! Local Variables
      INTEGER :: i, j
      REAL :: elh
      CHARACTER(LEN=80), SAVE :: Version_potet_jh
!***********************************************************************
      potet_jh = 0

      IF ( Process(:3)=='run' ) THEN
!***********************************************************************
! 597.3 cal/gm at 0 C is the energy required to change the state of
! water to vapor
! elh is the latent heat of vaporization (not including the *2.54)
        Basin_potet = 0.0D0
        DO j = 1, Active_hrus
          i = Hru_route_order(j)
          elh = (597.3-(0.5653*Tavgc(i)))*2.54
          Potet(i) = Jh_coef(i, Nowmonth)*(Tavgf(i)-Jh_coef_hru(i))*Swrad(i)/elh
          IF ( Potet(i)<0.0) Potet(i) = 0.0
          Basin_potet = Basin_potet + DBLE( Potet(i)*Hru_area(i) )
        ENDDO
        Basin_potet = Basin_potet*Basin_area_inv

!******Declare parameters
      ELSEIF ( Process(:4)=='decl' ) THEN
        Version_potet_jh = 'potet_jh.f90 2016-05-10 15:48:00Z'
        CALL print_module(Version_potet_jh, 'Potential Evapotranspiration', 90)
        MODNAME = 'potet_jh'

        ALLOCATE ( Jh_coef(Nhru,12) )
        IF ( declparam(MODNAME, 'jh_coef', 'nhru,nmonths', 'real', &
     &       '0.014', '0.0', '0.1', &
     &       'Monthly air temperature coefficient for each HRU - Jensen-Haise', &
     &       'Monthly (January to December) air temperature coefficient used in Jensen-Haise potential ET computations'// &
     &       ' for each HRU', &
     &       'per degrees Fahrenheit')/=0 ) CALL read_error(1, 'jh_coef')

        ALLOCATE ( Jh_coef_hru(Nhru) )
        IF ( declparam(MODNAME, 'jh_coef_hru', 'nhru', 'real', &
     &       '13.0', '-99.0', '150.0', &
     &       'HRU air temperature coefficient - Jensen-Haise', &
     &       'Air temperature coefficient used in Jensen-Haise potential ET computations for each HRU', &
     &       'degrees Fahrenheit')/=0 ) CALL read_error(1, 'jh_coef_hru')

!******Get parameters
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( getparam(MODNAME, 'jh_coef', Nhru*12, 'real', Jh_coef)/=0 ) CALL read_error(2, 'jh_coef')
        IF ( getparam(MODNAME, 'jh_coef_hru', Nhru, 'real', Jh_coef_hru)/=0 ) CALL read_error(2, 'jh_coef_hru')

      ENDIF

      END FUNCTION potet_jh


      SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG,
     $                   Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a symplectic URV (SURV) decomposition of a real
C     2N-by-2N matrix H,
C
C            [ op(A)   G   ]                 [ op(R11)   R12   ]
C        H = [             ] = U R V'  = U * [                 ] * V' ,
C            [  Q    op(B) ]                 [   0     op(R22) ]
C
C     where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real
C     N-by-N upper triangular matrix, op(R22) is a real N-by-N lower
C     Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic
C     matrices. Blocked version.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   CHARACTER*1
C             Specifies the form of op( A ) as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     TRANB   CHARACTER*1
C             Specifies the form of op( B ) as follows:
C             = 'N':  op( B ) = B;
C             = 'T':  op( B ) = B';
C             = 'C':  op( B ) = B'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     ILO     (input) INTEGER
C             It is assumed that op(A) is already upper triangular,
C             op(B) is lower triangular and Q is zero in rows and
C             columns 1:ILO-1. ILO is normally set by a previous call
C             to MB04DD; otherwise it should be set to 1.
C             1 <= ILO <= N+1, if N > 0; ILO = 1, if N = 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the triangular matrix R11, and in the zero part
C             information about the elementary reflectors used to
C             compute the SURV decomposition.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix B.
C             On exit, the leading N-by-N part of this array contains
C             the Hessenberg matrix R22, and in the zero part
C             information about the elementary reflectors used to
C             compute the SURV decomposition.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix G.
C             On exit, the leading N-by-N part of this array contains
C             the matrix R12.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix Q.
C             On exit, the leading N-by-N part of this array contains
C             information about the elementary reflectors used to
C             compute the SURV decomposition.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     CSL     (output) DOUBLE PRECISION array, dimension (2N)
C             On exit, the first 2N elements of this array contain the
C             cosines and sines of the symplectic Givens rotations
C             applied from the left-hand side used to compute the SURV
C             decomposition.
C
C     CSR     (output) DOUBLE PRECISION array, dimension (2N-2)
C             On exit, the first 2N-2 elements of this array contain the
C             cosines and sines of the symplectic Givens rotations
C             applied from the right-hand side used to compute the SURV
C             decomposition.
C
C     TAUL    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, the first N elements of this array contain the
C             scalar factors of some of the elementary reflectors
C             applied form the left-hand side.
C
C     TAUR    (output) DOUBLE PRECISION array, dimension (N-1)
C             On exit, the first N-1 elements of this array contain the
C             scalar factors of some of the elementary reflectors
C             applied form the right-hand side.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK, (16*N + 5)*NB, where NB is the optimal
C             block size determined by the function UE01MD.
C             On exit, if  INFO = -16,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrices U and V are represented as products of symplectic
C     reflectors and Givens rotations
C
C     U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
C         diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
C                              ....
C         diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),
C
C     V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
C         diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
C                                   ....
C         diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ).
C
C     Each HU(i) has the form
C
C           HU(i) = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in
C     Q(i+1:n,i), and tau in Q(i,i).
C
C     Each FU(i) has the form
C
C           FU(i) = I - nu * w * w'
C
C     where nu is a real scalar, and w is a real vector with
C     w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in
C     A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The
C     scalar nu is stored in TAUL(i).
C
C     Each GU(i) is a Givens rotation acting on rows i and n+i,
C     where the cosine is stored in CSL(2*i-1) and the sine in
C     CSL(2*i).
C
C     Each HV(i) has the form
C
C           HV(i) = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
C     Q(i,i+2:n), and tau in Q(i,i+1).
C
C     Each FV(i) has the form
C
C           FV(i) = I - nu * w * w'
C
C     where nu is a real scalar, and w is a real vector with
C     w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
C     B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise.
C     The scalar nu is stored in TAUR(i).
C
C     Each GV(i) is a Givens rotation acting on columns i+1 and n+i+1,
C     where the cosine is stored in CSR(2*i-1) and the sine in
C     CSR(2*i).
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 +
C     ( -16*NB + 48 )*NB*N + O(N) floating point operations, where
C     NB is the used block size, and is numerically backward stable.
C
C     REFERENCES
C
C     [1] Benner, P., Mehrmann, V., and Xu, H.
C         A numerically stable, structure preserving method for
C         computing the eigenvalues of real Hamiltonian or symplectic
C         pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.
C
C     [2] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUB).
C     V. Sima, Aug. 2011, Oct. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Matrix decompositions, Hamiltonian
C     matrix
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANA, TRANB
      INTEGER           ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*),
     $                  G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, LTRA, LTRB
      INTEGER           I, IB, IERR, MINWRK, NB, NBMIN, NH, NIB, NNB,
     $                  NX, PDW, PXA, PXB, PXG, PXQ, PYA, PYB, PYG, PYQ,
     $                  WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           UE01MD
      EXTERNAL          LSAME, UE01MD
C     .. External Subroutines ..
      EXTERNAL          DGEQRF, DGEMM, MB03XU, MB04TS, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' )
      LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' )
C
      MINWRK = MAX( 1, N )
C
      IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN
         INFO = -4
      ELSE IF ( LDA.LT.MINWRK ) THEN
         INFO = -6
      ELSE IF ( LDB.LT.MINWRK ) THEN
         INFO = -8
      ELSE IF ( LDG.LT.MINWRK ) THEN
         INFO = -10
      ELSE IF ( LDQ.LT.MINWRK ) THEN
         INFO = -12
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -18
         ELSE
            IF ( N.EQ.0 ) THEN
               WRKOPT = ONE
            ELSE
               CALL DGEQRF( N, ILO, DWORK, MINWRK, DWORK, DWORK, -1,
     $                      INFO )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
               NB     = INT( WRKOPT/ILO )
               WRKOPT = MAX( WRKOPT, 16*N*NB + 5*NB )
            END IF
            IF ( LQUERY ) THEN
               DWORK(1) = DBLE( WRKOPT )
               RETURN
            END IF
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04TB', -INFO )
         RETURN
      END IF
C
C     Set elements 1:ILO-1 of CSL, CSR, TAUL and TAUR to their default
C     values.
C
      DO 10  I = 1, ILO - 1
         CSL(2*I-1) = ONE
         CSL(2*I)   = ZERO
         CSR(2*I-1) = ONE
         CSR(2*I)   = ZERO
         TAUL(I)    = ZERO
         TAUR(I)    = ZERO
   10 CONTINUE
C
C     Quick return if possible.
C
      NH = N - ILO + 1
      IF ( NH.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Determine the block size.
C
      NBMIN = 2
      IF ( NB.GT.1 .AND. NB.LT.NH ) THEN
C
C        Determine when to cross over from blocked to unblocked code.
C
         NX = MAX( NB, UE01MD( 3, 'MB04TB', TRANA // TRANB, N, ILO, -1 )
     $           )
         IF ( NX.LT.NH ) THEN
C
C           Check whether workspace is large enough for blocked code.
C
            IF ( LDWORK.LT.WRKOPT ) THEN
C
C              Not enough workspace available. Determine minimum value
C              of NB, and reduce NB.
C
               NBMIN = MAX( 2, UE01MD( 2, 'MB04TB', TRANA // TRANB, N,
     $                                 ILO, -1 ) )
               NB = LDWORK / ( 16*N + 5 )
            END IF
         END IF
      END IF
C
      NNB = N*NB
      PYB = 1
      PYQ = PYB + 2*NNB
      PYA = PYQ + 2*NNB
      PYG = PYA + 2*NNB
      PXQ = PYG + 2*NNB
      PXA = PXQ + 2*NNB
      PXG = PXA + 2*NNB
      PXB = PXG + 2*NNB
      PDW = PXB + 2*NNB
C
      IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
C
C        Use unblocked code.
C
         I = ILO
C
      ELSE IF ( LTRA .AND. LTRB ) THEN
         DO 20  I = ILO, N-NX-1, NB
            IB  = MIN( NB, N-I )
            NIB = N*IB
C
C           Reduce rows and columns i:i+nb-1 to symplectic URV form and
C           return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which
C           are needed to update the unreduced parts of the matrices.
C
            CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA,
     $                   B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA),
     $                   N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N,
     $                   DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N,
     $                   DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I),
     $                   TAUR(I), DWORK(PDW) )
C
C           Update the submatrix A(i+1+ib:n,1:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1,
     $                  IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ,
     $                  ONE, A(I+IB+1,I+IB), LDA )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB,
     $                  N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N,
     $                  A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB,
     $                  ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE,
     $                  A(I+IB+1,1), LDA )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N, IB,
     $                  ONE, B(I+IB+1,I), LDB, DWORK(PYA+NIB), N, ONE,
     $                  A(I+IB+1,1), LDA )
C
C           Update the submatrix Q(i+ib:n,i+1+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NB), N,
     $                  Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N,
     $                  B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ )
C
C           Update the matrix G.
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE,
     $                  G(1,I+IB+1), LDG )
            CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE,
     $                  G(1,I+IB+1), LDG )
C
C           Update the submatrix B(1:n,i+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1,
     $                  IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ,
     $                  ONE, B(1,I+IB), LDB )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB+1, IB,
     $                  ONE, DWORK(PXB+NIB), N, A(I,I+IB), LDA, ONE,
     $                  B(1,I+IB), LDB )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1,
     $                  IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N,
     $                  ONE, B(I+IB+1,I+IB), LDB )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1,
     $                  IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N,
     $                  ONE, B(I+IB+1,I+IB), LDB )
   20    CONTINUE
C
      ELSE IF ( LTRA ) THEN
         DO 30  I = ILO, N-NX-1, NB
            IB  = MIN( NB, N-I )
            NIB = N*IB
C
C           Reduce rows and columns i:i+nb-1 to symplectic URV form and
C           return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which
C           are needed to update the unreduced parts of the matrices.
C
            CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA,
     $                   B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA),
     $                   N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N,
     $                   DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N,
     $                   DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I),
     $                   TAUR(I), DWORK(PDW) )
C
C           Update the submatrix A(i+1+ib:n,1:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1,
     $                  IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ,
     $                  ONE, A(I+IB+1,I+IB), LDA )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB,
     $                  N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N,
     $                  A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB,
     $                  ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE,
     $                  A(I+IB+1,1), LDA )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB,
     $                  ONE, B(I,I+IB+1), LDB, DWORK(PYA+NIB), N, ONE,
     $                  A(I+IB+1,1), LDA )
C
C           Update the submatrix Q(i+ib:n,i+1+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NB), N,
     $                  Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N,
     $                  B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ )
C
C           Update the matrix G.
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE,
     $                  G(1,I+IB+1), LDG )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE,
     $                  G(1,I+IB+1), LDG )
C
C           Update the submatrix B(i+ib:n,1:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N,
     $                  ONE, B(I+IB,1), LDB )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, A(I,I+IB), LDA, DWORK(PXB+NIB), N, ONE,
     $                  B(I+IB,1), LDB )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1),
     $                  LDQ, ONE, B(I+IB,I+IB+1), LDB )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N,
     $                  B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB )
   30    CONTINUE
C
      ELSE IF ( LTRB ) THEN
         DO 40  I = ILO, N-NX-1, NB
            IB  = MIN( NB, N-I )
            NIB = N*IB
C
C           Reduce rows and columns i:i+nb-1 to symplectic URV form and
C           return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which
C           are needed to update the unreduced parts of the matrices.
C
            CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA,
     $                   B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA),
     $                   N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N,
     $                   DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N,
     $                   DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I),
     $                   TAUR(I), DWORK(PDW) )
C
C           Update the submatrix A(1:n,i+1+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N,
     $                  ONE, A(I+IB,I+IB+1), LDA )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N,
     $                  ONE, A(I+IB,I+IB+1), LDA )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE,
     $                  A(1,I+IB+1), LDA )
            CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYA+NIB), N, B(I+IB+1,I), LDB, ONE,
     $                  A(1,I+IB+1), LDA )
C
C           Update the submatrix Q(i+ib:n,i+1+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NB), N,
     $                  Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No Transpose', 'Transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N,
     $                  B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ )
C
C           Update the matrix G.
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE,
     $                  G(1,I+IB+1), LDG )
            CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE,
     $                  G(1,I+IB+1), LDG )
C
C           Update the submatrix B(1:n,i+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1,
     $                  IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ,
     $                  ONE, B(1,I+IB), LDB )
            CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, IB,
     $                  ONE, DWORK(PXB+NIB), N, A(I+IB,I), LDA, ONE,
     $                  B(1,I+IB), LDB )
            CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1,
     $                  IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N,
     $                  ONE, B(I+IB+1,I+IB), LDB )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1,
     $                  IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N,
     $                  ONE, B(I+IB+1,I+IB), LDB )
   40    CONTINUE
C
      ELSE
         DO 50  I = ILO, N-NX-1, NB
            IB  = MIN( NB, N-I )
            NIB = N*IB
C
C           Reduce rows and columns i:i+nb-1 to symplectic URV form and
C           return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which
C           are needed to update the unreduced parts of the matrices.
C
            CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA,
     $                   B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA),
     $                   N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N,
     $                   DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N,
     $                   DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I),
     $                   TAUR(I), DWORK(PDW) )
C
C           Update the submatrix A(1:n,i+1+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N,
     $                  ONE, A(I+IB,I+IB+1), LDA )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N,
     $                  ONE, A(I+IB,I+IB+1), LDA )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE,
     $                  A(1,I+IB+1), LDA )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYA+NIB), N, B(I,I+IB+1), LDB, ONE,
     $                  A(1,I+IB+1), LDA )
C
C           Update the submatrix Q(i+ib:n,i+1+ib:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB,
     $                  IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N,
     $                  ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NB), N,
     $                  Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N,
     $                  B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ )
C
C           Update the matrix G.
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE,
     $                  G(I+IB,1), LDG )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE,
     $                  G(1,I+IB+1), LDG )
            CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB,
     $                  ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE,
     $                  G(1,I+IB+1), LDG )
C
C           Update the submatrix B(i+ib:n,1:n).
C
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N,
     $                  IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N,
     $                  ONE, B(I+IB,1), LDB )
            CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB,
     $                  ONE, A(I+IB,I), LDA, DWORK(PXB+NIB), N, ONE,
     $                  B(I+IB,1), LDB )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1),
     $                  LDQ, ONE, B(I+IB,I+IB+1), LDB )
            CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1,
     $                  N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N,
     $                  B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB )
   50    CONTINUE
      END IF
C
C     Unblocked code to reduce the rest of the matrices.
C
      CALL MB04TS( TRANA, TRANB, N, I, A, LDA, B, LDB, G, LDG, Q, LDQ,
     $             CSL, CSR, TAUL, TAUR, DWORK, LDWORK, IERR )
C
      DWORK(1) = DBLE( WRKOPT )
C
      RETURN
C *** Last line of MB04TB ***
      END


! { dg-do run }
! Checks the LOGICAL version of dot_product
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
   logical :: l1(4) = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./)
   logical :: l2(4) = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./)
   if (dot_product (l1, l2)) call abort ()
   l2 = .TRUE.
   if (.not.dot_product (l1, l2)) call abort ()
end


subroutine matmulf128(row,col,inn,x,y,z,alg)
    use ISO_FORTRAN_ENV
    implicit none
    integer, intent(in) :: row, col, inn, alg
    real(kind=REAL128), intent(in) :: x(row,inn),y(inn,col)
    real(kind=REAL128), intent(inout) :: z(row,col)
    integer :: i,j,k
    select case(alg)
        case(1)
            do i=1, row
              do j=1, col
                do k=1, inn
                  z(i,j) = z(i,j) + x(i,k) * y(k,j)
                enddo
              enddo
            enddo
        case(2)
            do j=1, col
              do k=1, inn
                do i=1, row
                  z(i,j) = z(i,j) + x(i,k) * y(k,j)
                enddo
              enddo
            enddo
        case default
            print*,'invalid algorithm: ',alg
    end select
    return
end subroutine matmulf128


Counter         = { get: Unit -> Nat, inc : Unit -> Unit } ;
ResetCounter    = { get: Unit -> Nat, inc : Unit -> Unit, reset: Unit -> Unit };
CounterRep      = { x: Ref Nat};

newCounter          = \a:Unit. let x = ref 1 in
                        {   get     = \a:Unit. !x,
                            inc     = \a:Unit. x:=succ(!x) };

a = newCounter ();
a.inc ();
a.inc ();
a.get ();

counterClass        =   \r:CounterRep.
                        {   get     = \u:Unit. !(r.x),
                            inc     = \u:Unit. r.x := succ(!(r.x)) } ;

newCounter          = \u:Unit. let r = { x = ref 0 } in counterClass r;

c                   = newCounter ();
c.inc();c.inc();
c.get();

resetCounterClass   =   \r:CounterRep.
                        { get   = \u:Unit. !(r.x),
                          inc   = \u:Unit. r.x := succ(!(r.x)),
                          reset = \u:Unit. r.x := 0 } ;

newResetCounter     =   \u:Unit. let r = {x = ref 0 } in resetCounterClass r;

c                   =   newResetCounter ();
c.inc(); c.inc(); c.get(); c.reset(); c.get();

BackupCounter       =   { get : Unit -> Nat, inc : Unit -> Unit, reset : Unit -> Unit, backup : Unit -> Unit };

BackupCounterRep    =   { x : Ref Nat, b : Ref Nat };

backupCounterClass  =   \r:BackupCounterRep.
                        let super = resetCounterClass r in
                        {   get     = super.get,
                            inc     = super.inc,
                            reset   = \u:Unit. r.x := !(r.b),
                            backup  = \u:Unit. r.b := !(r.x)    };

newBackupCounter    =   \u:Unit. let r = { x = ref 0, b = ref 0 } in backupCounterClass r ;

c = newBackupCounter () ;
c.inc () ; c.backup(); c.inc () ; c.inc() ; c.get (); c.reset (); c.get () ;

/* SetCounter */

SetCounter          = { get: Unit->Nat, set: Nat->Unit, inc: Unit->Unit };
setCounterClass     = \r:CounterRep. fix (\self: SetCounter.
                        {   get = \u:Unit. !(r.x),
                            set = \n:Nat. r.x := n,
                            inc = \u:Unit. self.set (succ (self.get unit))      } );

newSetCounter       = \u:Unit. let r = { x = ref 1 } in setCounterClass r ;
c = newSetCounter ();

c.set 10;
c.inc ();
c.get ();

/* SetCounter 2 */
setCounterClass     = \r:CounterRep. \self:SetCounter.
                        {   get = \u:Unit. !(r.x),
                            set = \n:Nat. r.x := n,
                            inc = \u:Unit. self.set (succ (self.get ()))    } ;
newSetCounter       = \u:Unit. let r = { x = ref 0 } in fix (setCounterClass r);

c = newSetCounter ();
c.set 10;
c.inc ();
c.get ();

InstrCounter        = { get : Unit -> Nat, set : Nat -> Unit, inc : Unit->Unit, accesses : Unit -> Nat } ;
InstrCounterRep     = { x : Ref Nat, a: Ref Nat } ;
instrCounterClass   = \r:InstrCounterRep. \self:InstrCounter.
                        let super = setCounterClass r self in
                        {   get = super.get,
                            set = \n:Nat. (r.a := succ(!(r.a)); super.set n),
                            inc = super.inc,
                            accesses = \u:Unit. !(r.a) } ;

newInstrCounter     = \u:Unit. let r = { x = ref 0, a = ref 0 } in fix ( instrCounterClass r );
/*
c = newInstrCounter () ;
c.set 10;
c.inc ();
c.inc 10;
c.accesses ();
*/

/* SetCounter 3 - InstrCounter Can Work with Instances  */
/*
setCounterClass     = \r:CounterRep. \self:Unit -> SetCounter. \u:Unit.
                        {   get = \u:Unit. !(r.x),
                            set = \n:Nat. r.x := n,
                            inc = \u:Unit. (self ()).set (succ ((self ()).get ()))    } ;
newSetCounter       = \u:Unit. let r = { x = ref 0 } in fix (setCounterClass r) () ;

c = newSetCounter ();
c.set 10;
c.inc ();
c.get ();

InstrCounter        = { get : Unit -> Nat, set : Nat -> Unit, inc : Unit->Unit, accesses : Unit -> Nat } ;
InstrCounterRep     = { x : Ref Nat, a: Ref Nat } ;
instrCounterClass   = \r:InstrCounterRep. \self:Unit -> InstrCounter. \u:Unit.
                        let super = setCounterClass r self () in
                        {   get = super.get,
                            set = \n:Nat. (r.a := succ(!(r.a)); super.set n),
                            inc = super.inc,
                            accesses = \u:Unit. !(r.a) } ;

newInstrCounter     = \u:Unit. let r = { x = ref 0, a = ref 0 } in fix ( instrCounterClass r ) ();
c = newInstrCounter () ;
c.set 10;
c.inc ();
c.inc ();
c.accesses ();
*/

/* SetCounter 4 - Efficient SetCounter */

setCounterClass     = \r:CounterRep. \self: Source SetCounter.
                        {   get = \u:Unit. !(r.x),
                            set = \n:Nat. r.x := n,
                            inc = \u:Unit. (! self).set (succ ((! self).get ()))  } ;
dummySetCounter     = { get = \u:Unit. 0, set = \n:Nat. (), inc = \u:Unit. () } ;
newSetCounter       = \u:Unit.
                        let r = { x = ref 1 } in
                        let cAux = ref dummySetCounter in
                        (cAux := (setCounterClass r cAux); !cAux);

InstrCounter        = { get : Unit -> Nat, set : Nat -> Unit, inc : Unit->Unit, accesses : Unit -> Nat } ;
InstrCounterRep     = { x : Ref Nat, a: Ref Nat } ;
instrCounterClass   = \r:InstrCounterRep. \self: Source InstrCounter.
                        let super = setCounterClass r self in
                        {   get = super.get,
                            set = (\n:Nat. ((r.a := succ(!(r.a))) ; super.set n)),
                            inc = super.inc,
                            accesses = \u:Unit. !(r.a)  } ;

dummyInstrCounter   = { get = \u:Unit. 0, set = \n:Nat. (), inc = \u:Unit.(), accesses = \u:Unit.0 } ;
newInstrCounter     = \u:Unit.
                        let r = { x = ref 1, a = ref 0 } in
                        let cAux = ref dummyInstrCounter in
                        (cAux := (instrCounterClass r cAux); !cAux);

c                   = newInstrCounter ();
c.inc ();

(((\x:Nat.(x))) 1);


!
! ej8d.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program orbitmap2

use precision, pr => dp

implicit none
integer, parameter      :: N = 2000, K = 2500
integer                 :: i, j, t
real(pr)                :: xt, xt_1, x0, r_0, r_f, r, dr
character(len=4)        :: rj

open(unit=10, file='ej8d_2.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#  t   xt   r"

r_0 = 3.847_pr
r_f = 3.856_pr
dr = (r_f - r_0)/real(K, pr)
x0 = 0.6_pr

do j = 1, K
    t = 0
    r = r_0 + dr * j
    xt_1 = x0
    !write(10, *) t + i, x0, r
    do i = 1, N
        xt = r * xt_1 * (1._pr - xt_1)
        if (i > 300) then
            write(10, *) t + i, xt, r
        end if
        xt_1 = xt
    end do

end do

close(10)
end program orbitmap2


*DECK TRED1
      SUBROUTINE TRED1 (NM, N, A, D, E, E2)
C***BEGIN PROLOGUE  TRED1
C***PURPOSE  Reduce a real symmetric matrix to symmetric tridiagonal
C            matrix using orthogonal similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B1
C***TYPE      SINGLE PRECISION (TRED1-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRED1,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine reduces a REAL SYMMETRIC matrix
C     to a symmetric tridiagonal matrix using
C     orthogonal similarity transformations.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the real symmetric input matrix.  Only the lower
C          triangle of the matrix need be supplied.  A is a two-
C          dimensional REAL array, dimensioned A(NM,N).
C
C     On Output
C
C        A contains information about the orthogonal transformations
C          used in the reduction in its strict lower triangle.  The
C          full upper triangle of A is unaltered.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is set
C          to zero.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2 may coincide with E if the squares are not needed.
C          E2 is a one-dimensional REAL array, dimensioned E2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  TRED1
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,*),D(*),E(*),E2(*)
      REAL F,G,H,SCALE
C
C***FIRST EXECUTABLE STATEMENT  TRED1
      DO 100 I = 1, N
  100 D(I) = A(I,I)
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 1) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(A(I,K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
  130    E(I) = 0.0E0
         E2(I) = 0.0E0
         GO TO 290
C
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.0E0
C
         DO 240 J = 1, L
            G = 0.0E0
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
C     .......... FORM ELEMENT OF P ..........
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
C
         H = F / (H + H)
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
C
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
C
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
C
      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2011-2016 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>
!! @brief Test program
!!
program main
	use Grid_
	use RNFunction_
	use CNFunction_

	implicit none
	character(255) :: fileNameA
	character(255) :: fileNameB
	integer :: argc
	character(255) :: snorm
	logical :: norm

	integer :: fileTypeA, fileTypeB
	type(RNFunction) :: rFuncA, rFuncB
	type(CNFunction) :: cFuncA, cFuncB
	type(Grid) :: xGrid
	real(8) :: rOverlap
	complex(8) :: cOverlap

	argc = command_argument_count()

	if( argc < 2 ) then
		write(*,*) "usage:"
		write(*,*) "   n1df.innerProduct fileA fileB norm"
		stop
	end if

	call get_command_argument( 1, fileNameA )
	call get_command_argument( 2, fileNameB )
	call get_command_argument( 3, snorm )

	norm = .false.
	if( argc > 2 ) then
		read(snorm,*) norm
	end if

	fileTypeA = RNFunction_checkTypeN1DF( fileNameA )
	fileTypeB = RNFunction_checkTypeN1DF( fileNameB )

	if( fileTypeA == 0 .and. fileTypeB == 0 ) then

		call rFuncA.init( fileNameA )
		call rFuncB.init( fileNameB )

		rFuncB = rFuncB.interpolate( rFuncA.xGrid )

		rOverlap = rFuncA.innerProduct( rFuncB )

		write(*,*) rOverlap

	else if( fileTypeA == 1 .and. fileTypeB == 1 ) then

		call cFuncA.init( fileNameA )
		call cFuncB.init( fileNameB )

		cFuncB = cFuncB.interpolate( cFuncA.xGrid )

		cOverlap = cFuncA.innerProduct( cFuncB )

		if( norm ) then
			write(*,*) abs( cOverlap )
		else
			write(*,*) cOverlap
		end if

	else
		write(0,*) "### ERROR ### reading type of file "//trim(fileNameA)//" and "//trim(fileNameB)
		stop
	end if

end program main


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   tim :    A test problem for timing AUTO
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      INTEGER NDIM2,I,I1,I2
      DOUBLE PRECISION E
      DOUBLE PRECISION, EXTERNAL :: FEXP

       NDIM2=NDIM/2
       DO I=1,NDIM2
         I1=2*(I-1)+1
         I2=I1+1
         E=FEXP(U(I1))
         F(I1)=U(I2)
         F(I2)=-PAR(1)*E
       ENDDO

      END SUBROUTINE FUNC
!----------------------------------------------------------------------

      DOUBLE PRECISION FUNCTION FEXP(U)
!     ------ --------- -------- ----

      DOUBLE PRECISION, INTENT(IN) :: U

      INTEGER NTERMS,K
      DOUBLE PRECISION TRM

       NTERMS=25
       FEXP=1.d0
       TRM=FEXP
       DO K=1,NTERMS
        TRM=TRM*U/K
        FEXP=FEXP + TRM
       ENDDO

      END FUNCTION FEXP
!----------------------------------------------------------------------

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      INTEGER I

      DO I=1,NDIM
        U(I)=0.0
      ENDDO

      END SUBROUTINE STPNT
!----------------------------------------------------------------------

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

      INTEGER NDIM2,I,I1,I2

       NDIM2=NDIM/2
       DO I=1,NDIM2
         I1=2*(I-1)+1
         I2=I1+1
         FB(I1)=U0(I1)
         FB(I2)=U1(I1)
       ENDDO

      END SUBROUTINE BCND
!----------------------------------------------------------------------

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS
!----------------------------------------------------------------------


module futils_sorting
! Module for sorting arrays.
! From github.com/certik/fortran-utils
! MIT license (included).
!
! Adapted to be self-contained, LKedward Feb. 2020
!
! Based on code written by John E. Pask, LLNL.

use iso_fortran_env, only: dp=>real64
implicit none
private
public sort, sortpairs, argsort

! overload argsort
interface argsort
    module procedure iargsort, rargsort
end interface

! overload sort
interface sort
    module procedure sortNums, sortINums, sortVecs
end interface

! overload sortpairs
interface sortpairs
    module procedure sortNumNumPairs, sortINumCNumPairs, &
                     sortNumVecPairs, sortINumVecPairs, sortNumCVecPairs, &
                     sortNumMatPairs, sortINumMatPairs
end interface

contains

subroutine sortNums(nums)
! sorts array of numbers, nums, from smallest to largest
real(dp), intent(inout):: nums(:)   ! array of numbers
nums = nums(argsort(nums))
end subroutine

subroutine sortINums(nums)
! sorts array of inegers, nums, from smallest to largest
integer, intent(inout):: nums(:)    ! array of numbers
nums = nums(argsort(nums))
end subroutine

subroutine sortVecs(vecs)
! sorts array of vectors, vecs, by length, from smallest to largest
real(dp), intent(inout):: vecs(:,:) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
real(dp) len2(size(vecs,2))         ! array of squares of vector lengths
integer i
do i=1,size(len2)
   len2(i)=dot_product(vecs(:,i),vecs(:,i))
end do
call sortpairs(len2,vecs)
end subroutine

subroutine sortNumNumPairs(nums1, nums2)
! sorts arrays of numbers, nums1 and nums2, according to increasing nums1
real(dp), intent(inout):: nums1(:), nums2(:)  ! arrays of numbers
integer :: a(size(nums1))
if (size(nums1) /= size(nums2)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums1)
nums1 = nums1(a)
nums2 = nums2(a)
end subroutine

subroutine sortINumCNumPairs(nums1, nums2)
! sorts arrays of numbers, nums1 and nums2, according to increasing nums1
integer, intent(inout):: nums1(:)            ! array of integers
complex(dp), intent(inout):: nums2(:)        ! array of complex numbers
integer :: a(size(nums1))
if (size(nums1) /= size(nums2)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums1)
nums1 = nums1(a)
nums2 = nums2(a)
end subroutine

subroutine sortNumVecPairs(nums, vecs)
! sorts arrays of numbers, nums, and vectors, vecs, according to increasing nums
real(dp), intent(inout):: nums(:)   ! array of numbers
real(dp), intent(inout):: vecs(:,:) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
integer :: a(size(nums))
if (size(nums) /= size(vecs,2)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums)
nums = nums(a)
vecs = vecs(:, a)
end subroutine

subroutine sortINumVecPairs(nums, vecs)
! sorts arrays of integers, nums, and vectors, vecs, according to increasing nums
integer, intent(inout):: nums(:)    ! array of numbers
real(dp), intent(inout):: vecs(:,:) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
integer :: a(size(nums))
if (size(nums) /= size(vecs,2)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums)
nums = nums(a)
vecs = vecs(:, a)
end subroutine

subroutine sortNumCVecPairs(nums, vecs)
! sorts arrays of numbers, nums, and complex vectors, vecs, according to increasing nums
real(dp), intent(inout):: nums(:)   ! array of numbers
complex(dp), intent(inout):: vecs(:,:) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
integer :: a(size(nums))
if (size(nums) /= size(vecs,2)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums)
nums = nums(a)
vecs = vecs(:, a)
end subroutine

subroutine sortNumMatPairs(nums, mats)
! sorts arrays of numbers, nums, and matrices, mats, according to increasing nums
real(dp), intent(inout):: nums(:)         ! array of numbers
real(dp), intent(inout):: mats(:,:,:)     ! array of matrices: mats(i,j,n) = (i,j) comp. of nth mat.
integer :: a(size(nums))
if (size(nums) /= size(mats,3)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums)
nums = nums(a)
mats = mats(:, :, a)
end subroutine

subroutine sortINumMatPairs(nums,mats)
! sorts arrays of integers, nums, and matrices, mats, according to increasing nums
integer, intent(inout):: nums(:)          ! array of numbers
real(dp), intent(inout):: mats(:,:,:)     ! array of matrices: mats(i,j,n) = (i,j) comp. of nth mat.
integer :: a(size(nums))
if (size(nums) /= size(mats,3)) then
    call stop_error("arrays must be of same length.")
end if
a = argsort(nums)
nums = nums(a)
mats = mats(:, :, a)
end subroutine

function iargsort(a) result(b)
! Returns the indices that would sort an array.
!
! Arguments
! ---------
!
integer, intent(in):: a(:)    ! array of numbers
integer :: b(size(a))         ! indices into the array 'a' that sort it
!
! Example
! -------
!
! iargsort([10, 9, 8, 7, 6])   ! Returns [5, 4, 3, 2, 1]

integer :: N                           ! number of numbers/vectors
integer :: i,imin                      ! indices: i, i of smallest
integer :: temp                        ! temporary
integer :: a2(size(a))
a2 = a
N=size(a)
do i = 1, N
    b(i) = i
end do
do i = 1, N-1
    ! find ith smallest in 'a'
    imin = minloc(a2(i:),1) + i - 1

    ! swap to position i in 'a' and 'b', if not already there
    if (imin /= i) then
        temp = a2(i); a2(i) = a2(imin); a2(imin) = temp
        temp = b(i); b(i) = b(imin); b(imin) = temp
    end if
end do
end function

function rargsort(a) result(b)
! Returns the indices that would sort an array.
!
! Arguments
! ---------
!
real(dp), intent(in):: a(:)   ! array of numbers
integer :: b(size(a))         ! indices into the array 'a' that sort it
!
! Example
! -------
!
! rargsort([4.1_dp, 2.1_dp, 2.05_dp, -1.5_dp, 4.2_dp]) ! Returns [4, 3, 2, 1, 5]

integer :: N                           ! number of numbers/vectors
integer :: i,imin                      ! indices: i, i of smallest
integer :: temp1                       ! temporary
real(dp) :: temp2
real(dp) :: a2(size(a))
a2 = a
N=size(a)
do i = 1, N
    b(i) = i
end do
do i = 1, N-1
    ! find ith smallest in 'a'
    imin = minloc(a2(i:),1) + i - 1
    ! swap to position i in 'a' and 'b', if not already there
    if (imin /= i) then
        temp2 = a2(i); a2(i) = a2(imin); a2(imin) = temp2
        temp1 = b(i); b(i) = b(imin); b(imin) = temp1
    end if
end do
end function

subroutine stop_error(msg)
! Aborts the program with nonzero exit code
!
! The statement "stop msg" will return 0 exit code when compiled using
! gfortran. stop_error() uses the statement "stop 1" which returns an exit code
! 1 and a print statement to print the message.
!
! Example
! -------
!
! call stop_error("Invalid argument")

character(len=*) :: msg ! Message to print on stdout
write(*,*) " (!) fortran-utils:mod_sorting Error: ",msg
stop 1
end subroutine

end module futils_sorting


      DOUBLE PRECISION FUNCTION DBESJ1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DBESJ1 Krogh  Added external statement.
C>> 1995-11-13 DBESJ1 Krogh  Changed data statment for C converstion.
C>> 1995-11-03 DBESJ1 Krogh  Removed blanks in numbers for C conversion.
C>> 1994-11-11 DBESJ1 Krogh   Declared all vars.
C>> 1994-10-20 DBESJ1 Krogh  Changes to use M77CON
C>> 1992-02-07 DBESJ1 WV Snyder Correct sign for X < 0.
C>> 1990-11-29 DBESJ1 CLL
C>> 1985-08-02 DBESJ1 Lawson  Initial code.
C JUNE 1978 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--D replaces "?": ?BESJ1, ?BMP1, ?INITS, ?CSEVL
c     ------------------------------------------------------------------
      EXTERNAL D1MACH, DCSEVL
      INTEGER NTJ1
      DOUBLE PRECISION X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y,
     1  D1MACH, DCSEVL
C
C SERIES FOR BJ1        ON THE INTERVAL  0.          TO  1.60000D+01
C                                        WITH WEIGHTED ERROR   1.16D-33
C                                         LOG WEIGHTED ERROR  32.93
C                               SIGNIFICANT FIGURES REQUIRED  32.36
C                                    DECIMAL PLACES REQUIRED  33.57
C
      SAVE NTJ1, XSML, XMIN
C
      DATA BJ1CS / -.117261415133327865606240574524003D+0,
     *  -.253615218307906395623030884554698D+0,
     *  +.501270809844695685053656363203743D-1,
     *  -.463151480962508191842619728789772D-2,
     *  +.247996229415914024539124064592364D-3,
     *  -.867894868627882584521246435176416D-5,
     *  +.214293917143793691502766250991292D-6,
     *  -.393609307918317979229322764073061D-8,
     *  +.559118231794688004018248059864032D-10,
     *  -.632761640466139302477695274014880D-12,
     *  +.584099161085724700326945563268266D-14,
     *  -.448253381870125819039135059199999D-16,
     *  +.290538449262502466306018688000000D-18,
     *  -.161173219784144165412118186666666D-20,
     *  +.773947881939274637298346666666666D-23,
     *  -.324869378211199841143466666666666D-25,
     *  +.120223767722741022720000000000000D-27,
     *  -.395201221265134933333333333333333D-30,
     *  +.116167808226645333333333333333333D-32 /
C
      DATA NTJ1, XSML, XMIN / 0, 2*0.D0 /
C     ------------------------------------------------------------------
      IF (NTJ1 .eq. 0) then
         call DINITS (BJ1CS, 19, 0.1D0*D1MACH(3), NTJ1)
         XSML = SQRT (4.0D0*D1MACH(3))
         XMIN = 2.0D0*D1MACH(1)
      endif
C
      Y = ABS(X)
C
      IF (Y .LE. XMIN) THEN
        DBESJ1 = 0.D0
      ELSE IF (Y .LE. XSML) THEN
        DBESJ1 = .5D0 * X
      ELSE IF (Y .LE. 4.D0) THEN
        DBESJ1 = X * ( .25D0 + DCSEVL (.125D0*Y*Y-1.D0,BJ1CS, NTJ1) )
      ELSE
        CALL DBMP1 (Y, AMPL, THETA)
        DBESJ1 = AMPL * COS(THETA)
        IF (X .LT. 0.0d0) DBESJ1 = -DBESJ1
      END IF
C
      RETURN
      END