C
C This subroutine removes missing values before
C calling SPCORR. It keeps count of the missing
C values via NMSG.
C
       SUBROUTINE SPCORRZ(X,Y,N,IWRITE,SPC,HASXMSG,XMSG,
     +                    HASYMSG,YMSG,NMSG)
C INPUT
       INTEGER N, IWRITE
       INTEGER HASXMSG, HASYMSG
       DOUBLE PRECISION X(N), Y(N), XMSG,YMSG
C OUTPUT
       DOUBLE PRECISION SPC
       INTEGER NMSG
C
C LOCAL
       INTEGER NN, K
       DOUBLE PRECISION XX(N), YY(N)

       IF(HASXMSG.EQ.0.AND.HASYMSG.EQ.0) THEN
          CALL SPCORR(X,Y,N,IWRITE,SPC)
          NMSG = 0
       ELSE
          NN   = 0
          DO K=1,N
             IF (.NOT.((HASXMSG.EQ.1.AND.X(K).EQ.XMSG) .OR.
     +                 (HASYMSG.EQ.1.AND.Y(K).EQ.YMSG))) THEN
                NN = NN+1
                XX(NN) = X(K)
                YY(NN) = Y(K)
             END IF
          END DO
          IF (NN.GT.0) THEN
             CALL SPCORR(XX,YY,NN,IWRITE,SPC)
          END IF
          NMSG = N - NN
       END IF
       RETURN
       END
C NCLFORTSTART
      SUBROUTINE SPCORR(X,Y,N,IWRITE,SPC)
C                                                  INPUT
      INTEGER N, IWRITE
      DOUBLE PRECISION X(N), Y(N)
C                                                  OUTPUT
      DOUBLE PRECISION SPC
C NCLEND
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SPEARMAN RANK CORRELATION COEFFICIENT
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C              THE SPEARMAN RANK CORRELATION COEFFICIENT WILL BE A
C              SINGLE PRECISION VALUE BETWEEN -1.0 AND 1.0
C              (INCLUSIVELY).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C                     --IWRITE = AN INTEGER FLAG CODE WHICH
C                                (IF SET TO 0) WILL SUPPRESS
C                                THE PRINTING OF THE
C                                SPEARMAN RANK CORRELATION COEFFICIENT
C                                AS IT IS COMPUTED;
C                                OR (IF SET TO SOME INTEGER
C                                VALUE NOT EQUAL TO 0),
C                                LIKE, SAY, 1) WILL CAUSE
C                                THE PRINTING OF THE
C                                SPEARMAN CORRELATION COEFFICIENT
C                                AT THE TIME IT IS COMPUTED.
C     OUTPUT ARGUMENTS--SPC    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SPEARMAN RANK CORRELATION
C                                COEFFICIENT BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SPEARMAN RANK CORRELATION COEFFICIENT BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     PRINTING--NONE, UNLESS IWRITE HAS BEEN SET TO A NON-ZERO
C               INTEGER, OR UNLESS AN INPUT ARGUMENT ERROR
C               CONDITION EXISTS.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 7500.
C     OTHER DATAPAC   SUBROUTINES NEEDED--RANK AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF
C                 STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 476-477.
C               --SNEDECOR AND COCHRAN, STATISTICAL METHODS,
C                 EDITION 6, 1967, PAGES 193-195.
C               --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C                 ANALYSIS, EDITION 2, 1957, PAGES 294-295.
C               --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY
C                 OF STATISTICS, EDITION 2, 1963, PAGE 424.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --OCTOBER   1974.
C     UPDATED         --JANUARY   1975.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --FEBRUARY  1976.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XR(N), YR(N)
      DOUBLE PRECISION AN
      DOUBLE PRECISION HOLD
      DOUBLE PRECISION SUM
C
      IPR = 6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      AN  = N
      SPC = 0.0D0
      IFLAG = 0
      IF (N.EQ.1) GO TO 55
      HOLD = X(1)
      DO I = 2,N
          IF (X(I).NE.HOLD) GO TO 65
      END DO
c c   WRITE (IPR,FMT=9) HOLD
      IFLAG = 1
   65 HOLD = Y(1)
      DO I = 2,N
          IF (Y(I).NE.HOLD) GO TO 80
      END DO

c c c WRITE (IPR,FMT=19) HOLD
      IFLAG = 1
   80 IF (IFLAG.EQ.1) RETURN
      GO TO 90
c c50 WRITE (IPR,FMT=27) IUPPER
c c   WRITE (IPR,FMT=47) N
c c   RETURN
   55 CONTINUE
c c   WRITE (IPR,FMT=28)
      RETURN
   90 CONTINUE
c c 9 FORMAT (1H ,
c c  +108H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT (A VECTO
c c  +R) TO THE SPCORR SUBROUTINE HAS ALL ELEMENTS =,D15.8,6H *****)
c c19 FORMAT (1H ,
c c  +108H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT (A VECTO
c c  +R) TO THE SPCORR SUBROUTINE HAS ALL ELEMENTS =,D15.8,6H *****)
c c27 FORMAT (' ***** FATAL ERROR--THE THIRD  INPUT ARGUMENT TO THE SP',
c c  + 'CORR SUBROUTINE IS OUTSIDE THE ALLOWABLE (1,,I6,16H) INTERVAL *'
c c  +       ,'****')
c c28 FORMAT (1H ,
c c  +100H***** NON-FATAL DIAGNOSTIC--THE THIRD  INPUT ARGUMENT TO THE S
c c  +PCORR SUBROUTINE HAS THE VALUE 1 *****)
c c47 FORMAT (1H ,35H***** THE VALUE OF THE ARGUMENT IS ,I8,6H *****)
C
C-----START POINT-----------------------------------------------------
C
      CALL SPRANK(X,N,XR)
      CALL SPRANK(Y,N,YR)

      SUM = 0.0D0
      DO I = 1,N
          SUM = SUM + (XR(I)-YR(I))**2
      END DO
      SPC = 1.0D0 - (6.0D0*SUM/ ((AN-1.0D0)*AN* (AN+1.0D0)))
C
c c   IF (IWRITE.NE.0) WRITE (IPR,FMT=105) N,SPC
c c05 FORMAT (1H ,
c c  +    59HTHE SPEARMAN RANK CORRELATION COEFFICIENT OF THE 2 SETS OF
c c  +       ,I6,17H OBSERVATIONS IS ,F14.5)
      RETURN
      END
C
      SUBROUTINE SPRANK(X,N,XR)
      INTEGER N
      DOUBLE PRECISION X(N), XR(N)
C  http://www.itl.nist.gov/div898/software/datapac/RANK.f
C
C     PURPOSE--THIS SUBROUTINE RANKS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X,
C              AND PUTS THE RESULTING N RANKS INTO THE
C              SINGLE PRECISION VECTOR XR.
C              THIS SUBROUTINE GIVES THE DATA ANALYST
C              THE ABILITY TO (FOR EXAMPLE) RANK THE DATA
C              PRELIMINARY TO CERTAIN DISTRIBUTION-FREE
C              ANALYSES.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE RANKED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XR     = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE RANKS
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR XR
C             CONTAINING THE RANKS
C             (IN ASCENDING ORDER)
C             OF THE VALUES
C             IN THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N
C                   FOR THIS SUBROUTINE IS 7500.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     COMMENT--THE RANK OF THE FIRST ELEMENT
C              OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR XR,
C              THE RANK OF THE SECOND ELEMENT
C              OF THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR XR,
C              ETC.
C     COMMENT--THE SMALLEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF 1 (UNLESS TIES EXIST).
C              THE LARGEST ELEMENT IN THE VECTOR X
C              WILL HAVE A RANK OF N (UNLESS TIES EXIST).
C     COMMENT--ALTHOUGH RANKS ARE USUALLY (UNLESS TIES EXIST)
C              INTEGRAL VALUES FROM 1 TO N, IT IS TO BE
C              NOTED THAT THEY ARE OUTPUTED AS SINGLE
C              PRECISION INTEGERS IN THE SINGLE PRECISION
C              VECTOR XR.
C              XR IS SINGLE PRECISION SO AS TO BE
C              CONSISTENT WITH THE FACT THAT ALL
C              VECTOR ARGUMENTS IN ALL OTHER
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION;
C              BUT MORE IMPORTANTLY, BECAUSE TIES FREQUENTLY
C              DO EXIST IN DATA SETS AND SO SOME OF THE
C              RESULTING RANKS WILL BE NON-INTEGRAL
C              AND SO THE OUTPUT VECTOR OF RANKS MUST NECESSARILY
C              BE SINGLE PRECISION AND NOT INTEGER.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--DUE TO CONFLICTING USE OF LABELED
C              COMMON /BLOCK2/ BY THIS RANK
C              SUBROUTINE AND THE SPCORR (SPEARMAN RANK
C              CORRELATION COEFFICIENT) SUBROUTINE,
C              THE VECTOR XS OF THIS RANK
C              SUBROUTINE HAS BEEN PLACED IN
C              LABELED COMMON /BLOCK4/
C     COMMENT--THE FIRST AND THIRD ARGUMENTS IN THE
C              CALLING SEQUENCE MAY
C              BE IDENTICAL; THAT IS, AN 'IN PLACE'
C              RANKING IS PERMITTED.
C              THE CALLING SEQUENCE
C              CALL RANK(X,N,X) IS VALID, IF DESIRED.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-2315
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --JANUARY   1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --JANUARY   1977.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XS(N)
      DOUBLE PRECISION AN
      DOUBLE PRECISION HOLD
      DOUBLE PRECISION AVRANK
      DOUBLE PRECISION XPREV
      DOUBLE PRECISION RPREV
C
      AN = N
      IPR = 6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF (N.EQ.1) GO TO 55
      HOLD = X(1)
      DO I = 2,N
          IF (X(I).NE.HOLD) GO TO 90
      END DO

c c   WRITE (IPR,FMT=9) HOLD
      AVRANK = (AN+1.0D0)/2.0D0
      DO I = 1,N
          XR(I) = AVRANK
      END DO
      RETURN

   50 CONTINUE
c c   WRITE (IPR,FMT=17) IUPPER
c c   WRITE (IPR,FMT=47) N
      RETURN
   55 CONTINUE
c c   WRITE (IPR,FMT=18)
      XR(1) = 1.0D0
      RETURN

   90 CONTINUE
c c 9 FORMAT (1H ,
c c  +109H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT (A VECTO
c c  +R) TO THE RANK   SUBROUTINE HAS ALL ELEMENTS = ,D15.8,6H *****)
c c17 FORMAT (1H ,
c c  +98H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE RANK   SUBR
c c  +OUTINE IS OUTSIDE THE ALLOWABLE (1,,I6,16H) INTERVAL *****)
c c18 FORMAT (1H ,
c c  +100H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE R
c c  +ANK   SUBROUTINE HAS THE VALUE 1 *****)
c c47 FORMAT (1H ,35H***** THE VALUE OF THE ARGUMENT IS ,I8,6H *****)
C
C-----START POINT-----------------------------------------------------
C
C     FIRST SORT THE DATA FROM THE INPUT VECTOR X
C     INTO THE INTERMEDIATE STORAGE VECTOR XS.
C
      CALL SPSORT(X,N,XS)
C
C     NOW DETERMINE THE RANKS.
C     THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT
C     IN THE ORIGINAL INPUT VECTOR X,
C     AND SCAN THE SORTED VALUES IN THE XS VECTOR
C     UNTIL A MATCH IS FOUND;
C     WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT
C     VALUE IN THE XS VECTOR IS DETERMINED.
C     THAT RANK IS THEN WRITTEN INTO THAT POSITION
C     IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE POSITION OF THE
C     GIVEN ELEMENT OF INTEREST IN THE ORIGINAL X VECTOR.
C     THE CODE IS LENGTHENED FROM THIS BASIC ALGORITHM
C     BY A SECTION WHICH CUTS DOWN THE SEARCH IN THE XS VECTOR,
C     AND BY A SECTION WHICH OBVIATES (UNDER CERTAIN CIRCUMSTANCES)
C     THE NEED FOR RECALCULATING THE RANK OF AN ELEMENT IN XS.
C
      NM1 = N - 1
      XPREV = X(1)
      DO I = 1,N
          JMIN = 1
          IF (X(I).GT.XPREV) GO TO 770
          IF (I.EQ.1) GO TO 790
          IF (X(I).EQ.XPREV) GO TO 750
          GO TO 790
  750     CONTINUE
          XR(I) = RPREV
          GO TO 880
  770     CONTINUE
          JMIN = K
          IF (JMIN.LT.N) GO TO 790
          IF (JMIN.EQ.N) GO TO 820
          IBRAN = 1
c c       WRITE (IPR,FMT=109) IBRAN
c c       WRITE (IPR,FMT=101) JMIN
c 109     FORMAT (1H ,40H*****INTERNAL ERROR IN RANK SUBROUTINE--,
c c  +           46HIMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ,I8)
c 101     FORMAT (1H ,'JMIN = ',I8)
          STOP
  790     CONTINUE
          DO 800 J = JMIN,NM1
              IF (X(I).NE.XS(J)) GO TO 800
              JP1 = J + 1
              DO K = JP1,N
                  IF (XS(K).NE.XS(J)) GO TO 950
              END DO
              K = N + 1
  950         CONTINUE
              AVRANK = J + K - 1
              AVRANK = AVRANK/2.0D0
              XR(I) = AVRANK
              GO TO 880
  800     CONTINUE
  820     CONTINUE
          J = N
          K = N + 1
          IF (X(I).EQ.XS(J)) GO TO 850
          IBRAN = 2
c c       WRITE (IPR,FMT=109) IBRAN
c c       WRITE (IPR,FMT=102) X(I),XS(J)
c 102     FORMAT (1H ,'X(I) = ',F15.7,'   XS(J) = ',F15.7)
          STOP
  850     CONTINUE
          XR(I) = N
  880     CONTINUE
          XPREV = X(I)
          RPREV = XR(I)
      END DO
C
      RETURN
      END
c ======================================================

      SUBROUTINE SPSORT(X, N, Y)
      INTEGER N
      DOUBLE PRECISION  X(N), Y(N)

C
C     PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER)
C              THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X
C              AND PUTS THE RESULTING N SORTED VALUES INTO THE
C              SINGLE PRECISION VECTOR Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE SORTED.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
C                                INTO WHICH THE SORTED DATA VALUES
C                                FROM X WILL BE PLACED.
C     OUTPUT--THE SINGLE PRECISION VECTOR Y
C             CONTAINING THE SORTED
C             (IN ASCENDING ORDER) VALUES
C             OF THE SINGLE PRECISION VECTOR X.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU
C                   (DEFINED AND USED INTERNALLY WITHIN
C                   THIS SUBROUTINE) DICTATE THE MAXIMUM
C                   ALLOWABLE VALUE OF N FOR THIS SUBROUTINE.
C                   IF IL AND IU EACH HAVE DIMENSION K,
C                   THEN N MAY NOT EXCEED 2**(K+1) - 1.
C                   FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS
C                   OF IL AND IU HAVE BEEN SET TO 36,
C                   THUS THE MAXIMUM ALLOWABLE VALUE OF N IS
C                   APPROXIMATELY 137 BILLION.
C                   SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE
C                   VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS,
C                   AND SINCE A SORT OF 137 BILLION ELEMENTS
C                   IS PRESENTLY IMPRACTICAL AND UNLIKELY,
C                   THEN THERE IS NO PRACTICAL RESTRICTION
C                   ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE.
C                   (IN LIGHT OF THE ABOVE, NO CHECK OF THE
C                   UPPER LIMIT OF N HAS BEEN INCORPORATED
C                   INTO THIS SUBROUTINE.)
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X
C              WILL BE PLACED IN THE FIRST POSITION
C              OF THE VECTOR Y,
C              THE SECOND SMALLEST ELEMENT IN THE VECTOR X
C              WILL BE PLACED IN THE SECOND POSITION
C              OF THE VECTOR Y, ETC.
C     COMMENT--THE INPUT VECTOR X REMAINS UNALTERED.
C     COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE',
C              THIS IS DONE BY HAVING THE SAME
C              OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE.
C              THUS, FOR EXAMPLE, THE CALLING SEQUENCE
C              CALL SORT(X,N,X)
C              IS ALLOWABLE AND WILL RESULT IN
C              THE DESIRED 'IN-PLACE' SORT.
C     COMMENT--THE SORTING ALGORTHM USED HEREIN
C              IS THE BINARY SORT.
C              THIS ALGORTHIM IS EXTREMELY FAST AS THE
C              FOLLOWING TIME TRIALS INDICATE.
C              THESE TIME TRIALS WERE CARRIED OUT ON THE
C              UNIVAC 1108 EXEC 8 SYSTEM AT NBS
C              IN AUGUST OF 1974.
C              BY WAY OF COMPARISON, THE TIME TRIAL VALUES
C              FOR THE EASY-TO-PROGRAM BUT EXTREMELY
C              INEFFICIENT BUBBLE SORT ALGORITHM HAVE
C              ALSO BEEN INCLUDED--
C              NUMBER OF RANDOM        BINARY SORT       BUBBLE SORT
C               NUMBERS SORTED
C                N = 10                 .002 SEC          .002 SEC
C                N = 100                .011 SEC          .045 SEC
C                N = 1000               .141 SEC         4.332 SEC
C                N = 3000               .476 SEC        37.683 SEC
C                N = 10000             1.887 SEC      NOT COMPUTED
C     REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM
C                 BY RICHARD C. SINGLETON).
C               --CACM JANUARY 1970, PAGE 54.
C               --CACM OCTOBER 1970, PAGE 624.
C               --JACM JANUARY 1961, PAGE 41.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-2315
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --NOVEMBER  1975.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION  HOLD
      DOUBLE PRECISION  AMED
      DOUBLE PRECISION  TT
      INTEGER  IU(36), IL(36)
C
      IPR = 6
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF (N .GE. 1) THEN
         IF (N .EQ. 1) GO TO 55
         HOLD = X(1)
         DO I = 2, N
            IF (X(I) .NE. HOLD) GO TO 90
         END DO
c c      WRITE (IPR, FMT=9) HOLD
         DO I = 1, N
            Y(I) = X(I)
         END DO
         RETURN
      ENDIF
c c   WRITE (IPR, FMT=15)
c c   WRITE (IPR, FMT=47) N
      RETURN
   55 CONTINUE
c c   WRITE (IPR, FMT=18)
      Y(1) = X(1)
      RETURN
   90 CONTINUE
c c 9 FORMAT(1H ,
c c  1108H***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT (A VECTO
c c  2R) TO THE SORT   SUBROUTINE HAS ALL ELEMENTS =,D15.8,6H *****)
c c15 FORMAT(1H ,
c c  191H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE SORT   SUBR
c c  2OUTINE IS NON-POSITIVE *****)
c c18 FORMAT(1H ,
c c  1100H***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE S
c c  2ORT   SUBROUTINE HAS THE VALUE 1 *****)
c c47 FORMAT(1H ,35H***** THE VALUE OF THE ARGUMENT IS ,I8,6H *****)
C
C-----START POINT-----------------------------------------------------
C
C     COPY THE VECTOR X INTO THE VECTOR Y
      DO I = 1, N
         Y(I) = X(I)
      END DO
C
C     CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED
C
      NM1 = N - 1
      DO I = 1, NM1
         IP1 = I + 1
         IF (Y(I) .GT. Y(IP1)) GO TO 250
      END DO
      RETURN
  250 CONTINUE
      M = 1
      I = 1
      J = N
  305 CONTINUE
      IF (I .GE. J) GO TO 370
  310 CONTINUE
      K = I
      MID = (I + J)/2
      AMED = Y(MID)
      IF (Y(I) .GT. AMED) THEN
         Y(MID) = Y(I)
         Y(I) = AMED
         AMED = Y(MID)
      ENDIF
      L = J
      IF (Y(J) .GE. AMED) GO TO 340
      Y(MID) = Y(J)
      Y(J) = AMED
      AMED = Y(MID)
      IF (Y(I) .LE. AMED) GO TO 340
      Y(MID) = Y(I)
      Y(I) = AMED
      AMED = Y(MID)
      GO TO 340
  330 CONTINUE
      Y(L) = Y(K)
      Y(K) = TT
  340 CONTINUE
      L = L - 1
      IF (Y(L) .GT. AMED) GO TO 340
      TT = Y(L)
  350 CONTINUE
      K = K + 1
      IF (Y(K) .LT. AMED) GO TO 350
      IF (K .LE. L) GO TO 330
      LMI = L - I
      JMK = J - K
      IF (LMI .GT. JMK) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M + 1
         GO TO 380
      ENDIF
      IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 380
  370 CONTINUE
      M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
  380 CONTINUE
      JMI = J - I
      IF (JMI .GE. 11) GO TO 310
      IF (I .EQ. 1) GO TO 305
      I = I - 1
  390 CONTINUE
      I = I + 1
      IF (I .EQ. J) GO TO 370
      AMED = Y(I+1)
      IF (Y(I) .LE. AMED) GO TO 390
      K = I
  395 CONTINUE
      Y(K+1) = Y(K)
      K = K - 1
      IF (AMED .LT. Y(K)) GO TO 395
      Y(K+1) = AMED
      GO TO 390
      END


module rp1_advection
  use iso_c_binding
  implicit none

  type :: advection_context
     real(c_double) :: u
  end type advection_context

contains

  subroutine new(u, context) bind(C, name='rp1_advection_new')
    real(c_double), intent(in)       :: u
    type(c_ptr), intent(out)         :: context

    type(advection_context), pointer :: param

    allocate(param)
    param%u = u
    context = c_loc(param)
  end subroutine new

  subroutine delete(context) bind(C, name='rp1_advection_delete')
    type(c_ptr), intent(in)          :: context

    type(advection_context), pointer :: param

    call c_f_pointer(context, param)
    deallocate(param)
  end subroutine delete

  ! only 1 wave, no need for an mwave parameter
  ! only 1 equation, no need for an meqn parameter

  subroutine advection(mx, mbc, ql, qr, s, wave, amdq, apdq, context) &
       bind(C, name='rp1_advection_c')
    ! C interfacable version of Riemann solver for advection
    !
    !
    ! inputs
    ! * ql  - data at left edge of each cell
    ! * qr  - data at right edge of each cell
    ! * mx  - number of physical grid points
    ! * mbc - number of boundary layer grid points
    ! outputs
    ! * s
    ! * wave
    ! * amdq
    ! * apdq
    ! context
    ! * u - constant advection speed
    !

    ! Solve Riemann problems for the 1D advection equation q_t + u*q_x = 0.
    ! for constant advection velocity u, passed in common block.
    !
    ! The advection speed u is passed in the derived type solver data
    ! On input, ql contains the state vector at the left edge of each cell
    !           qr contains the state vector at the right edge of each cell
    ! On output, wave contains the waves,
    !            s the speeds,
    !            amdq the  left-going flux difference  A^- \Delta q
    !            apdq the right-going flux difference  A^+ \Delta q
    !
    ! Note that the i'th Riemann problem has left state qr(i-1,:) and
    !                                    right state ql(i,:) From the
    !                                    basic clawpack routine step1, rp
    !                                    is called with ql = qr = q.

    integer(c_int), intent(in), value :: mx, mbc
    real(c_double), intent(in) :: &
         ql(1, 1-mbc:mx+mbc), &
         qr(1, 1-mbc:mx+mbc)
    type(c_ptr), intent(in), value :: context

    real(c_double), intent(out) :: &
         s(1, 1-mbc:mx+mbc), &
         wave(1, 1, 1-mbc:mx+mbc), &
         apdq(1, 1-mbc:mx+mbc), &
         amdq(1, 1-mbc:mx+mbc)

    type(advection_context), pointer :: param
    real(c_double) :: u
    integer :: i

    call c_f_pointer(context, param)
    u = param%u

    do i=2-mbc,mx+mbc
       ! Compute the wave
       wave(1,1,i) = ql(1,i) - qr(1,i-1)

       ! Speeds are all the same
       s(1,i) = u

       ! Set fluctuations
       amdq(1,i) = dmin1(u, 0.d0) * wave(1,1,i)
       apdq(1,i) = dmax1(u, 0.d0) * wave(1,1,i)
    end do

  end subroutine advection

end module rp1_advection


module calculator
  implicit none
contains

  subroutine add(a, b, output)
    !! A subroutine to add two integers
    integer, intent (in) :: a, b
    integer, intent (out) :: output
    output = a + b
  end subroutine add

  subroutine multiply(a, b, output)
    !! A subroutine to multiply two integers
    integer, intent (in) :: a, b
    integer, intent (out) :: output
    output = a * b
  end subroutine multiply

end module calculator


      subroutine ludcmp(a,ia,iabase,n,indx,indbas,d,vv,iptty,ierr)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  Given an n*n matrix a, with physical dimension np, this routine
CD1  replaces it by the lu decomposition of a rowwise decomposition
CD1  of itself.  a and n are input.  a is output with l below the
CD1  diagonal and u on and above the diagonal.  indx is an output
CD1  vector which records the row permutation effected by the
CD1  partial pivotting.  d is output as +/- 1 depending on whether
CD1  the number of row interchanges was even or odd, respectively.
CD1  this routine is used in conjunction with lubksb to solve
CD1  linear equations or invert a matrix.  vv is used for working
CD1  space.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/ludcmp.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:28   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:10:02   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:10:52   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:25:16   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:05:00   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:43:26 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.4   Fri Feb 16 10:04:28 1996   zvd
CD2 Modified requirement.
CD2
CD2    Rev 1.3   Wed Jan 10 14:28:38 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.2   06/20/94 11:13:22   zvd
CD2 Added ierr unit number for error output.
CD2
CD2    Rev 1.1   03/18/94 16:07:10   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:25:30   pvcs
CD2 original version in process of being certified
CD2
C**********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  Not Applicable. This is a general utility routine used in the code as
CD3  needed for solving a matrix.
CD3
C**********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4  these two routines for lu decomposition and back-substitution,
CD4  with row pivotting are from
CD4  'numerical recipes the art of scientific computing' by
CD4  w.h.press, b.p.flannery, s.a.teukolsky and w.t.vetterling
CD4  they will be used in george's routines, for inverting the
CD4  small 'block' matricies.
CD4
CD4  Given an n*n matrix a, with physical dimension np, this routine
CD4  replaces it by the lu decomposition of a rowwise decomposition
CD4  of itself.  a and n are input.  a is output with l below the
CD4  diagonal and u on and above the diagonal.  indx is an output
CD4  vector which records the row permutation effected by the
CD4  partial pivotting.  d is output as +/- 1 depending on whether
CD4  the number of row interchanges was even or odd, respectively.
CD4  this routine is used in conjunction with lubksb to solve
CD4  linear equations or invert a matrix.  vv is used for working
CD4  space.
CD4
C***********************************************************************
c       8 august 1988.  modified to reflect the way that the coefficient
c       matrix is stored for george's routines.  it is stored in
c       form in a 1-d array.  iabase is a base position in a for the
c       sub-matrix of interest.  ia contains positions relative to this
c       base.  n is the number of equations in the sub-matrix.  so that
c       coefficient (i,j) is in a(iabase+ia((i-1)*n+j)).
C***********************************************************************

      implicit none
      integer i, imax, j, k
      integer ia(*), iabase, indx(*), indbas, iptty, ierr, n
      real*8  a(*), d, vv(*)
      real*8  aamax, dum, sum

 999  format ('singular matrix in ludcmp')
      d=1.
      do i=1,n
         aamax=0.
         do j=1,n
            if (abs(a(iabase+ia((i-1)*n+j))).gt.aamax)
     &           aamax=abs(a(iabase+ia((i-1)*n+j)))
         enddo
         if (aamax.eq.0.) then
            write (ierr, 999)
            if (iptty .ne. 0) write(iptty, 999)
            stop
         endif
         vv(i)=1./aamax
      enddo
      do j=1,n
         if (j.gt.1) then
            do i=1,j-1
               sum=a(iabase+ia((i-1)*n+j))
               if (i.gt.1) then
                  do k=1,i-1
                     sum=sum-a(iabase+ia((i-1)*n+k))
     &                    *a(iabase+ia((k-1)*n+j))
                  enddo
                  a(iabase+ia((i-1)*n+j))=sum
               endif
            enddo
         endif
         aamax=0.
         do i=j,n
            sum=a(iabase+ia((i-1)*n+j))
            if (j.gt.1) then
               do k=1,j-1
                  sum=sum-a(iabase+ia((i-1)*n+k))*
     &                 a(iabase+ia((k-1)*n+j))
               enddo
               a(iabase+ia((i-1)*n+j))=sum
            endif
            dum=vv(i)*abs(sum)
            if (dum.ge.aamax) then
               imax=i
               aamax=dum
            endif
         enddo
         if (j.ne.imax) then
            do k=1,n
               dum=a(iabase+ia((imax-1)*n+k))
               a(iabase+ia((imax-1)*n+k))=a(iabase+ia((j-1)*n+k))
               a(iabase+ia((j-1)*n+k))=dum
            enddo
            d=-d
            vv(imax)=vv(j)
         endif
         indx(indbas+j-1)=imax
         if (j.ne.n) then
            if (a(iabase+ia((j-1)*n+j)).eq.0.) then
               write (ierr, 999)
               if (iptty .ne. 0) write(iptty, 999)
               stop
            endif
            dum=1./a(iabase+ia((j-1)*n+j))
            do i=j+1,n
               a(iabase+ia((i-1)*n+j))=a(iabase+ia((i-1)*n+j))*dum
            enddo
         endif
      enddo
      if (a(iabase+ia(n*n)).eq.0.) then
         write (ierr, 999)
         if (iptty .ne. 0) write(iptty, 999)
         stop
      endif

      return
      end


c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   ikeda.f
c   iterate Ikeda map
c   author Thomas Schreiber (1998)
c===========================================================================
      double precision xo, yo, xn, yn, a, b, c, s, cs, ss
      character*72 fout
      data a/0.4/,b/6.0/,c/0.9/,
     .   ntrans/10000/,xo/.68587/,yo/.65876/
      data iverb/1/

      call whatido("Ikeda map",iverb)
      nmax=imust('l')
      ntrans=ican('x',ntrans)
      a=fcan('A',real(a))
      b=fcan('B',real(b))
      c=fcan('C',real(c))
      xo=fcan('X',real(xo))
      yo=fcan('Y',real(yo))
      isout=igetout(fout,iverb)

      if(isout.eq.1) fout="ikeda.dat"
      call outfile(fout,iunit,iverb)
      n=-ntrans
 1    n=n+1
      s=a-b/(1.+xo**2+yo**2)
      cs=cos(s)
      ss=sin(s)
      xn=1.+c*(xo*cs-yo*ss)
      yn=c*(xo*ss+yo*cs)
      xo=xn
      yo=yn
      if(n.lt.1) goto 1
      write(iunit,*) real(xn), real(yn)
      if(nmax.eq.0.or.n.lt.nmax) goto 1
      end

      subroutine usage()
c usage message

      call whatineed(
     .   "-l# [-A# -B# -C# -R# -I# -o outfile -x# -V# -h]")
      call popt("l","number of points x,y (l=0: infinite)")
      call popt("A","parameter a (0.4)")
      call popt("B","parameter b (6.0)")
      call popt("C","parameter c (0.9)")
      call popt("R","initial Re(z)")
      call popt("I","initial Im(z)")
      call popt("x","number of transients discarded (10000)")
      call pout("ikeda.dat")
      call pall()
      stop
      end


        subroutine surfim (yy, dlteta, psi)
c
      common/surf/ro,costh,sinth,rnumb,gamma,epq
c
      if (ro.le.0) then
        srag = 0
        detar = costh
        detai = sinth
      else
        srag1 = yy / rnumb
        srag2 = alog(2 * yy / gamma)
        srag = srag1 * srag2
        sraq = srag * srag
        dnm = epq + sraq + 2 * srag * sinth
        etanr = sraq * costh
        etani = epq * srag + sraq * sinth
        etar = etanr / dnm
        etai = etani / dnm
        detar = costh - etar
        detai = sinth - etai
      endif
      dlteta = sqrt(detar**2 + detai**2)
      psi = atan(detai / detar)
      return
      end
c---------------------------------------------------------------


program test_dimred

  ! This program demonstrates how to:
  !
  ! 1. Simulate ground-based SWIR measurement (spectrum)
  ! 2. Retrieve ch4 profile from the measurement using
  !    dimension reduction approach and Levenberg-Marquardt
  !    optimization
  !
  ! Simo Tukiainen, 2015

  use global_variables
  use math, only : Bvgd, Levmar
  use forward_model, only : Init_fmodel, Simulate_meas
  use retrieval
  implicit none

  type(obs) :: data
  real(DP), dimension(:), allocatable :: air, dens, alt, wn, t, q, theta, prior, profile, r
  real(DP), dimension(:,:), allocatable :: cs, p, c1, c2, c, cerr
  character(len=*), parameter :: CSFILE = "abs_coef.dat"
  character(len=*), parameter :: ATMOSFILE = "atmos.dat"
  integer :: nalt, d, nobs
  real(DP) :: noise, rss

  ! read cross sections and true/prior profiles
  call Init_fmodel(dens, prior, air, alt, cs, wn, CSFILE, ATMOSFILE)

  nalt = size(alt) ! number of altitudes
  nobs = size(wn) ! number of wavelengths

  ! simulate measurement
  write(*,*)
  write(*,*) 'Give std of noise. Signal is between 0-1 and the noise is additive ~ N(0,std^2)'
  write(*,*) 'Common value is e.g. 0.001 but you can try different values..'
  read(*,*) noise
  t = Simulate_meas(cs, dens, noise)

  ! Experimental prior covariance with two exponential components
  C1 = Bvgd(alt, 25.0_DP, 25.0_DP, 5.0_DP, 5.0_DP, 0.5_DP) * 1e7
  C2 = Bvgd(alt, 5.0_DP, 5.0_DP, 15.0_DP, 15.0_DP, 0.8_DP) * 5e6
  C = C1 + C2

  ! Its reduction
  write(*,*) ' Give number of principal components (~2-5 is good)'
  do
     read(*,*) d
     if (d < 0) then
        write(*,*) ' It can''t be negative! Try again...'
     elseif (d > nalt) then
        write(*,*) ' Too many! Try again...'
     else
        exit
     end if
  end do
  allocate(p(nalt, d), q(nalt))
  call Reduce_dim(c, d, p, q)

  ! Initial values for parameters
  allocate(theta(d))
  theta = 0.0

  ! Save needed variables to the data-structure
  data%t = t
  data%p = p
  data%d = d
  data%noise = noise
  data%cs = cs
  data%prior = prior
  data%air = air
  data%nobs = size(t)
  data%nprior = size(prior)

  ! Retrieve parameters
  allocate(r(nobs+d))
  call Levmar(resfun, jacfun, theta, cerr, r, rss, data)

  ! Inverted profile
  profile = Redu2full(P, prior, air, theta)

  ! Save results
  call Write_data(P,       'output/P.dat')
  call Write_data(profile, 'output/profile.dat')
  call Write_data(t,       'output/t.dat')
  call Write_data(dens,    'output/dens.dat')
  call Write_data(prior,   'output/prior.dat')
  call Write_data(air,     'output/air.dat')
  call Write_data(alt,     'output/alt.dat')
  call Write_data(r,       'output/r.dat')
  call Write_data(wn,      'output/wn.dat')
  call Write_data(d,       'output/d.dat')
  call Write_data(C,       'output/C.dat')
  call Write_data(q,       'output/q.dat')

end program test_dimred


c=======================================================================
c
c     subroutine APTCST
c
c     APT (Arbitrage Pricing Theory) model with alpha/beta constraints
c
c            Y = alpha + X*beta'
c
c     where Y is the matrix (n*p) of asset(s) value(s), X the matrix (n*q)
c     of factor(s) value(s) and beta=[beta(1), ...,beta(q)]
c
c     Min[ theta'*(F'F)*theta - 2*theta'*(F'*Y) ],
c     where F = [1., X] and theta = [alpha, beta']
c      s.t.
c     C*theta <= b             (linear constraints)
c     Cinf <= theta <= Csup    (lower/upper bounds)
c
c-----------------------------------------------------------------------
      SUBROUTINE aptcst ( n, q, Y, X,
     &                    neq, nin, ccst, bcst, cinf, csup,
     &                    iwork, dwork,
     &                    alpha, beta, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of value(s) (n > 0)                 integer
c            q      : number of factors  (q > 0)                 integer
c            Y      : asset(s) values (n)                         double
c            X      : factor(s) values (n*q)                      double
c            neq    : number equality constraints                integer
c            nin    : number inequality constraints              integer
c            ccst   : matrix of constraints ((q+1)*(neq+nin))     double
c            bcst   : vector initial of constraints (neq+nin)     double
c            cinf   : lower bound (q+1)                           double
c            csup   : upper bound (q+1)                           double
c
c     WORKSPACE
c            iwork  : 3*p + 2*nin + neq + 1                      integer
c            dwork  : p*(2*p + n + 9) + 3*nin + neq               double
c                     with p = q + 1
c
c     OUTPUT
c            alpha  : alpha coefficient(s)                        double
c            beta   : beta coefficient(s) (q)                     double
c            info   : diagnostic argument                        integer
c
c     CALL
c            IVX    : initialization at a scalar of a vector
c            YV     : copy a vector in a vector
c            PRMM   : M'*M -> Matrix
c            PMTV   : M'*V -> Vector
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, q, info, neq, nin
      DOUBLE PRECISION alpha
      DOUBLE PRECISION Y(*), X(*), cinf(*), csup(*), ccst(q,*), bcst(*),
     &                 beta(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, p, piw, pf, pdqua, pdlin, pdw, pdlagr, pdxopt
      DOUBLE PRECISION DUN
      PARAMETER ( DUN = 1.E0 )
c
c     external subroutines
      EXTERNAL PRMM, PMTV, YV, IVX, qp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      p = q + 1
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw  = 1
c     piw  : pointer for internal workspaces of QUAPRO
c             needs( 3*p + 2*nin + neq + 1 )
c
c     Total size of iwork array = 3*p + 2*nin + neq + 1
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pf     = 1
c     pf    : pointer for matrix F, so ( n*p ) more
      pdqua  = pf + ( n*p )
c     pdqua : pointer for quadratic part matrix( p*p )
      pdlin  = pdqua + ( p*p )
c     pdlin : pointer for linear part, so ( p ) more
      pdw    = pdlin + ( p )
c     pdw   : pointer for QUAPRO, so (p*p + 6*p + 2*nin) more
      pdlagr = pdw + ( p*p + 6*p + 2*nin )
c     pdlagr: pointer for QUAPRO Lagrange multipliers, so (p+nin+neq) more
      pdxopt = pdlagr + ( p + nin + neq )
c     pdxopt: pointer for QUAPRO optimal points, ( p )
c
c     Total size of dwork array = n*p
c                               + p*p
c                               + p
c                               + p*p + 6*p + 2*nin
c                               + p + nin + neq
c                               + p
c                              =  p*(2*p + n + 9) + 3*nin + neq
c
c-----------------------------------------------------------------------
c
c     construction of matrix F = [1.0, X]
      CALL IVX ( n, dwork(pf), DUN )
      CALL YV ( q*n, X, dwork(pf + n) )
c
c     quadratic part, F'*F
      CALL PRMM ( n, p, dwork(pf), dwork(pdqua) )
c
c     test matrix condition number (Lmax/Lmin)

c
c     applied SDLS correction if bad condition number

c
c     linear part, -2*(F'*Y)
      CALL PMTV ( n, p, dwork(pf), Y, dwork(pdlin) )
      DO i = 1,p
        dwork(pdlin + i - 1) = -2.0*dwork(pdlin + i - 1)
      ENDDO
c
c     quadratic solver: Min[ theta'*(F'F)*theta - 2*theta'*(F'*Y) ]
      CALL qp ( p, dwork(pdqua), dwork(pdlin), neq, nin, ccst,
     &          bcst, cinf, csup,
     &          iwork(piw), dwork(pdw), dwork(pdlagr),dwork(pdxopt),
     &          info )
c
c     coefficients alpha and beta
      alpha = dwork(pdxopt)
      DO i = 1,q
        beta(i) = dwork(pdxopt + i)
      ENDDO
c
      RETURN
      END


C    @(#)opieqiv.f	20.4 2/13/96
      subroutine opieqiv (p, y, error)
      complex y(2,2)
      integer p, error
c
c     This subroutine computes the 2-port admittance matrix y
c     for obrnch(1,aq) from the ALTERNATE BASE CASE IN RESIDENCE!
c
      include 'ipfinc/parametr.inc'

      include 'ipfinc/alt_case.inc'
      include 'ipfinc/prt.inc'

c     set up record type code parameters...
      include 'ipfinc/brtype.inc'

      common /is_batch / is_batch

      complex cx
      integer q, aq
      character xbuf * 120
c
      error = 0
      k1 = okx(p)
      k2 = oky(p)
      ltype = obrtype(p)
      q = obrnch_ptr(p)
      aq = iabs(q)

      if (ltype.eq.BRTYP_L .or. ltype.eq.BRTYP_T .or.
     &    ltype.eq.BRTYP_TP .or. ltype.eq.BRTYP_E) then
c
c        compute transfer impedance
c
         r=obrnch(5,aq)
         x=obrnch(6,aq)
         z=r**2 + x**2
         if (z .eq. 0.0) then
            write (errbuf(1),110)
  110       format(' Branch has zero transfer impedance.')
            errbuf(2) = ' '
            call bcdbrn(p,xbuf)
            write (errbuf(3), 120) xbuf(1:80)
  120       format(13x,'(',a80,')')
            if (is_batch .eq. 0) then
               call prterx ('E',3)
            else
               call prterx ('F',3)
            endif
            error = 1
            z=1.0
         endif

         if (ltype .eq. BRTYP_L) then
c
c           "L" branch
c
            y(1,2)=-cmplx (r/z, -x/z)
            y(2,1) = y(1,2)
            y(1,1)=cmplx (obrnch(7,aq),obrnch(8,aq))-y(1,2)
            y(2,2)=y(1,1)

         else if (ltype .eq. BRTYP_T) then
c
c           "T" branch
c
            if (q .gt. 0) then
               tk=obrnch(9,aq)/oldbase(k1)
               tm=obrnch(10,aq)/oldbase(k2)
            else
               tk=obrnch(10,aq)/oldbase(k1)
               tm=obrnch(9,aq)/oldbase(k2)
            endif
            if (amax1(tk,tm).ge.1.40 .or. amin1(tk,tm).le.0.60) then
               if (q .gt. 0) then
                  tk=obrnch(10,aq)/oldbase(k1)
                  tm=obrnch(9,aq)/oldbase(k2)
               else
                  tk=obrnch(9,aq)/oldbase(k1)
                  tm=obrnch(10,aq)/oldbase(k2)
               endif
               if (amax1(tk,tm).lt.1.40 .and. amin1(tk,tm).gt.0.60)
     &            then
                  write(errbuf(1),130)
  130             format(' Backwards transformer taps are reversed.')
                  errbuf(2) = ' '
                  call bcdbrn(p,xbuf)
                  write (errbuf(3),120) xbuf(1:80)
                  temp = obrnch(9,aq)
                  obrnch(9,aq) = obrnch(10,aq)
                  obrnch(10,aq) = temp
                  call bcdbrn(p,xbuf)
                  write (errbuf(4),120) xbuf(1:80)
                  call prterx ('W',4)
               else
                  write (errbuf(1),140)
  140             format(' Transformer taps are beyond 40% of base kv.')
                  errbuf(2) = ' '
                  call bcdbrn(p,xbuf)
                  write (errbuf(3),120) xbuf(1:80)
                  if (is_batch .eq. 0) then
                     call prterx ('E',3)
                  else
                     call prterx ('F',3)
                  endif
                  if (tk.eq.0.0) tk=1.0
                  if (tm.eq.0.0) tm=1.0
               endif
            endif
            tkm = 1.0 / (tk*tm)
            y(1,1) = cmplx (0.5*tkm*obrnch(7,aq),
     &                     -0.5*tkm*abs(obrnch(8,aq)))
            y(2,2) = y(1,1)
            y(1,2) = -cmplx(r/(z*tk*tm),-x/(z*tk*tm))
            y(2,1) = y(1,2)
            y(1,1) = y(1,1) + cmplx (r/(z*tk*tk),-x/(z*tk*tk))
            y(2,2) = y(2,2) + cmplx (r/(z*tm*tm), -x/(z*tm*tm))

         else if (ltype .eq. BRTYP_TP) then
c
c           "TP" branch
c
            if (q .gt. 0) then
               tk=obrnch(9,aq)
               tm=obrnch(10,aq)/oldbase(k2)
            else
               tk=-obrnch(9,aq)
               tm=obrnch(10,aq)/oldbase(k1)
            endif
            if (tm .eq. 0.0) tm=1.0
            if (tm .ge. 1.40 .or. tm .le. 0.60) then
               write (errbuf(1),150)
  150          format(' Phase shifter tap2 is beyond 40% of base kv.')
               errbuf(2) = ' '
               call bcdbrn(p,xbuf)
               write (errbuf(3),120) xbuf(1:80)
               call prterx ('W',3)
               tm=1.0
            endif
            if (tk .ge. 120.1 .or. tk .le. -120.1) then
               write (errbuf(1), 160)
  160          format(' Phase shifter has excessive angle ',
     &                '(> 120 degrees)')
               errbuf(2) = ' '
               call bcdbrn(p,xbuf)
               write (errbuf(3),120) xbuf(1:80)
               call prterx ('W',3)
            endif
            angle=0.0174532925*tk
            y(1,2)=cmplx(0.5*obrnch(7,aq),-0.5*abs(obrnch(8,aq)))
            y(1,1)=y(1,2)+cmplx(r/z,-x/z)
            y(2,2)=y(1,2)+cmplx(r/z,-x/z)/cmplx(tm**2,0.0)
            y(1,2)=-cmplx(cos(angle),
     &                    sin(angle))*cmplx(r/(z*tm),-x/(z*tm))
            y(2,1)=-cmplx(cos(angle),
     &                   -sin(angle))*cmplx(r/(z*tm),-x/(z*tm))
            if (q .lt. 0) then
               cx=y(2,2)
               y(2,2)=y(1,1)
               y(1,1)=cx
            endif

         else
c
c           "E" branch
c
            y(1,2)= -cmplx (r/z, -x/z)
            y(2,1)=y(1,2)
            if (q .gt. 0) then
               y(1,1)=cmplx(obrnch(7,aq),obrnch(8,aq))-y(1,2)
               y(2,2)=cmplx(obrnch(9,aq),obrnch(10,aq))-y(2,1)
            else
               y(2,2)=cmplx(obrnch(7,aq),obrnch(8,aq))-y(2,1)
               y(1,1)=cmplx(obrnch(9,aq),obrnch(10,aq))-y(1,2)
            endif

         endif

      else if (ltype.eq.BRTYP_PEQ) then
c
c        "pi-equivalent" branch
c
         if (q .gt. 0) then
            y(1,1) = cmplx(obrnch(4,aq),obrnch(5,aq))
            y(1,2) = cmplx(obrnch(6,aq),obrnch(7,aq))
            y(2,1) = cmplx(obrnch(8,aq),obrnch(9,aq))
            y(2,2) = cmplx(obrnch(10,aq),obrnch(11,aq))
         else
            y(2,2) = cmplx(obrnch(4,aq),obrnch(5,aq))
            y(2,1) = cmplx(obrnch(6,aq),obrnch(7,aq))
            y(1,2) = cmplx(obrnch(8,aq),obrnch(9,aq))
            y(1,1) = cmplx(obrnch(10,aq),obrnch(11,aq))
         endif

      else
c
c        error-illegal branch type calling "pieqiv"
c
         write (errbuf(1), 170)
  170    format(' Illegal branch type processed by "PIEQIV"')
         errbuf(2) = ' '
         call bcdbrn(p,xbuf)
         write (errbuf(3),120) xbuf(1:80)
         call prterx ('W',3)
         error = 1
      endif

      return
      end


      subroutine fan2(x1,y1,x2,y2,x3,y3,x4,y4)
C**     for     h-10/mt           es-1022
C... to draw a fan shade by the coordinate value of four vertices of
C     x1,y1 ...
C     x2,y2   ,
C             .coordinate value of four vertices forming a fan shade.
C     x3,y3   ,
C     x4,y4 ...
C ********************************************************************
      a=x1*(y2-y3)+y1*(x3-x2)+x2*y3-x3*y2
      if(a.le.1.e-6)goto 50
       if(x4-x1) 200,100,200
C... x0,y0 coordinates of the circular arc.
  50   x0=(x2+x1)/2.
       y0=(y2+y1)/2.
       goto 500
C ********************************************************************
 100   x0=x1
       y0=(y3-y2)/(x3-x2)*(x0-x2)+y2
       goto 500
 200   if(x3-x2) 400,300,400
 300  x0=x2
       y0=(y4-y1)/(x4-x1)*(x0-x1)+y1
       goto 500
 400   x0=((y2-y1)+(y4-y1)/(x4-x1)*x1-(y3-y2)/(x3-x2)*x2)/
     1     ((y4-y1)/(x4-x1)-(y3-y2)/(x3-x2))
       y0=(y4-y1)/(x4-x1)*(x0-x1)+y1
500    continue
      call arc1(x1,y1,x2,y2,x0,y0,2)
      call move(x2,y2,0)
      call move(x3,y3,1)
      call arc1(x3,y3,x4,y4,x0,y0,1)
      call move(x4,y4,0)
      call move(x1,y1,1)
      return
      end


program test_sto_be4

! The results here are to be compared against [1]:

! [1] Doll, J. D., & Reinhardt, W. P. (1972). Many-Body Green’s Functions for
! Finite, Nonuniform Systems: Applications to Closed Shell Atoms. The Journal
! of Chemical Physics, 57(3), 1169–1184. doi:10.1063/1.1678374

use types, only: dp
use sto, only: stoints2, get_basis2, slater_sto_gauss
use utils, only: assert
use radialscf, only: doscf, kinetic_energy, slater2int22, &
    get_basis, radialC2C, &
    radiallam2lam
use hfprint, only: printall, printlam
use mbpt, only: transform_int2, mbpt2, mbpt3, mbpt4, transform_int22
use gf2, only: find_poles, find_pole_diag, total_energy, plot_poles
use sorting, only: argsort
use scf, only: ijkl2intindex, ijkl2intindex2
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :), &
    slater2(:, :)
integer :: n, Z, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

Lmax = 2
allocate(nbfl(0:Lmax), nl(9, 0:Lmax), zl(9, 0:Lmax), focc(2, 0:Lmax))
nbfl = 0
focc = 0
focc(:2, 0) = [2, 2]
nbfl(0) = 5
nl(:5, 0) = [1, 1, 3, 2, 2]
zl(:5, 0) = [5.4297_dp, 2.9954_dp, 3.5810_dp, 1.1977_dp, 0.8923_dp]
nbfl(1) = 5
nl(:5, 1) = [2, 2, 4, 3, 3]
zl(:5, 1) = [5.6998_dp, 2.7850_dp, 4.1500_dp, 1.4387_dp, 0.9819_dp]
nbfl(2) = 2
nl(:2, 2) = [3, 3]
zl(:2, 2) = [1.2662_dp, 7.8314_dp]

Z = 4
tolE = 1e-10_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
call stoints2(Z, nbfl, nl, zl, S, T, V, slater2)
! We calculate the slater integrals using Gauss-Laguerre quadrature:
call slater_sto_gauss(nbfl, nl, zl, slater)
! This test is crucial: it tests that the numerical and analytical integrals
! agree to very high accuracy:
call assert(all(abs(slater2-slater) < 1e-10_dp))

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), H(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
Ekin = kinetic_energy(nbfl, P_, T)
!call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-14.57278856_dp)) < 1e-8_dp)
call assert(all(abs(lam(:2, 0) - [-4.73091975_dp, -0.30838296_dp]) < 1e-8_dp))
call assert(all(abs(lam(:2, 1) - [ 0.06564083_dp,  0.36350961_dp]) < 1e-8_dp))
call assert(all(abs(lam(:2, 2) - [ 0.58990240_dp, 25.29557149_dp]) < 1e-8_dp))

end program


!***********************************************************************
!                                                                      *
      SUBROUTINE SETCON
!                                                                      *
!   This  subprogram  sets the values of the fundamental and derived   *
!   physical constants, and other useful constants.                    *
!                                                                      *
!   Written by Farid A Parpia, at Oxford   Last updated: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:28   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEBUG_C
      USE DEF_C
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(DOUBLE), PARAMETER :: AINFCM = 0.52917721067D-08
      REAL(DOUBLE), PARAMETER :: ALFAI  = 137.035999139D00
      REAL(DOUBLE), PARAMETER :: CCMPS  = 2.99792458D10
      REAL(DOUBLE), PARAMETER :: EESU   = 4.803204673D-10
      REAL(DOUBLE), PARAMETER :: EMEG   = 9.10938356D-28
      REAL(DOUBLE), PARAMETER :: EMEAMU = 5.48579909070D-04
      REAL(DOUBLE), PARAMETER :: EMPAMU = 1.007276466879D00
      REAL(DOUBLE), PARAMETER :: HBARES = 1.054571800D-27
      REAL(DOUBLE), PARAMETER :: RINFEV = 13.605693009D00
      REAL(DOUBLE), PARAMETER :: RINFK  = 109737.31568508D00
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
!
!
!   Physical constants: see description below.
!
!
!   The values of the physical constants used here are taken from
!    (see setcon.f-????)
!   E R Cohen and B N Taylor, The 1986 Adjstment of the Fundamental
!   Physical Constants, Report of the CODATA Task Group on Funda-
!   mental COnstants, CODATA Bulletin 63, Pergamon, Elmsford, NY
!   (1986)
!
!      AINFCM: Bohr radius in cm
!      ALFAI : Inverse of the fine-structure constant
!      CCMPS : Speed of light in cm/s
!      EESU  : Electron charge in esu
!              conversion : EESU = EEC * 2997924580
!      EMEG  : Electron mass in g
!      EMEAMU: Electron mass in amu
!      EMPAMU: Proton mass in amu
!      HBARES: Rationalized Planck's constant in erg s
!      RINFEV: Rydberg in eV
!      RINFK : Rydberg in Kaysers
!
!   In the context of new results, Taylor warns that ... since the
!   output values of a least-squares adjustment are related in a
!   complex way and a change in the measured value of one constant
!   usually leads to corresponding changes in the adjusted values
!   of others, one must be cautious in carrying out calculations
!   using both the [above values] and the results of more recent
!   measurements.
!
!   Calculate constants for /DEF3/:
!
      EMPAM = EMPAMU
      RBCM = AINFCM
!
!   Calculate constants for  /DEF11/:
!
!      CVAC is the speed of light in the vacuum in atomic units
!      B1 is the conversion factor between the amu and the atomic
!         unit of mass
!
      CVAC = ALFAI
      AUMAMU = EMEAMU
!
!   Calculate constants for  /DEF10/:
!
!      AUCM converts au to kaysers assuming an infinitely-heavy
!           nucleus
!      AUEV Converst au to eV assuming an infinitely-heavy
!           nucleus
!      CCMS is the speed of light in the vacuum in centimetres
!            per second
!      FASI converts the Einstein A coefficients from atomic to SI
!            units
!      FBSI converts the Einstein B coefficients from atomic to SI
!            units
!
      AUCM = 2.0D00*RINFK
      AUEV = 2.0D00*RINFEV
      CCMS = CCMPS
      FASI = (EMEG/HBARES)*(EESU*EESU/HBARES)**2
      FBSI = (10.0D00*AINFCM**3/HBARES)*FASI
!
!   Calculate conversion factor for Fermis to Bohr radii
!
      FMTOAU = 1.0D-13/AINFCM
!
!   Calculate \pi from FORTRAN function
!
      PI = 4.0D00*ATAN(1.0D00)
!
!   Printouts
!
      IF (LDBPG(2)) WRITE (99, 300) AINFCM, ALFAI, CCMPS, EESU, EMEG, EMEAMU, &
         EMPAMU, HBARES, RINFEV, RINFK
!
      RETURN
!
  300 FORMAT(/,'From SUBROUTINE SETCON:'/,' AINFCM (Bohr radius in cm): ',0P,1D&
         16.9,','/,' ALFAI (Inverse of the fine-structure constant): ',3P,1D&
         16.9,','/,' CCMPS (Speed of light in cm/s): ',1P,1D15.8,','/,&
         ' EESU (Electron charge in esu): ',1P,1D15.8,','/,&
         ' EMEG (Electron mass in g): ',1P,1D14.7,','/,&
         ' EMEAMU (Electron mass in u): ',1P,1D16.9,','/,&
         ' EMPAMU (Proton mass in u): ',1P,1D16.9,','/,&
         ' HBARES (Rationalized Planck constant in erg s): ',1P,1D15.8,','/,&
         ' RINFEV (Rydberg in eV): ',2P,1D15.8,','/,&
         ' RINFK (Rydberg in Kaysers): ',6P,1D17.10,'.')
      RETURN
!
      END SUBROUTINE SETCON


*----------------------------------------------------------------------*
      pure integer function msgmdid2(occ_c,idxms_c,gam_c,nc,
     &                               occ_a,idxms_a,gam_a,na,nsym)
*----------------------------------------------------------------------*
*     calculate integer-valued ID of (ms,Gamma) distribution
*     version for condensed representation
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'

      integer, intent(in) ::
     &     nc, na, nsym,
     &     occ_c(nc), idxms_c(nc), gam_c(nc),
     &     occ_a(na), idxms_a(na), gam_a(na)

      integer ::
     &     ipatt, ibase, idx

      ipatt = 0
      ibase = 1
      do idx = 1, nc
        ipatt = ipatt + ((idxms_c(idx)-1)*nsym + gam_c(idx)-1)*ibase
        ibase = ibase * (occ_c(idx)+1)*nsym
      end do
      do idx = 1, na
        ipatt = ipatt + ((idxms_a(idx)-1)*nsym + gam_a(idx)-1)*ibase
        ibase = ibase * (occ_a(idx)+1)*nsym
      end do

      msgmdid2 = ipatt

      return
      end


subroutine interp2(n,m,theta1,theta2,fin,theta1p,theta2p,fout)
    use linear_interpolation_module
    use,intrinsic :: iso_fortran_env,only: wp => real64
    implicit none
    integer(kind = 8),intent(in) :: n,m
    real(kind = 8),dimension(1:n),intent(in) :: theta1,theta2
    real(kind = 8),dimension(1:m),intent(in) :: theta1p,theta2p
    real(kind = 8),dimension(1:n,1:n),intent(in) :: fin
    type(linear_interp_2d) :: s2
    integer :: iflag
    integer(kind = 8) :: i,j
    real(kind = 8),dimension(1:m,1:m),intent(out) :: fout
        call s2%initialize(theta1,theta2,fin,iflag)
        if (iflag .ne. 0) then
            print*,iflag
            call s2%destroy()
            return
        end if
        do j = 1,m
            do i = 1,m
                call s2%evaluate(theta1p(i),theta2p(j),fout(i,j))
            end do
        end do
        call s2%destroy()
    return
end subroutine interp2
subroutine gradient(n,dx,V,gradV)
    implicit none
    integer(kind = 8),intent(in) :: n
    real(kind = 8),intent(in) :: dx
    real(kind = 8),dimension(0:n+1,0:n+1),intent(in) :: V
    integer(kind = 8) :: i,j
    real(kind = 8),dimension(1:2,1:n,1:n),intent(out) :: gradV
        gradV = 0.0d0
        !$omp parallel do
        do j = 1,n
            do i = 1,n
                gradV(1,i,j) = (V(i+1,j) - V(i,j))/dx
                gradV(2,i,j) = (V(i,j+1) - V(i,j))/dx
            end do
        end do
        !$omp end parallel do
    return
end subroutine gradient
subroutine source(n,theta,shift,Vin,LV)
    implicit none
    integer(kind = 8),intent(in) :: n
    real(kind = 8),dimension(1:2,1:n),intent(in) :: theta
    real(kind = 8),dimension(1:4,1:2,1:n),intent(in) :: shift
    real(kind = 8),dimension(1:n,1:n),intent(in) :: Vin
    integer(kind = 8) :: i,j
    real(kind = 8),dimension(1:n) :: theta1,theta2,theta1p,theta2p
    real(kind = 8),dimension(1:4,1:n,1:n) :: interped
    real(kind = 8),dimension(1:n,1:n),intent(out) :: LV
    LV = 0.0d0
    interped = 0.0d0
    !$omp parallel do private(theta1,theta2,theta1p,theta2p)
    do i = 1,4
        theta1 = theta(1,:)
        theta2 = theta(2,:)
        theta1p = shift(i,1,:)
        theta2p = shift(i,2,:)
        call interp2(n,n,theta1,theta2,Vin,theta1p,theta2p,interped(i,:,:))
    end do
    !$omp end parallel do
    !$omp parallel do
    do j = 1,n
        do i = 1,n
            LV(i,j) = sum(interped(:,i,j)) - 4.0d0*Vin(i,j)
        end do
    end do
    !$omp end parallel do
    return
end subroutine source
subroutine hamiltonian(n,dx,theta,shift,V,f,lambda,Lag,H)
    implicit none
    integer(kind = 8) :: n
    real(kind = 8),intent(in) :: dx,lambda
    real(kind = 8), dimension(1:2,1:n),intent(in) :: theta
    real(kind = 8), dimension(1:4,1:2,1:n),intent(in) :: shift
    real(kind = 8),dimension(1:n,1:n),intent(in)  :: V,Lag
    real(kind = 8),dimension(1:2,1:n,1:n),intent(in) :: f
    integer(kind = 8) :: i,j
    real(kind = 8),dimension(0:n+1,0:n+1) :: Vb
    real(kind = 8),dimension(1:n,1:n) :: LV
    real(kind = 8) :: Lagij,LVij
    real(kind = 8),dimension(1:2) :: fij,gradVij
    real(kind = 8),dimension(1:2,1:n,1:n) :: gradV
    real(kind = 8),dimension(1:n,1:n),intent(out) :: H
        Vb = 0.0d0
        H = 0.0d0
        Lagij = 0.0d0
        fij = 0.0d0
        gradVij = 0.d0
        gradV = 0.0d0
        Vb(1:n,1:n) = V
        Vb(0,1:n) = V(n,:)
        Vb(n+1,1:n) = V(1,:)
        Vb(1:n,0) = V(:,n)
        Vb(1:n,n+1) = V(:,1)
        LV = 0.0d0
        call source(n, theta, shift, V, LV)
        call gradient(n,dx,Vb,gradV)
        !$omp parallel do private(Lagij,fij,gradVij)
        do j = 1,n
            do i = 1,n
                Lagij = Lag(i,j)
                LVij = LV(i,j)
                fij = f(:,i,j)
                gradVij = gradV(:,i,j)
                H(i,j) = Lagij + dot_product(fij,gradVij) - &
                .5d0*norm2(gradVij) + lambda*LVij
            end do
        end do
        !$omp end parallel do
    return
end subroutine hamiltonian

subroutine solve_HJB(n,T,dx,dt,VT,theta,shift,f,Lag,lambda,V)
    implicit none
    integer(kind = 8),intent(in) :: n,T
    real(kind = 8),intent(in) :: dx,dt,lambda
    real(kind = 8),dimension(1:n,1:n),intent(in) :: VT
    real(kind = 8),dimension(1:2,1:n),intent(in) :: theta
    real(kind = 8),dimension(1:4,1:2,1:n) :: shift
    real(kind = 8),dimension(1:2,1:n,1:n),intent(in) :: f
    real(kind = 8),dimension(1:n,1:n),intent(in) :: Lag
    integer(kind = 8) :: tau
    real(kind = 8),dimension(1:n,1:n) :: Vtau,V1,H1,H2
    real(kind = 8),dimension(1:n,1:n,1:T),intent(out) :: V
        V = 0.0d0
        Vtau = 0.0d0
        V1 = 0.0d0
        H1 = 0.0d0
        H2 = 0.0d0
        V(:,:,T) = VT
        do tau = T,2,-1
            Vtau = V(:,:,tau)
            call hamiltonian(n,dx,theta,shift,Vtau,f,lambda,Lag,H1)
            V1 = Vtau + dt*H1
            call hamiltonian(n,dx,theta,shift,V1,f,lambda,Lag,H2)
            V(:,:,tau-1) = .5d0*Vtau + .5d0*(V1 + dt*H2)
            ! if (modulo(tau, 1000) .eq. 0)  then
            !     print*, tau
            ! end if
        end do
    return
end subroutine solve_HJB


module m_unique_eigvec
   interface linear_independency
      module procedure linear_independency_cmplx, linear_independency_real
   end interface linear_independency
contains
   subroutine unique_eigvec(eigval, z, ierr)
      use omp_lib
      implicit none
      real(kind=8), intent(in) :: eigval(:)
      real(kind=8)             :: z(:,:)
      integer, intent(out)     :: ierr

      integer :: beg_group, end_group, n_g
      integer, allocatable :: groups(:)

      groups = make_groups(eigval)

      do n_g = 1, size(groups)
         beg_group = sum(groups(1:n_g-1)) + 1
         end_group = sum(groups(1:n_g))

         if(end_group <= size(z,2))then
            call unify_group_operator(beg_group, end_group, z, ierr)
         endif
      enddo
   end subroutine unique_eigvec

   subroutine unify_group_operator(beg_group, end_group, z, ierr)
      implicit none
      integer, intent(in)         :: beg_group, end_group
      real(kind=8), intent(inout) :: z(:,:)
      integer, intent(out)        :: ierr
      real(kind=8), allocatable   :: mtx(:,:), eigval(:), work(:), rq_mat(:,:), tau(:), Q(:,:), tmp(:,:)
      integer :: dim, lwork, info, i, j
      real(kind=8) :: work_size(1)
      real(kind=8), parameter :: zero = 0.0, one = 1.0

      dim = end_group - beg_group + 1
      allocate(rq_mat(dim, dim), tau(dim),Q(dim,dim))
      call make_rq_mat(z(:,beg_group:end_group), rq_mat, ierr)
      if(ierr /= 0) return

      rq_mat = transpose(rq_mat)

      call dgeqrfp(dim, dim, rq_mat, dim, tau, work_size, -1, info)
      if(info /= 0) then
         write (*,*) "Problem setting up dgeqrfp"
         ierr = 2
         return
      endif
      lwork = int(work_size(1))
      allocate(work(lwork))
      call dgeqrfp(dim, dim, rq_mat, dim, tau, work, lwork, info)
      if(info /= 0) then
         write (*,*) "Problem executing dgeqrfp"
         ierr = 4
         return
      endif
      deallocate(work)

      q = rq_mat

      do i =1,3
         do j=i,dim
            q(i,j) = 0.0
         enddo
      enddo

      call dorgqr(dim, dim, dim, Q, dim, tau, work_size, -1, info)
      if(info /= 0) then
         write (*,*) "Problem setting up dorgqr"
         ierr = 8
         return
      endif
      lwork = int(work_size(1))
      allocate(work(lwork))
      call dorgqr(dim, dim, dim, Q, dim, tau, work, lwork, info)
      if(info /= 0) then
         write (*,*) "Problem executing dorgqr"
         ierr = 16
         return
      endif

      tmp = z(:,beg_group:end_group)
      ! z(:,beg_group:end_group) = matmul(z(:,beg_group:end_group), q)
      call dgemm("N", "N", size(z,1), dim, dim, one, tmp, size(z,1), q, dim, zero, z(:,beg_group:end_group), size(z,1))
   end subroutine unify_group_operator

   function make_groups(eigval) result(groups)
      implicit none
      real(8), intent(in)  :: eigval(:)
      integer, allocatable :: groups(:)
      integer              :: color(size(eigval))

      integer :: i, beg, g_cnt, n_groups

      g_cnt = 1
      beg  = 1

      do while (beg <= size(eigval))
         i = beg
         do while (abs(eigval(i) - eigval(beg)) < 1e-8  )
            color(i) = g_cnt
            i = i + 1
            if(i > size(eigval)) exit
         enddo
         g_cnt = g_cnt + 1
         beg = i
      enddo

      n_groups = color(size(eigval))
      allocate(groups(n_groups))

      do i = 1,n_groups
         groups(i) = count(i == color)
      enddo
   end function make_groups

   subroutine make_rq_mat(eigvecs, rq_mat, ierr)
      implicit none
      real(kind=8), intent(in)                 :: eigvecs(:,:)
      real(kind=8), intent(inout), allocatable :: rq_mat(:,:)
      integer, intent(out) :: ierr
      integer :: n, i, j, best_j
      logical :: l_full_search
      real(kind=8) :: cutoff, lindep, best_lindep
      real(kind=8), allocatable :: tmp(:,:)

      n = size(eigvecs,2)
      cutoff = 1e-6 * sqrt(1.0/size(eigvecs,1))
      if(allocated(rq_mat)) deallocate(rq_mat)
      allocate(rq_mat(n,n), tmp(n,n))

      rq_mat = 0.0
      lindep = 0.0
      j = 0
      do i = 1,n
         if(allocated(tmp)) deallocate(tmp)
         allocate(tmp(i,n))
         tmp = 0.0
         lindep = 0.0
         l_full_search = .False.

         best_j = 0
         best_lindep = 0.0
         do while(lindep < cutoff)
            j = j + 1
            if(j > size(eigvecs,1)) then
               rq_mat(i,:) = eigvecs(best_j,:)
               if(l_full_search) then
                  exit
               else
                  j = 1
                  l_full_search = .True.
               endif
            endif

            rq_mat(i,:) = eigvecs(j,:)
            tmp = rq_mat(1:i,:)
            lindep = linear_independency(tmp)
            if(lindep > best_lindep) then
               best_j = j
               best_lindep = lindep
            endif
         enddo
      enddo
      if(lindep < 1e-9) then
         write (*,*) "RQ matrix seems linear dependent", lindep
         ierr = 1
      else
         ierr = 0
      endif
   end subroutine make_rq_mat

   function linear_independency_real(mat)
      implicit none
      real(kind=8), intent(inout) :: mat(:,:)
      real(kind=8) :: linear_independency_real

      integer :: info, lwork, iwork(8*minval(shape(mat))), ldmat, m, n
      integer, parameter :: ldu = 1, ldvt = 1

      real(kind=8) :: s(minval(shape(mat))), u(1,1), vt(1,1), work_size(1)
      real(kind=8), allocatable :: work(:)

      ldmat = size(mat, 1)
      m = size(mat,1)
      n = size(mat,2)

      !call dgesdd(jobz,m,n, a,   lda, s, u, ldu, vt, ldvt, work,lwork, iwork, info)
      call dgesdd("N", m, n, mat, ldmat, s, u, ldu, vt, ldvt, work_size, -1, iwork, info)

      lwork = int(work_size(1))
      allocate(work(lwork))

      call dgesdd("N", m, n, mat, ldmat, s, u, ldu, vt, ldvt, work, lwork, iwork, info)

      linear_independency_real = s(size(s))
   end function linear_independency_real

   function linear_independency_cmplx(mat)
      implicit none
      complex(kind=8), intent(inout) :: mat(:,:)
      real(kind=8) :: linear_independency_cmplx

      integer :: info, lwork, iwork(8*minval(shape(mat))), ldmat, m, n
      integer, parameter :: ldu = 1, ldvt = 1

      real(kind=8) :: s(minval(shape(mat))), rwork(7*minval(shape(mat)))
      complex(kind=8) :: u(1,1), vt(1,1), work_size(1)
      complex(kind=8), allocatable :: work(:)

      ldmat = size(mat, 1)
      m = size(mat,1)
      n = size(mat,2)

      !call zgesdd(jobz, m, n, a,  lda,  s, u, ldu, vt, ldvt, work,    lwork, rwork, iwork, info )
      call zgesdd("N", m, n, mat, ldmat, s, u, ldu, vt, ldvt, work_size, -1, rwork, iwork, info)

      lwork = int(work_size(1))
      allocate(work(lwork))

      call zgesdd("N", m, n, mat, ldmat, s, u, ldu, vt, ldvt, work, lwork, rwork, iwork, info)

      linear_independency_cmplx = s(size(s))
   end function linear_independency_cmplx

   subroutine print_mtx(mtx)
      implicit none
      real(kind=8), intent(in) :: mtx(:,:)
      integer ::i

      do i = 1, size(mtx,1)
         write (*,*) mtx(i,:)
      enddo
      write (*,*) "####"
   end subroutine print_mtx
end module m_unique_eigvec


MODULE mo_constants

  IMPLICIT NONE

! Universal constants
  REAL, PARAMETER :: avo   = 6.02214e23    ! Avogadro constant in 1/mol

! Molar weights in g/mol
  REAL, PARAMETER :: amd   = 28.970        ! molecular weight of dry air

! Dry air and water vapour thermodynamic constants
  REAL, PARAMETER :: rd    = 287.05        ! gas constant for dry air in J/K/kg
  REAL, PARAMETER :: rv    = 461.51        ! gas constant for water vapour
                                                  ! in J/K/kg
  REAL, PARAMETER :: alv    = 2.5008e6      ! latent heat for vaporisation in J/kg
  REAL, PARAMETER :: als    = 2.8345e6      ! latent heat for sublimation in J/kg
  REAL, PARAMETER :: alf    = als-alv          ! latent heat for fusion in J/kg

! Earth and earth orbit parameters
  REAL, PARAMETER :: g     = 9.80665       ! gravity acceleration in m/s2

END MODULE mo_constants


! vectorspace_function.f90 --
!     Define a module for dealing with vector spaces in an abstract sense
!     and a specific class for adding and multiplying functions.
!
!     The basic data type is an abstract vector, with the following
!     operations:
!     "+" - to add two vectors to get a new vector
!     "*" - to multiply a vector with a scalar
!     We can use an array of vectors as a collection: the operation ".in."
!     determines if a given vector is in that collection.
!
!     Note:
!     The multiplication does not work as I want, because I need a PASS attribute
!     and that conflicts with some restriction.
!
module vectorspaces
    implicit none

    type, abstract :: vector
    contains
        private
        procedure(addition), deferred                :: add
       ! This does not work, for some reason:
        procedure(multiplication), deferred, pass(b) :: multiply ! Note the "pass(b)" attribute!
        procedure(membership), deferred              :: is_member
        generic, public                              :: operator(+)    => add
        generic, public                              :: operator(*)    => multiply
        generic, public                              :: operator(.in.) => is_member
    end type vector

    abstract interface
        function addition( a, b )
            import :: vector

            class(vector), intent(in), target :: a, b     !<= We need the target attribute here
            class(vector), allocatable        :: addition
        end function addition

        function multiplication( a, b )
            import :: vector

            real, intent(in)                  :: a
            class(vector), intent(in), target :: b
            class(vector), allocatable        :: multiplication
        end function multiplication

        function membership( a, b )
            import :: vector

            class(vector), intent(in)               :: a
            class(vector), intent(in), dimension(:) :: b
            logical                                 :: membership
        end function membership
    end interface
end module vectorspaces

!
! Test this with an actual implementation
!
module vectors_function
    use vectorspaces

    type, extends(vector) :: vector_function
        real                               :: factor = 0.0
        procedure(f_of_x), nopass, pointer :: f  => null()
        type(vector_function), pointer     :: v1 => null()
        type(vector_function), pointer     :: v2 => null()
    contains
        procedure :: add               => add_functions
        procedure, pass(b) :: multiply => multiply_function  !<== Note: pass(b) required!
        procedure :: is_member         => is_member_dummy
        procedure :: eval              => eval_function
    end type

    interface assignment(=)
        module procedure assign_vector_function
    end interface

    interface
        real function f_of_x( x )
            real, intent(in) :: x
        end function f_of_x
    end interface

contains
function add_functions( a, b )
    class(vector_function), intent(in), target  :: a
    class(vector), intent(in), target           :: b
    class(vector), allocatable                  :: add_functions

    allocate( add_functions, mold = a )

    !
    ! Clumsy, but that is a consequence of the strict typing in Fortran
    !
    select type (add_functions)
        type is (vector_function)
            select type (b)
                type is (vector_function)
                    add_functions%v1 => a
                    add_functions%v2 => b
                class default
                     add_functions%v1 => null()
                     add_functions%v2 => null()
            end select
    end select
end function add_functions

function multiply_function( a, b )
    real, intent(in)                            :: a
    class(vector_function), intent(in), target  :: b
    class(vector), allocatable                  :: multiply_function

    allocate( multiply_function, mold = b )

    select type (multiply_function)
        type is (vector_function)
            multiply_function%factor =  a
            multiply_function%v1     => b
            multiply_function%v2     => null()
    end select

end function multiply_function

! Dummy - it is possible in principle, but you will have to descend the
!         tree of vectors
logical function is_member_dummy( a, b )
    class(vector_function), intent(in)         :: a
    class(vector), intent(in), dimension(:)    :: b

    is_member_dummy = .false.

end function is_member_dummy

! eval_function --
!     To evaluate the composite function for a particular value of x
!
recursive real function eval_function( a, x )
    class(vector_function), intent(in) :: a
    real                               :: x

    if ( associated(a%v2) ) then
        eval_function = a%v1%eval(x) + a%v2%eval(x)
    elseif ( associated(a%v1) ) then
        eval_function = a%factor * a%v1%eval(x)
    else if ( associated(a%f) ) then
        eval_function = a%f(x)
    else
        eval_function = 0.0
    endif
end function eval_function

! assign_vector_function --
!     Overcome the discrepancy between vector and vector_function
!
!     Note:
!     This is a rather naive implementation - we should actually
!     so a deep copy to make it robust.
!
subroutine assign_vector_function( a, b )
    class(vector_function), intent(out) :: a
    class(vector), intent(in)           :: b

    select type ( b )
        type is (vector_function)
            a%factor =  b%factor
            a%v1     => b%v1
            a%v2     => b%v2
        class default
            a%factor = 0.0
            a%v1     => null()
            a%v2     => null()
    end select
end subroutine assign_vector_function

subroutine setfunc( a, f )
    class(vector_function), intent(inout) :: a
    procedure(f_of_x), pointer            :: f

    a%f => f
end subroutine setfunc

end module vectors_function

! Test program for the vector space modules
!
program test_space
    use vectors_function

    implicit none

    type(vector_function)      :: a, b, c, d
    procedure(f_of_x), pointer :: f

    ! A bit roundabout, but f is a private member
    f => sine;   call setfunc( a, f )
    f => cosine; call setfunc( b, f )

    c = a + b
    d = 10.0 * c

    write(*,*) 'a at x = 1.0: ', a%eval(1.0)
    write(*,*) 'b at x = 1.0: ', b%eval(1.0)
    write(*,*) 'c at x = 1.0: ', c%eval(1.0)
    write(*,*) 'd at x = 1.0: ', d%eval(1.0)

contains
real function sine( x )
    real, intent(in) :: x
    sine = sin(x)
end function sine
real function cosine( x )
    real, intent(in) :: x
    cosine = cos(x)
end function cosine

end program test_space


! Evalute density as functino of temperature based on correlation
!
! Correlation is of the form density(T) = a + b*T where a, b are constants
!
! G. J. Janz, R. P. T. Tomkins, Physical properties data compilations relevant to energy storage. IV. Molten salts: Data on Additional Single and Multi- Component Salt Systems. NSRDS-NBS-61(Pt.IV), U.S. National Bureau of Standards, 1981
! This was done for KCl-MgCl2 salts
!
! Valid from 1017 - 1174 K
!
! Taube and Ligou had 2.344 g/cc density @ 984 C for PuCl3
!
! Adjusted KCl-MgCl2 to better align with Taube correlation
!
!---**************UPDATED
!  From paper evaluating UCl3-NaCl
! https://link.springer.com/content/pdf/10.1007/BF01121527.pdf

! Input:
!       T - temperature to evaluate density at
! Output:
!       density - evaluated conductivity at T [ g/cm^3]
!
subroutine density_corr(T, density)

    USE global_parameters_M
    USE Flags_M
implicit none

! Dummy
    real(dp), intent(in)  :: T
    real(dp), intent(out) :: density
! Local
    real(dp) :: a
    real(dp) :: b

    !a = 2007.0_dp
    ! 2800 is not correct but this correlation is wrong for our temp range
    !a = 2800.0_dp
    !b= -0.4571_dp

    !--Russian paper 1975
    a =  3860.4_dp
    b = -0.8321_dp

    density = (a + b*T)*0.001_dp

    if ( MSRE_problem .eqv. .TRUE.) then

        density = 2.306

    end if

end


!========================================================================
! PROGRAMA PRINCIPAL DEL LA SIMULACION, LLAMA SUBRUTINAS PARA REALIZAR
! LA SIMULACION. SE UTILIZA DINAMICA BROWNIANA
! AUTOR: MARTIN ALEJANDRO PAREDES SOSA
!========================================================================
Program Main
  Use cte
  Implicit None
  Integer :: i, j, IStep , k, k2,  ki                       !CONTADORES
  Real :: RanX, RanY, RanZ                                  !VALORES ALEATORIOS PARA POSICION
  Real :: phi                                               !VARIABLE TEMP FRACCION EN VOLUMEN
  Real :: Var
  Logical :: Ctrl, Ctrl1, Ctrl2                             !CONTROL LOGICO

  Integer :: istat1, istat2
  Character (len=80) :: err_msg1, err_msg2

  !PARAMETROS DE SIMULADOR
  N = 800
  NStep =100000
  ISave = 100                                            !G(r)
  ISave2 = 100                                           !W(t), D(t)
  iPrint = 1000
  dt = 0.0004

  phi = 4.4D-4
  Dens = 6*phi/pi
  YukA = 556.0
  YukZk = 0.149
  YukA = YukA * Exp( YukZk )
  NN = ( NStep- CEq ) / ISave
  !Write(*,*) phi !DEBUG

  !PEDIR DENSIDAD Y NUMERO DE PARTICULAS
  Write(*,*) "NUMERO DE PARTICULAS"
  Write(*,*) N
  Write(*,*) "CONCENTRACION REDUCIDA"
  Write(*,*) Dens
  Write(*,*) "NUMERO DE CICLOS"
  Write(*,*) NStep
  Write(*,*) "MONITOREO EN PANTALLA (CADA CAUNTOS CICLOS)"
  write(*,*) IPrint
  Write(*,*) "NUMERO DE PASOS PARA GUARDAR CONFIGURACION ( G(r) )"
  write(*,*) ISave
  Write(*,*) "NUMERO DE PASOS PARA GUARDAR CONFIGURACION ( W(t),D(t)  )"
  write(*,*) ISave2
  Write(*,*) "PASO DE TIEMPO"
  write(*,*) DT
  Write(*,*) "============================================================================="

  !ALOJAR ESPACIO EN MEOMORIA PARA LOS ARREGLO DE POSICION DE PARTICULAS
  Allocate( X(N), Y(N), Z(N), STAT= istat1 , ERRMSG=err_msg1  )
  Allocate( XR(N), YR(N), ZR(N) )

  !ALOJAR ESPACIO EN MEMORIA PARA LAS FUERZAS DE INTERACCION
  Allocate( FX(N), FY(N), FZ(N) )

  !ALOJAR ESPACIO EN MEOMORIA PARA LOS ARREGLOS DE CONFIGURACION
  Allocate( CX(N,NN), CY(N,NN), CZ(N,NN), STAT= istat2 , ERRMSG=err_msg2 )
  Allocate( CXD(N,NN), CYD(N,NN), CZD(N,NN) )

  !GENERAR LA CONFIGURACION INICIAL
  Call ConfigIni
  Write(*,*) "CONFIGURACION INICIAL LISTA"

  !CALCULO/PARAMETROS PARA INICIALIZAR
  RCut = BoxL / 2.0
  Var = sqrt(2.0*dt)
  k2 = 0                                                                  !G(r)
  ki = 0                                                                  !W(t), D(t)

  !CALCULO DE FUERZAS DE LA CONFIGURACION INICIAL
  Open(3, File="Terma.dat" )
  Call Fuerza(iStep)

  !ABRIENDO ARCHIVOS PARA GUARDAR INFO DEL SISTEMA
  Open(2, File="ConFin.dat")

  !MOVIMIENTO DE PARTICULAS

  Configuracion: Do iStep = 1, NStep

     Particula: Do i = 1, N

        !GENERAR VALORES ALEATORIO CON DISTRIBUCION GAUSSIANA
        Call RanGauss(RanX)
        Call RanGauss(RanY)
        Call RanGauss(RanZ)

        !MOVIMINETO DE PARTICULAS EN BASE A LA ECUACION DE LANGEVIN
        !SOBREAMORTIGUADA, O REGIMEN DIFUSIVO
        !ALGORITMO DE EMARK PARA EL DESPLAZAMIENTO

        X(i) = X(i) + FX(i) * dt + Var * RanX
        Y(i) = Y(i) + FY(i) * dt + Var * RanY
        Z(i) = Z(i) + FZ(i) * dt + Var * RanZ

        XR(i) = XR(i) + FX(i) * dt + Var * RanX
        YR(i) = YR(i) + FY(i) * dt + Var * RanY
        ZR(i) = ZR(i) + FZ(i) * dt + Var * RanZ

        !CONDICIONES PERIODICAS (MANTENER MISMA N EN TODA CONFIGURACION)
        X(i) = X(i) - BoxL*Anint( X(i) / BoxL )
        Y(i) = Y(i) - BoxL*Anint( Y(i) / BoxL )
        Z(i) = Z(i) - BoxL*Anint( Z(i) / BoxL )

        !FIN DE MOVIMIENTO DE PARTICULAS DE LA CONFIGURACION ISTEP

     End Do Particula

     !ALMACENANDO CONFIGURACIONES DE EQUILIBRIO CX, CY, CZ PARA LA G(R)
     Ctrl1 =  Mod( iStep, iSave) == 0
     Ctrl2 = iStep .GT. CEq
     Ctrl = Ctrl1 .AND. Ctrl2

     ConfigGR: If (Ctrl) Then
        k2 = k2 + 1

        SAV:Do k = 1 , N

           CX(k,k2) = X(k)
           CY(k,k2) = Y(k)
           CZ(k,k2) = Z(k)
           !Write(*,*) "ENTRO"

        End Do SAV

     End If ConfigGR

     !ALMACENANDO CONFIGURACIONES DE EQUILIBRIO CXD, CYD, CZD PARA W(t) Y D(t)
     Ctrl1 =  Mod( iStep, iSave2) == 0
     Ctrl2 = iStep .GT. CEq
     Ctrl = Ctrl1 .AND. Ctrl2

     ConfigWt: If (Ctrl) Then

        ki = ki + 1

        SAV1:Do k = 1 , N

           CXD(k,ki) = XR(k)
           CYD(k,ki) = YR(k)
           CZD(k,ki) = ZR(k)

        End Do SAV1

     End If ConfigWt

     !CALCULO DE FUERZAS DE LAS CONFIGURACIONES
     Call Fuerza(iStep)

  End Do Configuracion

  Write(*,*) "DONE CONFIGURACIONES"
  Close(3)

  !GUARDAR CONFIG FINAL
  ConfigFin: Do i=1, N

     Write(2,*) X(i), Y(i), Z(i)

  End Do ConfigFin
  Close (2)
  WRITE(*,*) "DONE SAVING CONFIG FINAL"
  Deallocate( X, Y, Z, XR, YR, ZR )
  WRITE(*,*) "CLEAR MEMORY POSICIONES" !DEBUG

  !CALCULO DE PROPIEDADES
  WRITE(*,*) "CALCULANDO GDR" !DEBUG
  Call GdrCalc
  WRITE(*,*) "GDR DONE CALC" !DEBUG
  Deallocate( CX, CY, CZ )
  WRITE(*,*) "CLEAR MEMORY CONFIGURACIONES G(r)" !DEBUG

  !CALCULO DE PROPIEDADES DE WDT
  Write(*,*) "CALCULADO WDT" !DEBUG
  Call WDT(ki)
  WRITE(*,*) "WDT DONE CALC" !DEBUG
  Deallocate( CXD, CYD, CZD )
  WRITE(*,*) "CLEAR MEMORY CONFIGURACIONES W(t)" !DEBUG

  WRITE(*,*) "DONE"

End Program Main


!-----------------------------------------------------------------------
!     Subroutine:    gaunt_freefree
!     Authors:       S. Lazerson (samuel.lazerson@ipp.mpg.de)
!     Date:          04/18/2021
!     Description:   This subroutine returns the Gaunt Free_Free Factor
!                    <g_{ff}> based on the paper
!                    Sutherland, R. S. (1998). Accurate free-free Gaunt
!                         factors for astrophysical plasmas. Monthly
!                         Notices of the Royal Astronomical Society,
!                         300(2), 321–330.
!                        http://doi.org/10.1046/j.1365-8711.1998.01687.x
!                    It is based on interpolation provided for Table 2.
!                    It takes arguments
!                        gamma2: gamma^2 = Z*Z*Ry/(k*T)
!                        u:            u = hc/(lambda*k*T)
!-----------------------------------------------------------------------
      SUBROUTINE gaunt_freefree(gamma2,u,gff)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
!-----------------------------------------------------------------------
!     Arguments
!          gamma2       Gamma^2=Z*Z*Ry/(k*T)
!          u            u=hc/lambda*k*T
!          gff          Interpolated Gaunt Free-Free Factor
!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL(rprec), INTENT(in) :: gamma2
      REAL(rprec), INTENT(in) :: u
      REAL(rprec), INTENT(out) :: gff
!-----------------------------------------------------------------------
!     PARAMETERS
!          A     Table 2
!          A1    Rows of Table 2
!          A2    Columns of Table 2
!          Note the notation for the table is reversed.
!-----------------------------------------------------------------------
      REAL(rprec), DIMENSION(17,9) :: A
      REAL(rprec), DIMENSION(17), PARAMETER :: A1 = &
        (/-4.0,-3.5,-3.0,-2.5,-2.0,-1.5,-1.0,-0.5,0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0/)
      REAL(rprec), DIMENSION(9), PARAMETER :: A2 = &
        (/-4.0,-3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0/)
!-----------------------------------------------------------------------
!     Variables
!          log10g2, log10u     Log base 10 of input quantities.
!          idex1,idex2         Index for spline tables
!          idex1b,idex2b       idex + 1
!          delta1,delta2       position between table units from [0,1]
!-----------------------------------------------------------------------
      INTEGER :: idex1,idex2, idex1b, idex2b
      REAL(rprec) :: log10g2, log10u, delta1, delta2
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      gff=0.0
      ! Intializations
      log10g2 = log10(gamma2)
      log10u  = log10(u)
      A = RESHAPE((/5.524300, 5.521300, 5.498300, 5.378000, 5.009000, 4.435400, 3.831700, 3.247200, 2.700800,&
                    4.890600, 4.888500, 4.867400, 4.750700, 4.388600, 3.837800, 3.247000, 2.700600, 2.212400,&
                    4.258100, 4.257700, 4.240300, 4.130700, 3.781600, 3.243600, 2.700800, 2.212600, 1.804100,&
                    3.628400, 3.631100, 3.620800, 3.524600, 3.198500, 2.698200, 2.213400, 1.804900, 1.491800,&
                    3.004800, 3.012500, 3.015200, 2.943400, 2.656000, 2.213100, 1.807100, 1.493300, 1.277100,&
                    2.395400, 2.409600, 2.433400, 2.403500, 2.175900, 1.810900, 1.498100, 1.280100, 1.146600,&
                    1.815300, 1.836700, 1.888000, 1.924300, 1.782500, 1.508800, 1.288600, 1.150700, 1.074700,&
                    1.290300, 1.317300, 1.394000, 1.517000, 1.491300, 1.309800, 1.164900, 1.081700, 1.039200,&
                    0.853140, 0.881520, 0.969750, 1.169900, 1.293900, 1.198800, 1.103300, 1.050100, 1.023700,&
                    0.527060, 0.551720, 0.632670, 0.860420, 1.145300, 1.149700, 1.081300, 1.039800, 1.018900,&
                    0.310120, 0.328290, 0.390000, 0.589370, 0.972540, 1.128400, 1.082500, 1.041900, 1.020200,&
                    0.177720, 0.189630, 0.230940, 0.376250, 0.747760, 1.084400, 1.095700, 1.052400, 1.025800,&
                    0.100690, 0.107960, 0.133150, 0.228140, 0.517140, 0.956080, 1.106500, 1.069300, 1.035500,&
                    0.056791, 0.061071, 0.076219, 0.133950, 0.329880, 0.742910, 1.077700, 1.090000, 1.049500,&
                    0.031977, 0.034444, 0.043211, 0.077187, 0.199710, 0.514600, 0.954790, 1.104200, 1.068000,&
                    0.017993, 0.019399, 0.024409, 0.044007, 0.117170, 0.328260, 0.742810, 1.077000, 1.089400,&
                    0.010121, 0.010918, 0.013760, 0.024939, 0.067498, 0.198700, 0.514620, 0.954660, 1.104000/),&
                    (/17,9/),ORDER=(/2,1/))
      idex1 = MIN(MAX(COUNT(A1<log10u),1),17)
      idex1b = MIN(idex1+1,17)
      idex2 = MIN(MAX(COUNT(A2<log10g2),1),9)
      idex2b = MIN(idex2+1,9)
      delta1 = (log10u - A1(idex1))*2 !delta x = 0.05
      delta2 = (log10g2 - A2(idex2))*1 !delta u = 1.0
      ! 2D Bilinear interpolation
      gff =  A(idex1 , idex2 )*(1.0-delta1)*(1.0-delta2) &
           + A(idex1b, idex2 )*delta1*(1.0-delta2) &
           + A(idex1 , idex2b)*(1.0-delta1)*delta2 &
           + A(idex1b, idex2b)*delta1*delta2
!            PRINT *,gamma2,u,log10g2,log10u,idex1,idex1b,idex2,idex2b,delta1,delta2,gff
      RETURN

!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE gaunt_freefree


      double precision function del3(p1,p2,p3,k1,k2,k3)
      implicit none
      double precision ovdot,p1(4),p2(4),p3(4),k1(4),k2(4),k3(4),del2
      del3=ovdot(p1,k1)*del2(p2,p3,k2,k3)
     &    -ovdot(p1,k2)*del2(p2,p3,k1,k3)
     &    +ovdot(p1,k3)*del2(p2,p3,k1,k2)
      return
      end


program main
      implicit none
      integer::i,j,n=108

      real(8),allocatable::a(:,:),rx(:),ry(:),rz(:),fx(:),fy(:),fz(:),vx(:),vy(:),vz(:)

      allocate (a(n,n),rx(n),ry(n),rz(n),vx(n),vy(n),vz(n))

      open(1,file='argon.init')

      do  i=1,n
        read(1,*) (a(i,j),j=1,3)
        rx(i) =a(i,1)
        ry(i) =a(i,2)
        rz(i) =a(i,3)
      end do
      call  verlet_algorithm(rx,ry,rz)
end program main

    subroutine verlet_algorithm(rx,ry,rz)
      implicit none
      integer::i,n=108,k,itime = 70000
      real(8)::v,pot_lj,KE,T,m,delta =0.005d0,T_req = 85.0d0
      real(8)::rx(200),ry(200),rz(200),fx(200),fy(200),fz(200),vx(200),vy(200),vz(200 )
      m=39.948
      !allocate (rx(n),ry(n),rz(n),fx(n),fy(n),fz(n),vx(n),vy(n),vz(n))
      call calc_force(n,rx,ry,rz,fx,fy,fz)
      call calc_pot(n,rx,ry,rz,v)
      do i=1,n
       vx(i)=0.0d0; vy(i)=0.0d0; vz(i)=0.0d0
      end do
      KE = 0.0d0
      k=0
      do i=1,n
        KE = KE + 0.5*m*((vx(i)*vx(i)) + (vy(i)*vy(i)) + (vz(i)*vz(i)))
        write(13,*)k*delta,i,rx(i),ry(i),rz(i)
        write(14,*)k*delta,i,vx(i),vy(i),vz(i)
      end do
      write(57,*)k*delta,v,KE,v+KE

     !!main loop
      do k=1,itime
       KE=0.00d0
       do i=1,n
        vx(i) = vx(i) + 0.5 * (fx(i)/m) * delta
        vy(i) = vy(i) + 0.5 * (fy(i)/m) * delta
        vz(i) = vz(i) + 0.5 * (fz(i)/m) * delta

        rx(i) = rx(i) + (vx(i)*delta)
        ry(i) = ry(i) + (vy(i)*delta)
        rz(i) = rz(i) + (vz(i)*delta)
       end do

       call calc_force(n,rx,ry,rz,fx,fy,fz)
       do i=1,n
        vx(i) = vx(i) +  0.5 * (fx(i)/m) * delta
        vy(i) = vy(i) +  0.5 * (fy(i)/m) * delta
        vz(i) = vz(i) +  0.5 * (fz(i)/m) * delta

        write(13,*)k*delta,i,rx(i),ry(i),rz(i)
        !rescale velocities
        write(14,*)k*delta,i,vx(i),vy(i),vz(i)
        KE= KE + 0.5 *m*((vx(i)*vx(i))+ (vy(i)*vy(i))+(vz(i)*vz(i)))
       end do

       T = (KE/(1.5*n))
       write(50,*)k*delta,T
       if (k<10000)then
        do i=1,n
         vx(i) = vx(i) * sqrt(T_req/T)
         vy(i) = vy(i) * sqrt(T_req/T)
         vz(i) = vz(i) * sqrt(T_req/T)
        end do
       end if
       call calc_pot(n,rx,ry,rz,v)
       write(57,*)k*delta,v,KE,v+KE
      end do
    end subroutine verlet_algorithm

subroutine calc_pot(n,rx,ry,rz,pot_lj)
     implicit none
     integer ::n
     real(kind=8) :: rx (200),ry(200),rz(200)
     real(kind=8) :: pot_lj
     integer::i,j
     real(kind=8) :: boxl,sigsq,epslon
     real(kind=8) :: rxij,ryij,rzij,rijsq
     real(kind=8) :: sr2,sr6,sr12
     real(kind=8) :: rcutoffsq,rcutoff
     real(kind=8) :: sig,kb,a
     n=108
     !do i= 1,n
        !write(15,*)rx(i),ry(i),rz(i)
    !end do

      boxl =17.158d0
      sig = 3.405d0
      sigsq = sig * sig
      kb = 1.38E-23
      epslon = 120.0d0 !* kb

      rcutoff = 0.50d0 * boxl
      rcutoffsq = rcutoff * rcutoff

     do i=1,n
        rx(i) = rx(i) - (boxl * anint(rx(i)/boxl))
        ry(i) = ry(i) - (boxl * anint(ry(i)/boxl))
        rz(i) = rz(i) - (boxl * anint(rz(i)/boxl))
        !write(3,*)rx(i),ry(i),rz(i)
     end do

     pot_lj=0.0d0
     do i=1,n-1
      do j=i+1,n
           rxij = rx(i) - rx(j)
           ryij = ry(i) - ry(j)
           rzij = rz(i) - rz(j)

           rxij = rxij - (boxl * anint(rxij/boxl))
           ryij = ryij - (boxl * anint(ryij/boxl))
           rzij = rzij - (boxl * anint(rzij/boxl))
           !write(18,*)rxij,ryij,rzij

           rijsq = rxij**2 + ryij**2 + rzij**2
           !write(19,*)rijsq
           sr2 = sigsq/rijsq
           sr6 = sr2 * sr2 * sr2
           sr12 = sr6 * sr6
        if(rijsq<rcutoffsq) then
          pot_lj= pot_lj + sr12 -sr6 +(3.83738839608178386E-003)
        endif
     end do
   end do
    pot_lj = (4.0d0*epslon*pot_lj)
end subroutine calc_pot

subroutine calc_force(n,rx,ry,rz,fx,fy,fz)
 implicit none
 integer::i,j,n
 real(8)::rx(200),ry(200),rz(200),boxl,sigsq,epslon,rxij,ryij,rzij,rijsq,sr2,sr6,sr12,rcutoffsq,rcutoff,sig,kb
 real(8)::fxij,fyij,fzij,fpr,fx(200),fy(200),fz(200)
 !real(8),allocatable::a(:,:)!,fx(:),fy(:),fz(:)
 n=108
 !do  i=1,n
  !write(15,*)rx(i),ry(i),rz(i)
 !end do

 boxl =17.158d0
 sig = 3.405d0
 sigsq = sig * sig
 kb = 1.38E-23
 epslon = 120.0d0 !* kb

 rcutoff = 0.50d0 * boxl
 rcutoffsq = rcutoff * rcutoff

 do i=1,n
  rx(i) = rx(i) - (boxl * anint(rx(i)/boxl))
  ry(i) = ry(i) - (boxl * anint(ry(i)/boxl))
  rz(i) = rz(i) - (boxl * anint(rz(i)/boxl))
 end do

 do i=1,n
  fx(i)=0.0d0; fy(i)=0.0d0; fz(i)=0.0d0
 end do

 do i=1,n-1
  do j=i+1,n
   rxij = rx(i) - rx(j)
   ryij = ry(i) - ry(j)
   rzij = rz(i) - rz(j)

   rxij = rxij - (boxl * anint(rxij/boxl))
   ryij = ryij - (boxl * anint(ryij/boxl))
   rzij = rzij - (boxl * anint(rzij/boxl))

   rijsq = rxij**2 + ryij**2 + rzij**2
   sr2 = sigsq/rijsq
   sr6 = sr2 * sr2 * sr2
   sr12 = sr6 * sr6

   if(rijsq<rcutoffsq) then
    fpr = (48.0d0 * epslon * (sr12 - (0.5d0*sr6)))/rijsq
    fxij = fpr * rxij
    fyij = fpr * ryij
    fzij = fpr * rzij

    fx(i) = fx(i) + fxij
    fy(i) = fy(i) + fyij
    fz(i) = fz(i) + fzij
    fx(j) = fx(j) - fxij
    fy(j) = fy(j) - fyij
    fz(j) = fz(j) - fzij

   end if
  end do

   !write(22,*)fx(i),fy(i),fz(i)

 end do
end subroutine calc_force