      program Ising2d_equilibrium_f77
      use benchmark_m
      implicit real(8) (a-h,o-z)
      parameter(nx=51, ny=50, N=nx*ny, noff=nx, nall=N+2*noff)
      parameter(ilb=-noff+1, irb=ilb+nall)
      parameter(nkbt=50, dkbt_beg=2.6d0, dkbt_end=2.0d0)
      parameter(mcs_relx=500000, mcs_smpl=500000)
      dimension Ising(ilb:irb)
      dimension exparr(-8:8)
      dimension dkbts(nkbt), dmagne(nkbt), energy(nkbt)
      dimension rnd(N)
      type(benchmark_t) :: bm
      write(6, '(a,i0)'     ) "# N = ", N
      write(6, '(a,i0)'     ) "# MCS(relaxation) = ", mcs_relx
      write(6, '(a,i0)'     ) "# MCS(sampling)   = ", mcs_smpl
      write(0, '(3(a, i0))' ) "nx", nx, " ny", ny
      write(0, '(a, f30.18)') "method: METROPOLIS"
      bm = benchmark_t()
c initialize dkbts, Ising, energy, dmagne.
      do i = 1, nkbt
         dkbts(i) =
     &        ( (nkbt-1-i+1)*dkbt_beg
     &        + (i-1)       *dkbt_end ) / (nkbt-1) ! internal division point.
      end do
      call random_number(rnd)
      do i = 1, N
         if (rnd(i) .lt. 0.5d0) then
            Ising(i) = +1
         else
            Ising(i) = -1
         end if
c$$$         print '(i5, a, i0)', i, ": ", Ising(i)
      end do
      energy = 0.0d0
      dmagne = 0.0d0
c update norishiro.
      do i = 1, noff
         Ising(i-noff) = Ising(i+N-noff)
         Ising(i+N)    = Ising(i)
      end do
c calculate initial magnetization and energy.
      magne   = 0
      ienergy = 0
      do i = 1, N
         magne   = magne   + Ising(i)
         ienergy = ienergy - Ising(i)*(Ising(i+1)+Ising(i+nx))
      end do
c update Ising in each temperatures.
      exparr = 1.0d0
      call bm%stamp("start update")
      do k = 1, nkbt
         dbeta = 1/dkbts(k)
         write(0, '(a, i7, es23.15)') "iterate: ", k, dkbts(k)
c        Initialize exparr.
         do i = 1, 8
            exparr(i) = exp(-dbeta*i)
         end do
c        relax Ising with Metropolis.
         do j = 1, mcs_relx
c           update Ising with checkerboard pattern.
            call random_number(rnd)
            do is = 1, 2
               do i = is, N, 2
                  ide = 2*Ising(i)*
     &                 (Ising(i+1)+Ising(i-1)+Ising(i+nx)+Ising(i-nx))
                  if (rnd(i) .lt. exparr(ide)) then
                     Ising(i) = -Ising(i)
                     magne   = magne   + 2*Ising(i)
                     ienergy = ienergy + ide
                  end if
               end do
c              update norishiro.
               do i = 1, noff
                  Ising(i-noff) = Ising(i+N-noff)
                  Ising(i+N)    = Ising(i)
               end do
            end do
         end do ! end j (1:mcs_relx)
c        relax Ising with Metropolis and calculate parameters.
         dm = 0.0d0
         e  = 0.0d0
         do j = 1, mcs_smpl
c           update Ising with checkerboard pattern.
            call random_number(rnd)
            do is = 1, 2
               do i = is, N, 2
                  ide = 2*Ising(i)*
     &                 (Ising(i+1)+Ising(i-1)+Ising(i+nx)+Ising(i-nx))
                  if (rnd(i) .lt. exparr(ide)) then
                     Ising(i) = -Ising(i)
                     magne   = magne   + 2*Ising(i)
                     ienergy = ienergy + ide
                  end if
               end do
c              update norishiro.
               do i = 1, noff
                  Ising(i-noff) = Ising(i+N-noff)
                  Ising(i+N)    = Ising(i)
               end do
            end do
            dm = dm + abs(1.0d0*magne / N)
            e  = e  +     1.0d0*ienergy / N
         end do ! end j (1:mcs_smpl)
         dmagne(k) = dm / mcs_smpl
         energy(k) = e  / mcs_smpl
      end do ! end k (1:nkbt)
      call bm%stamp("end update")
c print parameters.
      write(6, '(a)') "# temperature, magne, energy"
      do k = 1, nkbt
         write(6, '(i0,a,i0," ",i0," ",*(es20.12))')
     &        nx, "x", ny,
     &        k, dkbts(k), dmagne(k), energy(k)
      end do
      call bm%dump()
      call destroy_benchmark_t(bm)
c print all spins including norishiro
c$$$      do j = 0, ny+1
c$$$         write(0, '(i8, a)', advance="NO") j, ": "
c$$$         do i = 1, nx
c$$$            write(0, '(i3)', advance="NO") Ising((j-1)*nx+i)
c$$$         end do
c$$$         write(0, *)
c$$$      end do
      stop
      end program Ising2d_equilibrium_f77


      subroutine setglonglat(IMAX,JMAX,GLON,GLAT)
!-----------------------------------------------------------------------
      use m_die,only : die
      implicit none
      integer,intent(in) :: IMAX,JMAX
      real,dimension(imax),intent(out) :: GLON
      real,dimension(jmax),intent(out) :: GLAT

      integer :: JHF
      real,dimension(JMAX/2) :: COLRAD,WGT,WGTCS,RCS2
      real :: PI,RDR,DLN
      integer :: LL,LLS,LN

      if(mod(JMAX,2)/=0) call die("setglonglat","mod(JMAX,2)/=0")
      JHF=JMAX/2

      CALL GLATS(JHF,COLRAD,WGT,WGTCS,RCS2)

      PI=ASIN(1.)*2
      RDR=180./PI
C
      DO LL = 1,JHF
      LLS = JMAX+1 - LL
      GLAT(LL)  = 90. - COLRAD(LL)*RDR
      GLAT(LLS) = -GLAT(LL)
      ENDDO
C
      DLN = 360.0/FLOAT(IMAX)
      DO LN = 1,IMAX
      GLON(LN) = (LN-1) * DLN
      ENDDO
      end subroutine setglonglat
	subroutine setglonglat2(IMAX,JMAX,GLON,GLAT)
!-----------------------------------------------------------------------
!-- define 2-d (lon,lat) grid with Gaussian latitudes.
	use m_die,only : die
	implicit none
	integer,intent(in) :: IMAX,JMAX
	real,dimension(IMAX,JMAX),intent(out) :: GLON
	real,dimension(IMAX,JMAX),intent(out) :: GLAT

	integer :: JHF
	real,dimension(JMAX/2) :: COLRAD,WGT,WGTCS,RCS2

        real :: PI,RAD,DLN
	integer :: I,LL,LLS
	integer :: J,LN

	if(mod(JMAX,2)/=0) call die("setglonglat2","mod(JMAX,2)/=0")
	JHF=JMAX/2

      CALL GLATS(JHF,COLRAD,WGT,WGTCS,RCS2)
C
      PI=ASIN(1.)*2
      RAD=PI/180.
C
      DO I = 1,IMAX
      DO LL = 1,JHF
      LLS = JMAX+1 - LL
      GLAT(I,LL)  = 90. - COLRAD(LL)/RAD
      GLAT(I,LLS) = -GLAT(I,LL)
      ENDDO
      ENDDO
C
      DLN = 360.0/FLOAT(IMAX)
      DO J = 1,JMAX
      DO LN = 1,IMAX
      GLON(LN,J) = (LN-1) * DLN
      ENDDO
      ENDDO
      end subroutine setglonglat2
      SUBROUTINE GLATS(LGGHAF,COLRAD,WGT,WGTCS,RCS2)
!-----------------------------------------------------------------------
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    GLATS       COMPUTES LOCATION OF GAUSSIAN LATITUDES.
C   PRGMMR: JOSEPH SELA      ORG: W/NMC23    DATE: 88-04-05
C
C ABSTRACT: COMPUTES THE LOCATION OF THE GAUSSIAN LATITUDES FOR THE
C   INPUT LGGHAF.  THE LATITUDES ARE DETERMINED BY FINDING
C   THE ZEROS OF THE LEGENDRE POLYNOMIALS.
C
C PROGRAM HISTORY LOG:
C   88-04-05  JOSEPH SELA
C
C USAGE:    CALL GLATS (LGGHAF, COLRAD, WGT, WGTCS, RCS2)
C   INPUT ARGUMENT LIST:
C     LGGHAF   - NUMBER OF GAUSSIAN LATITUDES IN A HEMISPHERE.
C
C   OUTPUT ARGUMENT LIST:
C     COLRAD   - ARRAY OF COLATITUDE OF GAUSSIAN LATITUDES
C                IN NORTHERN HEMISPHERE.
C     WGT      - ARRAY OF WEIGHTS AT EACH GAUSSIAN LATITUDE
C                REQUIRED FOR GAUSSIAN QUADRATURE.
C     WGTCS    - ARRAY OF GAUSSIAN WEIGHT/SIN OF COLATITUDE SQUARED.
C     RCS2     - ARRAY OF RECIPROCAL  OF  SIN OF COLATITUDE SQUARED.
C
C   OUTPUT FILES:
C     OUTPUT   - PRINTOUT FILE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 200.
C   MACHINE:  CYBER 205.
C
C$$$
CCCC  HALF PRECISION COLRAD,WGT,WGTCS,RCS2
      REAL COLRAD(LGGHAF),WGT(LGGHAF),WGTCS(LGGHAF)
      REAL RCS2(LGGHAF)
      EPS=1.E-12
C     PRINT 101
C101  FORMAT ('0 I   COLAT   COLRAD     WGT', 12X, 'WGTCS',
CCCC 1 10X, 'ITER  RES')
      SI = 1.0
      L2=2*LGGHAF
      RL2=L2
      SCALE = 2.0/(RL2*RL2)
      K1=L2-1
      PI = ATAN(SI)*4.E+00
      DRADZ = PI / 360.
      RAD = 0.0
      DO 1000 K=1,LGGHAF
      ITER=0
      DRAD=DRADZ
1     CALL POLY(L2,RAD,P2)
2     P1 =P2
      ITER=ITER+1
      RAD=RAD+DRAD
      CALL POLY(L2,RAD,P2)
      IF(SIGN(SI,P1).EQ.SIGN(SI,P2)) GO TO 2
      IF(DRAD.LT.EPS)GO TO 3
      RAD=RAD-DRAD
      DRAD = DRAD * 0.25
      GO TO 1
3     CONTINUE
      COLRAD(K)=RAD
      PHI = RAD * 180 / PI
      CALL POLY(K1,RAD,P1)
      X = COS(RAD)
      W = SCALE * (1.0 - X*X)/ (P1*P1)
      WGT(K) = W
      SN = SIN(RAD)
      W=W/(SN*SN)
      WGTCS(K) = W
      RC=1./(SN*SN)
      RCS2(K) = RC
      CALL POLY(L2,RAD,P1)
C     PRINT 102,K,PHI,COLRAD(K),WGT(K),WGTCS(K),ITER,P1
C102  FORMAT(1H ,I2,2X,F6.2,2X,F10.7,2X,E13.7,2X,E13.7,2X,I4,2X,D13.7)
1000  CONTINUE
      RETURN
      END SUBROUTINE GLATS
      SUBROUTINE POLY(N,RAD,P)
!-----------------------------------------------------------------------
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    POLY        EVALUATES LEGENDRE POLYNOMIAL.
C   PRGMMR: JOSEPH SELA      ORG: W/NMC23    DATE: 88-04-01
C
C ABSTRACT: EVALUATES THE UNNORMALIZED LEGENDRE POLYNOMIAL
C   OF SPECIFIED DEGREE AT A GIVEN COLATITUDE USING A STANDARD
C   RECURSION FORMULA.  REAL ARITHMETIC IS USED.
C
C PROGRAM HISTORY LOG:
C   88-04-01  JOSEPH SELA
C
C USAGE:    CALL POLY (N, RAD, P)
C   INPUT ARGUMENT LIST:
C     N        - DEGREE OF LEGENDRE POLYNOMIAL.
C     RAD      - REAL COLATITUDE IN RADIANS.
C
C   OUTPUT ARGUMENT LIST:
C     P        - REAL VALUE OF LEGENDRE POLYNOMIAL.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 200.
C   MACHINE:  CYBER 205.
C
C$$$
      X = COS(RAD)
      Y1 = 1.0
      Y2=X
      DO 1 I=2,N
      G=X*Y2
      Y3=G-Y1+G-(G-Y1)/FLOAT(I)
      Y1=Y2
      Y2=Y3
1     CONTINUE
      P=Y3
      RETURN
      END SUBROUTINE POLY
      subroutine maxmin(a,len,k,k1,k2,ch)
!-----------------------------------------------------------------------
      dimension a(len,k)
      character ch*(*)
c
cccc cmic$ do all
cccc cmic$1 shared(a,ch,len,k1,k2)
cccc cmic$1 private(aamax,aamin,m)
      do 100 j=k1,k2
      aamax = a(1,j)
      aamin = a(1,j)
      do 10 m=1,len
      aamax = max( aamax, a(m,j) )
      aamin = min( aamin, a(m,j) )
10    continue
C      print   *,ch,' has max=',aamax,' min=',aamin
100   continue
      return
      end subroutine maxmin
      SUBROUTINE WRIT1(IRX,JRX,DIN,NWT1,NWRT1,MTV2,NST,IUT,HDAT)
      !!PARAMETER (IRX=41,JRX=41,NST=10)
      implicit none
      integer,intent(in) :: IRX,JRX
      REAL,intent(in) :: DIN(IRX,JRX)
      integer,intent(inout) :: NWT1,NWRT1
      integer,intent(in) :: MTV2,NST,IUT
      real,intent(out) :: HDAT(IRX,JRX,MTV2,NST)

      integer :: I,J
      NWRT1=NWRT1+1
      NWT1=NWT1+1
c      PRINT*,'WRIT1 COUNT = ',NWRT1,NWT1,IUT
      DO J=1,JRX
      DO I=1,IRX
        HDAT(I,J,NWRT1,IUT)=DIN(I,J)
      END DO
      END DO
      END SUBROUTINE WRIT1
      SUBROUTINE READ1(IUT,NRED1,MTV3,DOUT,PDAT)
      PARAMETER (IRX=41,JRX=41)
      REAL DOUT(IRX,JRX),PDAT(IRX,JRX,MTV3)
      NRED1=NRED1+1
c      PRINT*,'READ1 COUNT = ',NRED1
      DO J=1,JRX
      DO I=1,IRX
        DOUT(I,J)=PDAT(I,J,NRED1)
      END DO
      END DO
      END SUBROUTINE READ1
      SUBROUTINE WRIT2(IMAX,JMAX,NWRT2,MTV,DIN,HDATA)
      REAL DIN(IMAX,JMAX),HDATA(IMAX,JMAX,MTV)
      NWRT2=NWRT2+1
c      PRINT*,'WRIT2 COUNT = ',NWRT2
c      call maxmin(DIN,IMAX*JMAX,1,1,1,'DIN in gbl')
      DO J=1,JMAX
      DO I=1,IMAX
        HDATA(I,J,NWRT2)=DIN(I,J)
      END DO
      END DO
      END SUBROUTINE WRIT2
      SUBROUTINE READ2(IMAX,JMAX,NRED2,MTV,DOUT,HDATA)
      REAL DOUT(IMAX,JMAX),HDATA(IMAX,JMAX,MTV)
      NRED2=NRED2+1
c      PRINT*,'READ2 COUNT = ',NRED2
      DO J=1,JMAX
      DO I=1,IMAX
        DOUT(I,J)=HDATA(I,J,NRED2)
      END DO
      END DO
      END SUBROUTINE READ2
      SUBROUTINE FIND_NEWCT(UD,VD)
      PARAMETER (IR=15,IT=24,IX=41,JX=41,ID=7,JD=7)
      DIMENSION TNMX(ID,JD),UD(IX,JX),VD(IX,JX)
      DIMENSION WTM(IR),R0(IT)

	! intent(in) :: ix,jx
	! intent(in) :: ud(ix,jx),vd(ix,jx)
	! intent(in) :: ir,it
      	! intent(in) :: slon,slat,clon,clat
	! intent(inout) :: clon_new,clat_new
	! unused :: r0(it), xvect(it), yvect(it)
	! remove :: common/POSIT/,common/vect/
	! integer,parameter,local :: id=7,jd=7
	! local :: wnmx(id,jd),wtm(ir)

      COMMON /POSIT/CLON_NEW,CLAT_NEW,SLON,SLAT,CLON,CLAT,RAD
      COMMON /vect/R0,XVECT(IT),YVECT(IT)
C
      PI=ASIN(1.)*2.
      RAD=PI/180.
C
      XLAT = CLAT-3.
      XLON = CLON-3.
c      print *,'STARTING LAT, LON AT FIND NEW CENTER ',XLAT,XLON
C
      DO I=1,ID
      DO J=1,JD
      TNMX(I,J) = 0.
      BLON = XLON + (I-1)
      BLAT = XLAT + (J-1)
C
C.. CALCULATE TANGENTIAL WIND EVERY 1 deg INTERVAL
C..  7*7 deg AROUND 1ST 1ST GUESS VORTEX CENTER
C
      DO 10 JL=1,IR
      WTS= 0.
      DO 20 IL=1,IT
      DR = JL
      DD = (IL-1)*15*RAD
      DLON = DR*COS(DD)
      DLAT = DR*SIN(DD)
      TLON = BLON + DLON
      TLAT = BLAT + DLAT
C.. INTERPOLATION U, V AT TLON,TLAT AND CLACULATE TANGENTIAL WIND
      IDX = IFIX(TLON) - SLON + 1
      IDY = IFIX(TLAT) - SLAT + 1
      DXX  = TLON - IFIX(TLON)
      DYY  = TLAT - IFIX(TLAT)
C
      X1 = UD(IDX  ,IDY+1)*DYY + UD(IDX  ,IDY)*(1-DYY)
      X2 = UD(IDX+1,IDY+1)*DYY + UD(IDX+1,IDY)*(1-DYY)
      Y1 = UD(IDX+1,IDY  )*DXX + UD(IDX,IDY  )*(1-DXX)
      Y2 = UD(IDX+1,IDY+1)*DXX + UD(IDX,IDY+1)*(1-DXX)
      UT = (X1*(1-DXX)+X2*DXX + Y1*(1-DYY)+Y2*DYY)/2.
      IF(IL.EQ.0.OR.IL.EQ.13) UT = Y1
      IF(IL.EQ.7.OR.IL.EQ.19) UT = X1
C
      X1 = VD(IDX  ,IDY+1)*DYY + VD(IDX  ,IDY)*(1-DYY)
      X2 = VD(IDX+1,IDY+1)*DYY + VD(IDX+1,IDY)*(1-DYY)
      Y1 = VD(IDX+1,IDY  )*DXX + VD(IDX,IDY  )*(1-DXX)
      Y2 = VD(IDX+1,IDY+1)*DXX + VD(IDX,IDY+1)*(1-DXX)
      VT = (X1*(1-DXX)+X2*DXX + Y1*(1-DYY)+Y2*DYY)/2.
      IF(IL.EQ.0.OR.IL.EQ.13) VT = Y1
      IF(IL.EQ.7.OR.IL.EQ.19) VT = X1
C.. TANGENTIAL WIND
      WT = -SIN(DD)*UT + COS(DD)*VT
      WTS = WTS+WT
20    CONTINUE
      WTM(JL) = WTS/24.
10    CONTINUE
C
C Southern Hemisphere
      IF(CLAT_NEW.LT.0)THEN
        DO JL=1,IR
          WTM(JL)=-WTM(JL)
        END DO
      END IF
C EnD SH

      TX = -10000000.
      DO KL = 1,IR
      IF(WTM(KL).GE.TX) THEN
      TX = WTM(KL)
      ENDIF
      ENDDO
C
      TNMX(I,J) = TX
      ENDDO
      ENDDO
C.. FIND NEW CENTER
      TTX = -1000000.
      DO I=1,ID
      DO J=1,JD
      IF(TNMX(I,J).GE.TTX) THEN
      TTX = TNMX(I,J)
      NIC = I
      NJC = J
      ENDIF
      ENDDO
      ENDDO
C
      CLAT_NEW = XLAT + (NJC-1)
      CLON_NEW = XLON + (NIC-1)
C
      print *,'NEW CENTER,  I, J IS   ',NIC,NJC
      print *,'NEW CENTER, LAT,LON IS ',CLAT_NEW,CLON_NEW
      print *,'MAX TAN. WIND AT NEW CENTER IS ',TTX
C
      RETURN
      END SUBROUTINE FIND_NEWCT
      SUBROUTINE TWIND(UD,VD,TW)
C
      PARAMETER (IX=41,JX=41,NF=11,IT=24,IR=120)
      DIMENSION UD(IX,JX),VD(IX,JX),TW(IT,IR),R0(IT)
      COMMON /POSIT/CLON_NEW,CLAT_NEW,SLON,SLAT,CLON,CLAT,RAD
      COMMON /vect/R0,XVECT(IT),YVECT(IT)
c      COMMON /CT/SLON,SLAT,CLON,CLAT,RAD
c      COMMON /GA/CLON_NEW,CLAT_NEW,R0
C
      DO J=1,IR
      DO I=1,IT
C.. DETERMINE LAT, LON AREOUND CIRCLE
      DR = 0.1*J
      DD = (I-1)*15.*RAD
      DLON = DR*COS(DD)
      DLAT = DR*SIN(DD)
      TLON = CLON_NEW + DLON
      TLAT = CLAT_NEW + DLAT
C.. INTERPOLATION U, V AT TLON,TLAT AND CLACULATE TANGENTIAL WIND
      IDX = IFIX(TLON) - SLON + 1
      IDY = IFIX(TLAT) - SLAT + 1
      DXX  = TLON - IFIX(TLON)
      DYY  = TLAT - IFIX(TLAT)
C
      X1 = UD(IDX  ,IDY+1)*DYY + UD(IDX  ,IDY)*(1-DYY)
      X2 = UD(IDX+1,IDY+1)*DYY + UD(IDX+1,IDY)*(1-DYY)
      Y1 = UD(IDX+1,IDY  )*DXX + UD(IDX,IDY  )*(1-DXX)
      Y2 = UD(IDX+1,IDY+1)*DXX + UD(IDX,IDY+1)*(1-DXX)
      UT = (X1*(1-DXX)+X2*DXX + Y1*(1-DYY)+Y2*DYY)/2.
      IF(I.EQ.0.OR.I.EQ.13) UT = Y1
      IF(I.EQ.7.OR.I.EQ.19) UT = X1
C
      X1 = VD(IDX  ,IDY+1)*DYY + VD(IDX  ,IDY)*(1-DYY)
      X2 = VD(IDX+1,IDY+1)*DYY + VD(IDX+1,IDY)*(1-DYY)
      Y1 = VD(IDX+1,IDY  )*DXX + VD(IDX,IDY  )*(1-DXX)
      Y2 = VD(IDX+1,IDY+1)*DXX + VD(IDX,IDY+1)*(1-DXX)
      VT = (X1*(1-DXX)+X2*DXX + Y1*(1-DYY)+Y2*DYY)/2.
      IF(I.EQ.0.OR.I.EQ.13) VT = Y1
      IF(I.EQ.7.OR.I.EQ.19) VT = X1
C.. TANGENTIAL WIND
      TW(I,J) = -SIN(DD)*UT + COS(DD)*VT
C
      ENDDO
      ENDDO
C SH
      IF(CLAT_NEW.LT.0)THEN
        DO J=1,IR
        DO I=1,IT
          TW(I,J)=-TW(I,J)
        ENDDO
        ENDDO
      END IF
C End SH
C
      RETURN
      END SUBROUTINE TWIND
      SUBROUTINE STRT_PT(RMX,TW,RFAVG)
C
      PARAMETER (IX=41,JX=41,NF=11,IT=24,IR=120)
      DIMENSION TW(IT,IR),TWM(IR),TMXX(IT),RMX(IT)
      REAL JMX
C
      DO I=1,IR
      TWM(I) = 0.
      ENDDO
C
C.. CALCULATE MEAN TANGENTIAL WIND
C
      DO 10 J=1,IR
      TM=0.
      DO 20 I=1,IT
      TM = TM + TW(I,J)
20    CONTINUE
      TWM(J) = TM/24.
c      print *,'MEAN TANGENTIAL WIND ',J,TWM(J)
10    CONTINUE
C
C.. FIND MAXIMUM TANGENTIAL WIND RADIUS
C
      TMX=-100000000000.
      DO J=1,IR
      IF(TWM(J).GE.TMX) THEN
      TMX=TWM(J)
      JMX = J*0.1
      ENDIF
      ENDDO
C
      print *,'MAXIMUM TANGENTIAL WIND RADIUS ',JMX
      JJ=IFIX(JMX*10.)
      print *,'MAXIMUM TANGENTIAL WIND SPEED  ',TWM(JJ)
C
      JXX = 15 * JMX
c      print *,'JXX, 15*JMX is ',JXX
C
      ICK = 1
      CNT = 0.000004
c      print *,'CNT  ',CNT
C
      DO 30 K=JXX,IR-1
      IF(TWM(K).GE.6..OR.TWM(K).LT.3.) GO TO 30
      DXX = 10000.
      DV = TWM(K) - TWM(K+1)
      DVDR = DV/DXX
      IF(DVDR.LT.CNT) ICK = ICK+1
      IF(ICK.EQ.3) THEN
      RF=K*0.1
      GO TO 40
      ENDIF
30    CONTINUE
C
40    CONTINUE
      IF(ICK.NE.3) THEN
      DO IK=JXX,120
      IF(TWM(IK).LE.3) THEN
      RF = IK*0.1
      ICK=3
      GO TO 50
      ENDIF
      ENDDO
      ENDIF
C
50    CONTINUE
      IF(ICK.NE.3) RF = 12.
C
      RFAVG = RF
c
C.. CALCULATE Ra, Rb..  REF. KURIHARA ET AL. 1995
C
      RA = IFIX((0.5 * JMX)*10.)/10.
      RB = IFIX((0.75 * JMX + 0.25 * RF)*10.)/10.
      IRA = IFIX(RA*10.+0.5)
      IRB = IFIX(RB*10.+0.5)
C
c      print *,'Ra, Rb, Rf  ', RA,RB,RF
C
C.. DETERMINE STARTING POINT FOR EVERY 24 DIRECTION
C
      DO I=1,IT
      TMXX(I) = -100000000.
      DO J=1,IR
      IF(TW(I,J).GE.TMXX(I)) THEN
      TMXX(I) = TW(I,J)
      RMX(I) = J*0.1*1.1
      ENDIF
      ENDDO
      ENDDO
C
c      DO I=1,IT
c      print *,'I, MX TANGENTIAL WIND RADIUS ',I,RMX(I),TMXX(I)
c      ENDDO
C
      DO I=1,IT
      IF (RMX(I).GT.RB.OR.RMX(I).LT.RA) THEN
      TMX = -10000000.
      DO KK=IRA,IRB
      IF(TW(I,KK).GE.TMX) RM = KK * 0.1 * 1.1
      ENDDO
      MR = IFIX(RM*10. + 0.5)
      ICL=0
      DO LL = MR,IRB
      IF(TW(I,LL).LT.0.) ICL=ICL+1
      ENDDO
      IF(ICL.EQ.0) RMX(I) = RM*1.1
      ENDIF
      ENDDO
C
c      DO I=1,IT
c      print *,'I, RST ',I,RMX(I)
c      ENDDO
C
      RETURN
      END SUBROUTINE STRT_PT
      SUBROUTINE FILTER(RS,TW,RF,RFAVG)
      PARAMETER (IX=41,JX=41,IT=24,IR=120)
C
      DIMENSION RS(IT),TW(IT,IR),RF(IT),R0(IT),IST(IT)
      COMMON /vect/R0,XVECT(IT),YVECT(IT)
c      COMMON /GA/CLON_NEW,CLAT_NEW,R0
C
      ICK = 1
      CNT = 0.000004
c      print *,'CNT  ',CNT
C
      DO I=1,IT
      IST(I) = IFIX(RS(I)*10)
c      print *,'STARTING POINT ',I,IST(I)
      ENDDO
C
      DO 100 I=1,IT
      IS = IST(I)
C
      DO 30 K=IS,IR-1
      IF(TW(I,K).GE.6..OR.TW(I,K).LT.3.) GO TO 30
      DXX = 10000.
      DV = TW(I,K) - TW(I,K+1)
      DVDR = DV/DXX
      IF(DVDR.LT.CNT) THEN
      ICK = ICK+1
      ENDIF
      IF(ICK.EQ.3) THEN
      RF(I)=K*0.1 + 0.0000001
c      print *,'1st Catagory ',I
      GO TO 100
      ENDIF
30    CONTINUE
C
40    CONTINUE
      DO IK=IS,IR
      IF(TW(I,IK).LE.3) THEN
      RF(I) = IK*0.1 + 0.00000001
c      print *,'2nd Catagory ',I
      GO TO 100
      ENDIF
      ENDDO
C
50    CONTINUE
c      print *,'3rd Catagory ',I
      RF(I) = 12.
100   CONTINUE
C
c      RMAX=0.
      DO I=1,IT
      R0(I) = 1.25 * RF(I)
!! NEW
      IF(R0(I).LT.2.0)R0(I)=2.0
c      IF(RMAX.LT.R0(I))RMAX=R0(I)
c      print *,'R0,Rf AT EACH DIRECTION ',I,R0(I),RF(I)
      ENDDO
C test for circular domain
c      DO I=1,IT
c         R0(I)=RMAX
cc        R0(I) = RFAVG*1.25
c      print *,'R0,Rf AT EACH DIRECTION ',I,R0(I),RF(I)
c      ENDDO
C
      RETURN
      END SUBROUTINE FILTER
      SUBROUTINE GMOVE(KST,KSTM,
     1		  KMAX,IGU,JGU,MTV,GLON,GLAT,HDATA,PSLB,ZDATG,
     1            IX,JX,ALON,ALAT,DM1,
     2		  IB,ING,JNG,MDX,MDY,AMDX,AMDY, IV,IS1,IFLAG)

      use m_die,only : die
      use m_vtxgrid, only: vtxgrid_lonModulo
! (index,count) of all storm grids
      integer,intent(in) :: KST,KSTM	! they should be removed later
      					! along with ZDATG/T1/PSLB and
					! SPL2SP().

! grid attributes of the background state
      integer,intent(in) :: KMAX,IGU,JGU,MTV
      real,dimension(IGU,JGU),intent(in) :: GLON,GLAT
      REAL,dimension(IGU,JGU,MTV),intent(inout) :: HDATA
      REAL,dimension(IGU,JGU),intent(inout) :: PSLB
      REAL,dimension(IGU,JGU),intent(in) :: ZDATG

      integer,intent(in) :: IX,JX
      real,intent(in) :: ALAT(JX),ALON(IX)
      real,intent(in) :: DM1(IX,JX)

! grid mapping information for a given storm grid
      integer,intent(in) :: IB
      integer,dimension(IB),intent(in) :: ING,JNG
      integer,intent(in) :: MDX,MDY
      real,intent(in) :: AMDX,AMDY

      	! Additional control flags
      integer,intent(in) :: IV,IS1,IFLAG

! Local variables
      DIMENSION DMM(IX,JX),DATG(IGU,JGU),DDAT(IGU,JGU)
      DIMENSION T1(IGU,JGU),PSL(IGU,JGU)

      COMMON /HDAT3/NWRT2,NRED2	! pointers of HDATA's put() and get().

      DIMENSION DATG2(IGU,JGU)

      real:: HLO,HLA
      integer,parameter:: RK=kind(HLO)

C
C.. SETTING BASIC VARIABLES FOR INTERPOLATING GAUSSIAN GRID
C
!!	print'(1x,a,8i6)','GMOVE(): ',
!!     &		KST,IV,IS1,IFLAG,NRED2+1,NWRT2+1

      ISE = IS1
      DO I=1,IX
      DO J=1,JX
      DMM(I,J) = DM1(I,J)
      ENDDO
      ENDDO
C
C.. INTERPOLATE TO GAUSSIAN GRID
C
      CALL READ2(IGU,JGU,NRED2,MTV,DATG,HDATA)
      	!!?? DATG(:,:)=HDATA(:,:,NRED2++)
c
      DO I=1,IGU
      DO J=1,JGU
        DATG2(I,J)=DATG(I,J)
        DDAT(I,J)=0.
      ENDDO
      ENDDO
C
      RDIST2=AMDX*AMDX+AMDY*AMDY
      IF(RDIST2.GT.0.02)THEN
cc test
      DO I = 1,IB
      IW = ING(I)
      JW = JNG(I)

c      DO IW = 1, IGU
c      DO JW = 1, JGU
      HLA = GLAT(IW,JW)

        ! Bi-linearly interpolate a field DMM defined on grid (ALON,ALAT),
        ! to scattered locations (HLO,HLA) of DATG on grid (GLON,GLAT).

        ! First, if HLO is out of the range of ALON(1:IX), adjust it to one
        ! of its periodic (n*360, for n=...,-3,-2,-1,0,1,2,3,...) values,
        ! such that it falls inside the range [ALON(1), ALON(1)+360.).

      HLO = GLON(IW,JW)
        ! This is, HLO=ALON(1)+modulo(HLO-ALON(1),360.).  Condition
        ! HLO>ALON(IX) is used instead of HLO>=ALON(1)+360., because there
        ! is a possibility of HLO, being out of the range [ALON(1),ALON(IX)].
      if(HLO<ALON(1).or.HLO>ALON(IX)) HLO=vtxgrid_lonModulo(HLO,reflon=ALON(1))

C
      LX=-2
      LY=-2
      DO II=1,IX-1
       IF( (II==1.and.HLO==ALON(II)) .or.
     &     (HLO.GT.ALON(II).and.HLO.LE.ALON(II+1)) )THEN
!       IF( (HLO.GT.ALON(II).and.HLO.LE.ALON(II+1)) )THEN
        LX=II
        LY=-1
        DO JJ=1,JX-1
        IF( (JJ==1.and.HLA==ALAT(JJ)) .or.
     &      (HLA.GT.ALAT(JJ).and.HLA.LE.ALAT(JJ+1)) )THEN
!        IF( (HLA.GT.ALAT(JJ).and.HLA.LE.ALAT(JJ+1)) )THEN
         LX=II
         LY=JJ

         DXX = HLO-ALON(LX)
         DYY = HLA-ALAT(LY)
C
         X1 = DMM(LX  ,LY+1)*DYY + DMM(LX  ,LY  )*(1-DYY)
         X2 = DMM(LX+1,LY+1)*DYY + DMM(LX+1,LY  )*(1-DYY)
         Y1 = DMM(LX+1,LY  )*DXX + DMM(LX  ,LY  )*(1-DXX)
         Y2 = DMM(LX+1,LY+1)*DXX + DMM(LX  ,LY+1)*(1-DXX)
         DATG(IW,JW)=(X1*(1-DXX)+X2*DXX + Y1*(1-DYY)+Y2*DYY)/2.

         IF(ISE.GE.2) DDAT(IW,JW)=DATG2(IW,JW)-DATG(IW,JW)
         GO TO 555

        END IF
        END DO
       END IF
      END DO
      if(LX<0.or.LY<0) then
      	write(6,'(a,2i4  )') 'GMOVE() >>> ERROR <<< unlocated LHS (H) grid point, IW,JW =',IW,JW
      	write(6,'(a,2i4  )') 'GMOVE() >>> ERROR <<<  indexed RHS (A) location at, LX,LY =',LX,LY
      	write(6,'(a,3f8.2)') 'GMOVE() >>> ERROR <<<              HLO, ALON(1), ALON(IX) =',HLO,ALON(1),ALON(IX)
      	write(6,'(a,3f8.2)') 'GMOVE() >>> ERROR <<<              HLA, ALAT(1), ALAT(JX) =',HLA,ALAT(1),ALAT(JX)
        call die("GMOVE()")
      endif
 555   CONTINUE
c      ENDDO
c      ENDDO
      ENDDO
      END IF
c end test

      IF(ISE.EQ.1) THEN
c
c        READ(70) PSL
        PSL=PSLB

        DO I = 1,IB
          IW = ING(I)
          JW = JNG(I)
          DDAT(IW,JW)=PSL(IW,JW)-DATG(IW,JW)
          PSL(IW,JW)=DATG(IW,JW)
        END DO
c
c Move vortex

cc        DO I = 1,IB
cc          IW = ING(I)
cc          JW = JNG(I)
cc          IWX=IW+MDX
cc          JWY=JW+MDY
cc          IF(IWX.GT.IGU)IWX=IWX-IGU
cc          IF(IWX.LT.1)IWX=IWX+IGU
CQLIUC
cc          PSL(IWX,JWY) = PSL(IWX,JWY)+DDAT(IW,JW)
cc        ENDDO

        CALL MOVETX(IGU,JGU,GLON,GLAT,PSL,DDAT,
     &    IB,ING,JNG,MDX,MDY,AMDX,AMDY)

        PSLB = PSL

!!!        CALL WRIT2(IGU,JGU,NWRT2,MTV,PSL,HDATA)
	NWRT2=NWRT2+1
c
      ELSEIF(ISE.EQ.2) THEN
cyc   REWIND 36
cyc   READ(36) PSL
       PSL = PSLB
       IF(IFLAG.EQ.1)THEN
        DO I=1,IGU
        DO J=1,JGU
         T1(I,J) = DATG2(I,J)
        ENDDO
        ENDDO
       ELSE
        DO I=1,IGU
        DO J=1,JGU
         T1(I,J) = DATG(I,J)
        ENDDO
        ENDDO
       END IF
        IF(KST.EQ.KSTM)THEN
          CALL SLP2SP(IGU,JGU,ZDATG,KUNIT,T1,PSL)
!!	  print*,'PSL(GMOVE/0) = ',exp(minval(PSL)),
!!     &				   exp(maxval(PSL)),NWRT2
	  NWRT2=NWRT2-1		! backup 1 record for PSL output
          CALL WRIT2(IGU,JGU,NWRT2,MTV,PSL,HDATA)
!!	  print*,'PSL(GMOVE/1) = ',exp(minval(HDATA(:,:,2))),
!!     &				   exp(maxval(HDATA(:,:,2)))
        END IF
      END IF

c temperature field
c qliu

      IF(ISE.GE.2.and.ISE.LE.(KMAX+1))then
        IF(IFLAG.EQ.1)THEN
cold          IF(KST.EQ.KSTM) THEN
cql            READ(20)SKIP2
cold            NCNT2 = NCNT2 + 1
cold            WRITE(KUNIT)(SKIP2(NW,NCNT2),NW=1,MAXWV2)
cold          END IF
          CALL WRIT2(IGU,JGU,NWRT2,MTV,DATG2,HDATA)
        ELSE

c Move vortex
cc          DO I = 1,IB
cc            IW = ING(I)
cc            JW = JNG(I)
cc            IWX=IW+MDX
cc            JWY=JW+MDY
cc            IF(IWX.GT.IGU)IWX=IWX-IGU
cc            IF(IWX.LT.1)IWX=IWX+IGU
CQLIUC
cc            DATG(IWX,JWY) = DATG(IWX,JWY)+DDAT(IW,JW)
cc          ENDDO

          CALL MOVETX(IGU,JGU,GLON,GLAT,DATG,DDAT,
     &      IB,ING,JNG,MDX,MDY,AMDX,AMDY)

cnew          IF(KST.EQ.KSTM) THEN
cql            READ(20)SKIP2
cnew            NCNT2 = NCNT2 + 1
cnew            CALL G2SPC(DATG)
cnew          END IF

          CALL WRIT2(IGU,JGU,NWRT2,MTV,DATG,HDATA)

        END IF
      END IF
C
      IF(ISE.GT.(KMAX+1).and.ISE.LE.(3*KMAX+1))THEN
c Move vortex

cc        DO I = 1,IB
cc          IW = ING(I)
cc          JW = JNG(I)
cc          IWX=IW+MDX
cc          JWY=JW+MDY
cc          IF(IWX.GT.IGU)IWX=IWX-IGU
cc          IF(IWX.LT.1)IWX=IWX+IGU
CQLIUC
cc          DATG(IWX,JWY) = DATG(IWX,JWY)+DDAT(IW,JW)
cc        ENDDO

         CALL MOVETX(IGU,JGU,GLON,GLAT,DATG,DDAT,
     &     IB,ING,JNG,MDX,MDY,AMDX,AMDY)
C
cnew        IF(KST.EQ.KSTM) THEN
cnew          CALL G2SPC(DATG)
cnew        END IF

        CALL WRIT2(IGU,JGU,NWRT2,MTV,DATG,HDATA)

      ENDIF

      IF(ISE.GT.(3*KMAX+1))THEN
        IF(IFLAG.EQ.1)THEN
cold          IF(KST.EQ.KSTM) THEN
cold            CALL G2SPC(KUNIT,MWAVE,IGU,JGU,DATG2)
cold          END IF
          CALL WRIT2(IGU,JGU,NWRT2,MTV,DATG2,HDATA)
        ELSE

c Move vortex
cc          DO I = 1,IB
cc            IW = ING(I)
cc            JW = JNG(I)
cc            IWX=IW+MDX
cc            JWY=JW+MDY
cc            IF(IWX.GT.IGU)IWX=IWX-IGU
cc            IF(IWX.LT.1)IWX=IWX+IGU
CQLIUC
cc            DATG(IWX,JWY) = DATG(IWX,JWY)+DDAT(IW,JW)
cc          ENDDO

           CALL MOVETX(IGU,JGU,GLON,GLAT,DATG,DDAT,
     &       IB,ING,JNG,MDX,MDY,AMDX,AMDY)

cnew          IF(KST.EQ.KSTM) THEN
cnew            CALL G2SPC(DATG)
cnew          END IF

          CALL WRIT2(IGU,JGU,NWRT2,MTV,DATG,HDATA)

        END IF
      ENDIF
!!	  print*,'PSL(GMOVE/2) = ',exp(minval(HDATA(:,:,2))),
!!     &				   exp(maxval(HDATA(:,:,2))),NWRT2,ISE

C
      RETURN
      END SUBROUTINE GMOVE
      SUBROUTINE SLP2SP(IGU,JGU,ZDATG,KUNIT,T1,PSL)
c      PARAMETER (IGU=384,JGU=190)
C
      DIMENSION T1(IGU,JGU),PSL(IGU,JGU)
      DIMENSION ZDATG(IGU,JGU)
c      COMMON /TR/ZDATG,GLON,GLAT,ING,JNG,IB
C
C.. MAKE SFC PRESSURE FROM MSLP
C
      G = 9.8
      R = 287.05
      GAMMA = 6.7*0.001
C
      DO JH=1,JGU
      DO IH=1,IGU
      PMSL = ALOG(PSL(IH,JH))
      A = (GAMMA * ZDATG(IH,JH)) / T1(IH,JH)
      B = ALOG(1+A)
      C = (G*B)/(R*GAMMA)
      DD = PMSL - C
      D1 = EXP(DD)/1000.
c      IF (D1.LE.10.) PRINT*,'SP is Less than 100mb at ',IH,JH,D1
      PSL(IH,JH) = ALOG(D1)
      ENDDO
      ENDDO
C
C.. GAUSSIAN GRID TO SPECTRAL COEFFEICENT
C
!!      call maxmin(psl,igu*jgu,1,1,1,'global SLP at SLP after int')
!!      CALL G2SPC(KUNIT,MWAVE,IGU,JGU,PSL)
!!	print*,'PSL(SLP2SP) = ',exp(minval(PSL)),exp(maxval(PSL))

!!      call maxmin(t1,igu*jgu,1,1,1,'global T1 at SLP after int')
c      CALL G2SPC(KUNIT,T1)
C
      RETURN
      END SUBROUTINE SLP2SP
      SUBROUTINE G2SPC(KUNIT,MWAVE,IMAX,JMAX,Q1)
C
c      PARAMETER ( IMAX= 384,JMAX= 190 )
C
      REAL Q1(IMAX,JMAX)

      REAL,   ALLOCATABLE :: DN(:)
      REAL(4),ALLOCATABLE :: WORK_3(:)

      MAXWV2=(MWAVE+1)*(MWAVE+2)
      MAXWV22=MAXWV2+1

      ALLOCATE ( DN(MAXWV22) )
      ALLOCATE ( WORK_3(MAXWV2) )
C
c      call maxmin(dn,MAXWV2,1,1,1,'surface pressure after making')

!!      print*,'specgrid(g2spc), grid_psfc=',sum(Q1)
       call SPTEZ(0,MWAVE,4,IMAX,JMAX,DN,Q1,-1)

      DO I=1,MAXWV2
        WORK_3(I)=DN(I)
      END DO
      WRITE(KUNIT) (WORK_3(NW),NW=1,MAXWV2)
!!      print*,'specgrid(g2spc), spec_psfc=',sum(work_3)

      DEALLOCATE (DN)
      DEALLOCATE (WORK_3)

      RETURN
      END SUBROUTINE G2SPC


PROGRAM TestInterpMat

USE dspline

IMPLICIT NONE

INTEGER :: m,n,j,k,jmin,jmax,jd,r,ir,nc,kloc
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: u,p,tinterp,ui,upi
DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: umat,upmat
DOUBLE PRECISION :: dt,t,tnow,uev,upev,utrue,uptrue,frac,s,erloc,uermax,upermax,tloc

n=500
tnow=17.137d0
dt=tnow/DBLE(n)

r=2157
ALLOCATE(tinterp(r),ui(r),upi(r))
!
DO m=2,12,2
  ALLOCATE(p(0:m))
  DO j=0,m
    CALL RANDOM_NUMBER(p(j))
    p(j)=-1.d0+2.d0*p(j)
  END DO
  PRINT *,m
!
! choose a bunch of points in 3 time steps
!
  DO kloc=0,314,314
!
  tloc=-dt*DBLE(kloc)
!
  DO ir=1,r
    CALL RANDOM_NUMBER(frac)
    tinterp(ir)=tloc-3.d0*dt*frac
  END DO
  CALL InterpMat(r,tinterp,dt,m,jmax,jmin,umat,upmat)
!
! Create data - here we assume that the polynomial is centered at 0
!
  nc=jmax-jmin+1
  ALLOCATE(u(nc))
  DO k=1,nc
    s=dt*DBLE(jmin+k-1)-tloc
    u(k)=p(m)
    DO jd=m-1,0,-1
      u(k)=s*u(k)+p(jd)
    END DO
  END DO
!
!  DO ir=1,r
!  DO k=1,nc
!    PRINT *,ir,k,umat(ir,k),upmat(ir,k)
!  END DO
!  END DO
  CALL dgemv('N',r,nc,1.d0,umat,r,u,1,0.d0,ui,1)
  CALL dgemv('N',r,nc,1.d0,upmat,r,u,1,0.d0,upi,1)
!
  uermax=0.d0
  upermax=0.d0
  DO ir=1,r
    s=tinterp(ir)-tloc
    utrue=p(m)
    uptrue=DBLE(m)*p(m)
    DO jd=m-1,1,-1
      utrue=s*utrue+p(jd)
      uptrue=s*uptrue+DBLE(jd)*p(jd)
    END DO
    utrue=s*utrue+p(0)
    erloc=ABS(ui(ir)-utrue)
    IF (erloc > uermax) THEN
      uermax=erloc
    END IF
    erloc=ABS(upi(ir)-uptrue)
    IF (erloc > upermax) THEN
      upermax=erloc
    END IF
  END DO
!
  PRINT *,kloc,uermax,upermax
  DEALLOCATE(u,umat,upmat)
!
  END DO
!
  DEALLOCATE(p)
END DO

DEALLOCATE(tinterp,ui,upi)

END PROGRAM TestInterpMat


!# Program to find standard deviation
!
! Authour: Ramsha Javed
!
!
PROGRAM ste_dev
IMPLICIT NONE

INTEGER:: steps,ndim
REAL*8,ALLOCATABLE::mean(:),stdev(:)

ndim=2
OPEN(1,file="COLVAR")

ALLOCATE(mean(ndim))
ALLOCATE(stdev(ndim))

CALL get_steps(1,steps)

CALL cal_mean(steps,mean,1,ndim)

CALL standard_dev(1,steps,stdev,mean,ndim)

DEALLOCATE(mean,stdev)

END PROGRAM

SUBROUTINE get_steps(file_number,steps)
IMPLICIT NONE

INTEGER :: file_number, steps, ios

steps=0
DO
 READ(file_number,*,iostat=ios)
 IF(ios.NE.0)EXIT
  steps=steps+1
END DO
REWIND(file_number)
END SUBROUTINE get_steps

SUBROUTINE cal_mean(steps,mean,file_number,ndim)
IMPLICIT NONE

INTEGER::steps,file_number,i,ndim
REAL*8::mean(ndim)
REAL*8:: dummy,cv(ndim)

mean(1:ndim)=0.d0

DO i=1,steps
 READ(file_number,*) dummy,cv(1:ndim)
 mean(1:ndim)=mean(1:ndim)+cv(1:ndim)
END DO

REWIND(file_number)
mean(1:ndim)=mean(1:ndim)/steps
PRINT*,mean(1:ndim)

END SUBROUTINE

SUBROUTINE standard_dev(file_number,steps,stdev,mean,ndim)
IMPLICIT NONE

INTEGER:: i,file_number,steps,ndim
REAL*8:: stdev(ndim),mean(ndim)
REAL*8::cv(ndim),dummy

stdev(1:ndim)=0.d0
DO i=1,steps
 READ(file_number,*) dummy,cv(1:ndim)
 stdev(1:ndim)=stdev(1:ndim)+(cv(1:ndim)-mean(1:ndim))**2
END DO
stdev(1:ndim)=dsqrt(stdev(1:ndim)/steps)
PRINT*,stdev(1:ndim)
END SUBROUTINE


module tridiag

use iso_c_binding, only: c_double, c_int

implicit none

contains

! The expression bind(c) tells the compiler to
! make the naming convention in the object file
! match the naming convention here.
! This will be a subroutine since it does not
! return any values.
subroutine ftridiag(a, b, c, x, n) bind(c)

!   Here we declare the types for the inputs.
!   Thisis where we use the c_double and c_int types.
!   The 'dimension' statement tells the compiler that
!   the argument is an array of the given shape.
    integer(c_int), intent(in) :: n
    real(c_double),dimension(n),intent(in) :: b
    real(c_double),dimension(n),intent(inout) :: x
    real(c_double),dimension(n-1),intent(in) :: a
    real(c_double),dimension(n-1),intent(inout) :: c

!   Two temporary varaibles.
!   'm' is a temporary value.
!   'i' is the index for the loops.
    real(c_double) m
    integer i

!   Here is the actual computation:
    c(1) = c(1) / b(1)
    x(1) = x(1) / b(1)
!   This is the syntax for a 'for' loop in Fortran.
!   Indexing for arrays in fortran starts at 1
!   instead of starting at 0 like it does in Python.
!   Arrays are accessed using parentheses
!   instead of brackets.
    do i = 1,n-2
        m = 1.0D0 / (b(i+1) - a(i) * c(i))
        c(i+1) = c(i+1) * m
        x(i+1) = x(i+1) - a(i) * x(i)
        x(i+1) = x(i+1) * m
!   Note that you have to explicitly end the loop.
    enddo
    x(n) = (x(n) - a(n-1) * x(n-1)) / (b(n) - a(n-1) * c(n-1))
    do i = n-1,1,-1
        x(i) = x(i) - c(i) * x(i+1)
    enddo
!   You must also explicitly end the function or subroutine.
end subroutine ftridiag

end module


!*==scnrm2.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b SCNRM2
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       REAL FUNCTION SCNRM2(N,X,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       COMPLEX X(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SCNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!>    SCNRM2 := sqrt( x**H*x )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is COMPLEX array, dimension (N)
!>         complex vector with N elements
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of X
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  -- This version written on 25-October-1982.
!>     Modified on 14-October-1993 to inline the call to CLASSQ.
!>     Sven Hammarling, Nag Ltd.
!> \endverbatim
!>
!  =====================================================================
      REAL FUNCTION SCNRM2(N,X,Incx)
      IMPLICIT NONE
!*--SCNRM279
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      INTEGER Incx , N
!     ..
!     .. Array Arguments ..
      COMPLEX X(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      REAL norm , scale , ssq , temp
      INTEGER ix
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , AIMAG , REAL , SQRT
!     ..
      IF ( N<1 .OR. Incx<1 ) THEN
         norm = ZERO
      ELSE
         scale = ZERO
         ssq = ONE
!        The following loop is equivalent to this call to the LAPACK
!        auxiliary routine:
!        CALL CLASSQ( N, X, INCX, SCALE, SSQ )
!
         DO ix = 1 , 1 + (N-1)*Incx , Incx
            IF ( REAL(X(ix))/=ZERO ) THEN
               temp = ABS(REAL(X(ix)))
               IF ( scale<temp ) THEN
                  ssq = ONE + ssq*(scale/temp)**2
                  scale = temp
               ELSE
                  ssq = ssq + (temp/scale)**2
               ENDIF
            ENDIF
            IF ( AIMAG(X(ix))/=ZERO ) THEN
               temp = ABS(AIMAG(X(ix)))
               IF ( scale<temp ) THEN
                  ssq = ONE + ssq*(scale/temp)**2
                  scale = temp
               ELSE
                  ssq = ssq + (temp/scale)**2
               ENDIF
            ENDIF
         ENDDO
         norm = scale*SQRT(ssq)
      ENDIF
!
      SCNRM2 = norm
!
!     End of SCNRM2.
!
      END FUNCTION SCNRM2


program BeadSortTest
  use iso_fortran_env
  ! for ERROR_UNIT; to make this a F95 code,
  ! remove prev. line and declare ERROR_UNIT as an
  ! integer parameter matching the unit associated with
  ! standard error

  integer, dimension(7) :: a = (/ 7, 3, 5, 1, 2, 1, 20 /)

  call beadsort(a)
  print *, a

contains

  subroutine beadsort(a)
    integer, dimension(:), intent(inout) :: a

    integer, dimension(maxval(a), maxval(a)) :: t
    integer, dimension(maxval(a)) :: s
    integer :: i, m

    m = maxval(a)

    if ( any(a < 0) ) then
       write(ERROR_UNIT,*) "can't sort"
       return
    end if

    t = 0
    forall(i=1:size(a)) t(i, 1:a(i)) = 1  ! set up abacus
    forall(i=1:m)             ! let beads "fall"; instead of
       s(i) = sum(t(:, i))    ! moving them one by one, we just
       t(:, i) = 0            ! count how many should be at bottom,
       t(1:s(i), i) = 1       ! and then "reset" and set only those
    end forall

    forall(i=1:size(a)) a(i) = sum(t(i,:))

  end subroutine beadsort

end program BeadSortTest


*     MC01XD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NEV
      PARAMETER        ( NEV = 3 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 42 )
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
*     .. Local Scalars ..
      INTEGER          I, INFO, J
      DOUBLE PRECISION ALPHA, BETA, DELTA, GAMMA
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), EVI(NEV), EVQ(NEV), EVR(NEV),
     $                 RT(2)
*     .. External Subroutines ..
      EXTERNAL         MC01XD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) ALPHA, BETA, GAMMA, DELTA
*     Compute the roots of the polynomial.
      CALL MC01XD( ALPHA, BETA, GAMMA, DELTA, EVR, EVI, EVQ,
     $             DWORK, LDWORK, INFO )
*
      IF ( INFO.NE.0 ) THEN
         WRITE ( NOUT, FMT = 99998 ) INFO
      ELSE
         WRITE ( NOUT, FMT = 99995 )
         WRITE ( NOUT, FMT = 99996 ) ( EVR(J), J = 1, 3 )
*
         WRITE ( NOUT, FMT = 99994 )
         WRITE ( NOUT, FMT = 99996 ) ( EVI(J), J = 1, 3 )
*
         WRITE ( NOUT, FMT = 99993 )
         WRITE ( NOUT, FMT = 99996 ) ( EVQ(J), J = 1, 3 )
*
         WRITE ( NOUT, FMT = 99992 )
         DO 20 I = 1, 3
            IF ( EVQ(I).NE.ZERO ) THEN
               RT(1) = EVR(I)/EVQ(I)
               RT(2) = EVI(I)/EVQ(I)
               WRITE ( NOUT, FMT = 99996 ) ( RT(J), J = 1, 2 )
            END IF
   20    CONTINUE
*
      END IF
      STOP
*
99999 FORMAT (' MC01XD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01XD = ',I2)
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (' Real part of the numerators of the roots')
99994 FORMAT (' Imaginary part of the numerators of the roots')
99993 FORMAT (' Denominators of the roots')
99992 FORMAT (' Roots of the polynomial',/1X)
      END


module forlab_linalg

    use stdlib_error, only: error_stop
    use stdlib_kinds, only: sp, dp, qp, &
                            int8, int16, int32, int64
    use forlab_sorting, only: argsort
    use stdlib_optval, only: optval
    implicit none
    private

    public :: is_square, is_symmetric
    public :: zeros, ones, linspace, logspace, seq
    public :: eye
    public :: horzcat, vertcat
    public :: diag, det, lu, matpow, qr, svd, trace, tril, triu, chol, norm, &
              diff
    public :: operator(.i.), operator(.x.), inv, outer, solve, svdsolve

    interface chol
        !! chol computes Cholesky's decomposition of a symmetric positive
        !! definite matrix.
        module function chol_sp(A) result(L)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:, :), allocatable :: L
        end function
        module function chol_dp(A) result(L)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:, :), allocatable :: L
        end function
        !#:for k1,t1 in CMPLX_KINDS_TYPES
        !    module function chol_cdp (A) result(L)
        !        real(dp), dimension(:, :), intent(in) :: A
        !        real(dp), dimension(:, :), allocatable :: L
        !    end function
        !#:endfor
    end interface chol

    interface det
        !! det computes the matrix determinant.
        module function det_sp(A, outL, outU) result(det)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:, :), allocatable, intent(inout), optional :: outL, outU
            real(sp) :: det
        end function det_sp
        module function det_dp(A, outL, outU) result(det)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:, :), allocatable, intent(inout), optional :: outL, outU
            real(dp) :: det
        end function det_dp
    end interface det

    interface diag
        !! diag creates diagonal matrix or get the diagonal of a matrix.
        module function diag1_sp(A) result(diag)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:), allocatable :: diag
        end function diag1_sp
        module function diag2_sp(x) result(diag)
            real(sp), dimension(:), intent(in) :: x
            real(sp), dimension(:, :), allocatable :: diag
        end function diag2_sp
        module function diag1_dp(A) result(diag)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:), allocatable :: diag
        end function diag1_dp
        module function diag2_dp(x) result(diag)
            real(dp), dimension(:), intent(in) :: x
            real(dp), dimension(:, :), allocatable :: diag
        end function diag2_dp
    end interface diag

    !> Version: Experimental
    !>
    !> `diff` computes differences of arrays.
    !> ([Specification](../page/specs/forlab_linalg.html))
    interface diff
        pure module function diff_1_sp(x, n) result(result)
            real(sp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: n
            real(sp), dimension(:), allocatable :: result
        end function diff_1_sp
        pure module function diff_2_sp(A, n, dim) result(result)
            real(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: n, dim
            real(sp), dimension(:, :), allocatable :: result
        end function diff_2_sp
        pure module function diff_1_dp(x, n) result(result)
            real(dp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: n
            real(dp), dimension(:), allocatable :: result
        end function diff_1_dp
        pure module function diff_2_dp(A, n, dim) result(result)
            real(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: n, dim
            real(dp), dimension(:, :), allocatable :: result
        end function diff_2_dp
        pure module function diff_1_int8(x, n) result(result)
            integer(int8), dimension(:), intent(in) :: x
            integer, intent(in), optional :: n
            integer(int8), dimension(:), allocatable :: result
        end function diff_1_int8
        pure module function diff_2_int8(A, n, dim) result(result)
            integer(int8), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: n, dim
            integer(int8), dimension(:, :), allocatable :: result
        end function diff_2_int8
        pure module function diff_1_int16(x, n) result(result)
            integer(int16), dimension(:), intent(in) :: x
            integer, intent(in), optional :: n
            integer(int16), dimension(:), allocatable :: result
        end function diff_1_int16
        pure module function diff_2_int16(A, n, dim) result(result)
            integer(int16), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: n, dim
            integer(int16), dimension(:, :), allocatable :: result
        end function diff_2_int16
        pure module function diff_1_int32(x, n) result(result)
            integer(int32), dimension(:), intent(in) :: x
            integer, intent(in), optional :: n
            integer(int32), dimension(:), allocatable :: result
        end function diff_1_int32
        pure module function diff_2_int32(A, n, dim) result(result)
            integer(int32), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: n, dim
            integer(int32), dimension(:, :), allocatable :: result
        end function diff_2_int32
        pure module function diff_1_int64(x, n) result(result)
            integer(int64), dimension(:), intent(in) :: x
            integer, intent(in), optional :: n
            integer(int64), dimension(:), allocatable :: result
        end function diff_1_int64
        pure module function diff_2_int64(A, n, dim) result(result)
            integer(int64), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: n, dim
            integer(int64), dimension(:, :), allocatable :: result
        end function diff_2_int64
    end interface diff

    interface eig
        !! eig computes eigenvalues and eigenvectors of symmetric matrix using Jacobi algorithm.
        module subroutine eig_sp(A, V, d, itermax)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:, :), allocatable, intent(out) :: V
            real(sp), dimension(:), allocatable, intent(out) :: d
            integer, intent(in), optional :: itermax
        end subroutine eig_sp
        module subroutine eig_dp(A, V, d, itermax)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:, :), allocatable, intent(out) :: V
            real(dp), dimension(:), allocatable, intent(out) :: d
            integer, intent(in), optional :: itermax
        end subroutine eig_dp
    end interface eig

    interface eye
        module subroutine eye_sp(X)
            real(sp), intent(out) :: X(:, :)
        end subroutine eye_sp
        module subroutine eye_dp(X)
            real(dp), intent(out) :: X(:, :)
        end subroutine eye_dp
    end interface eye

    interface horzcat
        module function horzcat_r_1_sp(x1, x2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:), intent(in) :: x1, x2
        end function horzcat_r_1_sp
        module function horzcat_r_2_sp(A1, A2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_r_2_sp
        module function horzcat_r_21_sp(A1, x2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:, :), intent(in) :: A1
            real(sp), dimension(:), intent(in) :: x2
        end function horzcat_r_21_sp
        module function horzcat_r_12_sp(x1, A2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:), intent(in) :: x1
            real(sp), dimension(:, :), intent(in) :: A2
        end function horzcat_r_12_sp
        module function horzcat_r_1_dp(x1, x2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:), intent(in) :: x1, x2
        end function horzcat_r_1_dp
        module function horzcat_r_2_dp(A1, A2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_r_2_dp
        module function horzcat_r_21_dp(A1, x2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:, :), intent(in) :: A1
            real(dp), dimension(:), intent(in) :: x2
        end function horzcat_r_21_dp
        module function horzcat_r_12_dp(x1, A2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:), intent(in) :: x1
            real(dp), dimension(:, :), intent(in) :: A2
        end function horzcat_r_12_dp
        module function horzcat_c_1_sp(x1, x2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:), intent(in) :: x1, x2
        end function horzcat_c_1_sp
        module function horzcat_c_2_sp(A1, A2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_c_2_sp
        module function horzcat_c_21_sp(A1, x2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:, :), intent(in) :: A1
            complex(sp), dimension(:), intent(in) :: x2
        end function horzcat_c_21_sp
        module function horzcat_c_12_sp(x1, A2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:), intent(in) :: x1
            complex(sp), dimension(:, :), intent(in) :: A2
        end function horzcat_c_12_sp
        module function horzcat_c_1_dp(x1, x2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:), intent(in) :: x1, x2
        end function horzcat_c_1_dp
        module function horzcat_c_2_dp(A1, A2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_c_2_dp
        module function horzcat_c_21_dp(A1, x2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:, :), intent(in) :: A1
            complex(dp), dimension(:), intent(in) :: x2
        end function horzcat_c_21_dp
        module function horzcat_c_12_dp(x1, A2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:), intent(in) :: x1
            complex(dp), dimension(:, :), intent(in) :: A2
        end function horzcat_c_12_dp
        module function horzcat_i_1_int8(x1, x2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:), intent(in) :: x1, x2
        end function horzcat_i_1_int8
        module function horzcat_i_2_int8(A1, A2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_i_2_int8
        module function horzcat_i_21_int8(A1, x2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:, :), intent(in) :: A1
            integer(int8), dimension(:), intent(in) :: x2
        end function horzcat_i_21_int8
        module function horzcat_i_12_int8(x1, A2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:), intent(in) :: x1
            integer(int8), dimension(:, :), intent(in) :: A2
        end function horzcat_i_12_int8
        module function horzcat_i_1_int16(x1, x2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:), intent(in) :: x1, x2
        end function horzcat_i_1_int16
        module function horzcat_i_2_int16(A1, A2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_i_2_int16
        module function horzcat_i_21_int16(A1, x2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:, :), intent(in) :: A1
            integer(int16), dimension(:), intent(in) :: x2
        end function horzcat_i_21_int16
        module function horzcat_i_12_int16(x1, A2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:), intent(in) :: x1
            integer(int16), dimension(:, :), intent(in) :: A2
        end function horzcat_i_12_int16
        module function horzcat_i_1_int32(x1, x2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:), intent(in) :: x1, x2
        end function horzcat_i_1_int32
        module function horzcat_i_2_int32(A1, A2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_i_2_int32
        module function horzcat_i_21_int32(A1, x2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:, :), intent(in) :: A1
            integer(int32), dimension(:), intent(in) :: x2
        end function horzcat_i_21_int32
        module function horzcat_i_12_int32(x1, A2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:), intent(in) :: x1
            integer(int32), dimension(:, :), intent(in) :: A2
        end function horzcat_i_12_int32
        module function horzcat_i_1_int64(x1, x2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:), intent(in) :: x1, x2
        end function horzcat_i_1_int64
        module function horzcat_i_2_int64(A1, A2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:, :), intent(in) :: A1, A2
        end function horzcat_i_2_int64
        module function horzcat_i_21_int64(A1, x2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:, :), intent(in) :: A1
            integer(int64), dimension(:), intent(in) :: x2
        end function horzcat_i_21_int64
        module function horzcat_i_12_int64(x1, A2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:), intent(in) :: x1
            integer(int64), dimension(:, :), intent(in) :: A2
        end function horzcat_i_12_int64
    end interface horzcat
    interface vertcat
        module function vertcat_r_1_sp(x1, x2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:), intent(in) :: x1, x2
        end function vertcat_r_1_sp
        module function vertcat_r_2_sp(A1, A2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_r_2_sp
        module function vertcat_r_21_sp(A1, x2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:, :), intent(in) :: A1
            real(sp), dimension(:), intent(in) :: x2
        end function vertcat_r_21_sp
        module function vertcat_r_12_sp(x1, A2) result(result)
            real(sp), dimension(:, :), allocatable :: result
            real(sp), dimension(:), intent(in) :: x1
            real(sp), dimension(:, :), intent(in) :: A2
        end function vertcat_r_12_sp
        module function vertcat_r_1_dp(x1, x2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:), intent(in) :: x1, x2
        end function vertcat_r_1_dp
        module function vertcat_r_2_dp(A1, A2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_r_2_dp
        module function vertcat_r_21_dp(A1, x2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:, :), intent(in) :: A1
            real(dp), dimension(:), intent(in) :: x2
        end function vertcat_r_21_dp
        module function vertcat_r_12_dp(x1, A2) result(result)
            real(dp), dimension(:, :), allocatable :: result
            real(dp), dimension(:), intent(in) :: x1
            real(dp), dimension(:, :), intent(in) :: A2
        end function vertcat_r_12_dp
        module function vertcat_c_1_sp(x1, x2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:), intent(in) :: x1, x2
        end function vertcat_c_1_sp
        module function vertcat_c_2_sp(A1, A2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_c_2_sp
        module function vertcat_c_21_sp(A1, x2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:, :), intent(in) :: A1
            complex(sp), dimension(:), intent(in) :: x2
        end function vertcat_c_21_sp
        module function vertcat_c_12_sp(x1, A2) result(result)
            complex(sp), dimension(:, :), allocatable :: result
            complex(sp), dimension(:), intent(in) :: x1
            complex(sp), dimension(:, :), intent(in) :: A2
        end function vertcat_c_12_sp
        module function vertcat_c_1_dp(x1, x2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:), intent(in) :: x1, x2
        end function vertcat_c_1_dp
        module function vertcat_c_2_dp(A1, A2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_c_2_dp
        module function vertcat_c_21_dp(A1, x2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:, :), intent(in) :: A1
            complex(dp), dimension(:), intent(in) :: x2
        end function vertcat_c_21_dp
        module function vertcat_c_12_dp(x1, A2) result(result)
            complex(dp), dimension(:, :), allocatable :: result
            complex(dp), dimension(:), intent(in) :: x1
            complex(dp), dimension(:, :), intent(in) :: A2
        end function vertcat_c_12_dp
        module function vertcat_i_1_int8(x1, x2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:), intent(in) :: x1, x2
        end function vertcat_i_1_int8
        module function vertcat_i_2_int8(A1, A2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_i_2_int8
        module function vertcat_i_21_int8(A1, x2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:, :), intent(in) :: A1
            integer(int8), dimension(:), intent(in) :: x2
        end function vertcat_i_21_int8
        module function vertcat_i_12_int8(x1, A2) result(result)
            integer(int8), dimension(:, :), allocatable :: result
            integer(int8), dimension(:), intent(in) :: x1
            integer(int8), dimension(:, :), intent(in) :: A2
        end function vertcat_i_12_int8
        module function vertcat_i_1_int16(x1, x2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:), intent(in) :: x1, x2
        end function vertcat_i_1_int16
        module function vertcat_i_2_int16(A1, A2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_i_2_int16
        module function vertcat_i_21_int16(A1, x2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:, :), intent(in) :: A1
            integer(int16), dimension(:), intent(in) :: x2
        end function vertcat_i_21_int16
        module function vertcat_i_12_int16(x1, A2) result(result)
            integer(int16), dimension(:, :), allocatable :: result
            integer(int16), dimension(:), intent(in) :: x1
            integer(int16), dimension(:, :), intent(in) :: A2
        end function vertcat_i_12_int16
        module function vertcat_i_1_int32(x1, x2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:), intent(in) :: x1, x2
        end function vertcat_i_1_int32
        module function vertcat_i_2_int32(A1, A2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_i_2_int32
        module function vertcat_i_21_int32(A1, x2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:, :), intent(in) :: A1
            integer(int32), dimension(:), intent(in) :: x2
        end function vertcat_i_21_int32
        module function vertcat_i_12_int32(x1, A2) result(result)
            integer(int32), dimension(:, :), allocatable :: result
            integer(int32), dimension(:), intent(in) :: x1
            integer(int32), dimension(:, :), intent(in) :: A2
        end function vertcat_i_12_int32
        module function vertcat_i_1_int64(x1, x2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:), intent(in) :: x1, x2
        end function vertcat_i_1_int64
        module function vertcat_i_2_int64(A1, A2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:, :), intent(in) :: A1, A2
        end function vertcat_i_2_int64
        module function vertcat_i_21_int64(A1, x2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:, :), intent(in) :: A1
            integer(int64), dimension(:), intent(in) :: x2
        end function vertcat_i_21_int64
        module function vertcat_i_12_int64(x1, A2) result(result)
            integer(int64), dimension(:, :), allocatable :: result
            integer(int64), dimension(:), intent(in) :: x1
            integer(int64), dimension(:, :), intent(in) :: A2
        end function vertcat_i_12_int64
    end interface vertcat

    interface inv
        module function inv_rsp(A) result(inv)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:, :), allocatable :: inv
        end function inv_rsp
        module function inv_rdp(A) result(inv)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:, :), allocatable :: inv
        end function inv_rdp
        module function inv_csp(A) result(inv)
            complex(sp), dimension(:, :), intent(in) :: A
            complex(sp), dimension(:, :), allocatable :: inv
        end function inv_csp
        module function inv_cdp(A) result(inv)
            complex(dp), dimension(:, :), intent(in) :: A
            complex(dp), dimension(:, :), allocatable :: inv
        end function inv_cdp
    end interface inv

    interface is_square
        procedure :: is_square_rsp
        procedure :: is_square_rdp
        procedure :: is_square_csp
        procedure :: is_square_cdp
    end interface is_square

    interface is_symmetric
        procedure :: is_symmetric_rsp
        procedure :: is_symmetric_rdp
        procedure :: is_symmetric_csp
        procedure :: is_symmetric_cdp
    end interface is_symmetric

    interface linspace
        pure module subroutine linspace_sp(X, from, to)
            real(sp), intent(out) :: X(:)
            real(sp), intent(in) :: from, to
        end subroutine linspace_sp
        pure module subroutine linspace_dp(X, from, to)
            real(dp), intent(out) :: X(:)
            real(dp), intent(in) :: from, to
        end subroutine linspace_dp
    end interface linspace
    interface logspace
        pure module subroutine logspace_sp(X, from, to)
            real(sp), intent(out) :: X(:)
            real(sp), intent(in) :: from, to
        end subroutine logspace_sp
        pure module subroutine logspace_dp(X, from, to)
            real(dp), intent(out) :: X(:)
            real(dp), intent(in) :: from, to
        end subroutine logspace_dp
    end interface logspace

    interface lu
        !! lu computes the LU matrix factorization.
        module subroutine lu_sp(A, L, U)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:, :), allocatable, intent(out) :: L, U
        end subroutine lu_sp
        module subroutine lu_dp(A, L, U)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:, :), allocatable, intent(out) :: L, U
        end subroutine lu_dp
    end interface lu

    interface matpow
        !! Calculat matrix power
        module function matpow_sp(a, num) result(c)
            real(sp), dimension(:, :), intent(in) :: a
            real(sp), allocatable :: c(:, :)
            integer::num
        end function matpow_sp
        module function matpow_dp(a, num) result(c)
            real(dp), dimension(:, :), intent(in) :: a
            real(dp), allocatable :: c(:, :)
            integer::num
        end function matpow_dp
    end interface matpow

    interface norm
        !! norm computes vector and matrix norms.
        real(sp) module function norm1_sp(x, p)
            real(sp), dimension(:), intent(in) :: x
            real(sp), intent(in), optional :: p
        end function norm1_sp
        real(sp) module function norm2_sp(A, p)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), intent(in), optional :: p
        end function norm2_sp
        real(dp) module function norm1_dp(x, p)
            real(dp), dimension(:), intent(in) :: x
            real(dp), intent(in), optional :: p
        end function norm1_dp
        real(dp) module function norm2_dp(A, p)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), intent(in), optional :: p
        end function norm2_dp
    end interface norm

    interface operator(.i.)
        !! Calculate the inverse of a real matrix.
        procedure inv_rsp
        procedure inv_rdp
        procedure inv_csp
        procedure inv_cdp
    end interface operator(.i.)

    interface operator(.x.)
        procedure :: rmut_sp
        procedure :: rmut_dp
        procedure :: cmut_sp
        procedure :: cmut_dp
        procedure :: rcmut_sp
        procedure :: rcmut_dp
        procedure :: crmut_sp
        procedure :: crmut_dp
    end interface operator(.x.)

    !> Version: experimental
    !>
    !> Creates a rank-1 or rank-2 array filled ones.
    !> ([Specification](../page/specs/forlab_linalg.html#zerosones))
    interface ones
        procedure :: ones_1_default
        procedure :: ones_2_default
    end interface ones

    interface outer
        module function outer_int8(x, y)
            integer(int8), dimension(:, :), allocatable :: outer_int8
            integer(int8), dimension(:), intent(in) :: x, y
        end function
        module function outer_int16(x, y)
            integer(int16), dimension(:, :), allocatable :: outer_int16
            integer(int16), dimension(:), intent(in) :: x, y
        end function
        module function outer_int32(x, y)
            integer(int32), dimension(:, :), allocatable :: outer_int32
            integer(int32), dimension(:), intent(in) :: x, y
        end function
        module function outer_int64(x, y)
            integer(int64), dimension(:, :), allocatable :: outer_int64
            integer(int64), dimension(:), intent(in) :: x, y
        end function
        module function outer_sp(x, y)
            real(sp), dimension(:, :), allocatable :: outer_sp
            real(sp), dimension(:), intent(in) :: x, y
        end function
        module function outer_dp(x, y)
            real(dp), dimension(:, :), allocatable :: outer_dp
            real(dp), dimension(:), intent(in) :: x, y
        end function
    end interface outer

    interface qr
        module subroutine qr_sp(a, q, r, l)
            real(sp), intent(in)::a(:, :)
            real(sp), allocatable, intent(out) :: q(:, :), r(:, :)
            integer, optional::l
        end subroutine qr_sp
        module subroutine qr_dp(a, q, r, l)
            real(dp), intent(in)::a(:, :)
            real(dp), allocatable, intent(out) :: q(:, :), r(:, :)
            integer, optional::l
        end subroutine qr_dp
    end interface qr

    interface seq
        !! seq returns evenly spaced vector.
        module subroutine seq_sp(X, from, to, by)
            real(sp), dimension(:), allocatable, intent(out) :: X
            real(sp), intent(in) :: from, to
            real(sp), optional, intent(in) :: by
        end subroutine seq_sp
        module subroutine seq_dp(X, from, to, by)
            real(dp), dimension(:), allocatable, intent(out) :: X
            real(dp), intent(in) :: from, to
            real(dp), optional, intent(in) :: by
        end subroutine seq_dp
        module subroutine seq_int8(X, from, to, by)
            integer(int8), dimension(:), allocatable, intent(out) :: X
            integer(int8), intent(in) :: from, to
            integer(int8), optional, intent(in) :: by
        end subroutine seq_int8
        module subroutine seq_int16(X, from, to, by)
            integer(int16), dimension(:), allocatable, intent(out) :: X
            integer(int16), intent(in) :: from, to
            integer(int16), optional, intent(in) :: by
        end subroutine seq_int16
        module subroutine seq_int32(X, from, to, by)
            integer(int32), dimension(:), allocatable, intent(out) :: X
            integer(int32), intent(in) :: from, to
            integer(int32), optional, intent(in) :: by
        end subroutine seq_int32
        module subroutine seq_int64(X, from, to, by)
            integer(int64), dimension(:), allocatable, intent(out) :: X
            integer(int64), intent(in) :: from, to
            integer(int64), optional, intent(in) :: by
        end subroutine seq_int64
    end interface seq

    interface solve
        module function solve_sp(A, b) result(x)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:), intent(in) :: b
            real(sp), dimension(:), allocatable :: x
        end function solve_sp
        module function solve_dp(A, b) result(x)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:), intent(in) :: b
            real(dp), dimension(:), allocatable :: x
        end function solve_dp
    end interface solve

    interface svd
        module subroutine svd_sp(a, w, u, v, d, ierr)
            real(sp), dimension(:, :), intent(in) :: a
            real(sp), dimension(:), allocatable, intent(out) :: w
            real(sp), dimension(:, :), allocatable, intent(out), optional :: u, v
            integer, intent(out), optional :: ierr
            logical, intent(in), optional ::d
        end subroutine svd_sp
        module subroutine svd_dp(a, w, u, v, d, ierr)
            real(dp), dimension(:, :), intent(in) :: a
            real(dp), dimension(:), allocatable, intent(out) :: w
            real(dp), dimension(:, :), allocatable, intent(out), optional :: u, v
            integer, intent(out), optional :: ierr
            logical, intent(in), optional ::d
        end subroutine svd_dp
    end interface svd

    interface svdsolve
        module function svdsolve_sp(A, b, cutoff) result(x)
            real(sp), dimension(:, :), intent(in) :: A
            real(sp), dimension(:), intent(in) :: b
            real(sp), dimension(:), allocatable :: x
            integer, intent(in), optional :: cutoff
        end function svdsolve_sp
        module function svdsolve_dp(A, b, cutoff) result(x)
            real(dp), dimension(:, :), intent(in) :: A
            real(dp), dimension(:), intent(in) :: b
            real(dp), dimension(:), allocatable :: x
            integer, intent(in), optional :: cutoff
        end function svdsolve_dp
    end interface svdsolve

    interface trace
        procedure :: trace_sp
        procedure :: trace_dp
    end interface trace

    interface tril
        module function tril_int8(A, k)
            integer(int8), dimension(:, :), allocatable :: tril_int8
            integer(int8), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_int8
        module function tril_int16(A, k)
            integer(int16), dimension(:, :), allocatable :: tril_int16
            integer(int16), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_int16
        module function tril_int32(A, k)
            integer(int32), dimension(:, :), allocatable :: tril_int32
            integer(int32), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_int32
        module function tril_int64(A, k)
            integer(int64), dimension(:, :), allocatable :: tril_int64
            integer(int64), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_int64
        module function tril_sp(A, k)
            real(sp), dimension(:, :), allocatable :: tril_sp
            real(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_sp
        module function tril_dp(A, k)
            real(dp), dimension(:, :), allocatable :: tril_dp
            real(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_dp
        module function tril_csp(A, k)
            complex(sp), dimension(:, :), allocatable :: tril_csp
            complex(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_csp
        module function tril_cdp(A, k)
            complex(dp), dimension(:, :), allocatable :: tril_cdp
            complex(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function tril_cdp
    end interface tril

    interface triu
        module function triu_int8(A, k)
            integer(int8), dimension(:, :), allocatable :: triu_int8
            integer(int8), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_int8
        module function triu_int16(A, k)
            integer(int16), dimension(:, :), allocatable :: triu_int16
            integer(int16), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_int16
        module function triu_int32(A, k)
            integer(int32), dimension(:, :), allocatable :: triu_int32
            integer(int32), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_int32
        module function triu_int64(A, k)
            integer(int64), dimension(:, :), allocatable :: triu_int64
            integer(int64), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_int64
        module function triu_sp(A, k)
            real(sp), dimension(:, :), allocatable :: triu_sp
            real(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_sp
        module function triu_dp(A, k)
            real(dp), dimension(:, :), allocatable :: triu_dp
            real(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_dp
        module function triu_csp(A, k)
            complex(sp), dimension(:, :), allocatable :: triu_csp
            complex(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_csp
        module function triu_cdp(A, k)
            complex(dp), dimension(:, :), allocatable :: triu_cdp
            complex(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: k
        end function triu_cdp
    end interface triu

    !> Version: experimental
    !>
    !> Creates a rank-1 or rank-2 array filled zeros.
    !> ([Specification](../page/specs/forlab_linalg.html#zerosones))
    interface zeros
        procedure :: zeros_1_default
        procedure :: zeros_2_default
    end interface zeros

contains

    function rmut_sp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        real(sp), intent(in) :: m1(:, :), m2(:, :)
        real(sp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function rmut_sp
    function rmut_dp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        real(dp), intent(in) :: m1(:, :), m2(:, :)
        real(dp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function rmut_dp
    function cmut_sp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        complex(sp), intent(in) :: m1(:, :), m2(:, :)
        complex(sp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function cmut_sp
    function cmut_dp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        complex(dp), intent(in) :: m1(:, :), m2(:, :)
        complex(dp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function cmut_dp
    function rcmut_sp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        real(sp), intent(in) :: m1(:, :)
        complex(sp), intent(in) :: m2(:, :)
        complex(sp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function rcmut_sp
    function rcmut_dp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        real(dp), intent(in) :: m1(:, :)
        complex(dp), intent(in) :: m2(:, :)
        complex(dp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function rcmut_dp
    function crmut_sp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        complex(sp), intent(in) :: m1(:, :)
        real(sp), intent(in) :: m2(:, :)
        complex(sp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function crmut_sp
    function crmut_dp(m1, m2) result(res)
        !! complex(dp) matrix multiplication
        complex(dp), intent(in) :: m1(:, :)
        real(dp), intent(in) :: m2(:, :)
        complex(dp) :: res(size(m1, 1), size(m2, 2))

        if (size(m1, 2) == size(m2, 1)) then
            res = matmul(m1, m2)
        else
            call error_stop('Error: size(matrix_1, 2) /= size(matrix_2, 1)')
        end if
    end function crmut_dp

    function is_square_rsp(A) result(is_square)
        !! real(sp) matrix is square or not.
        real(sp), intent(in) :: A(:, :)
        logical :: is_square
        is_square = .false.
        if (size(A, 1) == size(A, 2)) is_square = .true.
        return
    end function is_square_rsp
    function is_square_rdp(A) result(is_square)
        !! real(dp) matrix is square or not.
        real(dp), intent(in) :: A(:, :)
        logical :: is_square
        is_square = .false.
        if (size(A, 1) == size(A, 2)) is_square = .true.
        return
    end function is_square_rdp
    function is_square_csp(A) result(is_square)
        !! complex(sp) matrix is square or not.
        complex(sp), intent(in) :: A(:, :)
        logical :: is_square
        is_square = .false.
        if (size(A, 1) == size(A, 2)) is_square = .true.
        return
    end function is_square_csp
    function is_square_cdp(A) result(is_square)
        !! complex(dp) matrix is square or not.
        complex(dp), intent(in) :: A(:, :)
        logical :: is_square
        is_square = .false.
        if (size(A, 1) == size(A, 2)) is_square = .true.
        return
    end function is_square_cdp

    function is_symmetric_rsp(A) result(is_symmetric)
        !! real(sp) matrix is symmetric or not.
        real(sp), intent(in) :: A(:, :)
        logical :: is_symmetric
        integer :: i, j, n
        is_symmetric = .true.
        if (.not. is_square(A)) then
            is_symmetric = .false.
            return
        else
            n = size(A, 1)
            do i = 1, n
                do j = 1, n
                    if (A(i, j) .ne. A(j, i)) then
                        is_symmetric = .false.
                        return
                    end if
                end do
            end do
        end if
        return
    end function is_symmetric_rsp
    function is_symmetric_rdp(A) result(is_symmetric)
        !! real(dp) matrix is symmetric or not.
        real(dp), intent(in) :: A(:, :)
        logical :: is_symmetric
        integer :: i, j, n
        is_symmetric = .true.
        if (.not. is_square(A)) then
            is_symmetric = .false.
            return
        else
            n = size(A, 1)
            do i = 1, n
                do j = 1, n
                    if (A(i, j) .ne. A(j, i)) then
                        is_symmetric = .false.
                        return
                    end if
                end do
            end do
        end if
        return
    end function is_symmetric_rdp
    function is_symmetric_csp(A) result(is_symmetric)
        !! complex(sp) matrix is symmetric or not.
        complex(sp), intent(in) :: A(:, :)
        logical :: is_symmetric
        integer :: i, j, n
        is_symmetric = .true.
        if (.not. is_square(A)) then
            is_symmetric = .false.
            return
        else
            n = size(A, 1)
            do i = 1, n
                do j = 1, n
                    if (A(i, j) .ne. A(j, i)) then
                        is_symmetric = .false.
                        return
                    end if
                end do
            end do
        end if
        return
    end function is_symmetric_csp
    function is_symmetric_cdp(A) result(is_symmetric)
        !! complex(dp) matrix is symmetric or not.
        complex(dp), intent(in) :: A(:, :)
        logical :: is_symmetric
        integer :: i, j, n
        is_symmetric = .true.
        if (.not. is_square(A)) then
            is_symmetric = .false.
            return
        else
            n = size(A, 1)
            do i = 1, n
                do j = 1, n
                    if (A(i, j) .ne. A(j, i)) then
                        is_symmetric = .false.
                        return
                    end if
                end do
            end do
        end if
        return
    end function is_symmetric_cdp

    function trace_sp(A) result(trace)
        real(sp), dimension(:, :), intent(in) :: A
        real(sp) :: trace

        trace = sum(diag(A))

    end function trace_sp
    function trace_dp(A) result(trace)
        real(dp), dimension(:, :), intent(in) :: A
        real(dp) :: trace

        trace = sum(diag(A))

    end function trace_dp

    !> `ones` creates a rank-1 array, filled completely with `1` `integer` type values.
    pure function ones_1_default(dim) result(result)
        integer, intent(in) :: dim
        integer(kind=int8), allocatable :: result(:)

        allocate (result(dim), source=1_int8)

    end function ones_1_default

    !> `ones` creates a rank-2 array, filled completely with `1` `integer` type values.
    pure function ones_2_default(dim1, dim2) result(result)
        integer, intent(in) :: dim1, dim2
        integer(kind=int8), allocatable :: result(:, :)

        allocate (result(dim1, dim2), source=1_int8)

    end function ones_2_default

    !> `zeros` creates a rank-1 array, filled completely with `0` `integer` type values.
    pure function zeros_1_default(dim) result(result)
        integer, intent(in) :: dim
        integer(kind=int8), allocatable :: result(:)

        allocate (result(dim), source=0_int8)

    end function zeros_1_default

    !> `zeros` creates a rank-2 array, filled completely with `0` `integer` type values.
    pure function zeros_2_default(dim1, dim2) result(result)
        integer, intent(in) :: dim1, dim2
        integer(kind=int8), allocatable :: result(:, :)

        allocate (result(dim1, dim2), source=0_int8)

    end function zeros_2_default

end module forlab_linalg


!*****************************************************************************************
!> author: Jacob Williams
!  date: 9/6/2017
!
!  1D definite integral test using the bspline module.
!
!  This test case evaluates the integral:
!
!  $$ \int_{0}^{\pi} x^2 \sin (x) dx = 2 $$
!
!  using a B-Spline of the points:
!
!  $$ \left[ \sin(0^{\circ}), \sin(1^{\circ}), ..., \sin(180^{\circ}) \right] $$

    program bspline_integrate_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    real(wp),parameter     :: pi      = acos(-1.0_wp)  !! \( \pi \)
    real(wp),parameter     :: deg2rad = pi/180.0_wp    !! degrees to radians
    integer(ip),parameter  :: iknot   = 0              !! automatically select the knots
    real(wp),parameter     :: x1      = 0.0_wp         !! left endpoint
    real(wp),parameter     :: x2      = pi             !! right endpoint
    integer(ip),parameter  :: nx      = 181            !! number of points in x dimension
                                                       !! in original grid
    real(wp),parameter :: tol = 10.0_wp*epsilon(1.0_wp)  !! tolerance for [[db1fqad]]

    real(wp),dimension(:),allocatable :: tx     !! x knots
    integer(ip)                       :: kx     !! x bspline order
    real(wp),dimension(nx)            :: x      !! new grid x points
    real(wp),dimension(nx)            :: fcn    !! original grid
                                                !! function evaluations
    integer(ip)                       :: i      !! counter
    integer(ip)                       :: iflag  !! status flag
    real(wp)                          :: f      !! the evaluated integral
    integer                           :: imeth  !! method counter
    character(len=:),allocatable      :: meth   !! method string
    real(wp)                          :: f_true !! the true integral of
                                                !! the analytic function
    real(wp),dimension(:),allocatable :: w1_1d  !! work array

    do imeth = 1,2  ! the two methods

        write(*,*) ''
        write(*,'(A8,1X,A5,1X,A30,1X,A30)') 'Method','Order','Integral','Error'

        do kx = 2, 15  ! spline orders

            if (allocated(tx))    deallocate(tx)
            if (allocated(w1_1d)) deallocate(w1_1d)
            allocate(tx(nx+kx))
            allocate(w1_1d(3*kx))

            ! x^2 * sin(x) function evaluations for original grid:
            do i=1,nx
                x(i) = deg2rad*real(i-1,wp)
                if (imeth==1) then
                    fcn(i) = x(i)**2 * sin(x(i))
                else
                    ! for this one the x^2 will be handled by func
                    fcn(i) = sin(x(i))
                end if
            end do

            f_true = pi**2 - 4.0_wp

            ! initialize:
            ! [note we are overwriting fcn here with the b coeffs]
            call db1ink(x,nx,fcn,kx,iknot,tx,fcn,iflag)
            if (iflag/=0) error stop 'error calling db1ink'

            ! integrate:
            if (imeth==1) then
                if (kx>20) cycle
                meth = 'db1sqad'
                call db1sqad(tx,fcn,nx,kx,x1,x2,f,iflag,w1_1d)
            else
                meth = 'db1fqad'
                call db1fqad(test_function,tx,fcn,nx,kx,0_ip,x1,x2,tol,f,iflag,w1_1d)
            end if

            ! display results:
            if (iflag/=0) then
                write(*,*) ''
                write(*,*) 'iflag: ',iflag
                write(*,*) 'error calling '//meth
                error stop
            else
                write(*,'(A8,1X,I5,1X,E30.16,1X,E30.16)') meth,kx,f,f-f_true
            end if

        end do
    end do
    write(*,*) ''

    contains

        function test_function(x) result(f)

        !! the function \( f(x) = x^2 \)
        !! to use for [[db1fqad]] test.

        implicit none

        real(wp),intent(in) :: x
        real(wp)            :: f  !! f(x)

        f = x*x

        end function test_function

    end program bspline_integrate_test
!*****************************************************************************************


program dinamica

implicit none

real, dimension (1:500) :: x, t
real :: xo, vo, a, cont
integer :: k

xo = 2
vo = 4
a = 6

cont = 0
do k = 1,500
    cont = cont + 0.01
    t(k) = cont
    x(k) = xo + vo*t(k)+((a*(t(k)**2))/2)
end do

do k = 1,500
    write(*,*) x(k), t(k)
end do

open(1,file = "dados.txt")

do k = 1,500
    write(1,*) x(k), t(k)
end do

close (1)

end program dinamica