*DECK MINFIT
      SUBROUTINE MINFIT (NM, M, N, A, W, IP, B, IERR, RV1)
C***BEGIN PROLOGUE  MINFIT
C***PURPOSE  Compute the singular value decomposition of a rectangular
C            matrix and solve the related linear least squares problem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D9
C***TYPE      SINGLE PRECISION (MINFIT-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure MINFIT,
C     NUM. MATH. 14, 403-420(1970) by Golub and Reinsch.
C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
C
C     This subroutine determines, towards the solution of the linear
C                                                        T
C     system AX=B, the singular value decomposition A=USV  of a real
C                                         T
C     M by N rectangular matrix, forming U B rather than U.  Householder
C     bidiagonalization and a variant of the QR algorithm are used.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and B, as declared in the calling
C          program dimension statement.  Note that NM must be at least
C          as large as the maximum of M and N.  NM is an INTEGER
C          variable.
C
C        M is the number of rows of A and B.  M is an INTEGER variable.
C
C        N is the number of columns of A and the order of V.  N is an
C          INTEGER variable.
C
C        A contains the rectangular coefficient matrix of the system.
C          A is a two-dimensional REAL array, dimensioned A(NM,N).
C
C        IP is the number of columns of B.  IP can be zero.
C
C        B contains the constant column matrix of the system if IP is
C          not zero.  Otherwise, B is not referenced.  B is a two-
C          dimensional REAL array, dimensioned B(NM,IP).
C
C     On OUTPUT
C
C        A has been overwritten by the matrix V (orthogonal) of the
C          decomposition in its first N rows and columns.  If an
C          error exit is made, the columns of V corresponding to
C          indices of correct singular values should be correct.
C
C        W contains the N (non-negative) singular values of A (the
C          diagonal elements of S).  They are unordered.  If an
C          error exit is made, the singular values should be correct
C          for indices IERR+1, IERR+2, ..., N.  W is a one-dimensional
C          REAL array, dimensioned W(N).
C
C                                   T
C        B has been overwritten by U B.  If an error exit is made,
C                       T
C          the rows of U B corresponding to indices of correct singular
C          values should be correct.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          K          if the K-th singular value has not been
C                     determined after 30 iterations.
C                     The singular values should be correct for
C                     indices IERR+1, IERR+2, ..., N.
C
C        RV1 is a one-dimensional REAL array used for temporary storage,
C          dimensioned RV1(N).
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  MINFIT
C
      INTEGER I,J,K,L,M,N,II,IP,I1,KK,K1,LL,L1,M1,NM,ITS,IERR
      REAL A(NM,*),W(*),B(NM,IP),RV1(*)
      REAL C,F,G,H,S,X,Y,Z,SCALE,S1
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  MINFIT
      IERR = 0
C     .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ..........
      G = 0.0E0
      SCALE = 0.0E0
      S1 = 0.0E0
C
      DO 300 I = 1, N
         L = I + 1
         RV1(I) = SCALE * G
         G = 0.0E0
         S = 0.0E0
         SCALE = 0.0E0
         IF (I .GT. M) GO TO 210
C
         DO 120 K = I, M
  120    SCALE = SCALE + ABS(A(K,I))
C
         IF (SCALE .EQ. 0.0E0) GO TO 210
C
         DO 130 K = I, M
            A(K,I) = A(K,I) / SCALE
            S = S + A(K,I)**2
  130    CONTINUE
C
         F = A(I,I)
         G = -SIGN(SQRT(S),F)
         H = F * G - S
         A(I,I) = F - G
         IF (I .EQ. N) GO TO 160
C
         DO 150 J = L, N
            S = 0.0E0
C
            DO 140 K = I, M
  140       S = S + A(K,I) * A(K,J)
C
            F = S / H
C
            DO 150 K = I, M
               A(K,J) = A(K,J) + F * A(K,I)
  150    CONTINUE
C
  160    IF (IP .EQ. 0) GO TO 190
C
         DO 180 J = 1, IP
            S = 0.0E0
C
            DO 170 K = I, M
  170       S = S + A(K,I) * B(K,J)
C
            F = S / H
C
            DO 180 K = I, M
               B(K,J) = B(K,J) + F * A(K,I)
  180    CONTINUE
C
  190    DO 200 K = I, M
  200    A(K,I) = SCALE * A(K,I)
C
  210    W(I) = SCALE * G
         G = 0.0E0
         S = 0.0E0
         SCALE = 0.0E0
         IF (I .GT. M .OR. I .EQ. N) GO TO 290
C
         DO 220 K = L, N
  220    SCALE = SCALE + ABS(A(I,K))
C
         IF (SCALE .EQ. 0.0E0) GO TO 290
C
         DO 230 K = L, N
            A(I,K) = A(I,K) / SCALE
            S = S + A(I,K)**2
  230    CONTINUE
C
         F = A(I,L)
         G = -SIGN(SQRT(S),F)
         H = F * G - S
         A(I,L) = F - G
C
         DO 240 K = L, N
  240    RV1(K) = A(I,K) / H
C
         IF (I .EQ. M) GO TO 270
C
         DO 260 J = L, M
            S = 0.0E0
C
            DO 250 K = L, N
  250       S = S + A(J,K) * A(I,K)
C
            DO 260 K = L, N
               A(J,K) = A(J,K) + S * RV1(K)
  260    CONTINUE
C
  270    DO 280 K = L, N
  280    A(I,K) = SCALE * A(I,K)
C
  290    S1 = MAX(S1,ABS(W(I))+ABS(RV1(I)))
  300 CONTINUE
C     .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS.
C                FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 400 II = 1, N
         I = N + 1 - II
         IF (I .EQ. N) GO TO 390
         IF (G .EQ. 0.0E0) GO TO 360
C
         DO 320 J = L, N
C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  320    A(J,I) = (A(I,J) / A(I,L)) / G
C
         DO 350 J = L, N
            S = 0.0E0
C
            DO 340 K = L, N
  340       S = S + A(I,K) * A(K,J)
C
            DO 350 K = L, N
               A(K,J) = A(K,J) + S * A(K,I)
  350    CONTINUE
C
  360    DO 380 J = L, N
            A(I,J) = 0.0E0
            A(J,I) = 0.0E0
  380    CONTINUE
C
  390    A(I,I) = 1.0E0
         G = RV1(I)
         L = I
  400 CONTINUE
C
      IF (M .GE. N .OR. IP .EQ. 0) GO TO 510
      M1 = M + 1
C
      DO 500 I = M1, N
C
         DO 500 J = 1, IP
            B(I,J) = 0.0E0
  500 CONTINUE
C     .......... DIAGONALIZATION OF THE BIDIAGONAL FORM ..........
  510 CONTINUE
C     .......... FOR K=N STEP -1 UNTIL 1 DO -- ..........
      DO 700 KK = 1, N
         K1 = N - KK
         K = K1 + 1
         ITS = 0
C     .......... TEST FOR SPLITTING.
C                FOR L=K STEP -1 UNTIL 1 DO -- ..........
  520    DO 530 LL = 1, K
            L1 = K - LL
            L = L1 + 1
            IF (S1 + ABS(RV1(L)) .EQ. S1) GO TO 565
C     .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
            IF (S1 + ABS(W(L1)) .EQ. S1) GO TO 540
  530    CONTINUE
C     .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 ..........
  540    C = 0.0E0
         S = 1.0E0
C
         DO 560 I = L, K
            F = S * RV1(I)
            RV1(I) = C * RV1(I)
            IF (S1 + ABS(F) .EQ. S1) GO TO 565
            G = W(I)
            H = PYTHAG(F,G)
            W(I) = H
            C = G / H
            S = -F / H
            IF (IP .EQ. 0) GO TO 560
C
            DO 550 J = 1, IP
               Y = B(L1,J)
               Z = B(I,J)
               B(L1,J) = Y * C + Z * S
               B(I,J) = -Y * S + Z * C
  550       CONTINUE
C
  560    CONTINUE
C     .......... TEST FOR CONVERGENCE ..........
  565    Z = W(K)
         IF (L .EQ. K) GO TO 650
C     .......... SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
         IF (ITS .EQ. 30) GO TO 1000
         ITS = ITS + 1
         X = W(L)
         Y = W(K1)
         G = RV1(K1)
         H = RV1(K)
         F = 0.5E0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y)
         G = PYTHAG(F,1.0E0)
         F = X - (Z / X) * Z + (H / X) * (Y / (F + SIGN(G,F)) - H)
C     .......... NEXT QR TRANSFORMATION ..........
         C = 1.0E0
         S = 1.0E0
C
         DO 600 I1 = L, K1
            I = I1 + 1
            G = RV1(I)
            Y = W(I)
            H = S * G
            G = C * G
            Z = PYTHAG(F,H)
            RV1(I1) = Z
            C = F / Z
            S = H / Z
            F = X * C + G * S
            G = -X * S + G * C
            H = Y * S
            Y = Y * C
C
            DO 570 J = 1, N
               X = A(J,I1)
               Z = A(J,I)
               A(J,I1) = X * C + Z * S
               A(J,I) = -X * S + Z * C
  570       CONTINUE
C
            Z = PYTHAG(F,H)
            W(I1) = Z
C     .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO ..........
            IF (Z .EQ. 0.0E0) GO TO 580
            C = F / Z
            S = H / Z
  580       F = C * G + S * Y
            X = -S * G + C * Y
            IF (IP .EQ. 0) GO TO 600
C
            DO 590 J = 1, IP
               Y = B(I1,J)
               Z = B(I,J)
               B(I1,J) = Y * C + Z * S
               B(I,J) = -Y * S + Z * C
  590       CONTINUE
C
  600    CONTINUE
C
         RV1(L) = 0.0E0
         RV1(K) = F
         W(K) = X
         GO TO 520
C     .......... CONVERGENCE ..........
  650    IF (Z .GE. 0.0E0) GO TO 700
C     .......... W(K) IS MADE NON-NEGATIVE ..........
         W(K) = -Z
C
         DO 690 J = 1, N
  690    A(J,K) = -A(J,K)
C
  700 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO A
C                SINGULAR VALUE AFTER 30 ITERATIONS ..........
 1000 IERR = K
 1001 RETURN
      END


!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!-----------------------------------------------------------------------------------------------------------------------------------
program display_date
use M_kracken95, only : kracken, lget, retrev, sget, dget     ! command line parameter cracking module
use M_time,    only : now,fmtdate_usage,fmtdate,days2sec,d2u,u2d,realtime,guessdate,j2d
use m_strings, only : string_to_values, isdigit, isspace, switch
implicit none
character(len=*),parameter     :: ident="@(#)now(1f): writes timestamp using specified syntax"
integer                        :: dat(8)=0
real                           :: rdat(8)=0
real(kind=realtime)            :: duration=0
character(len=:),allocatable   :: output
!character(len=1),allocatable   :: chars(:)
integer                        :: ierr, inums
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   call kracken('now',' -help .F. -version .F. -dat -date -jed -uet -test .false. -delta')  ! crack command line
   call help_version(lget('now_version'))                                    ! display version number if --version is present
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   if(lget('now_help'))then                                        ! display help text and exit if --help is present
      call usage()
      stop
   endif
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   if(lget('now_test'))then                                        ! try each format type
      call fmtdate_usage(3)
      stop
   endif
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   if (sget('now_uet').ne.' ')then
      dat=u2d(dget('now_uet'))                                     ! convert command option to UET number, convert to dat
   elseif (sget('now_jed').ne.' ')then
      dat=j2d(dget('now_jed'))                                     ! convert command option to JED number, convert to dat
   elseif (sget('now_dat').ne.' ')then
      dat=u2d()                                                    ! initialize DAT with current date and time to get time zone
      dat=[dat(1),1,1,dat(4),0,0,0,0]                              ! default is Jan 1st in current year and timezone 00:00:00
      call string_to_values(sget('now_dat'),size(dat),rdat,inums,' ,:/',ierr) ! convert string to array and overlay default values
      dat(1:inums)=nint(rdat(1:inums))

      ! if -date is all integer digits and whitespace and +- and only one - (for UTC value) then use it directly to load a DAT
      !chars=switch(trim(sget('now_dat')))
      !if( all(isdigit(chars).or.isspace(chars).or.chars.eq.'-'.or.chars.eq.'+' ) .and. count(chars.eq.'-').le.1 )then
      !else
      !   write(*,*)'*now* error: invalid characters in -dat input '//trim(sget('now_dat'))
      !endif

   elseif (sget('now_date').ne.' ')then                            ! convert command option to date string and try to guess date
      call guessdate(sget('now_date'),dat)
   else                                                            ! create DAT for current time
      dat=u2d()                                                    ! current time
   endif
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   duration=days2sec(sget('now_delta'))                            ! convert string to duration in seconds
   dat=u2d(d2u(dat)+duration)                                      ! convert DAT to UET, add duration, place back in DAT
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   output=fmtdate(dat,sget('now_oo'))                              ! create output string by applying format
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   write(*,'(a)')trim(output)                                      ! write output
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
contains
!-----------------------------------------------------------------------------------------------------------------------------------
subroutine usage()
!
character(len=*),parameter    :: ident="@(#)usage(3f,private): writes program help to stdout and exits"
character(len=80),allocatable :: text(:)
integer                       :: i
! NOTE: Without the type specification this constructor would have to specify all of the constants with the same character length.
text=[ character(len=len(text(1))) ::                                               &
&'NAME                                                                            ',&
&'   now(1f)  - [TIME] print the date and time                                    ',&
&'   (LICENSE:PD)                                                                 ',&
&'                                                                                ',&
&'SYNOPSIS                                                                        ',&
&'  now [Format [ -date date_str|-ued Unix_time|-jed Julian_Date|-dat date_vector]',&
&'      [ -delta dd-hh:mm:ss]]|--help |--version|-test]                           ',&
&'                                                                                ',&
&'DESCRIPTION                                                                     ',&
&'   Report the current time or a Fortran date vector in a variety of formats.    ',&
&'   Julian dates, Unix Epoch time, weekdays, monthnames, ordinal days,           ',&
&'   AM/PM and iso-8601 week-numbering are supported by building a format         ',&
&'   string containing the desired macros.                                        ',&
&'OPTIONS                                                                         ',&
&'   Format  :                                                                    ',&
&'     This string, containing macro names or keywords, creates the format used   ',&
&'     to print the specified date.                                               ',&
&'                                                                                ',&
&'     The FORMAT string is expanded using the following macros:                  ',&
&'                                                                                ',&
&'CALL FMTDATE_USAGE                                                              ',&
&'                                                                                ',&
&'   -dat date_vector  :                                                          ',&
&'      A date vector is eight integers representing a date in the same manner as ',&
&'      the Fortran DATE_AND_TIME(3f) function:                                   ',&
&'          yyyy mm dd zone hh mm ss mss                                          ',&
&'      only numeric time zones are supported.                                    ',&
&'                                                                                ',&
&'      When present, the specified date is used instead of the current time.     ',&
&'                                                                                ',&
&'   -uet Unix_Epoch_Time  :                                                      ',&
&'      When present a value is used as the Unix Epoch Time. This date is         ',&
&'      is then adjusted using any -delta value and then printed using            ',&
&'      the specified format.                                                     ',&
&'                                                                                ',&
&'   -jed Julian_Date  :                                                          ',&
&'      When present a value is used as the Julian Ephemeris Date.                ',&
&'                                                                                ',&
&'   -delta dd-hh:mm:ss  :                                                        ',&
&'      Add the specified duration to the date.                                   ',&
&'                                                                                ',&
&'   -date date_str  :                                                            ',&
&'      The guessdate(3f) routine is used to try to convert a date description    ',&
&'      to a date vector. For the guess to work, dates must either be in the      ',&
&'      form YYYY-MM-DD or the order of numeric values must be ""dd yy yyy".      ',&
&'      Only four-digit years are supported. Month names are preferred over       ',&
&'      numeric values. See the guessdate(3f) documentation for further details.  ',&
&'                                                                                ',&
&'   -test :                                                                      ',&
&'      To list allowed macros use the -test switch.                              ',&
&'                                                                                ',&
&'   When present, the specified date is used instead of the current time.        ',&
&'EXAMPLES                                                                        ',&
&' Sample commands:                                                               ',&
&'                                                                                ',&
&'  now                                                                           ',&
&'    Friday, June 17th, 2016 03:22:53 PM UTC-4:00                                ',&
&'                                                                                ',&
&'  now -delta  1-0:0:0  # Tomorrow                                               ',&
&'    Sunday, June 19th, 2016 11:32:26 AM UTC-4:00                                ',&
&'                                                                                ',&
&'  now -delta -1-0:0:0  # Yesterday                                              ',&
&'    Friday, June 17th, 2016 11:32:43 AM UTC-4:00                                ',&
&'                                                                                ',&
&'  now long -delta  7-0:0:0  # Next week                                         ',&
&'    Saturday, June 25th, 2016 11:32:57 AM UTC-04:00                             ',&
&'                                                                                ',&
&'  now The date is %Y/%M/%D %h:%m:%s  # user-specified formats using macros      ',&
&'    The date is 2009/08/10 00:33:48                                             ',&
&'                                                                                ',&
&'  now Y/M/D h:m:s # user-specified format with no % character                   ',&
&'    2009/08/10 00:33:48                                                         ',&
&'                                                                                ',&
&'  now year-month-day # user-specified format with no % with long keywords       ',&
&'  2016-07-29                                                                    ',&
&'                                                                                ',&
&'  now -dat 2016 07 23 -240 1 01 00 00  # alternate date                         ',&
&'  Saturday, July 23rd, 2016 1:01:00 AM UTC-4:00                                 ',&
&'                                                                                ',&
&'  now -uet  1469250060                 # alternate Unix Epoch date              ',&
&'  now -date January 4th, 1999 10:20:30 # try to determine date from description.',&
&'                                                                                ',&
&'  now YEAR=%Y MONTH=%M DAY=%D          # YEAR=2009 MONTH=08 DAY=10              ',&
&'                                                                                ',&
&'  now HOUR=%h MINUTES=%m SECONDS=%s MILLISECONDS=%x                             ',&
&'      HOUR=01 MINUTES=18 SECONDS=44 MILLISECONDS=946                            ',&
&'                                                                                ',&
&'  # double-quotes are tricky (double them) to put in literally in this program: ',&
&'  now ''""year-month-day"",""hour-minute-second""'' #  "2017-04-23","14-41-09"  ',&
&'                                                                                ',&
&'  # quotes are easier to control using the single-letter macros(use %q and %Q): ',&
&'  now QY-M-DQ,Qh:m:sQ                                                           ',&
&'     "2017-04-23","14-41-09"                                                    ',&
&'                                                                                ',&
&'  now -test       # Show formatting options, handy way to look up macro names   ',&
&'                                                                                ',&
&'LIMITS                                                                          ',&
&'  See the M_time module description. Basically, A Gregorian Calendar is         ',&
&'  assumed, and Leap Seconds are not specifically accounted for.                 ',&
&'SEE ALSO                                                                        ',&
&'   month(1), sec2days(1), days2sec(1), easter(1), paws(1), today(1), ttee(1)    ',&
&'AUTHOR                                                                          ',&
&'   John S. Urban                                                                ',&
&'LICENSE                                                                         ',&
&'   Public Domain                                                                ',&
&'                                                                                ']

do i=1,size(text)
   select case (text(i))
   case('CALL FMTDATE_USAGE')
      call fmtdate_usage(6)
   case default
      write(*,'(a)')trim(text(i))
   end select
enddo

stop
end subroutine usage
subroutine help_version(l_version)
implicit none
! @(#)help_version(3f): prints version information
logical,intent(in)             :: l_version
character(len=:),allocatable   :: help_text(:)
integer                        :: i
if(l_version)then
help_text=[ CHARACTER(LEN=128) :: &
'@(#)PRODUCT:        GPF (General Purpose Fortran) utilities and examples>',&
'@(#)PROGRAM:        now(1f)>',&
'@(#)DESCRIPTION:    Report a date in a variety of formats>',&
'@(#)VERSION:        1.0, 2009>',&
'@(#)AUTHOR:         John S. Urban>',&
'@(#)REPORTING BUGS: http://www.urbanjost.altervista.org/>',&
'@(#)HOME PAGE:      http://www.urbanjost.altervista.org/index.html>',&
'@(#)COPYRIGHT:      Copyright (C) 2009 John S. Urban>',&
'@(#)LICENSE:        Public Domain. This is free software: you are free to change and redistribute it.>',&
'@(#)                There is NO WARRANTY, to the extent permitted by law.>',&
'@(#)COMPILED:       Mon, Dec 28th, 2020 12:47:39 PM>',&
'']
   WRITE(*,'(a)')(trim(help_text(i)(5:len_trim(help_text(i),kind=kind(1))-1)),i=1,size(help_text))
   stop ! if -version was specified, stop
endif
end subroutine help_version
!-----------------------------------------------------------------------------------------------------------------------------------
end program display_date
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================


0 = \x . \y . y
s = \x . \y . \z . y (x y z)

1 = s 0
2 = s 0

+ = \n1 . \n2 . \f . \x . n2 f (n1 f x)
* = \n1 . \n2 . \f . n1 (n2 f)

-----------------

+ 1 2


! $Id$
! -----------------------------------------------------------
! Module splines
! -----------------------------------------------------------
! Code area 9: general
! -----------------------------------------------------------

!!****h* Conquest/spline_module
!!  NAME
!!
!!  PURPOSE
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   23/05/01
!!  MODIFICATION HISTORY
!!   31/05/2001 dave
!!    Added RCS Id tag to header, increased ROBODoc documentation
!!   20/06/2001 dave
!!    Added RCS Log tag and cq_abort
!!   15:48, 08/04/2003 drb
!!    Bug fixes in splint and dsplint
!!   2019/08/14 16:37 dave
!!    Replacing NR routines
!!***
module splines

  use global_module, only: area_general

  implicit none

contains

! -----------------------------------------------------------
! Subroutine spline
! -----------------------------------------------------------

!!****f* splines/spline *
!!
!!  NAME
!!   spline
!!  USAGE
!!
!!  PURPOSE
!!   Given an array y(1:n) containing a function tabulated at
!!   REGULAR intervals with spacing delta_x, and given values
!!   dy1 and dyn for the first derivative of the function at
!!   the end points, this subroutine returns an array d2y(1:n)
!!   containing the second derivatives of the interpolating
!!   function at the tabulated points. If dy1 and/or dyn are
!!   equal or larger than BIG, the routine is signaled to set
!!   the corresponding boundary condition for a natural spline,
!!   with zero second derivative at that point.
!!
!!   Uses LAPACK dptsv to solve symmetric tridiagonal linear equation
!!  INPUTS
!!   integer :: n - size of table to be splined
!!   real(double) :: delta_x - spacing of values in table
!!   real(double) :: dy1, dyn - end points giving boundaries
!!   real(double), dimension(n) :: y, d2y - table and second derivative
!!  USES
!!   datatypes, numbers
!!  AUTHOR
!!   D. R. Bowler
!!  CREATION DATE
!!   2019/08/13
!!  MODIFICATION HISTORY
!!  SOURCE
  subroutine spline( n, delta_x, y, dy1, dyn, d2y )

    use datatypes
    use numbers
    use GenComms, only: cq_abort
    use memory_module, only: reg_alloc_mem, reg_dealloc_mem, type_dbl

    implicit none

    ! Passed variables
    integer :: n

    real(double) :: delta_x, dy1, dyn
    real(double), dimension(n) :: y, d2y

    ! Local variables
    integer :: i, stat, info
    real(double), dimension(:), allocatable :: b, d, du
    external :: dptsv

    allocate(b(n), d(n), du(n-1),STAT=stat)
    if (stat /= 0) call cq_abort("spline: Error alloc mem: ", n)
    call reg_alloc_mem(area_general, 3*n, type_dbl)

    b = zero
    ! Diagonal (d) and sub-diagonal (du) entries in matrix
    d = four
    du = one

    ! Now set up RHS of linear equation
    if (dy1 > BIG) then ! lower boundary condition set to 'natural'
       b(1) = zero
       b(n) = zero
    else ! or else to have a specified first derivative: 'clamped'
       b(1) = (six/delta_x) * ((y(2) - y(1))/delta_x - dy1 )
       b(n) = (six/delta_x) * (dyn - (y(n) - y(n-1))/delta_x )
       d(1) = two
       d(n) = two
    end if
    do i = 2, n-1
       b(i) = six*(y(i-1) - two*y(i) + y(i+1))/(delta_x * delta_x)
    end do
    ! Solution of A.x = b is returned in b
    call dptsv(n, 1, d, du, b, n, info)
    if(info/=0) call cq_abort("spline: error in dptsv, info is ",info)
    d2y = b
    if(dy1 > BIG) then
       d2y(1) = zero
       d2y(n) = zero
    end if
    deallocate(d,b,du)
    return
  end subroutine spline
!!***

! -----------------------------------------------------------
! Subroutine spline_nonU
! -----------------------------------------------------------

!!****f* splines/spline_nonU *
!!
!!  NAME
!!   spline_nonU - makes a spline table for non-uniform x array
!!  USAGE
!!   spline_nonU(n, x, y, dy1, dyn, d2y)
!!  PURPOSE
!!   Given an array y(1:n) containing a function tabulated at
!!   IRREGULAR intervals given by array x(1:n), and given values
!!   yp1 and ypn for the first derivative of the function at
!!   the end points, this subroutine returns an array d2y(1:n)
!!   containing the second derivatives of the interpolating
!!   function at the tabulated points. If dy1 and/or dyn are
!!   equal or larger than BIG, the routine is signaled to set
!!   the corresponding boundary condition for a natural spline,
!!   with zero second derivative at that point.
!!
!!   Uses LAPACK dgtsv to solve general tridiagonal linear equation
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   2019/08/15
!!  MODIFICATION HISTORY
!!  SOURCE
!!
  subroutine spline_nonU( n, x, y, dy1, dyn, d2y )

    use datatypes
    use numbers
    use GenComms, only: cq_abort
    use memory_module, only: reg_alloc_mem, reg_dealloc_mem, type_dbl

    implicit none

    ! Passed variables
    integer :: n

    real(double) :: dy1, dyn
    real(double), dimension(n) :: x, y, d2y

    ! Local variables
    integer :: i, stat, info
    real(double), dimension(:), allocatable :: b, d, du, dl
    external :: dgtsv

    allocate(b(n), d(n), dl(n-1), du(n-1),STAT=stat)
    if (stat /= 0) call cq_abort("spline: Error alloc mem: ", n)
    call reg_alloc_mem(area_general, 3*n, type_dbl)

    b = zero

    ! Now set up RHS of linear equation
    if (dy1 > BIG) then ! lower boundary condition set to 'natural'
       b(1) = zero
       b(n) = zero
       d(1) = four*(x(2) - x(1))
       d(n) = four*(x(n) - x(n-1))
    else ! or else to have a specified first derivative: 'clamped'
       b(1) = six * ( (y(2) - y(1))/(x(2) - x(1)) - dy1 )
       b(n) = six * ( dyn - (y(n) - y(n-1))/(x(n) - x(n-1)) )
       d(1) = two*(x(2) - x(1))
       d(n) = two*(x(n) - x(n-1))
    end if
    do i = 2, n-1
       dl(i-1) = x(i) - x(i-1)
       d(i)  = two * ( x(i+1) - x(i-1) )
       du(i) = x(i+1) - x(i)
       b(i)  = six*(y(i-1) - y(i))/(x(i) - x(i-1)) + &
            six*(y(i+1) - y(i))/(x(i+1) - x(i))
    end do
    du(1) = x(2) - x(1)
    dl(n-1) = x(n) - x(n-1)
    ! Solution of A.x = b is returned in b
    call dgtsv(n, 1, dl, d, du, b, n, info)
    if(info/=0) call cq_abort("spline: error in dgtsv, info is ",info)
    d2y = b
    if(dy1 > BIG) then
       d2y(1) = zero
       d2y(n) = zero
    end if
    deallocate(d,b,du)
    return
  end subroutine spline_nonU
!!***

end module splines


!*==cgesvx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!
!> \brief  CGESVX computes the solution to system of linear equations A * X = B for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGESVX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
!                          EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
!                          WORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          EQUED, FACT, TRANS
!       INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
!       REAL               RCOND
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       REAL               BERR( * ), C( * ), FERR( * ), R( * ),
!      $                   RWORK( * )
!       COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
!      $                   WORK( * ), X( LDX, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGESVX uses the LU factorization to compute the solution to a complex
!> system of linear equations
!>    A * X = B,
!> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
!>
!> Error bounds on the solution and a condition estimate are also
!> provided.
!> \endverbatim
!
!> \par Description:
!  =================
!>
!> \verbatim
!>
!> The following steps are performed:
!>
!> 1. If FACT = 'E', real scaling factors are computed to equilibrate
!>    the system:
!>       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
!>       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
!>       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
!>    Whether or not the system will be equilibrated depends on the
!>    scaling of the matrix A, but if equilibration is used, A is
!>    overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
!>    or diag(C)*B (if TRANS = 'T' or 'C').
!>
!> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
!>    matrix A (after equilibration if FACT = 'E') as
!>       A = P * L * U,
!>    where P is a permutation matrix, L is a unit lower triangular
!>    matrix, and U is upper triangular.
!>
!> 3. If some U(i,i)=0, so that U is exactly singular, then the routine
!>    returns with INFO = i. Otherwise, the factored form of A is used
!>    to estimate the condition number of the matrix A.  If the
!>    reciprocal of the condition number is less than machine precision,
!>    INFO = N+1 is returned as a warning, but the routine still goes on
!>    to solve for X and compute error bounds as described below.
!>
!> 4. The system of equations is solved for X using the factored form
!>    of A.
!>
!> 5. Iterative refinement is applied to improve the computed solution
!>    matrix and calculate error bounds and backward error estimates
!>    for it.
!>
!> 6. If equilibration was used, the matrix X is premultiplied by
!>    diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
!>    that it solves the original system before equilibration.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] FACT
!> \verbatim
!>          FACT is CHARACTER*1
!>          Specifies whether or not the factored form of the matrix A is
!>          supplied on entry, and if not, whether the matrix A should be
!>          equilibrated before it is factored.
!>          = 'F':  On entry, AF and IPIV contain the factored form of A.
!>                  If EQUED is not 'N', the matrix A has been
!>                  equilibrated with scaling factors given by R and C.
!>                  A, AF, and IPIV are not modified.
!>          = 'N':  The matrix A will be copied to AF and factored.
!>          = 'E':  The matrix A will be equilibrated if necessary, then
!>                  copied to AF and factored.
!> \endverbatim
!>
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of linear equations, i.e., the order of the
!>          matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is
!>          not 'N', then A must have been equilibrated by the scaling
!>          factors in R and/or C.  A is not modified if FACT = 'F' or
!>          'N', or if FACT = 'E' and EQUED = 'N' on exit.
!>
!>          On exit, if EQUED .ne. 'N', A is scaled as follows:
!>          EQUED = 'R':  A := diag(R) * A
!>          EQUED = 'C':  A := A * diag(C)
!>          EQUED = 'B':  A := diag(R) * A * diag(C).
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] AF
!> \verbatim
!>          AF is COMPLEX array, dimension (LDAF,N)
!>          If FACT = 'F', then AF is an input argument and on entry
!>          contains the factors L and U from the factorization
!>          A = P*L*U as computed by CGETRF.  If EQUED .ne. 'N', then
!>          AF is the factored form of the equilibrated matrix A.
!>
!>          If FACT = 'N', then AF is an output argument and on exit
!>          returns the factors L and U from the factorization A = P*L*U
!>          of the original matrix A.
!>
!>          If FACT = 'E', then AF is an output argument and on exit
!>          returns the factors L and U from the factorization A = P*L*U
!>          of the equilibrated matrix A (see the description of A for
!>          the form of the equilibrated matrix).
!> \endverbatim
!>
!> \param[in] LDAF
!> \verbatim
!>          LDAF is INTEGER
!>          The leading dimension of the array AF.  LDAF >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>          If FACT = 'F', then IPIV is an input argument and on entry
!>          contains the pivot indices from the factorization A = P*L*U
!>          as computed by CGETRF; row i of the matrix was interchanged
!>          with row IPIV(i).
!>
!>          If FACT = 'N', then IPIV is an output argument and on exit
!>          contains the pivot indices from the factorization A = P*L*U
!>          of the original matrix A.
!>
!>          If FACT = 'E', then IPIV is an output argument and on exit
!>          contains the pivot indices from the factorization A = P*L*U
!>          of the equilibrated matrix A.
!> \endverbatim
!>
!> \param[in,out] EQUED
!> \verbatim
!>          EQUED is CHARACTER*1
!>          Specifies the form of equilibration that was done.
!>          = 'N':  No equilibration (always true if FACT = 'N').
!>          = 'R':  Row equilibration, i.e., A has been premultiplied by
!>                  diag(R).
!>          = 'C':  Column equilibration, i.e., A has been postmultiplied
!>                  by diag(C).
!>          = 'B':  Both row and column equilibration, i.e., A has been
!>                  replaced by diag(R) * A * diag(C).
!>          EQUED is an input argument if FACT = 'F'; otherwise, it is an
!>          output argument.
!> \endverbatim
!>
!> \param[in,out] R
!> \verbatim
!>          R is REAL array, dimension (N)
!>          The row scale factors for A.  If EQUED = 'R' or 'B', A is
!>          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!>          is not accessed.  R is an input argument if FACT = 'F';
!>          otherwise, R is an output argument.  If FACT = 'F' and
!>          EQUED = 'R' or 'B', each element of R must be positive.
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is REAL array, dimension (N)
!>          The column scale factors for A.  If EQUED = 'C' or 'B', A is
!>          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!>          is not accessed.  C is an input argument if FACT = 'F';
!>          otherwise, C is an output argument.  If FACT = 'F' and
!>          EQUED = 'C' or 'B', each element of C must be positive.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the N-by-NRHS right hand side matrix B.
!>          On exit,
!>          if EQUED = 'N', B is not modified;
!>          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
!>          diag(R)*B;
!>          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
!>          overwritten by diag(C)*B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] X
!> \verbatim
!>          X is COMPLEX array, dimension (LDX,NRHS)
!>          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
!>          to the original system of equations.  Note that A and B are
!>          modified on exit if EQUED .ne. 'N', and the solution to the
!>          equilibrated system is inv(diag(C))*X if TRANS = 'N' and
!>          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
!>          and EQUED = 'R' or 'B'.
!> \endverbatim
!>
!> \param[in] LDX
!> \verbatim
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!> \endverbatim
!>
!> \param[out] RCOND
!> \verbatim
!>          RCOND is REAL
!>          The estimate of the reciprocal condition number of the matrix
!>          A after equilibration (if done).  If RCOND is less than the
!>          machine precision (in particular, if RCOND = 0), the matrix
!>          is singular to working precision.  This condition is
!>          indicated by a return code of INFO > 0.
!> \endverbatim
!>
!> \param[out] FERR
!> \verbatim
!>          FERR is REAL array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!> \endverbatim
!>
!> \param[out] BERR
!> \verbatim
!>          BERR is REAL array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (2*N)
!>          On exit, RWORK(1) contains the reciprocal pivot growth
!>          factor norm(A)/norm(U). The "max absolute element" norm is
!>          used. If RWORK(1) is much less than 1, then the stability
!>          of the LU factorization of the (equilibrated) matrix A
!>          could be poor. This also means that the solution X, condition
!>          estimator RCOND, and forward error bound FERR could be
!>          unreliable. If factorization fails with 0<INFO<=N, then
!>          RWORK(1) contains the reciprocal pivot growth factor for the
!>          leading INFO columns of A.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, and i is
!>                <= N:  U(i,i) is exactly zero.  The factorization has
!>                       been completed, but the factor U is exactly
!>                       singular, so the solution and error bounds
!>                       could not be computed. RCOND = 0 is returned.
!>                = N+1: U is nonsingular, but RCOND is less than machine
!>                       precision, meaning that the matrix is singular
!>                       to working precision.  Nevertheless, the
!>                       solution and error bounds are computed because
!>                       there are a number of situations where the
!>                       computed solution can be more accurate than the
!>                       value of RCOND would suggest.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup complexGEsolve
!
!  =====================================================================
      SUBROUTINE CGESVX(Fact,Trans,N,Nrhs,A,Lda,Af,Ldaf,Ipiv,Equed,R,C, &
     &                  B,Ldb,X,Ldx,Rcond,Ferr,Berr,Work,Rwork,Info)
      IMPLICIT NONE
!*--CGESVX354
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!     .. Scalar Arguments ..
      CHARACTER Equed , Fact , Trans
      INTEGER Info , Lda , Ldaf , Ldb , Ldx , N , Nrhs
      REAL Rcond
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      REAL Berr(*) , C(*) , Ferr(*) , R(*) , Rwork(*)
      COMPLEX A(Lda,*) , Af(Ldaf,*) , B(Ldb,*) , Work(*) , X(Ldx,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL colequ , equil , nofact , notran , rowequ
      CHARACTER norm
      INTEGER i , infequ , j
      REAL amax , anorm , bignum , colcnd , rcmax , rcmin , rowcnd ,    &
     &     rpvgrw , smlnum
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      REAL CLANGE , CLANTR , SLAMCH
      EXTERNAL LSAME , CLANGE , CLANTR , SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL CGECON , CGEEQU , CGERFS , CGETRF , CGETRS , CLACPY ,    &
     &         CLAQGE , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
      Info = 0
      nofact = LSAME(Fact,'N')
      equil = LSAME(Fact,'E')
      notran = LSAME(Trans,'N')
      IF ( nofact .OR. equil ) THEN
         Equed = 'N'
         rowequ = .FALSE.
         colequ = .FALSE.
      ELSE
         rowequ = LSAME(Equed,'R') .OR. LSAME(Equed,'B')
         colequ = LSAME(Equed,'C') .OR. LSAME(Equed,'B')
         smlnum = SLAMCH('Safe minimum')
         bignum = ONE/smlnum
      ENDIF
!
!     Test the input parameters.
!
      IF ( .NOT.nofact .AND. .NOT.equil .AND. .NOT.LSAME(Fact,'F') )    &
     &     THEN
         Info = -1
      ELSEIF ( .NOT.notran .AND. .NOT.LSAME(Trans,'T') .AND.            &
     &         .NOT.LSAME(Trans,'C') ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Nrhs<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldaf<MAX(1,N) ) THEN
         Info = -8
      ELSEIF ( LSAME(Fact,'F') .AND.                                    &
     &         .NOT.(rowequ .OR. colequ .OR. LSAME(Equed,'N')) ) THEN
         Info = -10
      ELSE
         IF ( rowequ ) THEN
            rcmin = bignum
            rcmax = ZERO
            DO j = 1 , N
               rcmin = MIN(rcmin,R(j))
               rcmax = MAX(rcmax,R(j))
            ENDDO
            IF ( rcmin<=ZERO ) THEN
               Info = -11
            ELSEIF ( N>0 ) THEN
               rowcnd = MAX(rcmin,smlnum)/MIN(rcmax,bignum)
            ELSE
               rowcnd = ONE
            ENDIF
         ENDIF
         IF ( colequ .AND. Info==0 ) THEN
            rcmin = bignum
            rcmax = ZERO
            DO j = 1 , N
               rcmin = MIN(rcmin,C(j))
               rcmax = MAX(rcmax,C(j))
            ENDDO
            IF ( rcmin<=ZERO ) THEN
               Info = -12
            ELSEIF ( N>0 ) THEN
               colcnd = MAX(rcmin,smlnum)/MIN(rcmax,bignum)
            ELSE
               colcnd = ONE
            ENDIF
         ENDIF
         IF ( Info==0 ) THEN
            IF ( Ldb<MAX(1,N) ) THEN
               Info = -14
            ELSEIF ( Ldx<MAX(1,N) ) THEN
               Info = -16
            ENDIF
         ENDIF
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGESVX',-Info)
         RETURN
      ENDIF
!
      IF ( equil ) THEN
!
!        Compute row and column scalings to equilibrate the matrix A.
!
         CALL CGEEQU(N,N,A,Lda,R,C,rowcnd,colcnd,amax,infequ)
         IF ( infequ==0 ) THEN
!
!           Equilibrate the matrix.
!
            CALL CLAQGE(N,N,A,Lda,R,C,rowcnd,colcnd,amax,Equed)
            rowequ = LSAME(Equed,'R') .OR. LSAME(Equed,'B')
            colequ = LSAME(Equed,'C') .OR. LSAME(Equed,'B')
         ENDIF
      ENDIF
!
!     Scale the right hand side.
!
      IF ( notran ) THEN
         IF ( rowequ ) THEN
            DO j = 1 , Nrhs
               DO i = 1 , N
                  B(i,j) = R(i)*B(i,j)
               ENDDO
            ENDDO
         ENDIF
      ELSEIF ( colequ ) THEN
         DO j = 1 , Nrhs
            DO i = 1 , N
               B(i,j) = C(i)*B(i,j)
            ENDDO
         ENDDO
      ENDIF
!
      IF ( nofact .OR. equil ) THEN
!
!        Compute the LU factorization of A.
!
         CALL CLACPY('Full',N,N,A,Lda,Af,Ldaf)
         CALL CGETRF(N,N,Af,Ldaf,Ipiv,Info)
!
!        Return if INFO is non-zero.
!
         IF ( Info>0 ) THEN
!
!           Compute the reciprocal pivot growth factor of the
!           leading rank-deficient INFO columns of A.
!
            rpvgrw = CLANTR('M','U','N',Info,Info,Af,Ldaf,Rwork)
            IF ( rpvgrw==ZERO ) THEN
               rpvgrw = ONE
            ELSE
               rpvgrw = CLANGE('M',N,Info,A,Lda,Rwork)/rpvgrw
            ENDIF
            Rwork(1) = rpvgrw
            Rcond = ZERO
            RETURN
         ENDIF
      ENDIF
!
!     Compute the norm of the matrix A and the
!     reciprocal pivot growth factor RPVGRW.
!
      IF ( notran ) THEN
         norm = '1'
      ELSE
         norm = 'I'
      ENDIF
      anorm = CLANGE(norm,N,N,A,Lda,Rwork)
      rpvgrw = CLANTR('M','U','N',N,N,Af,Ldaf,Rwork)
      IF ( rpvgrw==ZERO ) THEN
         rpvgrw = ONE
      ELSE
         rpvgrw = CLANGE('M',N,N,A,Lda,Rwork)/rpvgrw
      ENDIF
!
!     Compute the reciprocal of the condition number of A.
!
      CALL CGECON(norm,N,Af,Ldaf,anorm,Rcond,Work,Rwork,Info)
!
!     Compute the solution matrix X.
!
      CALL CLACPY('Full',N,Nrhs,B,Ldb,X,Ldx)
      CALL CGETRS(Trans,N,Nrhs,Af,Ldaf,Ipiv,X,Ldx,Info)
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL CGERFS(Trans,N,Nrhs,A,Lda,Af,Ldaf,Ipiv,B,Ldb,X,Ldx,Ferr,Berr,&
     &            Work,Rwork,Info)
!
!     Transform the solution matrix X to a solution of the original
!     system.
!
      IF ( notran ) THEN
         IF ( colequ ) THEN
            DO j = 1 , Nrhs
               DO i = 1 , N
                  X(i,j) = C(i)*X(i,j)
               ENDDO
            ENDDO
            DO j = 1 , Nrhs
               Ferr(j) = Ferr(j)/colcnd
            ENDDO
         ENDIF
      ELSEIF ( rowequ ) THEN
         DO j = 1 , Nrhs
            DO i = 1 , N
               X(i,j) = R(i)*X(i,j)
            ENDDO
         ENDDO
         DO j = 1 , Nrhs
            Ferr(j) = Ferr(j)/rowcnd
         ENDDO
      ENDIF
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF ( Rcond<SLAMCH('Epsilon') ) Info = N + 1
!
      Rwork(1) = rpvgrw
!
!     End of CGESVX
!
      END SUBROUTINE CGESVX


    module determinant_func
    CONTAINS
        subroutine determinant(matrix, deter_value)
            REAL(8), dimension(3, 3), intent(in) :: matrix
            REAL(8), intent(out) :: deter_value
            deter_value=(matrix(1,1)*matrix(2,2)*matrix(3,3)+matrix(1,2)*matrix(2,3)*matrix(3,1)&
                    +matrix(1,3)*matrix(2,1)*matrix(3,2)&
                    -matrix(3,1)*matrix(2,2)*matrix(1,3)-matrix(2,1)*matrix(1,2)*matrix(3,3)&
                    -matrix(1,1)*matrix(3,2)*matrix(2,3))
        end subroutine determinant
    end module determinant_func

    module distance
    CONTAINS
      subroutine distance_info(atom_coords_i, atom_coords_j, bds, pbc, r, d)

          REAL(8), dimension(3), intent(in) :: atom_coords_i, atom_coords_j
          REAL(8), dimension(3), intent(out):: r
          REAL(8), intent(out) :: d
          REAL(8), dimension(3, 2) :: bds
          REAL(8), dimension(3) :: Lens
          integer, dimension(3) :: pbc

          Lens(1) = bds(1, 2) - bds(1, 1)
          Lens(2) = bds(2, 2) - bds(2, 1)
          Lens(3) = bds(3, 2) - bds(3, 1)

          do m = 1, 3
            r(m) = atom_coords_i(m) - atom_coords_j(m)
!            write(*, *) r(m), atom_coords_i(m), atom_coords_j(m)
            if (pbc(m) == 1) then
              if (r(m) > Lens(m)*0.5) then
                r(m) = (r(m) - Lens(m))
              else if (r(m) < Lens(m)*(-0.5)) then
                r(m) = (r(m) + Lens(m))
              else
                r(m) = r(m)  ! why divided by 2?
              end if
            end if
          end do

          d = sqrt(r(1)**2 + r(2)**2 + r(3)**2)
      end subroutine distance_info
    end module distance

    module quicksort
    CONTAINS
      recursive subroutine quick_sort(array, sort_col, &
          sort_index_min, sort_index_max)
      implicit none
      integer :: sort_col, sort_index_min, sort_index_max
      REAL(8), dimension(:, :) :: array

      REAL(8), dimension(size(array, 2)) :: trans
      REAL(8) :: x
      integer i, j

      x = array((sort_index_min + sort_index_max) / 2, sort_col)   !!integer division
      i = sort_index_min
      j = sort_index_max

      do
        do while (array(i, sort_col) < x)
          i = i + 1
        end do
        do while (x < array(j, sort_col))
          j = j - 1
        end do

        if (i >= j) then
            exit
        end if

        trans = array(i, :)
        array(i, :) = array(j, :)
        array(j, :) = trans

        i = i + 1
        j = j - 1
      end do

      if (sort_index_min < i - 1) then
        call quick_sort(array, sort_col, sort_index_min, i - 1)
      end if

      if (j + 1 < sort_index_max) then
        call quick_sort(array, sort_col, j + 1, sort_index_max)
      end if

      end subroutine quick_sort
    end module quicksort

    ! for boop
    module CG_function
    CONTAINS
      function calculate_CG(half_l_min, half_l_max) result(CG)
          integer, intent(in) :: half_l_min, half_l_max
          integer:: l_min, l_max
          REAL(8), dimension(half_l_min:half_l_max, -half_l_max*2:half_l_max*2, &
              -half_l_max*2:half_l_max*2, -half_l_max*2:half_l_max*2):: CG

          integer :: i, j, l, m1, m2, m3, v, s
          REAL(8) :: v0, v1, v2
          REAL(8), dimension(0:100) :: fac

          do i = 0, 50
            if(i == 0) then
              fac(i)=0
            else
              do j = 1, i
                fac(i) = fac(i) + log10(1.0*j)
              end do
            end if
          end do

          CG = 0
          l_min = half_l_min * 2
          l_max = half_l_max * 2

          do l = l_min, l_max, 2
            do m1 = -l, l
              do m2 = max(-l, -l-m1), min(l, l-m1)
                m3 = -(m1 + m2)
                s = 0
                v2 = 0
                do v = max(0, -m1, m2), min(l, l-m1, l+m2)
                  s = s + 1
                  v1 = fac(v) + fac(l-v) + fac(l-m1-v) + fac(l+m2-v) + fac(-m2+v) + fac(m1+v)
                  if(s.eq.1) then
                    v0 = v1
                  end if
                  v2 = v2 + (-1)**(-v) * 10**(1.0*(v0-v1))
                end do
                CG(l/2, m1, m2, m3) = 10**(1.0/2 * &
                    (log10(1.0*2*l+1) + 3*fac(l)-fac(3*l+1) + &
                    fac(l+m1)+fac(l-m1)+fac(l+m2)+fac(l-m2)+fac(l+m3)+fac(l-m3))-v0) * v2 * &
                    (-1)**(-m3) / sqrt(1.0*(2*l+1))
              end do
            end do
          end do

      end function calculate_CG
    end module

    ! for boop
    module angle

    CONTAINS
      subroutine angle_info(atom_coords_i, atom_coords_j, bds, pbc, ksai, theta)
      REAL(8), dimension(3), intent(in) :: atom_coords_i, atom_coords_j
      REAL(8), intent(out) :: ksai, theta
      REAL(8), dimension(3, 2), intent(in) :: bds
      integer, dimension(3), intent(in) :: pbc
      REAL(8), dimension(3) :: r
      REAL(8) :: d
      REAL(8), dimension(3) :: Lens
      integer :: m

      Lens(1) = bds(1, 2) - bds(1, 1)
      Lens(2) = bds(2, 2) - bds(2, 1)
      Lens(3) = bds(3, 2) - bds(3, 1)

      do m = 1, 3
        r(m) = atom_coords_i(m) - atom_coords_j(m)
        if (pbc(m) == 1) then
          if (r(m) > Lens(m)*0.5) then
            r(m) = (r(m) - Lens(m)) / 2.0
          else if (r(m) < Lens(m)*(-0.5)) then
            r(m) = (r(m) + Lens(m)) / 2.0
          else
            r(m) = r(m) / 2.0  ! why divided by 2?
          end if
        end if
      end do

      d = sqrt(r(1)**2 + r(2)**2 + r(3)**2)
      ksai = atan(r(2) / r(1))
      theta = acos(r(3) / d)

      end subroutine angle_info
    end module

    module c_stats
    contains
    function customize_stats(list, stats_types, stats_types_sum, self_prop) result(stats)
        REAL(8), dimension(:) :: list
        integer, dimension(:) :: stats_types
        REAL(8) :: self_prop
        integer:: list_len, atom, i, j, stats_types_sum
        REAL(8), dimension(6) :: stats_all
        REAL(8), dimension(stats_types_sum) :: stats
        REAL(8) :: prop, sum_stat, mean_stat, std_stat, min_stat, max_stat, diff_stat

        list_len = size(list)
        min_stat = list(1)
        max_stat = min_stat
        sum_stat = 0
        mean_stat = 0
        std_stat = 0

        do atom = 1, list_len
            prop = list(atom)
            sum_stat = sum_stat + prop
            if (prop > max_stat) then
                max_stat = prop
            end if

            if (prop < min_stat) then
                min_stat = prop
            end if
        end do

        mean_stat = sum_stat / list_len

        if (stats_types(3) == 1) then
          do atom = 1, list_len
            std_stat = std_stat + (list(atom) - mean_stat)**2
          end do
          std_stat = sqrt(std_stat / list_len)
        end if

        if (stats_types(6) == 1) then
          diff_stat = mean_stat - self_prop
        end if

        stats_all(1) = sum_stat
        stats_all(2) = mean_stat
        stats_all(3) = std_stat
        stats_all(4) = min_stat
        stats_all(5) = max_stat
        stats_all(6) = diff_stat

        i = 0
        do j = 1, 6
          if (stats_types(j) == 1) then
            i = i + 1
            stats(i) = stats_all(j)
          end if
        end do

    end function customize_stats
    end module c_stats

    module a_stats
    contains
    function all_stats(list, len) result(stats)
        REAL(8), dimension(len) :: list(len)
        integer :: len, atom
        REAL(8) :: s, mean, sum, min, max
        REAL(16) :: std
        REAL(8), dimension(5) :: stats

        min = list(1)
        max = min
        mean = 0
        sum = 0
        std = 0
        if (len.eq.0) then
            len = 1
        end if
        do atom = 1, len
            s = list(atom)
            sum = sum + s
            if (s > max) then
                max = s
            end if

            if (s < min) then
                min = s
            end if
        end do

        mean = sum / len

        do atom = 1, len
            std = std + (list(atom) - mean)**2
        end do
        std = sqrt(std / len)

        stats(1) = sum
        stats(2) = mean
        stats(3) = std
        stats(4) = min
        stats(5) = max

    end function all_stats
    end module a_stats


!===============================================================================
program test_sg_gcp_to_azimuth
!===============================================================================
!  Test the sg_gcp_to_azimuth subroutine.
!  Usage: test_sg_gcp_to_azimuth [long] [latg] [lonp] [latp]

   use spherical_geometry, only: sg_gcp_to_azimuth

   implicit none
   integer, parameter :: rs = 8
   real(rs) :: long,latg,lonp,latp,azi
   character(len=250) :: arg

   ! Pole to Greenwich meridian
   long = -90.
   latg = 0.

   ! Point on the equator
   lonp = 0.
   latp = 0.

   ! If we've supplied some arguments, use them
   if (command_argument_count() == 4) then
      call get_command_argument(1,arg)
      read(arg,*) long
      call get_command_argument(2,arg)
      read(arg,*) latg
      call get_command_argument(3,arg)
      read(arg,*) lonp
      call get_command_argument(4,arg)
      read(arg,*) latp
   endif

   write(*,'(f0.6)') sg_gcp_to_azimuth(long,latg,lonp,latp,degrees=.true.)

end program test_sg_gcp_to_azimuth
!-------------------------------------------------------------------------------


      PROGRAM MAIN

      INTEGER N, NMAX, IL, IU, M, LDA, LDB, ZERO,
     $        SEED
      PARAMETER (NMAX=1000, LDA=NMAX, LDB=NMAX, ZERO=0,
     $           SEED=1267893)

      DOUBLE PRECISION VL, VU, A(NMAX,NMAX), B(NMAX,NMAX),
     $                 W(NMAX)

      INTEGER ITYPE, I, J, IERR

*     external functions
      EXTERNAL DSYGEIG

*     Intialize symmetric matrices A and B of size N-by-N full
*     such that either only the upper or lower triangular part
*     can later be used
      N = 100

      CALL SRAND(SEED)
      DO 100, J=1,N
         DO 200, I=1,J
            A(I,J) = RAND()
            B(I,J) = RAND()
            IF (I .EQ. J) THEN
               B(I,J) = B(I,J) + N
            ENDIF
 200     CONTINUE
 100  CONTINUE

      DO 300, J=1,N
         DO 400, I=J+1,N
            A(I,J) = A(J,I)
            B(I,J) = B(J,I)
 400     CONTINUE
 300  CONTINUE

*     Solve the symmetric eigenproblem with itype=1, that is
*     A*x = lambda*B*x
*     Array A contains the eigenvectors on exit
*     The number of threads for the LAPACK routines are set by
*     OMP_NUM_THREADS or GOTO_NUM_THREADS or MKL_NUM_THREADS ...
*     depending on the BLAS used. For the tridiagonal stage with
*     PMR_NUM_THREADS.
      ITYPE = 1
      IL    = 1
      IU    = N/2 + 1
      CALL DSYGEIG(ITYPE, 'V', 'I', 'L', N, A, LDA, B, LDB,
     $             VL, VU, IL, IU, M, W, IERR)
      IF (IERR .NE. 0) THEN
         WRITE(*,*) 'Routine has failed with error', IERR
      ENDIF

      WRITE(*,*) 'Sucessfully computed eigenpairs!'

      END


program spectrum

  implicit none

  character(len=100)            :: filename, units, arg

  integer                       :: rwstat, i_line, N_lines
  double precision              :: Ek, eps_total, E_nm, sigma
  double precision, allocatable :: Ek_nm(:), fk(:)
  double precision, external    :: eps_k
  double precision, parameter   :: ev2cmi =   8065.54464585453d0
  double precision, parameter   :: au2cmi = 219474.6314739536d0

  call getarg(1, arg)
  filename=trim(arg)

  call getarg(2, arg)
  units=trim(arg)

  call getarg(3, arg)
  open(unit=10, file='scr')
  write(10,*)trim(arg)
  close(10)
  open(unit=10, file='scr')
  read(10,*)sigma
  close(10)

  open(unit=10, file=trim(filename))
  N_lines=0
  loop1: do
      read(10,*,iostat=rwstat)Ek, Ek
      if ( rwstat .ne. 0) exit loop1
      N_lines=N_lines+1
  enddo loop1
  close(10)

  allocate(Ek_nm(1:N_lines), fk(1:N_lines))

  open(unit=10, file=trim(filename))
  do i_line = 1, N_lines
    read(10,*) Ek, fk(i_line)
    select case(units)
    case('au2nm')
      Ek_nm(i_line) = 1d7 / (Ek * au2cmi)
    case('ev2nm')
      Ek_nm(i_line) = 1d7 / (Ek * ev2cmi)
    case('cmi2nm')
      Ek_nm(i_line) = 1d7 / Ek
    case('nm')
      Ek_nm(i_line) = Ek
    case default
      write(*,'(a)') " ERROR: Unknown choice for the unit"
    end select
  enddo
  close(10)

  open(unit=10, file='spectrum.dat')
  E_nm   = 0d0
  loop2: do
    if ( E_nm .gt. 500d0 ) exit loop2
    eps_total = 0.0d0
    do i_line = 1, N_lines
      eps_total = eps_total + eps_k(Ek_nm(i_line), fk(i_line), E_nm, sigma)
    enddo
    E_nm = E_nm + 0.01d0
    write(10,'(2f15.8)') E_nm, eps_total
  enddo loop2
  close(10)

  open(unit=10, file='spectrumstick.dat')
  do i_line = 1, N_lines
    E_nm = Ek_nm(i_line)
    write(10,'(2f25.8)') E_nm, 10000d0
  enddo
  close(10)

  deallocate(Ek_nm, fk)
end program spectrum

double precision function eps_k(Ek_nm, fk, E_nm, sigma_ev)

  implicit none

  double precision, intent(in) :: Ek_nm, fk, E_nm, sigma_ev

  double precision, parameter  :: ev2cmi =  8065.54464585453d0
  !double precision, parameter  :: sigma_ev = 0.4d0
  double precision             :: sigma_cmi, sigma_nm

  sigma_cmi = sigma_ev * ev2cmi
  sigma_nm = 1d7 / sigma_cmi

  eps_k = 1.3062974d8 * (fk/sigma_nm) * dexp(-((1d0/E_nm-1d0/Ek_nm)/(1.0d0/sigma_nm))**2)

end function eps_k


! The Computer Language Benchmarks Game
! http://benchmarksgame.alioth.debian.org/
!
!   contributed by Simon Geard, translated from  Mark C. Williams nbody.java
!   modified by Brian Taylor
!   modified by yuankun shi
!   modified by Padraig O Conbhui

program nbody
  implicit none

  integer, parameter :: dp = kind(1.d0)

  real(kind=dp), parameter :: tstep = 0.01d0
  real(kind=dp), parameter ::  PI = 3.141592653589793d0
  real(kind=dp), parameter ::  SOLAR_MASS = 4 * PI * PI
  real(kind=dp), parameter ::  DAYS_PER_YEAR = 365.24d0

  type body
     real(kind=dp) :: x, y, z, u, vx, vy, vz, vu, mass
  end type body

  type(body), parameter :: jupiter = body( &
       4.84143144246472090d0,    -1.16032004402742839d0, &
       -1.03622044471123109d-01, 0.d0, 1.66007664274403694d-03 * DAYS_PER_YEAR, &
       7.69901118419740425d-03 * DAYS_PER_YEAR, &
       -6.90460016972063023d-05 * DAYS_PER_YEAR, 0.d0,&
       9.54791938424326609d-04 * SOLAR_MASS)

  type(body), parameter :: saturn = body( &
       8.34336671824457987d+00, &
       4.12479856412430479d+00, &
       -4.03523417114321381d-01, 0.d0, &
       -2.76742510726862411d-03 * DAYS_PER_YEAR, &
       4.99852801234917238d-03 * DAYS_PER_YEAR, &
       2.30417297573763929d-05 * DAYS_PER_YEAR, 0.d0,&
       2.85885980666130812d-04 * SOLAR_MASS)

  type(body), parameter :: uranus = body( &
       1.28943695621391310d+01, &
       -1.51111514016986312d+01, &
       -2.23307578892655734d-01, 0.d0,&
       2.96460137564761618d-03 * DAYS_PER_YEAR, &
       2.37847173959480950d-03 * DAYS_PER_YEAR, &
       -2.96589568540237556d-05 * DAYS_PER_YEAR, 0.d0,&
       4.36624404335156298d-05 * SOLAR_MASS )

  type(body), parameter :: neptune = body( &
       1.53796971148509165d+01, &
       -2.59193146099879641d+01, &
       1.79258772950371181d-01, 0.d0,&
       2.68067772490389322d-03 * DAYS_PER_YEAR, &
       1.62824170038242295d-03 * DAYS_PER_YEAR, &
       -9.51592254519715870d-05 * DAYS_PER_YEAR, 0.d0,&
       5.15138902046611451d-05 * SOLAR_MASS)

  type(body), parameter :: sun = body(0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, &
        0.0d0, 0.d0, 0.d0, SOLAR_MASS)

  integer, parameter :: nb = 5
  integer, parameter :: N = (nb-1)*nb/2

  real(kind=dp), parameter :: mass(nb) = (/ sun%mass, jupiter%mass, saturn%mass, &
        uranus%mass, neptune%mass /)

  integer :: num, i
  character(len=8) :: argv

  real(kind=dp) :: e, x(3,nb), v(3,nb)

  x(:,1) = (/ sun%x, sun%y, sun%z /)
  x(:,2) = (/ jupiter%x, jupiter%y, jupiter%z /)
  x(:,3) = (/ saturn%x, saturn%y, saturn%z /)
  x(:,4) = (/ uranus%x, uranus%y, uranus%z /)
  x(:,5) = (/ neptune%x, neptune%y, neptune%z /)

  v(:,1) = (/ sun%vx, sun%vy, sun%vz /)
  v(:,2) = (/ jupiter%vx, jupiter%vy, jupiter%vz /)
  v(:,3) = (/ saturn%vx, saturn%vy, saturn%vz /)
  v(:,4) = (/ uranus%vx, uranus%vy, uranus%vz /)
  v(:,5) = (/ neptune%vx, neptune%vy, neptune%vz /)

  call getarg(1, argv)
  read (argv,*) num

  call offsetMomentum(1, v, mass)
  e = energy(x, v, mass)
  write (*,'(f12.9)') e
  do i = 1, num
     call advance(tstep, x, v, mass)
  end do
  e = energy(x, v, mass)
  write (*,'(f12.9)') e

contains

  pure subroutine offsetMomentum(k, v, mass)
    integer, intent(in) :: k
    real(kind=dp), dimension(3,nb), intent(inout) :: v
    real(kind=dp), dimension(nb), intent(in) :: mass

    real(kind=dp), dimension(3) :: p

    p = (/ (sum(v(i,:) * mass(:)), i=1,3) /)
    v(:,k) = -p / SOLAR_MASS
  end subroutine offsetMomentum

  pure subroutine advance(tstep, x, v, mass)
    real(kind=dp), intent(in) :: tstep
    real(kind=dp), dimension(3,nb), intent(inout) :: x, v
    real(kind=dp), dimension(nb), intent(in) :: mass
    real(kind=dp) :: r(3,N),mag(N)

    real(kind=dp) :: distance, d2
    integer :: i, j, m
    m = 1
    do i = 1, nb
       do j = i + 1, nb
          r(:,m) = x(:,i) - x(:,j)
          m = m + 1
       end do
    end do

    do m = 1, N
       d2 = sum(r(:,m)**2)
       distance = 1/sqrt(real(d2))
       distance = distance * (1.5d0 - 0.5d0 * d2 * distance * distance)
       !distance = distance * (1.5d0 - 0.5d0 * d2 * distance * distance)
       mag(m) = tstep * distance**3
    end do

    m = 1
    do i = 1, nb
       do j = i + 1, nb
          v(:,i) = v(:,i) - r(:,m) * mass(j) * mag(m)
          v(:,j) = v(:,j) + r(:,m) * mass(i) * mag(m)

          m = m + 1
       end do
    end do

    x = x + tstep * v
  end subroutine advance

  pure function energy(x, v, mass)
    real(kind=dp) :: energy
    real(kind=dp), dimension(3,nb), intent(in) :: x, v
    real(kind=dp), dimension(nb), intent(in) :: mass

    real(kind=dp) :: distance
    real(kind=dp), dimension(3) :: d
    integer :: i, j

    energy = 0.0d0
    do i = 1, nb
       energy = energy + 0.5d0 * mass(i) * sum(v(:,i)**2)
       do j = i + 1, nb
          d = x(:,i) - x(:,j)
          distance = sqrt(sum(d**2))
          energy = energy - (mass(i) * mass(j)) / sqrt(sum(d**2))
       end do
    end do
  end function energy

end program nbody


PROGRAM wlInterpolationTest

  USE wlKindModule, ONLY: dp
  USE HDF5
  USE wlEquationOfStateTableModule
  USE wlInterpolationModule
  USE wlIOModuleHDF, ONLY: InitializeHDF, FinalizeHDF, &
                           ReadEquationOfStateTableHDF

  implicit none

  INTEGER  :: i
  REAL(dp) :: rho
  REAL(dp) :: T
  REAL(dp) :: Ye
  INTEGER :: RhoLocation
  INTEGER :: TLocation
  INTEGER :: YeLocation
  LOGICAL, DIMENSION(3) :: LogInterp
  TYPE(EquationOfStateTableType) :: EOSTable

  REAL(dp) :: Interpolant

  CALL InitializeHDF( )

  CALL ReadEquationOfStateTableHDF( EOSTable, "SmallEquationOfStateTable.h5" )

  LogInterp = (/.true.,.true.,.false./)

  rho = ( EOSTable % TS % States(1) % Values(6) -         &
          EOSTable % TS % States(1) % Values(5) )/2.0d0 + &
          EOSTable % TS % States(1) % Values(5)

  T = ( EOSTable % TS % States(2) % Values(6) -         &
        EOSTable % TS % States(2) % Values(5) )/2.0d0 + &
        EOSTable % TS % States(2) % Values(5)

  Ye = ( EOSTable % TS % States(3) % Values(6) -         &
         EOSTable % TS % States(3) % Values(5) )/2.0d0 + &
         EOSTable % TS % States(3) % Values(5)

  CALL LogInterpolateSingleVariable( rho, T, Ye,                                   &
                                     EOSTable % TS % States(1) % Values,           &
                                     EOSTable % TS % States(2) % Values,           &
                                     EOSTable % TS % States(3) % Values,           &
                                     LogInterp,                                    &
                                     EOSTable % DV % Variables(1) % Values(:,:,:), &
                                     Interpolant )
   WRITE (*,*) Interpolant

  CALL DeAllocateEquationOfStateTable( EOSTable )

  CALL FinalizeHDF( )

END PROGRAM wlInterpolationTest


*> \brief \b DLARGE
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, N
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       DOUBLE PRECISION   A( LDA, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLARGE pre- and post-multiplies a real general n by n matrix A
*> with a random orthogonal matrix: A = U*D*U'.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the original n by n matrix A.
*>          On exit, A is overwritten by U*A*U' for some random
*>          orthogonal matrix U.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= N.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry, the seed of the random number generator; the array
*>          elements must be between 0 and 4095, and ISEED(4) must be
*>          odd.
*>          On exit, the seed is updated.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_matgen
*
*  =====================================================================
      SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   TAU, WA, WB, WN
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER, DLARNV, DSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SIGN
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DNRM2
      EXTERNAL           DNRM2
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'DLARGE', -INFO )
         RETURN
      END IF
*
*     pre- and post-multiply A by random orthogonal matrix
*
      DO 10 I = N, 1, -1
*
*        generate random reflection
*
         CALL DLARNV( 3, ISEED, N-I+1, WORK )
         WN = DNRM2( N-I+1, WORK, 1 )
         WA = SIGN( WN, WORK( 1 ) )
         IF( WN.EQ.ZERO ) THEN
            TAU = ZERO
         ELSE
            WB = WORK( 1 ) + WA
            CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 )
            WORK( 1 ) = ONE
            TAU = WB / WA
         END IF
*
*        multiply A(i:n,1:n) by random reflection from the left
*
         CALL DGEMV( 'Transpose', N-I+1, N, ONE, A( I, 1 ), LDA, WORK,
     $               1, ZERO, WORK( N+1 ), 1 )
         CALL DGER( N-I+1, N, -TAU, WORK, 1, WORK( N+1 ), 1, A( I, 1 ),
     $              LDA )
*
*        multiply A(1:n,i:n) by random reflection from the right
*
         CALL DGEMV( 'No transpose', N, N-I+1, ONE, A( 1, I ), LDA,
     $               WORK, 1, ZERO, WORK( N+1 ), 1 )
         CALL DGER( N, N-I+1, -TAU, WORK( N+1 ), 1, WORK, 1, A( 1, I ),
     $              LDA )
   10 CONTINUE
      RETURN
*
*     End of DLARGE
*
      END


C
C	$Id$
C
      LOGICAL FUNCTION CSSWPTST (N1,N2,N3,N4,X,Y,Z)
      INTEGER N1, N2, N3, N4
      DOUBLE PRECISION X(*), Y(*), Z(*)
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   03/29/91
C
C   This function decides whether or not to replace a
C diagonal arc in a quadrilateral with the other diagonal.
C The decision will be to swap (CSSWPTST = TRUE) if and only
C if N4 lies above the plane (in the half-space not contain-
C ing the origin) defined by (N1,N2,N3), or equivalently, if
C the projection of N4 onto this plane is interior to the
C circumcircle of (N1,N2,N3).  The decision will be for no
C swap if the quadrilateral is not strictly convex.
C
C
C On input:
C
C       N1,N2,N3,N4 = Indexes of the four nodes defining the
C                     quadrilateral with N1 adjacent to N2,
C                     and (N1,N2,N3) in counterclockwise
C                     order.  The arc connecting N1 to N2
C                     should be replaced by an arc connec-
C                     ting N3 to N4 if CSSWPTST = TRUE.  Refer
C                     to Subroutine CSSWAP.
C
C       X,Y,Z = Arrays of length N containing the Cartesian
C               coordinates of the nodes.  (X(I),Y(I),Z(I))
C               define node I for I = N1, N2, N3, and N4.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       CSSWPTST = TRUE if and only if the arc connecting N1
C                and N2 should be swapped for an arc con-
C                necting N3 and N4.
C
C Modules required by CSSWPTST:  None
C
C***********************************************************
C
      DOUBLE PRECISION DX1, DX2, DX3, DY1, DY2, DY3, DZ1,
     .                 DZ2, DZ3, X4, Y4, Z4
C
C Local parameters:
C
C DX1,DY1,DZ1 = Coordinates of N4->N1
C DX2,DY2,DZ2 = Coordinates of N4->N2
C DX3,DY3,DZ3 = Coordinates of N4->N3
C X4,Y4,Z4 =    Coordinates of N4
C
      X4 = X(N4)
      Y4 = Y(N4)
      Z4 = Z(N4)
      DX1 = X(N1) - X4
      DX2 = X(N2) - X4
      DX3 = X(N3) - X4
      DY1 = Y(N1) - Y4
      DY2 = Y(N2) - Y4
      DY3 = Y(N3) - Y4
      DZ1 = Z(N1) - Z4
      DZ2 = Z(N2) - Z4
      DZ3 = Z(N3) - Z4
C
C N4 lies above the plane of (N1,N2,N3) iff N3 lies above
C   the plane of (N2,N1,N4) iff Det(N3-N4,N2-N4,N1-N4) =
C   (N3-N4,N2-N4 X N1-N4) > 0.
C
      CSSWPTST = DX3*(DY2*DZ1 - DY1*DZ2)
     .        -DY3*(DX2*DZ1 - DX1*DZ2)
     .        +DZ3*(DX2*DY1 - DX1*DY2) .GT. 0.D0
      RETURN
      END


program main
    implicit none

    interface
        SUBROUTINE MIEV0( XX, CREFIN, PERFCT, MIMCUT, ANYANG, NUMANG, XMU, &
                          NMOM, IPOLZN, MOMDIM, PRNT, QEXT, QSCA, GQSC, &
                          PMOM, SFORW, SBACK, S1, S2, TFORW, TBACK, &
                          SPIKE )
            LOGICAL  ANYANG, PERFCT, PRNT(*)
            INTEGER  IPOLZN, MOMDIM, NUMANG, NMOM
            REAL     GQSC, MIMCUT, PMOM( 0:MOMDIM, * ), QEXT, QSCA, SPIKE, &
                     XMU(*), XX
            COMPLEX  CREFIN, SFORW, SBACK, S1(*), S2(*), TFORW(*), TBACK(*)
        END SUBROUTINE
    end interface

    integer :: len, n
    integer numang, nmom, ipolzn, momdim
    real, parameter :: r_min=0.1e-6, r_max=100e-6, r_d=0.1e-6
    character(len=:), allocatable :: lambda_s
    integer :: lambda_i
    !real, parameter :: lambda=532e-9
    real :: lambda
    real, parameter :: pi=4*atan(1.0)
    real r
    real xx
    complex crefin
    parameter (momdim = 200)
    real mimcut, qext, qsca, gqsc, spike, pmom(0:momdim, 4), xmu(1), p180
    complex sforw, sback, s1(2), s2(2), tforw(2), tback(2)
    logical perfct, anyang, prnt(2)

    n = command_argument_count()
    if (n /= 1) then
        write(*,*) 'Usage: miev <wavelength_nm>'
        stop 1
    end if

    call get_command_argument(1, lambda_s, len)
    allocate(character(len=len) :: lambda_s)
    call get_command_argument(1, lambda_s, len)
    read(lambda_s,'(I64)') lambda_i
    lambda = lambda_i*1e-9

    xx = 100.0
    crefin = 1.33
    mimcut = 0.0
    perfct = .false.
    anyang = .true.
    numang = 1
    xmu = (/ -1.0 /)
    nmom = 0
    ipolzn = 0
    prnt = (/.false., .false./)

    write(*,*) 'wavelength_nm: ', lambda_i, 'crefin: { ', realpart(crefin), imagpart(crefin), ' }'
    write(*,*) 'r qext qsca p180'

    r = r_min
    do while (r < r_max)
        xx = 2*pi*r/lambda
        call miev0( &
            xx=xx, &
            crefin=crefin, &
            perfct=perfct, &
            mimcut=mimcut, &
            anyang=anyang, &
            numang=numang, &
            xmu=xmu, &
            nmom=nmom, &
            ipolzn=ipolzn, &
            momdim=momdim, &
            prnt=prnt, &
            qext=qext, &
            qsca=qsca, &
            gqsc=gqsc, &
            pmom=pmom, &
            sforw=sforw, &
            sback=sback, &
            s1=s1, &
            s2=s2, &
            tforw=tforw, &
            tback=tback, &
            spike=spike &
        )

        p180 = 4/(xx**2*qsca)*(cabs(s1(1))**2 + cabs(s2(1))**2)/2
        if (spike == 1.0) then
            write(*,*) r*1e6, qext, qsca, p180
        end if

        r = r + r_d
    end do
end program