PROGRAM read_n_calc
IMPLICIT NONE
REAL, ALLOCATABLE, DIMENSION(:,:) :: data
CHARACTER(LEN=20) :: filename
INTEGER :: status
INTEGER :: rows, cols, i, j
CHARACTER(LEN=10) :: row_str, col_str
CHARACTER(LEN=40) :: row_sum_fmt, col_sum_fmt

WRITE(*, *) "Enter the filename to read and process:"
READ(*, *) filename

OPEN(1, FILE=filename, STATUS='OLD', ACTION='READ', IOSTAT=status)
READ(1, *) rows, cols
ALLOCATE(data(1:rows, 1:cols))

WRITE(row_str, '(I3)') rows
WRITE(col_str, '(I3)') cols
row_str = TRIM(row_str)
col_str = TRIM(col_str)
row_sum_fmt = '(' // row_str // '(A, I4, 2X, A, F12.1, A))'
col_sum_fmt = '(' // col_str // '(A, I4, 2X, A, F12.1, A))'
row_sum_fmt = TRIM(row_sum_fmt)
col_sum_fmt = TRIM(col_sum_fmt)

DO i = 1, rows
  READ(1, '(' // col_str // 'F8.1)', IOSTAT=status) (data(i, j), j = 1, cols)
  IF (status .lt. 0) THEN
    EXIT
  END IF
END DO

WRITE(*, row_sum_fmt) ("Row:", i, "Sum:", SUM(data(i, 1:cols)), NEW_LINE('A'), i = 1, rows)
WRITE(*, col_sum_fmt) ("Col:", i, "Sum:", SUM(data(1:rows, i)), NEW_LINE('A'), i = 1, cols)
!WRITE(*, row_sum_fmt) ("Row:", i, "Sum:", SUM(data(i, 1:cols)), NEW_LINE('A'), i = 1, rows)
!WRITE(*, col_sum_fmt) ("Col:", i, "Sum:", SUM(data(1:rows, i)), i = 1, cols)

DEALLOCATE(data)
END PROGRAM read_n_calc


C File: arrays-constr-07.f
C This program has a simple 1-D array with the default lower bound of 1.
C It shows the use of an array constructor to initialize the array.

      program main
      implicit none

C     A, B, C are 1-D arrays of integers with implicit lower-bound = 1
C     and upper bound of 12.
      integer, dimension(12) :: A
      integer, dimension(12) :: B = (/12,11,10,9,8,7,6,5,4,3,2,1/)
      integer, dimension(12) :: C = (/1,3,5,7,9,11,13,15,17,19,21,23/)
      integer :: i

C     array constructor III -- implied do loop, nested array expressions
C     This example is very similar to arrays-constr-06.f with the
C     difference that the iteration for the inner array expression goes
C     from 12 down to 1 (start value = 12, end value = 1, step = -1).
C     The inner expression B(12:1:-1) therefore gives the sequence of
C     values of B's elements in the order B(12), B(11), ..., B(1), i.e.:
C
C         1, 2, 3, ..., 10, 11, 12
C
C     The outer expression uses this sequence of values to index into
C     the array C, giving the sequence of values of C's elements in the
C     order C(1), C(2), C(3), ..., C(10), C(11), C(12).  The sequence of
C     values assigned to the elements of A is therefore:
C
C         1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23

      A = (/ (C(B(12:1:-1))) /)

      do i = 1, 12
          write (*,10) A(i)
      end do

 10   format(I5)

      stop
      end program main


! chk_isnan.f90
!     Check: can we check if a number is not-a-number via the IEEE features?
!
program chk_isnan
    use ieee_arithmetic
    implicit none

    real :: x

    call random_number( x )
    x = sqrt(x-1.0)

    write( *, '(a,a)' ) 'The value of x should be "not-a-number" - ', merge( 'YES', 'NO ', ieee_is_nan(x) )
    write( *, '(a,a)' ) 'The ieee_is_nan intrinsic function is available'

end program chk_isnan


program where_test
    use, intrinsic :: iso_fortran_env, only : sp => REAL32, error_unit
    implicit none
    integer, parameter :: N = 5
    real, parameter :: eps = 1.0e-2_sp
    real(kind=sp), dimension(N, N) :: A
    integer, dimension(N, N) :: Pos, Neg, Zero
    real(kind=sp) :: r
    integer :: i, j
    character(len=40) :: r_fmt_str
    character(len=40) :: i_fmt_str

    write (r_fmt_str, "('(', I2, 'F7.2)')") N
    write (i_fmt_str, "('(', I2, 'I7)')") N

    do i = 1, N
        do j = 1, N
            call random_number(r)
            A(i, j) = 2.0_sp*(r - 0.5_sp)
        end do
    end do

    where (A > eps)
        Pos = 1
        Neg = 0
        Zero = 0
    elsewhere (A < eps)
        Pos = 0
        Neg = 1
        Zero = 0
    elsewhere
        Pos = 0
        Neg = 0
        Zero = 1
    end where

    print '(A)', 'matrix:'
    do i = 1, N
        print r_fmt_str, A(i, :)
    end do
    print '(2A)', '---------', 'positive'
    do i = 1, N
        print i_fmt_str, Pos(i, :)
    end do
    print '(2A)', '---------', 'negative'
    do i = 1, N
        print i_fmt_str, Neg(i, :)
    end do
    print '(2A)', '---------', 'zero'
    do i = 1, N
        print i_fmt_str, Zero(i, :)
    end do

    if (sum(Pos + Neg + Zero) /= N*N) then
        write (unit=error_unit, fmt='(A)') '# error: not all covered'
        stop 1
    end if

end program where_test


! Liao 1/5/2010
! Several variants of Fortran Do loops
      program mymain
      integer i, n, sum

      sum = 0
      n = 10
      write (*,*) 'loop 1-----------------'
      do 10 i = 1, n
         sum = sum + i
         write(*,*) 'i =', i
         write(*,*) 'sum =', sum
  10  continue

! Decremental: -2, integer type
      write (*,*) 'loop 2-----------------'
      do 20 i = 10, 1, -2
         write(*,*) 'i =', i
  20  continue

! end do
      write (*,*) 'loop 3-----------------'
      do i = 1, n
         sum = sum + i
         write(*,*) 'i =', i
      end do
      end


module lnumz
    integer, parameter:: b4 = selected_real_kind(4)
end module
module csolve
    use lnumz
    contains
        subroutine ludcmp(a,n,np,indx,d)
        use lnumz
        implicit none
        integer n,np,indx(n)
        complex(b4) a(np,*),tiny
        complex(b4) :: tmp
        complex(b4) :: sum
        integer d
        parameter (tiny=1.0e-20_b4)
        integer i,imax,j,k
        real(b4),allocatable :: vv(:)
        real(b4) :: aamax,dum
        allocate(vv(n))
        d=1.0_b4
        do i=1,n
          aamax=0.0_b4
          do j=1,n
             if(abs(a(i,j)) .gt.  aamax) aamax=abs(a(i,j))
          enddo
          if( aamax .eq. 0.0_b4)then
              write(*,*)"sigular matrix"
              stop
          endif
          vv(i)=1.0_b4/aamax
        enddo
        do j=1,n
          do i=1,j-1
            sum=a(i,j)
            do k=1,i-1
                sum=sum-a(i,k)*a(k,j)
            enddo
            a(i,j)=sum
          enddo
          aamax=0.0_b4
          do i=j,n
            sum=a(i,j)
            do k=1,j-1
              sum=sum-a(i,k)*a(k,j)
            enddo
            a(i,j)=sum
            dum=vv(i)*abs(sum)
            if (dum .ge. aamax)then
              imax=i
              aamax=dum
            endif
          enddo
          if ( j .ne. imax)then
            do k=1,n
              tmp=a(imax,k)
              a(imax,k)=a(j,k)
              a(j,k)=tmp
            enddo
            d=-d
            vv(imax)=vv(j)
          endif
          indx(j)=imax
          if(a(j,j) .eq. 0.0_b4)a(j,j)=tiny
          if(j .ne. n)then
            tmp=1.0_b4/a(j,j)
            do i=j+1,n
                a(i,j)=a(i,j)*tmp
            enddo
          endif
         enddo
         deallocate(vv)
         end subroutine

         subroutine lubksb(a,n,np,indx,b)
         use lnumz
         implicit none
         integer n,np,indx(n)
         complex(b4) :: a(np,np),b(n)
         integer i,ii,j,ll
         complex(b4) sum
         ii=0
         do i=1,n
           ll=indx(i)
           sum=b(ll)
           b(ll)=b(i)
           if (ii .ne. 0)then
             do j=ii,i-1
               sum=sum-a(i,j)*b(j)
             enddo
           else if (sum .ne. 0.0_b4) then
             ii=i
           endif
           b(i)=sum
         enddo
         do i=n,1,-1
           sum=b(i)
           do j=i+1,n
             sum=sum-a(i,j)*b(j)
           enddo
             b(i)=sum/a(i,i)
         enddo
         end subroutine
end module
subroutine cgesv( n, nrhs, a, lda, ipiv, b, ldb, info )
  use lnumz
  use csolve
  implicit none
  integer n,nrhs,lda,ldb,info,id
  integer j
  complex(b4) :: a(lda,*),b(ldb,*)
  integer ipiv(*)
  call ludcmp(a,n,lda,ipiv,id)
  info=0
  do j=1,nrhs
    call lubksb(a,n,lda,ipiv,b(:,j))
  enddo
end subroutine


      subroutine CGEI(A,LDA,N,IPVT,WORK)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1992-05-18 CLL
C>> 1987-08-14 CGEI   Lawson  Initial code.
C
c     This subroutine computes the inverse of the N x N matrix, A,
C     using the LU factorization of A given in the array A().
c     ------------------------------------------------------------------
c                        Subroutine arguments
C
C     A(,)  [inout]  An array of size at least N x N.  On entry must
c            contain the LU factors of an N x N  matrix, A.  It is
c            expected that this factorization will have been computed by
c            use of _GEFA, either directly or indirectly via use of _GEC
c            _GEFS or _GEFSC.
c            On return contains the N x N inverse matrix of A.
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the original matrix, A.
C
C     IPVT()  [in]  An integer array of length at least N, containg a
c           record of the row interchanges made during factorization of
c           A.
C
c     WORK()  [scratch]  An array of length at least N used by this
c        subroutine as working space.
c     ------------------------------------------------------------------
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        setting of LDA.  The user can avoid sending a singular matrix
c        to this subr by testing INFO (set by _GEFS or _GEFA) or
c        RCOND (set by _GEFSC or _GECO) before calling this subr.
c        Nonsingularity is indicated by INFO .eq. 0 or RCOND .ne. ZERO.
c     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
c     Subprograms referenced: CAXPY, CSCAL, CSWAP
C     ------------------------------------------------------------------
      integer LDA,N,IPVT(N),I,J,K,KB,KP1,L,NM1
      complex A(LDA,N), WORK(N), T, ONE, ZERO
      parameter(ONE = (1.E0,0.E0), ZERO = (0.E0,0.E0))
C     ------------------------------------------------------------------
C     COMPUTE INVERSE(U)
C
         DO 100 K = 1, N
c           5/18/92 CLL The following stmt rewritten to avoid a bug in
c           the current SUN Fortran compiler.
c           IF (A(K,K) .NE. ZERO) THEN
            if(real(A(K,K)) .ne. 0.0e0 .or.
     *          aimag(A(K,K)) .ne. 0.0e0) then
              A(K,K) = ONE/A(K,K)
            ELSE
              CALL ERMSG('CGEI',1,0,'A diagonal element is zero','.')
              RETURN
            END IF
            T = -A(K,K)
            CALL CSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = ZERO
               CALL CAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = ZERO
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL CAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL CSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
      RETURN
      END


Program Sum_of_trace
INTEGER N, trace
integer, dimension (50,50) :: matrix
Print *, "Enter N"
read(*,*) N
Print *, "Enter Matrix"
trace=0
do i=1, N
    do j = 1, N
        read(*,*) matrix(i, j)
        if( i == j ) then
            trace = trace + matrix(i, j)
        end if
    end do
end do
Print *, "Trace= ", trace
End Program Sum_of_trace


      subroutine DCONMC(N, COEFF)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DCONMC Krogh   Declared all vars.
c>> 1994-10-20 DCONMC Krogh  Changes to use M77CON
c>> 1992-06-04 DCONMC Krogh  Corrected line below.
c>> 1992-01-31 DCONMC Krogh  Initial Code.
c--D replaces "?": ?CONMC
c
c Converts COEFF in monomial basis to the Chebyshev basis.
c
      integer N, J, I
      double precision COEFF(0:N), TP
c
      if (N .le. 0) return
      TP = .5D0**(N-1)
      COEFF(N) = TP * COEFF(N)
      COEFF(N-1) = TP * COEFF(N-1)
      do 20 J = N-2, 0, -1
         TP = 2.D0 * TP
         COEFF(J) = TP * COEFF(J)
         COEFF(J+1) = 2.D0 * COEFF(J+1)
         do 10 I = J, N-2
            COEFF(I) = COEFF(I) + COEFF(I+2)
   10    continue
   20 continue
      return
      end


Module MathLib

contains

    SUBROUTINE LEGS (A_,Nn,B_,Xx)
      INTEGER, INTENT (IN) :: Nn
      INTEGER :: iI,iJ
      INTEGER, DIMENSION (Nn) :: INDX
      REAL, INTENT (IN), DIMENSION (Nn,Nn) :: A_
      REAL, INTENT (IN), DIMENSION (Nn) :: B_
      REAL, DIMENSION (Nn,Nn) :: Aa
      REAL, DIMENSION (Nn) :: Bb
      REAL, INTENT (OUT), DIMENSION (Nn) :: Xx

      Aa  = A_
      Bb  = B_
    !
      CALL ELGS (Aa,Nn,INDX)
    !
      DO iI = 1, Nn-1
        DO iJ = iI+1, Nn
          Bb(INDX(iJ)) = Bb(INDX(iJ))-Aa(INDX(iJ),iI)*Bb(INDX(iI))
        END DO
      END DO
    !
      Xx(Nn) = Bb(INDX(Nn))/Aa(INDX(Nn),Nn)
      DO iI = Nn-1, 1, -1
        Xx(iI) = Bb(INDX(iI))
        DO iJ = iI+1, Nn
          Xx(iI) = Xx(iI)-Aa(INDX(iI),iJ)*Xx(iJ)
        END DO
        Xx(iI) =  Xx(iI)/Aa(INDX(iI),iI)
      END DO
    !
    END SUBROUTINE LEGS
    !
    SUBROUTINE ELGS (Aa,Nn,INDX)
      INTEGER, INTENT (IN) :: Nn
      INTEGER :: iI, iJ, iK = 0, ITMP
      INTEGER, INTENT (OUT), DIMENSION (Nn) :: INDX
      REAL :: C1, PI, PI1,PJ
      REAL, INTENT (INOUT), DIMENSION (Nn,Nn) :: Aa
      REAL, DIMENSION (Nn) :: C
    !
    ! Initialize the index
      DO iI = 1, Nn
        INDX(iI) = iI
      END DO
    !
    ! Find the rescaling factors, one from each row
      DO iI = 1, Nn
        C1= 0.0
        DO iJ = 1, Nn
          C1 = AMAX1(C1,ABS(Aa(iI,iJ)))
        END DO
        C(iI) = C1
      END DO
    !
    ! Search the pivoting (largest) element from each column
      DO iJ = 1, Nn-1
        PI1 = 0.0
        DO iI = iJ, Nn
          PI = ABS(Aa(INDX(iI),iJ))/C(INDX(iI))
          IF (PI.GT.PI1) THEN
            PI1 = PI
            iK   = iI
          ENDIF
        END DO
    !
    ! Interchange the rows via INDX(N) to record pivoting order
        ITMP     = INDX(iJ)
        INDX(iJ) = INDX(iK)
        INDX(iK) = ITMP

        DO iI = iJ+1, Nn
          PJ  = Aa(INDX(iI),iJ)/Aa(INDX(iJ),iJ)
    !
    ! Record pivoting ratios below the diagonal
    !
          Aa(INDX(iI),iJ) = PJ
    !
    ! Modify other elements accordingly
          DO iK = iJ+1, Nn
            Aa(INDX(iI),iK) = Aa(INDX(iI),iK)-PJ*Aa(INDX(iJ),iK)
          END DO
        END DO
      END DO
    !
    END SUBROUTINE ELGS
    !
    character(len=20) function rStr(rk)
    implicit none

    ! Convertir un intier en chaine de caractères.
    real, intent(in) :: rk

    write(rStr, *) rk
    rStr = adjustl(rStr)
    end function rStr

    character(len=20) function Str(ik)
    implicit none

    ! Convertir un intier en chaine de caractères.
    integer, intent(in) :: ik

    write(Str, *) ik
    Str = adjustl(str)
    end function Str

    Integer function Str2int(str_)
       implicit none

       character(len=*), intent(in) :: str_
       integer :: int_
       read(str_, *)  int_
       Str2int = int_
    end function Str2int

    Real function Str2float(str_)
       implicit none

       character(len=*), intent(in) :: str_
       Real :: f_

       read(str_, "(F9.3)")  f_
       Str2float = f_
    end function Str2float

    character(len=20) function Formatte(s_, nc_)
    ! Convertir un intier en chaine de caractères.
    integer, intent(in) :: nc_
    integer, intent(in) :: s_
    character(len=20) :: sfmt

        if (s_ == 0) then
            sfmt = REPEAT(" ", int(nc_/2)) // Str(s_) // REPEAT(" ", int(nc_/2))
        else
            sfmt = REPEAT(" ", int(nc_/2)) // "-" // REPEAT(" ", int(nc_/2))
        endif
        write(Formatte, *) s_
        Formatte = adjustl(Formatte)
    end function Formatte

    ! Processus d'importation à partir de fichier IEEE CDF

End module MathLib

program newtonrap

Use MathLib

Implicit none

!> Declarations des variables
real,parameter :: pi=3.14159
integer :: N, I, J, W, NB, k, JN, Np, Ng, Kmax = 100, Cond, narg, slack = 1, io
character(len=30) :: NName

!> Variables principales
complex, allocatable, Dimension(:,:) :: Ya, Z, Spq, Ys
complex, allocatable, Dimension(:) :: V, Sg, Sd
real, allocatable, dimension(:,:) :: YB, YG, Ja, c !, Vs
Integer, allocatable, dimension(:) :: Nfrom, Nto, Indx
real, allocatable, dimension(:) :: P, Q, Fd, X, DX, ModV, Theta
character(1), allocatable, dimension(:) :: Typen
real :: eps = 0.001 , MaxDx, t1, t2, PL, QL, Sbase
character(100) :: A2Fmt, AFmt, A3Fmt, fnamein, fnameout, name, hlpfilename = "NR.hlp"
character(len=100) :: hlpstr
logical :: lookForIn = .false., fileExist, LookForInOut = .FALSE., Yes
logical :: lookForOut= .false., lookForCDF = .FALSE.
Character(len=5) :: CalcWith = "INV"
Character(1) :: Y_
! variables génériques
real :: a, b, d, e

! ici commence mon programme

! Passage des argument, correspondance au nom de fichier. narg représente le nombre d'arguments
narg=command_argument_count()
! Vérification des arguments
! fnamein et fnameout sont respectivement les noms de fichiers d'entrée et de sortie (noms complets)
if (narg > 0) then
   do i= 1, narg
      call get_command_argument(i, name)
      select case(adjustl(name))
            case("--in")
                lookForIn  = .TRUE. !change logical value
            case("--out")
                lookForOut = .TRUE.
            case("--cdfin")
                lookForIn  = .TRUE.
                lookForCDF = .TRUE.
            case("--INV")
                calcWith = "INV"
            case("--GAUSS")
                calcWith = "GAUSS"
            case("--LU")
                calcWith = "LU"
            case("--help")
                inquire(file = hlpfilename, exist = fileExist) ! Vérifier si le fichier d'aide existe
                    if (.not. fileExist) then
                        write(*, *) "fichier d'aide ", hlpfilename, ' inéxistant'
                        write(*, *) "Utilisation de NRPower :"
                        write(*, *) "NRPower [Option] [Attribut]"
                        write(*, *) "Option : --help, --in, --out"
                        write(*, *) "Attribut : Nom du fichier (d'Aide, d'entrée de données, de sortie des résultats"
                        stop
                    else
                        open(10, file=hlpfilename, action='write')
                        io = 0
                        do while (io == 0)
                           read(10, *, IOSTAT=io) hlpstr
                           write(*,*) adjustl(trim(hlpstr))
                        end do
                    endif
            case default
                if (LookForIn) then
                    ! Nom du fichier d'entrée des données réseau
                    fnamein = adjustl(name)
                    ! Vérifier son existance dans le chemin spécifié
                    inquire(file = fnamein, exist = fileExist)
                    if (.not. fileExist) then
                        write(*,*) "fichier de données ", fnamein, " est inéxistant dans l'emplacement désigné ..."
                        stop
                    else
                        write(*,*) "Accès au fichier de données ", fnamein, "..."
                        open(50, file = fnamein, action = "read")
                        if (LookForCDF) Then
                            Call CDFImport1(50)
                            ! Dimensionnement des matrices et vecteurs
                            print*, "Allocation mémoire des matrices du réseau"
                            allocate (Ya(N,N), Z(N,N), Ys(N, N), YB(N,N), YG(N,N), Spq(N,N))
                            allocate (V(N), P(N), Q(N), Typen(N), ModV(N), Theta(N), Sg(N), Sd(N), Indx(N))
                            ! Initialisation des données
                            ! Matrice admittance
                            Ya = cmplx(0., 0.)
                            Call CDFImport2(50)
                            allocate (Nfrom(NB), Nto(NB))
                            ! Vecteurs Nfrom et Nto à 0
                            Nfrom = 0
                            Nto   = 0
                            Call CDFImport3(50)
                            Call Mef
                            Call SaveImport(fnamein)
                            print*, "Dé-allocation dynamique de la mémoire des données CDF ..."
                            deallocate (Ya, Z, Ys, YB, YG, Spq)
                            deallocate (V, P, Q, Typen, ModV, Theta, Sg, Sd, Indx)
                            deallocate (Nfrom, Nto)
                            print*, "Ouverture du fichier de données conforme NMSS ... traitement."
                            LookForCDF = .FALSE.
                            close(50)
                            open(50, file = fnamein, action = "read")
                        endif
                    endif
                    LookForIn = .FALSE.
                    LookForInOut = .TRUE.
                elseif (LookForOut) then
                    ! Nom du fichier d'entrée des données réseau
                    fnameout = adjustl(name)
                    ! Vérifier son existance dans le chemin spécifié
                    inquire(file = fnameout, exist = fileExist)
                    if (fileExist) then
                        write(*,*) "fichier de sortie ", fnameout, " éxiste dans l'emplacement désigné ..."
                        Yes = .FALSE.
                        Do While (.not. Yes)
                           Print*, "Comfirmer l'ecrasement (O/N) ? "
                           read(*, "(A1)") Y_
                           if (Y_ == "O") Then
                               Yes = .TRUE.
                               write(*,*) "Accès au fichier de sortie ", fnameout, "..."
                               open(60, file = fnameout, action='write')
                           else
                               print*,"Impossibilité de continuer ... Merci de réessayer."
                               stop
                           endif
                        EndDo
                    else
                        write(*,*) "Accès au fichier de sortie ", fnameout, "..."
                        open(60, file = fnameout, action='write')
                    endif
                    LookForOut = .FALSE.
                    LookForInOut = .TRUE.
                else
                    write(*,*)"Option [",adjustl(name),"] inconnue"
                endif
      end select
   end do
endif

! saisie Dimension réseau

if (.not. LookForIn .and. .not. LookForInOut) Then
    write(*,*) "Execution des données TEST ... "
    open(50, file='/home/mtamali/NR/NR/obj/Debug/data.dat')
end if

if (.not. LookForOut .and. .not. LookForInOut) Then
    write(*,*) "Ecriture des résultats selon données TEST ... "
    open(60, file='/home/mtamali/NR/NR/obj/Debug/result.res', action='write')
end if

! Choix de laméthode d'entrée des données (CDF ou standard NMSS)
If (.not. lookForCDF) Then
    ! Lecture des nombres de noeuds et de branches
    read(50, *) NName, N, NB, Sbase
    ! Ecriture des données du réseau.
    print*, "Lecture de l'identification du réseau"
    write(60, *) 'Identification : ', NName
    write(60, *) "le nombre de noeuds N= ", trim(Str(N)), ", le nombre de branches Nb= ", trim(Str(NB)),&
   &" et la puissance de base Sb= ", Sbase, " MVA."

    print*, "Allocation mémoire des matrices du réseau"
    allocate (Ya(N,N), Z(N,N), Ys(N, N), YB(N,N), YG(N,N), Spq(N,N), Indx(N))
    allocate (V(N), P(N), Q(N), Typen(N), ModV(N), Theta(N), Sg(N), Sd(N), Nfrom(NB), Nto(NB))
    ! Initialisation des données
    ! Matrice admittance
    Ya = cmplx(0., 0.)
    ! Vecteurs Nfrom et Nto à 0
    Nfrom = 0
    Nto   = 0
    ! Vecteur tension nodal
    print*, "Initialisation du vecteur tension nodal du réseau ..."
    V=cmplx(1.,0.)
    ! Dimensionnement des matrices et vecteurs
    ! Initialisation des puissances
    Sg=(0.0, 0.0)
    Sd=(0.0, 0.0)
    ! Lecture des données des lignes de transport
    print*, "Lecture des donées lignes de transport du réseau"
    do w=1,NB
        ! Bfrom BTo R X Gsh Bsh
        Read(50,*) I, J, a, b, d, e
        Nfrom(w) = I
        Nto(w) = J
        Z(I,J)=cmplx(a,b)
        Ys(I,J)=cmplx(d,e)
    end do
    ! Initialisation des variables Np et Ng : Nombre de noeuds consommateurs et générateurs respectivement
    Np    = 0
    Ng    = 0
    ! Initialisation des vecteur ModV et Theta, Module de tension nodal et Argument
    ModV  = 1.0
    Theta = 0.0

    ! Saisie type des noeud, valeurs spécifiées.
    ! Noeud Générateur G (Lire V, Pg), Consommateur C (Lire Pd, Qd) et Bilan B (Affecter V)
    print*, "Lecture des données caractéristiques des noeuds du réseau (pu)"
    do I = 1, N
       Read(50,*) typen(I), a, b
       if (typen(I) == "G") then
           Ng      = Ng + 1
           ModV(i) = a
           V(I)    = ModV(I)*(V(i)/ModCmplx(V(I)))
           Sg(I)=Cmplx(b, 0.0)
           P(I)    = Real(Sg(I) - Sd(I))
           write(60,"(A,A,A,F9.3,A,A,A,F9.3)")  "Noeud générateur  |V|(", trim(Str(I)), ")=", &
           &ModCmplx(V(I)), " | Pg(", trim(Str(I)), ")=", P(I)
       elseif (typen(I)=="C") then
           Np      = Np + 1
           Sd(I)=Cmplx(a, b)
           P(I)    = Real(Sg(I) - Sd(I))
           Q(I)    = Imag(Sg(I) - Sd(I))
           write(60,"(A,A,A,F9.3,A6,A,A,F9.3)") "Noeud consommateur Pd(", trim(Str(I)), ")=", &
           &P(I), " | Qd(", trim(Str(I)), ")=", Q(I)
       else
           slack    = I
           ModV(I)  = a
           Theta(I) = b
           V(I)=cmplx(a*cos(b), a*sin(b))
           write(60, "(A,A,A,F9.3,A,A,A,F9.3)") "Noeud balancier   |V|(", trim(Str(I)), ")=", ModCmplx(V(I)), &
           &" | Theta(", trim(Str(I)), ")=", Argum(V(I))
       end if
    enddo
    !c:saisie de epsilon et de Kmax
    print*, "Lecture des éléments de tolérance/limite des itérations des traitements ..."
    read(50,*) a, Kmax
    eps=a
endif

! Mise en forme des indices de noeuds.
Call Mef
!Call SaveImport
!stop

write(60,*) '------------------------------------------------------------------'
write(60,"(A)") 'le vecteur tension nodal après initialisation ...'
write(60,"(2F6.3,A5)") (V(Indx(I)),"*i pu", I = 1, N)
write(60,*) '------------------------------------------------------------------'

! Subroutine de calcul de la matrice admittance Ya
Call CalcYa

! Formation des matrices G et B
print*, "Initialisation de la matrice admitance du réseau"
YG=real(Ya)
YB=aimag(Ya)
! Initialisation des vecteurs P et Q
P=0.
Q=0.

A2Fmt= "(" // Trim(Str(N)) // "(A1,(F9.3,1X,F9.3),A3))"

! Impression de la matrice admittance (ligne/ligne)
!write(60,*) 'la matrice admittance Y ...'
!do I=1,N
!   write(60, A2Fmt) ("(", Ya(I,J), "*i)", J=1,N)
!end do
!write(60,*) '------------------------------------------------------------------'

write(60,*) 'la matrice conductance G=Real(Y)'
AFmt= "(" // Trim(Str(N)) // "F9.3,1X)"
do I=1,N
   write(60, AFmt) (YG(I,J), J=1,N)
end do

write(60,*) '------------------------------------------------------------------'
write(60,*) 'la matrice susceptance B=Imag(Y)'
do I=1,N
   write(60, AFmt) (YB(I,J), J=1,N)
end do
write(60,*) '------------------------------------------------------------------'

! Alloue dynamiquement la vraie dimension de Ja, Fd et DX
JN = Ng+2*Np
print*, "Initialisation de la matrice Jacobienne du réseau ... "
Allocate (Ja(JN, JN), Fd(JN), DX(JN), X(JN), c(JN, JN)) !, INDX(JN)

!-----------------------------------------------------------------------------------------------------
write(60,"(A28, A, A23, F9.3)") "Nombre max des itérations : ", trim(Str(Kmax)), ", Précision demandée : ", eps

! Affectation et formation de la valeur ESTIME du veteur des inconnues [Teta, |V|] à l'itération k=0
X = 0.
print*, "Initialisation du vecteur INCONNUES du réseau ..."
write(60,"(A39)") "Vecteur inconnues après initialisation ..."
write(60,*) '------------------------------------------------------------------'
do I = 1, N-1
   X(I) = Argum(V(Indx(I+1)))
end do
do I = N, JN
   X(I) = ModCmplx(V(Indx(I - Np + 1)))
end do

do I=1, JN
   if (I .le. N-1) then
       write(60, "(A2,A,A4,F9.3,A)") "X(", trim(Str(I)), ") = ", X(I), " radian(s)"
   else
       write(60, "(A2,A,A4,F9.3,A)") "X(", trim(Str(I)), ") = ", X(I), " pu"
   endif
end do
write(60,*) '=================================================================='

! Début des itérations
Cond = 0 ! Condition d'arrêt relative à Epsilloon
k=1 ! Indice de l'itération
print*, "Début du traitement du réseau ", NName
! Evaluation du moment du début des traitements
call cpu_time ( t1 )
write(*, "(A,f9.3,A2)") "Temps début du traitement évalué à : ", t1, " s"

Do while (Cond==0 .and. k<=Kmax)
    write(60, "(A26, A)") "Début de l'itération, k = ", trim(Str(k))

    !Calcul des composantes de la matrice Jacobienne
    Ja = 0.0
    ! Element de la sous-matrice J1
    do i = 2, N
       do j = 2, N
          if (Indx(i) == Indx(j)) then
              Ja(i-1, j-1) = DP_Dtetaii(Indx(i), N)
          else
              Ja(i-1, j-1) = DP_Dtetaij(Indx(i), Indx(j))
          end if
       end do
    enddo
    ! Element de la sous-matrice J2
    do i = 1, N-1
       do j = N, JN
          if (Indx(i+1) == Indx(j-Np+1)) then
              Ja(i, j) = DP_DModVii(Indx(i+1), N)
          else
              Ja(i, j) = DP_DModVij(Indx(i+1), Indx(j-Np+1))
          end if
       end do
    enddo
    ! Element de la sous-matrice J3
    do i = N, JN
       do j = 1, N-1
          if (Indx(i-Np+1) == Indx(j+1)) then
              Ja(i, j) = DQ_Dtetaii(Indx(i-Np+1), N)
          else
              Ja(i, j) = DQ_Dtetaij(Indx(i-Np+1), Indx(j+1))
          endif
       end do
    enddo
    ! Element de la sous-matrice J4
    do i = N, JN
       do j = N, JN
          if (Indx(i-Np+1) == Indx(j-Np+1)) then
              Ja(i, j) = DQ_DModVii(Indx(i-Np+1), N)
          else
              Ja(i, j) = DQ_DModVij(Indx(i-Np+1), Indx(j-Np+1))
          endif
       end do
    enddo

    write(60,*) '------------------------------------------------------------------'
    ! Impression des elements de la matrice Jacobienne
    A3Fmt= "(" // Trim(Str(JN)) // "F9.3,1X)"
    write(60, *) "Matrice jacobienne à l'itération k=", trim(Str(k))
    do i = 1, JN
        write(60, A3Fmt) (Ja(i, j), j = 1, JN)
    end do

    write(60,*) '------------------------------------------------------------------'
    ! Calcul des fonctions DeltaF
    write(60, *) "Vecteur second membre DF ( itération k :",trim(Str(k)),")"
    Fd = 0
    ! Les DeltaP de tous le noeuds sauf balancier (Ng + Np)
    do I = 1, N-1
       ! Correspond à P (Noeuds de type PV et PQ)
       Fd(I)   = - P(Indx(I+1)) + calcP(Indx(I+1))
    enddo
    ! DeltaQ des neux consommateurs seulement (Np)
    do I = N, JN
           Fd(I) = - Q(Indx(I-Np+1)) + CalcQ(Indx(I-Np+1))
    enddo

    ! Impression des DeltaP, DeltaQ résultants
    write(60,*) "Impression des DeltaP, DeltaQ résultants"
    do I=1, JN
       write(60, "(A3,A,A2,F9.3)") "DF(",trim(Str(I)),")= ",Fd(I)
    end do

    if (CalcWith == "INV") Then
    !    ! Inversion de la matrice Jacobienne, en utilisant La méthode de Gauss-Jordan
        Call InvMat(Ja, c, JN)
        ! Calcul de la solution du système linéaire J.DX = F
        DX = MatMul(c, Fd)
    elseif (CalcWith == "GAUSS") then
        Call GaussMat(Ja, Fd, DX, JN)
    elseif (CalcWith == "LU") then
        Call LEGS(Ja, JN, Fd, DX)
    endif

    ! Calculer les nouvelles valeurs de Theta et ModV
    X = X - DX
!
    write(60,*) '------------------------------------------------------------------'
    write(60,*) "Vecteur corrections à l'itération k= ", trim(Str(k))
    write(60, "(E9.3)") (DX(I), I = 1, JN)
!
    write(60,*) '------------------------------------------------------------------'
    write(60,*) "Vecteur solution intermédiaire à l'itération k= ", trim(Str(k))
    write(60, "(E9.3)") (X(I), I = 1, JN)
!
    ! Ré-établissement des valeurs des vecteurs ModV et de Theta
    do i=1, N-1 ! les N premières valeurs sont pour les arguments Theta
       Theta(i+1) = X(i)
    end do
    do i = N, JN ! Les suivantes sont pour les modules de V
       ModV(i-Np+1) = X(i)
    end do
    ! Ré-évaluation du vecteur tension nodal, à partir des corrections obtenues
    do i = 1, N
       V(i) = cmplx(ModV(i)*cos(Theta(i)), ModV(i)*sin(Theta(i)))
    enddo
!
    ! Déterminer le maximum des DX
    MaxDX=Maxval(DX)
    write(60,*) '------------------------------------------------------------------'
    write (60,"(A8,E9.3,A12,E9.3)") "MaxDX = ",MaxDX, " Epsillon = ",eps

    ! Comparer avec Eps
    if (MaxDX <= eps) then
        ! si petit terminer, imprimer resultats
        Cond=1
        write(60,*) '------------------------------------------------------------------'
        write(60,*) " Vecteur tension nodal à l'itération k= ", trim(Str(k))
        write(60,*) '------------------------------------------------------------------'
        write(60,*) '         V(I) (pu)               |V| (pu)     Theta (Deg)'
        write(60,*) '------------------------------------------------------------------'
        do i = 1, N
           write(60, "(A1,2F12.8,A6, F12.8, 2X, F12.8)") "(",V(i),"*i) - ", ModCmplx(V(i)), Argum(V(i))*180/pi
        enddo

        write(60,*) '------------------------------------------------------------------'
        ! Calcul du transit des puissance P et Q dans le réseau et des pertes avec les dernières corrections
        PL=0.
        QL=0.
        do i=1, N
           if (Typen(i) == "B") Then
                P(i) = CalcP(i)
                Q(i) = calcQ(i)
           elseif (Typen(i) == "G") Then
                Q(i) = CalcQ(i)
           end if
           PL = PL + P(i)
           QL = QL + Q(i)
        enddo

        ! Calcul du transit de puissances Spq
        Spq = 0.
        do i=1, N
           do j=1, N
              if (i /= j) Then
                  Spq(i, j) = (V(i) - V(j))*conjg((V(i) - V(j))*Ya(i, j) - Ys(i, j)*V(i))
                  Spq(j, i) = (V(j) - V(i))*conjg((V(j) - V(i))*Ya(i, j) - Ys(j, i)*V(j))
              end if
           end do
        end do

        ! Impression du transit de puissance et des pertes par transmission
        write(60, "(A,F9.3,A5)") "            Tableau des puissances nodales  (pu), Sbase = ", Sbase, " MVA."
        write(60, *) "------------------------------------------------------------------------------------"
        write(60, *) "|       Si         |      Pgi     |      Qgi      |      Pdi     |       Qdi       |"
        write(60, *) "------------------------------------------------------------------------------------"
        AFmt = "(A2,2F9.3,A1,F14.8,A1,F15.8,A1,F14.8,A1,F17.8,A1)"
        do i=1, N
            write(60, AFmt) "|", Cmplx(P(i),Q(i)), "|", Real(Sg(i)), "|", Imag(Sg(i)), "|", &
            &Real(Sd(i)), "|", Imag(Sd(i)), "|"
        end do
        write(60, "(A)") "          Tableau des puissances transmises  (pu)"
        write(60, *) "------------------------------------------------------------------------------------"
        write(60, *) "| i | j |        Sij (pu)        |        Sij (pu)        |        SLij (pu)       |"
        write(60, *) "------------------------------------------------------------------------------------"
        AFmt = "(A2,I3,A1,I3,A1,2F12.8,A1,2F12.8,A1,2F12.8,A1)"
        do i=1, N
            do j=i+1, N
                write(60, AFmt) "|", i,"|",j,"|",Spq(i,j),"|",Spq(j,i),"|",(Spq(i,j)-Spq(j,i)),"|"
            end do
        end do
        write(60, *) "------------------------------------------------------------------------------------"
        write(60, "(A)") "              Pertes par transmission  (pu)"
        write(60, *) "------------------------------------------------------------------------------------"
        write(60,*) "           ", Cmplx(PL, QL)
        write(60, *) "------------------------------------------------------------------------------------"
        call cpu_time ( t2 )
        write(*, "(A,f6.3)") "Arrêt des traitement à ", t2
        print*, '=================================================================='
        write(60, "(A,f6.3,A)") "Arrêt des traitement à ", t2, " s"
    else    ! sinon refaire le calcul Jacob Ja
        k=k+1
    end if
    !Cond=1
enddo ! Fin de la boucle

! Fin du programme Newton raphson pour le calcul du Load Flow
write(*,"(A,f6.3,A2)") "Durée du traitement est évaluée à ", (t2 - t1), " s"
write(60, "(A,f6.3,A2)") "Durée du traitement est évaluée à ", (t2 - t1), " s"
write(60,*) '=================================================================='
! Impression des résultats ans le fichier de sortie (60)
!
Close(50)
Close(60)

contains

    ! Fonction de calcul de la amatrice admittance Ya
    Subroutine CalcYa()
        Integer :: w, i_, j_

        do w=1,NB
            i_ = Nfrom(w)
            j_ = Nto(w)
            Ya(i_,j_)=-1/Z(i_,j_)
            ! ce ne sont pas les meme valeurs, Yii et Yjj
            Ya(i_,i_)=Ya(i_,i_)+(-Ya(i_,j_)+Ys(i_,j_)/2)
            Ya(j_,j_)=Ya(j_,j_)+(-Ya(i_,j_)+Ys(i_,j_)/2)
            Ya(j_,i_)=Ya(i_,j_)
            Z(j_,i_)=Z(i_,j_)
        end do
    end Subroutine

    ! Fonction du calcul de la puissance active
    Real function calcP(iI)
        integer :: ik, k_
        integer, intent(IN) :: iI
        Real :: S

        S = 0.
        Do ik = 1, N
           k_ = Indx(ik)
           S = S + ModCmplx(V(k_))*(YG(iI,k_)*cos(Teta(iI,k_)) + YB(iI,k_)*sin(Teta(iI,k_)))
        enddo
        calcP = ModCmplx(V(iI))*S
    end function

    ! Fonction du calcul de la puissance réactive
    Real function calcQ(iI)
        integer :: ik, k_
        integer, intent(IN) :: iI
        Real :: S

        S = 0.
        Do ik = 1, N
           k_ = Indx(ik)
           S = S + ModCmplx(V(k_))*(YG(iI,k_)*sin(Teta(iI,k_)) - YB(iI,k_)*cos(Teta(iI,k_)))
        enddo
        calcQ = ModCmplx(V(iI))*S
    end function

    ! Fonction du calcul du module de la tension nodale en un noeud
    Real function ModCmplx(z)
        complex, intent(IN) :: z

        !ModCmplx = (sqrt(Real(z)**2 + imag(z)**2))
        ModCmplx = (cabs(z))
    end function ModCmplx

    ! Fonction du calcul de l'argument de la tension nodale en un noeud
    Real function Argum(z)
        real :: theta

        complex, intent(IN) :: z

        theta = atan(imag(z)/real(z))
        !Argum = (theta*180)/pi
        Argum = theta
    end function
    !
    ! Fonction du calcul de la solution du système AX=B selon GAUSS
    Subroutine GaussMat(Jaa, Bb, Xx, Nn)

        integer, intent(IN) :: Nn
        Real, intent(IN) :: Jaa(:,:), Bb(:)
        Real, allocatable, intent(OUT) :: Xx(:)

        Real, allocatable, Dimension(:,:) :: Aa
        integer :: ii, ij, ik
        Real :: Xsum, xmult
        !character(len=40) :: A3Fmt

        ! Formation de la matrice a = [Jaa | I]
        allocate(Aa(Nn,Nn+1), Xx(Nn))

        Xx=0.
        Aa=0.
        do ii=1, Nn
            do ij=1, Nn+1
               Aa(ii,ij) = Jaa(ii,ij)
            end do
            Aa(ii, Nn+1) = Bb(ii)
        end do

        ! Elimination de Gauss
        do ik = 1, Nn-1
           do ii = ik+1, Nn
              xmult = Aa(ii, ik) / Aa(ik, ik)
              Aa(ii, ik) = 0.
              do ij = ik+1, Nn+1
                 Aa(ii, ij) = Aa(ii, ij) - xmult * Aa(ik, ij)
              end do
           end do
        end do

        Xx(Nn) = Aa(Nn, Nn+1) / Aa(Nn, Nn)
        do ii = Nn-1, 1, -1
           Xsum = 0.
           do ij= ii+1, Nn
              Xsum = Xsum + Aa(ii, ij) * Xx(ij)
           end do
           Xx(ii) = (Aa(ii, Nn+1) - Xsum) / Aa(ii, ii)
        end do

        deallocate(Aa)
    End Subroutine

    ! Procédure d'inversion matrice selon GAUSS-JORDAN
    Subroutine InvMat(Aa, Cc, Nn)
        !implicit none

        integer, Intent(IN) :: Nn
        Real, Intent(INOUT) :: Aa(Nn,Nn)

        Real, Intent(OUT) :: Cc(Nn,Nn)
        Real :: L(Nn,Nn), U(Nn,Nn), b(Nn), d(Nn), Xx(Nn)
        Real :: coeff
        integer ii, ij, ik

        L = 0.0
        U = 0.0
        b = 0.0

        do ik = 1, Nn-1
           do ii = ik+1, Nn
              coeff = Aa(ii,ik) / Aa(ik,ik)
              L(ii,ik) = coeff
              do ij = ik + 1, Nn
                 Aa(ii,ij) = Aa(ii,ij) - coeff*Aa(ik,ij)
              end do
           end do
        end do

        do ii = 1, Nn
          L(ii,ii) = 1.0
        end do

        do ij = 1, Nn
          do ii = 1, ij
            U(ii, ij) = Aa(ii,ij)
          end do
        end do

        do ik = 1, Nn
          b(ik) = 1.0
          d(1) = b(1)
          do ii = 2, Nn
            d(ii) = b(ii)
            do ij = 1, ii-1
              d(ii) = d(ii) - L(ii,ij)*d(ij)
            end do
          end do
          Xx(Nn)=d(Nn)/U(Nn,Nn)
          do ii = Nn-1, 1, -1
            Xx(ii) = d(ii)
            do ij = n, ii+1, -1
              Xx(ii) = Xx(ii) - U(ii, ij)*Xx(ij)
            end do
            Xx(ii) = Xx(ii)/U(ii,ii)
          end do
          do ii = 1, Nn
            Cc(ii, ik) = Xx(ii)
          end do
          b(ik)=0.0
        end do
    end subroutine InvMat
    !
    ! Function de calcul de dP/dTeta ii
    Real function DP_Dtetaii(ii, Nn)
        Integer, intent(IN) :: ii, Nn
        integer :: ij, j_
        Real :: S

        S = 0.
        do ij = 1, Nn
           j_ = Indx(ij)
           if (ii /= j_) then
               S = S + ModCmplx(V(j_))*(YB(ii,j_)*cos(Teta(ii,j_)) - YG(ii,j_)*sin(teta(ii,j_)))
           endif
        enddo
        DP_Dtetaii = S*ModCmplx(V(ii))
    end function

    ! Function de calcul de dP/dTeta ij
    Real function DP_Dtetaij(ii, ij)
        Integer, intent(IN) :: ii, ij

        DP_Dtetaij = ModCmplx(V(ii))*ModCmplx(V(ij))*(YG(ii,ij)*sin(teta(ii,ij)) - YB(ii,ij)*cos(teta(ii,ij)))
    end function

    ! Function de calcul de dQ/dTeta ii
    Real function DQ_Dtetaii(ii, Nn)
        Integer, intent(IN) :: ii, Nn

        Integer :: ij,j_
        Real :: S

        S=0.
        do ij=1,Nn
           j_ = Indx(ij)
           if (ii/=j_) then
               S = S + ModCmplx(V(j_))*(YG(ii,j_)*cos(teta(ii,j_)) + YB(ii,j_)*sin(teta(ii,j_)))
           endif
        enddo
        DQ_Dtetaii = CalcP(ii) - YG(ii,ii)*(ModCmplx(V(ii))**2)
    end function

    ! Function de calcul de dQ/dTeta ij
    Real function DQ_Dtetaij(ii, ij)
        Integer, intent(IN) :: ii, ij

        DQ_Dtetaij = - ModCmplx(V(ii))*ModCmplx(V(ij))*(YG(ii,ij)*cos(teta(ii,ij)) + YB(ii,ij)*sin(teta(ii,ij)))
    end function

    ! Function de calcul de dP/dMod ii
    Real function DP_DModVii(ii, Nn)
        Integer, intent(IN) :: ii, Nn

        Integer :: ij, j_
        Real :: S

        S=0.
        do ij=1,Nn
           j_ = Indx(ij)
           if (ii/=j_) then
               S = S + ModCmplx(V(j_))*(YG(ii,j_)*cos(teta(ii,j_)) + YB(ii,j_)*sin(teta(ii,j_)))
           endif
        enddo
        DP_DModVii = ModCmplx(V(ii))*S + 2*YG(ii,ii)*(ModCmplx(V(ii)))**2
    end function

    ! Function de calcul de dP/dMod ij
    Real function DP_DModVij(ii, ij)
        Integer, intent(IN) :: ii, ij

        DP_DModVij = ModCmplx(V(ii))*ModCmplx(V(ij))*(YG(ii,ij)*cos(teta(ii,ij)) + YB(ii,ij)*sin(teta(ii,ij)))
    end function

    ! Function de calcul de dQ/dMod ii
    Real function DQ_DModVii(ii, Nn)
        Integer, intent(IN) :: ii, Nn

        Integer :: ij, j_
        Real :: S

        S = 0.
        do ij=1, Nn
           j_ = Indx(ij)
           if (ii /= j_) then
               S = S + ModCmplx(V(j_))*(YG(ii,j_)*sin(teta(ii,j_)) - YB(ii,j_)*cos(teta(ii,j_)))
           endif
        enddo
        DQ_DModVii = ModCmplx(V(ii))*S - 2*YB(ii,ii)*(ModCmplx(V(ii)))**2
    end function

    ! Function de calcul de dP/dMod ij
    Real function DQ_DModVij(Ii, Ji)
        Integer, intent(IN) :: Ii, Ji

        DQ_DModVij = ModCmplx(V(Ii))*ModCmplx(V(Ji))*(YG(Ii,Ji)*sin(teta(Ii,Ji)) - YB(Ii,Ji)*cos(teta(Ii,Ji)))
    end function

    ! Fonction de calcul de la diférence des arguments de deux tensions nodale
    Real function Teta(Ii,Ji)
        Integer, intent(IN) :: Ii,Ji

        Teta = Argum(V(Ii)) - Argum(V(Ji))
    end function

    ! Fonction Import de données à partir de fichier CDF (Common Data Format)
    subroutine CDFImport1(f_)
        !implicit none

        Integer, Intent(In) :: f_
        character(len=200) :: a_

        ! Lecture des informations de la première section (Identification du réseau)
        read(f_,'(A)') a_
        !NName = adjustl(a_(11:30))
        NName = adjustl(a_(46:73))
        SBase = Str2float(a_(32: 37))

        ! Lecture de la deuxième section (Pas importante) mention du nombre de neuds dans le réseau.
        read(f_, '(A)') a_
        N = Str2int(a_(30: 46))
    end subroutine CDFImport1

    subroutine CDFImport2(f_)

        Integer, Intent(In) :: f_
        Integer :: ii, t_, inn = 0
        character(len=200) :: a_
        Real :: Pd_, Qd_, Pg_, Qg_

        ! Lecture de la troisième section, Données des noeuds
        loop1 : Do
           read(f_, "(A)") a_
           ii  = Str2Int(a_(1: 4))
           If (ii /= -999) then
               inn = inn +1
               ii  = Str2Int(a_(1: 4))
               t_ = Str2Int(a_(25: 26))
               If (t_ .le. 1) then
                  Typen(ii) = "C"
               elseif (t_ == 2) then
                  Typen(ii) = "G"
               else
                  Typen(ii) = "B"
               endif
               Pd_   = Str2Float(a_(41: 49))
               Qd_   = Str2Float(a_(50: 59))
               Pg_   = Str2Float(a_(60: 67))
               Qg_   = Str2Float(a_(68: 75))
               V(ii) = Str2Float(a_(28: 33))
               Sd(ii) = Cmplx(Pd_/Sbase, Qd_/Sbase)
               Sg(ii) = Cmplx(Pg_/Sbase, Qg_/Sbase)
           else
               exit loop1
           endif
           ! Affectation du nombre de noeuds, exact.
           N = inn
        enddo loop1

        ! Après detection de la fin de la section 3, lecture de la section quatrième : Données es lignes
        read(f_, '(A)') a_
        Nb = Str2Int(a_(30: 46))
    end subroutine CDFImport2

    subroutine CDFImport3(f_)
        Integer, Intent(In) :: f_
        Integer :: ii, jj, inb = 0
        character(len=200) :: a_
        Real :: r_ , x_

        loop2: Do
           read(f_, "(A)") a_
           ii  = Str2Int(a_(1: 4))
           If (ii /= -999) then
               inb = inb + 1
               Nfrom(inb) = ii
               jj = Str2Int(a_(6: 9))
               Nto(inb) = jj

               r_ = Str2Float(a_(20: 29))
               x_ = Str2Float(a_(30: 40))
               Z(ii, jj) = Cmplx(r_, x_)
               Ys(ii, jj) = Cmplx(0., Str2Float(a_(41: 50))/2)
           else
               exit loop2
           endif
        enddo loop2
    end subroutine CDFImport3

    Subroutine Mef()

    Integer :: i_
    !character(30) :: fm

        Indx = 0
        If (LookForCDF) Then
            ! Domaine du noeud Bilan B, un seul noeud.
            do i_= 1, N
               If (Typen(i_) == "B") Then
                   Indx(1) = i_
                   !Indx(i_) = 1
               endif
            enddo
            ! Domaine des noeuds générateurs, à partir de 2 (1 réservé au noeud Bilan).
            Ng=0
            do i_= 1, N
               if (Typen(i_) == "G") then
                   Ng = Ng +1
                   Indx(Ng + 1) = i_
                   !Indx(i_) = Ng + 1
               endif
            end do
            ! Domaine des neuds consommateurs, à partir de (Ng+1).
            Np=0
            do i_= 1, N
               If (Typen(i_) == "C") Then
                   Np = Np +1
                   Indx(Np + (Ng + 1)) = i_
                   !Indx(i_) = Np + (Ng + 1)
               end if
            end do
        else
           do i_ = 1, N
              Indx(i_) = i_
           enddo
        end if

!        fm = "(" // Str(Ng+1) // "(I3,2X))"
!        write(*, fm) (Indx(i_), i_=1,N)

    end Subroutine Mef

    Subroutine SaveImport(f_)
        implicit none

        character(len=100), intent(out) :: f_
        integer :: i_, j_, k_

        f_ = adjustl(trim(f_(1: len(f_)-4)) // trim(GenerateRndCar()) // ".dat")
        write(*,*) "Ecriture temporaire dans fichier conforme standard NMSS ..."

        open (unit=70, file=f_, action="write")
        ! Retrait de tous les espaces de Nname
        Call removesp(Nname)

        write(70, "(A,1X,I4,1X,I4,1X,F6.1)") Nname, N, NB, Sbase
        do i_=1,NB
!           j_ = Indx(Nfrom(i_))
!           k_ = Indx(Nto(i_))
           j_ = Nfrom(i_)
           k_ = Nto(i_)
           write(70, "(I4,1X,I4,1X,2F10.4,1X,2F10.4, I3,1X,I3)") Indx(j_), Indx(k_), Z(j_, k_), Ys(j_, k_)
        enddo
        do j_ = 1, N
           i_ = Indx(j_)
           if (Typen(i_) == "B") Then
                write(70, "(A1,1X,F9.3, 1X, F9.3, 1X, I4)") Typen(i_), ModCmplx(V(i_)), Argum(V(i_)), i_
           elseif (Typen(i_) == "G") Then
                write(70, "(A1,1X,F9.3, 1X, F9.3, 1X, I4)") Typen(i_), ModCmplx(V(i_)), Real(Sg(i_)), i_
           elseif (Typen(i_) == "C") Then
                write(70, "(A1,1X,F9.3, 1X, F9.3, 1X, I4)") Typen(i_), Real(Sd(i_)), Imag(Sd(i_)), i_
           endif
        enddo
        write(70, "(F10.6,1X,I4)") eps, Kmax
        print*, "Fermeture du fichier temporaire ..."
        close(70)
    End Subroutine

    subroutine Removesp(str)
    implicit none

    character(len=*):: str
    character(len=1):: ch
    character(len=len_trim(str))::outstr
    integer :: i_, k_, ich, lenstr

    str=adjustl(str)
    lenstr=len_trim(str)
    outstr=' '
    k_=0

    do i_=1,lenstr
      ch=str(i_:i_)
      ich=iachar(ch)
      select case(ich)
        case(0:32)  ! space, tab, or control character
             cycle
        case(33:)
          k_=k_+1
          outstr(k_:k_)=ch
      end select
    end do

    str=adjustl(outstr)
    end subroutine Removesp

    character(len=30) Function GenerateRndCar()
        implicit none

        real :: r_ = 2008.1960

        call RANDOM_NUMBER(r_)
        GenerateRndCar = Adjustl(Str(floor(r_*10000)))

    end function

end program newtonrap


res = PRODUCT(x)**(1._prec/REAL(SIZE(x),prec))


! { dg-do run }
! { dg-options "-O2 -ftree-vectorize -ffast-math" }
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
SUBROUTINE T(nsubcell,sab_max,subcells)
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
  REAL(dp) :: sab_max(3), subcells,nsubcell(3)
  nsubcell(:) = MIN(MAX(1,NINT(0.5_dp*subcells/sab_max(:))),20)
END SUBROUTINE T

INTEGER, PARAMETER :: dp=KIND(0.0D0)
REAL(dp) :: sab_max(3), subcells,nsubcell(3)
subcells=2.0_dp
sab_max=0.590060749244805_dp
CALL T(nsubcell,sab_max,subcells)
IF (ANY(nsubcell.NE.2.0_dp)) STOP 1
END


module runge_kutta_mod
  use object_space_mod

contains

  subroutine run_runge_kutta(list, timescale, siz, steps, output_file, everyNth)
    implicit none
    integer, intent(in) :: siz, steps, everyNth
    real, intent(in) :: timescale
    character(LEN=100), intent(in) :: output_file
    integer :: i, j, x
    type(object_space), intent(inout) :: list(siz)

    open(unit=1, file=output_file, status='replace')

    write(1,*) siz
    write(1,*) (steps / everyNth)

    do j=1, steps

!Calculate acceleration
      do x=1, siz
        call total_acceleration(x, siz, list)
      end do

!Calculate runge_kutta
      do i=1, siz

        call calculate_runge_kutta(i, list, timescale, siz)

!Write position
        if (MOD(j, everyNth) == 1) then
          do x=1, siz
            write(1,*) list(x)%pos(1)
            write(1,*) list(x)%pos(2)
            write(1,*) list(x)%pos(3)
          end do
        end if
      end do

    end do

    close(unit=1, status='keep')

  end subroutine

!Calculate the the position
  subroutine calculate_runge_kutta(object, list, timescale, siz)
    implicit none
    integer, intent(in) :: object, siz
    real, intent(in) :: timescale
    real :: ax, ay, bx, by, cx, cy, dx, dy, velx, vely, posx, posy
    type(object_space), intent(inout) :: list(siz)

    list(object)%vel(1) = list(object)%vel(1) + list(object)%acc(1)*timescale
    list(object)%vel(2) = list(object)%vel(2) + list(object)%acc(2)*timescale

    velx = list(object)%vel(1)
    vely = list(object)%vel(2)
    posx = list(object)%pos(1)
    posy = list(object)%pos(2)

    ax = velx
    ay = vely

    list(object)%pos(1) = list(object)%pos(1) + 0.5 *timescale * ax
    list(object)%pos(2) = list(object)%pos(2) + 0.5 *timescale * ay

    call total_acceleration(object, siz, list)

    bx = list(object)%vel(1) + list(object)%acc(1) * timescale
    by = list(object)%vel(2) + list(object)%acc(2) * timescale

    list(object)%pos(1) = list(object)%pos(1) + 0.5 *timescale * bx
    list(object)%pos(2) = list(object)%pos(2) + 0.5 *timescale * by

    call total_acceleration(object, siz, list)

    cx = list(object)%vel(1) + list(object)%acc(1) * timescale
    cy = list(object)%vel(2) + list(object)%acc(2) * timescale

    list(object)%pos(1) = list(object)%pos(1) + timescale * cx
    list(object)%pos(2) = list(object)%pos(2) + timescale * cy

    dx = list(object)%vel(1) + cx * timescale
    dy = list(object)%vel(2) + cy * timescale

    list(object)%pos(1) = posx + timescale * (ax + 2 * bx + 2 * cx + dx) / 6
    list(object)%pos(2) = posy + timescale * (ay + 2 * by + 2 * cy + dy) / 6

  end subroutine calculate_runge_kutta

end module runge_kutta_mod


      SUBROUTINE GETACT (N,M,AMAT,B,NACT,IACT,QFAC,RFAC,SNORM,
     1  RESNEW,RESACT,G,DW,VLAM,W)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AMAT(N,*),B(*),IACT(*),QFAC(N,*),RFAC(*),
     1  RESNEW(*),RESACT(*),G(*),DW(*),VLAM(*),W(*)
C
C     N, M, AMAT, B, NACT, IACT, QFAC and RFAC are the same as the terms
C       with these names in SUBROUTINE LINCOB. The current values must be
C       set on entry. NACT, IACT, QFAC and RFAC are kept up to date when
C       GETACT changes the current active set.
C     SNORM, RESNEW, RESACT, G and DW are the same as the terms with these
C       names in SUBROUTINE TRSTEP. The elements of RESNEW and RESACT are
C       also kept up to date.
C     VLAM and W are used for working space, the vector VLAM being reserved
C       for the Lagrange multipliers of the calculation. Their lengths must
C       be at least N.
C     The main purpose of GETACT is to pick the current active set. It is
C       defined by the property that the projection of -G into the space
C       orthogonal to the active constraint normals is as large as possible,
C       subject to this projected steepest descent direction moving no closer
C       to the boundary of every constraint whose current residual is at most
C       0.2*SNORM. On return, the settings in NACT, IACT, QFAC and RFAC are
C       all appropriate to this choice of active set.
C     Occasionally this projected direction is zero, and then the final value
C       of W(1) is set to zero. Otherwise, the direction itself is returned
C       in DW, and W(1) is set to the square of the length of the direction.
C
C     Set some constants and a temporary VLAM.
C
      ONE=1.0D0
      TINY=1.0D-60
      ZERO=0.0D0
      TDEL=0.2D0*SNORM
      DDSAV=ZERO
      DO 10 I=1,N
      DDSAV=DDSAV+G(I)**2
   10 VLAM(I)=ZERO
      DDSAV=DDSAV+DDSAV
C
C     Set the initial QFAC to the identity matrix in the case NACT=0.
C
      IF (NACT .EQ. 0) THEN
          DO 30 I=1,N
          DO 20 J=1,N
   20     QFAC(I,J)=ZERO
   30     QFAC(I,I)=ONE
          GOTO 100
      END IF
C
C     Remove any constraints from the initial active set whose residuals
C       exceed TDEL.
C
      IFLAG=1
      IC=NACT
   40 IF (RESACT(IC) .GT. TDEL) GOTO 800
   50 IC=IC-1
      IF (IC .GT. 0) GOTO 40
C
C     Remove any constraints from the initial active set whose Lagrange
C       multipliers are nonnegative, and set the surviving multipliers.
C
      IFLAG=2
   60 IF (NACT .EQ. 0) GOTO 100
      IC=NACT
   70 TEMP=ZERO
      DO 80 I=1,N
   80 TEMP=TEMP+QFAC(I,IC)*G(I)
      IDIAG=(IC*IC+IC)/2
      IF (IC .LT. NACT) THEN
          JW=IDIAG+IC
          DO 90 J=IC+1,NACT
          TEMP=TEMP-RFAC(JW)*VLAM(J)
   90     JW=JW+J
      END IF
      IF (TEMP .GE. ZERO) GOTO 800
      VLAM(IC)=TEMP/RFAC(IDIAG)
      IC=IC-1
      IF (IC .GT. 0) GOTO 70
C
C     Set the new search direction D. Terminate if the 2-norm of D is zero
C       or does not decrease, or if NACT=N holds. The situation NACT=N
C       occurs for sufficiently large SNORM if the origin is in the convex
C       hull of the constraint gradients.
C
  100 IF (NACT .EQ. N) GOTO 290
      DO 110 J=NACT+1,N
      W(J)=ZERO
      DO 110 I=1,N
  110 W(J)=W(J)+QFAC(I,J)*G(I)
      DD=ZERO
      DO 130 I=1,N
      DW(I)=ZERO
      DO 120 J=NACT+1,N
  120 DW(I)=DW(I)-W(J)*QFAC(I,J)
  130 DD=DD+DW(I)**2
      IF (DD .GE. DDSAV) GOTO 290
      IF (DD .EQ. ZERO) GOTO 300
      DDSAV=DD
      DNORM=DSQRT(DD)
C
C     Pick the next integer L or terminate, a positive value of L being
C       the index of the most violated constraint. The purpose of CTOL
C       below is to estimate whether a positive value of VIOLMX may be
C       due to computer rounding errors.
C
      L=0
      IF (M .GT. 0) THEN
          TEST=DNORM/SNORM
          VIOLMX=ZERO
          DO 150 J=1,M
          IF (RESNEW(J) .GT. ZERO .AND. RESNEW(J) .LE. TDEL) THEN
              SUM=ZERO
              DO 140 I=1,N
  140         SUM=SUM+AMAT(I,J)*DW(I)
              IF (SUM .GT. TEST*RESNEW(J)) THEN
                  IF (SUM .GT. VIOLMX) THEN
                      L=J
                      VIOLMX=SUM
                  END IF
              END IF
          END IF
  150     CONTINUE
          CTOL=ZERO
          TEMP=0.01D0*DNORM
          IF (VIOLMX .GT. ZERO .AND. VIOLMX .LT. TEMP) THEN
              IF (NACT .GT. 0) THEN
                  DO 170 K=1,NACT
                  J=IACT(K)
                  SUM=ZERO
                  DO 160 I=1,N
  160             SUM=SUM+DW(I)*AMAT(I,J)
  170             CTOL=DMAX1(CTOL,DABS(SUM))
              END IF
          END IF
      END IF
      W(1)=ONE
      IF (L .EQ. 0) GOTO 300
      IF (VIOLMX .LE. 10.0D0*CTOL) GOTO 300
C
C     Apply Givens rotations to the last (N-NACT) columns of QFAC so that
C       the first (NACT+1) columns of QFAC are the ones required for the
C       addition of the L-th constraint, and add the appropriate column
C       to RFAC.
C
      NACTP=NACT+1
      IDIAG=(NACTP*NACTP-NACTP)/2
      RDIAG=ZERO
      DO 200 J=N,1,-1
      SPROD=ZERO
      DO 180 I=1,N
  180 SPROD=SPROD+QFAC(I,J)*AMAT(I,L)
      IF (J .LE. NACT) THEN
          RFAC(IDIAG+J)=SPROD
      ELSE
          IF (DABS(RDIAG) .LE. 1.0D-20*DABS(SPROD)) THEN
              RDIAG=SPROD
          ELSE
              TEMP=DSQRT(SPROD*SPROD+RDIAG*RDIAG)
              COSV=SPROD/TEMP
              SINV=RDIAG/TEMP
              RDIAG=TEMP
              DO 190 I=1,N
              TEMP=COSV*QFAC(I,J)+SINV*QFAC(I,J+1)
              QFAC(I,J+1)=-SINV*QFAC(I,J)+COSV*QFAC(I,J+1)
  190         QFAC(I,J)=TEMP
          END IF
      END IF
  200 CONTINUE
      IF (RDIAG .LT. ZERO) THEN
          DO 210 I=1,N
  210     QFAC(I,NACTP)=-QFAC(I,NACTP)
      END IF
      RFAC(IDIAG+NACTP)=DABS(RDIAG)
      NACT=NACTP
      IACT(NACT)=L
      RESACT(NACT)=RESNEW(L)
      VLAM(NACT)=ZERO
      RESNEW(L)=ZERO
C
C     Set the components of the vector VMU in W.
C
  220 W(NACT)=ONE/RFAC((NACT*NACT+NACT)/2)**2
      IF (NACT .GT. 1) THEN
          DO 240 I=NACT-1,1,-1
          IDIAG=(I*I+I)/2
          JW=IDIAG+I
          SUM=ZERO
          DO 230 J=I+1,NACT
          SUM=SUM-RFAC(JW)*W(J)
  230     JW=JW+J
  240     W(I)=SUM/RFAC(IDIAG)
      END IF
C
C     Calculate the multiple of VMU to subtract from VLAM, and update VLAM.
C
      VMULT=VIOLMX
      IC=0
      J=1
  250 IF (J .LT. NACT) THEN
          IF (VLAM(J) .GE. VMULT*W(J)) THEN
              IC=J
              VMULT=VLAM(J)/W(J)
          END IF
          J=J+1
          GOTO 250
      END IF
      DO 260 J=1,NACT
  260 VLAM(J)=VLAM(J)-VMULT*W(J)
      IF (IC .GT. 0) VLAM(IC)=ZERO
      VIOLMX=DMAX1(VIOLMX-VMULT,ZERO)
      IF (IC .EQ. 0) VIOLMX=ZERO
C
C     Reduce the active set if necessary, so that all components of the
C       new VLAM are negative, with resetting of the residuals of the
C       constraints that become inactive.
C
      IFLAG=3
      IC=NACT
  270 IF (VLAM(IC) .LT. ZERO) GOTO 280
      RESNEW(IACT(IC))=DMAX1(RESACT(IC),TINY)
      GOTO 800
  280 IC=IC-1
      IF (IC .GT. 0) GOTO 270
C
C     Calculate the next VMU if VIOLMX is positive. Return if NACT=N holds,
C       as then the active constraints imply D=0. Otherwise, go to label
C       100, to calculate the new D and to test for termination.
C
      IF (VIOLMX .GT. ZERO) GOTO 220
      IF (NACT .LT. N) GOTO 100
  290 DD=ZERO
  300 W(1)=DD
      RETURN
C
C     These instructions rearrange the active constraints so that the new
C       value of IACT(NACT) is the old value of IACT(IC). A sequence of
C       Givens rotations is applied to the current QFAC and RFAC. Then NACT
C       is reduced by one.
C
  800 RESNEW(IACT(IC))=DMAX1(RESACT(IC),TINY)
      JC=IC
  810 IF (JC .LT. NACT) THEN
          JCP=JC+1
          IDIAG=JC*JCP/2
          JW=IDIAG+JCP
          TEMP=DSQRT(RFAC(JW-1)**2+RFAC(JW)**2)
          CVAL=RFAC(JW)/TEMP
          SVAL=RFAC(JW-1)/TEMP
          RFAC(JW-1)=SVAL*RFAC(IDIAG)
          RFAC(JW)=CVAL*RFAC(IDIAG)
          RFAC(IDIAG)=TEMP
          IF (JCP .LT. NACT) THEN
              DO 820 J=JCP+1,NACT
              TEMP=SVAL*RFAC(JW+JC)+CVAL*RFAC(JW+JCP)
              RFAC(JW+JCP)=CVAL*RFAC(JW+JC)-SVAL*RFAC(JW+JCP)
              RFAC(JW+JC)=TEMP
  820         JW=JW+J
          END IF
          JDIAG=IDIAG-JC
          DO 830 I=1,N
          IF (I .LT. JC) THEN
              TEMP=RFAC(IDIAG+I)
              RFAC(IDIAG+I)=RFAC(JDIAG+I)
              RFAC(JDIAG+I)=TEMP
          END IF
          TEMP=SVAL*QFAC(I,JC)+CVAL*QFAC(I,JCP)
          QFAC(I,JCP)=CVAL*QFAC(I,JC)-SVAL*QFAC(I,JCP)
  830     QFAC(I,JC)=TEMP
          IACT(JC)=IACT(JCP)
          RESACT(JC)=RESACT(JCP)
          VLAM(JC)=VLAM(JCP)
          JC=JCP
          GOTO 810
      END IF
      NACT=NACT-1
      GOTO (50,60,280),IFLAG
      END


module zfun_hilbert
use types, only : rprec => dp
private
public :: zfun_hil_init, zfun_hil

! to get a double precision version, set n = 30 (or so)
! residuals are ~ 1.0e-14
integer, parameter ::  n = 32 ! number of eigenfunctions used in expansion
integer :: ierr ! error flag for fftpack
integer, parameter :: mult = 2! sample multiplyer--default is 2
integer, parameter :: m = mult * n! number of velocity function sample
integer, parameter :: lensav = 2 * m + int(log(real(2 * m))/log(2.0)) + 4
real(kind = rprec), parameter :: inv_m = 1.0_rprec / real(m, kind = rprec)
real(kind = rprec), dimension(2 * m) :: work
real(kind = rprec), dimension(lensav) ::  wsave
real(kind = rprec) :: length, & ! renormalization parameter--set by n
  d_theta ! theta grid increment
logical, save :: first_flag ! use for initialization
real(kind = rprec), parameter :: infinity = huge(1.0_rprec)
real(kind = rprec), parameter :: pi = 4.0_rprec * atan(1.0_rprec)
real(kind = rprec), dimension(:), allocatable :: &
  f_vel, & ! array of f values on velocity grid
  theta_grid, & ! theta grid-- -pi to pi - dtheta
  veloc_grid    ! grid of velocity values from vel = length * tan(theta/2.0)
                ! first value is -infinity, not actuall used--value of function will
                ! be set to zero.
complex(kind = rprec), dimension(:,:), allocatable ::   exp_m ! precomputed exponentials
complex(kind = rprec), dimension(:), allocatable :: an !array for eigenfunction expansion coefficents
real(kind = rprec), dimension(:), allocatable :: re_an
complex(kind = rprec), parameter :: zi = cmplx(0.0_rprec, 1.0_rprec)
contains
subroutine zfun_hil_init(ieer)
integer :: i
!print*, 'lensav = ', lensav, 'fft len = ', m
call rfft1i(2*m, wsave, lensav, ieer)
!print *, 'fft init '
!print *,  2*m, lensav
!do i = 1, lensav
!    print*, wsave(i)
!end do

!if(ieer .eq. 2) then
!    print *, 'input parameter lensav not big enough'
!    return
!end if
! move initial calculations to init
allocate(theta_grid(0:2 * m))
! a standard [0, 2*pi] grid will be used with an
! even number of intervals and an odd number to
! grid points.  all will be indexed [0,2*m]
! but the last on won't be used because of periodicity.
!print *, 'theta grid', 'points = ', 2*m + 1
d_theta = pi * inv_m
do i = 0, 2 * m
    theta_grid(i) = real(i, rprec) * d_theta
    !print *, i, theta_grid(i)
end do
! set the renormaliztion parameter
length = sqrt(real(n, rprec) * 0.7_rprec)
! fill the velocity grid
allocate(veloc_grid(0:2 * m ))
veloc_grid(0) = -infinity
veloc_grid(2 * m) = infinity
veloc_grid(1:2 * m - 1 ) = length * tan((theta_grid(1:2 * m - 1)  - pi) * 0.5_rprec)

! fill the function grid
allocate(f_vel(0:2 * m ))
! may need to truncate the fill for practical cases
! put zeros at the ends
f_vel(0) = 0.0_rprec
f_vel(2 * m) = 0.0_rprec
! and the rest
f_vel(1:2 * m -1) = exp(- veloc_grid(1:2 * m-1)**2) *  &
    (length**2 + veloc_grid(1:2 * m-1)**2)
!last term is takes out the weighting function in
!the hilbert transorm
!f_vel = 1.0_rprec
!do i = 0, 2 * m
!    print *, i, theta_grid(i), veloc_grid(i), f_vel(i)
!end do
!end do
!print *, ''
! ft f_vel
! compute the exponentials (not needed in general when using fft)
!allocate(exp_m(0:2 * m - 1, 0:2 * m - 1))
!do i = 0, 2 * m -1
!    do j = 0, 2 * m -1
!        exp_m(i, j) = exp(- zi * j * theta_grid(i))
!        !if(j .eq. 0) print*, exp_m(i, j)
!    end do
!end do

! get the coefficients--will use fft of real function ultimately
allocate(an(0:2 * m))
allocate(re_an(0:m))

an = cmplx(0.0_rprec, 0.0_rprec)
!do j = 0, 2 * m - 1
!    do i = 0, 2 * m - 1
!        an(j) = an(j) + exp_m(i, j) * f_vel(i)
!        ! for odd harmonics need to give the fft negative values
!        !if(j.eq.0) print*, an(j)
!    end do
!end do
! try and make the fftpack call
!print *, 'ier for fftf call = ', ieer!, sum(f_vel(0:2*m -1))/2.0_rprec/m
!print *, 'size of work ', size(work), 2 * m, size(f_vel(0:2 * m -1))
call rfft1f(2 * m, 1, f_vel(0:2 * m -1), 2 * m, wsave, lensav, &
    work, 2 * m, ieer)
!print *, 'ier for fftf call = ', ieer, sum(f_vel)
!print *, 'long, real fft ', j, an(0)* 0.5_rprec * inv_m, f_vel(0)
do j = 1, m
!    print *, 'long, real fft ', j, an(j) * inv_m, f_vel(2*j-1), f_vel(2*j)
!    an(j) = (-1)**j * an(j) * 0.5_rprec * inv_m
    !an(j) = (-1)**j * f_vel(2*j-1) * 0.5_rprec
    re_an(j) = (-1)**j * f_vel(2*j-1) * 0.5_rprec
    !  need to adjust signs because of coordinate shift from
    !  [-pi, pi] to [0, 2*pi] and remove the 2*m dtf normalization
    !  don't need to higher j's since they are aliased to negative
    !  frequencies
end do
!an(0) = an(0) * 0.5_rprec * inv_m
!an(m) = an(m) * 2.0_rprec
re_an(m) = 2.0_rprec * re_an(m)
!an(0) = cmplx(f_vel(0), kind = rprec)
re_an(0) = f_vel(0)
!re_an = real(an(0:m))
!print *, 'fourier coefficients'

return
end subroutine zfun_hil_init

subroutine zfun_hil(z_in, z_out, flag)
!  This routine computes the 'Z' function using an expansion of the
!  in the distribution function in eigenfunctions of the
!  eigenfunctions of the Hilbert transform.  These eigen functions,
!  when the integration variable is changed from +/1 infinity via a
!  y = tan(theta/2.0), are Fourier basis functions on the interval
!  [-pi, pi].  With this renormalized integration variable, the
!  coefficients in the eigenvalue expansions can be computed with
!  FFTs.  In addition, with the further normalizaton z = L*tan(theta/2),
!  the convergence can be made competitive with the classical three-region
!  algogrithm presented by GPM Poppe, CMJ Wigers:  More efficient
!  computation of the complex error function ACM Trans. Math. Software
!  Vol. 16, No. 1, pp.47 presented by Hammett, netlib, and used (until replaced
!  because of license restrictions) in scipy.  While the advantages maybe small
!  for CPU Maxwellian calcualtions, there are no if tests, except perhaps
!  for faults.  The present routine is only good in the upper half plane
!  including the real axis
!  version2--convert to ffts, first use fftpack
implicit none
complex(kind = rprec), intent(in) :: z_in
complex(kind = rprec), intent(out) :: z_out
logical, intent(out) :: flag
integer :: i   ! dummy index
complex(kind = rprec) :: z_poly, z_term, z_out2
real(kind = rprec) :: x_term, y_term, x_poly, y_poly, x_in, y_in, x_out, y_out, &
    x_sq, y_sq, len_sq, denom_in, denom, x_out_sav, z_mod_sq, denom_l_in
! check for allocations
z_term = (length + zi * z_in) / (length - zi * z_in)
!x_in = real(z_in); y_in = aimag(z_in)
!x_sq = x_in **2; y_sq = y_in**2; len_sq = length**2
!z_mod_sq = x_sq + y_sq
!denom = z_mod_sq + len_sq + 2.0_rprec * length * y_in
!denom_l_in = 1.0_rprec /( z_mod_sq * (x_sq - y_sq) - 2.0_rprec * len_sq * x_in * y_in)

!denom_in = 1.0_rprec / denom
!x_term = (len_sq - z_mod_sq) * denom_in
!y_term = 2.0_rprec * x_in * length * denom_in
!print *, z_term, x_term, y_term
z_out = re_an(m)
!x_out = re_an(m)
!y_out = 0.0_rprec

do i = m, 2, -1
    z_out = z_term * z_out + re_an(i -1)
    !x_out_sav = x_out
    !x_out = re_an(i-1) + x_term * x_out_sav - y_term * y_out
    !y_out = x_term * y_out + y_term * x_out_sav
end do
!print *, 'long/short ', z_out, x_out, y_out
!z_out = cmplx(x_out, y_out, kind = rprec)
z_out = 2.0_rprec * z_term * z_out / (length**2 + z_in**2)
z_out = z_out + re_an(0) / length / (length - zi * z_in)
!x_out_sav = x_out
!x_out = 2.0_rprec * (x_term * x_out - y_term * y_out) * denom_l_in
!y_out = 2.0_rprec * (x_term * y_out + y_term * x_out_sav) * denom_l_in
!x_out_sav = x_out
!x_out = x_out * (len_sq + x_sq + y_sq)
!y_out = -y_out * (x_in * y_in)
!x_out_sav = x_out
!x_out = x_out + re_an(0) / length /
!y_out = y_out * re_an(0) / length

!print *, an(0) / length * sqrt(pi)
!x_out_sav = x_out
!x_out = -sqrt(pi) * y_out
!Y_out = sqrt(pi) * x_out_sav
z_out = zi * sqrt(pi) * z_out
! set the flag for success
flag = .true.
if(aimag(z_in) .lt. 0.0_rprec) stop 'negative im(zeta)'
return

end subroutine zfun_hil

end module zfun_hilbert


      subroutine newint(nr,r,f,g,ip0)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c----- this routine integrates functn f on a 1-d mesh by interpolation
c      the partial integrals (up to r(k)) are stored in b(k).  the mesh
c      is arbitrary
c      xgz  ornl 1998
c
      implicit real*8 (a-h,o-z)
c
      real*8 r(nr),cr(4)
      real*8 f(nr),g(nr)
      real*8 fr(4),rs(4)
      parameter (nj=6,njm1=nj-1)
      parameter (dnj=1.d0/nj)
      parameter (wt0=2.d0/(3.d0*nj),wt1=3.d0*wt0)
c
      ip=2*ip0+1
      pip1=1.d0/dble(ip+1)
      pip2=1.d0/dble(ip+2)
      g(1)=0.d0
      i1=1
      i2=2
      i3=3
      i4=4
      i0=1
      do i=1,4
	rs(i)=sqrt(r(i))
	fr(i)=f(i)
      enddo
      ip1=1
      ip2=4
      do i=1,nr-1
	ip1=ip1+1

	if(i.gt.2.and.ip2.le.nr) then
	  rs(i4)=sqrt(r(ip2))
          fr(i4)=f(ip2)
	endif
        call fit(rs,fr,4,i0,cr)
c First integrate a linear frunction going through f(i) and f(ip1)
c A4=fi-A1
	rip1=rs(mod(i0,4)+1)
	gj=1.d0
	fj=rip1
	do j=1,ip
	  gj=gj*rs(i0)+fj
	  fj=fj*rip1
	enddo
	fj=(gj*rs(i0)+fj)*pip2
	gj=gj*pip1
	gr=(fr(i0)-cr(3)*rs(i0))*gj+cr(3)*fj
c Using Simpson's rule. No contribution from j=0 and j=nj.
	dr=rip1-rs(i0)
        h1=dnj*dr
	h2=0.d0
	wt=wt0
	do j=1,njm1
	  h2=h2+h1
	  wt=wt1-wt
	  fj=wt
	  rj=rs(i0)+h2
	  do k=1,ip
	    fj=fj*rj
	  enddo
	  gj=h2*(dr-h2)
	  c1=(cr(3)-cr(2))*h2+cr(1)
	  c2=cr(4)*gj
	  gr=gr-fj*c1*c2/(1.d0+c2)
	enddo
	g(ip1)=g(i)+2.d0*dr*gr
	if(i.gt.1.and.ip2.lt.nr) then
	  ip2=ip2+1
	  j=i1
	  i1=i2
	  i2=i3
	  i3=i4
	  i4=j
	endif
	i0=mod(i0,4)+1
      enddo
      return
      end


C$Procedure      LATSPH ( Latitudinal to spherical coordinates )

      SUBROUTINE LATSPH ( RADIUS, LONG, LAT,  RHO, COLAT, LONGS )

C$ Abstract
C
C     Convert from latitudinal coordinates to spherical coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   RADIUS
      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   LAT
      DOUBLE PRECISION   RHO
      DOUBLE PRECISION   COLAT
      DOUBLE PRECISION   LONGS

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RADIUS     I   Distance of a point from the origin.
C     LONG       I   Angle of the point from the XZ plane in radians.
C     LAT        I   Angle of the point from the XY plane in radians.
C     RHO        O   Distance of the point from the origin.
C     COLAT      O   Angle of the point from positive Z axis (radians).
C     LONGS      O   Angle of the point from the XZ plane (radians).
C
C$ Detailed_Input
C
C     RADIUS     Distance of a point from the origin.
C
C     LONG       Angle of the point from the XZ plane in radians.
C
C     LAT        Angle of the point from the XY plane in radians.
C
C$ Detailed_Output
C
C     RHO        Distance of the point from the origin.
C
C     COLAT      Angle between the vector from the origin to the point
C                and the positive Z axis in radians. COLAT is computed
C                as PI/2 - LAT.
C
C     LONGS      Angle of the point from the XZ plane (radians). LONGS
C                is set equal to LONG.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the spherical coordinates of a point
C     whose position is input in latitudinal coordinates.
C
C     Latitudinal coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     above the equator of a sphere centered at the central reference
C     point.
C
C     Spherical coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     from the z-axis.
C
C$ Examples
C
C     Co-latitude is obtained by subtracting latitude from HALFPI()
C     Radius and longitude mean the same thing in both latitudinal
C     and spherical coordinates.  The table below lists LAT
C     corresponding COLAT in terms of degrees.
C
C             LAT            COLAT
C            ------         ------
C              0             90
C             20             70
C             45             45
C            -30            120
C             90              0
C            -45            135
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     latitudinal to spherical coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      HALFPI

C
C     Local Variables
C
      DOUBLE PRECISION TH
      DOUBLE PRECISION PH

C
C     Convert to spherical coordinates, storing the results in
C     temporary variables
C
      TH = HALFPI() - LAT
      PH = LONG

C
C     Move results to output variables
C
      RHO   = RADIUS
      COLAT = TH
      LONGS = PH

      RETURN
      END


 FUNCTION RAN1_b(IDUM)
   implicit none
   integer idum,ia,im,iq,ir,ntab,ndiv
   real ran1_b,am,eps,rnmx
   parameter(ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836,      &
        ntab=32,ndiv=1+(im-1)/ntab,eps=1.2e-7,rnmx=1.-eps)

! Minimal random number generator of Park and Miller with Bays-Durham
! shuffle and added safeguards.  Returns a uniform random deviate between
! 0.0 and 1.0 (exclusive of the endpoint values.)  Call with idum a negative
! integer to initialize; thereafter, do not alter idum between successive
! deviates in a sequence.  tnmx should approximate the largest floating
! value that is less than 1.  From Numerical Recipes.

   integer j,k,iv(ntab),iy
   save iv,iy
   data iv /ntab*0/, iy /0/
   if(idum.le.0.or.iy.eq.0)then
      idum=max(-idum,1)
      do j=ntab+8,1,-1
         k=idum/iq
         idum=ia*(idum-k*iq)-ir*k
         if(idum.lt.0) idum=idum+im
         if(j.le.ntab) iv(j)=idum
      end do
      iy=iv(1)
   end if
   k=idum/iq
   idum=ia*(idum-k*iq)-ir*k
   if(idum.lt.0) idum=idum+im
   j=1+iy/ndiv
   iy=iv(j)
   iv(j)=idum
   ran1_b=min(am*iy,rnmx)
   return
 END FUNCTION RAN1_B


      subroutine eemd(LXY,indata,An,Nesb,Nm,idum,rslt)
!-----------------------------------------------------------------------------
! This is a subroutine to decompose data(LXY) in terms of its EEMD component.
! When the added noise amplitude is zero (An=0) and the ensemble number
! is one (Nesb=0), the code degenerates to standard EMD
!
! In this code, the number of the oscillatory components is specified as an
! input, Nm. For most cases, automatic calculation, Nm can be set to log2(LXY)-2
!
! INPUT DATA:
!		indata(LXY)		input array with a length of LXY
!  		An 			amplitude of added noise
!  		Nesb 			number of ensemble members
!  		Nm 			number of mode in each decomposition
!  		idum 			seed for the random number
! OUTPUT DATA:
!  		rslt(LXY, Nm+2) 	output rseults, which contains Nm+2 columns
!					The first column is the origninal indata;
!					The second column is the first component;
!					The third column is the second component;
!					and so on
!					The last column is the residue
!-------------------------------------------------------------------------------
      implicit none
      INCLUDE 'eemd.common'
      real :: An				! noise amplitude
      integer, intent(in) :: LXY, Nesb, Nm
      integer, intent(inout):: idum
      real, dimension(LXY), intent(in) :: indata
      real, dimension(LXY) :: ximf		! data for sifting
      real, dimension(LXY) :: spmax		! upper envelope, cubic spline
      real, dimension(LXY) :: spmin		! lower envelope, cubic spline
      real, dimension(LXY) :: ave		! the average of spmax and spmin
      real, dimension(LXY) :: remp		! the input data for sifting
      real, dimension(LXY) :: rem		! the remainder (remp-ximf)

      real, dimension(LXY,Nm+2) :: rslt		! the final output data
      real, dimension(LXY,Nm+2) :: allmode	! the results of a single EMD decomposition

      integer :: nmax, nmin			! numbers of maximum and minimum
      real, dimension(LXY) :: trend		! linear trend of indata
      real :: std		! standard deviation of the linearly detrended indata
      integer:: i,j,IE,im,ii
      real :: fNesb, gasdev

!  initialize the output
      rslt=0.0

!
!  ensemble EMD
!
!  *******************************************************
      do IE=1,Nesb
!  *******************************************************
!
        call standev(LXY,indata,trend, std)

!  inputted data + noise
        if(Nesb.eq.1) then
          ximf=indata
        else
          do i=1,LXY
            ximf(i)=indata(i)+An*std*gasdev(idum)
          enddo
        endif

!  save modified data
        do i=1,LXY
          allmode(i,1)=ximf(i)
        enddo

!  calculate modes
!       =======================================================
        do im=1,Nm
!       =======================================================
!
!  leave a copy of the input data before IMF is calculated
          remp=ximf
!
!  Sifting
!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          do ii=1,10
!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

            call min_max(LXY,ximf,spmax,spmin,nmax,nmin)
            call natural_spline(spmax,LXY,nmax)
            call natural_spline(spmin,LXY,nmin)

            ave=(spmax+spmin)/2.0
            ximf=ximf-ave

!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          enddo
!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

          rem=remp-ximf

          do i=1,LXY
            allmode(i,im+1)=ximf(i)
          enddo

          ximf=rem

!       =======================================================
        enddo
!       =======================================================

        do i=1,LXY
          allmode(i,Nm+2)=ximf(i)
        enddo

        do j=1,Nm+2
          do i=1,LXY
            rslt(i,j)=rslt(i,j)+allmode(i,j)
          enddo
        enddo

!     ---------------------------------------------------------
      enddo
!     ---------------------------------------------------------

      fNesb=real(Nesb)
      rslt=rslt/fNesb

      end subroutine eemd


module mat_lib
 interface matinv
  module procedure matinv_d,matinv_z
 end interface
 private :: matinv_d,matinv_z,matinv_svd_d,matinv_svd_z

 interface eye
  module procedure eye_d1, eye_z1, eye_d2,eye_z2
 end interface
 interface laplace
  module procedure laplace_d2,laplace_z2
 end interface

contains
 subroutine matinv_d(a,ainv,alg,tol)
  implicit none
  double precision,intent(inout)  :: a(:,:)
  double precision,intent(out),optional :: ainv(size(a,2),size(a,1))
  character(len=1),intent(in),optional :: alg
  double precision,intent(in),optional :: tol
  character(len=*),parameter   :: subnam='matinv_d'
  if(.not.present(alg) .or. size(a,1).ne.size(a,2))then
   call matinv_svd_d(a,ainv,tol)
  else
   select case(alg)
    case('s','S')
     call matinv_svd_d(a,ainv,tol)
    case('t','T')
     call matinv_lu_d(a,ainv)
    case default
     write(*,'(3a)')subnam,': unknown alg: ',alg
     stop
   end select
  end if
  return
 end subroutine
 subroutine matinv_z(a,ainv,alg,tol)
  implicit none
  complex(8),intent(inout)  :: a(:,:)
  complex(8),intent(out),optional :: ainv(size(a,2),size(a,1))
  character(len=1),intent(in),optional :: alg
  double precision,intent(in),optional :: tol
  character(len=*),parameter   :: subnam='matinv_z'
  if(.not.present(alg) .or. size(a,1).ne.size(a,2))then
   call matinv_svd_z(a,ainv,tol)
  else
   select case(alg)
    case('s','S')
     call matinv_svd_z(a,ainv,tol)
    case('t','T')
     call matinv_lu_z(a,ainv)
    case default
     write(*,'(3a)')subnam,': unknown alg: ',alg
     stop
   end select
  end if
  return
 end subroutine

 subroutine matinv_svd_d(a,ainv,tol)
  implicit none
  double precision,intent(inout)  :: a(:,:)
  double precision,intent(out),optional :: ainv(size(a,2),size(a,1))
  double precision,intent(in),optional :: tol
  character(len=*),parameter   :: subnam='matinv_svd_d'
  double precision,allocatable :: b(:,:),u(:,:),v(:,:),s(:),work(:)
  integer :: r,lwork,info,i,ntrunc,m,n
  double precision :: si,s1,small
  character(len=180) :: str

  m=size(a,1); n=size(a,2)
  if(present(tol))then;small=tol;else;small=1.d-14;endif
  write(str,'(a,a,i8,1x,i8)')subnam,': m,n:',m,n
  !call plog(2,str)
  r=min(m,n); lwork=64*max(m,n)
  allocate(b(m,n),u(m,r),v(r,n),s(r),work(lwork))
  b=a
  call dgesvd('s','s',m,n,b,m,s,u,m,v,r, work,lwork,info)
  if(info.ne.0)then
   write(*,'(a,a,i10)')subnam,': dgesvd info: ',info
   stop
  end if

  s1=s(1)
  !write(str,'(a,80(e9.3,1x))')'sv:',(fmem(s+i)/s1,i=1,r)
  !call plog(1,str)

  ntrunc=0
  do i=1,r
   si=s(i)
    if(si.lt.small*s1)then
     s(i)=0.d0; ntrunc=ntrunc+1
    else
     s(i)=1.d0/s(i)
    end if
  end do

  forall(i=1:r)u(:,i)=u(:,i)*s(i)
  if(present(ainv))then
   call dgemm('t','t',n,m,r,1.d0,v,r,u,m,0.d0,ainv,n)
  else
   call dgemm('t','t',n,m,r,1.d0,v,r,u,m,0.d0,a,n)
  end if
  if(ntrunc.gt.0)then
   write(*,'(a,a,i5,a,i5)')subnam,': truncate: ',ntrunc,' of: ',r
   !call plog(1,str)
  end if

  deallocate(b,u,v,s,work)
  return
 end subroutine
 subroutine matinv_svd_z(a,ainv,tol)
  implicit none
  complex(8),intent(in)  :: a(:,:)
  complex(8),intent(out) :: ainv(size(a,2),size(a,1))
  double precision,intent(in),optional :: tol
  character(len=*),parameter   :: subnam='matinv_svd_z'
  complex(8),allocatable   :: b(:,:),u(:,:),v(:,:),work(:)
  double precision,allocatable :: s(:),rwork(:)
  integer :: r,lwork,lrwork,info,i,ntrunc,m,n
  double precision :: small=1.d-14
  double precision :: si,s1
  character(len=180) :: str

  m=size(a,1); n=size(a,2)
  if(present(tol))small=tol
  write(str,'(a,a,i8,1x,i8)')subnam,': m,n:',m,n
  !call plog(2,str)
  r=min(m,n); lwork=64*max(m,n); lrwork=5*min(m,n)
  allocate(b(m,n),u(m,r),v(n,r),s(r),work(lwork),rwork(lrwork))
  b=a
  call zgesvd('s','s',m,n,b,m,s,u,m,v,n,work,lwork,rwork,info)
  if(info.ne.0)then
   write(*,'(a,a,i10)')subnam,': zgesvd info: ',info
   stop
  end if

  s1=s(1)
  !write(str,'(a,80(e9.3,1x))')'sv:',(fmem(s+i)/s1,i=1,r)
  !call plog(1,str)

  ntrunc=0
  do i=1,r
   si=s(i)
    if(si.lt.small*s1)then
     s(i)=0.d0; ntrunc=ntrunc+1
    else
     s(i)=1.d0/s(i)
    end if
  end do

  forall(i=1:r)u(:,i)=u(:,i)*s(i)
  call zgemm('c','c',n,m,r,(1.d0,0.d0),v,r,u,m,(0.d0,0.d0),ainv,n)
  if(ntrunc.gt.0)then
   write(str,'(a,a,i5,a,i5)')subnam,': truncate: ',ntrunc,' of: ',r
   !call plog(1,str)
  end if

  deallocate(b,u,v,s,work,rwork)
  return
 end subroutine

 subroutine matinv_lu_d(a,ainv)
  implicit none
  double precision,intent(inout)  :: a(:,:)
  double precision,intent(out),optional :: ainv(size(a,2),size(a,1))
  character(len=*),parameter   :: subnam='matinv_lu_d'
  double precision,allocatable :: work(:)
  double precision,dimension(:,:),pointer :: aa
  target  :: a,ainv
  integer :: lwork,m,n,info
  integer,allocatable :: piv(:)
  m=size(a,1); n=size(a,2)
  if(m.ne.n)then
   write(*,*)subnam,': matrix not square: ',m,n
   stop
  end if
  if(present(ainv))then
   aa=>ainv; ainv=a
  else
   aa=>a
  end if

  lwork=64*n
  allocate(work(lwork),piv(n))
  call dgetrf(n,n,aa,n,piv,info)
  if(info.ne.0)then; write(*,*)subnam,': dgertf: info: ',info; stop; end if
  call dgetri(n,aa,n,piv,work,lwork,info)
  if(info.ne.0)then; write(*,*)subnam,': dgerti: info: ',info; stop; end if

  nullify(aa)
  deallocate(work,piv)
  return
 end subroutine
 subroutine matinv_lu_z(a,ainv)
  implicit none
  complex(8),intent(inout)  :: a(:,:)
  complex(8),intent(out),optional :: ainv(size(a,2),size(a,1))
  character(len=*),parameter   :: subnam='matinv_lu_z'
  complex(8),allocatable :: work(:)
  complex(8),dimension(:,:),pointer :: aa
  target  :: a,ainv
  integer :: lwork,m,n,info
  integer,allocatable :: piv(:)
  m=size(a,1); n=size(a,2)
  if(m.ne.n)then
   write(*,*)subnam,': matrix not square: ',m,n
   stop
  end if
  if(present(ainv))then
   aa=>ainv; ainv=a
  else
   aa=>a
  end if

  lwork=64*n
  allocate(work(lwork),piv(n))
  call zgetrf(n,n,aa,n,piv,info)
  if(info.ne.0)then; write(*,*)subnam,': dgertf: info: ',info; stop; end if
  call zgetri(n,aa,n,piv,work,lwork,info)
  if(info.ne.0)then; write(*,*)subnam,': dgerti: info: ',info; stop; end if

  deallocate(work,piv)
  return
 end subroutine

 subroutine eye_d2(a)
  implicit none
  double precision,intent(out) :: a(:,:)
  integer :: m,n,i
  m=size(a,1); n=size(a,2)
  a=0.d0
  forall(i=1:min(m,n))a(i,i)=1.d0
  return
 end subroutine

 subroutine eye_d1(a,n)
    implicit none
    integer, intent(in) :: n
    real(8), intent(out) :: a(:)
    integer :: i
    a(1:n*n) = 0d0
    forall(i = 1:n) a(i+(i-1)*n) = 1d0
 end subroutine eye_d1

 subroutine eye_z1(a,n)
    implicit none
    integer, intent(in) :: n
    complex(8), intent(out) :: a(:)
    integer :: i
    a(1:n*n) = (0d0,0d0)
    forall(i = 1:n) a(i+(i-1)*n) = (1d0,0d0)
 end subroutine eye_z1

 subroutine eye_z2(a)
  implicit none
  complex(8),intent(out) :: a(:,:)
  integer :: m,n,i
  m=size(a,1); n=size(a,2)
  a=(0.d0,0.d0)
  forall(i=1:min(m,n))a(i,i)=(1.d0,0.d0)
  return
 end subroutine

 subroutine d2eye(n,a)
  implicit none
  integer,intent(in) :: n
  double precision,intent(out) :: a(n,n)
  integer :: i
  call dscal(n*n,0.d0,a,1)
  forall(i=1:n)a(i,i)=1.d0
 end subroutine

 subroutine z2eye(n,a)
  implicit none
  integer,intent(in) :: n
  complex(8),intent(out) :: a(n,n)
  integer :: i
  call zdscal(n*n,0.d0,a,1)
  forall(i=1:n)a(i,i)=(1.d0,0.d0)
 end subroutine

 subroutine laplace_d2(a)
  implicit none
  double precision,intent(out) :: a(:,:)
  integer :: m,n,i
  m=size(a,1); n=size(a,2)
  call dscal(m*n,0.d0,a,1)
  forall(i=1:min(m,n))a(i,i)=2.d0
  forall(i=1:min(m-1,n))a(i+1,i)=-1.d0
  forall(i=1:min(m,n-1))a(i,i+1)=-1.d0
  return
 end subroutine
 subroutine laplace_z2(a)
  implicit none
  double complex,intent(out) :: a(:,:)
  integer :: m,n,i
  m=size(a,1); n=size(a,2)
  call zdscal(m*n,0.d0,a,1)
  forall(i=1:min(m,n))a(i,i)=(2.d0,0.d0)
  forall(i=1:min(m-1,n))a(i+1,i)=-(1.d0,0.d0)
  forall(i=1:min(m,n-1))a(i,i+1)=-(1.d0,0.d0)
  return
 end subroutine

 subroutine d2submat(m,n,a,lda,b)
  implicit none
  integer,intent(in) :: m,n,lda
  double precision,intent(in) :: a(lda,n)
  double precision,intent(out) :: b(m,n)
  integer :: i,j
  if(m.gt.lda)then;write(*,*)'d2submat: lda,m: ',lda,m;stop;endif
  if(m.eq.lda)then;call dcopy(m*n,a,1,b,1);return;endif
  forall(i=1:m,j=1:n)b(i,j)=a(i,j)
 end subroutine
 subroutine z2submat(m,n,a,lda,b)
  implicit none
  integer,intent(in) :: m,n,lda
  complex(8),intent(in) :: a(lda,n)
  complex(8),intent(out) :: b(m,n)
  integer :: i,j
  if(m.gt.lda)then;write(*,*)'d2submat: lda,m: ',lda,m;stop;endif
  if(m.eq.lda)then;call zcopy(m*n,a,1,b,1);return;endif
  forall(i=1:m,j=1:n)b(i,j)=a(i,j)
 end subroutine
end module