C
C     file hstcsp.f
C
      SUBROUTINE HSTCSP (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,
     1                   BDD,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE STANDARD FIVE-POINT FINITE
C                        DIFFERENCE APPROXIMATION ON A STAGGERED
C                        GRID TO THE MODIFIED HELMHOLTZ EQUATION IN
C                        SPHERICAL COORDINATES ASSUMING AXISYMMETRY
C                        (NO DEPENDENCE ON LONGITUDE).
C
C                        THE EQUATION IS
C
C                           (1/R**2)(D/DR)(R**2(DU/DR)) +
C                           1/(R**2*SIN(THETA))(D/DTHETA)
C                           (SIN(THETA)(DU/DTHETA)) +
C                           (LAMBDA/(R*SIN(THETA))**2)U  =  F(THETA,R)
C
C                        WHERE THETA IS COLATITUDE AND R IS THE
C                        RADIAL COORDINATE. THIS TWO-DIMENSIONAL
C                        MODIFIED HELMHOLTZ EQUATION RESULTS FROM
C                        THE FOURIER TRANSFORM OF THE THREE-
C                        DIMENSIONAL POISSON EQUATION.
C
C
C USAGE                  CALL HSTCSP (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,IDIMF,
C                                     PERTRB,IERROR,W)
C
C ARGUMENTS
C  ON INPUT              INTL
C
C                          = 0  ON INITIAL ENTRY TO HSTCSP OR IF ANY
C                               OF THE ARGUMENTS C, D, N, OR NBDCND
C                               ARE CHANGED FROM A PREVIOUS CALL
C
C                          = 1  IF C, D, N, AND NBDCND ARE ALL
C                               UNCHANGED FROM PREVIOUS CALL TO HSTCSP
C
C                          NOTE:
C                          A CALL WITH INTL = 0 TAKES APPROXIMATELY
C                          1.5 TIMES AS MUCH TIME AS A CALL WITH
C                          INTL = 1.  ONCE A CALL WITH INTL = 0
C                          HAS BEEN MADE THEN SUBSEQUENT SOLUTIONS
C                          CORRESPONDING TO DIFFERENT F, BDA, BDB,
C                          BDC, AND BDD CAN BE OBTAINED FASTER WITH
C                          INTL = 1 SINCE INITIALIZATION IS NOT
C                          REPEATED.
C
C                        A,B
C                          THE RANGE OF THETA (COLATITUDE),
C                          I.E. A .LE. THETA .LE. B.  A
C                          MUST BE LESS THAN B AND A MUST BE
C                          NON-NEGATIVE.  A AND B ARE IN RADIANS.
C                          A = 0 CORRESPONDS TO THE NORTH POLE AND
C                          B = PI CORRESPONDS TO THE SOUTH POLE.
C
C                          * * *  IMPORTANT  * * *
C
C                          IF B IS EQUAL TO PI, THEN B MUST BE
C                          COMPUTED USING THE STATEMENT
C                              B = PIMACH(DUM)
C                          THIS INSURES THAT B IN THE USER'S PROGRAM
C                          IS EQUAL TO PI IN THIS PROGRAM, PERMITTING
C                          SEVERAL TESTS OF THE INPUT PARAMETERS THAT
C                          OTHERWISE WOULD NOT BE POSSIBLE.
C
C                          * * * * * * * * * * * *
C
C                        M
C                          THE NUMBER OF GRID POINTS IN THE INTERVAL
C                          (A,B).  THE GRID POINTS IN THE THETA-
C                          DIRECTION ARE GIVEN BY
C                            THETA(I) = A + (I-0.5)DTHETA
C                          FOR I=1,2,...,M WHERE DTHETA =(B-A)/M.
C                          M MUST BE GREATER THAN 4.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT THETA = A AND THETA = B.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = A AND THETA = B.
C                               (SEE NOTES 1, 2 BELOW)
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = A AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = B
C                               (SEE NOTES 1, 2 BELOW).
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = A (SEE NOTES 1, 2 BELOW)
C                               AND THETA = B.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED AT
C                               THETA = A (SEE NOTES 1, 2 BELOW) AND
C                               THE SOLUTION IS SPECIFIED AT THETA = B.
C
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = A = 0 AND THE SOLUTION IS
C                               SPECIFIED AT THETA = B.
C                               (SEE NOTE 2 BELOW)
C
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = A = 0 AND THE DERIVATIVE OF
C                               THE SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = B
C                               (SEE NOTE 2 BELOW).
C
C                          = 7  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = A AND THE SOLUTION IS
C                               UNSPECIFIED AT THETA = B = PI.
C
C                          = 8  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED AT
C                               THETA = A (SEE NOTE 1 BELOW)
C                               AND THE SOLUTION IS UNSPECIFIED AT
C                               THETA = B = PI.
C
C                          = 9  IF THE SOLUTION IS UNSPECIFIED AT
C                                THETA = A = 0 AND THETA = B = PI.
C
C                          NOTE 1:
C                          IF A = 0, DO NOT USE MBDCND = 1,2,3,4,7
C                          OR 8, BUT INSTEAD USE MBDCND = 5, 6, OR 9.
C
C                          NOTE 2:
C                          IF B = PI, DO NOT USE MBDCND = 1,2,3,4,5,
C                          OR 6, BUT INSTEAD USE MBDCND = 7, 8, OR 9.
C
C                          NOTE 3:
C                          WHEN A = 0  AND/OR B = PI THE ONLY
C                          MEANINGFUL BOUNDARY CONDITION IS
C                          DU/DTHETA = 0.   SEE D. GREENSPAN,
C                          'NUMERICAL ANALYSIS OF ELLIPTIC
C                           BOUNDARY VALUE PROBLEMS,'
C                          HARPER AND ROW, 1965, CHAPTER 5.)
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES (IF ANY) OF
C                          THE SOLUTION AT THETA = A.
C
C                          WHEN  MBDCND = 1, 2, OR 7,
C                            BDA(J) = U(A,R(J)),   J=1,2,...,N.
C
C                          WHEN MBDCND = 3, 4, OR 8,
C                            BDA(J) = (D/DTHETA)U(A,R(J)), J=1,2,...,N.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A
C                          DUMMY VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT THETA = B.
C
C                          WHEN MBDCND = 1, 4, OR 5,
C                            BDB(J) = U(B,R(J)),     J=1,2,...,N.
C
C                          WHEN MBDCND = 2,3, OR 6,
C                            BDB(J) = (D/DTHETA)U(B,R(J)), J=1,2,...,N.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS
C                          A DUMMY VARIABLE.
C
C                        C,D
C                          THE RANGE OF R , I.E. C .LE. R .LE. D.
C                          C MUST BE LESS THAN D AND NON-NEGATIVE.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE INTERVAL
C                          (C,D).  THE UNKNOWNS IN THE R-DIRECTION
C                          ARE GIVEN BY R(J) = C + (J-0.5)DR,
C                          J=1,2,...,N, WHERE DR = (D-C)/N.
C                          N MUST BE GREATER THAN 4.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT R = C AND R = D.
C
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               R = C AND R = D.
C
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               R = C AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO R IS
C                               SPECIFIED AT R = D. (SEE NOTE 1 BELOW)
C
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = C AND R = D.
C
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS
C                               SPECIFIED AT R = C AND THE SOLUTION
C                               IS SPECIFIED AT R = D.
C
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = C = 0 (SEE NOTE 2 BELOW) AND THE
C                               SOLUTION IS SPECIFIED AT R = D.
C
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = C = 0 (SEE NOTE 2 BELOW)
C                               AND THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = D.
C
C                          NOTE 1:
C                          IF C = 0 AND MBDCND = 3,6,8 OR 9, THE
C                          SYSTEM OF EQUATIONS TO BE SOLVED IS
C                          SINGULAR.  THE UNIQUE SOLUTION IS
C                          DETERMINED BY EXTRAPOLATION TO THE
C                          SPECIFICATION OF U(THETA(1),C).
C                          BUT IN THESE CASES THE RIGHT SIDE OF THE
C                          SYSTEM WILL BE PERTURBED BY THE CONSTANT
C                          PERTRB.
C
C                          NOTE 2:
C                          NBDCND = 5 OR 6 CANNOT BE USED WITH
C                          MBDCND =1, 2, 4, 5, OR 7
C                          (THE FORMER INDICATES THAT THE SOLUTION IS
C                          UNSPECIFIED AT R = 0; THE LATTER INDICATES
C                          SOLUTION IS SPECIFIED).
C                          USE INSTEAD NBDCND = 1 OR 2.
C
C                        BDC
C                          A ONE DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT R = C.  WHEN NBDCND = 1 OR 2,
C                            BDC(I) = U(THETA(I),C),    I=1,2,...,M.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDC(I) = (D/DR)U(THETA(I),C), I=1,2,...,M.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS
C                          A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT
C                          SPECIFIES THE BOUNDARY VALUES OF THE
C                          SOLUTION AT R = D.  WHEN NBDCND = 1 OR 4,
C                            BDD(I) = U(THETA(I),D) ,    I=1,2,...,M.
C
C                          WHEN NBDCND = 2 OR 3,
C                            BDD(I) = (D/DR)U(THETA(I),D), I=1,2,...,M.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS
C                          A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE MODIFIED
C                          HELMHOLTZ EQUATION.  IF LAMBDA IS GREATER
C                          THAN 0, A SOLUTION MAY NOT EXIST.
C                          HOWEVER, HSTCSP WILL ATTEMPT TO FIND A
C                          SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT SIDE OF THE MODIFIED
C                          HELMHOLTZ EQUATION.  FOR I=1,2,...,M AND
C                          J=1,2,...,N
C
C                                F(I,J) = F(THETA(I),R(J)) .
C
C                          F MUST BE DIMENSIONED AT LEAST M X N.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HSTCSP.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.
C                          IDIMF MUST BE AT LEAST M.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          WITH K = INT(LOG2(N))+1 AND L = 2**(K+1),
C                          W MAY REQUIRE UP TO
C                          (K-2)*L+K+MAX(2N,6M)+4(N+M)+5 LOCATIONS.
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HSTCSP AND IS RETURNED IN THE
C                          LOCATION W(1).
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (THETA(I),R(J)) FOR I=1,2,..,M, J=1,2,...,N.
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC, DERIVATIVE,
C                          OR UNSPECIFIED BOUNDARY CONDITIONS IS
C                          SPECIFIED FOR A POISSON EQUATION
C                          (LAMBDA = 0), A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT, CALCULATED AND
C                          SUBTRACTED FROM F, WHICH ENSURES THAT A
C                          SOLUTION EXISTS.  HSTCSP THEN COMPUTES THIS
C                          SOLUTION, WHICH IS A LEAST SQUARES SOLUTION
C                          TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C                          A SOLUTION; HENCE, THE SOLUTION IS NOT
C                          UNIQUE.  THE VALUE OF PERTRB SHOULD BE
C                          SMALL COMPARED TO THE RIGHT SIDE F.
C                          OTHERWISE, A SOLUTION IS OBTAINED TO AN
C                          ESSENTIALLY DIFFERENT PROBLEM.
C                          THIS COMPARISON SHOULD ALWAYS BE MADE TO
C                          INSURE THAT A MEANINGFUL SOLUTION HAS BEEN
C                          OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS. EXCEPT FOR NUMBERS 0 AND 10,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR
C
C                          =  1  A .LT. 0 OR B .GT. PI
C
C                          =  2  A .GE. B
C
C                          =  3  MBDCND .LT. 1 OR MBDCND .GT. 9
C
C                          =  4  C .LT. 0
C
C                          =  5  C .GE. D
C
C                          =  6  NBDCND .LT. 1 OR NBDCND .GT. 6
C
C                          =  7  N .LT. 5
C
C                          =  8  NBDCND = 5 OR 6 AND
C                                MBDCND = 1, 2, 4, 5, OR 7
C
C                          =  9  C .GT. 0 AND NBDCND .GE. 5
C
C                          = 10  ELMBDA .GT. 0
C
C                          = 11  IDIMF .LT. M
C
C                          = 12  M .LT. 5
C
C                          = 13  A = 0 AND MBDCND =1,2,3,4,7 OR 8
C
C                          = 14  B = PI AND MBDCND .LE. 6
C
C                          = 15  A .GT. 0 AND MBDCND = 5, 6, OR 9
C
C                          = 16  B .LT. PI AND MBDCND .GE. 7
C
C                          = 17  LAMBDA .NE. 0 AND NBDCND .GE. 5
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HSTCSP,
C                          THE USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C                          ALSO  W CONTAINS INTERMEDIATE VALUES THAT
C                          MUST NOT BE DESTROYED IF HSTCSP WILL BE
C                          CALLED AGAIN WITH INTL = 1.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       BLKTRI AND COMF FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN 1977.
C                        RELEASED ON NCAR'S PUBLIC SOFTWARE LIBRARIES
C                        IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS
C                        THE RIGHT SIDE WHEN THE SYSTEM IS SINGULAR
C                        AND CALLS BLKTRI WHICH SOLVES THE LINEAR
C                        SYSTEM OF EQUATIONS.
C
C
C TIMING                 FOR LARGE M AND N, THE OPERATION COUNT IS
C                        ROUGHLY PROPORTIONAL TO M*N*LOG2(N).  THE
C                        TIMING ALSO DEPENDS ON INPUT PARAMETER INTL.
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN
C                        A LOSS OF NO MORE THAN FOUR SIGNIFICANT
C                        DIGITS FOR N AND M AS LARGE AS 64.
C                        MORE DETAILED INFORMATION ABOUT ACCURACY
C                        CAN BE FOUND IN THE DOCUMENTATION FOR
C                        SUBROUTINE BLKTRI WHICH IS THE ROUTINE
C                        SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C REFERENCES             P.N. SWARZTRAUBER, "A DIRECT METHOD FOR
C                        THE DISCRETE SOLUTION OF SEPARABLE ELLIPTIC
C                        EQUATIONS",
C                        SIAM J. NUMER. ANAL. 11(1974), PP. 1136-1150.
C
C                        U. SCHUMANN AND R. SWEET, "A DIRECT METHOD FOR
C                        THE SOLUTION OF POISSON'S EQUATION WITH NEUMANN
C                        BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                        ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                        PP. 171-182.
C***********************************************************************
      DIMENSION       F(IDIMF,1) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C
      PI = PIMACH(DUM)
C
C     CHECK FOR INVALID INPUT PARAMETERS
C
      IERROR = 0
      IF (A.LT.0. .OR. B.GT.PI) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3
      IF (C .LT. 0.) IERROR = 4
      IF (C .GE. D) IERROR = 5
      IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 6
      IF (N .LT. 5) IERROR = 7
      IF ((NBDCND.EQ.5 .OR. NBDCND.EQ.6) .AND. (MBDCND.EQ.1 .OR.
     1    MBDCND.EQ.2 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.5 .OR.
     2                                                     MBDCND.EQ.7))
     3    IERROR = 8
      IF (C.GT.0. .AND. NBDCND.GE.5) IERROR = 9
      IF (IDIMF .LT. M) IERROR = 11
      IF (M .LT. 5) IERROR = 12
      IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6 .AND. MBDCND.NE.9)
     1    IERROR = 13
      IF (B.EQ.PI .AND. MBDCND.LE.6) IERROR = 14
      IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9))
     1    IERROR = 15
      IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 16
      IF (ELMBDA.NE.0. .AND. NBDCND.GE.5) IERROR = 17
      IF (IERROR .NE. 0) GO TO 101
      IWBM = M+1
      IWCM = IWBM+M
      IWAN = IWCM+M
      IWBN = IWAN+N
      IWCN = IWBN+N
      IWSNTH = IWCN+N
      IWRSQ = IWSNTH+M
      IWWRK = IWRSQ+N
      IERR1 = 0
      CALL HSTCS1 (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1             ELMBDA,F,IDIMF,PERTRB,IERR1,W,W(IWBM),W(IWCM),
     2             W(IWAN),W(IWBN),W(IWCN),W(IWSNTH),W(IWRSQ),W(IWWRK))
      W(1) = W(IWWRK)+FLOAT(IWWRK-1)
      IERROR = IERR1
  101 CONTINUE
      RETURN
      END
      SUBROUTINE HSTCS1 (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,
     1                   BDD,ELMBDA,F,IDIMF,PERTRB,IERR1,AM,BM,CM,AN,
     2                   BN,CN,SNTH,RSQ,WRK)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                F(IDIMF,1) ,AM(*)      ,BM(*)      ,CM(*)      ,
     2                AN(*)      ,BN(*)      ,CN(*)      ,SNTH(*)    ,
     3                RSQ(*)     ,WRK(*)
      DTH = (B-A)/FLOAT(M)
      DTHSQ = DTH*DTH
      DO 101 I=1,M
         SNTH(I) = SIN(A+(FLOAT(I)-0.5)*DTH)
  101 CONTINUE
      DR = (D-C)/FLOAT(N)
      DO 102 J=1,N
         RSQ(J) = (C+(FLOAT(J)-0.5)*DR)**2
  102 CONTINUE
C
C     MULTIPLY RIGHT SIDE BY R(J)**2
C
      DO 104 J=1,N
         X = RSQ(J)
         DO 103 I=1,M
            F(I,J) = X*F(I,J)
  103    CONTINUE
  104 CONTINUE
C
C      DEFINE COEFFICIENTS AM,BM,CM
C
      X = 1./(2.*COS(DTH/2.))
      DO 105 I=2,M
         AM(I) = (SNTH(I-1)+SNTH(I))*X
         CM(I-1) = AM(I)
  105 CONTINUE
      AM(1) = SIN(A)
      CM(M) = SIN(B)
      DO 106 I=1,M
         X = 1./SNTH(I)
         Y = X/DTHSQ
         AM(I) = AM(I)*Y
         CM(I) = CM(I)*Y
         BM(I) = ELMBDA*X*X-AM(I)-CM(I)
  106 CONTINUE
C
C     DEFINE COEFFICIENTS AN,BN,CN
C
      X = C/DR
      DO 107 J=1,N
         AN(J) = (X+FLOAT(J-1))**2
         CN(J) = (X+FLOAT(J))**2
         BN(J) = -(AN(J)+CN(J))
  107 CONTINUE
      ISW = 1
      NB = NBDCND
      IF (C.EQ.0. .AND. NB.EQ.2) NB = 6
C
C     ENTER DATA ON THETA BOUNDARIES
C
      GO TO (108,108,110,110,112,112,108,110,112),MBDCND
  108 BM(1) = BM(1)-AM(1)
      X = 2.*AM(1)
      DO 109 J=1,N
         F(1,J) = F(1,J)-X*BDA(J)
  109 CONTINUE
      GO TO 112
  110 BM(1) = BM(1)+AM(1)
      X = DTH*AM(1)
      DO 111 J=1,N
         F(1,J) = F(1,J)+X*BDA(J)
  111 CONTINUE
  112 CONTINUE
      GO TO (113,115,115,113,113,115,117,117,117),MBDCND
  113 BM(M) = BM(M)-CM(M)
      X = 2.*CM(M)
      DO 114 J=1,N
         F(M,J) = F(M,J)-X*BDB(J)
  114 CONTINUE
      GO TO 117
  115 BM(M) = BM(M)+CM(M)
      X = DTH*CM(M)
      DO 116 J=1,N
         F(M,J) = F(M,J)-X*BDB(J)
  116 CONTINUE
  117 CONTINUE
C
C     ENTER DATA ON R BOUNDARIES
C
      GO TO (118,118,120,120,122,122),NB
  118 BN(1) = BN(1)-AN(1)
      X = 2.*AN(1)
      DO 119 I=1,M
         F(I,1) = F(I,1)-X*BDC(I)
  119 CONTINUE
      GO TO 122
  120 BN(1) = BN(1)+AN(1)
      X = DR*AN(1)
      DO 121 I=1,M
         F(I,1) = F(I,1)+X*BDC(I)
  121 CONTINUE
  122 CONTINUE
      GO TO (123,125,125,123,123,125),NB
  123 BN(N) = BN(N)-CN(N)
      X = 2.*CN(N)
      DO 124 I=1,M
         F(I,N) = F(I,N)-X*BDD(I)
  124 CONTINUE
      GO TO 127
  125 BN(N) = BN(N)+CN(N)
      X = DR*CN(N)
      DO 126 I=1,M
         F(I,N) = F(I,N)-X*BDD(I)
  126 CONTINUE
  127 CONTINUE
C
C     CHECK FOR SINGULAR PROBLEM.  IF SINGULAR, PERTURB F.
C
      PERTRB = 0.
      GO TO (137,137,128,137,137,128,137,128,128),MBDCND
  128 GO TO (137,137,129,137,137,129),NB
  129 IF (ELMBDA) 137,131,130
  130 IERR1 = 10
      GO TO 137
  131 CONTINUE
      ISW = 2
      DO 133 I=1,M
         X = 0.
         DO 132 J=1,N
            X = X+F(I,J)
  132    CONTINUE
         PERTRB = PERTRB+X*SNTH(I)
  133 CONTINUE
      X = 0.
      DO 134 J=1,N
         X = X+RSQ(J)
  134 CONTINUE
      PERTRB = 2.*(PERTRB*SIN(DTH/2.))/(X*(COS(A)-COS(B)))
      DO 136 J=1,N
         X = RSQ(J)*PERTRB
         DO 135 I=1,M
            F(I,J) = F(I,J)-X
  135    CONTINUE
  136 CONTINUE
  137 CONTINUE
      A2 = 0.
      DO 138 I=1,M
         A2 = A2+F(I,1)
  138 CONTINUE
      A2 = A2/RSQ(1)
C
C     INITIALIZE BLKTRI
C
      IF (INTL .NE. 0) GO TO 139
      CALL BLKTRI (0,1,N,AN,BN,CN,1,M,AM,BM,CM,IDIMF,F,IERR1,WRK)
  139 CONTINUE
C
C     CALL BLKTRI TO SOLVE SYSTEM OF EQUATIONS.
C
      CALL BLKTRI (1,1,N,AN,BN,CN,1,M,AM,BM,CM,IDIMF,F,IERR1,WRK)
      IF (ISW.NE.2 .OR. C.NE.0. .OR. NBDCND.NE.2) GO TO 143
      A1 = 0.
      A3 = 0.
      DO 140 I=1,M
         A1 = A1+SNTH(I)*F(I,1)
         A3 = A3+SNTH(I)
  140 CONTINUE
      A1 = A1+RSQ(1)*A2/2.
      IF (MBDCND .EQ. 3)
     1    A1 = A1+(SIN(B)*BDB(1)-SIN(A)*BDA(1))/(2.*(B-A))
      A1 = A1/A3
      A1 = BDC(1)-A1
      DO 142 I=1,M
         DO 141 J=1,N
            F(I,J) = F(I,J)+A1
  141    CONTINUE
  142 CONTINUE
  143 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


      SUBROUTINE uice(ug, vg, ui, vi, nlong, nlat)
C     Compute the motion of the non-interacting floes.
C     Bob Grumbine 17 September 1993.
C     U10 wind rule implemented 15 March 2007

      IMPLICIT none
CD      INCLUDE "sicedrft.inc"

C     Declare the arguments
      INTEGER nlat, nlong
      REAL ug(nlong, nlat), vg(nlong, nlat)
      REAL ui(nlong, nlat), vi(nlong, nlat)

C     Declare local utility variables
      INTEGER i, j

C     Declare the flow model.
      REAL pi, betar
      REAL alpha1, beta1
      REAL alpha2, beta2
C These are the geostrophic wind values, superceded 15 March 2007
COLD      PARAMETER (alpha1 = 0.008)
COLD      PARAMETER (beta1  = 8.0)
COLD      PARAMETER (alpha2 = 0.0303)
COLD      PARAMETER (beta2  = -23.4)
      PARAMETER (alpha1 = 0.01468)
      PARAMETER (beta1  = 28.0)
      PARAMETER (alpha2 = 0.01468)
      PARAMETER (beta2  = -28.0)

      PARAMETER (pi    = 3.141592654)

C     Operational Code.
C     Compute the gridded ice drift velocity field. Note j convention is
C       reversed from MRF standard, and runs south to north.
C     Northern Hemisphere
      betar = pi*beta1/180.
      DO 2000 j = nlat/2+1, nlat
        DO 2010 i = 1, nlong
          ui(i,j) = alpha1*(COS(betar)*ug(i,j)+SIN(betar)*vg(i,j))
          vi(i,j) = alpha1*(-SIN(betar)*ug(i,j)+COS(betar)*vg(i,j))
 2010   CONTINUE
 2000 CONTINUE
C     Southern Hemisphere
      betar = pi*beta2/180.
      DO 2100 j = 2, nlat/2
        DO 2110 i = 1, nlong
          ui(i,j) = alpha2*(COS(betar)*ug(i,j)+SIN(betar)*vg(i,j))
          vi(i,j) = alpha2*(-SIN(betar)*ug(i,j)+COS(betar)*vg(i,j))
 2110   CONTINUE
 2100 CONTINUE

      PRINT *,'debug max, min u, v ',MAXVAL(ui), MINVAL(ui),
     1               MAXVAL(vi), MINVAL(vi)

      RETURN
      END


C Copyright 2021 Dennis Decker Jensen
C Date: 9 May 2021
C Purpose: Find prime permutations
C Tectonics: gfortran --std=f95 -ffixed-form -o euler049 euler049.f primetest.f

      PROGRAM EULER049
         DIMENSION IDIGITS(9)
         EXTERNAL PRIME,PERM
         LOGICAL PRIME,PERM
         NDIG(N,M)=MOD(INT(N/10**(M-1)),10)

         DO 20 I=1000,3339
            J=I+3330
            K=J+3330
C            PRINT *,I,PRIME(I),J,PRIME(J),K,PRIME(K)
            IF (K.LE.9999 .AND. PRIME(I).AND.PRIME(J).AND.PRIME(K)) THEN
               DO 10 L=1,9
  10              IDIGITS(L)=0
               DO 15 L=1,4
                  IDIGITS(NDIG(I,L))=IDIGITS(NDIG(I,L))+1
                  IDIGITS(NDIG(J,L))=IDIGITS(NDIG(J,L))+1
  15              IDIGITS(NDIG(K,L))=IDIGITS(NDIG(K,L))+1
C               PRINT *,I,J,K,IDIGITS
               DO 16 L=1,9
                  IF (MOD(IDIGITS(L),3).NE.0) GOTO 20
  16           CONTINUE
               PRINT '(3I0,'': '',3(I0,1X))',I,J,K,I,J,K
            ENDIF
  20     CONTINUE
      END


subroutine nbody_system_properties
! Calculates the various properties of the system
! Includes energy, angular momentum and orbits

use embryodata

implicit none

call angular_momentum
call energy

totalmass = sum(mass)
call calc_orbit_from_vector(totalmass)

end subroutine nbody_system_properties

subroutine angular_momentum
! Calculate the angular momentum of all the bodies

use embryodata

implicit none

integer :: ix

! Compute angular momentum = r x v

angmom(1,:) = pos(2,:)*vel(3,:) - pos(3,:)*vel(2,:)
angmom(2,:) = pos(3,:)*vel(1,:) - pos(1,:)*vel(3,:)
angmom(3,:) = pos(1,:)*vel(2,:) - pos(2,:)*vel(1,:)
angmag(:) = sqrt(angmom(1,:)*angmom(1,:) + angmom(2,:)*angmom(2,:) + angmom(3,:)*angmom(3,:))

do ix=1,3
system_angmom(ix) = sum(angmom(ix,:))
enddo

system_ang =sqrt(system_angmom(1)*system_angmom(1) + system_angmom(2)*system_angmom(2)+system_angmom(3)*system_angmom(3))

if(initial_system_ang>1.0e-30)then
dL = (system_ang-initial_system_ang)/initial_system_ang
else
dL=0.0
endif

end subroutine angular_momentum

subroutine energy
! Calculate the orbital parameters of all the bodies
! Also compute energy and angular momentum for error tracking

use embryodata

implicit none

integer :: ix, ibody,jbody
real :: relpos
real,dimension(nbodies) :: vmag
real,dimension(3) :: sep

! Compute kinetic energy of the bodies

vmag(:) = sqrt(vel(1,:)*vel(1,:) + vel(2,:)*vel(2,:) + vel(3,:)*vel(3,:))
ekin(:) = 0.5*vmag(:)*vmag(:)

! Compute potential energy

do ibody=1,nbodies

epot(ibody)=0.0

do jbody=1,nbodies

if(ibody==jbody) cycle

do ix=1,3
sep(ix) = pos(ix,ibody) - pos(ix,jbody)
enddo

relpos = sqrt(sep(1)*sep(1) + sep(2)*sep(2)+sep(3)*sep(3) +rsoft*rsoft)

do ix=1,3
epot(ibody) = epot(ibody) - mass(jbody)/(relpos)
enddo
enddo

enddo

etot(:) = ekin(:) + epot(:)

system_energy = sum(etot)

if(initial_system_energy >1.0e-30) then
dE = (system_energy-initial_system_energy)/initial_system_energy
else
dE = 0.0
endif

end subroutine energy


      program main
      double precision x1,y1,z1, x2,y2,z2,length
      write(6,*) 'input 1st point:'
      read(5,*) x1,y1,z1
      write(6,*) 'input 2nd point:'
      read(5,*) x2,y2,z2

      length=sqrt((x2-x1)**2+(y2-y1)**2+(z2-z1)**2)

      write(6,*) 'length between Point 1 and 2 = ',length
      stop
      end


integer :: i
integer, dimension (10) :: a = (/(i * i, i = 1, 10)/)


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

module Math_
	use ieee_arithmetic   ! http://fortranwiki.org/fortran/show/ieee_arithmetic
	implicit none
	private

	real(8), public, parameter :: Math_PI = acos(-1.0_8)
	real(8), public, parameter :: Math_INF = 1.0_8/0.0_8
! 	real(8), public, parameter :: Math_INF = 99999999999999999.0_8
	real(8), public, parameter :: Math_NAN = 0.0_8/0.0_8
	complex(8), public, parameter :: Math_I = cmplx(0.0_8,1.0_8)

	integer, public, parameter :: Math_IINF = huge(0)

	public :: &
		Math_wigner3j, &
		Math_cart2Spher, &
		Math_spher2Cart, &
		Math_sort, &
		Math_fact, &
		Math_comb, &
		Math_combinationsNumber, &
		Math_combinations, &
		Math_multisetNumber, &
		Math_multisets, &
		Math_isOdd, &
		Math_isEven, &
		Math_fixPrecision, &
		Math_erfinv, &
		Math_ustep, &
		Math_ubox, &
		Math_sinc, &
		Math_nsinc, &
		Math_gaussian, &
		Math_lorentzian, &
		Math_erfTophat, &
		Math_flatTopWindow, &
		Math_average, &
		Math_stdev, &
		Math_skewness, &
		Math_floorDivision, &
		Math_isNaN, &
		Math_isInf, &
		Math_isIInf, &
		Math_dotProduct, &
		Math_crossProduct, &
		Math_pointLineDistance, &
		Math_test

	interface Math_sort
		module procedure Math_isort
		module procedure Math_rsort
	end interface Math_sort

	interface Math_floorDivision
		module procedure Math_iFloorDivision
		module procedure Math_rFloorDivision
	end interface Math_floorDivision

	interface
		function prototypeMultisetConstraint( multisetPositions, current ) result( output )
			integer, allocatable, intent(in) :: multisetPositions(:)
			integer, intent(in) :: current
			logical :: output
		end function prototypeMultisetConstraint
	end interface

	integer, allocatable :: kCombChosen(:)
	integer(8) :: kCombIterator = -1

	integer, allocatable :: kMultiCombChosen(:)
	integer(8) :: kMultiCombIterator = -1

	integer, allocatable :: ids(:)
	procedure(prototypeMultisetConstraint), pointer, private :: MSConstraint !<- This is neccesary only for Math_multisets
	logical :: isMultisetLocated = .false.

	integer, allocatable :: MyiArray(:) !<- This is only neccesary for test method

	real(8), private :: erfinv_a3 = -0.140543331_8
	real(8), private :: erfinv_a2 = 0.914624893_8
	real(8), private :: erfinv_a1 = -1.645349621_8
	real(8), private :: erfinv_a0 = 0.886226899_8

	real(8), private :: erfinv_b4 = 0.012229801_8
	real(8), private :: erfinv_b3 = -0.329097515_8
	real(8), private :: erfinv_b2 = 1.442710462_8
	real(8), private :: erfinv_b1 = -2.118377725_8
	real(8), private :: erfinv_b0 = 1.0_8

	real(8), private :: erfinv_c3 = 1.641345311_8
	real(8), private :: erfinv_c2 = 3.429567803_8
	real(8), private :: erfinv_c1 = -1.62490649_8
	real(8), private :: erfinv_c0 = -1.970840454_8

	real(8), private :: erfinv_d2 = 1.637067800_8
	real(8), private :: erfinv_d1 = 3.543889200_8
	real(8), private :: erfinv_d0 = 1.0_8

	contains

	!>
	!! This function calculates the value of a Wigner-3j symbol.
	!! The equation used is equation 1.5 in "The 3j and 6j symbols" by
	!! Manuel Rotenber, R. Bivins, N.Metropolis  and John K. Wooten, JR
	!! 1959, The Technology Press, Massachusett.
	!!
	!! The function has been tested for all sets, where j1d=j2d=5/2
	!! and j3d={0, 2, 4}, and m1d+m2d+m3d=0
	!! It has been tested to give zero for some vanishing terms
	!! If you should want to use it for higher js than the ones I have tested
	!! you might have to do something to avoid overflow in the expression with
	!! the many factorials
	!!
	function Math_wigner3j( j1, j2, j3, m1, m2, m3 ) result (w3j)
		real(8), intent(in) :: j1,j2,j3,m1,m2,m3
		real(8) :: w3j

		integer:: i
		real(8) :: j1d,j2d,j3d,m1d,m2d,m3d
		real(8) :: k,kmin,kmax,ksum,divisor,sign
		real(8), dimension(0:200) ::lnfac

		j1d = real(j1,8)
		j2d = real(j2,8)
		j3d = real(j3,8)
		m1d = real(m1,8)
		m2d = real(m2,8)
		m3d = real(m3,8)

		lnfac(0)=0.d0
		lnfac(1)=0.d0
		do i=2,200
			lnfac(i)=lnfac(i-1)+log(REAL(i))
		end do

		kmax = min(j1d+j2d-j3d, j1d-m1d,j2d+m2d)
		kmin = max(0.d0, j2d-j3d-m1d, j1d-j3d+m2d)

		ksum=0.
		do k = kmin, kmax
			divisor=exp(lnfac(nint(k))+lnfac(nint(j1d+j2d-j3d-k))+ &
				lnfac(nint(j1d-m1d-k))+lnfac(nint(j2d+m2d-k))+ &
				lnfac(nint(j3d-j2d+m1d+k))+lnfac(nint(j3d-j1d-m2d+k)))
			ksum=ksum+minusonetothe(int(k))/divisor
		end do !k

		w3j= minusonetothe(nint(j1d-j2d-m3d))*sqrt(  &
				exp(lnfac(nint(j1d+j2d-j3d))+lnfac(nint(j1d-j2d+j3d))+&
				lnfac(nint(-j1d+j2d+j3d))+&
				lnfac(nint(j1d+m1d))+lnfac(nint(j1d-m1d))+&
				lnfac(nint(j2d+m2d))+lnfac(nint(j2d-m2d))+&
				lnfac(nint(j3d+m3d))+lnfac(nint(j3d-m3d))-&
				lnfac(nint(j1d+j2d+j3d+1))))*ksum
	end function Math_wigner3j

	!>
	!! @brief Converts cartesian coordinates to spherical coordinates
	!! @param   vec = [ x, y, z ]
	!! @return rvec = [ r, theta, phi ]
	!!
	function Math_cart2Spher( vec ) result( rvec )
		real(8), intent(in) :: vec(3)
		real(8) :: rvec(3)

		real(8) :: r

		r = sqrt(sum(vec**2))
		rvec = [ r, acos(vec(3)/r), atan2(vec(2),vec(1)) ]
	end function Math_cart2Spher

	!>
	!! @brief Converts spherical coordinates to cartesian coordinates
	!! @param rvec = [ r, theta, phi ]
	!! @return vec = [ x, y, z ]
	!!
	function Math_spher2Cart( rvec ) result( vec )
		real(8), intent(in) :: rvec(3)
		real(8) :: vec(3)

		vec = [ rvec(1)*sin(rvec(2))*cos(rvec(3)), rvec(1)*sin(rvec(2))*sin(rvec(3)), rvec(1)*cos(rvec(2)) ]
	end function Math_spher2Cart

	!>
	!! @brief
	!!
	function minusonetothe(j) result (sgn)
		integer :: i,j
		real*8 :: sgn

		i=j
		if (j<=0) i=-j
		if (mod(i,2)==0) then
			sgn=1
		else
			sgn=-1
		endif
	end function minusonetothe

	!>
	!! indexing array so that array(indexes(j)), j=1..n is in
	!! ascending numerical order.
	!! method is heapsort, see also subroutine hpsort.
	!! taken from numerical recipies, p 233.
	!!
	subroutine Math_isort( array, indexes )
		integer, allocatable, intent(in) :: array(:)
		integer, allocatable, intent(inout) :: indexes(:)

		integer :: i, j, l
		integer :: n
		integer :: id, ir
		real(8) :: value

		if( .not. allocated(array) ) then
			write(*,*) "Error in Math_sort, array not allocated"
			stop
		end if

		if( .not. allocated(indexes) ) then
			write(*,*) "Error in Math_sort, indexes not allocated"
			stop
		end if

		if( size(array) /= size(indexes) ) then
			write(*,*) "Error in Math_sort, array and indexes have different size"
			stop
		end if

		n = size(array)

		do j=1,n
			indexes(j)=j
		end do

		if( n == 1 ) return

		l=n/2+1
		ir=n

		do while( .true. )
			if( l > 1 ) then
				l = l-1
				id = indexes(l)
				value = array(id)
			else
				id=indexes(ir)
				value=array(id)
				indexes(ir)=indexes(1)
				ir=ir-1

				if(ir == 1) then
					indexes(1)=id
					return
				end if
			end if

			i = l
			j = 2*l

			do while( j <= ir )
				if( j < ir ) then
					if( array(indexes(j)) < array(indexes(j+1)) ) then
						j=j+1
					end if
				end if

				if( value < array(indexes(j)) ) then
					indexes(i)=indexes(j)
					i=j
					j=2*j
				else
					j=ir+1
				end if
			end do

			indexes(i)=id
		end do
	end subroutine Math_isort

	!>
	!! indexing array so that array(indexes(j)), j=1..n is in
	!! ascending numerical order.
	!! method is heapsort, see also subroutine hpsort.
	!! taken from numerical recipies, p 233.
	!!
	subroutine Math_rsort( array, indexes )
		real(8), allocatable, intent(in) :: array(:)
		integer, allocatable, intent(inout) :: indexes(:)

		integer :: i, j, l
		integer :: n
		integer :: id, ir
		real(8) :: value

		if( .not. allocated(array) ) then
			write(*,*) "Error in Math_sort, array not allocated"
			stop
		end if

		if( .not. allocated(indexes) ) then
			write(*,*) "Error in Math_sort, indexes not allocated"
			stop
		end if

		if( size(array) /= size(indexes) ) then
			write(*,*) "Error in Math_sort, array and indexes have different size"
			stop
		end if

		n = size(array)

		do j=1,n
			indexes(j)=j
		end do

		if( n == 1 ) return

		l=n/2+1
		ir=n

		do while( .true. )
			if( l > 1 ) then
				l = l-1
				id = indexes(l)
				value = array(id)
			else
				id=indexes(ir)
				value=array(id)
				indexes(ir)=indexes(1)
				ir=ir-1

				if(ir == 1) then
					indexes(1)=id
					return
				end if
			end if

			i = l
			j = 2*l

			do while( j <= ir )
				if( j < ir ) then
					if( array(indexes(j)) < array(indexes(j+1)) ) then
						j=j+1
					end if
				end if

				if( value < array(indexes(j)) ) then
					indexes(i)=indexes(j)
					i=j
					j=2*j
				else
					j=ir+1
				end if
			end do

			indexes(i)=id
		end do
	end subroutine Math_rsort

	!>
	!! @brief Returns the factorial of n
	!!
	pure function Math_fact( n ) result( output )
		integer, intent(in) :: n
		integer :: output

		integer :: i

		output = 1
		do i=n,1,-1
			output = output*i
		end do
	end function Math_fact

	!>
	!!
	!! taken from http://orion.math.iastate.edu/burkardt/f_src/combo/combo.html
	!! COMB computes the combinatorial coefficient C(N,K).
	!!
	!!    Real arithmetic is used, and C(N,K) is computed directly, via
	!!    Gamma functions, rather than recursively.
	!!
	!!    C(N,K) is the number of distinct combinations of K objects
	!!    chosen from a set of N distinct objects.  A combination is
	!!    like a set, in that order does not matter.
	!!
	!!  Examples:
	!!    The number of combinations of 2 things chosen from 5 is 10.
	!!
	!!    C(5,2) = ( 5 * 4 * 3 * 2 * 1 ) / ( ( 3 * 2 * 1 ) * ( 2 * 1 ) ) = 10.
	!!
	!!    The actual combinations may be represented as:
	!!
	!!      (1,2), (1,3), (1,4), (1,5), (2,3),
	!!      (2,4), (2,5), (3,4), (3,5), (4,5).
	!!
	!!  Formula:
	!!    C(N,K) = N! / ( (N-K)! * K! )
	!!
	!!  Modified:
	!!    16 June 1999
	!!
	!!  Author:
	!!    John Burkardt
	!!
	!!  @param[in]      n integer N, the value of N.
	!!  @param[in]      m integer K, the value of K.
	!!  @output    output real CNK, the value of C(N,K)
	!!
	pure function Math_comb( n, k ) result( output )
		integer, intent(in) :: n, k
		integer(8) :: output

		real(8) :: arg
		real(8) :: cnk
		real(8) :: fack
		real(8) :: facn
		real(8) :: facnmk

		if ( n < 0 ) then
			cnk = 0.0E+00
		else if ( k == 0 ) then
			cnk = 1.0E+00
		else if ( k == 1 ) then
			cnk = real( n )
		else if ( k > 1 .and. k < n-1 ) then
			arg = real( n + 1 )
			facn = log(gamma( arg ))

			arg = real( k + 1 )
			fack = log(gamma( arg ))

			arg = real( n - k + 1 )
			facnmk = log(gamma( arg ))

			cnk = anint( exp ( facn - fack - facnmk ) )
		else if ( k == n-1 ) then
			cnk = real( n )
		else if ( k == n ) then
			cnk = 1.0E+00
		else
			cnk = 0.0E+00
		end if

		output = int(cnk,8)
	end function Math_comb

	!>
	!! @brief Number of combinations with repetitions (same that Math_comb)
	!!
	function Math_combinationsNumber( nElems, sGroups ) result ( output )
		integer, intent(in) :: nElems
		integer, intent(in) :: sGroups
		integer(8) :: output

		output = Math_comb( nElems, sGroups )
	end function Math_combinationsNumber

	!>
	!! @brief Builds the combinations without repetitions
	!!
	!! @param[in] nElems Number of elements
	!! @param[in] sGroups size of the groups
	!! @param[out] items final groups
	!!
	!! example: if S={1,2,3,4,5} then the combination of these elements in groups of three elements are
	!!     1)   1 2 3
	!!     2)   1 2 4
	!!     3)   1 2 5
	!!     4)   1 3 4
	!!     5)   1 3 5
	!!     6)   1 4 5
	!!     7)   2 3 4
	!!     8)   2 3 5
	!!     9)   2 4 5
	!!    10)   3 4 5
	subroutine Math_combinations( nElems, sGroups, items )
		integer, intent(in) :: nElems
		integer, intent(in) :: sGroups
		integer, allocatable, intent(inout) :: items(:,:)

		if( allocated(items) ) deallocate( items )
		allocate( items( Math_comb(nElems,sGroups), sGroups ) )

		allocate( kCombChosen(sGroups) )

		kCombIterator=1
		call combinationsBase( nElems, sGroups, items, 1 )
		kCombIterator=-1

		deallocate( kCombChosen )
	end subroutine Math_combinations

	!>
	!! @brief Internal function
	!!
	recursive subroutine combinationsBase( nElems, sGroups, items, m )
		integer, intent (in) :: nElems, sGroups
		integer, allocatable, intent(inout) :: items(:,:)
		integer, intent (in) :: m
		integer :: n

		if( m > sGroups ) then
			items(kCombIterator,:) = kCombChosen
			kCombIterator = kCombIterator+1
		else
			do n=1, nElems
				if( (m == 1) .or. (n > kCombChosen(m - 1)) ) then
					kCombChosen( m ) = n
					call combinationsBase( nElems, sGroups, items, m + 1 )
				end if
			end do
		end if
	end subroutine combinationsBase

	!>
	!! @brief Number of combinations with repetitions
	!!
	!! The number of ways to sample sGroups elements from a set of nElems elements allowing for duplicates
	!!
	function Math_multisetNumber( nElems, sGroups ) result ( output )
		integer, intent(in) :: nElems
		integer, intent(in) :: sGroups
		integer(8) :: output

		output = Math_comb( nElems+sGroups-1, sGroups )
	end function Math_multisetNumber

	!>
	!! @brief Builds the combinations with repetitions
	!!
	!! A sGroups-combination with repetitions, or sGroups-multicombination, or multiset of size sGroups
	!! from a set S is given by a sequence of sGroups not necessarily distinct elements of S,
	!! where order is not taken into account.
	!!
	!! @param[in] nElems Number of elements
	!! @param[in] sGroups size of the groups
	!! @param[out] items final groups
	!!
	!! example: if S={a,b,c} then the combination of these elements in groups of two elements are
	!!     1)   aa
	!!     2)   ab
	!!     3)   ac
	!!     4)   bb
	!!     5)   bc
	!!     6)   cc
	recursive subroutine Math_multisets( nElems, sGroups, items, constrainFunction )
		integer, intent(in) :: nElems
		integer, intent(in) :: sGroups
		integer, allocatable, intent(inout) :: items(:,:)
		procedure(prototypeMultisetConstraint), optional :: constrainFunction

		integer, allocatable :: itemsBase(:,:)
		integer :: i

		if( allocated(kMultiCombChosen) ) deallocate( kMultiCombChosen )

		kMultiCombIterator = 1

		allocate( kMultiCombChosen(sGroups) )
		kMultiCombChosen = 0

		if( allocated(itemsBase) ) deallocate( itemsBase )
		allocate( itemsBase( Math_multisetNumber( nElems, sGroups ), sGroups ) )
		itemsBase = 0
		MSConstraint => constrainFunction

		call multisetsBase( nElems, sGroups, itemsBase )

		if( kMultiCombIterator-1 < 1 ) then
			write(6,"(A)") "### ERROR ### Math_multisets: There is not multisets with chosen constraint"
			write(6,"(A)") "                              Don't forget that the constraint don't must be dependent of order of elements"
			stop
		end if

		if( allocated(items) ) deallocate(items)
		allocate( items(kMultiCombIterator-1,sGroups) )

		do i=1,size(items,dim=1)
			items(i,:) = itemsBase(i,:)
		end do

		deallocate(itemsBase)
		MSConstraint => null()
		kMultiCombIterator = -1
		deallocate( kMultiCombChosen )
	end subroutine Math_multisets

	!>
	!! @brief Internal function
	!!
	recursive subroutine multisetsBase( nElems, sGroups, items, nChosen, at )
		integer, intent(in) :: nElems
		integer, intent(in) :: sGroups
		integer, allocatable, intent(inout) :: items(:,:)
		integer, optional, intent(in) :: nChosen
		integer, optional, intent(in) :: at

		integer :: effNChosen
		integer :: effAt

		logical :: isMultisetOK, isBadWay
		integer :: i
		integer :: counter

		effNChosen = 1
		if( present(nChosen) ) effNChosen = nChosen

		effAt = 1
		if( present(at) ) effAt = at

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		! When this point is reached, the current combination
		! is the kMultiCombChosen vector
		if ( effNChosen == sGroups+1 ) then
			if( associated(MSConstraint) ) then
				isMultisetOK = MSConstraint( kMultiCombChosen, effNChosen-1 )
			else
				isMultisetOK = .true.
			end if

			if( isMultisetOK ) then
				items( kMultiCombIterator, : ) = kMultiCombChosen(:)
				kMultiCombIterator = kMultiCombIterator + 1
			end if

			return
		else if( effNChosen > 1 ) then
			if( associated(MSConstraint) ) then
				isBadWay = MSConstraint( kMultiCombChosen, effNChosen-1 )
			else
				isBadWay = .false.
			end if

			if( isBadWay ) return
		end if

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		! Build all possibilities for each element in the item array
		do i=effAt,nElems
			kMultiCombChosen(effNChosen) = i

			call multisetsBase( nElems, sGroups, items, effNChosen+1, i )
		end do

		return
	end subroutine multisetsBase

	!>
	!! @brief
	!!
	function Math_isOdd( n ) result( output )
		integer, intent(in) :: n
		logical :: output

		output = ( mod(n,2)>0 )
	end function Math_isOdd

	!>
	!! @brief
	!!
	function Math_isEven( n ) result( output )
		integer, intent(in) :: n
		logical :: output

		output = ( mod(n,2) == 0 )
	end function Math_isEven

	!>
	!! @brief
	!!
	function Math_fixPrecision( x, prec ) result( output )
		real(8), intent(in) :: x
		integer, intent(in) :: prec
		real(8) :: output

		output = real(ceiling(x*10**prec),8)/10**prec
	end function Math_fixPrecision

	!>
	!! @brief
	!! @todo La sección comentada puede hacer falta
	!! Tomada de https://www.google.es/search?q=error+%237768%3A+This+operation+on+this+data+type+is+currently+inaccurate.&oq=error+%237768%3A+This+operation+on+this+data+type+is+currently+inaccurate.&aqs=chrome..69i57.363j0j4&client=ubuntu-browser&sourceid=chrome&es_sm=91&ie=UTF-8
	!!
	function Math_erfinv( x_in ) result( r )
		real(8), intent(in) :: x_in
		real(8) :: r

		real(8) :: x, x2, y
		integer :: sign_x

		x = x_in

		if( x < -1.0_8 .or. x > 1_8 ) then
! 			r = Math_NAN
			r = sqrt(-1.0_8)
			return
		end if

		if( x == 0.0_8 ) then
			r = 0.0_8
			return
		end if

		if( x > 0.0_8 ) then
			sign_x = 1
		else
			sign_x = -1
			x = -x
		end if

		if( x <= 0.7_8 ) then
			x2 = x*x
			r = x*(((erfinv_a3 * x2 + erfinv_a2) * x2 + erfinv_a1) * x2 + erfinv_a0)
! 			r = r/(((erfinv_b4 * x2 + erfinv_b3) * x2 + erfinv_b2) * x2 + erfinv_b1)*x2 + erfinv_b0
		else
			y = sqrt (-log ((1.0_8 - x) /2.0_8))
			r = (((erfinv_c3 * y + erfinv_c2) * y + erfinv_c1) * y + erfinv_c0)
			r = r/((erfinv_d2 * y + erfinv_d1) * y + erfinv_d0)
		end if

		r = r * sign_x
		x = x * sign_x

		r = r - (erf(r) - x) / (2.0_8/sqrt(Math_PI)*exp(-r*r))
		r = r - (erf(r) - x) / (2.0_8/sqrt(Math_PI)*exp(-r*r))
	end function Math_erfinv

	!>
	!! @brief
	!!
	pure function Math_ustep( x ) result( output )
		real(8), intent(in) :: x
		real(8) :: output

		output = 0.5_8*( 1.0_8 + tanh( 1.0d12*x ) )
	end function Math_ustep

	!>
	!! @brief
	!!
	pure function Math_ubox( x ) result( output )
		real(8), intent(in) :: x
		real(8) :: output

		output = Math_ustep( x+0.5_8 ) - Math_ustep( x-0.5_8 )
	end function Math_ubox

	!>
	!! @brief Unnormalized sinc function
	!!
	pure function Math_sinc( x ) result( output )
		real(8), intent(in) :: x
		real(8) :: output

		output = sin(x)/x
	end function Math_sinc

	!>
	!! @brief Normalized sinc function
	!!
	pure function Math_nsinc( x ) result( output )
		real(8), intent(in) :: x
		real(8) :: output

		output = sin(Math_PI*x)/Math_PI/x
	end function Math_nsinc

	!>
	!! @brief Gaussian function
	!!
	pure function Math_gaussian( x, x0, I0, FWHM  ) result( output )
		real(8), intent(in) :: x, x0, I0, FWHM
		real(8) :: output

		real(8) :: width

		width = FWHM/2.35482_8
		output = I0*exp( -(x-x0)**2/2.0_8/width**2 )
	end function Math_gaussian

	!>
	!! @brief Gaussian lorentzian
	!!
	pure function Math_lorentzian( x, x0, I0, FWHM  ) result( output )
		real(8), intent(in) :: x, x0, I0, FWHM
		real(8) :: output

		real(8) :: width

		width = 0.5_8*FWHM
		output = I0/( 1.0_8+((x-x0)/width)**2 )
	end function Math_lorentzian

	!>
	!! @brief
	!! @input t Independent variable (time)
	!! @input t0 Position of its center
	!! @input w tophat width of the pulse
	!! @input w turn-on/turn-off time
	!!
	function Math_erfTophat( t, t0, w, dw ) result( output )
		real(8) :: t
		real(8) :: t0
		real(8) :: w
		real(8) :: dw
		real(8) :: output

		output = 0.0_8
		if ( t>t0-w/2-dw .and. t<=t0-w/2 ) then
			output = 0.5*erf( 4.0*(t-(t0-w/2-dw/2))/dw )+0.5
		else if ( t>t0-w/2 .and. t<=t0+w/2 ) then
			output = 1.0
		else if ( t>t0+w/2 .and. t<t0+w/2+dw ) then
			output = 0.5-0.5*erf( 4.0*(t-(t0+w/2+dw/2))/dw )
		end if
	end function Math_erfTophat

	!>
	!! @brief
	!! @input t Independent variable (time)
	!! @input t0 Position of its center
	!! @input w width of the window
	!!
	function Math_flatTopWindow( t, t0, w ) result( output )
		real(8) :: t
		real(8) :: t0
		real(8) :: w
		real(8) :: output

		output = 0.0_8
		if ( t>=t0-w/2 .and. t<=t0+w/2 ) then
			output = 1d-9*( 215578947.0 + 416631580.0*cos(2.0*Math_PI*(t-t0)/w) + 277263158.0*cos(4.0*Math_PI*(t-t0)/w)\
					+83578947.0*cos(6.0*Math_PI*(t-t0)/w) + 6947368.0*cos(8.0*Math_PI*(t-t0)/w) )
		end if
	end function Math_flatTopWindow

	!>
	!! @brief
	!!
	function Math_average( array ) result( output )
		real(8), allocatable, intent(in) :: array(:)
		real(8) :: output

		integer :: i
		real(8) :: ssum

		ssum = 0.0_8
		do i=1,size(array)
			ssum = ssum + array(i)
		end do

		output = ssum/real(size(array),8)
	end function Math_average

	!>
	!! @brief
	!!
	function Math_stdev( array, aver ) result( output )
		real(8), allocatable, intent(in) :: array(:)
		real(8), optional, intent(in) :: aver
		real(8) :: output

		real(8) :: effAver

		integer :: i
		real(8) :: ssum

		if( present(aver) ) then
			effAver = aver
		else
			effAver = Math_average( array )
		end if

		ssum = 0.0_8
		do i=1,size(array)
			ssum = ssum + ( array(i) - effAver )**2
		end do

		output = sqrt( ssum/real(size(array),8) )
	end function Math_stdev

	!>
	!! @brief
	!!
	function Math_skewness( array ) result( output )
		real(8), allocatable, intent(in) :: array(:)
		real(8) :: output

		integer :: i
		real(8) :: aver, stdev, ssum

		aver = Math_average( array )
		stdev = Math_stdev( array, aver )

		ssum = 0.0_8
		do i=1,size(array)
			ssum = ssum + ( array(i) - aver )**3
		end do

		output = ssum/real(size(array),8)/stdev**3

		! Esto ocurre si stdev es cero, entonces es una delta de Dirac
		! y por lo tanto simetrica, por eso he puesto output=0
		if( Math_isNaN(output) ) output = 0.0_8
	end function Math_skewness

	!>
	!! @brief
	!!
	pure function Math_rFloorDivision( x, y ) result( output )
		real(8), intent(in) :: x
		real(8), intent(in) :: y
		real(8) :: output

		output = floor( x/y )
	end function Math_rFloorDivision

	!>
	!! @brief
	!!
	pure function Math_iFloorDivision( x, y ) result( output )
		integer, intent(in) :: x
		integer, intent(in) :: y
		real(8) :: output

		output = floor( real(x,8)/real(y,8) )
	end function Math_iFloorDivision

	!>
	!! This is only necessary for Math_test method
	!!
	function myStrConstrain( multisetPositions, current ) result( output )
		integer, allocatable, intent(in) :: multisetPositions(:)
		integer, intent(in) :: current
		logical :: output

		integer :: i, j

		if( current == size(multisetPositions) ) then
			!----------------------------------------------
			! ¿ El multiset encontrado es correcto ?
			!----------------------------------------------
			output = .false.

			do i=1,size(multisetPositions)
! 				do j=1,size(multisetPositions)
! 					if( multisetPositions(i) == 1 .and. multisetPositions(j) == 3 ) then ! Que la cadena tenga una "a" y una "c"
! 						output = .true.
! 						return
! 					end if

					if( multisetPositions(i) == 1 ) then ! Que la cadena tenga una "a" en cualquier posición
						output = .true.
						return
					end if
! 				end do
			end do
		else
			!----------------------------------------------
			! ¿ El camino recorrido es incorrecto ?
			!----------------------------------------------
			output = .false. ! La solución solo se puede saber hasta el final
		end if

		return
	end function myStrConstrain

	!>
	!! This is only necessary for RandomUtils_test method
	!!
	function myIntConstrainDebug( multisetPositions, current ) result( output )
		integer, allocatable, intent(in) :: multisetPositions(:)
		integer, intent(in) :: current
		logical :: output

		integer :: i
		integer :: ssum

		write(*,"(A)", advance="no") ">>>"

		ssum = 0
		do i=1,current
			ssum = ssum + MyiArray( multisetPositions(i) )

			write(*,"(I1,A,I1,A)", advance="no") MyiArray( multisetPositions(i) ), "(", multisetPositions(i), ")"
		end do

		if( current == size(multisetPositions) ) then
			!----------------------------------------------
			! ¿ El multiset encontrado es correcto ?
			!----------------------------------------------
			write(*,"(A,I3,I5)", advance="no") "<<<", ssum, current

			output = .false.
			if( ssum <= 8 ) then ! Que la suma no exceda 8
				write(*,"(A)") "   OK"
				output = .true.
			else
				write(*,"(A)") "   Failed"
			end if

		else
			!----------------------------------------------
			! ¿ El camino recorrido es incorrecto ?
			!----------------------------------------------
			write(*,"(A,I3,I5)", advance="no") "<<<", ssum

			output = .true.
			if( ssum <= 8 ) then ! Que la suma no exceda 8
				write(*,"(A)") "   right way"
				output = .false.
			else
				write(*,"(A)") "   bad way"
			end if

		end if

		return
	end function myIntConstrainDebug

	!>
	!! This is only necessary for RandomUtils_test method
	!!
	function myIntConstrain( multisetPositions, current ) result( output )
		integer, allocatable, intent(in) :: multisetPositions(:)
		integer, intent(in) :: current
		logical :: output

		integer :: i
		integer :: ssum

		ssum = 0
		do i=1,current
			ssum = ssum + MyiArray( multisetPositions(i) )
		end do

		if( current == size(multisetPositions) ) then
			!----------------------------------------------
			! ¿ El multiset encontrado es correcto ?
			!----------------------------------------------
			output = .false.
			if( ssum <= 8 ) then ! Que la suma no exceda 8
				output = .true.
			end if
		else
			!----------------------------------------------
			! ¿ El camino recorrido es incorrecto ?
			!----------------------------------------------
			output = .true.
			if( ssum <= 8 ) then ! Que la suma no exceda 8
				output = .false.
			end if
		end if

		return
	end function myIntConstrain

	!>
	!! This is only necessary for RandomUtils_test method
	!!
	function myMassConstrain( multisetPositions, current ) result( output )
		integer, allocatable, intent(in) :: multisetPositions(:)
		integer, intent(in) :: current
		logical :: output

		integer :: i
		integer :: ssum

		ssum = 0
		do i=1,current
			ssum = ssum + MyiArray( multisetPositions(i) )
		end do

		if( current == size(multisetPositions) ) then
			!----------------------------------------------
			! ¿ El multiset encontrado es correcto ?
			!----------------------------------------------
			output = .false.
			if( ssum <= MyiArray(size(MyiArray)) ) then
				output = .true.
			end if
		else
			!----------------------------------------------
			! ¿ El camino recorrido es incorrecto ?
			!----------------------------------------------
			output = .true.
			if( ssum <= MyiArray(size(MyiArray)) ) then
				output = .false.
			end if
		end if

		return
	end function myMassConstrain

	!>
	!! @brief The result has the value true if the value of x is NaN; otherwise, false.
	!!
	function Math_isNaN( x ) result( output )
		real(8), intent(in) :: x
		logical :: output

		output = IEEE_IS_NAN( x )
	end function Math_isNaN

	!>
	!! @brief The result has the value true if the value of x is Inf; otherwise, false.
	!!
	function Math_isInf( x ) result( output )
		real(8), intent(in) :: x
		logical :: output

		output = .not. IEEE_IS_FINITE( x )
	end function Math_isInf

	!>
	!! @brief The result has the value true if the value of x is Inf; otherwise, false.
	!!
	function Math_isIInf( x ) result( output )
		integer, intent(in) :: x
		logical :: output

		output = ( huge(0) == x )
	end function Math_isIInf

	!>
	!! @brief Returns the scalar product of two vectors (r1,r2),
	!!        which must have the same length (same number of elements).
	!!
	function Math_dotProduct( r1, r2 ) result( output )
		real(8) :: r1(3), r2(3)
		real(8) :: output

		output = DOT_PRODUCT( r1, r2 )
	end function Math_dotProduct

	!>
	!! @brief Returns the cross product of two vectors (r1,r2),
	!!        which must have the same length (same number of elements).
	!!
	function Math_crossProduct( r1, r2 ) result( output )
		real(8) :: r1(3), r2(3)
		real(8) :: output(3)

		output(1) = r1(2)*r2(3) - r1(3)*r2(2)
		output(2) = r1(3)*r2(1) - r1(1)*r2(3)
		output(3) = r1(1)*r2(2) - r1(2)*r2(1)
	end function Math_crossProduct

	!>
	!! @brief Returns the distance from the point r0 to the line specified by
	!!        two points r1 and r2 lying on it. Only 3D case is available.
	!!
	function Math_pointLineDistance( r0, r1, r2 ) result( output )
		real(8) :: r0(3), r1(3), r2(3)
		real(8) :: output

		output = norm2(Math_crossProduct( r0-r1, r0-r2 ))/norm2(r2-r1)
	end function Math_pointLineDistance

	!>
	!! @brief Test method
	!!
	subroutine Math_test()
		real(8), allocatable :: rArray(:)
		integer, allocatable :: iArray(:)
		integer, allocatable :: indexes(:)
		integer, allocatable :: iComb(:), iCombOld(:,:)
		character(10), allocatable :: strArray(:), sComb(:)
! 		character(10), allocatable :: comb(:)
		real(8) :: x

		integer :: i, j, k, l
		integer :: nFrag

! 		write(*,*) ""
! 		write(*,*) "Sorting vectors"
! 		write(*,*) "==============="
! 		allocate( rArray(19) )
! 		allocate( indexes(19) )
!
! 		rArray = [ -33.89007, -33.89007, -35.21007, -35.42677, -35.90699, &
! 			  -33.67374, -34.15396, -33.27902, -33.27902, -34.04338, &
! 			  -34.04338, -31.81726, -31.81726, -33.49329, -33.97351, &
! 			  -32.91849, -33.39871, -33.24224, -33.24224 ]
!
! 		call Math_sort( rArray, indexes )
!
! 		write(*,"(5X,2A15)") "original", "sorted"
! 		write(*,"(5X,2A15)") "--------", "------"
! 		do i=1,size(rArray)
! 			write(*,"(I5,2F15.5)") i, rArray(i), rArray( indexes(i) )
! 		end do
!
! 		allocate( iArray(19) )
!
! 		iArray = [ -35, -33, -35, -35, -31, &
! 			     -32, -34, -33, -34, -32, &
! 			     -39, -31, -31, -31, -33, &
! 			     -31, -33, -33, -30 ]
!
! 		call Math_sort( iArray, indexes )
!
! 		write(*,"(A)") ""
! 		write(*,"(5X,2A15)") "original", "sorted"
! 		write(*,"(5X,2A15)") "--------", "------"
! 		do i=1,size(rArray)
! 			write(*,"(I5,2I15)") i, iArray(i), iArray( indexes(i) )
! 		end do
!
! 		deallocate( rArray )
! 		deallocate( iArray )
! 		deallocate( indexes )
!
! 		write(*,*) ""
! 		write(*,*) "3j symbols"
! 		write(*,*) "=========="
!
! 		write(*,*) "(3/2  0  3/2;    0  0    0) = ", Math_wigner3j( 1.5_8, 0.0_8, 1.5_8, 0.0_8, 0.0_8, 0.0_8 )
! 		write(*,*) "(3/2  0  3/2;  1/2  0 -1/2) = ", Math_wigner3j( 1.5_8, 0.0_8, 1.5_8, 0.5_8, 0.0_8,-0.5_8 )
! 		write(*,*) "(3/2  0  3/2; -1/2  0  1/2) = ", Math_wigner3j( 1.5_8, 0.0_8, 1.5_8,-0.5_8, 0.0_8, 0.5_8 )
! 		write(*,*) "(3/2  0  3/2;  3/2  0 -3/2) = ", Math_wigner3j( 1.5_8, 0.0_8, 1.5_8, 1.5_8, 0.0_8,-1.5_8 )
! 		write(*,*) "(3/2  0  3/2; -3/2  0  3/2) = ", Math_wigner3j( 1.5_8, 0.0_8, 1.5_8,-1.5_8, 0.0_8, 1.5_8 )

		write(*,*) ""
		write(*,*) "Combinatorial"
		write(*,*) "============="

		write(*,*) "Gamma(0.5) = ", Gamma(0.5_8)
		write(*,*) "log_Gamma(0.5) = ", log_Gamma(0.5_8)
		write(*,*) "Gamma(7+1) = ", Gamma(8.0_8)
		write(*,*) "Math_fact(7) = ", Math_fact(7)
		write(*,*) "Math_comb(7,2) = ", Math_comb(7,2)
		write(*,*) "Math_multisetNumber(7,2) = ", Math_multisetNumber( 7, 2 )
		write(*,*) ""

! 		deallocate( comb )
		!--------------------------------------------------------

		allocate( strArray(3) )
		strArray = ["a", "b", "c"]

		write(*,*)
		write(*,"(A,3A2,A)") " set = { ", strArray, "}"
		write(*,*) "Math_multisetNumber( nElems, 3 ) = "
		call Math_multisets( 3, 3, iCombOld, myStrConstrain )

		do i=1,size(iCombOld,dim=1)
			write(*,"(I5,A)", advance="no") i, ")   "
			do j=1,3
				write(*,"(A)", advance="no") trim(strArray( iCombOld(i,j) ))
			end do
			write(*,*) ""
		end do

		deallocate( strArray )
		deallocate( iCombOld )

		!-----------------------------------------------------------------
		allocate( MyiArray(3) )
		MyiArray = [1, 3, 5]

		write(*,*)
		write(*,"(A,3I2,A)") " set = { ", MyiArray, " }"
		write(*,*) "Math_multisetNumber( nElems, 3 ) = ", Math_multisetNumber( 3, 3 )
		call Math_multisets( 3, 3, iCombOld, myIntConstrain )
! 		call Math_multisets( 3, 3, iCombOld, myIntConstrainDebug )

		do i=1,size(iCombOld,dim=1)
			write(*,"(I5,A)", advance="no") i, ")   "
			do j=1,3
				write(*,"(I1)", advance="no") MyiArray( iCombOld(i,j) )
			end do
			write(*,*) ""
		end do

		deallocate( MyiArray )
		deallocate( iCombOld )

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

		allocate( strArray(8) )
		strArray = ["H", "C", "CH", "C2", "H2", "C2H", "CH2", "C2H2"]

		allocate( MyiArray(8) )
		MyiArray = [1, 6, 7, 12, 2, 13, 8, 14]

		write(*,*)
		write(*,"(A,<size(strArray)>A5,A)") " set = { ", strArray, " }"

		k=1
		do nFrag=1,size(strArray)
			call Math_multisets( size(strArray), nFrag, iCombOld, myMassConstrain )

			do i=1,size(iCombOld,dim=1)
				write(*,"(I5,A)", advance="no") k, ")   "
				do j=1,nFrag-1
					write(*,"(A)", advance="no") trim(strArray( iCombOld(i,j) ))//"+"
				end do
				write(*,"(A)", advance="no") trim(strArray( iCombOld(i,nFrag) ))
				write(*,*) ""

				k=k+1
			end do
		end do

		deallocate( strArray )
		deallocate( iCombOld )

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

! 		x = -0.99999_8
! 		do while( x < 1.0_8 )
! 			write(*,*) x, Math_erfinv(x)
! 			x = x+0.001_8
! 		end do

! 		write(*,"(3F15.6)") Math_erfinv(0.5_8), Math_erfinv(0.33_8), Math_erfinv(-1.0_8/3.0_8)
! 		write(*,"(3F15.6)") 0.4769362762, 0.3013321461, -0.3045701942
! 		write(*,"(3F15.6)") Math_erfinv(0.5_8)-0.4769362762, Math_erfinv(0.33_8)-0.3013321461, Math_erfinv(-1.0_8/3.0_8)-(-0.3045701942)

		write(*,*) ""
		write(*,*) "Testing IEEE support"
		write(*,*) "===================="
		write(*,*) "isNaN( 2.0 ) = ", Math_isNaN( 2.0_8 )
		write(*,*) "isNaN( 1.0d500 ) = ", Math_isNaN( 1.0d500 )
		write(*,*) "isNaN( sqrt(-1.0_8) ) = ", Math_isNaN( sqrt(-1.0_8) )
		write(*,*) "1.0_8/Math_INF = ", 1.0_8/Math_INF
		write(*,"(A,F10.5)") "Math_INF = ", Math_INF
		write(*,*) "isInf( 1.0d56 ) = ", Math_isInf( 1.0d56 )
		write(*,*) "isInf( 1.0_8/0.0_8 ) = ", Math_isInf( 1.0_8/0.0_8 )
		write(*,*) "isInf( 1.0_8/0.0_8+10.0_8 ) = ", Math_isInf( 1.0_8/0.0_8+10.0_8 )
		write(*,*) "isInf( 1.0_8/0.0_8-10.0_8 ) = ", Math_isInf( 1.0_8/0.0_8-10.0_8 )

	end subroutine Math_test

end module Math_


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!       ops :    Optimization of periodic solutions
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

      DOUBLE PRECISION x,y,z,p1,p2,p3,p4
      INTEGER I,J

       x=U(1)
       y=U(2)
       z=U(3)

       p1=PAR(1)
       p2=PAR(2)
       p3=PAR(3)
       p4=PAR(4)

       F(1)=( -p4*(x**3/3-x) + (z-x)/p2 - y ) / p1
       F(2)=x-p3
       F(3)=-(z-x)/p2

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=( -p4*(x**2-1) - 1/p2 ) /p1
       DFDU(1,2)=-1/p1
       DFDU(1,3)=1/(p2*p1)

       DFDU(2,1)=1
       DFDU(2,2)=0
       DFDU(2,3)=0

       DFDU(3,1)=1/p2
       DFDU(3,2)=0
       DFDU(3,3)=-1/p2

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DO I=1,3
         DO J=1,9
           DFDP(I,J)=0.d0
         ENDDO
       ENDDO

       DFDP(1,1)=-( -p4*(x**3/3-x) + (z-x)/p2 - y )/p1**2
       DFDP(1,2)=-(z-x)/(p2**2*p1)
       DFDP(1,3)=0
       DFDP(1,4)=-(x**3/3-x)/p1

       DFDP(2,1)=0
       DFDP(2,2)=0
       DFDP(2,3)=-1
       DFDP(2,4)=0

       DFDP(3,1)=0
       DFDP(3,2)=(z-x)/p2**2
       DFDP(3,3)=0
       DFDP(3,4)=0

      END SUBROUTINE FUNC

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

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

      DOUBLE PRECISION p1,p2,p3,p4

      p1=0.5
      p2=4
      p3=0.9
      p4=2.

      U(1)=p3
      U(2)=-p4*(p3**3/3-p3)
      U(3)=p3

      PAR(1)=p1
      PAR(2)=p2
      PAR(3)=p3
      PAR(4)=p4

      END SUBROUTINE STPNT

      SUBROUTINE FOPT(NDIM,U,ICP,PAR,IJAC,FS,DFDU,DFDP)
!     ---------- ----

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

      INTEGER I

       FS=PAR(3)

      IF(IJAC.EQ.0)RETURN

       DO I=1,NDIM
         DFDU(I)=0.d0
       ENDDO

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DO I=1,9
         DFDP(I)=0.d0
       ENDDO

       DFDP(3)=1.d0

      END SUBROUTINE FOPT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


program main
    ! compare the energy calculated from matrix diagonalization method and Numerov's method

    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    ! local vars
    integer :: i, n(100)
    real(dp) :: EMD(100), EN(100)

    open(unit = 1, file = '3-energy-ExactDiagonalization.txt', status = 'unknown')
    do i = 1, 100
        read(1, '(i4,f20.8)') n(i), EMD(i)
    end do
    close(1)

    open(unit = 2, file = '3-energy-Numerov.txt', status = 'unknown')
    do i = 1, 100
        read(2, '(i4,f20.8)') n(i), EN(i)
    end do
    close(2)

    open(unit = 3, file = '3-energy-Compare.txt', status = 'unknown')
    do i = 1, 10
        write(3, '(i4,4f20.8)') n(i), EMD(i), EN(i), EMD(i) - EN(i), (EMD(i) - EN(i)) / EN(i)
    end do
    write(3, *)
    do i = 91, 100
        write(3, '(i4,4f20.8)') n(i), EMD(i), EN(i), EMD(i) - EN(i), (EMD(i) - EN(i)) / EN(i)
    end do
    close(3)
end program main


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

subroutine linlsq(n,m,f,y,w,c)

! This subroutine performs a fit of the datavalues (i,y(i)), i = 1,..,n         !
! to the linear modelfunction c(1)*f(:,1) + c(2)*f(:,2) + ... + c(m)*f(:,m)     !
!                                                                               !
! see A. Garcia, Numerical methods for physics, ISBN 0-13-906744-2              !
! pages 142-146                                                                 !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 26/3-2005                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,n,m
double precision :: f(n,m),y(n),w(n),wsq(n),a(m,m),b(m),c(m)

!---- Construct the matrices a = A^T A  and b = A^T y --------------------------

wsq = w**2.d0
do i = 1,m
  do j = i,m
    a(i,j) = sum(f(:,i)*f(:,j)*wsq)
  end do
  b(i) = sum(f(:,i)*y*wsq)
end do

do i = 2,m
  do j = 1,i-1
    a(i,j) = a(j,i)
  end do
end do

!---- Solve the m x m normal equation  A^T A c = A^T b -------------------------

call gauss(m,a,b,c)

end subroutine linlsq