      SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV,
     &            EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.2)                                    --
*
*  -- Contributed by Zlatko Drmac of the University of Zagreb and     --
*  -- Kresimir Veselic of the Fernuniversitaet Hagen                  --
*  -- November 2008                                                   --
*
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* This routine is also part of SIGMA (version 1.23, October 23. 2008.)
* SIGMA is a library of algorithms for highly accurate algorithms for
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
*     -#- Scalar Arguments -#-
*
      IMPLICIT    NONE
      REAL        EPS, SFMIN, TOL
      INTEGER     INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
      CHARACTER*1 JOBV
*
*     -#- Array Arguments -#-
*
      REAL        A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
     &            WORK( LWORK )
*     ..
*
*  Purpose
*  ~~~~~~~
*  SGSVJ1 is called from SGESVJ as a pre-processor and that is its main
*  purpose. It applies Jacobi rotations in the same way as SGESVJ does, but
*  it targets only particular pivots and it does not check convergence
*  (stopping criterion). Few tunning parameters (marked by [TP]) are
*  available for the implementer.
*
*  Further details
*  ~~~~~~~~~~~~~~~
*  SGSVJ1 applies few sweeps of Jacobi rotations in the column space of
*  the input M-by-N matrix A. The pivot pairs are taken from the (1,2)
*  off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The
*  block-entries (tiles) of the (1,2) off-diagonal block are marked by the
*  [x]'s in the following scheme:
*
*     | *   *   * [x] [x] [x]|
*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.
*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*
*  In terms of the columns of A, the first N1 columns are rotated 'against'
*  the remaining N-N1 columns, trying to increase the angle between the
*  corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is
*  tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.
*  The number of sweeps is given in NSWEEP and the orthogonality threshold
*  is given in TOL.
*
*  Contributors
*  ~~~~~~~~~~~~
*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
*
*  Arguments
*  ~~~~~~~~~
*
*  JOBV    (input) CHARACTER*1
*          Specifies whether the output from this procedure is used
*          to compute the matrix V:
*          = 'V': the product of the Jacobi rotations is accumulated
*                 by postmulyiplying the N-by-N array V.
*                (See the description of V.)
*          = 'A': the product of the Jacobi rotations is accumulated
*                 by postmulyiplying the MV-by-N array V.
*                (See the descriptions of MV and V.)
*          = 'N': the Jacobi rotations are not accumulated.
*
*  M       (input) INTEGER
*          The number of rows of the input matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the input matrix A.
*          M >= N >= 0.
*
*  N1      (input) INTEGER
*          N1 specifies the 2 x 2 block partition, the first N1 columns are
*          rotated 'against' the remaining N-N1 columns of A.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, M-by-N matrix A, such that A*diag(D) represents
*          the input matrix.
*          On exit,
*          A_onexit * D_onexit represents the input matrix A*diag(D)
*          post-multiplied by a sequence of Jacobi rotations, where the
*          rotation threshold and the total number of sweeps are given in
*          TOL and NSWEEP, respectively.
*          (See the descriptions of N1, D, TOL and NSWEEP.)
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  D       (input/workspace/output) REAL array, dimension (N)
*          The array D accumulates the scaling factors from the fast scaled
*          Jacobi rotations.
*          On entry, A*diag(D) represents the input matrix.
*          On exit, A_onexit*diag(D_onexit) represents the input matrix
*          post-multiplied by a sequence of Jacobi rotations, where the
*          rotation threshold and the total number of sweeps are given in
*          TOL and NSWEEP, respectively.
*          (See the descriptions of N1, A, TOL and NSWEEP.)
*
*  SVA     (input/workspace/output) REAL array, dimension (N)
*          On entry, SVA contains the Euclidean norms of the columns of
*          the matrix A*diag(D).
*          On exit, SVA contains the Euclidean norms of the columns of
*          the matrix onexit*diag(D_onexit).
*
*  MV      (input) INTEGER
*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a
*                           sequence of Jacobi rotations.
*          If JOBV = 'N',   then MV is not referenced.
*
*  V       (input/output) REAL array, dimension (LDV,N)
*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a
*                           sequence of Jacobi rotations.
*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a
*                           sequence of Jacobi rotations.
*          If JOBV = 'N',   then V is not referenced.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V,  LDV >= 1.
*          If JOBV = 'V', LDV .GE. N.
*          If JOBV = 'A', LDV .GE. MV.
*
*  EPS     (input) INTEGER
*          EPS = SLAMCH('Epsilon')
*
*  SFMIN   (input) INTEGER
*          SFMIN = SLAMCH('Safe Minimum')
*
*  TOL     (input) REAL
*          TOL is the threshold for Jacobi rotations. For a pair
*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
*          applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.
*
*  NSWEEP  (input) INTEGER
*          NSWEEP is the number of sweeps of Jacobi rotations to be
*          performed.
*
*  WORK    (workspace) REAL array, dimension LWORK.
*
*  LWORK   (input) INTEGER
*          LWORK is the dimension of WORK. LWORK .GE. M.
*
*  INFO    (output) INTEGER
*          = 0 : successful exit.
*          < 0 : if INFO = -i, then the i-th argument had an illegal value
*
*     -#- Local Parameters -#-
*
      REAL        ZERO,         HALF,         ONE,         TWO
      PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 )

*     -#- Local Scalars -#-
*
      REAL      AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, BIGTHETA,
     &          CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,ROOTEPS, ROOTSFMIN,
     &          ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN
      INTEGER   BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, ISWROT, jbc,
     &          jgl, KBL, MVL, NOTROT, nblc, nblr, p, PSKIPPED, q,
     &          ROWSKIP, SWBAND
      LOGICAL   APPLV, ROTOK, RSVEC
*
*     Local Arrays
      REAL      FASTR(5)
*
*     Intrinsic Functions
      INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT
*
*     External Functions
      REAL             SDOT, SNRM2
      INTEGER          ISAMAX
      LOGICAL          LSAME
      EXTERNAL         ISAMAX, LSAME, SDOT, SNRM2
*
*     External Subroutines
      EXTERNAL  SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP
*
*
      APPLV = LSAME(JOBV,'A')
      RSVEC = LSAME(JOBV,'V')
      IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN
         INFO = -1
      ELSE IF ( M .LT. 0 ) THEN
         INFO = -2
      ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN
         INFO = -3
      ELSE IF ( N1 .LT. 0 ) THEN
         INFO = -4
      ELSE IF ( LDA .LT. M ) THEN
         INFO = -6
      ELSE IF ( MV .LT. 0 ) THEN
         INFO = -9
      ELSE IF ( LDV .LT. M ) THEN
         INFO = -11
      ELSE IF ( TOL .LE. EPS ) THEN
         INFO = -14
      ELSE IF ( NSWEEP .LT. 0 ) THEN
         INFO = -15
      ELSE IF ( LWORK .LT. M ) THEN
         INFO = -17
      ELSE
         INFO = 0
      END IF
*
*     #:(
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SGSVJ1', -INFO )
         RETURN
      END IF
*
      IF ( RSVEC ) THEN
         MVL = N
      ELSE IF ( APPLV ) THEN
         MVL = MV
      END IF
      RSVEC = RSVEC .OR. APPLV

         ROOTEPS     = SQRT(EPS)
         ROOTSFMIN   = SQRT(SFMIN)
         SMALL       = SFMIN  / EPS
         BIG         = ONE   / SFMIN
         ROOTBIG     = ONE  / ROOTSFMIN
         LARGE       = BIG / SQRT(FLOAT(M*N))
         BIGTHETA    = ONE  / ROOTEPS
         ROOTTOL = SQRT(TOL)
*
*     -#- Initialize the right singular vector matrix -#-
*
*     RSVEC = LSAME( JOBV, 'Y' )
*
      EMPTSW = N1 * ( N - N1 )
      NOTROT     = 0
      FASTR(1)   = ZERO
*
*     -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
*
      KBL = MIN0(8,N)
      NBLR = N1 / KBL
      IF ( ( NBLR * KBL ) .NE. N1 ) NBLR = NBLR + 1

*     .. the tiling is nblr-by-nblc [tiles]

      NBLC = ( N - N1 ) / KBL
      IF ( ( NBLC * KBL ) .NE. ( N - N1 ) ) NBLC = NBLC + 1
      BLSKIP = ( KBL**2 ) + 1
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.

      ROWSKIP = MIN0( 5, KBL )
*[TP] ROWSKIP is a tuning parameter.
      SWBAND = 0
*[TP] SWBAND is a tuning parameter. It is meaningful and effective
*     if SGESVJ is used as a computational routine in the preconditioned
*     Jacobi SVD algorithm SGESVJ.
*
*
*     | *   *   * [x] [x] [x]|
*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.
*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*     |[x] [x] [x] *   *   * |
*
*
      DO 1993 i = 1, NSWEEP
*     .. go go go ...
*
      MXAAPQ = ZERO
      MXSINJ = ZERO
      ISWROT = 0
*
      NOTROT = 0
      PSKIPPED = 0
*
      DO 2000 ibr = 1, NBLR

      igl = ( ibr - 1 ) * KBL + 1
*
*
*........................................................
* ... go to the off diagonal blocks

      igl = ( ibr - 1 ) * KBL + 1

      DO 2010 jbc = 1, NBLC

         jgl = N1 + ( jbc - 1 ) * KBL + 1

*        doing the block at ( ibr, jbc )

         IJBLSK = 0
         DO 2100 p = igl, MIN0( igl + KBL - 1, N1 )

         AAPP = SVA(p)

         IF ( AAPP .GT. ZERO ) THEN

         PSKIPPED = 0

         DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
*
         AAQQ = SVA(q)

         IF ( AAQQ .GT. ZERO ) THEN
            AAPP0 = AAPP
*
*     -#- M x 2 Jacobi SVD -#-
*
*        -#- Safe Gram matrix computation -#-
*
         IF ( AAQQ .GE. ONE ) THEN
            IF ( AAPP .GE. AAQQ ) THEN
               ROTOK = ( SMALL*AAPP ) .LE. AAQQ
            ELSE
               ROTOK = ( SMALL*AAQQ ) .LE. AAPP
            END IF
            IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
               AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
     &                  D(p) * D(q) / AAQQ ) / AAPP
            ELSE
               CALL SCOPY( M, A(1,p), 1, WORK, 1 )
               CALL SLASCL( 'G', 0, 0, AAPP, D(p), M,
     &              1, WORK, LDA, IERR )
               AAPQ = SDOT( M, WORK, 1, A(1,q), 1 ) *
     &                D(q) / AAQQ
            END IF
         ELSE
            IF ( AAPP .GE. AAQQ ) THEN
               ROTOK = AAPP .LE. ( AAQQ / SMALL )
            ELSE
               ROTOK = AAQQ .LE. ( AAPP / SMALL )
            END IF
            IF ( AAPP .GT.  ( SMALL / AAQQ ) ) THEN
               AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
     &               D(p) * D(q) / AAQQ ) / AAPP
            ELSE
               CALL SCOPY( M, A(1,q), 1, WORK, 1 )
               CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, 1,
     &              WORK, LDA, IERR )
               AAPQ = SDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP
            END IF
         END IF

         MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )

*        TO rotate or NOT to rotate, THAT is the question ...
*
         IF ( ABS( AAPQ ) .GT. TOL ) THEN
            NOTROT   = 0
*           ROTATED  = ROTATED + 1
            PSKIPPED = 0
            ISWROT   = ISWROT  + 1
*
            IF ( ROTOK ) THEN
*
               AQOAP = AAQQ / AAPP
               APOAQ = AAPP / AAQQ
               THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
               IF ( AAQQ .GT. AAPP0 ) THETA = - THETA

               IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
                  T = HALF / THETA
                  FASTR(3) =  T * D(p) / D(q)
                  FASTR(4) = -T * D(q) / D(p)
                  CALL SROTM( M,   A(1,p), 1, A(1,q), 1, FASTR )
                  IF ( RSVEC )
     &            CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
                  SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
                  AAPP   = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
                  MXSINJ = AMAX1( MXSINJ, ABS(T) )
               ELSE
*
*                 .. choose correct signum for THETA and rotate
*
                  THSIGN = - SIGN(ONE,AAPQ)
                  IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
                  T  = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
                  CS = SQRT( ONE / ( ONE + T*T ) )
                  SN = T * CS
                  MXSINJ = AMAX1( MXSINJ, ABS(SN) )
                  SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
                  AAPP   = AAPP*SQRT( ONE - T*AQOAP*AAPQ)

                  APOAQ = D(p) / D(q)
                  AQOAP = D(q) / D(p)
                  IF ( D(p) .GE. ONE ) THEN
*
                     IF ( D(q) .GE.  ONE ) THEN
                        FASTR(3) =   T * APOAQ
                        FASTR(4) = - T * AQOAP
                        D(p)  = D(p) * CS
                        D(q)  = D(q) * CS
                        CALL SROTM( M,   A(1,p),1, A(1,q),1, FASTR )
                        IF ( RSVEC )
     &                  CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
                     ELSE
                        CALL SAXPY( M,    -T*AQOAP, A(1,q),1, A(1,p),1 )
                        CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
                        IF ( RSVEC ) THEN
                        CALL SAXPY( MVL, -T*AQOAP,  V(1,q),1, V(1,p),1 )
                        CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
                        END IF
                        D(p) = D(p) * CS
                        D(q) = D(q) / CS
                     END IF
                  ELSE
                     IF ( D(q) .GE. ONE ) THEN
                        CALL SAXPY( M,     T*APOAQ, A(1,p),1, A(1,q),1 )
                        CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
                        IF ( RSVEC ) THEN
                        CALL SAXPY(MVL,T*APOAQ,     V(1,p),1, V(1,q),1 )
                        CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
                        END IF
                        D(p) = D(p) / CS
                        D(q) = D(q) * CS
                     ELSE
                        IF ( D(p) .GE. D(q) ) THEN
                           CALL SAXPY( M,-T*AQOAP,   A(1,q),1,A(1,p),1 )
                           CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
                           D(p) = D(p) * CS
                           D(q) = D(q) / CS
                           IF ( RSVEC ) THEN
                           CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
                           CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
                           END IF
                        ELSE
                           CALL SAXPY(M, T*APOAQ,    A(1,p),1,A(1,q),1)
                           CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
                           D(p) = D(p) / CS
                           D(q) = D(q) * CS
                          IF ( RSVEC ) THEN
                          CALL SAXPY(MVL, T*APOAQ,    V(1,p),1,V(1,q),1)
                          CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
                          END IF
                        END IF
                     END IF
                  ENDIF
               END IF

            ELSE
               IF ( AAPP .GT. AAQQ ) THEN
                  CALL SCOPY( M, A(1,p), 1, WORK, 1 )
                  CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR)
                  CALL SLASCL('G',0,0,AAQQ,ONE,M,1,   A(1,q),LDA,IERR)
                  TEMP1 = -AAPQ * D(p) / D(q)
                  CALL SAXPY(M,TEMP1,WORK,1,A(1,q),1)
                  CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
                  SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
                  MXSINJ = AMAX1( MXSINJ, SFMIN )
               ELSE
                  CALL SCOPY( M, A(1,q), 1, WORK, 1 )
                  CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR)
                  CALL SLASCL('G',0,0,AAPP,ONE,M,1,   A(1,p),LDA,IERR)
                  TEMP1 = -AAPQ * D(q) / D(p)
                  CALL SAXPY(M,TEMP1,WORK,1,A(1,p),1)
                  CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
                  SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
                  MXSINJ = AMAX1( MXSINJ, SFMIN )
               END IF
            END IF
*           END IF ROTOK THEN ... ELSE
*
*           In the case of cancellation in updating SVA(q)
*           .. recompute SVA(q)
            IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS  ) THEN
               IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
                  SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q)
               ELSE
                  T    = ZERO
                  AAQQ = ZERO
                  CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
                  SVA(q) = T * SQRT(AAQQ) * D(q)
               END IF
            END IF
            IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS  ) THEN
               IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
                  AAPP = SNRM2( M, A(1,p), 1 ) * D(p)
               ELSE
                  T    = ZERO
                  AAPP = ZERO
                  CALL SLASSQ( M, A(1,p), 1, T, AAPP )
                  AAPP = T * SQRT(AAPP) * D(p)
               END IF
               SVA(p) = AAPP
            END IF
*              end of OK rotation
         ELSE
            NOTROT   = NOTROT   + 1
*           SKIPPED  = SKIPPED  + 1
            PSKIPPED = PSKIPPED + 1
            IJBLSK   = IJBLSK   + 1
         END IF
      ELSE
         NOTROT   = NOTROT   + 1
         PSKIPPED = PSKIPPED + 1
         IJBLSK   = IJBLSK   + 1
      END IF

*      IF ( NOTROT .GE. EMPTSW )  GO TO 2011
      IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
         SVA(p) = AAPP
         NOTROT = 0
         GO TO 2011
      END IF
      IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
         AAPP = -AAPP
         NOTROT = 0
         GO TO 2203
      END IF

*
 2200    CONTINUE
*        end of the q-loop
 2203    CONTINUE

         SVA(p) = AAPP
*
      ELSE
         IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
         IF ( AAPP .LT. ZERO ) NOTROT = 0
***      IF ( NOTROT .GE. EMPTSW )  GO TO 2011
      END IF

 2100 CONTINUE
*     end of the p-loop
 2010 CONTINUE
*     end of the jbc-loop
 2011 CONTINUE
*2011 bailed out of the jbc-loop
      DO 2012 p = igl, MIN0( igl + KBL - 1, N )
         SVA(p) = ABS(SVA(p))
 2012 CONTINUE
***   IF ( NOTROT .GE. EMPTSW ) GO TO 1994
 2000 CONTINUE
*2000 :: end of the ibr-loop
*
*     .. update SVA(N)
      IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
         SVA(N) = SNRM2( M, A(1,N), 1 ) * D(N)
      ELSE
         T    = ZERO
         AAPP = ZERO
         CALL SLASSQ( M, A(1,N), 1, T, AAPP )
         SVA(N) = T * SQRT(AAPP) * D(N)
      END IF
*
*     Additional steering devices
*
      IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
     &     ( ISWROT .LE. N ) ) )
     &   SWBAND = i

      IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.FLOAT(N)*TOL).AND.
     &   (FLOAT(N)*MXAAPQ*MXSINJ.LT.TOL))THEN
        GO TO 1994
      END IF

*
      IF ( NOTROT .GE. EMPTSW ) GO TO 1994

 1993 CONTINUE
*     end i=1:NSWEEP loop
* #:) Reaching this point means that the procedure has completed the given
*     number of sweeps.
      INFO = NSWEEP - 1
      GO TO 1995
 1994 CONTINUE
* #:) Reaching this point means that during the i-th sweep all pivots were
*     below the given threshold, causing early exit.

      INFO = 0
* #:) INFO = 0 confirms successful iterations.
 1995 CONTINUE
*
*     Sort the vector D
*
      DO 5991 p = 1, N - 1
         q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
         IF ( p .NE. q ) THEN
            TEMP1  = SVA(p)
            SVA(p) = SVA(q)
            SVA(q) = TEMP1
            TEMP1   = D(p)
            D(p) = D(q)
            D(q) = TEMP1
            CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
            IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
         END IF
 5991 CONTINUE
*
      RETURN
*     ..
*     .. END OF SGSVJ1
*     ..
      END
*


SUBROUTINE gammas

!-------------------------------------------------------------
!
! Compute gamma elements from known analytic form of gamma
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
REAL*8 :: alf

! Set the scalar alpha
alf = 1.0d0/(-0.125d0-0.25d0*ez-0.25d0*ey-0.25d0*ex)

! Now need 16 formulas to make 16 gamma elements
! gaa
gaa = alf*(-0.125d0)

! gax, gaxz, gayz
gaxy = alf*(-0.25d0)*ez
gaxz = alf*(-0.25d0)*ey
gayz = alf*(-0.25d0)*ex

! gxya, gxza, gyza
gxya = alf*(-0.25d0)
gxza = gxya
gyza = gxya

! gxyxy, gxyxz, gxyyz, gxzxy, gxzxz, gxzyz, gyzxy, gyzxz, gyzyz
gxyxy = alf*(0.5d0*(0.25d0+0.5d0*(ey+ex))-0.25d0*ez)
gxyxz = 2.0d0*gaxz
gxyyz = 2.0d0*gayz

gxzxy = 2.0d0*gaxy
gxzxz = alf*(0.5d0*(0.25d0+0.5d0*(ez+ex))-0.25d0*ey)
gxzyz = 2.0d0*gayz

gyzxy = 2.0d0*gaxy
gyzxz = 2.0d0*gaxz
gyzyz = alf*(0.5d0*(0.25d0+0.5d0*(ez+ey))-0.25d0*ex)

RETURN
END SUBROUTINE gammas


      SUBROUTINE SHPSTS (SIGMA,VONMS,SIGP)
C
C     TO CALCULATE PRINCIPAL STRESSES AND THEIR ANGLES FOR THE
C     ISOPARAMETRIC SHELL ELEMENTS
C
C
C     INPUT :
C           SIGMA  - ARRAY OF 3 STRESS COMPONENTS
C           VONMS  - LOGICAL FLAG INDICATING THE PRESENCE OF VON-MISES
C                    STRESS REQUEST
C     OUTPUT:
C           SIGP   - ARRAY OF PRINCIPAL STRESSES
C
C
      LOGICAL VONMS
CWKBNB 7/94 SPR94004
      LOGICAL OSTRAI
      COMMON / BLANK / APP(2), SORT2, IDUM(2), COMPS, SKP(4), OSTRAI
     &,                SK2(39), MIDVE
CWKBNE 7/94 SPR94004
      REAL    SIGMA(3),SIGP(4),SIG,PROJ,TAUMAX,EPS,TXY2
      DATA    EPS / 1.0E-11 /
C
C
C     CALCULATE PRINCIPAL STRESSES
C
      SIG  = 0.5*(SIGMA(1)+SIGMA(2))
      PROJ = 0.5*(SIGMA(1)-SIGMA(2))
      TAUMAX = PROJ*PROJ + SIGMA(3)*SIGMA(3)
CWKBI 7/94 SPR94004
      IF ( OSTRAI ) TAUMAX = PROJ*PROJ + SIGMA(3)*SIGMA(3)/4.
      IF (TAUMAX .NE. 0.0) TAUMAX = SQRT(TAUMAX)
      IF (TAUMAX .LE. EPS) TAUMAX = 0.0
C
C     CALCULATE THE PRINCIPAL ANGLE
C
      TXY2 = SIGMA(3)*2.0
      PROJ = PROJ*2.0
      SIGP(1) = 0.0
      IF (ABS(TXY2).GT.EPS .OR. ABS(PROJ).GT.EPS)
     1    SIGP(1) = 28.64788976*ATAN2(TXY2,PROJ)
C                   28.64788976 = 90./PI
C
      SIGP(2) = SIG + TAUMAX
      SIGP(3) = SIG - TAUMAX
      SIGP(4) = TAUMAX
C
C     OUTPUT VON MISES YIELD STRESS IF REQUESTED
C
      IF (.NOT.VONMS) RETURN
      SIG = SIGP(2)*SIGP(2) + SIGP(3)*SIGP(3) - SIGP(2)*SIGP(3)
      IF (SIG .NE. 0.0) SIG = SQRT(SIG)
      IF (SIG .LE. EPS) SIG = 0.0
      SIGP(4) = SIG
C
      RETURN
      END


program P2491
    implicit none

    integer :: length
    integer, dimension(100000) :: sequence
    integer, dimension(100000) :: increasing_up_to, decreasing_up_to
    integer :: i

    integer :: max_length

    read (*,*) length
    read (*,*) (sequence(i), i = 1, length)

    increasing_up_to(1) = 1
    decreasing_up_to(1) = 1

    do i = 2, length
        if (sequence(i) >= sequence(i - 1)) then
            increasing_up_to(i) = increasing_up_to(i - 1) + 1
        else
            increasing_up_to(i) = 1
        end if
        if (sequence(i) <= sequence(i - 1)) then
            decreasing_up_to(i) = decreasing_up_to(i - 1) + 1
        else
            decreasing_up_to(i) = 1
        end if
    end do

    max_length = 0
    do i = 1, length
        max_length = max(max_length, increasing_up_to(i), decreasing_up_to(i))
    end do

    write (*, '(I0)') max_length
end program P2491


FUNCTION ppchi2(p, v, g) RESULT(fn_val)

! N.B. Argument IFAULT has been removed.

! This version by Alan Miller
! amiller @ bigpond.net.au
! Latest revision - 27 October 2000

!  Algorithm AS 91   Appl. Statist. (1975) Vol.24, P.35

!  To evaluate the percentage points of the chi-squared
!  probability distribution function.

!  p must lie in the range 0.000002 to 0.999998,
!  v must be positive,
!  g must be supplied and should be equal to ln(gamma(v/2.0))

!  Incorporates the suggested changes in AS R85 (vol.40(1), pp.233-5, 1991)
!  which should eliminate the need for the limited range for p above,
!  though these limits have not been removed from the routine.

!  If IFAULT = 4 is returned, the result is probably as accurate as
!  the machine will allow.

!  Auxiliary routines required: PPND = AS 111 (or AS 241) and GAMMAD = AS 239.

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), INTENT(IN)  :: p
REAL (dp), INTENT(IN)  :: v
REAL (dp), INTENT(IN)  :: g
REAL (dp)              :: fn_val

INTERFACE
  FUNCTION gammad(x, p) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN) :: x, p
    REAL (dp)             :: fn_val
  END FUNCTION gammad

  SUBROUTINE ppnd16 (p, normal_dev, ifault)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)   :: p
    INTEGER, INTENT(OUT)    :: ifault
    REAL (dp), INTENT(OUT)  :: normal_dev
  END SUBROUTINE ppnd16
END INTERFACE

! Local variables

REAL (dp)  :: a, b, c, p1, p2, q, s1, s2, s3, s4, s5, s6, t, x, xx
INTEGER    :: i, if1

INTEGER, PARAMETER    :: maxit = 20
REAL (dp), PARAMETER  :: aa = 0.6931471806_dp, e = 0.5e-06_dp,         &
                         pmin = 0.000002_dp, pmax = 0.999998_dp,       &
                         zero = 0.0_dp, half = 0.5_dp, one = 1.0_dp,   &
                         two = 2.0_dp, three = 3.0_dp, six = 6.0_dp,   &
                         c1 = 0.01_dp, c2 = 0.222222_dp, c3 = 0.32_dp, &
                         c4 = 0.4_dp, c5 = 1.24_dp, c6 = 2.2_dp,       &
                         c7 = 4.67_dp, c8 = 6.66_dp, c9 = 6.73_dp,     &
                         c10 = 13.32_dp, c11 = 60.0_dp, c12 = 70.0_dp, &
                         c13 = 84.0_dp, c14 = 105.0_dp, c15 = 120.0_dp, &
                         c16 = 127.0_dp, c17 = 140.0_dp, c18 = 175.0_dp, &
                         c19 = 210.0_dp, c20 = 252.0_dp, c21 = 264.0_dp, &
                         c22 = 294.0_dp, c23 = 346.0_dp, c24 = 420.0_dp, &
                         c25 = 462.0_dp, c26 = 606.0_dp, c27 = 672.0_dp, &
                         c28 = 707.0_dp, c29 = 735.0_dp, c30 = 889.0_dp, &
                         c31 = 932.0_dp, c32 = 966.0_dp, c33 = 1141.0_dp, &
                         c34 = 1182.0_dp, c35 = 1278.0_dp, c36 = 1740.0_dp, &
                         c37 = 2520.0_dp, c38 = 5040.0_dp

!       Test arguments and initialise

fn_val = -one
IF (p < pmin .OR. p > pmax) THEN
  WRITE(*, *) 'Error in PPCHI2: p must be between 0.000002 & 0.999998'
  RETURN
END IF
IF (v <= zero) THEN
  WRITE(*, *) 'Error in PPCHI2: Number of deg. of freedom <= 0'
  RETURN
END IF

xx = half * v
c = xx - one

!       Starting approximation for small chi-squared

IF (v < -c5 * LOG(p)) THEN
  fn_val = (p * xx * EXP(g + xx * aa)) ** (one/xx)
  IF (fn_val < e) GO TO 6
  GO TO 4
END IF

!       Starting approximation for v less than or equal to 0.32

IF (v > c3) GO TO 3
fn_val = c4
a = LOG(one-p)

2 q = fn_val
p1 = one + fn_val * (c7+fn_val)
p2 = fn_val * (c9 + fn_val * (c8 + fn_val))
t = -half + (c7 + two * fn_val) / p1 - (c9 + fn_val * (c10 + three * fn_val)) / p2
fn_val = fn_val - (one - EXP(a + g + half * fn_val + c * aa) * p2 / p1) / t
IF (ABS(q / fn_val - one) > c1) GO TO 2
GO TO 4

!       Call to algorithm AS 241 - note that p has been tested above.

3 CALL ppnd16(p, x, if1)

!       Starting approximation using Wilson and Hilferty estimate

p1 = c2 / v
fn_val = v * (x * SQRT(p1) + one - p1) ** 3

!       Starting approximation for p tending to 1

IF (fn_val > c6 * v + six) fn_val = -two * (LOG(one-p) - c * LOG(half * fn_val) + g)

!       Call to algorithm AS 239 and calculation of seven term Taylor series

4 DO i = 1, maxit
  q = fn_val
  p1 = half * fn_val
  p2 = p - gammad(p1, xx)

  t = p2 * EXP(xx * aa + g + p1 - c * LOG(fn_val))
  b = t / fn_val
  a = half * t - b * c
  s1 = (c19 + a * (c17 + a * (c14 + a * (c13 + a * (c12 + c11 * a))))) / c24
  s2 = (c24 + a * (c29 + a * (c32 + a * (c33 + c35 * a)))) / c37
  s3 = (c19 + a * (c25 + a * (c28 + c31 * a))) / c37
  s4 = (c20 + a * (c27 + c34 * a) + c * (c22 + a * (c30 + c36 * a))) / c38
  s5 = (c13 + c21 * a + c * (c18 + c26 * a)) / c37
  s6 = (c15 + c * (c23 + c16 * c)) / c38
  fn_val = fn_val + t * (one + half * t * s1 - b * c * (s1 - b *   &
           (s2 - b * (s3 - b * (s4 - b * (s5 - b * s6))))))
  IF (ABS(q / fn_val - one) > e) RETURN
END DO

WRITE(*, *) 'Error in PPCHI2: Max. number of iterations exceeded'

6 RETURN
END FUNCTION ppchi2


program main

use test, only: test_value
use io, only: stdout

use solver

implicit none

integer :: i, j, ierr, nrows, ncols, imat5x4(5,4), imat2x3(2,3)
double precision :: vec2(2), vec5(5), vec4_constraint(4)
double precision :: mat2x3(2,3), mat5x2(5,2), mat5x4(5,4)
logical :: isConst(4)

#ifdef USE_LAPACK
double precision :: mat3x3(3,3), vec3(3), mat3x3_b(3,3)
#elif USE_SUPERLU
double precision :: mat3x3(3,3), vec3(3)
#endif

!---- Test: loading 1-D double precision array
vec5 = 0.0d0
vec2(1) =  8.0d0
vec2(2) = -3.0d0
call load_dp_array1(vec5,5,vec2,2,3,'vec2',ierr)
call test_value(vec5(1), 0.0d0,'load_dp_array1: vec5(1)')
call test_value(vec5(2), 0.0d0,'load_dp_array1: vec5(2)')
call test_value(vec5(3), 8.0d0,'load_dp_array1: vec5(3)')
call test_value(vec5(4),-3.0d0,'load_dp_array1: vec5(4)')
call test_value(vec5(5), 0.0d0,'load_dp_array1: vec5(5)')
call load_dp_array1(vec5,5,vec2,2,5,'vec2',ierr)
call test_value(ierr,1,'load_dp_array1: overflow')
write(stdout,*) 'subroutine load_dp_array1() passed unit test'
write(stdout,*)

!---- Test: loading 2-D double precision array
mat5x4 = 0.0d0
do i = 1,2
    do j = 1,3
        mat2x3(i,j) = dble(i)*10.0d0 + dble(j)
    enddo
enddo
call load_dp_array2(mat5x4,5,4,mat2x3,2,3,3,2,'mat2x3',ierr)
call test_value(mat5x4(1,1), 0.0d0,'load_dp_array2: mat5x4(1,1)')
call test_value(mat5x4(1,2), 0.0d0,'load_dp_array2: mat5x4(1,2)')
call test_value(mat5x4(1,3), 0.0d0,'load_dp_array2: mat5x4(1,3)')
call test_value(mat5x4(1,4), 0.0d0,'load_dp_array2: mat5x4(1,4)')
call test_value(mat5x4(2,1), 0.0d0,'load_dp_array2: mat5x4(2,1)')
call test_value(mat5x4(2,2), 0.0d0,'load_dp_array2: mat5x4(2,2)')
call test_value(mat5x4(2,3), 0.0d0,'load_dp_array2: mat5x4(2,3)')
call test_value(mat5x4(2,4), 0.0d0,'load_dp_array2: mat5x4(2,4)')
call test_value(mat5x4(3,1), 0.0d0,'load_dp_array2: mat5x4(3,1)')
call test_value(mat5x4(3,2),11.0d0,'load_dp_array2: mat5x4(3,2)')
call test_value(mat5x4(3,3),12.0d0,'load_dp_array2: mat5x4(3,3)')
call test_value(mat5x4(3,4),13.0d0,'load_dp_array2: mat5x4(3,4)')
call test_value(mat5x4(4,1), 0.0d0,'load_dp_array2: mat5x4(4,1)')
call test_value(mat5x4(4,2),21.0d0,'load_dp_array2: mat5x4(4,2)')
call test_value(mat5x4(4,3),22.0d0,'load_dp_array2: mat5x4(4,3)')
call test_value(mat5x4(4,4),23.0d0,'load_dp_array2: mat5x4(4,4)')
call test_value(mat5x4(5,1), 0.0d0,'load_dp_array2: mat5x4(5,1)')
call test_value(mat5x4(5,2), 0.0d0,'load_dp_array2: mat5x4(5,2)')
call test_value(mat5x4(5,3), 0.0d0,'load_dp_array2: mat5x4(5,3)')
call test_value(mat5x4(5,4), 0.0d0,'load_dp_array2: mat5x4(5,4)')
call load_dp_array2(mat5x4,5,4,mat2x3,2,3,3,3,'mat2x3',ierr)
call test_value(ierr,1,'load_dp_array2: overflow')
write(stdout,*) 'subroutine load_dp_array2() passed unit test'
write(stdout,*)

!---- Test: loading 2-D integer array
imat5x4 = 0
do i = 1,2
    do j = 1,3
        imat2x3(i,j) = i*10 + j
    enddo
enddo
call load_int_array2(imat5x4,5,4,imat2x3,2,3,3,2,'imat2x3',ierr)
call test_value(imat5x4(1,1), 0,'load_int_array2: imat5x4(1,1)')
call test_value(imat5x4(1,2), 0,'load_int_array2: imat5x4(1,2)')
call test_value(imat5x4(1,3), 0,'load_int_array2: imat5x4(1,3)')
call test_value(imat5x4(1,4), 0,'load_int_array2: imat5x4(1,4)')
call test_value(imat5x4(2,1), 0,'load_int_array2: imat5x4(2,1)')
call test_value(imat5x4(2,2), 0,'load_int_array2: imat5x4(2,2)')
call test_value(imat5x4(2,3), 0,'load_int_array2: imat5x4(2,3)')
call test_value(imat5x4(2,4), 0,'load_int_array2: imat5x4(2,4)')
call test_value(imat5x4(3,1), 0,'load_int_array2: imat5x4(3,1)')
call test_value(imat5x4(3,2),11,'load_int_array2: imat5x4(3,2)')
call test_value(imat5x4(3,3),12,'load_int_array2: imat5x4(3,3)')
call test_value(imat5x4(3,4),13,'load_int_array2: imat5x4(3,4)')
call test_value(imat5x4(4,1), 0,'load_int_array2: imat5x4(4,1)')
call test_value(imat5x4(4,2),21,'load_int_array2: imat5x4(4,2)')
call test_value(imat5x4(4,3),22,'load_int_array2: imat5x4(4,3)')
call test_value(imat5x4(4,4),23,'load_int_array2: imat5x4(4,4)')
call test_value(imat5x4(5,1), 0,'load_int_array2: imat5x4(5,1)')
call test_value(imat5x4(5,2), 0,'load_int_array2: imat5x4(5,2)')
call test_value(imat5x4(5,3), 0,'load_int_array2: imat5x4(5,3)')
call test_value(imat5x4(5,4), 0,'load_int_array2: imat5x4(5,4)')
call load_int_array2(imat5x4,5,4,imat2x3,2,3,3,3,'imat2x3',ierr)
call test_value(ierr,1,'load_int_array2: overflow')
write(stdout,*) 'subroutine load_int_array2() passed unit test'
write(stdout,*)

!---- Test: load equation constraints
nrows = 5
ncols = 4
vec5 = 0.0d0
vec4_constraint(1) = 0.0d0
vec4_constraint(2) = 1.0d0
vec4_constraint(3) = 0.0d0
vec4_constraint(4) = 2.0d0
isConst(1) = .false.
isConst(2) = .true.
isConst(3) = .false.
isConst(4) = .true.
! do i = 1,5
!     write(0,*) mat5x4(i,:)
! enddo
call load_dp_array_constraints(mat5x4,vec5,nrows,ncols,vec4_constraint,isConst,ierr)
! do i = 1,5
!     write(0,*) mat5x4(i,:)
! enddo
! do i = 1,5
!     write(0,*) vec5(i)
! enddo
call test_value(mat5x4(1,1), 0.0d0,'load_dp_array_constraints: mat5x4(1,1)')
call test_value(mat5x4(1,2), 0.0d0,'load_dp_array_constraints: mat5x4(1,2)')
call test_value(mat5x4(2,1), 0.0d0,'load_dp_array_constraints: mat5x4(2,1)')
call test_value(mat5x4(2,2), 0.0d0,'load_dp_array_constraints: mat5x4(2,2)')
call test_value(mat5x4(3,1), 0.0d0,'load_dp_array_constraints: mat5x4(3,1)')
call test_value(mat5x4(3,2),12.0d0,'load_dp_array_constraints: mat5x4(3,2)')
call test_value(mat5x4(4,1), 0.0d0,'load_dp_array_constraints: mat5x4(4,1)')
call test_value(mat5x4(4,2),22.0d0,'load_dp_array_constraints: mat5x4(4,2)')
call test_value(mat5x4(5,1), 0.0d0,'load_dp_array_constraints: mat5x4(5,1)')
call test_value(mat5x4(5,2), 0.0d0,'load_dp_array_constraints: mat5x4(5,2)')
call test_value(vec5(1),  0.0d0,'load_dp_array_constraints: vec5(1)')
call test_value(vec5(2),  0.0d0,'load_dp_array_constraints: vec5(2)')
call test_value(vec5(3),-37.0d0,'load_dp_array_constraints: vec5(3)')
call test_value(vec5(4),-67.0d0,'load_dp_array_constraints: vec5(4)')
call test_value(vec5(5),  0.0d0,'load_dp_array_constraints: vec5(5)')
call test_value(ncols,2,'load_dp_array_constraints: ncols output')
write(stdout,*) 'subroutine load_dp_array_constraints() passed unit test'
write(stdout,*)

!---- Test: linear equation solver
! dgesv
#ifdef USE_LAPACK
mat3x3(1,1) = 1.0d0
mat3x3(1,2) = 2.0d0
mat3x3(1,3) = 3.0d0
mat3x3(2,1) = 4.0d0
mat3x3(2,2) = 5.0d0
mat3x3(2,3) = 4.0d0
mat3x3(3,1) = 3.0d0
mat3x3(3,2) = 2.0d0
mat3x3(3,3) = 1.0d0
vec3(1) = 11.0d0
vec3(2) = 12.0d0
vec3(3) = 13.0d0
call solve_dgesv(mat3x3,vec3,vec3,3,ierr)
! do i = 1,3
!     write(0,*) vec3(i)
! enddo
call test_value(vec3(1),  9.5d0,'solve_dgesv: vec3(1)')
call test_value(vec3(2),-12.0d0,'solve_dgesv: vec3(2)')
call test_value(vec3(3),  8.5d0,'solve_dgesv: vec3(3)')
write(stdout,*) 'subroutine solve_dgesv() (linear equation solver) passed unit test'
write(stdout,*)

mat3x3_b(1,1) = -7.0d0
mat3x3_b(1,2) =  4.0d0
mat3x3_b(1,3) =  1.0d0
mat3x3_b(2,1) = -3.0d0
mat3x3_b(2,2) = -2.0d0
mat3x3_b(2,3) =  8.0d0
mat3x3_b(3,1) =  4.0d0
mat3x3_b(3,2) = -4.0d0
mat3x3_b(3,3) =  0.0d0
call solve_dgesv_nrhs(mat3x3,mat3x3_b,mat3x3_b,3,3,ierr)
call test_value(mat3x3_b(1,1), 2.375d0,'solve_dgesv_nrhs: mat3x3_b(1,1)')
call test_value(mat3x3_b(1,2),-1.000d0,'solve_dgesv_nrhs: mat3x3_b(1,2)')
call test_value(mat3x3_b(1,3),-3.625d0,'solve_dgesv_nrhs: mat3x3_b(1,3)')
call test_value(mat3x3_b(2,1), 0.000d0,'solve_dgesv_nrhs: mat3x3_b(2,1)')
call test_value(mat3x3_b(2,2),-2.000d0,'solve_dgesv_nrhs: mat3x3_b(2,1)')
call test_value(mat3x3_b(2,3), 7.000d0,'solve_dgesv_nrhs: mat3x3_b(2,1)')
call test_value(mat3x3_b(3,1),-3.125d0,'solve_dgesv_nrhs: mat3x3_b(3,1)')
call test_value(mat3x3_b(3,2), 3.000d0,'solve_dgesv_nrhs: mat3x3_b(3,2)')
call test_value(mat3x3_b(3,3),-3.125d0,'solve_dgesv_nrhs: mat3x3_b(3,3)')
write(stdout,*) 'subroutine solve_dgesv_nrhs() (linear equation solver) passed unit test'
write(stdout,*)

! dsysv
mat3x3(1,1) = -2.0d0
mat3x3(1,2) =  1.0d0
mat3x3(1,3) =  3.0d0
mat3x3(2,1) =  1.0d0
mat3x3(2,2) =  1.0d0
mat3x3(2,3) = -1.0d0
mat3x3(3,1) =  3.0d0
mat3x3(3,2) = -1.0d0
mat3x3(3,3) =  2.0d0
vec3(1) = 5.0d0
vec3(2) = 9.0d0
vec3(3) = 2.0d0
call solve_dsysv(mat3x3,vec3,vec3,3,ierr)
call test_value(vec3(1),2.526315789473684d0,'solve_dsysv: vec3(1)')
call test_value(vec3(2),7.368421052631579d0,'solve_dsysv: vec3(2)')
call test_value(vec3(3),0.894736842105263d0,'solve_dsysv: vec3(3)')
write(stdout,*) 'subroutine solve_dsysv() (symmetric equation solver) passed unit test'
write(stdout,*)

mat3x3_b(1,1) = -7.0d0
mat3x3_b(1,2) =  4.0d0
mat3x3_b(1,3) =  1.0d0
mat3x3_b(2,1) = -3.0d0
mat3x3_b(2,2) = -2.0d0
mat3x3_b(2,3) =  8.0d0
mat3x3_b(3,1) =  4.0d0
mat3x3_b(3,2) = -4.0d0
mat3x3_b(3,3) =  0.0d0
call solve_dsysv_nrhs(mat3x3,mat3x3_b,mat3x3_b,3,3,ierr)
call test_value(mat3x3_b(1,1),0.42105263157894735d0,'solve_dsysv_nrhs: mat3x3_b(1,1)')
call test_value(mat3x3_b(1,2),-1.5789473684210527d0,'solve_dsysv_nrhs: mat3x3_b(1,2)')
call test_value(mat3x3_b(1,3),2.0526315789473681d0,'solve_dsysv_nrhs: mat3x3_b(1,3)')
call test_value(mat3x3_b(2,1),-4.1052631578947363d0,'solve_dsysv_nrhs: mat3x3_b(2,1)')
call test_value(mat3x3_b(2,2),-0.10526315789473685d0,'solve_dsysv_nrhs: mat3x3_b(2,1)')
call test_value(mat3x3_b(2,3),5.7368421052631575d0,'solve_dsysv_nrhs: mat3x3_b(2,1)')
call test_value(mat3x3_b(3,1),-0.68421052631578960d0,'solve_dsysv_nrhs: mat3x3_b(3,1)')
call test_value(mat3x3_b(3,2),0.31578947368421056d0,'solve_dsysv_nrhs: mat3x3_b(3,2)')
call test_value(mat3x3_b(3,3),-0.21052631578947367d0,'solve_dsysv_nrhs: mat3x3_b(3,3)')
write(stdout,*) 'subroutine solve_dsysv_nrhs() (symmetric equation solver) passed unit test'
write(stdout,*)
#endif

!---- Test: sparse linear equation solver
#ifdef USE_SUPERLU
mat3x3(1,1) = 1.0d0
mat3x3(1,2) = 0.0d0
mat3x3(1,3) = 3.0d0
mat3x3(2,1) = 0.0d0
mat3x3(2,2) = 5.0d0
mat3x3(2,3) = 0.0d0
mat3x3(3,1) = 3.0d0
mat3x3(3,2) = 0.0d0
mat3x3(3,3) = 1.0d0
vec3(1) = 11.0d0
vec3(2) = 12.0d0
vec3(3) = 13.0d0
call solve_dgssv(mat3x3,vec3,vec3,3,3,ierr)
call test_value(vec3(1),3.5d0,'solve_dgssv: vec3(1)')
call test_value(vec3(2),2.4d0,'solve_dgssv: vec3(2)')
call test_value(vec3(3),2.5d0,'solve_dgssv: vec3(3)')
! do i = 1,3
!     write(0,*) vec3(i)
! enddo
write(stdout,*) 'subroutine solve_dgssv() (sparse linear equation solver) passed unit test'
write(stdout,*)
#endif

!---- Test: least squares solver
#ifdef USE_LAPACK
mat5x2(:,1) = 1.0d0
mat5x2(1,2) = 3.0d0
mat5x2(2,2) = 4.0d0
mat5x2(3,2) = 5.0d0
mat5x2(4,2) = 6.0d0
mat5x2(5,2) = 7.0d0
vec5(1) = 2.1d0
vec5(2) = 4.1d0
vec5(3) = 5.8d0
vec5(4) = 7.9d0
vec5(5) = 10.1d0
call solve_dgels(mat5x2,vec5,vec2,5,2,ierr)
! do i = 1,2
!     write(0,*) vec2(i)
! enddo
call test_value(vec2(1),-3.90d0,'solve_dgels: vec2(1)')
call test_value(vec2(2), 1.98d0,'solve_dgels: vec2(2)')
write(stdout,*) 'subroutine solve_dgels() (least-squares solver) passed unit test'
write(stdout,*)
#endif

!---- Test: non-negative least squares solver
mat5x2(:,1) = 1.0d0
mat5x2(1,2) = 3.0d0
mat5x2(2,2) = 4.0d0
mat5x2(3,2) = 5.0d0
mat5x2(4,2) = 6.0d0
mat5x2(5,2) = 7.0d0
vec5(1) = 10.1d0
vec5(2) = 12.1d0
vec5(3) = 13.8d0
vec5(4) = 15.9d0
vec5(5) = 18.1d0
call solve_nnls(mat5x2,vec5,vec2,5,2,ierr)
! do i = 1,2
!     write(0,*) vec2(i)
! enddo
call test_value(vec2(1), 4.10d0,'solve_nnls: vec2(1)')
call test_value(vec2(2), 1.98d0,'solve_nnls: vec2(2)')
write(stdout,*) 'subroutine solve_nnls() (non-negative least-squares solver) passed unit test'
write(stdout,*)

write(stdout,*) 'solver_module unit test passed'
end


*DECK QRFAC
      SUBROUTINE QRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA, ACNORM,
     +   WA)
C***BEGIN PROLOGUE  QRFAC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (QRFAC-S, DQRFAC-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     This subroutine uses Householder transformations with column
C     pivoting (optional) to compute a QR factorization of the
C     M by N matrix A. That is, QRFAC determines an orthogonal
C     matrix Q, a permutation matrix P, and an upper trapezoidal
C     matrix R with diagonal elements of nonincreasing magnitude,
C     such that A*P = Q*R. The Householder transformation for
C     column K, K = 1,2,...,MIN(M,N), is of the form
C
C                           T
C           I - (1/U(K))*U*U
C
C     where U has zeros in the first K-1 positions. The form of
C     this transformation and the method of pivoting first
C     appeared in the corresponding LINPACK subroutine.
C
C     The subroutine statement is
C
C       SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of A.
C
C       N is a positive integer input variable set to the number
C         of columns of A.
C
C       A is an M by N array. On input A contains the matrix for
C         which the QR factorization is to be computed. On output
C         the strict upper trapezoidal part of A contains the strict
C         upper trapezoidal part of R, and the lower trapezoidal
C         part of A contains a factored form of Q (the non-trivial
C         elements of the U vectors described above).
C
C       LDA is a positive integer input variable not less than M
C         which specifies the leading dimension of the array A.
C
C       PIVOT is a logical input variable. If pivot is set .TRUE.,
C         then column pivoting is enforced. If pivot is set .FALSE.,
C         then no column pivoting is done.
C
C       IPVT is an integer output array of length LIPVT. IPVT
C         defines the permutation matrix P such that A*P = Q*R.
C         Column J of P is column IPVT(J) of the identity matrix.
C         If pivot is .FALSE., IPVT is not referenced.
C
C       LIPVT is a positive integer input variable. If PIVOT is
C             .FALSE., then LIPVT may be as small as 1. If PIVOT is
C             .TRUE., then LIPVT must be at least N.
C
C       SIGMA is an output array of length N which contains the
C         diagonal elements of R.
C
C       ACNORM is an output array of length N which contains the
C         norms of the corresponding columns of the input matrix A.
C         If this information is not needed, then ACNORM can coincide
C         with SIGMA.
C
C       WA is a work array of length N. If pivot is .FALSE., then WA
C         can coincide with SIGMA.
C
C***SEE ALSO  SNLS1, SNLS1E, SNSQ, SNSQE
C***ROUTINES CALLED  ENORM, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  QRFAC
      INTEGER M,N,LDA,LIPVT
      INTEGER IPVT(*)
      LOGICAL PIVOT
      REAL A(LDA,*),SIGMA(*),ACNORM(*),WA(*)
      INTEGER I,J,JP1,K,KMAX,MINMN
      REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO
      REAL R1MACH,ENORM
      SAVE ONE, P05, ZERO
      DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/
C***FIRST EXECUTABLE STATEMENT  QRFAC
      EPSMCH = R1MACH(4)
C
C     COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS.
C
      DO 10 J = 1, N
         ACNORM(J) = ENORM(M,A(1,J))
         SIGMA(J) = ACNORM(J)
         WA(J) = SIGMA(J)
         IF (PIVOT) IPVT(J) = J
   10    CONTINUE
C
C     REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS.
C
      MINMN = MIN(M,N)
      DO 110 J = 1, MINMN
         IF (.NOT.PIVOT) GO TO 40
C
C        BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION.
C
         KMAX = J
         DO 20 K = J, N
            IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K
   20       CONTINUE
         IF (KMAX .EQ. J) GO TO 40
         DO 30 I = 1, M
            TEMP = A(I,J)
            A(I,J) = A(I,KMAX)
            A(I,KMAX) = TEMP
   30       CONTINUE
         SIGMA(KMAX) = SIGMA(J)
         WA(KMAX) = WA(J)
         K = IPVT(J)
         IPVT(J) = IPVT(KMAX)
         IPVT(KMAX) = K
   40    CONTINUE
C
C        COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE
C        J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR.
C
         AJNORM = ENORM(M-J+1,A(J,J))
         IF (AJNORM .EQ. ZERO) GO TO 100
         IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM
         DO 50 I = J, M
            A(I,J) = A(I,J)/AJNORM
   50       CONTINUE
         A(J,J) = A(J,J) + ONE
C
C        APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS
C        AND UPDATE THE NORMS.
C
         JP1 = J + 1
         IF (N .LT. JP1) GO TO 100
         DO 90 K = JP1, N
            SUM = ZERO
            DO 60 I = J, M
               SUM = SUM + A(I,J)*A(I,K)
   60          CONTINUE
            TEMP = SUM/A(J,J)
            DO 70 I = J, M
               A(I,K) = A(I,K) - TEMP*A(I,J)
   70          CONTINUE
            IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80
            TEMP = A(J,K)/SIGMA(K)
            SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2))
            IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80
            SIGMA(K) = ENORM(M-J,A(JP1,K))
            WA(K) = SIGMA(K)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
         SIGMA(J) = -AJNORM
  110    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE QRFAC.
C
      END


c invierte una matriz a por medio del metodo svd
c y calcula la solucion x al problema a*x=b
c a la salida la solucion x se guardara en b
c la matriz a queda destruida a la salida
        subroutine svdmatriz2(a,n,mnodos,b,tol,v,w)

	implicit real*4 (a-h,o-z)
	include 'PARAMETER'  !para kt y mfitmax

        dimension a(mfitmax,mfitmax),b(*),w(mfitmax),v(mfitmax,mfitmax)
     &            ,mnodos(*),mm(18)
	real wt(kt),ww(kt),wi(2,kt)

c      print*,'mfitmax,n=',mfitmax,n
c      do i=1,mfitmax
c          do j=1,mfitmax
c             print*,'a(i,j)=',i,j,a(i,j)
c          enddo
c      enddo

c      do i=1,mfitmax
c         print*,'i,b=',i,b(i)
c      enddo

       call svdcmp2(a,n,n,n,n,w,v)

c contamos el numero de variables (no param. libres sino variables t,pe...)
	nvar=0
	do i=1,18
	   if(mnodos(i).gt.0)then
	       nvar=nvar+1
	       mm(nvar)=mnodos(i)
c               print*,'en svdmatriz2 mm(',nvar,')=',mm(nvar),' n=',n
	   end if
	end do

c el numero minimo de param. libres es el numero de variables.
c Si el num. de variables es > que el de param. libres estudiamos si
c se debe reducir el numero de variables

	if(nvar.ne.n)then

c evidentemente si el num. de variables es 1 no hacemos nada

	   if(nvar.eq.1)then

c calculamos el maximo
	      wmax=0.d0
	      do j=1,n
	         if(w(j).gt.wmax)wmax=w(j)
	      end do

c anulamos los terminos menores que el max. por tol.
	      wmin=wmax*tol
	      do j=1,n
	         if(w(j).lt.wmin)w(j)=0
	      end do
           else

c repito dos veces el proceso para optimizarlo
	      do ido=1,2

	         do i=1,n
	            ww(i)=0.
	         end do
	         i2=0
	         do i0=1,nvar
                    i1=i2+1	         !indice inicial para el parametro i
		    i2=i2+mm(i0)         !indice final
                    do j=1,n
                       wt(j)=0           !inicializo las w para cada parametro
                    end do

c construyo la submatriz
	            do j=1,n
                       do i=i1,i2        !w para cada parametro
	                  wt(j)=wt(j)+v(i,j)*v(i,j)*w(j)
	               end do
	            end do

c calculamos el maximo
	            wtx=0.
                    do j=1,n
	               if(wt(j).gt.wtx)wtx=wt(j)
	            end do

c anulamos los terminos menores que el max. por tol.
	            wtn=wtx*tol
	            do j=1,n
	               if(wt(j).lt.wtn)then
		          wt(j)=0.
	               else
	                  ww(j)=ww(j)+wt(j)
	               end if
	            end do
	         end do
	         do j=1,n
	            w(j)=ww(j)
	            wi(ido,j)=w(j)
	         end do
	      end do

c adopto la primera correccion modificada por la segunda
	      do j=1,n
	         if(abs(wi(2,j)).gt.1.e-10)then
	            w(j)=wi(1,j)*wi(1,j)/wi(2,j)
	         else
	            w(j)=0.e0
	         end if
	      end do
	   end if

        end if

c        print*,'en svdmatriz2 a',a(1,1),' b=',b(1)

	call svbksb(a,w,v,n,n,n,n,b,b)

c        print*,'en svdmatriz2 a*x=b x=',b(1)

	return
	end


module math
    use def
    contains
        function subtractPoint(p1, p2) result(p3)
            type(point), intent(in) :: p1, p2
            type(point):: p3
            p3%x = p1%x - p2%x
            p3%y = p1%y - p2%y
            p3%z = p1%z - p2%z
        end function subtractPoint
        function addPoint(p1, p2) result(p3)
            type(point), intent(in) :: p1, p2
            type(point) :: p3
            p3%x = p1%x + p2%x
            p3%y = p1%y + p2%y
            p3%z = p1%z + p2%z
        end function addPoint
        function scalePoint(p1, d) result(p2)
            type(point), intent(in) :: p1
            real, intent(in) :: d
            type(point) :: p2
            p2%x = p1%x * d
            p2%y = p1%y * d
            p2%z = p1%z * d
        end function scalePoint
        function rayToPoint(r1) result(p1)
            type(ray), intent(in) :: r1
            type(point) :: p1
            p1%x = r1%p%x
            p1%y = r1%p%y
            p1%z = r1%p%z
        end function rayToPoint
        function rayVelToPoint(r1) result(p1)
            type(ray), intent(in) :: r1
            type(point) :: p1
            p1%x = r1%v%x
            p1%y = r1%v%y
            p1%z = r1%v%z
        end function rayVelToPoint
        function magnitude(p1) result(d)
            type(point), intent(in) :: p1
            real :: d
            d = real(sqrt(p1%x ** 2 + p1%y ** 2 + p1%z ** 2))
        end function magnitude
        function calculateRay(r1, distance) result(r3)
            type(ray), intent(in) :: r1
            real :: distance, vmag, t
            type(ray) :: r3
            type(point) :: r1p2, v, L, r1p1
            r1p1 = rayToPoint(r1)
            r1p2 = rayVelToPoint(r1)
            v = subtractPoint(r1p2,r1p1)
            vmag = magnitude(v)
            t = distance / vmag
            L = addPoint(r1p1, scalePoint(v, t))
            r3%p%x = r1%p%x
            r3%p%z = r1%p%z
            r3%p%y = r1%p%y
            r3%v%x = L%x
            r3%v%y = L%y
            r3%v%z = L%z
        end function calculateRay
        function sphdistance(p1, p2) result(d1)
            type(point), intent(in) :: p2
            type(sphere), intent(in) :: p1
            real :: d1
            d1 = real(sqrt((p1%p%x - p2%x) ** 2 + (p1%p%y - p2%y) ** 2 + (p1%p%z - p2%z) ** 2))
            d1 = d1 + p1%r - 0.1
        end function sphdistance
        function distance(p1, p2) result(d1)
            type(point), intent(in) :: p1, p2
            real :: d1
            d1 = real(sqrt((p1%x - p2%x) ** 2 + (p1%y - p2%y) ** 2 + (p1%z - p2%z) ** 2))
        end function distance
        function isInsideSphere(p1, sph) result (bool)
            type(point), intent(in) :: p1
            type(sphere), intent(in) :: sph
            integer :: bool
            if (distance(p1, sph%p) < sph%r + 0.01) then
                bool = 1
            else
                bool = 0
            end if
        end function isInsideSphere
end module math


c ----------------------------------------------------------------------
c
c Modified N.O.Jensen wake model
c by Juan P. Murcia <jumu@dtu.dk>
c
c ----------------------------------------------------------------------

c ----------------------------------------------------------------------
c get_RW(x,D,CT,kj)
c ----------------------------------------------------------------------
c Computes the wake radius at a location
c
c Inputs
c ----------
c x (float): Distance between turbines in the stream-wise direction
c D (float): Wind turbine diameter
c CT (float): Outputs WindTurbine object's thrust coefficient
c kj (float): Wake (linear) expansion coefficient
c
c Outputs
c ----------
c Rw (float): Wake radius at a location
      subroutine get_RW(n,x,D,CT,RW,kj)

      implicit none
      integer :: n
      real(kind=8) :: x(n),D,CT,RW(n),kj
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py real(kind=8) intent(in),dimension(n) :: x
cf2py real(kind=8) intent(in) :: D,CT
cf2py real(kind=8) optional,intent(in) :: kj = 0.050
cf2py real(kind=8) intent(out), depend(n),dimension(n) :: RW
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i
      real(kind=8) :: Area,a,k

      Area=pi*D*D/4.0d0
      ! axial velocity deficit at rotor disc
      a=(1.0d0-(sqrt(1.0d0-CT)))/2.0d0
      ! Near wake expansion ratio: k = D0/D from momentum balance
      !k=1.0d0
      k=sqrt((1.0d0-a)/(1.0d0-2.0d0*a))

      do i = 1, n
        if (x(i)<= 0) then !3.0d0*D ) then !
          ! Null wake radius for locations in front of the rotor disc
          RW(i) = 0.0d0
        else
          ! Linear wake expansion x0 = 3D
          RW(i)=0.5d0*k*D + kj*( x(i) - 3.0d0*D )
          !RW(i)=0.5d0*k*D + kj*( x(i) )
        end if
      end do
      end subroutine get_RW

c ----------------------------------------------------------------------
c get_dU(x,r,D,CT,kj)
c ----------------------------------------------------------------------
c Computes the wake velocity deficit at a location
c
c Inputs
c ----------
c x (float): Distance between turbines in the stream-wise direction
c r (array): Radial distance between the turbine and the location
c D (float): Wind turbine diameter
c CT (float): Outputs WindTurbine object's thrust coefficient
c kj (float): Wake (linear) expansion coefficient
c
c Outputs
c ----------
c dU (float): Wake velocity deficit at a location normalized
c             by rotor averaged (equivalent) inflow velocity
      subroutine get_dU(n,x,r,D,CT,kj,dU)

      implicit none
      integer :: n
      real(kind=8) :: x(n),r(n),D,CT,kj,dU(n)
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py real(kind=8) intent(in),dimension(n) :: x
cf2py real(kind=8) intent(in),depend(n),dimension(n) :: r
cf2py real(kind=8) intent(in) :: D,CT
cf2py real(kind=8) optional,intent(in) :: kj = 0.050
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: dU
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i
      real(kind=8) :: a
      real(kind=8), dimension(n) :: RW

      ! axial velocity deficit at rotor disc
      a=(1.0d0-(sqrt(1.0d0-CT)))/2.0d0
      ! wake radius at x locations
      call get_RW(n,x,D,CT,RW,kj)

      do i = 1, n
        if ((x(i) <= 0).or.(r(i) >= RW(i))) then
          ! Null deficit for locations in front of the rotor disc
          ! and outside the wake radius
          dU(i) = 0.0d0
        else
          dU(i)=-(2.0d0*a*(D**(2.0d0)))/((2.0d0*RW(i))**(2.0d0))
        end if
      end do
      end subroutine get_dU

c ----------------------------------------------------------------------
c get_dUeq(x,y,z,DT,D,CT,kj)
c ----------------------------------------------------------------------
c Computes the rotor averaged (equivalent) wake velocity deficit at
c different turbine locations and diameters.
c Takes into account partial wake conditions as presented in:
c Wan, C., Wang, J., Yang, G., Gu, H., & Zhang, X. (2012).
c Wind farm micro-siting by Gaussian particle swarm optimization with
c local search strategy. Renewable Energy, 48, 276-286.
c
c Inputs
c ----------
c x (array): Distance between turbines in the stream-wise direction
c y (array): Distance between turbines in the cross-flow direction
c z (array): Distance between turbines in the vertical direction
c DT (array): Wake operating turbines diameter
c D (float): Wake generating turbine diameter
c CT (float): Outputs WindTurbine object's thrust coefficient
c kj (float): Wake (linear) expansion coefficient
c
c Outputs
c ----------
c dUeq (float): Wake velocity deficit at a location normalized by
c               inflow velocity
      subroutine get_dUeq(n,x,y,z,DT,D,CT,kj,dUeq)

      implicit none
      integer :: n
      real(kind=8) :: x(n),y(n),z(n),DT(n),D,CT,kj,dUeq(n)
cf2py integer intent(hide),depend(x) :: n = len(x)
cf2py real(kind=8) intent(in),dimension(n) :: x
cf2py real(kind=8) intent(in),depend(n),dimension(n) :: y,z,DT
cf2py real(kind=8) intent(in) :: D,CT
cf2py real(kind=8) optional,intent(in) :: kj = 0.050
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: dUeq
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i
      real(kind=8) :: Area,alpha1,alpha2,q,tm1,tm2,tm3,tm4,tm5,tm6
      real(kind=8), dimension(1) :: x_e,r_e,dU
      real(kind=8), dimension(n) :: r,RT,RW

      Area=pi*D*D/4.0d0
      RT = DT/2.0d0
      ! Location of the turbines in wake coordinates
      r  = (y**(2.0d0) + z**(2.0d0))**(0.5d0)
      ! wake radius at turbine x locations
      call get_RW(n,x,D,CT,RW,kj)
      do i = 1, n
        if (x(i) > 0.0) then
          if (((x(i)==0.0d0).and.(r(i)==0.0d0)).or.(RW(i)==0.0d0)) then
            dUeq(i)=0.0d0
          ! turbine is totally inside the wake
          else if (r(i) <= (RW(i)-RT(i))) then
            x_e = x(i)
            r_e = r(i)
            call get_dU(1,x_e,r_e,D,CT,kj,dU)
            dUeq(i)=dU(1)
          ! Partial wakes
          else if ((r(i)>(RW(i)-RT(i))).and.(r(i)<(RW(i)+RT(i)))) then
            x_e = x(i)
            r_e = 0.5d0*(RW(i)+r(i)-RT(i))
            call get_dU(1,x_e,r_e,D,CT,kj,dU)
            tm1 = RT(i)**(2.0d0)+r(i)**(2.0d0)-RW(i)**(2.0d0)
            tm2 = tm1/(2.0d0*RT(i)*r(i))
            alpha1 = 2.0d0*acos(tm2)

            tm3 = RW(i)**(2.0d0)+r(i)**(2.0d0)-RT(i)**(2.0d0)
            tm4 = tm3/(2.0d0*RW(i)*r(i))
            alpha2 = 2.0d0*acos(tm4)

            tm5 = 0.5d0*((RT(i))**(2.0d0))*(alpha1 - sin(alpha1))
            tm6 = 0.5d0*((RW(i))**(2.0d0))*(alpha2 - sin(alpha2))
            q = (tm5 + tm6)/Area

            dUeq(i)=dU(1)*q
          else
            dUeq(i)=0.0d0
          end if
        else
          dUeq(i)=0.0d0
        end if
      end do

      end subroutine get_dUeq

c ----------------------------------------------------------------------
c mod_noj_s(x,y,z,DT,P_c,CT_c,WS,kj)
c ----------------------------------------------------------------------
c SINGLE FLOW CASE
c Computes the WindFarm flow and Power using N. O. Jensen model:
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (float): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (float): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c kj (float): Wake (linear) expansion coefficient
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine mod_noj_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,kj,
     &rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),WS,WD,kj
      real(kind=8) :: rho,WS_CI(n),WS_CO(n),CT_idle(n),P(n),T(n),U(n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in) :: WS,WD
cf2py real(kind=8) optional,intent(in) :: kj = 0.050
cf2py real(kind=8) optional,intent(in) :: rho = 1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI = 4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO = 25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle = 0.053
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: P,T,U
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i,j,k,nDownstream(n),idT(n)
      real(kind=8) :: x(n),y(n),z(n),D,CT,angle,dUeq(n),dUsq(n)
      real(kind=8) :: x_l(n,n),y_l(n,n)

      ! Rotates the global coordinates to local flow coordinates
      angle = pi*(270.0d0-WD)/180.0d0
      do i=1,n
        do j=1,n
          x_l(i,j) = cos(angle)*x_g(i,j)+sin(angle)*y_g(i,j)
          y_l(i,j) = -sin(angle)*x_g(i,j)+cos(angle)*y_g(i,j)
        end do
        ! counts the number of turbines in front of turbine
        nDownstream(i) = count(x_l(i,:).lt.0)
      end do
      ! Indexes of ordered turbines from most upstream turbine
      call order_id(n,nDownstream,idT)
      ! Initializes the rotor averaged (equivalent) velocity
      U = WS
      dUsq = 0d0
      ! Computes the rotor averaged (equivalent) velocity deficit
      do j=1,n
        i=idT(j)
        x = x_l(i,:)
        y = y_l(i,:)
        z = z_g(i,:)
        D = DT(i)

        if ((U(i) >= WS_CI(i)).and.(U(i) <= WS_CO(i))) then
          call interp_l(CT_c(i,:,1),CT_c(i,:,2),nCT,U(i),CT)
        else
          CT = CT_idle(i)
        end if
        call get_dUeq(n,x,y,z,DT,D,CT,kj,dUeq)
        !
        !Wake deficits are normalized by the local velocity
        !Linear sum wake deficits superposition
        dUsq = (U(i)*dUeq)**(2.0d0)
        U = U - dUsq**(0.5d0)
        !
        !All deficits are normalized by the inflow velocity
        !Squared root of the sum of squares wake deficits superposition
        !dUsq = dUsq + (WS*dUeq)**(2.0d0)
        !U = WS - dUsq**(0.5d0)
      end do
      ! Calculates the power and thrust
      do k=1,n
        if ((U(k) >= WS_CI(k)).and.(U(k) <= WS_CO(k))) then
          call interp_l(P_c(k,:,1),P_c(k,:,2),nP,U(k),P(k))
          call interp_l(CT_c(k,:,1),CT_c(k,:,2),nCT,U(k),CT)
        else
          P(k)=0.0d0
          CT = CT_idle(k)
        end if
        T(k) = CT*0.5d0*rho*U(k)*U(k)*pi*DT(k)*DT(k)/4.0d0
      end do

      end subroutine mod_noj_s

c ----------------------------------------------------------------------
c mod_noj(x,y,z,DT,P_c,CT_c,WS,WD,kj)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c kj (float): Wake (linear) expansion coefficient
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine mod_noj(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,kj,
     &rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,WD,kj
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,WD
cf2py real(kind=8) optional,intent(in),dimension(nF)::kj = 0.050
cf2py real(kind=8) optional,intent(in) :: rho = 1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI = 4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO = 25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle = 0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i

      do i=1,nF
        call mod_noj_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD(i),
     &            kj(i),rho,WS_CI,WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine mod_noj

c ----------------------------------------------------------------------
c mod_noj_av(x,y,z,DT,P_c,CT_c,WS,WD,kj,AV)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES with wt available
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c kj (float): Wake (linear) expansion coefficient
c AV (array): Wind turbine available per flow [nF,n]
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine mod_noj_av(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,
     &kj,AV,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,AV(nf,n)
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,WD,kj
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,WD
cf2py integer intent(in),dimension(nF,n) :: AV
cf2py real(kind=8) optional,intent(in),dimension(nF)::kj = 0.050
cf2py real(kind=8) optional,intent(in) :: rho = 1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI = 4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO = 25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle = 0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i,j
      real(kind=8) :: CT_c_AV(n,nCT,2), P_c_AV(n,nCT,2)

      do i=1,nF
        CT_c_AV = CT_c
        P_c_AV  = P_c
        ! Re-defines the trust curve for non available turbines
        do j=1,n
          if (AV(i,j)==0) then
            CT_c_AV(j,:,2) = CT_idle(j)
            P_c_AV(j,:,2) = 0.0d0
          end if
        end do
        call mod_noj_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c_AV,CT_c_AV,WS(i),
     &       WD(i),kj(i),rho,WS_CI,WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine mod_noj_av

c ----------------------------------------------------------------------
c mod_noj_GA(x,y,z,DT,P_c,CT_c,WS,WD,STD_WD,Nga)
c ----------------------------------------------------------------------
c GAUSSIAN AVERAGE
c Gauss-Hermite quadrature for normally distributed wind direction
c uncertainty (inside Reynolds averaging time), for a global/unique wind
c direction uncertainty
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c STD_WD(array): Standard deviation of wind direction uncertainty
c Nga (int): Number of quadrature points for Gaussian averaging
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine mod_noj_GA(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,
     &STD_WD,Nga,kj,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,Nga
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,WD,STD_WD,kj
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,WD,STD_WD
cf2py integer optional,intent(in) :: Nga = 4
cf2py real(kind=8) optional,intent(in),dimension(nF)::kj = 0.050
cf2py real(kind=8) optional,intent(in) :: rho = 1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI = 4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO = 25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle = 0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i,j
      real(kind=8) :: WD_aux
      real(kind=8), dimension(n) :: P_aux,T_aux,U_aux
      real(kind=8), dimension(Nga) :: root,weight

      ! Gauss-Hermite quadrature points and weights
      select case (Nga)
        case ( 1 )
          root(1) = 0.0d0
          weight(1) = sqrt(pi)
        case ( 4 )
          root(1) = -1.650680123885785d0
          root(2) = -0.524647623275290d0
          root(3) = 0.524647623275290d0
          root(4) = 1.650680123885785d0

          weight(1) = 0.081312835447245d0
          weight(2) = 0.804914090005513d0
          weight(3) = 0.804914090005513d0
          weight(4) = 0.081312835447245d0
        case ( 5 )
          root(1) = -2.020182870456086d0
          root(2) = -0.958572464613819d0
          root(3) = 0.000000000000000d0
          root(4) = 0.958572464613819d0
          root(5) = 2.020182870456086d0

          weight(1) = 0.019953242059046d0
          weight(2) = 0.393619323152241d0
          weight(3) = 0.945308720482942d0
          weight(4) = 0.393619323152241d0
          weight(5) = 0.019953242059046d0
        case ( 6 )
          root(1) = -2.350604973674492d0
          root(2) = -1.335849074013697d0
          root(3) = -0.436077411927617d0
          root(4) = 0.436077411927617d0
          root(5) = 1.335849074013697d0
          root(6) = 2.350604973674492d0

          weight(1) = 0.004530009905509d0
          weight(2) = 0.157067320322856d0
          weight(3) = 0.724629595224392d0
          weight(4) = 0.724629595224392d0
          weight(5) = 0.157067320322856d0
          weight(6) = 0.004530009905509d0
        case ( 7 )
          root(1) = -2.651961356835233d0
          root(2) = -1.673551628767471d0
          root(3) = -0.816287882858965d0
          root(4) = 0.000000000000000d0
          root(5) = 0.816287882858965d0
          root(6) = 1.673551628767471d0
          root(7) = 2.651961356835233d0

          weight(1) = 0.000971781245100d0
          weight(2) = 0.054515582819127d0
          weight(3) = 0.425607252610128d0
          weight(4) = 0.810264617556807d0
          weight(5) = 0.425607252610128d0
          weight(6) = 0.054515582819127d0
          weight(7) = 0.000971781245100d0
        case ( 8 )
          root(1) = -2.930637420257244d0
          root(2) = -1.981656756695843d0
          root(3) = -1.157193712446780d0
          root(4) = -0.381186990207322d0
          root(5) = 0.381186990207322d0
          root(6) = 1.157193712446780d0
          root(7) = 1.981656756695843d0
          root(8) = 2.930637420257244d0

          weight(1) = 0.000199604072211d0
          weight(2) = 0.017077983007413d0
          weight(3) = 0.207802325814892d0
          weight(4) = 0.661147012558241d0
          weight(5) = 0.661147012558241d0
          weight(6) = 0.207802325814892d0
          weight(7) = 0.017077983007413d0
          weight(8) = 0.000199604072211d0
      end select

      do i=1,nF
        P(i,:)=0.0d0
        T(i,:)=0.0d0
        U(i,:)=0.0d0
        do j=1,Nga
          WD_aux = WD(i)+sqrt(2.0d0)*STD_WD(i)*root(j)
          call mod_noj_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD_aux,
     &      kj(i),rho,WS_CI,WS_CO,CT_idle,P_aux,T_aux,U_aux)
          P(i,:)=P(i,:)+weight(j)*P_aux*(1.0d0/sqrt(pi))
          T(i,:)=T(i,:)+weight(j)*T_aux*(1.0d0/sqrt(pi))
          U(i,:)=U(i,:)+weight(j)*U_aux*(1.0d0/sqrt(pi))
        end do
      end do

      end subroutine mod_noj_GA

c ----------------------------------------------------------------------
c mod_noj_mult_wd(x,y,z,DT,P_c,CT_c,WS,WD,TI)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES with individual wind direction for each turbine
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c TI (array): Ambient turbulence intensity [-]
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine mod_noj_mult_wd(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,
     &WD,STD_WD,Nga,kj,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,Nga
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,kj
      real(kind=8),dimension(nF,n) :: WD, STD_WD
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS
cf2py real(kind=8) intent(in),dimension(nF,n) :: WD
cf2py real(kind=8) optional,intent(in),dimension(nF,n) :: STD_WD = 0.0
cf2py integer optional intent(in) :: Nga = 1
cf2py real(kind=8) optional,intent(in),dimension(nF)::kj = 0.050
cf2py real(kind=8) optional,intent(in) :: rho = 1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI = 4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO = 25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle = 0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i,j
      real(kind=8), dimension(n) :: P_aux,T_aux,U_aux

      do j=1,n
        do i=1,nF
          call mod_noj_GA(n,nP,nCT,1,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),
     &WD(i,j),STD_WD(i,j),Nga,kj(i),rho,WS_CI,WS_CO,CT_idle,P_aux,
     &T_aux,U_aux)
!          call mod_noj_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD(i,j),
!     &      kj(i),rho,WS_CI,WS_CO,CT_idle,P_aux,T_aux,U_aux)
          P(i,j)=P_aux(j)
          T(i,j)=T_aux(j)
          U(i,j)=U_aux(j)
        end do
      end do

      end subroutine mod_noj_mult_wd

c ----------------------------------------------------------------------
c Additional routines
c ----------------------------------------------------------------------

c ----------------------------------------------------------------------
c Find the lower location index of a point in an ordered array
c ----------------------------------------------------------------------
      subroutine loc_in_list(n,xa,x,j)
      implicit none
      integer j,n
      real(kind=8) x,xa(n)
cf2py integer intent(hide),depend(xa) :: n = len(xa)
cf2py real(kind=8) intent(in),dimension(n) :: xa
cf2py real(kind=8) intent(in) :: x
cf2py integer intent(out) :: j
      ! internal variables
      integer j_low,j_mid,j_up
      j_low=0
      j_up=n+1
      ! bisecting loop
      do while (j_up-j_low.gt.1)
        j_mid=(j_up+j_low)/2
        if((xa(n).ge.xa(1)).eqv.(x.ge.xa(j_mid)))then
          j_low=j_mid
        else
          j_up=j_mid
        end if
      end do
      ! check for cases
      if(x.eq.xa(1))then
        j=1
      else if(x.eq.xa(n))then
        j=n-1
      else
        j=j_low
      end if
      end subroutine loc_in_list

c ----------------------------------------------------------------------
c Linear interpolation
c ----------------------------------------------------------------------
      subroutine interp_l(xa,ya,n,x,y)
      implicit none
      integer n
      real(kind=8) x,y,xa(n),ya(n)
cf2py integer intent(hide),depend(xa) :: n = len(xa)
cf2py real(kind=8) intent(in),dimension(n) :: xa
cf2py real(kind=8) intent(in),depend(n),dimension(n) :: ya
cf2py real(kind=8) intent(in) :: x
cf2py real(kind=8) intent(out) :: y
      ! internal variables
      integer j
      call loc_in_list(n,xa,x,j)
      y = ((ya(j+1)-ya(j))/(xa(j+1)-xa(j)))*(x-xa(j)) + ya(j)
      end subroutine interp_l

c ----------------------------------------------------------------------
c Finds the index that order an array from lower to higher values
c only for integers
c
c Knuth, D. E. "Sorting and Searching, vol. 3 of The Art of Computer
c Programming, section 6.2. 2." (1997): 430-31.
c ----------------------------------------------------------------------
      subroutine order_id(n,a,id)
      integer n,a(n),id(n)
cf2py integer intent(hide),depend(a) :: n = len(a)
cf2py integer intent(in),dimension(n) :: a
cf2py integer intent(out),depend(n),dimension(n) :: id
      ! internal variables
      integer i,j,inc,v,w
      do i=1,n
        id(i)=i
      end do
      ! Determine starting increment
      inc=1
      do while (inc.le.n)
        inc=3*inc+1
      end do
      ! Partial sorts loop
      do while (inc.gt.1)
        inc=inc/3
        do i=inc+1,n
          v=a(i)
          w=id(i)
          j=i
          do while (a(j-inc).gt.v)
            a(j)=a(j-inc)
            id(j)=id(j-inc)
            j=j-inc
            if(j.le.inc) exit
          end do
          a(j)=v
          id(j)=w
        end do
      end do
      end subroutine order_id


	SUBROUTINE VC_QUAD  ( p1, p2, p3, pp, v1, v2, v3, nxy, vv, iret )
C************************************************************************
C* VC_QUAD								*
C*									*
C*  This subroutine performs quadratic interpolation.			*
C*									*
C* VC_QUAD ( P1, P2, P3, PP, V1, V2, V3, NXY, VV, IRET )		*
C*									*
C* Input parameters:							*
C*	P1 (NXY)	REAL		Ln (p) bottom			*
C*	P2 (NXY)	REAL		Ln (p) intermediate		*
C*	P3 (NXY)	REAL		Ln (p) top			*
C*	PP (NXY)	REAL		Ln (p) at level of interest	*
C*	V1 (NXY)	REAL		Value at bottom			*
C*	V2 (NXY)	REAL		Value at intermediate level	*
C*	V3 (NXY)	REAL		Value at top			*
C*	NXY		INTEGER		Number of grid points		*
C*									*
C* Output parameters:							*
C*	VV (NXY)	REAL		Value on level of interest	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC		07/92						*
C* K. Brill/NMC		08/92	Add missing value check			*
C* K. Brill/NMC		11/92	Add last icnt increment			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		p1 (*), p2 (*), p3 (*), pp (*),
     +			v1 (*), v2 (*), v3 (*), vv (*)
C*
	LOGICAL		betwen
	INCLUDE		'ERMISS.FNC'
C*
	BETWEN ( rlev, rlo, rhi ) =
     +     ( ( rlev .ge. rlo .and. rlev .le. rhi )   .or.
     +       ( rlev .le. rlo .and. rlev .ge. rhi ) )
C-----------------------------------------------------------------------
	iret = 0
	icnt = 0
C
C*	Interpolate only at points between the two bounding surfaces.
C*	Store missing values elsewhere.
C
	DO ij = 1, nxy
	    IF ( BETWEN ( pp (ij), p1 (ij), p3 (ij) ) .and.
     +		 .not. ( ERMISS ( p1 (ij) ) .or.
     +			 ERMISS ( p2 (ij) ) .or.
     +			 ERMISS ( p3 (ij) ) .or.
     +		         ERMISS ( pp (ij) ) .or.
     +			 ERMISS ( v1 (ij) ) .or.
     +			 ERMISS ( v2 (ij) ) .or.
     +			 ERMISS ( v3 (ij) )      ) .and.
     +			 p1 (ij) .ne. p2 (ij) .and.
     +			 p2 (ij) .ne. p3 (ij) .and.
     +			 p1 (ij) .ne. p3 (ij) ) THEN
C
C*		Do quadratic interpolation if values are not missing.
C
		a = p1 (ij) * p1 (ij)
		b = p1 (ij)
		d = p2 (ij) * p2 (ij)
		e = p2 (ij)
		g = p3 (ij) * p3 (ij)
		h = p3 (ij)
		f = d - g
		ff = a - d
		IF ( f .ne. 0.0 .and. ff .ne. 0.0 ) THEN
		    c = ( e - h ) / f
		    cc =  ( v2 (ij) - v3 (ij) ) / f
		    y = ( v1 (ij) - v2 (ij) ) / ff - cc
		    y = y / ( (b-e)/ff - c )
		    x = cc - c * y
		    z = v3 (ij) - g * x - h * y
C*
		    vv ( ij ) = z + pp (ij) * ( y + x * pp (ij) )
		ELSE
		    vv ( ij ) = RMISSD
		    icnt = icnt + 1
		END IF
C*
	    ELSE
		vv (ij) = RMISSD
		icnt = icnt + 1
	    END IF
	END DO
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


*> \brief \b DSYEQUB
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYEQUB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, N
*       DOUBLE PRECISION   AMAX, SCOND
*       CHARACTER          UPLO
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * ), S( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DSYEQUB computes row and column scalings intended to equilibrate a
*> symmetric matrix A (with respect to the Euclidean norm) and reduce
*> its condition number. The scale factors S are computed by the BIN
*> algorithm (see references) so that the scaled matrix B with elements
*> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
*> the smallest possible condition number over all possible diagonal
*> scalings.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of A is stored;
*>          = 'L':  Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          The N-by-N symmetric matrix whose scaling factors are to be
*>          computed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is DOUBLE PRECISION array, dimension (N)
*>          If INFO = 0, S contains the scale factors for A.
*> \endverbatim
*>
*> \param[out] SCOND
*> \verbatim
*>          SCOND is DOUBLE PRECISION
*>          If INFO = 0, S contains the ratio of the smallest S(i) to
*>          the largest S(i). If SCOND >= 0.1 and AMAX is neither too
*>          large nor too small, it is not worth scaling by S.
*> \endverbatim
*>
*> \param[out] AMAX
*> \verbatim
*>          AMAX is DOUBLE PRECISION
*>          Largest absolute value of any matrix element. If AMAX is
*>          very close to overflow or very close to underflow, the
*>          matrix should be scaled.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup doubleSYcomputational
*
*> \par References:
*  ================
*>
*>  Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n
*>  Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n
*>  DOI 10.1023/B:NUMA.0000016606.32820.69 \n
*>  Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679
*>
*  =====================================================================
      SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   AMAX, SCOND
      CHARACTER          UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), S( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
      INTEGER            MAX_ITER
      PARAMETER          ( MAX_ITER = 100 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, ITER
      DOUBLE PRECISION   AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE,
     $                   SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ
      LOGICAL            UP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      LOGICAL            LSAME
      EXTERNAL           DLAMCH, LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASSQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
      ELSE IF ( N .LT. 0 ) THEN
         INFO = -2
      ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'DSYEQUB', -INFO )
         RETURN
      END IF

      UP = LSAME( UPLO, 'U' )
      AMAX = ZERO
*
*     Quick return if possible.
*
      IF ( N .EQ. 0 ) THEN
         SCOND = ONE
         RETURN
      END IF

      DO I = 1, N
         S( I ) = ZERO
      END DO

      AMAX = ZERO
      IF ( UP ) THEN
         DO J = 1, N
            DO I = 1, J-1
               S( I ) = MAX( S( I ), ABS( A( I, J ) ) )
               S( J ) = MAX( S( J ), ABS( A( I, J ) ) )
               AMAX = MAX( AMAX, ABS( A( I, J ) ) )
            END DO
            S( J ) = MAX( S( J ), ABS( A( J, J ) ) )
            AMAX = MAX( AMAX, ABS( A( J, J ) ) )
         END DO
      ELSE
         DO J = 1, N
            S( J ) = MAX( S( J ), ABS( A( J, J ) ) )
            AMAX = MAX( AMAX, ABS( A( J, J ) ) )
            DO I = J+1, N
               S( I ) = MAX( S( I ), ABS( A( I, J ) ) )
               S( J ) = MAX( S( J ), ABS( A( I, J ) ) )
               AMAX = MAX( AMAX, ABS( A( I, J ) ) )
            END DO
         END DO
      END IF
      DO J = 1, N
         S( J ) = 1.0D0 / S( J )
      END DO

      TOL = ONE / SQRT( 2.0D0 * N )

      DO ITER = 1, MAX_ITER
         SCALE = 0.0D0
         SUMSQ = 0.0D0
*        beta = |A|s
         DO I = 1, N
            WORK( I ) = ZERO
         END DO
         IF ( UP ) THEN
            DO J = 1, N
               DO I = 1, J-1
                  WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J )
                  WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I )
               END DO
               WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J )
            END DO
         ELSE
            DO J = 1, N
               WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J )
               DO I = J+1, N
                  WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J )
                  WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I )
               END DO
            END DO
         END IF

*        avg = s^T beta / n
         AVG = 0.0D0
         DO I = 1, N
            AVG = AVG + S( I )*WORK( I )
         END DO
         AVG = AVG / N

         STD = 0.0D0
         DO I = N+1, 2*N
            WORK( I ) = S( I-N ) * WORK( I-N ) - AVG
         END DO
         CALL DLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ )
         STD = SCALE * SQRT( SUMSQ / N )

         IF ( STD .LT. TOL * AVG ) GOTO 999

         DO I = 1, N
            T = ABS( A( I, I ) )
            SI = S( I )
            C2 = ( N-1 ) * T
            C1 = ( N-2 ) * ( WORK( I ) - T*SI )
            C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG
            D = C1*C1 - 4*C0*C2

            IF ( D .LE. 0 ) THEN
               INFO = -1
               RETURN
            END IF
            SI = -2*C0 / ( C1 + SQRT( D ) )

            D = SI - S( I )
            U = ZERO
            IF ( UP ) THEN
               DO J = 1, I
                  T = ABS( A( J, I ) )
                  U = U + S( J )*T
                  WORK( J ) = WORK( J ) + D*T
               END DO
               DO J = I+1,N
                  T = ABS( A( I, J ) )
                  U = U + S( J )*T
                  WORK( J ) = WORK( J ) + D*T
               END DO
            ELSE
               DO J = 1, I
                  T = ABS( A( I, J ) )
                  U = U + S( J )*T
                  WORK( J ) = WORK( J ) + D*T
               END DO
               DO J = I+1,N
                  T = ABS( A( J, I ) )
                  U = U + S( J )*T
                  WORK( J ) = WORK( J ) + D*T
               END DO
            END IF

            AVG = AVG + ( U + WORK( I ) ) * D / N
            S( I ) = SI
         END DO
      END DO

 999  CONTINUE

      SMLNUM = DLAMCH( 'SAFEMIN' )
      BIGNUM = ONE / SMLNUM
      SMIN = BIGNUM
      SMAX = ZERO
      T = ONE / SQRT( AVG )
      BASE = DLAMCH( 'B' )
      U = ONE / LOG( BASE )
      DO I = 1, N
         S( I ) = BASE ** INT( U * LOG( S( I ) * T ) )
         SMIN = MIN( SMIN, S( I ) )
         SMAX = MAX( SMAX, S( I ) )
      END DO
      SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
*
      END


program test_ewald3

! This test compares lattice energy calculated from the Ewald summation
! against the energy calculated using the Madelung constant for various lattice
! constants L. The agreement is essentially to machine precision.

! This test tests ewald_box().

use types, only: dp
use constants, only: ang2bohr, kJmol2Ha
use ewald_sums, only: ewald_box, fred2fcart, ewald_fft1, min_distance
use utils, only: assert, init_random
implicit none

integer :: natom, ntypat
! Various NaCl lattice constants in A
real(dp), parameter :: Llist(5) = [5.6402_dp, 5.5_dp, 4.5_dp, 6.5_dp, 10._dp]
! The component of the correct force for the given L
! The components of the correct force and stress tensor (multiplied by L)
real(dp), parameter :: fcorrect0 = 10.180280846982683_dp
real(dp), parameter :: stress0 = -4.6601722523551734_dp
real(dp), parameter :: stress1 = -6.6903565769534099_dp
real(dp), parameter :: stress2 = -5.7797035916557675_dp

real(dp) :: stress(6)
real(dp), allocatable :: xred(:, :), forces(:, :), q(:)
real(dp) :: L, alpha, E_ewald, E_ewald_fft, E_madelung
integer :: i, j

alpha = 1.74756459463318219064_dp ! Madelung constant for NaCl

! Conventional cell:
natom = 8
ntypat = 2
allocate(xred(3, natom), forces(3, natom), q(natom))
! Cl^-
xred(:, 1) = [0, 0, 0]
xred(:, 2) = [1, 1, 0] / 2._dp
xred(:, 3) = [1, 0, 1] / 2._dp
xred(:, 4) = [0, 1, 1] / 2._dp
! Na^+
xred(:, 5) = [1, 1, 1] / 2._dp
xred(:, 6) = [1, 0, 0] / 2._dp
xred(:, 7) = [0, 1, 0] / 2._dp
xred(:, 8) = [0, 0, 1] / 2._dp
q = [-1, -1, -1, -1, 1, 1, 1, 1]

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr
    call ewald_box(L, xred*L, q, E_ewald, forces, stress)
    E_ewald = E_ewald / (natom/ntypat)

    call ewald_fft1(L, xred*L, q, 64, 0.25_dp*L, E_ewald_fft)
    E_ewald_fft = E_ewald_fft / (natom/ntypat)

    E_madelung = -2*alpha/L

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung: ", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:    ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "Ewald FFT:", E_ewald_fft / kJmol2Ha, "kJ/mol"
    print *, "error:    ", abs(E_ewald - E_madelung), "a.u."
    print *, "error FFT:", abs(E_ewald_fft - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 1e-14_dp)
    call assert(abs(E_ewald_fft - E_madelung) < 1e-10_dp)
    call assert(all(abs(forces) < 1e-17_dp))
    call assert(all(abs(stress - (stress0/L)*[1, 1, 1, 0, 0, 0]) < 1e-15_dp))
end do

print *, "--------"

! Madelung constant for NaCl, where the diagonal Na atom is moved by 3/8
! towards the Cl atom
alpha = 2.5088837163575413_dp

! Cl^-
xred(:, 1) = [0, 0, 0]
xred(:, 2) = [1, 1, 0] / 2._dp
xred(:, 3) = [1, 0, 1] / 2._dp
xred(:, 4) = [0, 1, 1] / 2._dp
! Na^+
xred(:, 5) = [1, 1, 1] / 2._dp
xred(:, 6) = [1, 0, 0] / 2._dp
xred(:, 7) = [0, 1, 0] / 2._dp
xred(:, 8) = [0, 0, 1] / 2._dp
xred(:, 5:8) = xred(:, 5:8) - spread([3, 3, 3] / 8._dp, 2, 4)
xred(:, 6:8) = xred(:, 6:8) - floor(xred(:, 6:8))

print *, "half of xred min distance:", min_distance(xred, 1._dp)/2

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr
    call ewald_box(L, xred*L, q, E_ewald, forces, stress)
    E_ewald = E_ewald / (natom/ntypat)

    call ewald_fft1(L, xred*L, q, 96, 0.10825_dp*L, E_ewald_fft)
    E_ewald_fft = E_ewald_fft / (natom/ntypat)

    E_madelung = -2*alpha/L

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung: ", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:    ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "Ewald FFT:", E_ewald_fft / kJmol2Ha, "kJ/mol"
    print *, "error:    ", abs(E_ewald - E_madelung), "a.u."
    print *, "error FFT:", abs(E_ewald_fft - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 1e-14_dp)
    call assert(abs(E_ewald_fft - E_madelung) < 5e-6_dp)
    call assert(all(abs(stress - [stress1, stress1, stress1, &
        stress2, stress2, stress2]/L) < 1e-10_dp))
    do j = 1, 4
        call assert(all(abs(forces(:, j) - (+fcorrect0/L**2)) < 1e-10_dp))
    end do
    do j = 5, 8
        call assert(all(abs(forces(:, j) - (-fcorrect0/L**2)) < 1e-10_dp))
    end do
end do
end program