! Copyright (C) 2017-2019 Matthieu Ancellin
! See LICENSE file at <https://github.com/mancellin/libDelhommeau>
MODULE Old_Prony_decomposition

  USE CONSTANTS

  IMPLICIT NONE

! The code below performs the approximation of the function FF as a sum of exponentials.
! Unlike the rest of the Fortran code, this module has not been completely refactored.
! A more readable and maintainable Python version has been implemented in libDelhommeau/bem/prony_decomposition.py.
! However, as of today (March 2019), the two versions do not give exactly the same result in all cases.
! For compatibility with Nemoh, the old version has thus been preserved.

! Unlike most of the rest of the Fortran code, these functions are only in single precision.

  PUBLIC :: FF
  PUBLIC :: LISC   ! Initialization of AMBDA and AR
  PUBLIC :: EXPORS ! Called by LISC
  PUBLIC :: MCAS   ! Called by EXPORS
  PUBLIC :: HOUSRS ! Called by EXPORS and MCAS
  PUBLIC :: SPRBM  ! Called by EXPORS
  PUBLIC :: SPQFB  ! Called by SPRBM

CONTAINS

  FUNCTION FF(XTT, AK, AM)

    ! Input
    REAL, INTENT(IN) :: XTT, AK, AM

    ! Local variables
    REAL :: COEF, TOL, A, B, C, D, E, F, FF

    COEF = (AM+AK)**2/(AM**2-AK**2+AK)

    TOL = MAX(0.1, 0.1*AM)
    IF (ABS(XTT-AM) > TOL) THEN
      FF = (XTT+AK)*EXP(XTT)/(XTT*SINH(XTT)-AK*COSH(XTT)) - COEF/(XTT-AM) - 2
    ELSE
      A = AM - TOL
      B = AM
      C = AM + TOL
      D = (A+AK)*EXP(A)/(A*SINH(A)-AK*COSH(A)) - COEF/(A-AM) - 2
      E = COEF/(AM+AK)*(AM+AK+1)               - (COEF/(AM+AK))**2*AM - 2
      F = (C+AK)*EXP(C)/(C*SINH(C)-AK*COSH(C)) - COEF/(C-AM) - 2
      FF = D*(XTT-B)*(XTT-C)/((A-B)*(A-C)) + &
           E*(XTT-C)*(XTT-A)/((B-C)*(B-A)) + &
           F*(XTT-A)*(XTT-B)/((C-A)*(C-B))
    ENDIF

    RETURN
  END FUNCTION FF

  SUBROUTINE LISC(AK0, wavenumber, &
                  AMBDA, AR, NEXP)
    ! Compute AMBDA and AR and test their values

    INTEGER, PARAMETER :: NEXR = 31
    INTEGER, PARAMETER :: NMAX = 4*(31-1)

    ! Range on which the function FF is tabulated
    REAL, PARAMETER :: A = -0.1
    REAL, PARAMETER :: B = 20.0

    REAL, PARAMETER :: PRECI = 1.0e-2

    ! Inputs
    REAL, INTENT(IN)                 :: AK0, wavenumber

    ! Outputs
    INTEGER, INTENT(OUT)             :: NEXP
    REAL, DIMENSION(31), INTENT(OUT) :: AMBDA, AR

    ! Local variables
    LOGICAL :: ISOR
    INTEGER :: I, J
    INTEGER :: NK, NM, NMO
    REAL :: XX, YY, TT
    REAL :: XT(4*(31-1)+1), YT(4*(31-1)+1) ! Tabulation of FF

    ! Initialize variables to be computed
    AMBDA = 0.0
    AR = 0.0

    ! Number of points in the tabulation (first try)
    NK = 4

62 CONTINUE

    ! Tabulate the function FF
    DO I = 1, (4*NK)+1
      XT(I) = A + (B-A)*(I-1)/(4*NK)
      YT(I) = FF(XT(I), AK0, wavenumber)
    END DO

    ! Compute AMBDA and AR based on this tabulation
    NM = NK
    CALL EXPORS(XT, YT, NM, NMAX, AMBDA, AR)

    ! Test values of AMBDA and AR
    ISOR = .False.
    NMO = 8*NM+1
    DO I = 1, NMO
      XX = (I-1)*B/(NMO-1)

      ! Exact value
      YY = FF(XX, AK0, wavenumber)

      ! Compute the sum of exponentials
      TT = 0.0
      DO J = 1, NM
        TT = TT + AR(J)*EXP(AMBDA(J)*XX)
      END DO

      ! Compare the error to a threshold
      IF (ABS(YY-TT) > PRECI) ISOR = .True.
    END DO

    ! The error was higher than the wanted precision
    IF (ISOR .AND. (NK <= NEXR-2)) THEN
      ! Add more exponentials to the sum and restart
      NK = NK+2
      GOTO 62
    END IF

    ! Final number of exponentials in the sum
    NEXP = NM

    RETURN

  END SUBROUTINE LISC

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

  SUBROUTINE EXPORS(XT, YT, NM, NMAX, AMBDA, AR)
    ! Compute AMBDA and AR based on XT and YT using Prony's method.

    INTEGER, INTENT(IN) :: NMAX
    REAL, INTENT(IN)    :: XT(4*(31-1)+1), YT(4*(31-1)+1)

    INTEGER, INTENT(INOUT) :: NM ! Number of exponentials in the sum.
    ! The number of exponentials will change during the computation, for
    ! instance if some roots of the polynomial are double and thus merged.

    REAL, INTENT(OUT) :: AR(31), AMBDA(31)

    ! Local variables
    INTEGER :: NPP

    REAL    :: SC(31), VR(31), VC(31)
    REAL    :: S(4*(31-1), 31+1)
    COMPLEX :: COM(31)

    INTEGER::I,J,K,JJ,II,IJ,MN,NEXP
    REAL::H,EPS

    ! Assemble an over-determined linear system
    NPP = 4*NM+1
    H = (XT(NPP) - XT(1))/(4*NM)
    K = NPP-NM
    DO I = 1, K
      DO J = 1, NM
        JJ = NM - J + I
        S(I, J) = YT(JJ)
      END DO
      II = NM + I
      S(I, NM+1) = -YT(II)
    END DO

    ! Solve the system
    CALL HOUSRS(S, NMAX, K, NM)

    ! Assemble the coefficients of the polynomial
    DO I = 1, NM
      IJ = NM-I+1
      SC(IJ) = S(I, NM+1)
    END DO
    MN = NM+1
    SC(MN) = 1.0

    ! Get roots of the polynomial
    CALL SPRBM(SC, MN, VR, VC)

    COM(1:NM) = CMPLX(VR(1:NM), VC(1:NM))
    COM(1:NM) = CLOG(COM(1:NM))/H
    VR(1:NM) = REAL(COM(1:NM))
    VC(1:NM) = AIMAG(COM(1:NM))

    ! Keep only the real part of the roots.
    ! In case of a double root, keep only one.
      I=1
      J=0
  100 IF(VC(I))110,111,110
  ! 100 IF (VC(I) == 0) THEN
  111 J=J+1
      AMBDA(J)=VR(I)
      I=I+1
      GO TO 101
    ! ELSE
  110 IF(ABS(VR(I)-VR(I+1))-1.E-5)120,120,121
      ! IF (ABS(VR(I)-VR(I+1)) <= -1.E-5) THEN
  120 J=J+1
      AMBDA(J)=VR(I)
      I=I+2
      GO TO 101
    ! ELSE
  121 J=J+1
      AMBDA(J)=VR(I)
      I=I+1
    ! END IF
    ! END IF
  101 IF(I-NM)100,100,102
  102 NEXP=J

    ! Rewrite AMBDA while keeping only the values between -20.0 and 0.0
    J = 0
    DO I = 1, NEXP
      IF ((AMBDA(I) > -20.0) .AND. (AMBDA(I) <= 0.0)) THEN
        J = J+1
        AMBDA(J) = AMBDA(I)
      END IF
    END DO

    ! Number of relevant values in AMBDA
    NEXP = J
    NM = NEXP

    ! Compute AR
    CALL MCAS(AMBDA, XT, YT, NPP, AR, S, NMAX, NEXP)

    RETURN
  END SUBROUTINE EXPORS

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

  SUBROUTINE MCAS(AMBDA, XT, YT, NPP, AR, A, NMAX, NEXP)
    ! Compute AR as the least-square solution of an over-determined system.

    REAL, INTENT(IN)    :: AMBDA(31), XT(4*(31-1)+1), YT(4*(31-1)+1)
    INTEGER, INTENT(IN) :: NPP, NMAX, NEXP
    REAL, INTENT(INOUT) :: A(4*(31-1), 31+1)
    REAL, INTENT(OUT)   :: AR(31)

    ! Local variables
    INTEGER :: I, J, L
    REAL :: S, TT, TTT

    ! Assemble the system
    DO I = 1, NEXP
      DO J = 1, NEXP
        S = 0
        DO L = 1, NPP
          TT = (AMBDA(I)+AMBDA(J))*XT(L)
          IF(TT >= -30) THEN
            S = S + EXP(TT)
          END IF
        END DO
        A(I,J) = S
      END DO
    END DO

    DO I = 1, NEXP
      S = 0
      DO L = 1, NPP
        TTT = AMBDA(I)*XT(L)
        IF(TTT >= -30) THEN
          S = S + EXP(TTT)*YT(L)
        END IF
      END DO
      A(I, NEXP+1) = S
    END DO

    ! Solve it
    CALL HOUSRS(A, NMAX, NEXP, NEXP)

    ! Extract results
    DO I = 1, NEXP
      AR(I) = A(I, NEXP+1)
    END DO

    RETURN
  END SUBROUTINE MCAS

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

  SUBROUTINE HOUSRS(A, NMAX, NL, NCC)
    ! Least-square solver for over-determined system.
    ! NCC : Number of columns
    ! NL: Number of lines

    INTEGER, INTENT(IN) :: NMAX, NL, NCC
    REAL, INTENT(INOUT) :: A(NMAX, 31+1)

    ! Local variables
    INTEGER, PARAMETER :: NS = 1
    REAL, PARAMETER :: EPS = 1e-20

    INTEGER :: I, J, K, L
    REAL    :: E, E0, AR, BA, ETA

    IF (NCC > NL) THEN
      PRINT*, ('Error in HOUSRS: number of columns > number of lines')
      STOP
    ENDIF

    DO K = 1, NCC
      E = 0.0
      DO I = K, NL
        E = E + A(I, K)**2
      END DO

      E0 = SQRT(E)
      ! IF(E0.LT.EPS)THEN
      !   WRITE(*, 201)EPS
    ! 201 FORMAT(1X, 'NORME INFERIEURE A ', 1PE16.6/)
      !   STOP
      ! ENDIF
      IF (A(K, K) == 0) THEN
        AR = -E0
      ELSE
        AR = -SIGN(1.0, A(K, K)) * E0
      ENDIF

      ETA = AR*(AR - A(K, K))
      DO J = K+1, NCC+NS
        BA = (A(K, K)-AR)*A(K, J)
        DO I = K+1, NL
          BA = BA+A(I, K)*A(I, J)
        END DO
        A(K, J) = A(K, J)+BA/AR
        DO I = K+1, NL
          A(I, J) = A(I, J)-A(I, K)*BA/ETA
        END DO
      END DO

      A(K, K) = AR
      DO I = K+1, NL
        A(I, K) = 0
      END DO
    END DO

    DO J = 1, NS
      A(NCC, NCC+J) = A(NCC, NCC+J)/A(NCC, NCC)
      DO L = 2, NCC
        DO I = NCC+2-L, NCC
          A(NCC+1-L, NCC+J) = A(NCC+1-L, NCC+J) - A(NCC+1-L, I)*A(I, NCC+J)
        END DO
        A(NCC+1-L, NCC+J) = A(NCC+1-L, NCC+J)/A(NCC+1-L, NCC+1-L)
      END DO
    END DO

    RETURN
  END SUBROUTINE HOUSRS

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

  SUBROUTINE SPRBM(C,IC,RR,RC)
    ! Somehow get the roots of a polynomial.

    INTEGER::IC,IR,IER
    REAL :: C(31), RR(31), RC(31)
    REAL :: POL(31)
    INTEGER::I,J,L,N,LIM,IST
    REAL::A,B,H
    REAL::EPS,Q1,Q2,Q(4)

      EPS=1.E-6
      LIM=100
      IR=IC+1
    1 IR=IR-1
      IF(IR-1)42,42,2
    2 IF(C(IR))3,1,3
    3 IER=0
      J=IR
      L=0
      A=C(IR)
      DO 8 I=1,IR
      IF(L)4,4,7
    4 IF(C(I))6,5,6
    5 RR(I)=0.
      RC(I)=0.
      POL(J)=0.
      J=J-1
      GO TO 8
    6 L=1
      IST=I
      J=0
    7 J=J+1
      C(I)=C(I)/A
      POL(J)=C(I)
      IF(ABS(POL(J))-1.E27)8,42,42
    8 CONTINUE
      Q1=0.
      Q2=0.
    9 IF(J-2)33,10,14
   10 A=POL(1)
      RR(IST)=-A
      RC(IST)=0.
      IR=IR-1
      Q2=0.
      IF(IR-1)13,13,11
   11 DO 12 I=2,IR
      Q1=Q2
      Q2=POL(I+1)
   12 POL(I)=A*Q2+Q1
   13 POL(IR+1)=A+Q2
      GO TO 34
   14 DO 22 L=1,10
      N=1
   15 Q(1)=Q1
      Q(2)=Q2
      CALL SPQFB(POL,J,Q,LIM,I)
      IF(I)16,24,23
   16 IF(Q1)18,17,18
   17 IF(Q2)18,21,18
   18 GOTO(19,20,19,21),N
   19 Q1=-Q1
      N=N+1
      GO TO 15
   20 Q2=-Q2
      N=N+1
      GO TO 15
   21 Q1=1.+Q1
   22 Q2=1.-Q2
      IER=3
      IR=IR-J
      GOTO 45
   23 IER=1
   24 Q1=Q(1)
      Q2=Q(2)
      B=0.
      A=0.
      I=J
   25 H=-Q1*B-Q2*A+POL(I)
      POL(I)=B
      B=A
      A=H
      I=I-1
      IF(I-2)26,26,25
   26 POL(2)=B
      POL(1)=A
      L=IR-1
      IF(J-L)27,27,29
   27 DO 28 I=J,L
   28 POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1
   29 POL(L)=POL(L)+POL(L+1)*Q2+Q1
      POL(IR)=POL(IR)+Q2
      H=-.5*Q2
      A=H*H-Q1
      B=SQRT(ABS(A))
      IF(A)30,30,31
   30 RR(IST)=H
      RC(IST)=B
      IST=IST+1
      RR(IST)=H
      RC(IST)=-B
      GO TO 32
   31 B=H+SIGN(B,H)
      RR(IST)=Q1/B
      RC(IST)=0.
      IST=IST+1
      RR(IST)=B
      RC(IST)=0.
   32 IST=IST+1
      J=J-2
      GO TO 9
   33 IR=IR-1
   34 A=0.
      DO 38 I=1,IR
      Q1=C(I)
      Q2=POL(I+1)
      POL(I)=Q2
      IF(Q1)35,36,35
   35 Q2=(Q1-Q2)/Q1
   36 Q2=ABS(Q2)
      IF(Q2-A)38,38,37
   37 A=Q2
   38 CONTINUE
      I=IR+1
      POL(I)=1.
      RR(I)=A
      RC(I)=0.
      IF(IER)39,39,41
   39 IF(A-EPS)41,41,40
   40 IER=-1
   41 GOTO 45
   42 IER=2
      IR=0
   45 IF(IER-2)46,47,46
   47 WRITE(*,48)IER
   48 FORMAT(/5X,'IER = ',I3,'  ERREUR DANS SPRBM'/)
      STOP
   46 RETURN

  END SUBROUTINE SPRBM

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

  SUBROUTINE SPQFB(C,IC,Q,LIM,IER)

    INTEGER::IC,LIM,IER,I,J,L,LL
    REAL:: C(31),Q(4)
    REAL:: H,HH,A,A1,AA,B,BB,B1,C1,CA,CB,CC,CD,DQ1,DQ2,EPS,EPS1
    REAL:: Q1,Q2,QQ1,QQ2,QQQ1,QQQ2

!--------- Value non initialized in previous versions ?!
      H=0.
      HH=0.
!---------
      IER=0
      J=IC+1
    1 J=J-1
      IF(J-1) 40,40,2
    2 IF(C(J)) 3,1,3
    3 A=C(J)
      IF(A-1.) 4,6,4
    4 DO 5 I=1,J
      C(I)=C(I)/A
      IF(ABS(C(I))-1.E27)5,40,40
    5 CONTINUE
    6 IF(J-3) 41,38,7
    7 EPS=1.E-14
      EPS1=1.E-6
      L=0
      LL=0
      Q1=Q(1)
      Q2=Q(2)
      QQ1=0.
      QQ2=0.
      AA=C(1)
      BB=C(2)
      CB=ABS(AA)
      CA=ABS(BB)
      IF(CB-CA) 8,9,10
    8 CC=CB+CB
      CB=CB/CA
      CA=1.
      GO TO 11
    9 CC=CA+CA
      CA=1.
      CB=1.
      GO TO 11
   10 CC=CA+CA
      CA=CA/CB
      CB=1.
   11 CD=CC*.1
   12 A=0.
      B=A
      A1=A
      B1=A
      I=J
      QQQ1=Q1
      QQQ2=Q2
      DQ1=HH
      DQ2=H
   13 H=-Q1*B-Q2*A+C(I)
      IF(ABS(H)-1.E27)14,42,42
   14 B=A
      A=H
      I=I-1
      IF(I-1) 18,15,16
   15 H=0.
   16 H=-Q1*B1-Q2*A1+H
      IF(ABS(H)-1.E27)17,42,42
   17 C1=B1
      B1=A1
      A1=H
      GO TO 13
   18 H=CA*ABS(A)+CB*ABS(B)
      IF(LL) 19,19,39
   19 L=L+1
      IF(ABS(A)-EPS*ABS(C(1))) 20,20,21
   20 IF(ABS(B)-EPS*ABS(C(2))) 39,39,21
   21 IF(H-CC) 22,22,23
   22 AA=A
      BB=B
      CC=H
      QQ1=Q1
      QQ2=Q2
   23 IF(L-LIM) 28,28,24
   24 IF(H-CD) 43,43,25
   25 IF(Q(1)) 27,26,27
   26 IF(Q(2)) 27,42,27
   27 Q(1)=0.
      Q(2)=0.
      GO TO 7
   28 HH=AMAX1(ABS(A1),ABS(B1),ABS(C1))
      IF(HH) 42,42,29
   29 A1=A1/HH
      B1=B1/HH
      C1=C1/HH ! Has C1 been intialized?
      H=A1*C1-B1*B1
      IF(H) 30,42,30
   30 A=A/HH
      B=B/HH
      HH=(B*A1-A*B1)/H
      H=(A*C1-B*B1)/H
      Q1=Q1+HH
      Q2=Q2+H
      IF(ABS(HH)-EPS*ABS(Q1)) 31,31,33
   31 IF(ABS(H)-EPS*ABS(Q2)) 32,32,33
   32 LL=1
      GO TO 12
   33 IF(L-1)12,12,34
   34 IF(ABS(HH)-EPS1*ABS(Q1)) 35,35,12
   35 IF(ABS(H)-EPS1*ABS(Q2)) 36,36,12
   36 IF(ABS(QQQ1*HH)-ABS(Q1*DQ1)) 37,44,44
   37 IF(ABS(QQQ2*H)-ABS(Q2*DQ2)) 12,44,44
   38 Q(1)=C(1)
      Q(2)=C(2)
      Q(3)=0.
      Q(4)=0.
      GOTO 45
   39 Q(1)=Q1
      Q(2)=Q2
      Q(3)=A
      Q(4)=B
      GOTO 45
   40 IER=-1
      GOTO 45
   41 IER=-2
      GOTO 45
   42 IER=-3
      GO TO 44
   43 IER=1
   44 Q(1)=QQ1
      Q(2)=QQ2
      Q(3)=AA
      Q(4)=BB
   45 RETURN

  END SUBROUTINE SPQFB

END MODULE Old_Prony_decomposition


C     ===================
      Program Test_Minuit
C     ===================
      Implicit DoublePrecision (A-H,O-Z)

      Character*8 CVar

      External FCN
      External Futil

C     ================
C     Interactive Call
C     ================

      Call Minuit(FCN,Futil)

      Stop
      End

C     ===============================================
      Subroutine FCN(NPAR,GRAD,FVAL,XVAL,IFLAG,FUTIL)
C     ===============================================

      Implicit DoublePrecision (A-H,O-Z)

      External Futil

!     Parameter (Np=100)

      Dimension YY(512,512),new_img(512,512)
      Dimension XVal(*),Grad(*)

C     +------------------+
C     |  Initialization  |
C     +------------------+

      If (IFLAG.EQ.1) Then

C     =========
C     Read Data
C     =========

          Open (Unit=11,file='big.txt',Status='OLD')

          Do j = 1,512
             Read (11,*) (YY(i,j), i=1,512)
          Enddo

          Close (11)

          Write (*,*) 'Matrix successfully loaded'
          max_inp = 0.0d0
          Do i=1,512
              Do j=1,512
                  If (YY(i,j).GT.max_inp) Then
                  	max_inp = YY(i,j)
                  EndIf
              EndDo
          EndDo

          Do i=1,512
              Do j=1,512
                  YY(i,j) = YY(i,j)/max_inp
                  If (YY(i,j)>0.4d0) Then
                      YY(i,j) = 1.0d0
                  Else
                      YY(i,j) = 0.0d0
                  EndIf
              EndDo
          EndDo

      EndIf

C     +-------------------+
C     |  Calclulate Chi2  |
C     +-------------------+

      x0     = Xval(1)
      y0     = Xval(2)
      sx     = Xval(3)
      sy     = Xval(4)
      drx    = Xval(5)
      dry    = Xval(6)
      phi    = Xval(7)

      Chi2 = 0.0d0

      Do i=1,512
          Do j=1,512
              x=j
              y=i
              new_img(i,j) = 0.0d0
              rr = sqrt((x-x0)*(x-x0) + (y-y0)*(y-y0))
              the = datan2(y-y0,x-x0)
              part_a = sy*sy*cos(the-phi)*cos(the-phi)
              part_b = sx*sx*sin(the-phi)*sin(the-phi)
              srr = (sx*sy) / dsqrt(part_a + part_b)
              p_a = (sy+dry)*(sy+dry)*cos(the-phi)*cos(the-phi)
              p_b = (sx+drx)*(sx+drx)*sin(the-phi)*sin(the-phi)
              srdr = (sx+drx)*(sy+dry)/dsqrt(p_a + p_b)

              If ((rr.LE.srdr).AND.(rr.GE.srr)) Then
                  new_img(i,j) = 1.0d0
              Endif
          EndDo
      EndDo
      FVal = 0.0d0

      Do i=1,512
          Do j=1,512
              diff = (new_img(i,j)-YY(i,j))
              FVal = FVal + (diff*diff)
          EndDo
      EndDo

C     +--------------------------------+
C     |  Fit Ended - Write Parameters  |
C     +--------------------------------+

      If (IFLAG.EQ.3) Then

         Write (*,*)

         Do i=1,NPAR
            Write (*,101) i,XVal(i)
         EndDo

         Write (*,*)

  101 Format (4x,I2,'. Parameter =',F12.4)

      EndIf

      Return
      End

C     ================
      Subroutine Futil
C     ================

      Return
      End


C NCLFORTSTART
      SUBROUTINE DFILTRQ(NWT,FCA,FCB,NSIGMA,IHP,WT,RESP,FREQ,IER)
      IMPLICIT NONE

c NCL:  wt = filwgts_lancos (nwt, ihp, fca,fcb,nsigma)
c       wt@freq = freq
c       wt@resp = resp

c routine to calculate filter wgts and the associated response function

c see an article by c. duchon (u. of oklahoma):
c                   j. applied meteorology;  august,1979; pp 1016-1022
c                   "lanczos filtering in one and two dimensions"

      INTEGER NWT,IHP,IER
      DOUBLE PRECISION FCA,FCB,NSIGMA
      DOUBLE PRECISION WT(NWT)
      DOUBLE PRECISION FREQ(2*NWT-1),RESP(2*NWT-1)
c c c real    freq(*), resp(*)
C NCLEND

c input parameters :
c
c     nwt     total number of weights (an odd number; nwt.ge.3)
c             the more wgts .... the better the filter but there
c             is a greater loss of data.
c
c     fca     the cut-off freq of the ideal high or
c             low-pass filter: [ 0.0 < fca < 0.5 ]
c
c     fcb     used only when a band-pass filter is desired,
c             in which case it is the cut-off freq for the
c             second low-pass filter:  [ fca < fcb < 0.5 ]
c
c     nsigma  the power of the sigma factor.  it is
c             greater than or equal to zero.
c             note: nsigma=1 to 3 is usually good enough.
c
c     ihp     if low-pass filter ihp = 0,
c             if high-pass ihp = 1,
c             if band-pass ihp = 2.
c
c     work    work array of length nwt
c
c output parameters :
c
c     wt      vector containing the computed wgts. its length is nwt.
c             the central weight is located at nwt/2+1.
c
c     resp    the array of responses at freq intvls
c             of 0.5/(2*nwt-2)  cycles/data intvl from the
c             origin to the nyquist.  its length is 2*nwt-1.
c
c     freq    the array of freqs at intvls of 0.5/(2*nwt-2)
c             cycles/data intvl at which the responses
c             are calculated.  its length is 2*nwt-1 .
c
c     ier     simple error code
c                                                   ! automatic
      DOUBLE PRECISION WORK(NWT)
      DOUBLE PRECISION PI,TWOPI,FNW,SUM,FRQINT
      INTEGER NW,N,NWP1,I,J,NF

      IER = 0
C      IF (NWT.LT.3) IER = 1
C      IF (IHP.LT.0 .OR. IHP.GT.2) IER = IER + 10
C      IF (FCA.LT.0.0D0 .OR. FCA.GT.0.5D0) IER = IER + 100
C      IF (IHP.EQ.2) THEN
C          IF (FCB.LT.0.0D0 .OR. FCB.GT.0.5D0) IER = IER + 1000
C          IF (FCB.LT.FCA) IER = IER + 10000
C      END IF

      IF (IER.NE.0) RETURN

      PI = 4.D0*ATAN(1.0D0)
      TWOPI = 2.D0*PI
      NW = (NWT-1)/2
      FNW = DBLE(NW)

c compute weights

      CALL DFILWTQ(WT,NWT,NW,FCA,PI,TWOPI,NSIGMA)
c                               ! alter weights to get high-pass filter.
      IF (IHP.EQ.1) THEN
          WT(1) = 1.0D0 - WT(1)
          DO I = 2,NW + 1
              WT(I) = -WT(I)
          END DO
      ELSE IF (IHP.EQ.2) THEN
c                               ! compute wgts of 2nd low-pass filt
c                               ! save 1st set of low pass filter wgts
          DO I = 1,NW + 1
              WORK(I) = WT(I)
          END DO
          CALL DFILWTQ(WT,NWT,NW,FCB,PI,TWOPI,NSIGMA)
c                               ! alter weights to get band-pass filter
          DO I = 1,NW + 1
              WT(I) = WT(I) - WORK(I)
          END DO
      END IF

c compute response fctn

      SUM = 0.0D0
      NF = 2*NWT - 1
      FREQ(1) = 0.0D0
      FRQINT = 0.5D0/DBLE(NF-1)
      DO J = 2,NW + 1
          SUM = SUM + 2.0D0*WT(J)
      END DO
      RESP(1) = SUM + WT(1)

      DO I = 2,NF
          SUM = 0.0D0
          FREQ(I) = DBLE(I-1)*FRQINT
          DO J = 2,NW + 1
              SUM = SUM + WT(J)*COS(TWOPI*FREQ(I)*DBLE(J-1))
          END DO
          RESP(I) = WT(1) + 2.0D0*SUM
      END DO

c make wt symmetric

      NWP1 = NW + 1
      DO N = 1,NW
          WORK(N) = WT(N+1)
      END DO
      WT(NWP1) = WT(1)
      DO N = 1,NW
          WT(N) = WORK(NWP1-N)
          WT(NWP1+N) = WORK(N)
      END DO

      RETURN
      END
c ----------------------------------------------------------
      SUBROUTINE DFILWTQ(WT,NWT,NW,FC,PI,TWOPI,NSIGMA)
      IMPLICIT NONE

c compute and normalize filter wgts

      INTEGER NWT,NW
      DOUBLE PRECISION WT(NWT),FC,PI,TWOPI,NSIGMA
c                                                ! local
      DOUBLE PRECISION ARG,FNW,SINX,SINY,SUM
      INTEGER I

      ARG = TWOPI*FC
      FNW = DBLE(NW)

      WT(1) = 2.0D0*FC
      DO I = 1,NW
          SINX = SIN(ARG*DBLE(I))/ (PI*DBLE(I))
          SINY = FNW*SIN(DBLE(I)*PI/FNW)/ (DBLE(I)*PI)
          WT(I+1) = SINX*SINY**NSIGMA
      END DO

c                                                ! normalize weights
      SUM = WT(1)
      DO I = 2,NW + 1
          SUM = SUM + 2.0D0*WT(I)
      END DO
      DO I = 1,NW + 1
          WT(I) = WT(I)/SUM
      END DO

      RETURN
      END

C NCLFORTSTART
      subroutine filwgtnormal (nwt, w, itype, sigma, ier)
      implicit none
      integer  nwt, itype, ier
      double precision     w(nwt), sigma
C NCLEND
c
c NCL: wgts = filwgts(nwt, sigma, itype)
c currently this only does gaussian (normal) weights
c
      double precision    pi, c1, c2, mean, delx, x, wsum
      integer n

      ier  = 0
      mean = 0.0d0

      pi   = 4.d0*atan(1.d0)
      c1   = 1.d0/(sigma*sqrt(2.d0*pi))
      c2   = -0.5d0/sigma**2

c                   delx = fspan(-1, 1, nwt)
      delx = 2.d0/(nwt-1)

c c c if (itype.eq.0) then
          x    = -(1.d0+delx)
          wsum = 0.0d0
          do n=1,nwt
             x = x+delx
             w(n) = c1*exp(c2*(x-mean)**2)
             wsum = wsum+w(n)
          end do
c c c else
c c c     ier = 1
c c c     print ("filwgts: unsupported option")
c c c end if

      do n=1,nwt
         w(n) = w(n)/wsum
      end do

      return
      end


!
!   FnXSH.f90
!
!
!   Created by Kurt Mitman on 19/03/15.
!   Copyright 2015 __MyCompanyName__. All rights reserved.
!

SUBROUTINE DFOVEC(N, MV, X, FVEC)
!     SUBROUTINE dfovec(n, mv, x, v_err) must be provided by the user.
!     It must provide the values of the vector function v_err(x) : R^n to R^{mv}
!     at the variables X(1),X(2),...,X(N), which are generated automatically in
!     a way that satisfies the bounds given in XL and XU.

!     Min  F(x) := Sum_{i=1}^{mv}  v_err_i(x)^2, s.t. xl <= x <= xu, x \in R^n,
!     where v_err(x) : R^n \to R^{mv} is a vector function.
  USE Params
  USE Globals
  USE funcs
  USE Procedures

  IMPLICIT NONE
      INTEGER, INTENT(IN) :: n,mv
      REAL(8), DIMENSION(n), INTENT(IN)   :: x
      REAL(8), DIMENSION(mv), INTENT(OUT) :: FVEC

CALL  BiLinInterp1(ngpPhh,GridPh,ngpPhr,GridPrPh,xsdemand1,x(1),x(2),FVEC(1))
CALL  BiLinInterp1(ngpPhh,GridPh,ngpPhr,GridPrPh,xsdemand2,x(1),x(2),FVEC(2))
!FnXSdemand = (pph(1)-0.50)**2+(pph(2)-0.10d0)**2

END SUBROUTINE DFOVEC


SUBROUTINE p82(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.2 One dimensional consolidation analysis
! (settlement and excess pore pressure) using 2-node "line" elements.
! Implicit time integration using the "theta" method.
!-------------------------------------------------------------------------
 USE main
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,nels,neq,nlen,nod=2,npri,nprops=2,       &
   np_types,nres,nstep,ntime
 REAL(iwp)::at,a0,dtim,gamw,penalty=1.0e20_iwp,pt5=0.5_iwp,sc,sl,theta,   &
   time,uav,uavs,zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),kdiag(:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::bp(:),ell(:),kc(:,:),kv(:),loads(:),mm(:,:),      &
   newlo(:),press(:),prop(:,:),storbp(:),value(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 neq=nels+1
 ALLOCATE(num(nod),etype(nels),kc(nod,nod),mm(nod,nod),press(0:neq),      &
   prop(nprops,np_types),ell(nels),kdiag(neq),loads(0:neq),newlo(0:neq))
 READ(10,*)prop,gamw  ! prop(1,:)=k, prop(2,:)=mv
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell,dtim,nstep,theta,npri,nres,ntime
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),bp(kdiag(neq)))
 bp=zero
 kv=zero
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------global conductivity and "mass" matrix assembly----
 elements_2: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL rod_km(kc,prop(1,etype(iel))/gamw,ell(iel))
   CALL rod_mm(mm,ell(iel)*prop(2,etype(iel)))
   CALL fsparv(kv,kc,num,kdiag)
   CALL fsparv(bp,mm,num,kdiag)
 END DO elements_2
 kv=kv*theta*dtim
 bp=bp+kv
 kv=bp-kv/theta
!-----------------------specify initial and boundary values---------------
 READ(10,*)loads(1:)
 loads(0)=zero
 a0=zero
 sc=zero
 DO iel=1,nels
   a0=a0+pt5*ell(iel)*(loads(iel)+loads(iel+1))
   sc=sc+pt5*ell(iel)*prop(2,etype(iel))*(loads(iel)+loads(iel+1))
 END DO
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
            storbp(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   bp(kdiag(node))=bp(kdiag(node))+penalty
   storbp=bp(kdiag(node))
 END IF
!-----------------------factorise equations-------------------------------
 CALL sparin(bp,kdiag)
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/2A,I4,A)')"    Time         U_av       U_av_s",              &
   "    Settlement  Pressure (node",nres,")"
 WRITE(11,'(6E12.4)')0.0,0.0,0.0,0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   CALL linmul_sky(kv,loads,newlo,kdiag)
   IF(fixed_freedoms/=0)newlo(node)=storbp*value
   CALL spabac(bp,newlo,kdiag)
   loads=newlo
   at=zero
   sl=zero
   DO iel=1,nels
     at=at+pt5*ell(iel)*(loads(iel)+loads(iel+1))
     sl=sl+pt5*ell(iel)*prop(2,etype(iel))*(loads(iel)+loads(iel+1))
   END DO
   uav=(a0-at)/a0
   uavs=(sc-sl)/sc
   IF(j==ntime)press(1:)=loads(1:)
   IF(j/npri*npri==j)WRITE(11,'(6E12.4)')time,uav,uavs,sc-sl,loads(nres)
 END DO timesteps
 WRITE(11,'(/A,E10.4,A)')"    Depth     Pressure (time=",ntime*dtim,")"
 WRITE(11,'(3E12.4)')0.0,press(1)
 WRITE(11,'(2E12.4)')(SUM(ell(1:i)),press(i+1),i=1,nels)

END SUBROUTINE p82


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't502-operator-f.h'
!-----------------------------------------------------------------------
      program test

      include 'ceed/fortran.h'

      integer ceed,err,i,j
      integer stridesu(3)
      integer erestrictx,erestrictui
      integer erestrictucoarse,erestrictufine
      integer bx,bucoarse,bufine
      integer qf_setup,qf_mass
      integer op_setup,op_masscoarse,op_massfine
      integer op_prolong,op_restrict
      integer qdata,x,ucoarse,ufine,vcoarse,vfine,pmultfine
      integer nelem,pcoarse,pfine,q,ncomp
      parameter(ncomp=2)
      parameter(nelem=15)
      parameter(pcoarse=3)
      parameter(pfine=5)
      parameter(q=8)
      integer nx,nucoarse,nufine
      parameter(nx=nelem+1)
      parameter(nucoarse=nelem*(pcoarse-1)+1)
      parameter(nufine=nelem*(pfine-1)+1)
      integer indx(nelem*2)
      integer inducoarse(nelem*pcoarse)
      integer indufine(nelem*pfine)
      real*8 arrx(nx)
      integer*8 voffset,xoffset
      real*8 val

      real*8 hv(nufine*ncomp)
      real*8 total

      character arg*32

      external setup,mass

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=0,nx-1
        arrx(i+1)=i/(nx-1.d0)
      enddo
      do i=0,nelem-1
        indx(2*i+1)=i
        indx(2*i+2)=i+1
      enddo
      call ceedelemrestrictioncreate(ceed,nelem,2,1,1,nx,ceed_mem_host,&
     & ceed_use_pointer,indx,erestrictx,err)

      do i=0,nelem-1
        do j=0,pcoarse-1
          inducoarse(pcoarse*i+j+1)=i*(pcoarse-1)+j
        enddo
      enddo
      call ceedelemrestrictioncreate(ceed,nelem,pcoarse,ncomp,nucoarse,&
     & ncomp*nucoarse,ceed_mem_host,ceed_use_pointer,inducoarse,&
     & erestrictucoarse,err)

      do i=0,nelem-1
        do j=0,pfine-1
          indufine(pfine*i+j+1)=i*(pfine-1)+j
        enddo
      enddo
      call ceedelemrestrictioncreate(ceed,nelem,pfine,ncomp,nufine,&
     & ncomp*nufine,ceed_mem_host,ceed_use_pointer,indufine,&
     & erestrictufine,err)

     stridesu=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,q*nelem,stridesu,&
     & erestrictui,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,ncomp,pfine,q,ceed_gauss,&
     & bufine,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,ncomp,pcoarse,q,ceed_gauss,&
     & bucoarse,err)

     call ceedqfunctioncreateinterior(ceed,1,setup,&
    &SOURCE_DIR&
    &//'t502-operator.h:setup'//char(0),qf_setup,err)
     call ceedqfunctionaddinput(qf_setup,'weight',1,ceed_eval_weight,err)
     call ceedqfunctionaddinput(qf_setup,'dx',1,ceed_eval_grad,err)
     call ceedqfunctionaddoutput(qf_setup,'qdata',1,ceed_eval_none,err)

     call ceedqfunctioncreateinterior(ceed,1,mass,&
    &SOURCE_DIR&
    &//'t502-operator.h:mass'//char(0),qf_mass,err)
     call ceedqfunctionaddinput(qf_mass,'qdata',1,ceed_eval_none,err)
     call ceedqfunctionaddinput(qf_mass,'u',ncomp,ceed_eval_interp,err)
     call ceedqfunctionaddoutput(qf_mass,'v',ncomp,ceed_eval_interp,err)

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_massfine,err)

      call ceedvectorcreate(ceed,nx,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)
      call ceedvectorcreate(ceed,nelem*q,qdata,err)

      call ceedoperatorsetfield(op_setup,'weight',ceed_elemrestriction_none,&
     & bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup,'dx',erestrictx,bx,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup,'qdata',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_massfine,'qdata',erestrictui,&
     & ceed_basis_collocated,qdata,err)
      call ceedoperatorsetfield(op_massfine,'u',erestrictufine,bufine,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_massfine,'v',erestrictufine,bufine,&
     & ceed_vector_active,err)

      call ceedoperatorapply(op_setup,x,qdata,ceed_request_immediate,err)

! Create multigrid level
      call ceedvectorcreate(ceed,ncomp*nufine,pmultfine,err)
      val=1.0
      call ceedvectorsetvalue(pmultfine,val,err)
      call ceedoperatormultigridlevelcreate(op_massfine,pmultfine,&
     & erestrictucoarse,bucoarse,op_masscoarse,op_prolong,op_restrict,err)

! Coarse problem
      call ceedvectorcreate(ceed,ncomp*nucoarse,ucoarse,err)
      val=1.0
      call ceedvectorsetvalue(ucoarse,val,err)
      call ceedvectorcreate(ceed,ncomp*nucoarse,vcoarse,err)
      call ceedoperatorapply(op_masscoarse,ucoarse,vcoarse,&
     & ceed_request_immediate,err)

! Check output
      call ceedvectorgetarrayread(vcoarse,ceed_mem_host,hv,voffset,err)
      total=0.
      do i=1,nucoarse*ncomp
        total=total+hv(voffset+i)
      enddo
      if (abs(total-2.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(vcoarse,hv,voffset,err)

! Prolong coarse u
      call ceedvectorcreate(ceed,ncomp*nufine,ufine,err)
      call ceedoperatorapply(op_prolong,ucoarse,ufine,&
     & ceed_request_immediate,err)

! Fine problem
      call ceedvectorcreate(ceed,ncomp*nufine,vfine,err)
      call ceedoperatorapply(op_massfine,ufine,vfine,&
     & ceed_request_immediate,err)

! Check output
      call ceedvectorgetarrayread(vfine,ceed_mem_host,hv,voffset,err)
      total=0.
      do i=1,nufine*ncomp
        total=total+hv(voffset+i)
      enddo
      if (abs(total-2.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area Fine Grid: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(vfine,hv,voffset,err)

! Restrict state to coarse grid
      call ceedoperatorapply(op_restrict,vfine,vcoarse,&
     & ceed_request_immediate,err)

! Check output
      call ceedvectorgetarrayread(vcoarse,ceed_mem_host,hv,voffset,err)
      total=0.
      do i=1,nucoarse*ncomp
        total=total+hv(voffset+i)
      enddo
      if (abs(total-2.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area Coarse Grid: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(vcoarse,hv,voffset,err)

      call ceedvectordestroy(qdata,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(ucoarse,err)
      call ceedvectordestroy(ufine,err)
      call ceedvectordestroy(vcoarse,err)
      call ceedvectordestroy(vfine,err)
      call ceedvectordestroy(pmultfine,err)
      call ceedoperatordestroy(op_masscoarse,err)
      call ceedoperatordestroy(op_massfine,err)
      call ceedoperatordestroy(op_prolong,err)
      call ceedoperatordestroy(op_restrict,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedbasisdestroy(bucoarse,err)
      call ceedbasisdestroy(bufine,err)
      call ceedbasisdestroy(bx,err)
      call ceedelemrestrictiondestroy(erestrictucoarse,err)
      call ceedelemrestrictiondestroy(erestrictufine,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


!$Id$
! Copyright (c) 2016 Anton Shterenlikht, The University of Bristol, UK
!
! Module with error function and related functions.
! Two algorithms are implemented: Poppe and Wijers (wpop, erf_pop)
! and Zaghloul and Ali (wzag, erf_zag). The second algorithm is
! supposed to be more accurate for some values. However, the first
! algorithm can be over an order of magnitude faster.
!
! This code was written before the author became aware of
! M. R. Zaghloul, Remark on "Algorithm 916: Computing the
! Faddeyeva and Voight functions": efficiency improvements and
! Fortran translation, ACM Trans. Math. Software 42, Article 26, 2016.

module errfun
use iso_fortran_env, only: real64
implicit none

integer, parameter :: rkind = real64
real( kind=rkind ), parameter :: zero = 0.0_rkind, one = 1.0_rkind,    &
   two = 2.0_rkind, half = 0.5_rkind, rmin = tiny( one ),              &
   eps0 = epsilon( one ), sqrt_log_rmin = sqrt( -log( rmin ) ),        &
   pi = 3.14159265358979323846264338327950288419_rkind,                &
   pi2 = pi * pi, one_sqrt_pi = one / sqrt( pi )
complex( kind=rkind ), parameter ::                                    &
   cmplxj = cmplx( zero, one, kind=rkind ),                            &
   cmplx0 = cmplx( zero, zero, kind=rkind )

private
public :: rkind, eps0, wpop, wzag, erf_pop, erf_zag

contains

!*********************************************************************72
elemental complex( kind=rkind ) function wzag( z, err )

! This is the Faddeyeva or the plasma dispersion function,
! w(z) = exp(-z**2) * erfc(-i*z). erfc(z) is the complex complementary
! error function of z. z is a complex number.
!
! Adapted from the Matlab code implementing TOMS
! Algorithm 916: http://www.netlib.org/toms/
!
! file: 916.zip
! ref: TOMS 38,2 (Dec 2011) Article: 15
! for: Computing the Faddeyeva and Voigt Functions
! by: Mofreh R. Zaghloul and Ahmed N. Ali
!
! Most of the code is calculation of equations (13)-(19) of the
! above paper.
!
! Inputs:
!    z - the argument of the function
!  err - The desired accuracy (positive). err must be (err .le. 1.0e-4)
!        and  (err .ge. 0.06447*epsilon). For efficiency,
!        no checks are made!
!        The lowest accuracy and the fastest calculation are obtained
!        with err .eq. 1.0e-4. For higher accuracy use smaller err.

 complex( kind=rkind ), intent(in) :: z
 real( kind=rkind ), intent(in) :: err

 real( kind=rkind ) :: a, half_a, a_sqr, two_a, two_a_sqr, &
   four_a_sqr, myerr, a_pi, two_a_pi, x, y, erfcsy, &
   xsign, ysign, x_sqr, y_sqr, two_yx, two_a_x, exp_x_sqr, &
   cos_2yx, sin_2yx, v_old, l_old, sigma1, sigma2, sigma3, &
   sigma4, sigma5, sigma4_5, delta3, delta5, exp1, exp2, exp3, &
   del2_tmp, del3_tmp, del3_3_tmp, den1, exp_del1, &
   exp3_den, exp3_3_den, del5, del3, two_exp_x_sqr_ysqr, aux13
 integer :: n, n3, n3_3

 x = real( z )
 y = aimag( z )

! For purely imaginary z, use intrinsic scaled complement of
! the error function, erfc_scaled (F2008 and beyond).
! Return immediately.
 if ( abs( x ) .eq. zero ) then
   wzag = erfc_scaled( y )
   return
 end if

      myerr = max( err, eps0 )
          a = sqrt( - pi2 / log( err / 2.0_rkind ) )
     half_a = half * a
      a_sqr = a**2
      two_a = 2 * a
  two_a_sqr = 2 * a_sqr
 four_a_sqr = 4 * a_sqr
       a_pi = a / pi
   two_a_pi = 2 * a_pi
     erfcsy = erfc_scaled( abs( y ) )
      xsign = sign( one, x )
      ysign = sign( one, y )
          x = abs( x )
          y = max( rmin, abs( y ) )
      x_sqr = x**2
      y_sqr = y**2
     two_yx = 2 * y * x
    two_a_x = two_a * x
  exp_x_sqr = exp( -x_sqr )
    cos_2yx = cos( two_yx )
    sin_2yx = sin( two_yx )
      v_old = exp_x_sqr * &
              ( erfcsy * cos_2yx + two_a_pi * sin( two_yx / 2)**2 / y )
      l_old = - erfcsy + a_pi / y
     sigma3 = rmin
     sigma5 = rmin
   sigma4_5 = zero
     delta3 = one
     delta5 = one
          n = 0
         n3 = ceiling( x / a )
       n3_3 = n3 - 1

outer: if ( (sqrt_log_rmin - x) .gt. 0 ) then
       sigma1 = rmin
       sigma2 = rmin
       sigma4 = rmin
         exp1 = exp( - two_a_x )
         exp2 = exp( four_a_sqr * n3 - 2 * two_a_x - two_a_sqr )
         exp3 = exp( - ( two_a_sqr * n3 - two_a_x - two_a_sqr ) )
     del2_tmp = one
     del3_tmp = exp( - ( a_sqr * n3**2 - two_a_x * n3                  &
                         - two_a_sqr * n3 + x_sqr + two_a_x + a_sqr ) )
   del3_3_tmp = exp( a_sqr - ( two_a_sqr * n3 - two_a_x ) )

   loop1: do
     if ( delta3 .lt. myerr .and. delta5 .lt. myerr .and.              &
                                        n .gt. 50 ) exit loop1
            n = n + 1
         den1 = a_sqr * n**2 + y_sqr
     exp_del1 = exp( -( a_sqr * n**2) ) / den1
     del2_tmp = del2_tmp * exp1

     minor: if ( n3_3 .ge. 1 ) then
         del3_tmp = del3_tmp * exp3
         exp3_den = del3_tmp * exp_del1 *                              &
                       ( den1 / ( a_sqr * n3**2 + y_sqr) )
       del3_3_tmp = del3_3_tmp * exp2
       exp3_3_den = exp3_den * del3_3_tmp *                            &
                     ( (a_sqr * n3**2 + y_sqr ) /                      &
                       (a_sqr * n3_3**2 + y_sqr ) )
             del5 = n3_3 * exp3_3_den + n3 * exp3_den
             del3 = exp3_3_den + exp3_den
     else
         del3_tmp = del3_tmp * exp3
             del3 = del3_tmp * exp_del1 *                              &
                           ( den1 / ( a_sqr * n3**2 + y_sqr ) )
             del5 = n3 * del3
     end if minor

     delta3 = del3 / sigma3
     delta5 = del5 / sigma5
     sigma1 = sigma1 + exp_del1
     sigma2 = sigma2 + del2_tmp * exp_x_sqr * exp_del1
     sigma3 = sigma3 + del3
     sigma4 = sigma4 + n * del2_tmp * exp_x_sqr * exp_del1
     sigma5 = sigma5 + del5

     if ( x .ge. 5.0e-4_rkind ) then
       sigma4_5 = - sigma4 + sigma5
     else
       sigma4_5 = sigma4_5 + 2 * n**2 * two_a_x * exp_x_sqr            &
                   * exp_del1 * ( one + 1.666666666666667e-1_rkind     &
                   * ( two_a_x * n )**2 + 8.333333333333333e-3_rkind   &
                   * ( two_a_x * n )**4 )
     end if

       n3 = n3 + 1
     n3_3 = n3_3 - 1

   end do loop1

   ! Second line of Eqn (13)
   aux13 = y * two_a_pi *                                              &
     ( - cos_2yx*exp_x_sqr*sigma1 + half*(sigma2 + sigma3) )
   mumu: if ( y .le. 5.0_rkind .and. two_yx .gt. rmin ) then
     wzag = v_old + aux13 + cmplxj * xsign             &
           * ( sin_2yx * exp_x_sqr * ( l_old + two_a_pi * y * sigma1 ) &
           + two_a_pi * half_a * sigma4_5 )
   else if ( y .le. 5.0_rkind .and. two_yx .le. rmin ) then
     wzag = v_old + aux13 + cmplxj * xsign             &
           * ( two * y * exp_x_sqr * ( x * l_old + x * two_a_pi * y    &
           * sigma1 ) + two_a_pi * half_a * sigma4_5 )
   else
     wzag = v_old + aux13 + cmplxj * xsign             &
           * ( sin_2yx * exp_x_sqr * min( zero, abs( l_old             &
           + ( two_a_pi * y * sigma1) ) ) + two_a_pi *half_a           &
           * sigma4_5 )
   end if mumu

 else if ( x .ge. sqrt_log_rmin .and. x .lt. 1.0e15_rkind ) then

         exp2 = exp( four_a_sqr * n3 - 2 * two_a_x - two_a_sqr )
   del3_3_tmp = exp( a_sqr + two_a_x - two_a_sqr * n3 )

   loop2: do
     if ( delta3 .lt. myerr .and. delta5 .lt. myerr .and.              &
                                        n .gt. 50 ) exit loop2
     n = n + 1
     if ( n3_3 .ge. 1 ) then
         exp3_den = exp( - ( a * n3 - x ) * ( a * n3 - x ) )           &
                     / ( a_sqr * n3**2 + y_sqr )
       del3_3_tmp = del3_3_tmp * exp2
       exp3_3_den = exp3_den * del3_3_tmp * ( ( a_sqr * n3**2 + y_sqr) &
                     / ( a_sqr * n3_3**2 + y_sqr ) )
             del5 = n3_3 * exp3_3_den + n3 * exp3_den
             del3 = exp3_3_den + exp3_den
     else
             del3 = exp( - (a * n3 - x)**2) / ( a_sqr * n3**2 + y_sqr )
             del5 = n3 * del3
     end if

     delta3 = del3 / sigma3
     delta5 = del5 / sigma5
     sigma3 = sigma3 + del3
     sigma5 = sigma5 + del5
         n3 = n3 + 1
       n3_3 = n3_3 - 1

   end do loop2

   wzag = v_old + y * a_pi * sigma3 + cmplxj * xsign * ( sin_2yx        &
         * exp_x_sqr * l_old + two_a_pi * half_a * sigma5 )

 else
   wzag = one_sqrt_pi * ( ( y + cmplxj * xsign * x ) / ( x_sqr + y_sqr ))
 end if outer

 if ( ysign .lt. zero ) then
   two_exp_x_sqr_ysqr = two * exp( - x_sqr + y_sqr )
   wzag = two_exp_x_sqr_ysqr * cos_2yx - real( wzag ) - cmplxj           &
         * ( - xsign * two_exp_x_sqr_ysqr * sin_2yx - aimag( wzag ) )
 end if

end function wzag

!*********************************************************************72
elemental complex( kind=rkind ) function erf_zag( z, err )

! This is an error function of a complex argument, which uses wzag(z).

 complex( kind=rkind ), intent(in) :: z
 real( kind=rkind ), intent(in) :: err

 erf_zag = one - wzag( cmplxj * z, err ) * exp( - z**2 )

end function erf_zag

!*********************************************************************72
elemental complex( kind=rkind ) function wpop( z )

! A modified version of algorithm 680, rewritten in Fortran 2008.
! G.P.M. Poppe, C.M.J. Wijers, More efficient computation of
! the complex error-function, ACM Trans. Math. Software 16:38-46, 1990.
!  and
! G.P.M. Poppe, C.M.J. Wijers, Algorithm 680, Evaluation of the
! complex error function, ACM Trans. Math. Software 16:47, 1990.
!
! Given a complex number z, this function computes
! the value of the Faddeeva-function w(z) = exp(-z**2)*erfc(-i*z),
! where erfc is the complex complementary error-function and i
! means sqrt(-1).  The accuracy of the algorithm for z in the 1st
! and 2nd quadrant is 14 significant digits; in the 3rd and 4th
! it is 13 significant digits outside a circular region with radius
! 0.126 around a zero of the function.

 complex( kind=rkind ), intent(in) :: z

!  factor is 2/sqrt(pi)
 real( kind=rkind ), parameter ::                                      &
   factor = 1.12837916709551257388_rkind

 logical :: a, b

 real( kind=rkind ) :: xabs, yabs, x, y, qrho, xabsq, yquad, c, daux,  &
   h, h2, qlambda, rx, ry, sx, sy, tx, ty, u1, u2, v1, v2, w1, xaux,   &
   xquad, xsum, ysum, xi, yi, u, v

 integer :: i, j, kapn, n, np1, nu

! To avoid the complier uninitialised varning
         h2 = zero

         xi = real( z )
         yi = aimag( z )
       xabs = abs( xi )
       yabs = abs( yi )
          x = xabs / 6.3_rkind
          y = yabs / 4.4_rkind
       qrho = x**2 + y**2
      xabsq = xabs**2
      xquad = xabsq - yabs**2
      yquad = 2*xabs*yabs

          a = qrho .lt. 0.085264_rkind

  branch1: if ( a ) then

    ! If ( qrho .lt. 0.085264 ) then the Faddeeva-function is evaluated
    !  using a power-series (abramowitz/stegun, equation (7.1.5), p.297)
    !  n is the minimum number of terms needed to obtain the required
    !  accuracy

        qrho  = ( one - 0.85_rkind * y ) * sqrt( qrho )
            n = nint( 6.0_rkind + 72.0_rkind * qrho )
            j = 2 * n + 1
         xsum = one / real( j, kind=rkind )
         ysum = zero

        do i = n, 1, -1
          j = j - 2
          xaux = ( xsum * xquad - ysum * yquad) / real( i, kind=rkind )
          ysum = ( xsum * yquad + ysum * xquad) / real( i, kind=rkind )
          xsum = xaux + one / real( j, kind=rkind )
        end do

          u1 = - factor * ( xsum * yabs + ysum * xabs ) + one
          v1 = factor * ( xsum * xabs - ysum * yabs )
        daux = exp( -xquad )
          u2 = daux * cos( yquad )
          v2 = -daux * sin( yquad )
           u = u1 * u2 - v1 * v2
           v = u1 * v2 + v1 * u2
  else

    bran2: if ( qrho .gt. one ) then

      ! If ( qrho .gt. 1) then w(z) is evaluated using the laplace
      ! continued fraction. nu is the minimum number of terms needed
      ! to obtain the required accuracy.

           h = zero
        kapn = 0
        qrho = sqrt( qrho )
          nu = int( 3.0_rkind + (1442.0_rkind / ( 26.0_rkind * qrho &
                + 77.0_rkind )))

    else

      ! If ( qrho .ge. 0.085264 .and. qrho .le. one ) then
      ! w(z) is evaluated by a truncated Taylor expansion,
      ! where the Laplace continued fraction is used to calculate
      ! the derivatives of w(z). KAPN is the minimum number of terms
      ! in the Taylor expansion needed to obtain the required accuracy.
      ! NU is the minimum number of terms of the continued fraction
      ! needed to calculate the derivatives with the required accuracy.

          qrho = ( one - y ) * sqrt( one - qrho )
             h = 1.88_rkind * qrho
            h2 = two * h
          kapn = nint( 7.0_rkind + 34.0_rkind * qrho )
          nu   = nint( 16.0_rkind + 26.0_rkind * qrho )

    end if bran2

    b = h .gt. zero

! To avoid uninitialise compiler warning. qlambda is used
! only if (b), so can define to any value otherwise.
    qlambda = zero
    if ( b ) qlambda = h2**kapn

    rx = zero
    ry = zero
    sx = zero
    sy = zero

    do n = nu, 0, -1
         np1 = n + 1
          tx = yabs + h + np1 * rx
          ty = xabs - np1 * ry
           c = half / (tx**2 + ty**2)
          rx = c * tx
          ry = c * ty
          if ( b .and. n .le. kapn ) then
            tx = qlambda + sx
            sx = rx*tx - ry*sy
            sy = ry*tx + rx*sy
            qlambda = qlambda / h2
          end if
    end do

        if ( h .eq. zero ) then
          u = factor * rx
          v = factor * ry
        else
          u = factor * sx
          v = factor * sy
        end if

        if ( yabs .eq. zero ) u = exp( -xabs**2 )

  end if branch1

! Evaluation of w(z) in the other quadrants

      if ( yi .lt. zero ) then

        if ( a ) then
          u2 = two * u2
          v2 = two * v2
        else
          xquad = -xquad
          w1 = two * exp( xquad )
          u2 = w1 * cos( yquad )
          v2 = -w1 * sin( yquad )
        end if

        u = u2 - u
        v = v2 - v
        if ( xi .gt. zero ) v = -v
      else
        if ( xi .lt. zero ) v = -v
      end if

 wpop = cmplx( u, v, kind=rkind )

end function wpop

!*********************************************************************72
elemental complex( kind=rkind ) function erf_pop( z )

! This is an error function of a complex argument, which uses wpop(z).

 complex( kind=rkind ), intent(in) :: z

 erf_pop = one - wpop( cmplxj * z ) * exp( - z**2 )

end function erf_pop

!*********************************************************************72
end module errfun


      module MOD_LTEPOP

      contains

      SUBROUTINE LTEPOP(N,ENLTE,TL,ENE,WEIGHT,NCHARG,EION,ELEVEL,NOM,ABXYZ,NFIRST,NLAST,NATOM)
C     ******************************************************************
C     POPULATION NUMBERS IN THERMODYNAMIC EQUILIBRIUM FOR ALL ELEMENTS
C     CALLED BY GREYM,POPZERO
C     ******************************************************************

      use mod_error

      IMPLICIT REAL*8(A - H, O - Z)

      DIMENSION ENLTE(N), WEIGHT(N), NCHARG(N), EION(N), ELEVEL(N), NOM(N)
      DIMENSION NFIRST(NATOM), NLAST(NATOM)

      real*8, allocatable :: ABXYZ(:)

C***  C1 = H * C / K    ( CM * KELVIN )
      DATA C1/1.4388d0/
C***  C2 = FACTOR IN SAHA EQ.   ( C.F. MIHALAS P.113 )
      DATA C2/2.07d-16/
      T32=TL*SQRT(TL)
C***  LOOP FOR EACH ELEMENT  -------------------------------------------

      DO 9 NA=1,NATOM
      NFIRNA=NFIRST(NA)
      NLANA=NLAST(NA)
      ENLTE(NFIRNA)=1.
      DO 1 J=NFIRNA+1,NLANA
C***  BOLTZMANN FACTOR
      ENLTE(J)=EXP(C1*(ELEVEL(J-1)-ELEVEL(J))/TL)*WEIGHT(J)/WEIGHT(J-1)
     $      * ENLTE(J-1)

!      print*, tl, na, j, enlte(j)
	IF(NOM(J) .NE. NOM(NFIRNA)) STOP 'LTEPOP:WRONG ELEMENT MEMBERSHIP'
      IF (NCHARG(J) .EQ. NCHARG(J-1) ) GOTO 1
      IF (NCHARG(J) .NE. NCHARG(J-1)+1 )
     $            STOP "LTEPOP: INVALID CHARGE DIFFERENCE"
C***  SAHA FACTOR
      ENLTE(J)=ENLTE(J)*EXP(-C1*EION(J-1)/TL)*T32/ENE/C2
    1 CONTINUE

C***  NORMALIZATION
      SUM=.0
      DO 2 J=NFIRNA,NLANA
    2 SUM=SUM+ENLTE(J)
      SUM=SUM/ABXYZ(NA)

      DO 3 J=NFIRNA,NLANA
    3 ENLTE(J)=ENLTE(J)/SUM
    9 CONTINUE

C***  ENDLOOP  ---------------------------------------------------------

      RETURN
      END subroutine

      SUBROUTINE LTEPOP_NEW (N,ENLTE,TL,ENE,WEIGHT,NCHARG,EION,ELEVEL,NOM,
     $                  ABXYZ,NFIRST,NLAST,NATOM)
C***********************************************************************
C***  POPULATION NUMBERS IN THERMODYNAMIC EQUILIBRIUM FOR ALL ELEMENTS
C***  CALLED BY GREYM,POPZERO
C***********************************************************************
      use mod_error
      use MOD_PARTF2
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 prt1, prt2, prt3
      DIMENSION ENLTE(N), WEIGHT(N),NCHARG(N),EION(N),ELEVEL(N),NOM(N)
      DIMENSION ABXYZ(NATOM),NFIRST(NATOM),NLAST(NATOM)
C***  C1 = H * C / K    ( CM * KELVIN )
      DATA C1/1.4388d0/
C***  C2 = FACTOR IN SAHA EQ.   ( C.F. MIHALAS P.113 )
      DATA C2/2.07d-16/
      T32=TL*SQRT(TL)
C***  LOOP FOR EACH ELEMENT  -------------------------------------------
      DO 9 NA=1,NATOM
      NFIRNA=NFIRST(NA)
      NLANA=NLAST(NA)
      ENLTE(NFIRNA)=1.
      DO 1 J=NFIRNA+1,NLANA
C***  BOLTZMANN FACTOR
      ENLTE(J)=EXP(C1*(ELEVEL(J-1)-ELEVEL(J))/TL)*WEIGHT(J)/WEIGHT(J-1)
     $      * ENLTE(J-1)
	IF(NOM(J) .NE. NOM(NFIRNA)) STOP 'LTEPOP:WRONG ELEMENT MEMBERSHIP'
      IF (NCHARG(J) .EQ. NCHARG(J-1) ) GOTO 1
      IF (NCHARG(J) .NE. NCHARG(J-1)+1 )
     $            STOP "LTEPOP: INVALID CHARGE DIFFERENCE"
C***  SAHA FACTOR
      ENLTE(J)=ENLTE(J)*EXP(-C1*EION(J-1)/TL)*T32/ENE/C2
    1 CONTINUE

C***  NORMALIZATION
      SUM=.0
      DO 2 J=NFIRNA,NLANA
    2 SUM=SUM+ENLTE(J)
      SUM=SUM/ABXYZ(NA)

      DO 3 J=NFIRNA,NLANA
    3 ENLTE(J)=ENLTE(J)/SUM

      SUMPC=0.
      DO J=NFIRNA,NLANA
      SUMPC=SUMPC+WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ENDDO

      I=NOM(NFIRNA)

      CALL PARTF2(I,1,TL,PRT1)
      CALL PARTF2(I,2,TL,PRT2)
      CALL PARTF2(I,3,TL,PRT3)

      SUMPTH=PRT1+PRT2+PRT3
 !    print *, 'TEST'
 !    print *, J, PRT1, PRT2, PRT3

      corr=SUMPC/SUMPTH

      DO J=NFIRNA,NLANA
      ENLTE(J)=ENLTE(J)*corr
      ENDDO

    9 CONTINUE

C***  ENDLOOP  ---------------------------------------------------------

      RETURN
      END subroutine

      SUBROUTINE LTEPOP_NEW1 (N,ENLTE,TL,ENE,WEIGHT,NCHARG,EION,ELEVEL,NOM,
     $                  ABXYZ,NFIRST,NLAST,NATOM)
C***********************************************************************
C***  POPULATION NUMBERS IN THERMODYNAMIC EQUILIBRIUM FOR ALL ELEMENTS
C***  CALLED BY GREYM,POPZERO
C***********************************************************************
      use mod_error
      use MOD_PARTF2
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 prt1, prt2, prt3
      DIMENSION Eip(3,30)
      DIMENSION ENLTE(N), WEIGHT(N),NCHARG(N),EION(N),ELEVEL(N),NOM(N)
      DIMENSION ABXYZ(NATOM),NFIRST(NATOM),NLAST(NATOM)
C***  C1 = H * C / K    ( CM * KELVIN )
      DATA C1/1.4388d0/
C***  C2 = FACTOR IN SAHA EQ.   ( C.F. MIHALAS P.113 )
      DATA C2/2.07d-16/
      DATA evtocm/8055.2/
      DATA Eip/'  H ',  0.756095, 13.6157,
     * '  HE',24.6190, 54.4876,
     * '  LI', 5.39864, 75.619,
     * '  BE', 9.33467, 18.206,
     * '  B ', 8.30868, 25.149,
     * '  C ',11.2748, 24.376,
     * '  N ',14.5638, 29.593,
     * '  O ',13.6355, 35.108,
     * '  F ',17.4452, 34.980,
     * '  NE',21.5922, 41.070,
     * '  NA', 5.1457, 47.290,
     * '  MG', 7.65605, 15.030,
     * ' AL ', 5.99342, 18.823,
     * ' SI ', 8.16215, 16.350,
     * ' P  ',10.5002, 19.720,
     * ' S  ',10.3733, 23.400,
     * ' CL ',12.9843, 23.800,
     * ' AR ',15.7798, 27.620,
     * ' K  ', 4.34624, 31.810,
     * ' CA ', 6.12101, 11.8870,
     * ' SC ', 6.56992, 12.800,
     * ' TI ', 6.82913, 13.630,
     * ' V  ', 6.74844, 14.200,
     * ' CR ', 6.77520, 16.490,
     * ' MN ', 7.44356, 15.640,
     * ' FE ', 7.91253, 16.183,
     * ' CO ', 7.87442, 17.060,
     * ' NI ', 7.64723, 18.168,
     * ' CU ', 7.7363, 20.292,
     * ' ZN ', 9.40626, 17.964/

      T32=TL*SQRT(TL)
C***  LOOP FOR EACH ELEMENT  -------------------------------------------
      DO 9 NA=1,NATOM

      if (NA .eq. 1) then
      CALL PARTF2(NA,1,TL,PRT2)
      CALL PARTF2(NA,2,TL,PRT3)
      CALL PARTF2(NA,3,TL,PRT1)
      goto 10
      endif

      CALL PARTF2(NA,1,TL,PRT1)
      CALL PARTF2(NA,2,TL,PRT2)
      CALL PARTF2(NA,3,TL,PRT3)

 10   F1=EXP(-C1*evtocm*Eip(2,NA)/TL)*T32/(C2*ENE)
      F2=EXP(-C1*evtocm*Eip(3,NA)/TL)*T32/(C2*ENE)

      denom=PRT1+PRT2*F1+PRT3*F1*F2
      coeff1=1./denom
      coeff2=coeff1*F1
      coeff3=coeff2*F2

      NFIRNA=NFIRST(NA)
      NLANA=NLAST(NA)

      if (NA .eq. 1) then

      DO 1 J=NFIRNA, NLANA

      IF (NCHARG(J) .EQ. -1) THEN
      ENLTE(J)=coeff1*WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ELSEIF (NCHARG(J) .EQ. 0) THEN
      ENLTE(J)=coeff2*WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ELSEIF (NCHARG(J) .EQ. 1) THEN
      ENLTE(J)=coeff3*WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ENDIF
      ENLTE(J)=ENLTE(J)*ABXYZ(NA)

   1  CONTINUE

      else

      DO 2 J=NFIRNA, NLANA
C***  BOLTZMANN FACTOR
      IF (NCHARG(J) .EQ. 0) THEN
      ENLTE(J)=coeff1*WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ELSEIF (NCHARG(J) .EQ. 1) THEN
      ENLTE(J)=coeff2*WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ELSEIF (NCHARG(J) .EQ. 2) THEN
      ENLTE(J)=coeff3*WEIGHT(J)*EXP(-C1*ELEVEL(J)/TL)
      ENDIF
      ENLTE(J)=ENLTE(J)*ABXYZ(NA)

 2    CONTINUE

      endif

    9 CONTINUE

C***  ENDLOOP  ---------------------------------------------------------

      RETURN
      END subroutine

      end module


MODULE fields

  USE boundary

  IMPLICIT NONE

  INTEGER :: field_order
  REAL(num) :: hdt, fac
  REAL(num) :: hdtx, hdty, hdtz
  REAL(num) :: cnx, cny, cnz
  LOGICAL :: fixed_fields

CONTAINS

  SUBROUTINE set_field_order(order)

    INTEGER, INTENT(IN) :: order

    field_order = order
    fng = field_order / 2

    IF (field_order == 2) THEN
      cfl = 1.0_num
    ELSE IF (field_order == 4) THEN
      cfl = 6.0_num / 7.0_num
    ELSE
      cfl = 120.0_num / 149.0_num
    ENDIF

  END SUBROUTINE set_field_order

  SUBROUTINE update_e_field

    INTEGER :: ix, iy, iz
    REAL(num) :: c1, c2, c3
    REAL(num) :: cx1, cx2, cx3
    REAL(num) :: cy1, cy2, cy3
    REAL(num) :: cz1, cz2, cz3

    IF (field_order == 2) THEN
      DO iz = 1, nz
        DO iy = 1, ny
          DO ix = 1, nx

            ex(ix, iy, iz) = ex(ix, iy, iz) &
                + cny * (bz(ix  , iy  , iz  ) - bz(ix  , iy-1, iz  )) &
                - cnz * (by(ix  , iy  , iz  ) - by(ix  , iy  , iz-1)) &
                - fac * jx(ix, iy, iz)

            ey(ix, iy, iz) = ey(ix, iy, iz) &
                + cnz * (bx(ix  , iy  , iz  ) - bx(ix  , iy  , iz-1)) &
                - cnx * (bz(ix  , iy  , iz  ) - bz(ix-1, iy  , iz  )) &
                - fac * jy(ix, iy, iz)

            ez(ix, iy, iz) = ez(ix, iy, iz) &
                + cnx * (by(ix  , iy  , iz  ) - by(ix-1, iy  , iz  )) &
                - cny * (bx(ix  , iy  , iz  ) - bx(ix  , iy-1, iz  )) &
                - fac * jz(ix, iy, iz)
          ENDDO
        ENDDO
      ENDDO
    ELSE IF (field_order == 4) THEN
      c1 = 9.0_num / 8.0_num
      c2 = -1.0_num / 24.0_num

      DO iz = 1, nz
        cz1 = c1 * cnz
        cz2 = c2 * cnz
        DO iy = 1, ny
          cy1 = c1 * cny
          cy2 = c2 * cny
          DO ix = 1, nx
            cx1 = c1 * cnx
            cx2 = c2 * cnx

            ex(ix, iy, iz) = ex(ix, iy, iz) &
                + cy1 * (bz(ix  , iy  , iz  ) - bz(ix  , iy-1, iz  )) &
                + cy2 * (bz(ix  , iy+1, iz  ) - bz(ix  , iy-2, iz  )) &
                - cz1 * (by(ix  , iy  , iz  ) - by(ix  , iy  , iz-1)) &
                - cz2 * (by(ix  , iy  , iz+1) - by(ix  , iy  , iz-2)) &
                - fac * jx(ix, iy, iz)

            ey(ix, iy, iz) = ey(ix, iy, iz) &
                + cz1 * (bx(ix  , iy  , iz  ) - bx(ix  , iy  , iz-1)) &
                + cz2 * (bx(ix  , iy  , iz+1) - bx(ix  , iy  , iz-2)) &
                - cx1 * (bz(ix  , iy  , iz  ) - bz(ix-1, iy  , iz  )) &
                - cx2 * (bz(ix+1, iy  , iz  ) - bz(ix-2, iy  , iz  )) &
                - fac * jy(ix, iy, iz)

            ez(ix, iy, iz) = ez(ix, iy, iz) &
                + cx1 * (by(ix  , iy  , iz  ) - by(ix-1, iy  , iz  )) &
                + cx2 * (by(ix+1, iy  , iz  ) - by(ix-2, iy  , iz  )) &
                - cy1 * (bx(ix  , iy  , iz  ) - bx(ix  , iy-1, iz  )) &
                - cy2 * (bx(ix  , iy+1, iz  ) - bx(ix  , iy-2, iz  )) &
                - fac * jz(ix, iy, iz)
          ENDDO
        ENDDO
      ENDDO
    ELSE
      c1 = 75.0_num / 64.0_num
      c2 = -25.0_num / 384.0_num
      c3 = 3.0_num / 640.0_num

      DO iz = 1, nz
        cz1 = c1 * cnz
        cz2 = c2 * cnz
        cz3 = c3 * cnz
        DO iy = 1, ny
          cy1 = c1 * cny
          cy2 = c2 * cny
          cy3 = c3 * cny
          DO ix = 1, nx
            cx1 = c1 * cnx
            cx2 = c2 * cnx
            cx3 = c3 * cnx

            ex(ix, iy, iz) = ex(ix, iy, iz) &
                + cy1 * (bz(ix  , iy  , iz  ) - bz(ix  , iy-1, iz  )) &
                + cy2 * (bz(ix  , iy+1, iz  ) - bz(ix  , iy-2, iz  )) &
                + cy3 * (bz(ix  , iy+2, iz  ) - bz(ix  , iy-3, iz  )) &
                - cz1 * (by(ix  , iy  , iz  ) - by(ix  , iy  , iz-1)) &
                - cz2 * (by(ix  , iy  , iz+1) - by(ix  , iy  , iz-2)) &
                - cz3 * (by(ix  , iy  , iz+2) - by(ix  , iy  , iz-3)) &
                - fac * jx(ix, iy, iz)

            ey(ix, iy, iz) = ey(ix, iy, iz) &
                + cz1 * (bx(ix  , iy  , iz  ) - bx(ix  , iy  , iz-1)) &
                + cz2 * (bx(ix  , iy  , iz+1) - bx(ix  , iy  , iz-2)) &
                + cz3 * (bx(ix  , iy  , iz+2) - bx(ix  , iy  , iz-3)) &
                - cx1 * (bz(ix  , iy  , iz  ) - bz(ix-1, iy  , iz  )) &
                - cx2 * (bz(ix+1, iy  , iz  ) - bz(ix-2, iy  , iz  )) &
                - cx3 * (bz(ix+2, iy  , iz  ) - bz(ix-3, iy  , iz  )) &
                - fac * jy(ix, iy, iz)

            ez(ix, iy, iz) = ez(ix, iy, iz) &
                + cx1 * (by(ix  , iy  , iz  ) - by(ix-1, iy  , iz  )) &
                + cx2 * (by(ix+1, iy  , iz  ) - by(ix-2, iy  , iz  )) &
                + cx3 * (by(ix+2, iy  , iz  ) - by(ix-3, iy  , iz  )) &
                - cy1 * (bx(ix  , iy  , iz  ) - bx(ix  , iy-1, iz  )) &
                - cy2 * (bx(ix  , iy+1, iz  ) - bx(ix  , iy-2, iz  )) &
                - cy3 * (bx(ix  , iy+2, iz  ) - bx(ix  , iy-3, iz  )) &
                - fac * jz(ix, iy, iz)
          ENDDO
        ENDDO
      ENDDO
    ENDIF

  END SUBROUTINE update_e_field

  SUBROUTINE update_b_field

    INTEGER :: ix, iy, iz
    REAL(num) :: c1, c2, c3
    REAL(num) :: cx1, cx2, cx3
    REAL(num) :: cy1, cy2, cy3
    REAL(num) :: cz1, cz2, cz3

    IF (field_order == 2) THEN
      DO iz = 1, nz
        DO iy = 1, ny
          DO ix = 1, nx
            bx(ix, iy, iz) = bx(ix, iy, iz) &
                - hdty * (ez(ix  , iy+1, iz  ) - ez(ix  , iy  , iz  )) &
                + hdtz * (ey(ix  , iy  , iz+1) - ey(ix  , iy  , iz  ))

            by(ix, iy, iz) = by(ix, iy, iz) &
                - hdtz * (ex(ix  , iy  , iz+1) - ex(ix  , iy  , iz  )) &
                + hdtx * (ez(ix+1, iy  , iz  ) - ez(ix  , iy  , iz  ))

            bz(ix, iy, iz) = bz(ix, iy, iz) &
                - hdtx * (ey(ix+1, iy  , iz  ) - ey(ix  , iy  , iz  )) &
                + hdty * (ex(ix  , iy+1, iz  ) - ex(ix  , iy  , iz  ))
          ENDDO
        ENDDO
      ENDDO
    ELSE IF (field_order == 4) THEN
      c1 = 9.0_num / 8.0_num
      c2 = -1.0_num / 24.0_num

      DO iz = 1, nz
        cz1 = c1 * hdtz
        cz2 = c2 * hdtz
        DO iy = 1, ny
          cy1 = c1 * hdty
          cy2 = c2 * hdty
          DO ix = 1, nx
            cx1 = c1 * hdtx
            cx2 = c2 * hdtx

            bx(ix, iy, iz) = bx(ix, iy, iz) &
                - cy1 * (ez(ix  , iy+1, iz  ) - ez(ix  , iy  , iz  )) &
                - cy2 * (ez(ix  , iy+2, iz  ) - ez(ix  , iy-1, iz  )) &
                + cz1 * (ey(ix  , iy  , iz+1) - ey(ix  , iy  , iz  )) &
                + cz2 * (ey(ix  , iy  , iz+2) - ey(ix  , iy  , iz-1))

            by(ix, iy, iz) = by(ix, iy, iz) &
                - cz1 * (ex(ix  , iy  , iz+1) - ex(ix  , iy  , iz  )) &
                - cz2 * (ex(ix  , iy  , iz+2) - ex(ix  , iy  , iz-1)) &
                + cx1 * (ez(ix+1, iy  , iz  ) - ez(ix  , iy  , iz  )) &
                + cx2 * (ez(ix+2, iy  , iz  ) - ez(ix-1, iy  , iz  ))

            bz(ix, iy, iz) = bz(ix, iy, iz) &
                - cx1 * (ey(ix+1, iy  , iz  ) - ey(ix  , iy  , iz  )) &
                - cx2 * (ey(ix+2, iy  , iz  ) - ey(ix-1, iy  , iz  )) &
                + cy1 * (ex(ix  , iy+1, iz  ) - ex(ix  , iy  , iz  )) &
                + cy2 * (ex(ix  , iy+2, iz  ) - ex(ix  , iy-1, iz  ))
          ENDDO
        ENDDO
      ENDDO
    ELSE
      c1 = 75.0_num / 64.0_num
      c2 = -25.0_num / 384.0_num
      c3 = 3.0_num / 640.0_num

      DO iz = 1, nz
        cz1 = c1 * hdtz
        cz2 = c2 * hdtz
        cz3 = c3 * hdtz
        DO iy = 1, ny
          cy1 = c1 * hdty
          cy2 = c2 * hdty
          cy3 = c3 * hdty
          DO ix = 1, nx
            cx1 = c1 * hdtx
            cx2 = c2 * hdtx
            cx3 = c3 * hdtx

            bx(ix, iy, iz) = bx(ix, iy, iz) &
                - cy1 * (ez(ix  , iy+1, iz  ) - ez(ix  , iy  , iz  )) &
                - cy2 * (ez(ix  , iy+2, iz  ) - ez(ix  , iy-1, iz  )) &
                - cy3 * (ez(ix  , iy+3, iz  ) - ez(ix  , iy-2, iz  )) &
                + cz1 * (ey(ix  , iy  , iz+1) - ey(ix  , iy  , iz  )) &
                + cz2 * (ey(ix  , iy  , iz+2) - ey(ix  , iy  , iz-1)) &
                + cz3 * (ey(ix  , iy  , iz+3) - ey(ix  , iy  , iz-2))

            by(ix, iy, iz) = by(ix, iy, iz) &
                - cz1 * (ex(ix  , iy  , iz+1) - ex(ix  , iy  , iz  )) &
                - cz2 * (ex(ix  , iy  , iz+2) - ex(ix  , iy  , iz-1)) &
                - cz3 * (ex(ix  , iy  , iz+3) - ex(ix  , iy  , iz-2)) &
                + cx1 * (ez(ix+1, iy  , iz  ) - ez(ix  , iy  , iz  )) &
                + cx2 * (ez(ix+2, iy  , iz  ) - ez(ix-1, iy  , iz  )) &
                + cx3 * (ez(ix+3, iy  , iz  ) - ez(ix-2, iy  , iz  ))

            bz(ix, iy, iz) = bz(ix, iy, iz) &
                - cx1 * (ey(ix+1, iy  , iz  ) - ey(ix  , iy  , iz  )) &
                - cx2 * (ey(ix+2, iy  , iz  ) - ey(ix-1, iy  , iz  )) &
                - cx3 * (ey(ix+3, iy  , iz  ) - ey(ix-2, iy  , iz  )) &
                + cy1 * (ex(ix  , iy+1, iz  ) - ex(ix  , iy  , iz  )) &
                + cy2 * (ex(ix  , iy+2, iz  ) - ex(ix  , iy-1, iz  )) &
                + cy3 * (ex(ix  , iy+3, iz  ) - ex(ix  , iy-2, iz  ))
          ENDDO
        ENDDO
      ENDDO
    ENDIF

  END SUBROUTINE update_b_field

  SUBROUTINE update_eb_fields_half
    IF(fixed_fields) RETURN

    hdt  = 0.5_num * dt
    hdtx = hdt / dx
    hdty = hdt / dy
    hdtz = hdt / dz

    cnx = hdtx * c**2
    cny = hdty * c**2
    cnz = hdtz * c**2

    fac = hdt / epsilon0

    ! Update E field to t+dt/2
    CALL update_e_field

    ! Now have E(t+dt/2), do boundary conditions on E
    CALL efield_bcs(ex, ey, ez, ng)

    ! Update B field to t+dt/2 using E(t+dt/2)
    CALL update_b_field

    ! Now have B field at t+dt/2. Do boundary conditions on B
    CALL bfield_bcs(ex, ey, ez, ng, .TRUE.)

    ! Now have E&B fields at t = t+dt/2
    ! Move to particle pusher

  END SUBROUTINE update_eb_fields_half

  SUBROUTINE rewind_fields_halfstep
    ex = ex_back
    ey = ey_back
    ez = ez_back
    bx = bx_back
    by = by_back
    bz = bz_back
  END SUBROUTINE rewind_fields_halfstep

  SUBROUTINE update_eb_fields_final
    IF(drift_kinetic_species_exist) THEN
       !Save EM fields to a temporary to allow us to rewind half a step
       ex_back = ex
       ey_back = ey
       ez_back = ez
       bx_back = bx
       by_back = by
       bz_back = bz
       jx = jx + jx_d
       jy = jy + jy_d
       jz = jz + jz_d
    END IF
    IF(fixed_fields) RETURN

    hdt  = 0.5_num * dt
    hdtx = hdt / dx
    hdty = hdt / dy
    hdtz = hdt / dz

    cnx = hdtx * c**2
    cny = hdty * c**2
    cnz = hdtz * c**2

    fac = hdt / epsilon0

    CALL update_b_field

    CALL bfield_final_bcs(bx, by, bz, ng)

    CALL update_e_field

    CALL efield_bcs(ex, ey, ez, ng)

  END SUBROUTINE update_eb_fields_final

END MODULE fields


*> \brief \b ZQRT14
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       DOUBLE PRECISION FUNCTION ZQRT14( TRANS, M, N, NRHS, A, LDA, X,
*                        LDX, WORK, LWORK )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            LDA, LDX, LWORK, M, N, NRHS
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         A( LDA, * ), WORK( LWORK ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZQRT14 checks whether X is in the row space of A or A'.  It does so
*> by scaling both X and A such that their norms are in the range
*> [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X]
*> (if TRANS = 'C') or an LQ factorization of [A',X]' (if TRANS = 'N'),
*> and returning the norm of the trailing triangle, scaled by
*> MAX(M,N,NRHS)*eps.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          = 'N':  No transpose, check for X in the row space of A
*>          = 'C':  Conjugate transpose, check for X in row space of A'.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of X.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          The M-by-N matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension (LDX,NRHS)
*>          If TRANS = 'N', the N-by-NRHS matrix X.
*>          IF TRANS = 'C', the M-by-NRHS matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          length of workspace array required
*>          If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
*>          if TRANS = 'C', LWORK >= (N+NRHS)*(M+2).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_lin
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION ZQRT14( TRANS, M, N, NRHS, A, LDA, X,
     $                 LDX, WORK, LWORK )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            LDA, LDX, LWORK, M, N, NRHS
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), WORK( LWORK ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            TPSD
      INTEGER            I, INFO, J, LDWORK
      DOUBLE PRECISION   ANRM, ERR, XNRM
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   RWORK( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           LSAME, DLAMCH, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGELQ2, ZGEQR2, ZLACPY, ZLASCL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      ZQRT14 = ZERO
      IF( LSAME( TRANS, 'N' ) ) THEN
         LDWORK = M + NRHS
         TPSD = .FALSE.
         IF( LWORK.LT.( M+NRHS )*( N+2 ) ) THEN
            CALL XERBLA( 'ZQRT14', 10 )
            RETURN
         ELSE IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
            RETURN
         END IF
      ELSE IF( LSAME( TRANS, 'C' ) ) THEN
         LDWORK = M
         TPSD = .TRUE.
         IF( LWORK.LT.( N+NRHS )*( M+2 ) ) THEN
            CALL XERBLA( 'ZQRT14', 10 )
            RETURN
         ELSE IF( M.LE.0 .OR. NRHS.LE.0 ) THEN
            RETURN
         END IF
      ELSE
         CALL XERBLA( 'ZQRT14', 1 )
         RETURN
      END IF
*
*     Copy and scale A
*
      CALL ZLACPY( 'All', M, N, A, LDA, WORK, LDWORK )
      ANRM = ZLANGE( 'M', M, N, WORK, LDWORK, RWORK )
      IF( ANRM.NE.ZERO )
     $   CALL ZLASCL( 'G', 0, 0, ANRM, ONE, M, N, WORK, LDWORK, INFO )
*
*     Copy X or X' into the right place and scale it
*
      IF( TPSD ) THEN
*
*        Copy X into columns n+1:n+nrhs of work
*
         CALL ZLACPY( 'All', M, NRHS, X, LDX, WORK( N*LDWORK+1 ),
     $                LDWORK )
         XNRM = ZLANGE( 'M', M, NRHS, WORK( N*LDWORK+1 ), LDWORK,
     $          RWORK )
         IF( XNRM.NE.ZERO )
     $      CALL ZLASCL( 'G', 0, 0, XNRM, ONE, M, NRHS,
     $                   WORK( N*LDWORK+1 ), LDWORK, INFO )
         ANRM = ZLANGE( 'One-norm', M, N+NRHS, WORK, LDWORK, RWORK )
*
*        Compute QR factorization of X
*
         CALL ZGEQR2( M, N+NRHS, WORK, LDWORK,
     $                WORK( LDWORK*( N+NRHS )+1 ),
     $                WORK( LDWORK*( N+NRHS )+MIN( M, N+NRHS )+1 ),
     $                INFO )
*
*        Compute largest entry in upper triangle of
*        work(n+1:m,n+1:n+nrhs)
*
         ERR = ZERO
         DO 20 J = N + 1, N + NRHS
            DO 10 I = N + 1, MIN( M, J )
               ERR = MAX( ERR, ABS( WORK( I+( J-1 )*M ) ) )
   10       CONTINUE
   20    CONTINUE
*
      ELSE
*
*        Copy X' into rows m+1:m+nrhs of work
*
         DO 40 I = 1, N
            DO 30 J = 1, NRHS
               WORK( M+J+( I-1 )*LDWORK ) = DCONJG( X( I, J ) )
   30       CONTINUE
   40    CONTINUE
*
         XNRM = ZLANGE( 'M', NRHS, N, WORK( M+1 ), LDWORK, RWORK )
         IF( XNRM.NE.ZERO )
     $      CALL ZLASCL( 'G', 0, 0, XNRM, ONE, NRHS, N, WORK( M+1 ),
     $                   LDWORK, INFO )
*
*        Compute LQ factorization of work
*
         CALL ZGELQ2( LDWORK, N, WORK, LDWORK, WORK( LDWORK*N+1 ),
     $                WORK( LDWORK*( N+1 )+1 ), INFO )
*
*        Compute largest entry in lower triangle in
*        work(m+1:m+nrhs,m+1:n)
*
         ERR = ZERO
         DO 60 J = M + 1, N
            DO 50 I = J, LDWORK
               ERR = MAX( ERR, ABS( WORK( I+( J-1 )*LDWORK ) ) )
   50       CONTINUE
   60    CONTINUE
*
      END IF
*
      ZQRT14 = ERR / ( DBLE( MAX( M, N, NRHS ) )*DLAMCH( 'Epsilon' ) )
*
      RETURN
*
*     End of ZQRT14
*
      END


PROGRAM test_quad
!     Three tests of the basic quadruple precision module.
!     1.       (A + B)^2          = (A - B)^2 + 4.A.B
!     2.  (A^2 - B^2) / (A - B)   = A + B
!     3.  SQRT(A^2 + 2.A.B + B^2) = A + B

USE quadruple_precision
IMPLICIT NONE

TYPE (quad)          :: a, b, lhs, rhs, diff
REAL (dp)            :: half = 0.5_dp, small = EPSILON(half)
INTEGER, ALLOCATABLE :: seed(:)
INTEGER              :: k, i

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k))
CALL RANDOM_SEED(get=seed)
WRITE(*, *)'Old random number seeds: ', seed

WRITE(*, '(1x, a, i4, a)') 'Enter ', k, ' integers as random number seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

DO i = 1, 10
  CALL RANDOM_NUMBER(a%hi)
  a%hi = (a%hi - half) / a%hi
  a%lo = a%hi * small
  CALL RANDOM_NUMBER(b%hi)
  b%hi = (b%hi - half) / b%hi
  b%lo = b%hi * small
                             ! (A + B)^2 = (A - B)^2 + 4.A.B
  lhs = (a + b) * (a + b)
  rhs = a * b
  rhs = 4._dp * rhs
  rhs = (a - b) * (a - b) + rhs
  diff = lhs - rhs
  WRITE(*, '(" lhs =", g13.5, "  Diff. =", g12.4)') lhs%hi, diff%hi
                             ! (A^2 - B^2) / (A - B) = (A + B)
  lhs = (a*a - b*b) / (a - b)
  rhs = a + b
  diff = lhs - rhs
  WRITE(*, '(" lhs =", g13.5, "  Diff. =", g12.4)') lhs%hi, diff%hi
                             ! SQRT(A^2 + 2.A.B + B^2) = A + B
  lhs = a * b
  lhs = 2._dp * lhs
  lhs = SQRT(a*a + lhs + b*b)
  IF (rhs%hi < 0._dp) THEN             ! Force +ve square root
    rhs = -rhs
  END IF
  diff = lhs - rhs
  WRITE(*, '(" lhs =", g13.5, "  Diff. =", g12.4)') lhs%hi, diff%hi

END DO

STOP
END PROGRAM test_quad


!==============================================================================
!!
!> @anchor  test_astro_conversions
!!
!> @brief   Program for testing transformation rv2coe abd coe2rv
!!
!> @author  Christopher Kebschull
!!
!> @date

!!
01.01.2021 (initial design)

!!

!!
!!
!> @copyright OKAPI:Orbits GmbH
!!
!------------------------------------------------------------------------

program test_astro

use slam_astro_conversions, only: coe2rv_long, rv2coe_long
use slam_io, only: slam_message
use slam_error_handling
use slam_types
use slam_orbit_types
use slam_math, only: eps15, eps9, eps6, eps3, pi, twopi, undefined

implicit none

logical 	             :: error = .false.
real(dp),dimension(3)  :: R_in, R, R_out
real(dp),dimension(3)  :: V_in, V, V_out

real(dp)   :: P_in, P, P_out
real(dp)   :: A_out
real(dp)   :: Ecc_in, Ecc, Ecc_out
real(dp)   :: Incl_in, Incl, Incl_out
real(dp)   :: Omega_in, Omega, Omega_out
real(dp)   :: Argp_in, Argp, Argp_out
real(dp)   :: Nu_in, Nu, Nu_out
real(dp)   :: M_out
real(dp)   :: ArgLat_in, ArgLat, ArgLat_out
real(dp)   :: TrueLon_in, TrueLon, TrueLon_out
real(dp)   :: LonPer_in, LonPer, LonPer_out

integer    :: otype_out

! Check circular orbit
P_in = 6877.952106508777d0
Ecc_in = 6.9632874704754230E-006
Incl_in = 1.134398510396487d0
Omega_in = 0.d0
Argp_in = 0.d0
Nu_in = 0.d0
ArgLat_in = 0.d0
TrueLon_in = 0.d0
LonPer_in = 0.d0
R = (/6.878d3,0.d0,0.d0/)
V = (/0.d0, 3.2177d0, 6.8992d0/)
call coe2rv_long(P_in,Ecc_in,Incl_in,Omega_in,Argp_in,Nu_in,ArgLat_in,TrueLon_in,LonPer_in,R_out,V_out)

if (any(dabs(R_out - R) .gt. 1d-1) .or. any(dabs(V_out - V) .gt. 1d-4)) then
  error = .true.
  call slam_message('ERROR: Could not convert Keplerian elements to state vector for the circular equatorial orbit!',1)
end if

write(*,*) ''

call rv2coe_long(R,V,P_out,A_out,Ecc_out,Incl_out,Omega_out,Argp_out,Nu_out,M_out,ArgLat_out,TrueLon_out,LonPer_out,otype_out)

if (dabs(P_out-P_in) .gt. eps15 &
  .or. dabs(Ecc_out - Ecc_in) .gt. eps9 &
  .or. dabs(Incl_out - Incl_in) .gt. eps15 &
  .or. ArgLat_out /= undefined &
  .or. TrueLon_out /= undefined &
  .or. LonPer_out /= undefined) then
  error = .true.
  call slam_message('ERROR: Could not convert state vector to Keplerian elements for the circular orbit!',1)
end if

! Check circular equatorial orbit
P_in = 6877.952106508777d0
Ecc_in = 6.9632874704754230E-006
Incl_in = 1.74532925d-4
Omega_in = 0.d0
Argp_in = 0.d0
Nu_in = 0.d0
ArgLat_in = 0.d0
TrueLon_in = 0.d0
LonPer_in = 0.d0
R = (/6.87795211d3,0.d0,0.d0/)
V = (/0.d0, 7.61271037d0, 1.32866862d-3/)
call coe2rv_long(P_in,Ecc_in,Incl_in,Omega_in,Argp_in,Nu_in,ArgLat_in,TrueLon_in,LonPer_in,R_out,V_out)

if (any(dabs(R_out - R) .gt. 1d-1) .or. any(dabs(V_out - V) .gt. 1d-4)) then
  error = .true.
  call slam_message('ERROR: Could not convert Keplerian elements to state vector for the circular equatorial orbit!',1)
end if

write(*,*) ''

call rv2coe_long(R,V,P_out,A_out,Ecc_out,Incl_out,Omega_out,Argp_out,Nu_out,M_out,ArgLat_out,TrueLon_out,LonPer_out,otype_out)

write (*,*) dabs(P_out-P_in), dabs(Ecc_out - Ecc_in), dabs(Incl_out - Incl_in)

if (dabs(P_out-P_in) .gt. 1d-5 &
  .or. dabs(Ecc_out - Ecc_in) .gt. 1d-5 &
  .or. dabs(Incl_out - Incl_in) .gt. 1d-12 &
  .or. LonPer_out /= undefined) then
  error = .true.
  call slam_message('ERROR: Could not convert state vector to Keplerian elements for the circular equatorial orbit!',1)
end if

!** Display conclusion
if (error) then
  CALL slam_message('Some tests failed.',1)
  error = .true.
else
  CALL slam_message('All tests passed.', 1)
end if
write(*,*) ''

end Program test_astro


PROGRAM sort
IMPLICIT NONE
  INTEGER, PARAMETER :: MAX_SIZE = 32
  INTEGER, DIMENSION(MAX_SIZE) :: numbers
  INTEGER :: arr_size, smallest, start, swap, status, index = 1
  CHARACTER(LEN = 85) :: msg

  OPEN(UNIT=1, FILE='numbers.txt', STATUS='OLD', ACTION='READ', IOSTAT=status, IOMSG=msg)

  ! Read data from file and load it into numbers array
  DO
    READ(1,*,IOSTAT=status) numbers(index)
    IF (status .ne. 0) THEN
      ! Get upper bound of array
      arr_size = index - 1
      EXIT
    END IF
    index = index + 1
  END DO

  CALL sort_algorithm(arr_size, numbers)

  ! Print out array
  WRITE(*, 100) (numbers(index), index = 1, arr_size)
  100 FORMAT (1I4)

  CLOSE(1)

END PROGRAM sort

SUBROUTINE sort_algorithm(size, nums)
IMPLICIT NONE
  INTEGER, INTENT(IN) :: size
  INTEGER, DIMENSION(size), INTENT(INOUT) :: nums
  INTEGER :: start, index, swap, smallest

  ! Find smallest and swap it with the value stored in start
  outer: DO start = 1, size
    smallest = start
    find_smallest: DO index = start, size
      IF (nums(index) < nums(smallest)) THEN
        smallest = index
      END IF
    END DO find_smallest
    IF (start .ne. smallest) THEN
      swap = nums(start)
      nums(start) = nums(smallest)
      nums(smallest) = swap
    END IF
  END DO outer

END SUBROUTINE sort_algorithm


!*==cchkrfp.f90 processed by SPAG 7.51RB at 17:34 on  4 Mar 2022
!> \brief \b CCHKRFP
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       PROGRAM CCHKRFP
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CCHKRFP is the main test program for the COMPLEX linear equation
!> routines with RFP storage format
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \verbatim
!>  MAXIN   INTEGER
!>          The number of different values that can be used for each of
!>          M, N, or NB
!>
!>  MAXRHS  INTEGER
!>          The maximum number of right hand sides
!>
!>  NTYPES  INTEGER
!>
!>  NMAX    INTEGER
!>          The maximum allowable value for N.
!>
!>  NIN     INTEGER
!>          The unit number for input
!>
!>  NOUT    INTEGER
!>          The unit number for output
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup complex_lin
!
!  =====================================================================
      PROGRAM CCHKRFP
      use M_tst_lin, only : CDRVRFP , CDRVRF1 , CDRVRF2 , CDRVRF3 , CDRVRF4, CERRRFP
      IMPLICIT NONE
!*--CCHKRFP63
!
!  -- LAPACK test routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER MAXIN
      PARAMETER (MAXIN=12)
      INTEGER NMAX
      PARAMETER (NMAX=50)
      INTEGER MAXRHS
      PARAMETER (MAXRHS=16)
      INTEGER NTYPES
      PARAMETER (NTYPES=9)
      INTEGER NIN , NOUT
      PARAMETER (NIN=5,NOUT=6)
!     ..
!     .. Local Scalars ..
      LOGICAL fatal , tsterr
      INTEGER vers_major , vers_minor , vers_patch
      INTEGER i , nn , nns , nnt
      REAL eps , s1 , s2 , thresh

!     ..
!     .. Local Arrays ..
      INTEGER nval(MAXIN) , nsval(MAXIN) , ntval(NTYPES)
      COMPLEX worka(NMAX,NMAX)
      COMPLEX workasav(NMAX,NMAX)
      COMPLEX workb(NMAX,MAXRHS)
      COMPLEX workxact(NMAX,MAXRHS)
      COMPLEX workbsav(NMAX,MAXRHS)
      COMPLEX workx(NMAX,MAXRHS)
      COMPLEX workafac(NMAX,NMAX)
      COMPLEX workainv(NMAX,NMAX)
      COMPLEX workarf((NMAX*(NMAX+1))/2)
      COMPLEX workap((NMAX*(NMAX+1))/2)
      COMPLEX workarfinv((NMAX*(NMAX+1))/2)
      COMPLEX c_work_clatms(3*NMAX)
      COMPLEX c_work_cpot02(NMAX,MAXRHS)
      COMPLEX c_work_cpot03(NMAX,NMAX)
      REAL s_work_clatms(NMAX)
      REAL s_work_clanhe(NMAX)
      REAL s_work_cpot01(NMAX)
      REAL s_work_cpot02(NMAX)
      REAL s_work_cpot03(NMAX)
!     ..
!     .. External Functions ..
      REAL SLAMCH , SECOND
      EXTERNAL SLAMCH , SECOND
!     ..
!     .. External Subroutines ..
      EXTERNAL ILAVER
!     ..
!     .. Executable Statements ..
!
      s1 = SECOND()
      fatal = .FALSE.
!
!     Read a dummy line.
!
      READ (NIN,FMT=*)
!
!     Report LAPACK version tag (e.g. LAPACK-3.2.0)
!
      CALL ILAVER(vers_major,vers_minor,vers_patch)
      WRITE (NOUT,FMT=99006) vers_major , vers_minor , vers_patch
!
!     Read the values of N
!
      READ (NIN,FMT=*) nn
      IF ( nn<1 ) THEN
         WRITE (NOUT,FMT=99004) ' NN ' , nn , 1
         nn = 0
         fatal = .TRUE.
      ELSEIF ( nn>MAXIN ) THEN
         WRITE (NOUT,FMT=99005) ' NN ' , nn , MAXIN
         nn = 0
         fatal = .TRUE.
      ENDIF
      READ (NIN,FMT=*) (nval(i),i=1,nn)
      DO i = 1 , nn
         IF ( nval(i)<0 ) THEN
            WRITE (NOUT,FMT=99004) ' M  ' , nval(i) , 0
            fatal = .TRUE.
         ELSEIF ( nval(i)>NMAX ) THEN
            WRITE (NOUT,FMT=99005) ' M  ' , nval(i) , NMAX
            fatal = .TRUE.
         ENDIF
      ENDDO
      IF ( nn>0 ) WRITE (NOUT,FMT=99007) 'N   ' , (nval(i),i=1,nn)
!
!     Read the values of NRHS
!
      READ (NIN,FMT=*) nns
      IF ( nns<1 ) THEN
         WRITE (NOUT,FMT=99004) ' NNS' , nns , 1
         nns = 0
         fatal = .TRUE.
      ELSEIF ( nns>MAXIN ) THEN
         WRITE (NOUT,FMT=99005) ' NNS' , nns , MAXIN
         nns = 0
         fatal = .TRUE.
      ENDIF
      READ (NIN,FMT=*) (nsval(i),i=1,nns)
      DO i = 1 , nns
         IF ( nsval(i)<0 ) THEN
            WRITE (NOUT,FMT=99004) 'NRHS' , nsval(i) , 0
            fatal = .TRUE.
         ELSEIF ( nsval(i)>MAXRHS ) THEN
            WRITE (NOUT,FMT=99005) 'NRHS' , nsval(i) , MAXRHS
            fatal = .TRUE.
         ENDIF
      ENDDO
      IF ( nns>0 ) WRITE (NOUT,FMT=99007) 'NRHS' , (nsval(i),i=1,nns)
!
!     Read the matrix types
!
      READ (NIN,FMT=*) nnt
      IF ( nnt<1 ) THEN
         WRITE (NOUT,FMT=99004) ' NMA' , nnt , 1
         nnt = 0
         fatal = .TRUE.
      ELSEIF ( nnt>NTYPES ) THEN
         WRITE (NOUT,FMT=99005) ' NMA' , nnt , NTYPES
         nnt = 0
         fatal = .TRUE.
      ENDIF
      READ (NIN,FMT=*) (ntval(i),i=1,nnt)
      DO i = 1 , nnt
         IF ( ntval(i)<0 ) THEN
            WRITE (NOUT,FMT=99004) 'TYPE' , ntval(i) , 0
            fatal = .TRUE.
         ELSEIF ( ntval(i)>NTYPES ) THEN
            WRITE (NOUT,FMT=99005) 'TYPE' , ntval(i) , NTYPES
            fatal = .TRUE.
         ENDIF
      ENDDO
      IF ( nnt>0 ) WRITE (NOUT,FMT=99007) 'TYPE' , (ntval(i),i=1,nnt)
!
!     Read the threshold value for the test ratios.
!
      READ (NIN,FMT=*) thresh
      WRITE (NOUT,FMT=99008) thresh
!
!     Read the flag that indicates whether to test the error exits.
!
      READ (NIN,FMT=*) tsterr
!
      IF ( fatal ) THEN
         WRITE (NOUT,FMT=99001)
         STOP
      ENDIF
!
!     Calculate and print the machine dependent constants.
!
      eps = SLAMCH('Underflow threshold')
      WRITE (NOUT,FMT=99009) 'underflow' , eps
      eps = SLAMCH('Overflow threshold')
      WRITE (NOUT,FMT=99009) 'overflow ' , eps
      eps = SLAMCH('Epsilon')
      WRITE (NOUT,FMT=99009) 'precision' , eps
      WRITE (NOUT,FMT=*)
!
!     Test the error exit of:
!
      IF ( tsterr ) CALL CERRRFP(NOUT)
!
!    Test the routines: cpftrf, cpftri, cpftrs (as in CDRVPO).
!    This also tests the routines: ctfsm, ctftri, ctfttr, ctrttf.
!
      CALL CDRVRFP(NOUT,nn,nval,nns,nsval,nnt,ntval,thresh,worka,       &
     &             workasav,workafac,workainv,workb,workbsav,workxact,  &
     &             workx,workarf,workarfinv,c_work_clatms,c_work_cpot02,&
     &             c_work_cpot03,s_work_clatms,s_work_clanhe,           &
     &             s_work_cpot01,s_work_cpot02,s_work_cpot03)
!
!    Test the routine: clanhf
!
      CALL CDRVRF1(NOUT,nn,nval,thresh,worka,NMAX,workarf,s_work_clanhe)
!
!    Test the conversion routines:
!       chfttp, ctpthf, ctfttr, ctrttf, ctrttp and ctpttr.
!
      CALL CDRVRF2(NOUT,nn,nval,worka,NMAX,workarf,workap,workasav)
!
!    Test the routine: ctfsm
!
      CALL CDRVRF3(NOUT,nn,nval,thresh,worka,NMAX,workarf,workainv,     &
     &             workafac,s_work_clanhe,c_work_cpot03,c_work_cpot02)
!
!
!    Test the routine: chfrk
!
      CALL CDRVRF4(NOUT,nn,nval,thresh,worka,workafac,NMAX,workarf,     &
     &             workainv,NMAX,s_work_clanhe)
!
      CLOSE (NIN)
      s2 = SECOND()
      WRITE (NOUT,FMT=99002)
      WRITE (NOUT,FMT=99003) s2 - s1
!
99001 FORMAT (/' Execution not attempted due to input errors')
99002 FORMAT (/' End of tests')
99003 FORMAT (' Total time used = ',F12.2,' seconds',/)
99004 FORMAT (' !! Invalid input value: ',A4,'=',I6,'; must be >=',I6)
99005 FORMAT (' !! Invalid input value: ',A4,'=',I6,'; must be <=',I6)
99006 FORMAT (/' Tests of the COMPLEX LAPACK RFP routines ',            &
     &        /' LAPACK VERSION ',I1,'.',I1,'.',I1,                     &
     &        //' The following parameter values will be used:')
99007 FORMAT (4X,A4,':  ',10I6,/11X,10I6)
99008 FORMAT (/' Routines pass computational tests if test ratio is ',  &
     &        'less than',F8.2,/)
99009 FORMAT (' Relative machine ',A,' is taken to be',D16.6)
!
!     End of CCHKRFP
!
      END PROGRAM CCHKRFP


PROGRAM LA_CPPSV_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_PPSV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, K, INFO, N, NRHS, NS
!  .. LOCAL ARRAYS ..
   COMPLEX(WP), ALLOCATABLE :: A(:), B(:,:)
   REAL(WP), ALLOCATABLE :: AA(:), BB(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'CPPSV ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, NRHS
   PRINT *, 'N = ', N, ' NRHS = ', NRHS
   NS = N*(N+1)/2
   ALLOCATE ( A(NS), AA(NS), B(N,NRHS), BB(N,NRHS) )
!
        READ (NIN, *) AA
      BB = 0.0_WP
      DO K = 1, NRHS
         DO I = 1, N
            DO J = 1, I
               BB(J,K) = BB(J,K) + AA(J+(I-1)*I/2)
               IF ( J /= I ) BB(I,K) = BB(I,K) + AA(J+(I-1)*I/2)
            ENDDO
         ENDDO
         BB(:,K) = BB(:,K)*K
      ENDDO
   A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE (NOUT,*) 'J = ', I; WRITE (NOUT,FMT) (A(J+(I-1)*I/2),J=1,I)
      ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_CPPSV LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSV(A, B )'
   A=AA; B=BB
   CALL LA_PPSV( A, B )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_PPSV:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSV(A, B(:,1) )'
   A=AA; B=BB
   CALL LA_PPSV( A, B(1:N,1) )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_PPSV:'
   WRITE (NOUT,FMT) B(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSV( A, B, ''L'' )'
   DO I = 1,N
      DO J = I, N
         A(J+(I-1)*(2*N-I)/2) = AA(I+J*(J-1)/2)
      ENDDO
   ENDDO
   B = BB
   CALL LA_PPSV( A, B, 'L' )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_PPSV:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSV( A, B(:,1), ''L'' )'
   DO I = 1,N
      DO J = I, N
         A(J+(I-1)*(2*N-I)/2) = AA(I+J*(J-1)/2)
      ENDDO
   ENDDO
   B = BB
   CALL LA_PPSV( A, B(1:N,1), 'L', INFO )
   WRITE(NOUT,*)'B - the solution vectors computed by LA_PPSV, INFO = ', INFO
   WRITE (NOUT,FMT) B(1:N,1)
!
END PROGRAM LA_CPPSV_ET_EXAMPLE


! Matrix distribution
!
! Distribute a global N x N matrix over P processes as evenly as possible so
! that each process has a local portion of this matrix.  Initialize such a
! portion with the process rank.  N is not necessarily divisible by P.  Each
! process sends its first and last columns (in Fortran) to neighbors: first to
! the left rank, last to the right rank.  Each process must allocate two extra
! colums with ghost cells.
!
! Compile and run:
!
!     $ mpifort -g -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace \
!       matrix_distribution.f90
!     $ mpirun -np 3 --oversubscribe ./a.out
!
! Enter size 10.
program matrix_distribution
    use mpi_f08
    implicit none
    type(MPI_Comm) :: comm
    type(MPI_Status) :: status
    type(MPI_Datatype) :: a_col
    integer :: my_rank, n_ranks, left_rank, right_rank, s, jb, je
    integer, allocatable :: matrix(:, :)

    call MPI_Init()
    comm = MPI_COMM_WORLD
    call MPI_Comm_rank(comm, my_rank)
    call MPI_Comm_size(comm, n_ranks)

    left_rank  = get_rank(my_rank - 1, n_ranks)
    right_rank = get_rank(my_rank + 1, n_ranks)

    if (my_rank == 0) read *, s
    call MPI_Bcast(s, 1, MPI_INTEGER, 0, comm)

    call partition(my_rank, n_ranks, s, jb, je)
    allocate(matrix(s, jb - 1 : je + 1), source=my_rank)

    call print_gatherv(matrix, my_rank, n_ranks, comm)

    call MPI_Type_contiguous(s, MPI_INTEGER, a_col)
    call MPI_Type_commit(a_col)

    call MPI_Sendrecv(matrix(1, jb),     1, a_col, left_rank,  0, &
                      matrix(1, je + 1), 1, a_col, right_rank, 0, comm, status)

    call MPI_Sendrecv(matrix(1, je),     1, a_col, right_rank, 1, &
                      matrix(1, jb - 1), 1, a_col, left_rank,  1, comm, status)

    call MPI_Type_free(a_col)

    call print_gatherv(matrix, my_rank, n_ranks, comm)

    deallocate(matrix)
    call MPI_Finalize()

contains

    !---------------------------------------------------------------------------
    subroutine print_gatherv(mtx, id, n_ids, comm)
        integer,        intent(in) :: mtx(:, :), id, n_ids
        type(MPI_Comm), intent(in) :: comm
        character(len=:), allocatable :: line, lines
        character(len=12) :: i_fmt ! integer format string
        integer :: line_len, lines_len, i, n_rows, n_cols, n_proc, disp
        integer, parameter :: I_WIDTH = 1 ! "(i2)" descriptor
        integer, allocatable :: sizes(:), disps(:)

        write(unit=i_fmt, fmt="(a, i0, a)") "(*(i", I_WIDTH,", 1x))"

        n_rows = size(mtx, dim=1)
        n_cols = size(mtx, dim=2)
        line_len = (I_WIDTH + 1) * (1 + n_cols)
        lines_len = 0
        call MPI_Reduce(line_len, lines_len, 1, MPI_INTEGER, MPI_SUM, 0, comm)
        allocate(character(len=line_len)  :: line)
        allocate(character(len=lines_len) :: lines)

        disp = 0
        call MPI_Exscan(line_len, disp, 1, MPI_INTEGER, MPI_SUM, comm)

        n_proc = merge(n_ids, 0, id == 0)
        allocate(sizes(n_proc))
        allocate(disps(n_proc))
        call MPI_Gather(line_len, 1, MPI_INTEGER, &
                        sizes,    1, MPI_INTEGER, 0, comm)
        call MPI_Gather(disp,     1, MPI_INTEGER, &
                        disps,    1, MPI_INTEGER, 0, comm)

        do i = 0, n_rows
            if (i == 0) then
                write(line, "(a, i0)") "Rank ", id
            else
                write(line, i_fmt) mtx(i, :)
            end if
            call MPI_Gatherv(line,  line_len,     MPI_CHARACTER, &
                             lines, sizes, disps, MPI_CHARACTER, 0, comm)
            if (id == 0) print "(a)", lines
        end do

        if (allocated(line)) deallocate(line)
        if (allocated(lines)) deallocate(lines)
        if (allocated(sizes)) deallocate(sizes)
        if (allocated(disps)) deallocate(disps)
        return
    end subroutine print_gatherv
    !---------------------------------------------------------------------------
    subroutine partition(id, n_ids, size, b, e)
        integer, intent(in)    :: id, n_ids, size
        integer, intent(inout) :: b, e
        integer :: remainder, quotient

        remainder = modulo(size, n_ids)
        quotient  = (size - remainder) / n_ids
        b = 1 + quotient * (id    ) + min(remainder, id    )
        e =     quotient * (id + 1) + min(remainder, id + 1)
        return
    end subroutine partition
    !---------------------------------------------------------------------------
    integer function get_rank(rnk, n_ids)
        integer, intent(in) :: rnk, n_ids
        get_rank = modulo(rnk, n_ids)
        return
    end function get_rank
    !---------------------------------------------------------------------------

end program matrix_distribution