!
!     -------------------------------------------------------------
!      N I N E 1 3
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
!                                                                  *
!     |  J1/2      J2/2  J3/2+1 |                                  *
!     |  L1/2      L2/2  J3/2   |                                  *
!     |  K1/2 + 1  K1/2    1    |                                  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius, LITHUANIA                              January 1997 *
!
      SUBROUTINE NINE13(J1, J2, J3, L1, L2, K1, A)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:09:06  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE nine_I
      USE sixj_I
      USE aconst_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J1
      INTEGER  :: J2
      INTEGER  :: J3
      INTEGER  :: L1
      INTEGER  :: L2
      INTEGER  :: K1
      REAL(DOUBLE)  :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K2, L3, IV, IN, IS
      REAL(DOUBLE) :: S1, A1, A2, S2, A3, S3, S, VAR2
!-----------------------------------------------
      A = ZERO
      K2 = K1 - 2
      L3 = J3 - 2
      IV = J3*(J1 - L1)*(J1 + L1 + 2) - K1*(J1 - J2)*(J1 + J2 + 2) + K1*J3*(K2&
          - L3)
      IF (IV == 0) THEN
         CALL NINE (J1, J2, J3, L1, L2, L3, K1, K2, 2, 0, IN, A)
      ELSE
         IS = L3 - K2
         IF (IS == 0) THEN
            S1 = ZERO
         ELSE
            CALL SIXJ (J1, L1, K2, L2, J2, L3, 1, S1)
            CALL ACONST (J1 + 1, L1, K2 + 1, J2, L3 + 1, A1)
            S1 = S1*A1*DBLE(IS)/TWO
         ENDIF
         CALL ACONST (L1 + 1, J1, K2 + 1, L2, L3 + 1, A2)
         IF (DABS(A2) < EPS) THEN
            S2 = ZERO
         ELSE
            CALL SIXJ (J1, J2, J3, L2, L1, K2, 1, S2)
            S2 = S2*A2*DBLE(J3)/TWO
         ENDIF
         CALL ACONST (J2 + 1, J1, L3 + 1, L2, K2 + 1, A3)
         IF (DABS(A3) < EPS) THEN
            S3 = ZERO
         ELSE
            CALL SIXJ (J1, J2, L3, L2, L1, K1, 1, S3)
            S3 = S3*A3*DBLE(K1)/TWO
         ENDIF
         S = S1 + S2 - S3
         IF (DABS(S) < EPS) RETURN
         VAR2 = DBLE(K2 + 3)*DBLE(K2 + 2)*DBLE(K2 + 1)*DBLE(L3 + 3)*DBLE(L3 + 2&
            )*DBLE(L3 + 1)
         A = S*DBLE(8)/(DBLE(IV)*DSQRT(VAR2))
         IF (MOD(J2 + L3 + L1 + K2,4) /= 0) A = -A
      ENDIF
      RETURN
      END SUBROUTINE NINE13


Real Function akplam(pkaon)
  Save
  p = pkaon
  If (pkaon<0.2 .Or. pkaon>=10.0) sigma = 0.
  If (pkaon>=0.2 .And. pkaon<0.9) sigma = 50.*p**2 - 67.*p + 24.
  If (pkaon>=0.9 .And. pkaon<10.0) sigma = 3.0*pkaon**(-2.6)
  akplam = sigma
  Return
End Function akplam


      DOUBLE PRECISION FUNCTION gamln1(a)
C-----------------------------------------------------------------------
C     EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION p0,p1,p2,p3,p4,p5,p6,q1,q2,q3,q4,q5,q6,r0,r1,r2,
     +                 r3,r4,r5,s1,s2,s3,s4,s5,w,x
C     ..
C     .. Data statements ..
C----------------------
      DATA p0/.577215664901533D+00/,p1/.844203922187225D+00/,
     +     p2/-.168860593646662D+00/,p3/-.780427615533591D+00/,
     +     p4/-.402055799310489D+00/,p5/-.673562214325671D-01/,
     +     p6/-.271935708322958D-02/
      DATA q1/.288743195473681D+01/,q2/.312755088914843D+01/,
     +     q3/.156875193295039D+01/,q4/.361951990101499D+00/,
     +     q5/.325038868253937D-01/,q6/.667465618796164D-03/
      DATA r0/.422784335098467D+00/,r1/.848044614534529D+00/,
     +     r2/.565221050691933D+00/,r3/.156513060486551D+00/,
     +     r4/.170502484022650D-01/,r5/.497958207639485D-03/
      DATA s1/.124313399877507D+01/,s2/.548042109832463D+00/,
     +     s3/.101552187439830D+00/,s4/.713309612391000D-02/,
     +     s5/.116165475989616D-03/
C     ..
C     .. Executable Statements ..
C----------------------
      IF (a.GE.0.6D0) GO TO 10
      w = ((((((p6*a+p5)*a+p4)*a+p3)*a+p2)*a+p1)*a+p0)/
     +    ((((((q6*a+q5)*a+q4)*a+q3)*a+q2)*a+q1)*a+1.0D0)
      gamln1 = -a*w
      RETURN
C
   10 x = (a-0.5D0) - 0.5D0
      w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/
     +    (((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x+1.0D0)
      gamln1 = x*w
      RETURN

      END


        SUBROUTINE ZCLWAV(GRAT,ORDER,CARPOS,CAP,COEF,SAMPLE,
     $			DELTAS,NS,WAVE,ISTAT)

*
*  Module number:
*
*  Module name: ZCLWAV
*
*  Keyphrase:
*  ----------
*       Compute HRS wavelength array
*  Description:
*  ------------
*       This routine computes the wavelengths by solving the
*       dispersion relation for wavelength using Newtons iterative
*       method.
*
*       The dispersion relation is:
*
*         s = a0 + a1*m*w + a2*m*m*w*w + a3*m + a4*w +
*		a5*m*m*w + a6*m*w*w + a7*m*m*m*w*w*w
*
*       where:
*               m - spectral order
*               w - wavelength
*               a0,a1,... - dispersion coefficients
*               s - sample position computed by SAMPLE+(i-1)*DELTAS
*                       where i is the data point number.
*
*  FORTRAN name: zclwav.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       None
*
*  Subroutines Called:
*  -------------------
*  SDAS:
*       ZMSPUT
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 89  D. Lindler      Designed and coded
*	1.1	May 91	S. Hulbert	Added cubic dispersion term
*					Change starting wavelength guess
*					Modify calling sequence to include
*					carpos
*	1.2	Sep 91	S. Hulbert	Bug fix for problem calculating "d"
*	1.2.1	Feb 92	S. Hulbert	Bug Fix--change datatype of "d" to
*					double precision
*       1.3     Apr 94  J. Eisenhamer   Removed hardwired constants related
*                                       wavelength guessing.
*-------------------------------------------------------------------------------
*
* INPUTS:
*
*       grat - grating mode
*       order - spectral order
*       coef - dispersion coefficients (8 of them, real*8)
*       sample - starting sample position
*       deltas - delta sample position
*       ns - number of data points
*
* OUTPUTS:
*       wave - wavelength vector (real*8)
*       istat - error status
*
*-----------------------------------------------------------------------------
        CHARACTER*5 GRAT
        INTEGER ORDER,CARPOS,NS,ISTAT
        DOUBLE PRECISION COEF(8),WAVE(1),CAP(2)
        REAL SAMPLE,DELTAS
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C LOCAL VARIABLES
C
        DOUBLE PRECISION S,W,DSDW,W2,MAXERR,SCOMP,A,B,C,D
        CHARACTER*80 CONTXT
        INTEGER M2,NITER,I,ITER
C
        DATA NITER/20/
C                                    --->maximum allowed number of iterations
        DATA MAXERR/0.001D0/
C                                    --->maximum allowed error in sample units
C
C-----------------------------------------------------------------------------
C
C Check for valid spectral order
C
        IF (((GRAT .EQ. 'ECH-A') .AND. ((ORDER .LT. 32) .OR.
     $		(ORDER .GT. 52))).OR.
     $      	((GRAT .EQ. 'ECH-B') .AND. ((ORDER .LT. 17) .OR.
     $		(ORDER .GT. 34))))THEN
            CONTXT='Invalid order number computed'
            GO TO 999
        ENDIF
C
C Initialize starting guess
C
        W = CAP(1)/ORDER*SIN((CAP(2)-CARPOS)/10430.378D0)
C
C convert disp. coef. to coefficients of w only
C
        M2=ORDER*ORDER
        A = COEF(1) + COEF(4)*ORDER
        B = COEF(2)*ORDER + COEF(5) + COEF(6)*M2
        C = COEF(3)*M2 + COEF(7)*ORDER
	D = COEF(8)*M2*ORDER
C
C Loop on data points
C
        DO 1000 I=1,NS
                S=SAMPLE+(I-1)*DELTAS
C
C LOOP ON ITERATIONS
C
                DO 100 ITER=1,NITER
                        W2=W*W
                        SCOMP = A + B*W + C*W2 + D*W2*W
                        DSDW = B + 2.0*C*W + 3.0*D*W2
                        IF(DABS(DSDW).LT.1.0E-30) GO TO 120
                        W = W + (S-SCOMP)/DSDW
                        IF(DABS(SCOMP-S).LT.MAXERR) GO TO 200
100             CONTINUE
C
C If we made it here, we did not converge
C
120             CONTXT='Convergence Failure in the wavelength '//
     *                  'computation'
                GO TO 999
C
C converged.
C
200             WAVE(I) = W
1000    CONTINUE
        ISTAT=0
        GO TO 2000
C
C error section
C
999     DO 1500 I=1,NS
                WAVE(I)=0.0
1500    CONTINUE
        CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
2000    RETURN
        END


subroutine create_I2(k,ncomp)

    use constants_module
    use arrays_module
    use arrays_section_module
    use xsec_attribute_module

    implicit none
    save

    integer, intent(in) :: k, ncomp

    integer :: i, pp
    real(kind=4) :: usTabProperty(2,nel),dsTabProperty(2,nel)
    real(kind=4) :: currentElev(nel),currentDpth(nel),currentWidth(nel),usWidth(nel),dsWidth(nel), cal_new_I2p(nel),cal_new_I2c(nel)
    real(kind=4) :: x1(nel), y1(nel), dbdxp(nel),dbdxc(nel)
    real(kind=4) :: increm, xt, r_interpo_nn

    currentElev = xsec_tab(1,:,k)
    currentWidth = xsec_tab(6,:,k)
    currentDpth = currentElev - currentElev(1)

    if (k .gt. 1) then

        usTabProperty(1,:) = xsec_tab(1,:,k-1)
        usTabProperty(2,:) = xsec_tab(6,:,k-1)

        x1=usTabProperty(1,:) - usTabProperty(1,1)
        y1=usTabProperty(2,:)
        do i=1,nel
            xt=currentDpth(i)
            usWidth(i)=r_interpo_nn(x1,y1,nel,xt)
        end do
    end if

    if (k .lt. ncomp) then

        dsTabProperty(1,:) = xsec_tab(1,:,k+1)
        dsTabProperty(2,:) = xsec_tab(6,:,k+1)
        x1=dsTabProperty(1,:) - dsTabProperty(1,1)
        y1=dsTabProperty(2,:)
        do i=1,nel
            xt=currentDpth(i)
            dsWidth(i)=r_interpo_nn(x1,y1,nel,xt)
        end do
    end if

    cal_new_I2p=0.0
    cal_new_I2c=0.0

    write(file_num,'(i4.4)')k
    open(22,file=trim(xSection_path)//file_num//'_I2')
    write(22,'(30a)')' Elev(m)    dbdxp(-)    dbdxc(-)      I2p     I2c'

    increm=currentElev(2)-currentElev(1)

    do i=1,nel
        if (k .eq. 1) then
            dbdxp(i)= 0
            dbdxc(i)=(dsWidth(i)-currentWidth(i))/(dx(k))
        elseif (k .eq. ncomp) then
            dbdxp(i)=(currentWidth(i)-usWidth(i))/(dx(k-1))
            dbdxc(i)= 0
        else
            dbdxp(i)=(currentWidth(i)-usWidth(i))/(dx(k-1))
            dbdxc(i)=(dsWidth(i)-currentWidth(i))/(dx(k))
        end if

        ! I2 calculation
        if (i .gt. 1) then
            do pp=2,i
                cal_new_I2p(i)=cal_new_I2p(i)+(currentElev(i)-currentElev(pp)+0.5*increm)*((dbdxp(pp)+dbdxp(pp-1))/2)*increm
                cal_new_I2c(i)=cal_new_I2c(i)+(currentElev(i)-currentElev(pp)+0.5*increm)*((dbdxc(pp)+dbdxc(pp-1))/2)*increm
            end do
        end if
        write(22,*)currentElev(i),dbdxp(i),dbdxc(i),cal_new_I2p(i),cal_new_I2c(i)
!10      format(3f12.2)
        xsec_tab(9,i,k) = cal_new_I2p(i)
        xsec_tab(10,i,k) = cal_new_I2c(i)
    end do
    close (22)

end subroutine create_I2

function r_interpo_nn(x,y,jj,xt)

    integer, intent(in) :: jj
    real, intent(in) :: xt, x(jj), y(jj)

    real :: yt

    ! nn means nearest neighbour

    if (xt.le. x(1)) then
        yt=y(1)
    elseif (xt.ge. x(jj)) then
        yt=y(jj)
    else
        do j=1,jj-1
            if((x(j)-xt)*(x(j+1)-xt).le.0)then

                yt=(xt-x(j))/(x(j+1)-x(j))*(y(j+1)-y(j))+y(j)

                EXIT
            endif
        end do
    end if
    r_interpo_nn = yt
    return
end function


*DECK DPSIFN
      SUBROUTINE DPSIFN (X, N, KODE, M, ANS, NZ, IERR)
C***BEGIN PROLOGUE  DPSIFN
C***PURPOSE  Compute derivatives of the Psi function.
C***LIBRARY   SLATEC
C***CATEGORY  C7C
C***TYPE      DOUBLE PRECISION (PSIFN-S, DPSIFN-D)
C***KEYWORDS  DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION,
C             PSI FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         The following definitions are used in DPSIFN:
C
C      Definition 1
C         PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of
C                  the log GAMMA function.
C      Definition 2
C                     K   K
C         PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X).
C   ___________________________________________________________________
C      DPSIFN computes a sequence of SCALED derivatives of
C      the PSI function; i.e. for fixed X and M it computes
C      the M-member sequence
C
C                    ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X)
C                       for K = N,...,N+M-1
C
C      where PSI(K,X) is as defined above.   For KODE=1, DPSIFN returns
C      the scaled derivatives as described.  KODE=2 is operative only
C      when K=0 and in that case DPSIFN returns -PSI(X) + LN(X).  That
C      is, the logarithmic behavior for large X is removed when KODE=2
C      and K=0.  When sums or differences of PSI functions are computed
C      the logarithmic terms can be combined analytically and computed
C      separately to help retain significant digits.
C
C         Note that CALL DPSIFN(X,0,1,1,ANS) results in
C                   ANS = -PSI(X)
C
C     Input      X is DOUBLE PRECISION
C           X      - Argument, X .gt. 0.0D0
C           N      - First member of the sequence, 0 .le. N .le. 100
C                    N=0 gives ANS(1) = -PSI(X)       for KODE=1
C                                       -PSI(X)+LN(X) for KODE=2
C           KODE   - Selection parameter
C                    KODE=1 returns scaled derivatives of the PSI
C                    function.
C                    KODE=2 returns scaled derivatives of the PSI
C                    function EXCEPT when N=0. In this case,
C                    ANS(1) = -PSI(X) + LN(X) is returned.
C           M      - Number of members of the sequence, M.ge.1
C
C    Output     ANS is DOUBLE PRECISION
C           ANS    - A vector of length at least M whose first M
C                    components contain the sequence of derivatives
C                    scaled according to KODE.
C           NZ     - Underflow flag
C                    NZ.eq.0, A normal return
C                    NZ.ne.0, Underflow, last NZ components of ANS are
C                             set to zero, ANS(M-K+1)=0.0, K=1,...,NZ
C           IERR   - Error flag
C                    IERR=0, A normal return, computation completed
C                    IERR=1, Input error,     no computation
C                    IERR=2, Overflow,        X too small or N+M-1 too
C                            large or both
C                    IERR=3, Error,           N too large. Dimensioned
C                            array TRMR(NMAX) is not large enough for N
C
C         The nominal computational accuracy is the maximum of unit
C         roundoff (=D1MACH(4)) and 1.0D-18 since critical constants
C         are given to only 18 digits.
C
C         PSIFN is the single precision version of DPSIFN.
C
C *Long Description:
C
C         The basic method of evaluation is the asymptotic expansion
C         for large X.ge.XMIN followed by backward recursion on a two
C         term recursion relation
C
C                  W(X+1) + X**(-N-1) = W(X).
C
C         This is supplemented by a series
C
C                  SUM( (X+K)**(-N-1) , K=0,1,2,... )
C
C         which converges rapidly for large N. Both XMIN and the
C         number of terms of the series are calculated from the unit
C         roundoff of the machine environment.
C
C***REFERENCES  Handbook of Mathematical Functions, National Bureau
C                 of Standards Applied Mathematics Series 55, edited
C                 by M. Abramowitz and I. A. Stegun, equations 6.3.5,
C                 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964.
C               D. E. Amos, A portable Fortran subroutine for
C                 derivatives of the Psi function, Algorithm 610, ACM
C                 Transactions on Mathematical Software 9, 4 (1983),
C                 pp. 494-502.
C***ROUTINES CALLED  D1MACH, I1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  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  DPSIFN
      INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ,
     *  FN
      INTEGER I1MACH
      DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN,
     * FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM,
     * TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN,
     * XM, XMIN, XQ, YINT
      DOUBLE PRECISION D1MACH
      DIMENSION B(22), TRM(22), TRMR(100), ANS(*)
      SAVE NMAX, B
      DATA NMAX /100/
C-----------------------------------------------------------------------
C             BERNOULLI NUMBERS
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
     * B(20), B(21), B(22) /1.00000000000000000D+00,
     * -5.00000000000000000D-01,1.66666666666666667D-01,
     * -3.33333333333333333D-02,2.38095238095238095D-02,
     * -3.33333333333333333D-02,7.57575757575757576D-02,
     * -2.53113553113553114D-01,1.16666666666666667D+00,
     * -7.09215686274509804D+00,5.49711779448621554D+01,
     * -5.29124242424242424D+02,6.19212318840579710D+03,
     * -8.65802531135531136D+04,1.42551716666666667D+06,
     * -2.72982310678160920D+07,6.01580873900642368D+08,
     * -1.51163157670921569D+10,4.29614643061166667D+11,
     * -1.37116552050883328D+13,4.88332318973593167D+14,
     * -1.92965793419400681D+16/
C
C***FIRST EXECUTABLE STATEMENT  DPSIFN
      IERR = 0
      NZ=0
      IF (X.LE.0.0D0) IERR=1
      IF (N.LT.0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (M.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      MM=M
      NX = MIN(-I1MACH(15),I1MACH(16))
      R1M5 = D1MACH(5)
      R1M4 = D1MACH(4)*0.5D0
      WDTOL = MAX(R1M4,0.5D-18)
C-----------------------------------------------------------------------
C     ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = 2.302D0*(NX*R1M5-3.0D0)
      XLN = LOG(X)
   41 CONTINUE
      NN = N + MM - 1
      FN = NN
      T = (FN+1)*XLN
C-----------------------------------------------------------------------
C     OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X
C-----------------------------------------------------------------------
      IF (ABS(T).GT.ELIM) GO TO 290
      IF (X.LT.WDTOL) GO TO 260
C-----------------------------------------------------------------------
C     COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1
C-----------------------------------------------------------------------
      RLN = R1M5*I1MACH(14)
      RLN = MIN(RLN,18.06D0)
      FLN = MAX(RLN,3.0D0) - 3.0D0
      YINT = 3.50D0 + 0.40D0*FLN
      SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0)
      XM = YINT + SLOPE*FN
      MX = INT(XM) + 1
      XMIN = MX
      IF (N.EQ.0) GO TO 50
      XM = -2.302D0*RLN - MIN(0.0D0,XLN)
      ARG = XM/N
      ARG = MIN(0.0D0,ARG)
      EPS = EXP(ARG)
      XM = 1.0D0 - EPS
      IF (ABS(ARG).LT.1.0D-3) XM = -ARG
      FLN = X*XM/EPS
      XM = XMIN - X
      IF (XM.GT.7.0D0 .AND. FLN.LT.15.0D0) GO TO 200
   50 CONTINUE
      XDMY = X
      XDMLN = XLN
      XINC = 0.0D0
      IF (X.GE.XMIN) GO TO 60
      NX = INT(X)
      XINC = XMIN - NX
      XDMY = X + XINC
      XDMLN = LOG(XDMY)
   60 CONTINUE
C-----------------------------------------------------------------------
C     GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      T = FN*XDMLN
      T1 = XDMLN + XDMLN
      T2 = T + XDMLN
      TK = MAX(ABS(T),ABS(T1),ABS(T2))
      IF (TK.GT.ELIM) GO TO 380
      TSS = EXP(-T)
      TT = 0.5D0/XDMY
      T1 = TT
      TST = WDTOL*TT
      IF (NN.NE.0) T1 = TT + 1.0D0/FN
      RXSQ = 1.0D0/(XDMY*XDMY)
      TA = 0.5D0*RXSQ
      T = (FN+1)*TA
      S = T*B(3)
      IF (ABS(S).LT.TST) GO TO 80
      TK = 2.0D0
      DO 70 K=4,22
        T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ
        TRM(K) = T*B(K)
        IF (ABS(TRM(K)).LT.TST) GO TO 80
        S = S + TRM(K)
        TK = TK + 2.0D0
   70 CONTINUE
   80 CONTINUE
      S = (S+T1)*TSS
      IF (XINC.EQ.0.0D0) GO TO 100
C-----------------------------------------------------------------------
C     BACKWARD RECUR FROM XDMY TO X
C-----------------------------------------------------------------------
      NX = INT(XINC)
      NP = NN + 1
      IF (NX.GT.NMAX) GO TO 390
      IF (NN.EQ.0) GO TO 160
      XM = XINC - 1.0D0
      FX = X + XM
C-----------------------------------------------------------------------
C     THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL
C-----------------------------------------------------------------------
      DO 90 I=1,NX
        TRMR(I) = FX**(-NP)
        S = S + TRMR(I)
        XM = XM - 1.0D0
        FX = X + XM
   90 CONTINUE
  100 CONTINUE
      ANS(MM) = S
      IF (FN.EQ.0) GO TO 180
C-----------------------------------------------------------------------
C     GENERATE LOWER DERIVATIVES, J.LT.N+MM-1
C-----------------------------------------------------------------------
      IF (MM.EQ.1) RETURN
      DO 150 J=2,MM
        FN = FN - 1
        TSS = TSS*XDMY
        T1 = TT
        IF (FN.NE.0) T1 = TT + 1.0D0/FN
        T = (FN+1)*TA
        S = T*B(3)
        IF (ABS(S).LT.TST) GO TO 120
        TK = 4 + FN
        DO 110 K=4,22
          TRM(K) = TRM(K)*(FN+1)/TK
          IF (ABS(TRM(K)).LT.TST) GO TO 120
          S = S + TRM(K)
          TK = TK + 2.0D0
  110   CONTINUE
  120   CONTINUE
        S = (S+T1)*TSS
        IF (XINC.EQ.0.0D0) GO TO 140
        IF (FN.EQ.0) GO TO 160
        XM = XINC - 1.0D0
        FX = X + XM
        DO 130 I=1,NX
          TRMR(I) = TRMR(I)*FX
          S = S + TRMR(I)
          XM = XM - 1.0D0
          FX = X + XM
  130   CONTINUE
  140   CONTINUE
        MX = MM - J + 1
        ANS(MX) = S
        IF (FN.EQ.0) GO TO 180
  150 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     RECURSION FOR N = 0
C-----------------------------------------------------------------------
  160 CONTINUE
      DO 170 I=1,NX
        S = S + 1.0D0/(X+NX-I)
  170 CONTINUE
  180 CONTINUE
      IF (KODE.EQ.2) GO TO 190
      ANS(1) = S - XDMLN
      RETURN
  190 CONTINUE
      IF (XDMY.EQ.X) RETURN
      XQ = XDMY/X
      ANS(1) = S - LOG(XQ)
      RETURN
C-----------------------------------------------------------------------
C     COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,...
C-----------------------------------------------------------------------
  200 CONTINUE
      NN = INT(FLN) + 1
      NP = N + 1
      T1 = (N+1)*XLN
      T = EXP(-T1)
      S = T
      DEN = X
      DO 210 I=1,NN
        DEN = DEN + 1.0D0
        TRM(I) = DEN**(-NP)
        S = S + TRM(I)
  210 CONTINUE
      ANS(1) = S
      IF (N.NE.0) GO TO 220
      IF (KODE.EQ.2) ANS(1) = S + XLN
  220 CONTINUE
      IF (MM.EQ.1) RETURN
C-----------------------------------------------------------------------
C     GENERATE HIGHER DERIVATIVES, J.GT.N
C-----------------------------------------------------------------------
      TOL = WDTOL/5.0D0
      DO 250 J=2,MM
        T = T/X
        S = T
        TOLS = T*TOL
        DEN = X
        DO 230 I=1,NN
          DEN = DEN + 1.0D0
          TRM(I) = TRM(I)/DEN
          S = S + TRM(I)
          IF (TRM(I).LT.TOLS) GO TO 240
  230   CONTINUE
  240   CONTINUE
        ANS(J) = S
  250 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     SMALL X.LT.UNIT ROUND OFF
C-----------------------------------------------------------------------
  260 CONTINUE
      ANS(1) = X**(-N-1)
      IF (MM.EQ.1) GO TO 280
      K = 1
      DO 270 I=2,MM
        ANS(K+1) = ANS(K)/X
        K = K + 1
  270 CONTINUE
  280 CONTINUE
      IF (N.NE.0) RETURN
      IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN
      RETURN
  290 CONTINUE
      IF (T.GT.0.0D0) GO TO 380
      NZ=0
      IERR=2
      RETURN
  380 CONTINUE
      NZ=NZ+1
      ANS(MM)=0.0D0
      MM=MM-1
      IF (MM.EQ.0) RETURN
      GO TO 41
  390 CONTINUE
      NZ=0
      IERR=3
      RETURN
      END


C*****************************************************************************
C Unit test program TDGELG.F for subroutine DGELG
C Ported to UNIX 11/10/1992
C*****************************************************************************
      include 'VICMAIN_FOR'
      subroutine main44

      integer i, ifail, ir, n, eps
c     .. local arrays ..
      double precision a(3,3)/33,-24,-8,16,-10,-4,72,-57,-17/
      double precision b(3,2)/-359,281,85,-718,562,170/
      character*80 string

      n = 3
      ir = 2

c.. Test the fortran subroutine
      call xvmessage(' Testing DGELG.F',' ')
      call xvmessage(' ...input R matrix:',' ')
      do 10 i=1,n
        write (string,99995) b(i,1)
        call xvmessage(string,' ')
        write (string,99995) b(i,2)
        call xvmessage(string,' ')
 10   continue
      call xvmessage(' ...input A coefficients:',' ')
      do 20 i=1,n
        write (string,99995) a(i,1)
        call xvmessage(string,' ')
        write (string,99995) a(i,2)
        call xvmessage(string,' ')
        write (string,99995) a(i,3)
        call xvmessage(string,' ')
 20   continue

      call dgelg(b,a,n,ir,eps,ifail)

      if (ifail .ne. 0) go to 100
      call xvmessage(' ...solution matrix:',' ')
      do 30 i=1,n
        write (string,99995) b(i,1)
        call xvmessage(string,' ')
        write (string,99995) b(i,2)
        call xvmessage(string,' ')
 30   continue

c.. Test the C-bridge
      call xvmessage(' Testing the C-bridge',' ')
      b(1,1) = -359
      b(2,1) = 281
      b(3,1) = 85
      b(1,2) = -718
      b(2,2) = 562
      b(3,2) = 170
      call xvmessage(' ...input R matrix:',' ')
      do 40 i=1,n
        write (string,99995) b(i,1)
        call xvmessage(string,' ')
        write (string,99995) b(i,2)
        call xvmessage(string,' ')
 40   continue
      a(1,1) = 33
      a(2,1) = -24
      a(3,1) = -8
      a(1,2) = 16
      a(2,2) = -10
      a(3,2) = -4
      a(1,3) = 72
      a(2,3) = -57
      a(3,3) = -17
      call xvmessage(' ...input A coefficients:',' ')
      do 50 i=1,n
        write (string,99995) a(i,1)
        call xvmessage(string,' ')
        write (string,99995) a(i,2)
        call xvmessage(string,' ')
        write (string,99995) a(i,3)
        call xvmessage(string,' ')
 50   continue

      call tzdgelg(b,a,n,ir,eps,ifail)

      if (ifail .ne. 0) go to 100
      call xvmessage(' ...solution matrix:',' ')
      do 60 i=1,n
       write (string,99995) b(i,1)
       call xvmessage(string,' ')
       write (string,99995) b(i,2)
       call xvmessage(string,' ')
60    continue

      return

100   write(string,99996) ifail
      call xvmessage(string,' ')
      return

99996 format (' error in dgelg, ifail = ', i2)
99995 format ('   ',1x , f10.5)
      end


!########################################################
!     Program  : HMIPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Hubbard model using DMFT-IPT
!     AUTHORS  : Adriano Amaricci
!########################################################
program hmipt_matsuara_2dsquare
  USE DMFT_IPT
  USE SQUARE_LATTICE
  USE IOTOOLS
  USE SPLINE
  implicit none

  logical                :: converged
  real(8)                :: n,z
  integer                :: i,Lk,iloop
  integer :: p,q
  logical :: upmflag
  complex(8)             :: zeta
  type(matsubara_gf)     :: fg,sigma,fg0
  !complex(8),allocatable :: fg0(:)
  real(8),allocatable    :: wm(:),tau(:),wt(:),epsik(:),nk(:),dtau(:)

  call read_input("inputIPT.in")
  call parse_cmd_variable(p,"P",default=10)
  call parse_cmd_variable(q,"Q",default=100)
  call parse_cmd_variable(upmflag,"UPMFLAG",default=.true.)
  L=2*P*Q
  !allocate functions:

  call allocate_gf(fg,L)
  call allocate_gf(sigma,L)
  call allocate_gf(fg0,L)

  !build freq. array
  allocate(wm(L))
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)

  allocate(tau(0:L),dtau(0:L))
  if(upmflag)then
     tau(0:) = upminterval(0.d0,beta,beta/2.d0,P,Q,type=0)
     call fftgf_iw2tau_upm(wm,(/(one,i=1,L)/),tau(0:),dtau(0:),beta)
  else
     tau(0:) = linspace(0.d0,beta,L+1)
     call fftgf_iw2tau((/(one,i=1,L)/),dtau(0:),beta)
  endif
  call splot("Delta_tau.ipt",tau(0:),dtau(0:))

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk),nk(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  !dmft loop:
  n=0.5d0
  sigma%iw=u*n
  !sigma%iw=u*(n-0.5d0)
  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     do i=1,L
        zeta = xi*wm(i) + xmu - sigma%iw(i)
        fg%iw(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo

     if(upmflag)then
        call fftgf_iw2tau_upm(wm,fg%iw,tau(0:),fg%tau(0:),beta)
     else
        call fftgf_iw2tau(fg%iw,fg%tau(0:),beta)
     endif
     n   = -fg%tau(L)
     fg0%iw = one/(one/fg%iw + sigma%iw - u*n)
     !fg0%iw = one/(one/fg%iw + sigma%iw - u*(n-0.5d0))
     if(upmflag)then
        call fftgf_iw2tau_upm(wm,fg0%iw,tau(0:),fg0%tau(0:),beta)
     else
        call fftgf_iw2tau(fg0%iw,fg0%tau,beta)
     endif
     forall(i=0:L)sigma%tau(i)=U**2*(fg0%tau(i))**2*fg0%tau(L-i)+u*n*dtau(i)

     if(upmflag)then
        call fftgf_tau2iw_upm(wm,sigma%iw,tau(0:),sigma%tau(0:),beta)
     else
        call fftgf_tau2iw(sigma%tau,sigma%iw,beta)
     endif
     !sigma%iw = sigma%iw  + u*n
     !sigma%iw = sigma%iw + u*(n-0.5d0)

     !! sigma%iw= solve_ipt_matsubara(fg0) + u*n
     !! sigma%iw= solve_ipt_matsubara(fg0) + u*(n-0.5d0)

     converged=check_convergence(sigma%iw,eps_error,nsuccess,nloop)
     z=1.d0 - dimag(sigma%iw(1))/wm(1);z=1.d0/z
     call splot("nVSiloop.ipt",iloop,n,append=TT)
     call splot("zetaVSiloop.ipt",iloop,z,append=TT)
  enddo
  call close_file("nVSiloop.ipt")
  call close_file("zetaVSiloop.ipt")
  call splot("G_iw.ipt",wm,fg%iw,append=printf)
  call splot("G0_iw.ipt",wm,fg0%iw,append=printf)
  call splot("Sigma_iw.ipt",wm,sigma%iw,append=printf)
  call splot("G_tau.ipt",tau(0:),fg%tau(0:),append=printf)
  call splot("G0_tau.ipt",tau(0:),fg0%tau(0:),append=printf)
  call splot("Sigma_tau.ipt",tau(0:),sigma%tau(0:),append=printf)
  nk = square_lattice_momentum_distribution(Lk)
  call splot("nkVSepsk.ipt",epsik,nk,append=printf)

contains

  function square_lattice_momentum_distribution(Lk) result(nk)
    integer            :: Lk
    integer            :: ik,i
    real(8)            :: nk(Lk)
    do ik=1,Lk
       fg%iw=one/(xi*wm - epsik(ik) - sigma%iw)
       call fftgf_iw2tau(fg%iw,fg%tau,beta)
       nk(ik)=-fg%tau(L)
    enddo
  end function square_lattice_momentum_distribution

  subroutine fftgf_iw2tau_upm(wm,gw,tm,gt,beta)
    integer                             :: i,j,N,L
    real(8),dimension(:)                :: wm
    complex(8),dimension(size(wm))      :: gw,tmpGw
    real(8),dimension(:)                :: tm
    real(8),dimension(size(tm))         :: gt
    complex(8)                          :: tail,fg
    real(8)                             :: tau,beta,mues,At,foo
    L=size(wm) ; N=size(tm)
    mues =-real(gw(L),8)*wm(L)**2
    tmpGw=(0.d0,0.d0)
    do i=1,L
       tail=-cmplx(mues,wm(i),8)/(mues**2+wm(i)**2)
       fg  = (0.d0,0.d0)
       if(i<=N)fg  = gw(i)-tail
       tmpGw(i)=fg
    enddo
    do i=1,N-1
       tau=tm(i)
       if(mues >= 0.d0)then
          if((mues*beta) > 30.d0)then
             At = -exp(-mues*tau)
          else
             At = -exp(-mues*tau)/(1.d0 + exp(-beta*mues))
          endif
       else
          if((mues*beta) < -30.d0)then
             At = -exp(mues*(beta-tau))
          else
             At = -exp(-mues*tau)/(1.d0 + exp(-beta*mues))
          endif
       endif
       foo   = sum(cos(wm(:)*tau)*dreal(tmpGw(:))) + sum(sin(wm(:)*tau)*dimag(tmpGw(:)))
       gt(i) = foo*2.d0/beta + At
    enddo
    gt(N)=-(gt(1)+1.d0)
  end subroutine fftgf_iw2tau_upm

  subroutine fftgf_tau2iw_upm(wm,gw,tm,gt,beta)
    integer                             :: i,j,N,L,NN
    real(8),dimension(:)                :: wm
    complex(8),dimension(size(wm))      :: gw
    real(8),dimension(:)                :: tm
    real(8),dimension(size(tm))         :: gt
    real(8),allocatable                 :: tmpGt(:),tmpt(:)
    complex(8)                          :: foo,tail,fg,xi
    real(8)                             :: tau,beta,mues,wn
    L=size(wm) ; N=size(tm)
    NN=min(32*L,2**14)
    xi=cmplx(0.d0,1.d0,8)
    allocate(tmpt(NN),tmpGt(NN))
    tmpt = linspace(0.d0,beta,NN)
    call cubic_spline(gt,tm,tmpGt,tmpt)
    do j=1,L                    !for all Matsubara frequencies:
       wn    = wm(j)!pi/beta*real(2*j-1,8)
       gw(j) = trapz(tmpt(:),exp(xi*wn*tmpt(:))*tmpGt(:))
    enddo
    deallocate(tmpt,tmpGt)
  end subroutine fftgf_tau2iw_upm

end program hmipt_matsuara_2dsquare


      module class_four_Vector

!     filename: class_Vector.inc
!     public, everything by default, but can specify any
      type four_Vector
!        private
        real(kind=8), dimension(4) :: data ! component values
        real(kind=8), dimension(10) :: metric ! metric
      end type four_Vector

      interface size
        module procedure four_Vector_size
      end interface

      interface lower
         module procedure lower
         module procedure lower_arr
      end interface

      interface assign_metric
        module procedure assign_metric, assign_metric_arr
        module procedure assign_metric_real, assign_metric_arr_real
        module procedure assign_metric_arr_real_same
        module procedure assign_metric_arr_same
      end interface

!     Overload common operators
      interface operator (+)    ! add others later
      module procedure add_four_Vector, add_Double_to_four_Vector
      module procedure add_four_Vector_arr
      module procedure add_Double_to_four_Vector_arr
      module procedure add_real_to_four_Vector_arr
      module procedure add_real_to_four_Vector
      end interface

      interface operator (-)    ! add unary versions later
      module procedure subtract_four_Vector, subtract_Double
      module procedure subtract_four_Vector_arr, subtract_Double_arr
      module procedure subtract_Real,subtract_Real_arr
      module procedure subtract_four_Vector_arr_single
      module procedure subtract_four_Vector_single_arr
      end interface

      interface operator (*)    ! overload *
      module procedure dot_four_Vector, double_mult_four_Vector
      module procedure four_Vector_mult_double
      module procedure dot_four_Vector_arr, double_mult_four_Vector_arr
      module procedure dot_four_vector_arr_single
      module procedure dot_four_Vector_single_arr
      module procedure four_Vector_mult_double_arr
      module procedure four_Vector_mult_real_arr
      module procedure real_mult_four_Vector_arr
      module procedure real_mult_four_Vector,four_Vector_mult_real
      end interface

      interface assignment (=)  ! overload =
      module procedure equal_Double, equal_Double_arr
      module procedure equal_Real, equal_Real_arr
      module procedure assign, assign_arr
      end interface

      interface operator (==)   ! overload ==
      module procedure is_equal_to, is_equal_to_arr
      end interface

      contains                     ! functions & operators

        pure function four_Vector_size(name) result (n) ! accessor member
        type (four_Vector), intent(in), dimension(:) :: name
        integer :: n
        n = size(name%data(1)) ; end function four_Vector_size

        function add_Double_to_four_Vector (v, r) result (new) ! overload +
        type (four_Vector), intent(in) :: v
        real(kind=8),          intent(in) :: r
        type (four_Vector)             :: new ! new = v + r
        new%data = v%data + r ; end function

        function add_four_Vector (a, b) result (new) ! vector + vector
        type (four_Vector), intent(in) :: a, b
        type (four_Vector)             :: new ! new = a + b
!        if ( a%size /= b%size ) stop "Sizes differ in add_four_Vector"
!        allocate ( new%data(a%size) ) ; new%size = a%size
        new%data = a%data + b%data    ; end function add_four_Vector

        subroutine assign (name, values)
        real(kind=8), intent(in) :: values(4)
        type (four_Vector), intent(inout) :: name
        name%data=values
        end subroutine assign

!        function assign (values) result (name) ! array to vector constructor
!        real(kind=8), intent(in) :: values(4) ! given rank 1 array
!        integer          :: length ! array size
!        type (four_Vector)    :: name  ! four_Vector to create
!        length = size(values); allocate ( name%data(length) )
!        name % data = values; end function assign

        function copy_four_Vector (name) result (new)
        type (four_Vector), intent(in) :: name
        type (four_Vector)             :: new
        new%data = name%data; new%metric = name%metric
        end function copy_four_Vector

        subroutine  delete_four_Vector (name) ! deallocate allocated items
        type (four_Vector), intent(inout) :: name
!        integer                      :: ok ! check deallocate status
!        deallocate (name%data, stat = ok )
!        if ( ok /= 0 ) stop "four_Vector &
!          not allocated in delete_four_Vector"
!        name%size = 0 ;
        name % data = 0; name % metric = 0
        end subroutine delete_four_Vector

        function dot_four_Vector (a, b) result (c) ! overload *
        type (four_Vector), intent(in) :: a, b
        type (four_Vector) :: d
        real(kind=8)                      :: c
!        if ( a%size /= b%size ) stop "Sizes differ in dot_four_Vector"
        d=lower(a) ! change a to co-variant
        c = dot_product (d%data, b%data) ; end function dot_four_Vector

        function lower(a) result(b)
        type (four_Vector), intent(in) :: a
        type (four_Vector) :: b
        b%data=(/a%metric(1)*a%data(1)+a%metric(2)*a%data(2)+a%metric(3) &
        *a%data(3)+ &
        a%metric(4)*a%data(4),a%metric(2)*a%data(1)+a%metric(5)* &
        a%data(2)+a%metric(6)* &
        a%data(3)+a%metric(7)*a%data(4),a%metric(3)*a%data(1)+ &
        a%metric(6)*a%data(2)+ &
        a%metric(8)*a%data(3)+a%metric(9)*a%data(4),a%metric(4)* &
        a%data(1)+a%metric(7)* &
        a%data(2)+a%metric(9)*a%data(3)+a%metric(10)*a%data(4)/)
        end function lower

        function lower_arr(a) result(b)
        type (four_Vector), dimension(:), intent(in) :: a
        type (four_Vector), dimension(size(a)) :: b
        integer :: i
        do i=1,size(a)
           b(i)=lower(a(i))
        end do
        end function lower_arr

        subroutine equal_Double (new, R) ! overload =, real(kind=8) to vector
        type (four_Vector), intent(inout) :: new
        real(kind=8),          intent(in)    :: R
!        if ( associated (new%data) ) deallocate (new%data)
!        allocate ( new%data(1) ); new%size = 1
        new%data = R            ; end subroutine equal_Double

        logical function is_equal_to (a, b) result (t_f) ! overload ==
        type (four_Vector), intent(in) :: a, b ! left & right of ==
        t_f = .false.             ! initialize
!        if ( a%size /= b%size ) return ! same size ?
        t_f = all ( a%data == b%data ) ! and all values match
        end function is_equal_to

!        function length (name) result (n) ! accessor member
!        type (four_Vector), intent(in) :: name
!        integer                  :: n
!        n = name % size ; end function length

        subroutine list (name)    ! accessor member
        type (four_Vector), intent(in) :: name
        print *,"[", name % data, "]"; end subroutine list

        function make_four_Vector (values, m_values) result(v) ! Optional Constructor
!        integer, optional, intent(in) :: len ! number of values
        real(kind=8), optional, intent(in) :: values(4)    ! given values
        real(kind=8), optional, intent(in) :: m_values(10) ! metric values
        type (four_Vector)                 :: v
!        if ( present (len) ) then ! create vector data
!          v%size = len ; allocate ( v%data(len) )
          if ( present (values)) then ; v%data = values ! vector
          else                      ; v%data = 0.d0 ! null vector
          end if                 ! values present
          if (present(m_values)) then ; v%metric = m_values
          else ; v% metric=(/-1.,0.,0.,0.,1.,0.,0.,1.,0.,1./)
          end if
        end function make_four_Vector

        function normalize_four_Vector (name)  result (new)
        type (four_Vector), intent(in) :: name
        type (four_Vector)             :: new
        real(kind=8)               :: total, nil = epsilon(nil) ! tolerance
        total = sqrt ( name*name ) ! use raise/lower op
        if ( total < nil ) then ; new%data = 0.d0 ! avoid division by 0
        else                  ; new%data = name%data/total
        end if                  ; end function normalize_four_Vector

        function double_mult_four_Vector (r, v) result (new) ! overload *
        real(kind=8),          intent(in) :: r
        type (four_Vector), intent(in) :: v
        type (four_Vector)             :: new ! new = r * v
        new%data = r * v%data
        end function double_mult_four_Vector

        function subtract_Double (v, r) result (new) ! vector-real(kind=8), overload -
        type (four_Vector), intent(in) :: v
        real(kind=8),          intent(in) :: r
        type (four_Vector)             :: new ! new = v + r
        new%data = v%data - r         ; end function subtract_double

        function subtract_four_Vector (a, b) result (new) ! overload -
        type (four_Vector), intent(in) :: a, b
        type (four_Vector)             :: new
        new%data = a%data - b%data ; end function subtract_four_Vector

        function values (name) result (array) ! accessor member

        type (four_Vector), intent(in) :: name
        real(kind=8)                      :: array(4)
        array = name % data ; end function values

        function four_Vector_ (values, metric) result(name) ! Public constructor
!        integer,      intent(in) :: length ! array size
        real(kind=8), intent(in) :: values(4) ! given
        real(kind=8), optional, intent(in) :: metric(10)
!        real(kind=8), pointer            :: pt_to_val(:) ! pointer to array
        type (four_Vector)            :: name ! four_Vector to create
        if(.not.(present(metric))) then
          name=four_Vector(values,(/-1.,0.,0.,0.,1.,0.,0.,1.,0.,1./))
        else
        name      = four_Vector(values,metric) ! intrinsic constructor
        end if
        end function four_Vector_

        function four_Vector_max_value (a) result (v) ! accessor member
        type (four_Vector), intent(in) :: a
        real(kind=8)                      :: v
        v = maxval ( a%data ); end function four_Vector_max_value

        function four_Vector_min_value (a) result (v) ! accessor member
        type (four_Vector), intent(in) :: a
        real(kind=8)                      :: v
        v = minval ( a%data ) ; end function four_Vector_min_value

        function four_Vector_mult_double (v, r) result (new) ! vector*real(kind=8), overload *
        type (four_Vector), intent(in) :: v
        real(kind=8),          intent(in) :: r
        type (four_Vector)             :: new            ! new = v * r
!        if ( v%size < 1 ) stop "Zero size in four_Vector_mult_real(kind=8)"
        new = Double_mult_four_Vector (r, v)
        end function four_Vector_mult_double

        function add_Double_to_four_Vector_arr (v, r) result (new) ! overload +
        type (four_Vector), intent(in), dimension(:) :: v
        real(kind=8),          intent(in)  :: r
        type (four_Vector), dimension(size(v)) :: new ! new = v + r
        new%data(1) = v%data(1) + r
        new%data(2) = v%data(2) + r
        new%data(3) = v%data(3) + r
        new%data(4) = v%data(4) + r
        end function

        function add_four_Vector_arr (a, b) result (new) ! vector + vector
        type (four_Vector), intent(in), dimension(:) :: a, b
        type (four_Vector), dimension(size(a)) :: new ! new = a + b
        integer :: i
        do i=1,size(a); new(i)%data=a(i)%data+b(i)%data; enddo
        end function add_four_Vector_arr

        subroutine assign_arr (name,values)
! array to vector constructor
        real(kind=8), intent(in) :: values(:,:) ! given rank 1 array
        integer          :: i ! array size
        type (four_Vector), dimension(size(values,2)), intent(inout) &
           :: name
! four_Vector to create
        do i=1,size(name); name(i)%data=values(:,i); enddo
        end subroutine assign_arr

        subroutine assign_metric(name,values)
        real(kind=8), intent(in), dimension(10) :: values
        type (four_Vector) :: name
        name%metric=values
        end subroutine assign_metric

        subroutine assign_metric_real(name,values)
        real, intent(in), dimension(10) :: values
        type (four_Vector) :: name
        name%metric=values
        end subroutine assign_metric_real

        subroutine assign_metric_arr_real(name,values)
        real, intent(in), dimension(:,:) :: values
        type (four_Vector), dimension(:) :: name
        integer :: i
        do i=1,size(values,2); name(i)%metric=values(:,i); enddo
        end subroutine assign_metric_arr_real

        subroutine assign_metric_arr_real_same(name,values)
        real, intent(in), dimension(10) :: values
        type (four_Vector), dimension(:) :: name
        integer :: i
        do i=1,size(name); name(i)%metric=values; enddo
        end subroutine assign_metric_arr_real_same

        subroutine assign_metric_arr_same(name,values)
        real(kind=8), intent(in), dimension(10) :: values
        type (four_Vector), dimension(:) :: name
        integer :: i
        do i=1,size(name); name(i)%metric=values; enddo
        end subroutine assign_metric_arr_same

        subroutine assign_metric_arr(name,values)
        real(kind=8), intent(in), dimension(:,:) :: values
        type (four_Vector), dimension(:) :: name
        integer :: i
        do i=1,size(values,2); name(i)%metric=values(:,i); enddo
        end subroutine assign_metric_arr

        function copy_four_Vector_arr (name) result (new)
        type (four_Vector), intent(in), dimension(:) :: name
        type (four_Vector), dimension(size(name)) :: new
        integer :: i
        do i=1,size(name)
          new(i)%data = name(i)%data; new(i)%metric=name(i)%metric
        enddo
        end function copy_four_Vector_arr

        subroutine  delete_four_Vector_arr (name) ! deallocate allocated items
        type (four_Vector), intent(inout), dimension(:) :: name
        integer                      :: i ! check deallocate status
        do i=1,size(name); name(i)%data=0;name(i)%metric=0; enddo
        end subroutine delete_four_Vector_arr

        function dot_four_Vector_arr (a, b) result (c) ! overload *
        type (four_Vector), intent(in), dimension(:) :: a, b
        type (four_Vector) :: d
        real(kind=8),dimension(size(a)) :: c
        integer :: i
        do i=1,size(a)
          d=lower(a(i)) ! change a to co-variant
          c(i)=dot_product(d%data,b(i)%data)
        enddo
        end function dot_four_Vector_arr

        function dot_four_Vector_arr_single (a, b) result (c) ! overload *
        type (four_Vector), intent(in), dimension(:) :: a
        type (four_Vector), intent(in) :: b
        type (four_Vector) :: d
        real(kind=8),dimension(size(a)) :: c
        integer :: i
        do i=1,size(a)
          d=lower(a(i)) ! change a to co-variant
          c(i)=dot_product(d%data,b%data)
        enddo
        end function dot_four_Vector_arr_single

        function dot_four_Vector_single_arr (a, b) result (c) ! overload *
        type (four_Vector), intent(in), dimension(:) :: b
        type (four_vector), intent(in) :: a
        type (four_Vector) :: d
        real(kind=8),dimension(size(b)) :: c
        integer :: i
        d=lower(a)
        do i=1,size(b)
          !d=lower(a(i)) ! change a to co-variant
          c(i)=dot_product(d%data,b(i)%data)
        enddo
        end function dot_four_Vector_single_arr

!        function lower_arr(a) result(b)
!        type (four_Vector), intent(in) :: a
!        type (four_Vector) :: b
!!        b%data=(/a%metric(1)*a%data(1)+a%metric(2)*a%data(2)+a%metric(3) & &
!        *a%data(3)+ &
!        a%metric(4)*a%data(4),a%metric(2)*a%data(1)+a%metric(5)* &
!        a%data(2)+a%metric(6)* &
!        a%data(3)+a%metric(7)*a%data(4),a%metric(2)*a%data(1)+ &
!!        a%metric(6)*a%data(2)+ &
!        a%metric(8)*a%data(3)+a%metric(9)*a%data(4),a%metric(4)* &
!        a%data(1)+a%metric(7)* &
!        a%data(2)+a%metric(9)*a%data(3)+a%metric(10)*a%data(4)/)
!        end function lower_arr

        subroutine equal_Double_arr (new, R) ! overload =, real(kind=8) to vector
        type (four_Vector), intent(inout), dimension(:) :: new
        real(kind=8), intent(in) :: R
        do i=1,size(new);new(i)%data=R;enddo
        end subroutine equal_Double_arr

        logical function is_equal_to_arr (a, b) result (t_f) ! overload ==
        type (four_Vector), intent(in), dimension(:) :: a, b ! left & right of ==
        integer :: i
        t_f = .false. ! initialize
        do i=1,size(a)
          t_f = all( a(i)%data == b(i)%data ) ! and all values match
          if(.not.t_f) exit
        enddo
        end function is_equal_to_arr

        subroutine list_arr (name)    ! accessor member
        type (four_Vector), intent(in) :: name
        print *,"[", name % data, "]"; end subroutine list_arr

        function make_four_Vector_arr (values, m_values) result(v) ! Optional Constructor
!        integer, optional, intent(in) :: len ! number of values
        real(kind=8), intent(in) :: values(:,:)
! given values
        real(kind=8), intent(in) :: m_values(:,:)
! metric values
        type (four_Vector), dimension(size(values,2)) :: v
        integer :: i
!        if ( present (len) ) then ! create vector data
!          v%size = len ; allocate ( v%data(len) )
        do i=1,size(values,2)
          v(i)%data = values(:,i) ! vector
          v(i)%metric = m_values(:,i)
        enddo
        end function make_four_Vector_arr

        function normalize_four_Vector_arr (name)  result (new)
        type (four_Vector), intent(in), dimension(:) :: name
        type (four_Vector), dimension(size(name))    :: new
        real(kind=8)          :: total, nil=epsilon(nil)
        integer :: i
! tolerance
        do i=1,size(name)
        total = sqrt ( name(i)*name(i) ) ! use raise/lower op
        if ( total < nil ) then ; new(i)%data = 0.d0 ! avoid division by 0
        else ; new(i)%data = name(i)%data/total
        end if; enddo; end function normalize_four_Vector_arr

        function double_mult_four_Vector_arr (r, v) result (new) ! overload *
        real(kind=8), intent(in) :: r
        type (four_Vector), intent(in), dimension(:) :: v
        type (four_Vector), dimension(size(v)) :: new ! new = r * v
        integer :: i
        do i=1,size(v); new(i)%data = r*v(i)%data; enddo
        end function double_mult_four_Vector_arr

        function size_four_Vector (name) result (n) ! accessor member
        type (four_Vector), intent(in), dimension(:) :: name
        integer                   :: n
        n = size(name) ; end function size_four_Vector

        function subtract_Double_arr (v, r) result (new) ! vector-real(kind=8), overload -
        type (four_Vector), intent(in), dimension(:) :: v
        real(kind=8), intent(in) :: r
        type (four_Vector), dimension(size(v)) :: new ! new = v + r
        integer :: i
        do i=1,size(v); new(i)%data = v(i)%data - r; enddo
        end function subtract_double_arr

        function subtract_four_Vector_arr (a, b) result (new) ! overload -
        type (four_Vector), intent(in), dimension(:) :: a, b
        type (four_Vector), dimension(size(a)) :: new
        integer :: i
        do i=1,size(a); new(i)%data = a(i)%data - b(i)%data; enddo
        end function subtract_four_Vector_arr

        function subtract_four_Vector_single_arr (a, b) result (new) ! overload -
        type (four_Vector), intent(in), dimension(:) :: b
        type (four_Vector), intent(in) :: a
        type (four_Vector), dimension(size(b)) :: new
        integer :: i
        do i=1,size(b); new(i)%data = a%data - b(i)%data; enddo
        end function subtract_four_Vector_single_arr

        function subtract_four_Vector_arr_single (a, b) result (new) ! overload -
        type (four_Vector), intent(in), dimension(:) :: a
        type (four_Vector), intent(in) :: b
        type (four_Vector), dimension(size(a)) :: new
        integer :: i
        do i=1,size(a); new(i)%data = a(i)%data - b%data; enddo
        end function subtract_four_Vector_arr_single

        function values_arr (name) result (array) ! accessor member
        type (four_Vector), intent(in), dimension(:) :: name
        real(kind=8) :: array(4,size(name))
        integer :: i
        do i=1,size(name); array(:,i)=name(i)%data ; enddo
        end function values_arr

        function four_Vector_mult_double_arr (v, r) result (new) ! vector*real(kind=8), overload *
        type (four_Vector), intent(in), dimension(:) :: v
        real(kind=8), intent(in) :: r
        type (four_Vector), dimension(size(v)) :: new  ! new = v * r
        new = Double_mult_four_Vector_arr (r, v)
        end function four_Vector_mult_double_arr

        function add_real_to_four_Vector (v, r) result (new) ! overload +
        type (four_Vector), intent(in) :: v
        real,          intent(in) :: r
        type (four_Vector)             :: new ! new = v + r
!        if ( v%size < 1 ) stop "No sizes in add_real Precision_to_four_Vector"
!        allocate ( new%data(4) )
!  new%data = v%data + r ! as array operation, or use implied loop
        new%data = v%data + r ; end function

        subroutine assign_real (name,values) ! array to vector constructor
        real, intent(in) :: values(4) ! given rank 1 array
        type (four_Vector)    :: name  ! four_Vector to create
        name % data = values; end subroutine assign_real

        function dot_four_Vector_real (a, b) result (c) ! overload *
        type (four_Vector), intent(in) :: a, b
        type (four_Vector) :: d
        real :: c
!        if ( a%size /= b%size ) stop "Sizes differ in dot_four_Vector"
        d=lower(a) ! change a to co-variant
        c = dot_product (d%data, b%data)
        end function dot_four_Vector_real

        subroutine equal_real (new, R) ! overload =, real to vector
        type (four_Vector), intent(inout) :: new
        real,          intent(in)    :: R
!        if ( associated (new%data) ) deallocate (new%data)
!        allocate ( new%data(1) ); new%size = 1
        new%data = R            ; end subroutine equal_real

        function make_four_Vector_real (values, m_values) result(v) ! Optional Constructor
!        integer, optional, intent(in) :: len ! number of values
        real, optional, intent(in) :: values(4)    ! given values
        real, optional, intent(in) :: m_values(10) ! metric values
        type (four_Vector)                 :: v
!        if ( present (len) ) then ! create vector data
!          v%size = len ; allocate ( v%data(len) )
          if ( present (values)) then ; v%data = values ! vector
          else                      ; v%data = 0.d0 ! null vector
          end if                 ! values present
          if (present(m_values)) then ; v%metric = m_values
          else ; v%metric=(/-1.,0.,0.,0.,1.,0.,0.,1.,0.,1./)
          end if
        end function make_four_Vector_real

        function normalize_four_Vector_real (name)  result (new)
        type (four_Vector), intent(in) :: name
        type (four_Vector)             :: new
        real               :: total, nil = epsilon(nil) ! tolerance
        total = sqrt ( name*name ) ! use raise/lower op
        if ( total < nil ) then ; new%data = 0.d0 ! avoid division by 0
        else                  ; new%data = name%data/total
        end if     ; end function normalize_four_Vector_real

        function real_mult_four_Vector (r, v) result (new) ! overload *
        real,          intent(in) :: r
        type (four_Vector), intent(in) :: v
        type (four_Vector)             :: new ! new = r * v
        new%data = r * v%data
        end function real_mult_four_Vector

        function subtract_real (v, r) result (new) ! vector-real, overload
        type (four_Vector), intent(in) :: v
        real,          intent(in) :: r
        type (four_Vector)             :: new ! new = v + r
        new%data = v%data - r         ; end function subtract_real

        function values_real (name) result (array) ! accessor member
        type (four_Vector), intent(in) :: name
        real                      :: array(4)
        array = name % data ; end function values_real

        function four_Vector_real_ (values, metric) result(name) ! Public constructor
!        integer,      intent(in) :: length ! array size
        real, intent(in) :: values(4) ! given
        real, optional, intent(in) :: metric(10)
!        real, pointer            :: pt_to_val(:) ! pointer to array
        type (four_Vector)            :: name ! four_Vector to create
        if(.not.(present(metric))) then
          name=four_Vector(values,(/-1.,0.,0.,0.,1.,0.,0.,1.,0.,1./))
        else
        name      = four_Vector(values,metric) ! intrinsic constructor
        end if
        end function four_Vector_real_

        function four_Vector_max_value_real (a) result (v) ! accessor member
        type (four_Vector), intent(in) :: a
        real                      :: v
        v = maxval ( a%data ); end function four_Vector_max_value_real

        function four_Vector_min_value_real (a) result (v) ! accessor member
        type (four_Vector), intent(in) :: a
        real                      :: v
        v = minval ( a%data ) ; end function four_Vector_min_value_real

        function four_Vector_mult_real (v, r) result (new) ! vector*real, overload *
        type (four_Vector), intent(in) :: v
        real,          intent(in) :: r
        type (four_Vector)             :: new            ! new = v * r
!        if ( v%size < 1 ) stop "Zero size in four_Vector_mult_real"
        new = real_mult_four_Vector (r, v)
        end function four_Vector_mult_real

        function add_real_to_four_Vector_arr (v, r) result (new) ! overload +
        type (four_Vector), intent(in), dimension(:) :: v
        real,          intent(in)  :: r
        type (four_Vector), dimension(size(v)) :: new ! new = v + r
        integer :: i
        do i=1,size(v); new(i)%data=v(i)%data+r; enddo
        end function

        subroutine assign_arr_real (name,values)
! array to vector constructor
        real, intent(in) :: values(:,:) ! given rank 2 array
        integer          :: i ! array size
        type (four_Vector), dimension(size(values,1)) :: name
! four_Vector to create
        do i=1,size(name); name(i)%data=values(:,i); enddo
        end subroutine assign_arr_real

        function dot_four_Vector_arr_real (a, b) result (c) ! overload *
        type (four_Vector), intent(in), dimension(:) :: a, b
        type (four_Vector) :: d
        real,dimension(size(a)) :: c
        integer :: i
!        if ( a%size /= b%size ) stop "Sizes differ in dot_four_Vector"
        do i=1,size(a)
          d=lower(a(i)) ! change a to co-variant
          c(i)=dot_product(d%data,b(i)%data)
        enddo
        end function dot_four_Vector_arr_real

        subroutine equal_real_arr (new, R) ! overload =, real to vector
        type (four_Vector), intent(inout), dimension(:) :: new
        real, intent(in) :: R
        do i=1,size(new);new(i)%data=R;enddo
        end subroutine equal_real_arr

        function make_four_Vector_arr_real (values, m_values) result(v) ! Optional Constructor
!        integer, optional, intent(in) :: len ! number of values
        real, intent(in) :: values(:,:)
! given values
        real, intent(in) :: m_values(:,:)
! metric values
        type (four_Vector), dimension(size(values,2)) :: v
        integer :: i
!        if ( present (len) ) then ! create vector data
!          v%size = len ; allocate ( v%data(len) )
        do i=1,size(values,2)
          v(i)%data = values(:,i) ! vector
          v(i)%metric = m_values(:,i)
        enddo
        end function make_four_Vector_arr_real

        function normalize_four_Vector_arr_real (name)  result (new)
        type (four_Vector), intent(in), dimension(:) :: name
        type (four_Vector), dimension(size(name))    :: new
        real          :: total, nil=epsilon(nil)
        integer :: i
! tolerance
        do i=1,size(name)
        total = sqrt ( name(i)*name(i) ) ! use raise/lower op
        if ( total < nil ) then ; new(i)%data = 0.d0 ! avoid division by 0
        else ; new(i)%data = name(i)%data/total
        end if; enddo; end function normalize_four_Vector_arr_real

        function real_mult_four_Vector_arr (r, v) result (new) ! overload *
        real, intent(in) :: r
        type (four_Vector), intent(in), dimension(:) :: v
        type (four_Vector), dimension(size(v)) :: new ! new = r * v
        integer :: i
        do i=1,size(v); new(i)%data = r*v(i)%data; enddo
        end function real_mult_four_Vector_arr

        function subtract_real_arr (v, r) result (new) ! vector-real, overload -
        type (four_Vector), intent(in), dimension(:) :: v
        real, intent(in) :: r
        type (four_Vector), dimension(size(v)) :: new ! new = v + r
        integer :: i
        do i=1,size(v); new(i)%data = v(i)%data - r; enddo
        end function subtract_real_arr

        function values_arr_real (name) result (array) ! accessor member
        type (four_Vector), intent(in), dimension(:) :: name
        real :: array(4,size(name))
        integer :: i
        do i=1,size(name); array(:,i)=name(i)%data ; enddo
        end function values_arr_real

        function four_Vector_mult_real_arr (v, r) result (new) ! vector*real, overload *
        type (four_Vector), intent(in), dimension(:) :: v
        real, intent(in) :: r
        type (four_Vector), dimension(size(v)) :: new  ! new = v * r
        new = real_mult_four_Vector_arr (r, v)
        end function four_Vector_mult_real_arr

      end module class_four_Vector


!########################################################
!     Program  : HMIPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Hubbard model using DMFT-IPT
!     AUTHORS  : Adriano Amaricci
!########################################################
program hmipt_matsuara_2dsquare
  USE DMFT_IPT
  USE SQUARE_LATTICE
  USE IOTOOLS
  implicit none

  logical                :: converged
  real(8)                :: n,z
  integer                :: i,Lk,iloop
  complex(8)             :: zeta
  type(matsubara_gf)     :: fg,sigma
  complex(8),allocatable :: fg0(:)
  real(8),allocatable    :: wm(:),tau(:),wt(:),epsik(:),nk(:)

  call read_input("inputIPT.in")
  !allocate functions:
  allocate(wm(L),tau(0:L))
  call allocate_gf(fg,L)
  call allocate_gf(sigma,L)
  allocate(fg0(L))

  !build freq. array
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)
  tau(0:)= linspace(0.d0,beta,L+1,mesh=dtau)

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk),nk(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  !dmft loop:
  n=0.5d0
  sigma%iw=u*(n-0.5d0) !u*n
  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     do i=1,L
        zeta = xi*wm(i) + xmu - sigma%iw(i)
        fg%iw(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo
     call fftgf_iw2tau(fg%iw,fg%tau,beta)
     n   = -fg%tau(L)
     fg0 = one/(one/fg%iw + sigma%iw - u*(n-0.5d0))!-u*n)
     sigma%iw= solve_ipt_matsubara(fg0) + u*(n-0.5d0)!+u*n
     converged=check_convergence(sigma%iw,eps_error,nsuccess,nloop)
     z=1.d0 - dimag(sigma%iw(1))/wm(1);z=1.d0/z
     call splot("nVSiloop.ipt",iloop,n,append=TT)
     call splot("zetaVSiloop.ipt",iloop,z,append=TT)
  enddo
  call close_file("nVSiloop.ipt")
  call close_file("zetaVSiloop.ipt")
  call splot("G_iw.ipt",wm,fg%iw,append=printf)
  call splot("G0_iw.ipt",wm,fg0,append=printf)
  call splot("Sigma_iw.ipt",wm,sigma%iw,append=printf)
  nk = square_lattice_momentum_distribution(Lk)
  call splot("nkVSepsk.ipt",epsik,nk,append=printf)

contains

  function square_lattice_momentum_distribution(Lk) result(nk)
    integer            :: Lk
    integer            :: ik,i
    real(8)            :: nk(Lk)
    do ik=1,Lk
       fg%iw=one/(xi*wm - epsik(ik) - sigma%iw)
       call fftgf_iw2tau(fg%iw,fg%tau,beta)
       nk(ik)=-fg%tau(L)
    enddo
  end function square_lattice_momentum_distribution

end program hmipt_matsuara_2dsquare


C
C	$Id$
C
      SUBROUTINE CSSTRI(N,RLATI,RLONI,NT,NTRI,IWK,WK,IER)
      REAL RLATI(N),RLONI(N)
      DOUBLE PRECISION WK(*)
C
      EXTERNAL CSBLDA
C
      DOUBLE PRECISION EPSILON,UN
      INTEGER N,NT,NTRI(3,*),IWK(*),IER
C
C  Parameters for random number usage.
C
      INTEGER CSJRAND
      PARAMETER (EPSILON=0.00001D0,IRMAX=32767)
      PARAMETER (D2R=0.017453293)
      DATA IX,IY,IZ/1,2,3/

C
C***********************************************************
C
C                              Simplified STRIPACK interface
C                                                 Fred Clare
C                                                       NCAR
C                                                   12/10/99
C
C   This subroutine provides a simplified interface to
C STRIPACK triangulation, at the expense of requiring a
C little extra storage.
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C    RLATI,RLONI = Arrays containing lat/lon coordinates of the nodes,
C                  in degrees.  The first three nodes must not be col-
C                  linear (lie on a common great circle).
C
C       NTRI =  A two-dimensional integer array dimensioned
C               for 3 x NT where NT is the number of triangles
C               in the triangulation (NT is at most 2*N).
C
C       IWK  =  An integer workspace of length 27*N.
C
C       WK   =  A *double precision* workspace of length 13*N.
C
C On output:
C
C       NT   = Number of triangles in the triangulation unless
C              IER .NE. 0, in which case NT = 0.  NT = 2N-NB-2
C              if NB .GE. 3 or 2N-4 if NB = 0, where NB is the
C              number of boundary nodes.
C
C       NTRI = The nodes for the triangles in the triangulation.
C              The nodes for the Jth triangle are NTRI(1,J),
C              NTRI(2,J) and NTRI(3,J) where node I references
C              the coordinate (X(I),Y(I),Z(I)).
C
C       IER = Error indicator:
C                =  0 - no error.
C                =  1 - invalid number of input points (must be
C                       greater than 3).
C                =  4 - first three nodes are collinear.
C                =  6 - internal algorithm error - please report this.
C                = 10 - insufficient space for the triangulation
C                       (must be >= number of boundary nodes minus 2).
C                = 11 - degenerate triangle (two vertices lie on
C                       same geodesic).
C                = -L - coordinates L and M coincide for some
C                       M  > L >= 1 (coordinate numbering
C                       starting at 1).
C
C Modules required by CSSTRI:  CSTRMESH, CSTRLIST
C
C***********************************************************
      IF (N .LT. 4) THEN
          IER = 1
          GO TO 200
      ENDIF
C
C  Convert RLATI and RLONI to radians.
C
      DO 7 I=1,N
        WK(4*N+I) = DBLE(D2R*RLATI(I))
        WK(5*N+I) = DBLE(D2R*RLONI(I))
    7 CONTINUE
C
C  Then convert to Cartesian coordinates.
C
      CALL CSTRANSD(N,WK(4*N+1),WK(5*N+1),WK(N+1),WK(2*N+1),WK(3*N+1))
C
C  Introduce a random perturbation in the 5th decimal place
C  to avoid duplicate input points.  The original input points
C  are copied into the real workspace so that they will not be
C  tampered with.
C
      DO 300 I = 1,N
          WK(  N+I) = DBLE(WK(  N+I) + EPSILON* (0.5-
     +                REAL(CSJRAND(IRMAX,IX,IY,IZ)/REAL(IRMAX))))
          WK(2*N+I) = DBLE(WK(2*N+I) + EPSILON* (0.5-
     +                REAL(CSJRAND(IRMAX,IX,IY,IZ)/REAL(IRMAX))))
          WK(3*N+I) = DBLE(WK(3*N+I) + EPSILON* (0.5-
     +                REAL(CSJRAND(IRMAX,IX,IY,IZ)/REAL(IRMAX))))
C
C  Renormalize the vector so that it is still a unit vector.
C
          UN = WK(N+I)**2
          UN = UN + WK(2*N+I)**2
          UN = UN + WK(3*N+I)**2
          UN = SQRT(UN)
          WK(N+I) = 0.99999D0*WK(N+I)/UN
          WK(2*N+I) = 0.99999D0*WK(2*N+I)/UN
          WK(3*N+I) = 0.99999D0*WK(3*N+I)/UN
  300 CONTINUE
C
C  Triangulate.
C
      CALL CSTRMESH(N,WK(N+1),WK(2*N+1),WK(3*N+1),IWK(1),IWK(6*N+1),
     +              IWK(12*N+1),LNEW,IWK(13*N+1),IWK(14*N+1),WK(1),IER)
      IF (IER.EQ.0) THEN
          GO TO 210
      ELSE IF (IER.EQ.-1) THEN
          IER = 1
          GO TO 200
      ELSE IF (IER.EQ.-2) THEN
          IER = 4
          GO TO 200
      ELSE IF (IER.EQ.-3) THEN
          IER = 6
          GO TO 200
      ELSE IF (IER.GT.0) THEN
          IER = -IER
          GO TO 200
      ELSE
          IER = 6
          GO TO 200
      END IF
C
  210 CONTINUE
C
C  Determine the triangle nodes.
C
      CALL CSTRLIST(N,IWK(1),IWK(6*N+1),IWK(12*N+1),6,NT,IWK(15*N+1),
     +              IER)
      IF (IER.NE.0) THEN
          NT = 0
          IER = 6
          GO TO 200
      END IF
C
C  Copy off the triangle nodes and return.
C
      DO 10 J = 1,NT
          NTRI(1,J) = IWK(15*N+6* (J-1)+1)
          NTRI(2,J) = IWK(15*N+6* (J-1)+2)
          NTRI(3,J) = IWK(15*N+6* (J-1)+3)
   10 CONTINUE
C
      RETURN
C
  200 CONTINUE
      CALL CSSERR('CSSTRI',IER)
      NT = 0
      RETURN
C
      END


**==grec.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION GREC(N,J,E,T)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL deg , drat , E , E3 , EA , EXINT1 , F , g , GREC , S2 , S3 ,
     &     S4 , S5 , T , V , WAVe , x1 , x12 , x14
      INTEGER J , LL , N
C*** End of declarations inserted by SPAG
      COMMON /DAT   / V(30) , EA(30) , S2(30) , WAVe(220) , E3(220) ,
     &                F(220) , LL(30) , S3(30) , S4(30) , S5(30)
      DIMENSION drat(30)
      DATA drat/2. , .5 , 2. , .5 , 6. , 2.5 , 2.22 , 2.25 , .67 ,
     &     .167 , 2. , .5 , 6. , 2.5 , 2.22 , 2.25 , .67 , .167 , 12*0./
      deg = drat(N-J+1)
      x1 = E*11590./T
      x12 = x1*x1
      x14 = x12*x12
      g = 5.238E-23*T**1.5*deg*(S2(J)*x12+S4(J)*x12*x1+x12*x1*S5(J)
     &    *(0.5-x1/2.)+EXINT1(x1,2)
     &    *(S3(J)*x12*x1-x14*S4(J)+x1*x14*S5(J)/2.))
      GREC = g
      IF ( x1.GE.300. ) GREC = 5.238E-23*T**1.5*deg*(S2(J)+S3(J)+S4(J)
     &                         +S5(J))*x12
      RETURN
      END


      SUBROUTINE DOP853(N,FCN,X,Y,XEND,
     &                  RTOL,ATOL,ITOL,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C ----------------------------------------------------------
C     NUMERICAL SOLUTION OF A SYSTEM OF FIRST 0RDER
C     ORDINARY DIFFERENTIAL EQUATIONS  Y'=F(X,Y).
C     THIS IS AN EXPLICIT RUNGE-KUTTA METHOD OF ORDER (4)5
C     DUE TO DORMAND & PRINCE (WITH STEPSIZE CONTROL AND
C     DENSE OUTPUT).
C
C     AUTHORS: E. HAIRER AND G. WANNER
C              UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
C              CH-1211 GENEVE 24, SWITZERLAND
C              E-MAIL:  Ernst.Hairer@math.unige.ch
C                       Gerhard.Wanner@math.unige.ch
C
C     THIS CODE IS DESCRIBED IN:
C         E. HAIRER, S.P. NORSETT AND G. WANNER, SOLVING ORDINARY
C         DIFFERENTIAL EQUATIONS I. NONSTIFF PROBLEMS. 2ND EDITION.
C         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
C         SPRINGER-VERLAG (1993)
C
C     VERSION OF APRIL 25, 1996
C     (latest correction of a small bug: August 8, 2005)
C
C     INPUT PARAMETERS
C     ----------------
C     N           DIMENSION OF THE SYSTEM
C
C     FCN         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
C                 VALUE OF F(X,Y):
C                    SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
C                    DOUBLE PRECISION X,Y(N),F(N)
C                    F(1)=...   ETC.
C
C     X           INITIAL X-VALUE
C
C     Y(N)        INITIAL VALUES FOR Y
C
C     XEND        FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
C
C     RTOL,ATOL   RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY
C                 CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
C
C     ITOL        SWITCH FOR RTOL AND ATOL:
C                   ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
C                     THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
C                     Y(I) BELOW RTOL*ABS(Y(I))+ATOL
C                   ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
C                     THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
C                     RTOL(I)*ABS(Y(I))+ATOL(I).
C
C     SOLOUT      NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
C                 NUMERICAL SOLUTION DURING INTEGRATION.
C                 IF IOUT.GE.1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
C                 SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
C                 IT MUST HAVE THE FORM
C                    SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,CON,ICOMP,ND,
C                                       RPAR,IPAR,IRTRN)
C                    DIMENSION Y(N),CON(5*ND),ICOMP(ND)
C                    ....
C                 SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
C                    GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
C                    THE FIRST GRID-POINT).
C                 "XOLD" IS THE PRECEEDING GRID-POINT.
C                 "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
C                    IS SET <0, DOPRI5 WILL RETURN TO THE CALLING PROGRAM.
C                    IF THE NUMERICAL SOLUTION IS ALTERED IN SOLOUT,
C                    SET  IRTRN = 2
C
C          -----  CONTINUOUS OUTPUT: -----
C                 DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION
C                 FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH
C                 THE FUNCTION
C                        >>>   CONTD5(I,S,CON,ICOMP,ND)   <<<
C                 WHICH PROVIDES AN APPROXIMATION TO THE I-TH
C                 COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE
C                 S SHOULD LIE IN THE INTERVAL [XOLD,X].
C
C     IOUT        SWITCH FOR CALLING THE SUBROUTINE SOLOUT:
C                    IOUT=0: SUBROUTINE IS NEVER CALLED
C                    IOUT=1: SUBROUTINE IS USED FOR OUTPUT.
C                    IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT
C                            (IN THIS CASE WORK(5) MUST BE SPECIFIED)
C
C     WORK        ARRAY OF WORKING SPACE OF LENGTH "LWORK".
C                 WORK(1),...,WORK(20) SERVE AS PARAMETERS FOR THE CODE.
C                 FOR STANDARD USE, SET THEM TO ZERO BEFORE CALLING.
C                 "LWORK" MUST BE AT LEAST  8*N+5*NRDENS+21
C                 WHERE  NRDENS = IWORK(5)
C
C     LWORK       DECLARED LENGHT OF ARRAY "WORK".
C
C     IWORK       INTEGER WORKING SPACE OF LENGHT "LIWORK".
C                 IWORK(1),...,IWORK(20) SERVE AS PARAMETERS FOR THE CODE.
C                 FOR STANDARD USE, SET THEM TO ZERO BEFORE CALLING.
C                 "LIWORK" MUST BE AT LEAST NRDENS+21 .
C
C     LIWORK      DECLARED LENGHT OF ARRAY "IWORK".
C
C     RPAR, IPAR  REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH
C                 CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING
C                 PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES.
C
C-----------------------------------------------------------------------
C
C     SOPHISTICATED SETTING OF PARAMETERS
C     -----------------------------------
C              SEVERAL PARAMETERS (WORK(1),...,IWORK(1),...) ALLOW
C              TO ADAPT THE CODE TO THE PROBLEM AND TO THE NEEDS OF
C              THE USER. FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES.
C
C    WORK(1)   UROUND, THE ROUNDING UNIT, DEFAULT 2.3D-16.
C
C    WORK(2)   THE SAFETY FACTOR IN STEP SIZE PREDICTION,
C              DEFAULT 0.9D0.
C
C    WORK(3), WORK(4)   PARAMETERS FOR STEP SIZE SELECTION
C              THE NEW STEP SIZE IS CHOSEN SUBJECT TO THE RESTRICTION
C                 WORK(3) <= HNEW/HOLD <= WORK(4)
C              DEFAULT VALUES: WORK(3)=0.2D0, WORK(4)=10.D0
C
C    WORK(5)   IS THE "BETA" FOR STABILIZED STEP SIZE CONTROL
C              (SEE SECTION IV.2). LARGER VALUES OF BETA ( <= 0.1 )
C              MAKE THE STEP SIZE CONTROL MORE STABLE. DOPRI5 NEEDS
C              A LARGER BETA THAN HIGHAM & HALL. NEGATIVE WORK(5)
C              PROVOKE BETA=0.
C              DEFAULT 0.04D0.
C
C    WORK(6)   MAXIMAL STEP SIZE, DEFAULT XEND-X.
C
C    WORK(7)   INITIAL STEP SIZE, FOR WORK(7)=0.D0 AN INITIAL GUESS
C              IS COMPUTED WITH HELP OF THE FUNCTION HINIT
C
C    IWORK(1)  THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
C              THE DEFAULT VALUE (FOR IWORK(1)=0) IS 100000.
C
C    IWORK(2)  SWITCH FOR THE CHOICE OF THE COEFFICIENTS
C              IF IWORK(2).EQ.1  METHOD DOPRI5 OF DORMAND AND PRINCE
C              (TABLE 5.2 OF SECTION II.5).
C              AT THE MOMENT THIS IS THE ONLY POSSIBLE CHOICE.
C              THE DEFAULT VALUE (FOR IWORK(2)=0) IS IWORK(2)=1.
C
C    IWORK(3)  SWITCH FOR PRINTING ERROR MESSAGES
C              IF IWORK(3).LT.0 NO MESSAGES ARE BEING PRINTED
C              IF IWORK(3).GT.0 MESSAGES ARE PRINTED WITH
C              WRITE (IWORK(3),*) ...
C              DEFAULT VALUE (FOR IWORK(3)=0) IS IWORK(3)=6
C
C    IWORK(4)  TEST FOR STIFFNESS IS ACTIVATED AFTER STEP NUMBER
C              J*IWORK(4) (J INTEGER), PROVIDED IWORK(4).GT.0.
C              FOR NEGATIVE IWORK(4) THE STIFFNESS TEST IS
C              NEVER ACTIVATED; DEFAULT VALUE IS IWORK(4)=1000
C
C    IWORK(5)  = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT
C              IS REQUIRED; DEFAULT VALUE IS IWORK(5)=0;
C              FOR   0 < NRDENS < N   THE COMPONENTS (FOR WHICH DENSE
C              OUTPUT IS REQUIRED) HAVE TO BE SPECIFIED IN
C              IWORK(21),...,IWORK(NRDENS+20);
C              FOR  NRDENS=N  THIS IS DONE BY THE CODE.
C
C----------------------------------------------------------------------
C
C     OUTPUT PARAMETERS
C     -----------------
C     X           X-VALUE FOR WHICH THE SOLUTION HAS BEEN COMPUTED
C                 (AFTER SUCCESSFUL RETURN X=XEND).
C
C     Y(N)        NUMERICAL SOLUTION AT X
C
C     H           PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
C
C     IDID        REPORTS ON SUCCESSFULNESS UPON RETURN:
C                   IDID= 1  COMPUTATION SUCCESSFUL,
C                   IDID= 2  COMPUT. SUCCESSFUL (INTERRUPTED BY SOLOUT)
C                   IDID=-1  INPUT IS NOT CONSISTENT,
C                   IDID=-2  LARGER NMAX IS NEEDED,
C                   IDID=-3  STEP SIZE BECOMES TOO SMALL.
C                   IDID=-4  PROBLEM IS PROBABLY STIFF (INTERRUPTED).
C
C   IWORK(17)  NFCN    NUMBER OF FUNCTION EVALUATIONS
C   IWORK(18)  NSTEP   NUMBER OF COMPUTED STEPS
C   IWORK(19)  NACCPT  NUMBER OF ACCEPTED STEPS
C   IWORK(20)  NREJCT  NUMBER OF REJECTED STEPS (DUE TO ERROR TEST),
C                      (STEP REJECTIONS IN THE FIRST STEP ARE NOT COUNTED)
C-----------------------------------------------------------------------
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C          DECLARATIONS
C *** *** *** *** *** *** *** *** *** *** *** *** ***
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),ATOL(*),RTOL(*),WORK(LWORK),IWORK(LIWORK)
      DIMENSION RPAR(*),IPAR(*)
      LOGICAL ARRET
      EXTERNAL FCN,SOLOUT
C *** *** *** *** *** *** ***
C        SETTING THE PARAMETERS
C *** *** *** *** *** *** ***
      NFCN=0
      NSTEP=0
      NACCPT=0
      NREJCT=0
      ARRET=.FALSE.
C -------- IPRINT FOR MONITORING THE PRINTING
      IF(IWORK(3).EQ.0)THEN
         IPRINT=6
      ELSE
         IPRINT=IWORK(3)
      END IF
C -------- NMAX , THE MAXIMAL NUMBER OF STEPS -----
      IF(IWORK(1).EQ.0)THEN
         NMAX=100000
      ELSE
         NMAX=IWORK(1)
         IF(NMAX.LE.0)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' WRONG INPUT IWORK(1)=',IWORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------- METH   COEFFICIENTS OF THE METHOD
      IF(IWORK(2).EQ.0)THEN
         METH=1
      ELSE
         METH=IWORK(2)
         IF(METH.LE.0.OR.METH.GE.4)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT IWORK(2)=',IWORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------- NSTIFF   PARAMETER FOR STIFFNESS DETECTION
      NSTIFF=IWORK(4)
      IF (NSTIFF.EQ.0) NSTIFF=1000
      IF (NSTIFF.LT.0) NSTIFF=NMAX+10
C -------- NRDENS   NUMBER OF DENSE OUTPUT COMPONENTS
      NRDENS=IWORK(5)
      IF(NRDENS.LT.0.OR.NRDENS.GT.N)THEN
         IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &           ' CURIOUS INPUT IWORK(5)=',IWORK(5)
         ARRET=.TRUE.
      ELSE
            IF(NRDENS.GT.0.AND.IOUT.LT.2)THEN
               IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &      ' WARNING: PUT IOUT=2 FOR DENSE OUTPUT '
            END IF
            IF (NRDENS.EQ.N) THEN
                DO 16 I=1,NRDENS
  16            IWORK(20+I)=I
            END IF
      END IF
C -------- UROUND   SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0
      IF(WORK(1).EQ.0.D0)THEN
         UROUND=2.3D-16
      ELSE
         UROUND=WORK(1)
         IF(UROUND.LE.1.D-35.OR.UROUND.GE.1.D0)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &        ' WHICH MACHINE DO YOU HAVE? YOUR UROUND WAS:',WORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------  SAFETY FACTOR -------------
      IF(WORK(2).EQ.0.D0)THEN
         SAFE=0.9D0
      ELSE
         SAFE=WORK(2)
         IF(SAFE.GE.1.D0.OR.SAFE.LE.1.D-4)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT FOR SAFETY FACTOR WORK(2)=',WORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------  FAC1,FAC2     PARAMETERS FOR STEP SIZE SELECTION
      IF(WORK(3).EQ.0.D0)THEN
         FAC1=0.2D0
      ELSE
         FAC1=WORK(3)
      END IF
      IF(WORK(4).EQ.0.D0)THEN
         FAC2=10.D0
      ELSE
         FAC2=WORK(4)
      END IF
C --------- BETA FOR STEP CONTROL STABILIZATION -----------
      IF(WORK(5).EQ.0.D0)THEN
         BETA=0.04D0
      ELSE
         IF(WORK(5).LT.0.D0)THEN
            BETA=0.D0
         ELSE
            BETA=WORK(5)
            IF(BETA.GT.0.2D0)THEN
               IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT FOR BETA: WORK(5)=',WORK(5)
            ARRET=.TRUE.
         END IF
         END IF
      END IF
C -------- MAXIMAL STEP SIZE
      IF(WORK(6).EQ.0.D0)THEN
         HMAX=XEND-X
      ELSE
         HMAX=WORK(6)
      END IF
C -------- INITIAL STEP SIZE
      H=WORK(7)
C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK -----
      IEY1=21
      IEK1=IEY1+N
      IEK2=IEK1+N
      IEK3=IEK2+N
      IEK4=IEK3+N
      IEK5=IEK4+N
      IEK6=IEK5+N
      IEYS=IEK6+N
      IECO=IEYS+N
C ------ TOTAL STORAGE REQUIREMENT -----------
      ISTORE=IEYS+5*NRDENS-1
      IF(ISTORE.GT.LWORK)THEN
        IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &   ' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE
        ARRET=.TRUE.
      END IF
      ICOMP=21
      ISTORE=ICOMP+NRDENS-1
      IF(ISTORE.GT.LIWORK)THEN
        IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &   ' INSUFFICIENT STORAGE FOR IWORK, MIN. LIWORK=',ISTORE
        ARRET=.TRUE.
      END IF
C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1
      IF (ARRET) THEN
         IDID=-1
         RETURN
      END IF
C -------- CALL TO CORE INTEGRATOR ------------
      CALL DOPCOR(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL,IPRINT,
     &   SOLOUT,IOUT,IDID,NMAX,UROUND,METH,NSTIFF,SAFE,BETA,FAC1,FAC2,
     &   WORK(IEY1),WORK(IEK1),WORK(IEK2),WORK(IEK3),WORK(IEK4),
     &   WORK(IEK5),WORK(IEK6),WORK(IEYS),WORK(IECO),IWORK(ICOMP),
     &   NRDENS,RPAR,IPAR,NFCN,NSTEP,NACCPT,NREJCT)
      WORK(7)=H
      IWORK(17)=NFCN
      IWORK(18)=NSTEP
      IWORK(19)=NACCPT
      IWORK(20)=NREJCT
C ----------- RETURN -----------
      RETURN
      END
C
C
C
C  ----- ... AND HERE IS THE CORE INTEGRATOR  ----------
C
      SUBROUTINE DOPCOR(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL,IPRINT,
     &   SOLOUT,IOUT,IDID,NMAX,UROUND,METH,NSTIFF,SAFE,BETA,FAC1,FAC2,
     &   Y1,K1,K2,K3,K4,K5,K6,YSTI,CONT,ICOMP,NRD,RPAR,IPAR,
     &   NFCN,NSTEP,NACCPT,NREJCT)
C ----------------------------------------------------------
C     CORE INTEGRATOR FOR DOPRI5
C     PARAMETERS SAME AS IN DOPRI5 WITH WORKSPACE ADDED
C ----------------------------------------------------------
C         DECLARATIONS
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION K1(N),K2(N),K3(N),K4(N),K5(N),K6(N)
      DIMENSION Y(N),Y1(N),YSTI(N),ATOL(*),RTOL(*),RPAR(*),IPAR(*)
      DIMENSION CONT(5*NRD),ICOMP(NRD)
      LOGICAL REJECT,LAST
      EXTERNAL FCN
      COMMON /CONDO5/XOLD,HOUT
C *** *** *** *** *** *** ***
C  INITIALISATIONS
C *** *** *** *** *** *** ***
      IF (METH.EQ.1) CALL CDOPRI(C2,C3,C4,C5,E1,E3,E4,E5,E6,E7,
     &                    A21,A31,A32,A41,A42,A43,A51,A52,A53,A54,
     &                    A61,A62,A63,A64,A65,A71,A73,A74,A75,A76,
     &                    D1,D3,D4,D5,D6,D7)
      FACOLD=1.D-4
      EXPO1=0.2D0-BETA*0.75D0
      FACC1=1.D0/FAC1
      FACC2=1.D0/FAC2
      POSNEG=SIGN(1.D0,XEND-X)
C --- INITIAL PREPARATIONS
      ATOLI=ATOL(1)
      RTOLI=RTOL(1)
      LAST=.FALSE.
      HLAMB=0.D0
      IASTI=0
C --- HMIN defined by Remco 25 feb 06
      HMIN=(XEND-X)/(NMAX*0.75)
      CALL FCN(N,X,Y,K1,RPAR,IPAR)
      HMAX=ABS(HMAX)
      IORD=5
      IF (H.EQ.0.D0) H=HINIT(N,FCN,X,Y,XEND,POSNEG,K1,K2,K3,IORD,
     &                       HMAX,ATOL,RTOL,ITOL,RPAR,IPAR)
      NFCN=NFCN+2
      REJECT=.FALSE.
      XOLD=X
      IF (IOUT.NE.0) THEN
          IRTRN=1
          HOUT=H
          CALL SOLOUT(NACCPT+1,XOLD,X,Y,N,CONT,ICOMP,NRD,
     &                RPAR,IPAR,IRTRN)
          IF (IRTRN.LT.0) GOTO 79
      ELSE
          IRTRN=0
      END IF
C --- BASIC INTEGRATION STEP
   1  CONTINUE
      IF (NSTEP.GT.NMAX) GOTO 78
      IF (0.1D0*ABS(H).LE.ABS(X)*UROUND)GOTO 77
      IF ((X+1.01D0*H-XEND)*POSNEG.GT.0.D0) THEN
         H=XEND-X
         LAST=.TRUE.
      END IF
      NSTEP=NSTEP+1
C --- THE FIRST 6 STAGES
      IF (IRTRN.GE.2) THEN
         CALL FCN(N,X,Y,K1,RPAR,IPAR)
      END IF
      DO 22 I=1,N
  22  Y1(I)=Y(I)+H*A21*K1(I)
      CALL FCN(N,X+C2*H,Y1,K2,RPAR,IPAR)
      DO 23 I=1,N
  23  Y1(I)=Y(I)+H*(A31*K1(I)+A32*K2(I))
      CALL FCN(N,X+C3*H,Y1,K3,RPAR,IPAR)
      DO 24 I=1,N
  24  Y1(I)=Y(I)+H*(A41*K1(I)+A42*K2(I)+A43*K3(I))
      CALL FCN(N,X+C4*H,Y1,K4,RPAR,IPAR)
      DO 25 I=1,N
  25  Y1(I)=Y(I)+H*(A51*K1(I)+A52*K2(I)+A53*K3(I)+A54*K4(I))
      CALL FCN(N,X+C5*H,Y1,K5,RPAR,IPAR)
      DO 26 I=1,N
  26  YSTI(I)=Y(I)+H*(A61*K1(I)+A62*K2(I)+A63*K3(I)+A64*K4(I)+A65*K5(I))
      XPH=X+H
      CALL FCN(N,XPH,YSTI,K6,RPAR,IPAR)
      DO 27 I=1,N
  27  Y1(I)=Y(I)+H*(A71*K1(I)+A73*K3(I)+A74*K4(I)+A75*K5(I)+A76*K6(I))
      CALL FCN(N,XPH,Y1,K2,RPAR,IPAR)
      IF (IOUT.GE.2) THEN
            DO 40 J=1,NRD
            I=ICOMP(J)
            CONT(4*NRD+J)=H*(D1*K1(I)+D3*K3(I)+D4*K4(I)+D5*K5(I)
     &                   +D6*K6(I)+D7*K2(I))
  40        CONTINUE
      END IF
      DO 28 I=1,N
  28  K4(I)=(E1*K1(I)+E3*K3(I)+E4*K4(I)+E5*K5(I)+E6*K6(I)+E7*K2(I))*H
      NFCN=NFCN+6
C --- ERROR ESTIMATION
      ERR=0.D0
      IF (ITOL.EQ.0) THEN
        DO 41 I=1,N
        SK=ATOLI+RTOLI*MAX(ABS(Y(I)),ABS(Y1(I)))
  41    ERR=ERR+(K4(I)/SK)**2
      ELSE
        DO 42 I=1,N
        SK=ATOL(I)+RTOL(I)*MAX(ABS(Y(I)),ABS(Y1(I)))
  42    ERR=ERR+(K4(I)/SK)**2
      END IF
      ERR=SQRT(ERR/N)
C --- COMPUTATION OF HNEW
      FAC11=ERR**EXPO1
C --- LUND-STABILIZATION
      FAC=FAC11/FACOLD**BETA
C --- WE REQUIRE  FAC1 <= HNEW/H <= FAC2
      FAC=MAX(FACC2,MIN(FACC1,FAC/SAFE))
      HNEW=H/FAC
C --- RvdB 26feb06 Accept step if step size is Hmin
      IF(ERR.LE.1.D0)THEN
C --- STEP IS ACCEPTED
         FACOLD=MAX(ERR,1.0D-4)
         NACCPT=NACCPT+1
C ------- STIFFNESS DETECTION
         IF (MOD(NACCPT,NSTIFF).EQ.0.OR.IASTI.GT.0) THEN
            STNUM=0.D0
            STDEN=0.D0
            DO 64 I=1,N
               STNUM=STNUM+(K2(I)-K6(I))**2
               STDEN=STDEN+(Y1(I)-YSTI(I))**2
 64         CONTINUE
            IF (STDEN.GT.0.D0) HLAMB=H*SQRT(STNUM/STDEN)
            IF (HLAMB.GT.3.25D0) THEN
               NONSTI=0
               IASTI=IASTI+1
               IF (IASTI.EQ.15) THEN
                  IF (IPRINT.GT.0) WRITE (IPRINT,*)
     &               ' THE PROBLEM SEEMS TO BECOME STIFF AT X = ',X
                  IF (IPRINT.LE.0) GOTO 76
               END IF
            ELSE
               NONSTI=NONSTI+1
               IF (NONSTI.EQ.6) IASTI=0
            END IF
         END IF
         IF (IOUT.GE.2) THEN
            DO 43 J=1,NRD
            I=ICOMP(J)
            YD0=Y(I)
            YDIFF=Y1(I)-YD0
            BSPL=H*K1(I)-YDIFF
            CONT(J)=Y(I)
            CONT(NRD+J)=YDIFF
            CONT(2*NRD+J)=BSPL
            CONT(3*NRD+J)=-H*K2(I)+YDIFF-BSPL
  43        CONTINUE
         END IF
         DO 44 I=1,N
         K1(I)=K2(I)
  44     Y(I)=Y1(I)
         XOLD=X
         X=XPH
         IF (IOUT.NE.0) THEN
            HOUT=H
            CALL SOLOUT(NACCPT+1,XOLD,X,Y,N,CONT,ICOMP,NRD,
     &                  RPAR,IPAR,IRTRN)
            IF (IRTRN.LT.0) GOTO 79
         END IF
C ------- NORMAL EXIT
         IF (LAST) THEN
            H=HNEW
            IDID=1
            RETURN
         END IF
         IF(ABS(HNEW).GT.HMAX)HNEW=POSNEG*HMAX
         IF(REJECT)HNEW=POSNEG*MIN(ABS(HNEW),ABS(H))
         REJECT=.FALSE.
      ELSE
C --- STEP IS REJECTED
         HNEW=H/MIN(FACC1,FAC11/SAFE)
         REJECT=.TRUE.
         IF(NACCPT.GE.1)NREJCT=NREJCT+1
         LAST=.FALSE.
      END IF
      H=HNEW
      GOTO 1
C --- FAIL EXIT
  76  CONTINUE
      IDID=-4
      RETURN
  77  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
      IF (IPRINT.GT.0) WRITE(IPRINT,*)' STEP SIZE T0O SMALL, H=',H
      IDID=-3
      RETURN
  78  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
      IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &     ' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED'
      IDID=-2
      RETURN
  79  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
 979  FORMAT(' EXIT OF DOPRI5 AT X=',E18.4)
      IDID=2
      RETURN
      END
C
      FUNCTION HINIT(N,FCN,X,Y,XEND,POSNEG,F0,F1,Y1,IORD,
     &                 HMAX,ATOL,RTOL,ITOL,RPAR,IPAR)
C ----------------------------------------------------------
C ----  COMPUTATION OF AN INITIAL STEP SIZE GUESS
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),Y1(N),F0(N),F1(N),ATOL(*),RTOL(*)
      DIMENSION RPAR(*),IPAR(*)
C ---- COMPUTE A FIRST GUESS FOR EXPLICIT EULER AS
C ----   H = 0.01 * NORM (Y0) / NORM (F0)
C ---- THE INCREMENT FOR EXPLICIT EULER IS SMALL
C ---- COMPARED TO THE SOLUTION
      DNF=0.0D0
      DNY=0.0D0
      ATOLI=ATOL(1)
      RTOLI=RTOL(1)
      IF (ITOL.EQ.0) THEN
        DO 10 I=1,N
        SK=ATOLI+RTOLI*ABS(Y(I))
        DNF=DNF+(F0(I)/SK)**2
  10    DNY=DNY+(Y(I)/SK)**2
      ELSE
        DO 11 I=1,N
        SK=ATOL(I)+RTOL(I)*ABS(Y(I))
        DNF=DNF+(F0(I)/SK)**2
  11    DNY=DNY+(Y(I)/SK)**2
      END IF
      IF (DNF.LE.1.D-10.OR.DNY.LE.1.D-10) THEN
         H=1.0D-6
      ELSE
         H=SQRT(DNY/DNF)*0.01D0
      END IF
      H=MIN(H,HMAX)
      H=SIGN(H,POSNEG)
C ---- PERFORM AN EXPLICIT EULER STEP
      DO 12 I=1,N
  12  Y1(I)=Y(I)+H*F0(I)
      CALL FCN(N,X+H,Y1,F1,RPAR,IPAR)
C ---- ESTIMATE THE SECOND DERIVATIVE OF THE SOLUTION
      DER2=0.0D0
      IF (ITOL.EQ.0) THEN
        DO 15 I=1,N
        SK=ATOLI+RTOLI*ABS(Y(I))
  15    DER2=DER2+((F1(I)-F0(I))/SK)**2
      ELSE
        DO 16 I=1,N
        SK=ATOL(I)+RTOL(I)*ABS(Y(I))
  16    DER2=DER2+((F1(I)-F0(I))/SK)**2
      END IF
      DER2=SQRT(DER2)/H
C ---- STEP SIZE IS COMPUTED SUCH THAT
C ----  H**IORD * MAX ( NORM (F0), NORM (DER2)) = 0.01
      DER12=MAX(ABS(DER2),SQRT(DNF))
      IF (DER12.LE.1.D-15) THEN
         H1=MAX(1.0D-6,ABS(H)*1.0D-3)
      ELSE
         H1=(0.01D0/DER12)**(1.D0/IORD)
      END IF
      H=MIN(100*ABS(H),H1,HMAX)
      HINIT=SIGN(H,POSNEG)
      RETURN
      END
C
      FUNCTION CONTD8(II,X,CON,ICOMP,ND)
C ----------------------------------------------------------
C     THIS FUNCTION CAN BE USED FOR CONTINUOUS OUTPUT IN CONNECTION
C     WITH THE OUTPUT-SUBROUTINE FOR DOPRI5. IT PROVIDES AN
C     APPROXIMATION TO THE II-TH COMPONENT OF THE SOLUTION AT X.
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CON(5*ND),ICOMP(ND)
      COMMON /CONDO5/XOLD,H
C ----- COMPUTE PLACE OF II-TH COMPONENT
      I=0
      DO 5 J=1,ND
      IF (ICOMP(J).EQ.II) I=J
   5  CONTINUE
      IF (I.EQ.0) THEN
         WRITE (6,*) ' NO DENSE OUTPUT AVAILABLE FOR COMP.',II
         RETURN
      END IF
      THETA=(X-XOLD)/H
      THETA1=1.D0-THETA
      CONTD8=CON(I)+THETA*(CON(ND+I)+THETA1*(CON(2*ND+I)+THETA*
     &           (CON(3*ND+I)+THETA1*CON(4*ND+I))))
      RETURN
      END
C
      SUBROUTINE CDOPRI(C2,C3,C4,C5,E1,E3,E4,E5,E6,E7,
     &                    A21,A31,A32,A41,A42,A43,A51,A52,A53,A54,
     &                    A61,A62,A63,A64,A65,A71,A73,A74,A75,A76,
     &                    D1,D3,D4,D5,D6,D7)
C ----------------------------------------------------------
C     RUNGE-KUTTA COEFFICIENTS OF DORMAND AND PRINCE (1980)
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      C2=0.2D0
      C3=0.3D0
      C4=0.8D0
      C5=8.D0/9.D0
      A21=0.2D0
      A31=3.D0/40.D0
      A32=9.D0/40.D0
      A41=44.D0/45.D0
      A42=-56.D0/15.D0
      A43=32.D0/9.D0
      A51=19372.D0/6561.D0
      A52=-25360.D0/2187.D0
      A53=64448.D0/6561.D0
      A54=-212.D0/729.D0
      A61=9017.D0/3168.D0
      A62=-355.D0/33.D0
      A63=46732.D0/5247.D0
      A64=49.D0/176.D0
      A65=-5103.D0/18656.D0
      A71=35.D0/384.D0
      A73=500.D0/1113.D0
      A74=125.D0/192.D0
      A75=-2187.D0/6784.D0
      A76=11.D0/84.D0
      E1=71.D0/57600.D0
      E3=-71.D0/16695.D0
      E4=71.D0/1920.D0
      E5=-17253.D0/339200.D0
      E6=22.D0/525.D0
      E7=-1.D0/40.D0
C ---- DENSE OUTPUT OF SHAMPINE (1986)
      D1=-12715105075.D0/11282082432.D0
      D3=87487479700.D0/32700410799.D0
      D4=-10690763975.D0/1880347072.D0
      D5=701980252875.D0/199316789632.D0
      D6=-1453857185.D0/822651844.D0
      D7=69997945.D0/29380423.D0
      RETURN
      END