      MODULE MOD_LIOP

      CONTAINS

      SUBROUTINE LIOP_RTE(EINST, WEIGHTI, WEIGHTJ, I, J,
     $                    ND, XLAM, ENTOT, POPNUM, RSTAR,
     $                    OPAL, ETAL, VDOP, N)

!     CALCULATES THE LINE OPACITY OPAL AND THE EMISSIVITY ETAL FOR ONE LINE
!     AT ALL DEPTH POINTS
!     PHYSICAL DIMENSION OF OPAL : PER RSTAR AND PER DELTA-NUE-DOPPLER
!     (THE LATTER WILL BE CANCELLED OUT BY THE NORMALISED PROFILE FUNCTION)
!     GIVEN QUANTITIES : EINST = EINSTEIN COEFFICIENT A (UP - LOW, PER SECOND)
!                        WEIGHTI, WEIGHTJ = STATISTICAL WEIGHTS (UP, LOW)
!                        POPNUM(L, J) = RELATIVE POPULATION NUMBERS
!                        ENTOT(L) = TOTAL NUMBER DENSITY

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

!     When liop.for is called from etl.for ND = ND, when called from other routines ND = 1
      INTEGER, INTENT(IN) :: ND

      INTEGER, INTENT(IN) :: N

      DIMENSION ENTOT(ND), OPAL(ND), ETAL(ND)

      REAL*8, DIMENSION(ND, N) :: POPNUM

      REAL*8, INTENT(IN) :: ENTOT

!     C3 = 4 * PI / H / C (CGS UNITS)
      DATA C3 /6.3268D16/

!     PI8 = 8 * PI
      DATA PI8 /25.1327D0/

      XLAMCM = XLAM / 1.0D+8

!     DND = DELTA-NUE-DOPPLER (HERTZ)
!     ************************************************************************************
      DND = VDOP / XLAM * 1.0D+13

!     RINAT TAGIROV:
!     VDOP = sqrt(V_therm^2 + V_turb^2), where V_therm is the
!     thermal velocity of atoms and V_turb is the turbulent velocity
!     of separate parcels of gas. This can be inferred from the FLGRID.for procedure,
!     formula for the Doppler line profile in page 205 of Lang's "Astrophysical formulas"
!     and the way VDOP enters this routine. While it is very simple to calculate
!     VDOP at any height having the model of the atmosphere in HMINUS
!     it is a free parameter set it the CARDS file.
!     It has to be free because of some computational obstacles arising in case
!     when VDOP is depth dependent (for details refer to Werner cuz I never quite figured
!     out the reason properly). However, one of the possible reasons could be that
!     in ETL.FOR the velocity field and its gradient are divided by VDOP
!     for the purposes of their conversion into dimensionless units.
!     Velocity field has to be monotonic and dividing it by a function of height
!     could obviate the monotonicity. Therefore VDOP has to be constant, hence it has to
!     be a free parameter. Why one needs to introduce the dimensionless velocity field
!     is another question which I don't have an answer to.
!     ************************************************************************************

      EMINDU = EINST * XLAMCM * XLAMCM / PI8 * RSTAR
      ABSORP = EMINDU * WEIGHTJ / WEIGHTI
      EMSPON = EINST / XLAMCM / C3 * RSTAR

      DO L = 1, ND

         ENI = POPNUM(L, I) * ENTOT(L)
         ENJ = POPNUM(L, J) * ENTOT(L)

         OPAL(L) = (ENI * ABSORP - ENJ * EMINDU) / DND

         IF (OPAL(L) .LT. 0.0D0) OPAL(L) = 0.0D0

         ETAL(L) = ENJ * EMSPON / DND

      ENDDO

      RETURN

      END SUBROUTINE

      SUBROUTINE LIOP_SBE(EINST, WEIGHTI, WEIGHTJ, I, J,
     $                    XLAM, ENTOTL, POPNUM, RSTAR,
     $                    OPAL, ETAL, VDOP, N)

!     CALCULATES THE LINE OPACITY OPAL AND THE EMISSIVITY ETAL FOR ONE LINE
!     AT ALL DEPTH POINTS
!     PHYSICAL DIMENSION OF OPAL : PER RSTAR AND PER DELTA-NUE-DOPPLER
!     (THE LATTER WILL BE CANCELLED OUT BY THE NORMALISED PROFILE FUNCTION)
!     GIVEN QUANTITIES : EINST = EINSTEIN COEFFICIENT A (UP - LOW, PER SECOND)
!                        WEIGHTI, WEIGHTJ = STATISTICAL WEIGHTS (UP, LOW)
!                        POPNUM(L, J) = RELATIVE POPULATION NUMBERS
!                        ENTOT(L) = TOTAL NUMBER DENSITY

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

!     When liop.for is called from etl.for ND = ND, when called from other routines ND = 1
      INTEGER, INTENT(IN) :: N

      REAL*8, DIMENSION(N) :: POPNUM

      REAL*8, INTENT(IN) :: ENTOTL

      real*8 :: opal, etal

!     C3 = 4 * PI / H / C (CGS UNITS)
      DATA C3 /6.3268D16/

!     PI8 = 8 * PI
      DATA PI8 /25.1327D0/

      XLAMCM = XLAM / 1.0D+8

!     DND = DELTA-NUE-DOPPLER (HERTZ)
!     ************************************************************************************
      DND = VDOP / XLAM * 1.0D+13

!     RINAT TAGIROV:
!     VDOP = sqrt(V_therm^2 + V_turb^2), where V_therm is the
!     thermal velocity of atoms and V_turb is the turbulent velocity
!     of separate parcels of gas. This can be inferred from the FLGRID.for procedure,
!     formula for the Doppler line profile in page 205 of Lang's "Astrophysical formulas"
!     and the way VDOP enters this routine. While it is very simple to calculate
!     VDOP at any height having the model of the atmosphere in HMINUS
!     it is a free parameter set it the CARDS file.
!     It has to be free because of some computational obstacles arising in case
!     when VDOP is depth dependent (for details refer to Werner cuz I never quite figured
!     out the reason properly). However, one of the possible reasons could be that
!     in ETL.FOR the velocity field and its gradient are divided by VDOP
!     for the purposes of their conversion into dimensionless units.
!     Velocity field has to be monotonic and dividing it by a function of height
!     could obviate the monotonicity. Therefore VDOP has to be constant, hence it has to
!     be a free parameter. Why one needs to introduce the dimensionless velocity field
!     is another question which I don't have an answer to.
!     ************************************************************************************

      EMINDU = EINST * XLAMCM * XLAMCM / PI8 * RSTAR
      ABSORP = EMINDU * WEIGHTJ / WEIGHTI
      EMSPON = EINST / XLAMCM / C3 * RSTAR

      ENI = POPNUM(I) * ENTOTL
      ENJ = POPNUM(J) * ENTOTL

      OPAL = (ENI * ABSORP - ENJ * EMINDU) / DND

      ETAL = ENJ * EMSPON / DND

!      if (j .eq. 3 .and. i .eq. 2) print*, 'liop:', popnum(i), popnum(j)

      IF (OPAL .LT. 0.0D0) OPAL = 0.0D0

      RETURN

      END SUBROUTINE

      END MODULE


****************************************************************************
* interpolation of model atmosphere
* parameter space of interpolation {Teff,logg,z}
* 8 MARCS binary models as input required:
* ! the order of input models matters !
* ! only standard composition has been tested, no guaranty for peculiar composition !
* turbospectrum/babsma format compatible output

* Interpolation scheme of model atmosphere(@)
* in {Teff,logg,z} stellar parameter space
*
*         |_ _ _ _ _
*         |        /|:
*        /|       /
*       _ |_ _ _ /  |
*       | |      |
*         |         |
*       | |    @ |
*         |--------------> logg
*       |/       | /
*       /_ _ _ _ ./
*      /
*     /
*    Teff
*
* Each structure component of each model (T,Pe,Pg,xit,optical depth, kappaross)
* is first resampled on a common optical depth basis tau(5000 or ross) (see resample routine).
*
* Then each component of the atmosphere(@) (T,Pe,Pg,xit,kappa,geom depth +tau5000 and tauross))
* is interpolated individually along each dimension between each input model value(*)
* (physically it is impossible to ensure a simple relationship between models in more than one dimension at the same time,
* that's why the input models MUST form a "cube" in the stellar parameter space {Teff,logg,z})
* The interpolation is successively done at each optical depth (tau)
* + interpolation point weighted by an empirical value (see TM thesis + manual)
*
*
*                 ^ T,Pe,Pg,xit or radius
*                 |
*                 |            *
*                 |           /|
*                 |          @
*                 |         /| |
*                 |   /    /
*                 |  /    /  | |
*         ^       | /    *
*         |       |/     |   | |
*         |       -----------------------> Teff, logg and z
*         |      /      low ref up
*         |     /*      /   / /
*         |    / |\
*         |   /    \  /   / /
*         |  /   |  \
*         | /       /@  / /
*         |/     |   |\
*         / _  _ /_ _ /*_ _ _ _ _
*        /      low ref up
*       /
*   tau{5000 or Ross}
*
***************************************************************************
* TM 07/2003

c  07/2004 resampling of each model on a common optical depth basis
c  06/2006 works for spherical geometry models
c  09/2007 new calibration of free parameter alpha
c           + modified to read Uppsala ascii models
c           + kappa interpolation
c           + rhox calculation
c           + 2 outputs (babsma and ATLAS/MOOG)
c  10/2007 error estimates
c  10/2011 two non crucial bugs fixed
c             -unformatted->formatted read for ascii models because there is a couple of trouble makers in the grid
c             -dimension of taubas was not matching tauR (emo@astro.indiana.edu)
c  04/2012 unformatted reading of ascii models reinstated (troublemakers hopefully fixed) /BE
****************************************************************************
!  compile with Fortran 90 or 95

c---------------------------------------------------------------------------------
      subroutine blend_103 (r,s,t,u,
     & x0000,x0010,x0100,x0110,x1000,x1010,x1100,x1110,
     & x0001,x0011,x0101,x0111,x1001,x1011,x1101,x1111, x )
!
!*******************************************************************************
!from http://www.math.iastate.edu/burkardt/f_src/
!
!! BLEND_103 extends scalar point data into a cube.
!
!
!  Diagram:
!
!    011--------------111
!      |               |
!      |               |
!      |               |
!      |               |
!      |               |
!    001--------------101
!
!
!      *---------------*
!      |               |
!      |               |
!      |      rst      |
!      |               |
!      |               |
!      *---------------*
!
!
!    010--------------110
!      |               |
!      |               |
!      |               |
!      |               |
!      |               |
!    000--------------100
!
!
!  Formula:
!
!    Written as a polynomial in R, S and T, the interpolation map has the
!    form:
!
!      X(R,S,T) =
!        1         * ( + x000 )
!      + r         * ( - x000 + x100 )
!      +     s     * ( - x000        + x010 )
!      +         t * ( - x000               + x001 )
!      + r * s     * ( + x000 - x100 - x010                       + x110 )
!      + r     * t * ( + x000 - x100        - x001        + x101 )
!      +     s * t * ( + x000        - x010 - x001 + x011 )
!      + r * s * t * ( - x000 + x100 + x010 + x001 - x011 - x101 - x110 + x111 )
!
!  Reference:
!
!    William Gordon,
!    Blending-Function Methods of Bivariate and Multivariate Interpolation
!      and Approximation,
!    SIAM Journal on Numerical Analysis,
!    Volume 8, Number 1, March 1971, pages 158-177.
!
!    William Gordon and Charles Hall,
!    Transfinite Element Methods: Blending-Function Interpolation over
!      Arbitrary Curved Element Domains,
!    Numerische Mathematik,
!    Volume 21, Number 1, 1973, pages 109-129.
!
!    William Gordon and Charles Hall,
!    Construction of Curvilinear Coordinate Systems and Application to
!      Mesh Generation,
!    International Journal of Numerical Methods in Engineering,
!    Volume 7, 1973, pages 461-477.
!
!    Joe Thompson, Bharat Soni, Nigel Weatherill,
!    Handbook of Grid Generation,
!    CRC Press, 1999.
!
!  Modified:
!
!    11 October 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real R, S, T, the coordinates where an interpolated value
!    is desired.
!
!    Input, real X000, X001, X010, X011, X100, X101, X110, X111, the
!    data values at the corners.
!
!    Output, real X, the interpolated data value at (R,S,T).
!
      implicit none
!
      real r,s,t,u,x
      real x0000,x0010,x0100,x0110
      real x1000,x1010,x1100,x1110
      real x0001,x0011,x0101,x0111
      real x1001,x1011,x1101,x1111
!
!  Interpolate the interior point.
!
      x =
     & 1.0E+00         * ( + x0000 )
     & + r             * ( - x0000 + x1000 )
     & + s             * ( - x0000 + x0100 )
     & + t             * ( - x0000 + x0010 )
     & + u             * ( - x0000 + x0001 )
     & + r * s         * ( + x0000 - x1000 - x0100 + x1100 )
     & + r * t         * ( + x0000 - x1000 - x0010 + x1010 )
     & + r * u         * ( + x0000 - x1000 - x0001 + x1001 )
     & + s * t         * ( + x0000 - x0100 - x0010 + x0110 )
     & + s * u         * ( + x0000 - x0100 - x0001 + x0101 )
     & + t * u         * ( + x0000 - x0010 - x0001 + x0011 )
     & + r * s * t     * ( - x0000 + x1000 + x0100 + x0010
     &                             - x0110 - x1010 + x1100 + x1110 )
     & + r * t * u     * ( - x0000 + x1000 + x0010 + x0001
     &                             - x0011 - x1001 - x1010 + x1011 )
     & + r * s * u     * ( - x0000 + x1000 + x0100 + x0001
     &                             - x1100 - x1001 - x0101 + x1101 )
     & + s * t * u     * ( - x0000 + x0100 + x0010 + x0001
     &                             - x0110 - x0101 - x0011 + x0111 )
     & + r * s * t * u * ( - x0000 - x1000 - x0100 - x0010 - x0001
     &                             + x1100 + x1010 + x1001
     &                             + x0110 + x0101 + x0011
     &                             - x1110 - x1101 - x1011 - x0111
     &                             + x1111 )

      return
      end

c---------------------------------------------------------------------------------
      subroutine extract_bin(FILE,TEFF,grav,metal,ndepth,xlr_ref,tau5,
     &                tauR,temp,prese,presg,xit,rad,sph,kappa)

!extracted from osplot.f 07/2003, to get tau,T,Pe,Pg,microturb from a model
      implicit none
      integer :: ndp,ndepth,k,nlp,nlb
      parameter(ndp=200)
      CHARACTER*117 ADUM
      CHARACTER*256 FILE,file2
      CHARACTER*30 COMMENT
      real metal,grav,xlr_ref,TEFF,GG,radius
      logical :: sph
      real :: tau(ndp),t(ndp),z(ndp),ptot(ndp),prad(ndp),
     &  pg(ndp),pturb(ndp),pe(ndp),ro(ndp),xmass(ndp),xkapr(ndp)
      real :: gradp(ndp),gravity(ndp),pcheck(ndp),rr(ndp),
     &   xit(ndp),geff(ndp),gradptur(ndp),dp(ndp),taus(ndp),xlr(30),
     &   coldens(ndp)
      real :: tau5(ndp),tauR(ndp),temp(ndp),prese(ndp),
     &   presg(ndp),rad(ndp),kappa(ndp)
      real :: xlb(155000),w(155000),fluxme(155000)
      real :: presmo(30,ndp),ptio(ndp)
      real :: bPPR(NDP),bPPT(NDP),bPP(NDP),bGG(NDP),
     & bZZ(NDP),bDD(NDP),
     & bVV(NDP),bFFC(NDP),bPPE(NDP),bTT(NDP),
     & bTAULN(NDP),erad(ndp)
      integer :: NbTAU,IbTER
      common /struct/ tau,t,z,ptot,prad,pg,pturb,pe,ro,rr,taus,xlr,
     &                nlp,xkapr
      common /spectr/ nlb,xlb,w,fluxme
      common /pressure/ presmo,ptio
      common /binstruc/bPPR,bPPT,bPP,bGG,
     & bZZ,bDD,
     & bVV,bFFC,bPPE,bTT,
     & bTAULN,NbTAU,IbTER,erad
      common /radius/ radius
      OPEN(UNIT=10,FILE=FILE,STATUS='OLD',FORM='UNFORMATTED',
     &     convert='big_endian')
ccc     &     RECL=152600)
*
      CALL READMO(10,NDEPTH,TEFF,GG,metal,sph)
c         open(21,file=file2,status='unknown')
      do k=1,ndepth
        tau5(k)=log10(taus(k))
        tauR(k)=log10(tau(k))
         temp(k)=t(k)
         prese(k)=log10(pe(k))
         presg(k)= log10(pg(k))
         kappa(k)=log10(xkapr(k))
      end do
         xit=2.0
         xlr_ref=xlr(nlp)
         grav=log10(GG)
*        rad=rr
         if(.not.sph) radius=0.0
         rad=radius-z
c         write(21,1966) ndepth,xlr(nlp),log10(GG)
c1966     format('''INTERPOL''',1x,i3,f8.0,2x,f4.2,1x,'0 0.00')
c         do k=1,ndepth
c           write(21,1965) log10(taus(k)),t(k),log10(pe(k)),
c     &                    log10(pg(k)), xit
c1965       format(f8.4,1x,f8.2,3(x,f8.4))
c         enddo
c      close(21)
      close(10)
      END
C
      SUBROUTINE READMO(IARCH,JTAU,TEFF,G,metal,spherical)
C        THIS ROUTINE READS ONE MODEL, TO GET INFO ON PRAD
C             ( All features taken from listmo )
      PARAMETER (NDP=200)
C
      DIMENSION ABUND(16),TKORRM(NDP),FCORR(NDP),TAU(NDP),TAUS(NDP),
     *T(NDP),PE(NDP),PG(NDP),PRAD(NDP),PTURB(NDP),XKAPR(NDP),RO(NDP),
     *CP(NDP),CV(NDP),AGRAD(NDP),Q(NDP),U(NDP),V(NDP),ANCONV(NDP),
     *PRESMO(30,NDP),FCONV(NDP),RR(NDP),Z(NDP),EMU(NDP),HNIC(NDP)
     *,NJ(16),XLR(30),IEL(16),ANJON(16,5),PART(16,5),PROV(50,20+1),
     *ABSKA(50),SPRIDA(50),XLB(155000),FLUXME(155000),FLUMAG(155000),
     & PEP(16),
     * ABNAME(50),SOURCE(50),PTOT(NDP)
      DIMENSION W(155000),UW(12),BW(21),VW(25)
      CHARACTER*10 DAG,NAME,NAMEP,KLOCK
      CHARACTER*8 ABNAME,SOURCE
      DIMENSION WAVFLX(10)
      dimension PTIO(NDP)
      real*8 dluminosity
      real abSc,abTi,abV,abMn,abCo,metal
      logical spherical
      common /binstruc/ dummy(11*ndp+2),erad(ndp)
      common /struct/ tau,t,z,ptot,prad,pg,pturb,pe,ro,rr,taus,xlr,
     &                nlp,xkapr
      common /spectr/ nlb,xlb,w,fluxme
      common /pressure/ presmo,ptio
      common /radius/ radius
      DATA UW/0.145,0.436,0.910,1.385,1.843,2.126,2.305,2.241,1.270,
     *0.360,0.128,0.028/,BW/0.003,0.026,0.179,0.612,1.903,2.615,2.912,
     *3.005,2.990,2.876,2.681,2.388,2.058,1.725,1.416,1.135,0.840,0.568,
     *0.318,0.126,0.019/,VW/0.006,0.077,0.434,1.455,2.207,2.703,2.872,
     *2.738,2.505,2.219,1.890,1.567,1.233,0.918,0.680,0.474,0.312,0.200,
     *0.132,0.096,0.069,0.053,0.037,0.022,0.012/
      DATA NAME/'LOCAL'/,NAMEP/'PARSONS'/
      DATA A,B/.34785485,.65214515/
      IREAD=5
C
      REWIND IARCH
      READ(IARCH)
      erad=-1.e30
      READ(IARCH) INORD,DAG,KLOCK
      READ(IARCH) TEFF,FLUX,G,PALFA,PNY,PY,PBETA,ILINE,ISTRAL,
     &                MIHAL,IDRAB1,IDRAB2,IDRAB3,IDRAB4,IDRAB5,IDRAB6,
     &            ITMAX,NEL,(ABUND(I),I=1,NEL),abSc,abTi,abV,abMn,abCo
      GLOG=ALOG10(G)
      FNORD=0.1*INORD
C        CONVERT TO 'PHYSICAL FLUX'
      FLUX=3.14159*FLUX
      DO 2 I=1,NEL
    2 ABUND(I)=ALOG10(ABUND(I))+12.
      metal=abund(15)-7.50
      READ(IARCH)JTAU,NCORE,DIFLOG,TAUM,RADIUS,(RR(K),K=1,JTAU)
      if (jtau.gt.ndp) then
        print*, 'ERROR !!! Jtau (number of depths of model) = ',jtau
        print*, ' is larger than ndp!! Increase NDP.'
        stop
      endif
      if (radius.le.2.) then
         spherical = .false.
      else
         spherical = .true.
         rr=radius-rr
      endif

      READ(IARCH)JTAU,(TKORRM(I),I=1,JTAU),(FCORR(K),K=1,JTAU)
      NTPO=0
      DO 3 K=1,JTAU
        READ(IARCH) KR,TAU(K),TAUS(K),Z(K),T(K),PE(K),PG(K),PRAD(K),
     &              PTURB(K),XKAPR(K),RO(K),EMU(K),CP(K),CV(K),
     &              AGRAD(K),Q(K),U(K),V(K),ANCONV(K),HNIC(K),NMOL,
     &              (PRESMO(J,K),J=1,NMOL),ptio(k)
        TAUK=ALOG10(TAU(K))+10.01
        KTAU=TAUK
        IF(ABS(TAUK-KTAU).GT.0.02) GO TO 31
        IF(KTAU.EQ.10) K0=K
        NTPO=NTPO+1
   31   CONTINUE
    3 CONTINUE
c      Z0=Z(K0)
c      DO 5 I=1,JTAU
c        Z(I)=Z(I)-Z0
c        i1=min(i+1,jtau)
c        PTOT(I)=PG(I)+PRAD(I)+0.5*(pturb(i)+pturb(i1))
    5 CONTINUE

      READ(IARCH)(NJ(I),I=1,NEL),NLP,(XLR(I),I=1,NLP)
     & ,NPROV,NPROVA,NPROVS,(ABNAME(KP),SOURCE(KP),KP=1,NPROV)
c      DO 22 KTAU=1,NTPO
c      DO 20 IE=1,NEL
c      NJP=NJ(IE)
c      READ(IARCH) KR,TAUI,TI,PEI,IEL(IE),ABUND(IE),
c     &            (ANJON(IE,JJ),JJ=1,NJP),(PART(IE,JJ),JJ=1,NJP)
c   20 CONTINUE
c      DO 21 KLAM=1,NLP
c      READ(IARCH) KR,TAUIL,(PROV(J,KLAM),J=1,NPROV),
c     &            ABSKA(KLAM),SPRIDA(KLAM)
   21 CONTINUE
   22 continue
c      READ(IARCH) NLB,(XLB(J),FLUXME(J),J=1,NLB),(W(J),J=1,NLB)
C CONVERT TO 'PHYSICAL' FLUXES
c      DO 24 J=1,NLB
c   24 FLUXME(J)=3.14159*FLUXME(J)

c      dluminosity=0.
c      do 25 j=1,nlb
c       dluminosity=dluminosity+fluxme(j)*w(j)
25    continue
c      dluminosity=dluminosity*4.*3.14159*radius**2/3.82d33
c      ddddd=real(dluminosity)
c      print*,'luminosity: ',dluminosity*3.82d33,' erg/s  = ',ddddd,
c     &  ' solar luminosities'

      RETURN
         END

c---------------------------------------------------------------------------------
      subroutine extract_ascii(FILE,TEFF,grav,metal,alpha,ndepth,
     &xlr_ref,tau5,tauR,temp,prese,presg,xit,rad,sph,xkapr)
c     adapted from P. DeLaverny
      implicit none
      integer :: ndp,k
      parameter(ndp=200)
      integer :: imod,idum,ndepth,stat
      CHARACTER*117 ADUM
      CHARACTER*256 FILE,file2,line
      CHARACTER*30 COMMENT
      CHARACTER*50 MOCODE,blabla
      real metal,radius,mass,grav,xlr_ref,TEFF,GG,xic,alpha
      logical :: sph
      real :: tau(ndp),t(ndp),z(ndp),ptot(ndp),prad(ndp),
     &  pg(ndp),pturb(ndp),pe(ndp),ro(ndp),xmass(ndp),xkapr(ndp)
      real :: gradp(ndp),gravity(ndp),pcheck(ndp),rr(ndp),
     &  xit(ndp),geff(ndp),gradptur(ndp),dp(ndp),taus(ndp),xlr(30),
     &   coldens(ndp)
      real :: tau5(ndp),tauR(ndp),temp(ndp),prese(ndp),
     &   presg(ndp),rad(ndp),emu(ndp),vconv(ndp),fconv(ndp)
      real :: dimension xlb(155000),w(155000),fluxme(155000)

          blabla=''
          imod =10
          OPEN(UNIT=imod,FILE=FILE,STATUS='OLD')
          read(imod,'(a)') mocode
c          print*,mocode,' = mocode'
          if (mocode(1:1).eq.'p' .or. mocode(1:3).eq.'sun') then
            print*,' this model is PLANE PARALLEL'
          else if (mocode(1:1).eq.'s') then
            print*,' this model is SPHERICALLY SYMMETRIC'
          else
            print*,' This model may not be a NewMARCS model!'
          endif
          sph=(mocode(1:1).eq.'s')
          xlr_ref=5000
          read(imod,*)TEFF
          read(imod,*)
          read(imod,*)grav
          grav=log10(grav)
          read(imod,*)xic
          read(imod,*)mass
          read(imod,*)metal,alpha
          read(imod,*)radius
          do while (blabla.ne.'Model structure')
            read(imod,'(a)') blabla
          enddo
          backspace(imod)
          backspace(imod)
          read(imod,*)ndepth
          read(imod,*)
          read(imod,*)
          do k=1,ndepth
            read(imod,*) idum,tauR(k),tau5(k),rad(k),temp(k),
     &                   Pe(k),Pg(k)
            prese(k)  = log10(Pe(k))
            presg(k)  = log10(Pg(k))
            xit(k) = xic
            rad(k)=radius-rad(k)
          enddo
          read(imod,*)

          do k=1,ndepth

            read(imod,*,iostat=stat) idum,tauR(k),xkapr(k),ro(k),emu(k),
     &                   Vconv(k),Fconv(k)

c           Added by I.Escala to handle MARCS file format errors
            if (stat.eq.5010) then
              line=''
              backspace(imod)
              read(imod,'(a)') line
              read(line(39:48), '(f10.3)') Vconv(k)
              read(line(49:56), '(f8.5)') Fconv(k)
c              print*,tauR(k),xkapr(k),ro(k),emu(k),Vconv(k),Fconv(k)
            endif

            xkapr(k) = log10(xkapr(k))

          enddo

         close(imod)

      END

c---------------------------------------------------------------------------------

      subroutine common_depth_basis(tauresample,tau,nlinemod,nfile)
      implicit none
      integer :: file,nlinemod,nfile
      real,dimension(nlinemod,nfile) :: tau
      real,dimension(nlinemod) :: tauresample

      tauresample=0
c initialize the common tau(5000) with min depth = max of the min depth of the models
c                                  and max depth = min of the max depth of the models
c essential for  the resampling with cubic spline
      tauresample(1)=tau(1,1)
      tauresample(nlinemod)=tau(nlinemod,1)
      do file=2,nfile
         if (tauresample(1).lt.tau(1,file)) then
            tauresample(1)=tau(1,file)
          end if
         if (tauresample(nlinemod).gt.tau(nlinemod,file)) then
            tauresample(nlinemod)=tau(nlinemod,file)
         end if
      end do
      call blend_i_0d1 ( tauresample, nlinemod )
      end

!*******************************************************************************

      subroutine blend_i_0d1 ( x, m )
!
!
!! BLEND_I_0D1 extends indexed scalar data at endpoints along a line.
!http://orion.math.iastate.edu/burkardt/f_src/f_src.html
!
!  Diagram:
!
!    ( X1, ..., ..., ..., ..., ..., XM )
!
!  Reference:
!
!    William Gordon,
!    Blending-Function Methods of Bivariate and Multivariate Interpolation
!      and Approximation,
!    SIAM Journal on Numerical Analysis,
!    Volume 8, Number 1, March 1971, pages 158-177.
!
!    William Gordon and Charles Hall,
!    Transfinite Element Methods: Blending-Function Interpolation over
!      Arbitrary Curved Element Domains,
!    Numerische Mathematik,
!    Volume 21, Number 1, 1973, pages 109-129.
!
!    William Gordon and Charles Hall,
!    Construction of Curvilinear Coordinate Systems and Application to
!      Mesh Generation,
!    International Journal of Numerical Methods in Engineering,
!    Volume 7, 1973, pages 461-477.
!
!    Joe Thompson, Bharat Soni, Nigel Weatherill,
!    Handbook of Grid Generation,
!    CRC Press, 1999.
!
!  Modified:
!
!    15 December 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real X(M).
!
!    On input, X(1) and X(M) contain scalar values which are to be
!    interpolated through the entries X(2) through X(M).  It is assumed
!    that the dependence of the data is linear in the vector index I.
!
!    On output, X(2) through X(M-1) have been assigned interpolated
!    values.
!
!    Input, integer M, the number of entries in X.

      implicit none
!
      integer m
!
      integer i
      real r
      real x(m)
!
      do i = 2, m - 1

        r = real ( i - 1 ) / real ( m - 1 )

        call blend_101 ( r, x(1), x(m), x(i) )

      end do

      return
      end

!*******************************************************************************

      subroutine blend_101 ( r, x0, x1, x )
!
!
!! BLEND_101 extends scalar endpoint data to a line.
!http://orion.math.iastate.edu/burkardt/f_src/f_src.html
!
!  Diagram:
!
!    0-----r-----1
!
!  Reference:
!
!    William Gordon,
!    Blending-Function Methods of Bivariate and Multivariate Interpolation
!      and Approximation,
!    SIAM Journal on Numerical Analysis,
!    Volume 8, Number 1, March 1971, pages 158-177.
!
!    William Gordon and Charles Hall,
!    Transfinite Element Methods: Blending-Function Interpolation over
!      Arbitrary Curved Element Domains,
!    Numerische Mathematik,
!    Volume 21, Number 1, 1973, pages 109-129.
!
!    William Gordon and Charles Hall,
!    Construction of Curvilinear Coordinate Systems and Application to
!      Mesh Generation,
!    International Journal of Numerical Methods in Engineering,
!    Volume 7, 1973, pages 461-477.
!
!    Joe Thompson, Bharat Soni, Nigel Weatherill,
!    Handbook of Grid Generation,
!    CRC Press, 1999.
!
!  Modified:
!
!    14 December 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real R, the coordinate where an interpolated value is desired.
!
!    Input, real X0, X1, the data values at the ends of the line.
!
!    Output, real X, the interpolated data value at (R).
!
      implicit none
!
      real r
      real x
      real x0
      real x1
!
      x = ( 1.0E+00 - r ) * x0 + r * x1

      return
      end

c*******************************************************************************

      subroutine calcrhox(tau,kappa,ndepth,rhox)
c     2 ways to calculate rhox : int(ro*dx) or int(1/kappa*dtau)
c      A&A 387, 595-604 (2002)
      implicit none
      integer :: i,ndepth
      real :: first
      real, dimension(ndepth) :: tau,kappa,rhox,f,x
      real :: tot
      real, external :: rinteg

      f=(1/10**kappa)
      x=10**(tau)
      first = x(1)*f(1)
      tot=rinteg(x,f,rhox,ndepth,first)
      do i=2,ndepth
           rhox(i) = rhox(i-1) + rhox(i)
      enddo
      end

      real function rinteg(x,f,fint,n,start)
c******************************************************************************
c     This routine is from ATLAS6
c******************************************************************************
      implicit none
      integer :: n,i,n1
      real x(5000), f(5000), fint(5000)
      real a(5000), b(5000), c(5000)
      real :: start

      call parcoe (f,x,a,b,c,n)
      fint(1) = start
      rinteg = start
      n1 = n - 1
      do 10 i=1,n1
         fint(i+1)= (a(i)+b(i)/2.*(x(i+1)+x(i))+
     .     c(i)/3.*((x(i+1)+x(i))*x(i+1)+x(i)*x(i)))*(x(i+1)-x(i))
10    rinteg = rinteg + fint(i+1)

      return
      end

c******************************************************************************

      subroutine parcoe(f,x,a,b,c,n)

      implicit none
      integer :: n,n1,j,j1
      real f(5000), x(5000), a(5000), b(5000), c(5000)
      real :: d,wt

      c(1)=0.
      b(1)=(f(2)-f(1))/(x(2)-x(1))
      a(1)=f(1)-x(1)*b(1)
      n1=n-1
      c(n)=0.
      b(n)=(f(n)-f(n1))/(x(n)-x(n1))
      a(n)=f(n)-x(n)*b(n)
      if(n.eq.2)return
      do 1 j=2,n1
      j1=j-1
      d=(f(j)-f(j1))/(x(j)-x(j1))
      c(j)=f(j+1)/((x(j+1)-x(j))*(x(j+1)-x(j1)))-f(j)/((x(j)-x(j1))*
     1(x(j+1)-x(j)))+f(j1)/((x(j)-x(j1))*(x(j+1)-x(j1)))
      b(j)=d-(x(j)+x(j1))*c(j)
    1 a(j)=f(j1)-x(j1)*d+x(j)*x(j1)*c(j)
      c(2)=0.
      b(2)=(f(3)-f(2))/(x(3)-x(2))
      a(2)=f(2)-x(2)*b(2)
      c(3)=0.
      b(3)=(f(4)-f(3))/(x(4)-x(3))
      a(3)=f(3)-x(3)*b(3)
      if(c(j).eq.0.)go to 2
      j1=j+1
      wt=abs(c(j1))/(abs(c(j1))+abs(c(j)))
      a(j)=a(j1)+wt*(a(j)-a(j1))
      b(j)=b(j1)+wt*(b(j)-b(j1))
      c(j)=c(j1)+wt*(c(j)-c(j1))
    2 continue
      a(n1)=a(n)
      b(n1)=b(n)
      c(n1)=c(n)
      return
      end

***********************************************************************************
      subroutine calc_error(xinf,xsup,yinf,ysup,zinf,zsup,teff_ref,
     &   logg_ref,z_ref)
      implicit none
      real :: xinf,xsup,yinf,ysup,zinf,zsup,teff_ref,logg_ref,z_ref
      real ::  error_T,error_Pe,error_Pg,error_kappa
      real :: errorTeffT,errorloggT,errorzT,
     &        errorTeffPe,errorloggPe,errorzPe,
     &         errorTeffPg,errorloggPg,errorzPg,
     &         errorTeffkappa,errorloggkappa,errorzkappa

! values read out of the figures of the manual and scaled down o the according step
              errorTeffT=0.055/32
              errorloggT=0.008/5
              errorzT=0.015/4
              errorTeffPe=0.65/32
              errorloggPe=0.4/5
              errorzPe=0.38/4
              errorTeffPg=0.25/32
              errorloggPg=0.23/5
              errorzPg=0.35/4
              errorTeffkappa=0.8/32
              errorloggkappa=0.36/5
              errorzkappa=0.38/4

      error_T=min((xsup-teff_ref),(teff_ref-xinf))/100*errorTeffT +
     &         min((ysup-logg_ref),(logg_ref-yinf))*errorloggT +
     &         min((zsup-z_ref),(z_ref-zinf))*errorzT
      write(*,1409) 'estimated max error on T =',error_T*100,'%'

      error_Pe=min((xsup-teff_ref),(teff_ref-xinf))/100*errorTeffPe +
     &         min((ysup-logg_ref),(logg_ref-yinf))*errorloggPe +
     &         min((zsup-z_ref),(z_ref-zinf))*errorzPe
       write(*,1409) 'estimated max error on Pe =',error_Pe*100,'%'

      error_Pg=min((xsup-teff_ref),(teff_ref-xinf))/100*errorTeffPg +
     &         min((ysup-logg_ref),(logg_ref-yinf))*errorloggPg +
     &         min((zsup-z_ref),(z_ref-zinf))*errorzPg
       write(*,1409) 'estimated max error on Pg =',error_Pg*100,'%'

      error_kappa=min((xsup-teff_ref),(teff_ref-xinf))/100
     &                                                *errorTeffkappa +
     &         min((ysup-logg_ref),(logg_ref-yinf))*errorloggkappa +
     &         min((zsup-z_ref),(z_ref-zinf))*errorzkappa
      write(*,1409) 'estimated max error on kappa =',error_kappa*100,'%'

 1409 format(a30,f5.1,a2)
      end

c*******************************************************************************

      REAL FUNCTION SevalSingle(u,x,y,n)

      REAL,INTENT(IN) :: u
      REAL,INTENT(IN),DIMENSION(:) :: x
      REAL,INTENT(IN),DIMENSION(:) :: y
      integer, intent(in) :: n

! for f2py wrapping output arguments cannot be of assumed SIZE or allocatable

c      REAL,DIMENSION(:),allocatable :: b,c,d
      real, dimension(n) :: b,c,d

      INTEGER, SAVE :: i=1
      INTEGER :: j, k
      REAL:: dx

c      INTERFACE
c       subroutine FMMsplineSingle(x, y, b, c, d, n)
c          REAL,INTENT(IN),DIMENSION(:) :: x
c          REAL,INTENT(IN),DIMENSION(:) :: y
c          integer, intent(in) :: n
c          REAL,INTENT(OUT),DIMENSION(:) :: b,c,d
c          real, intent(out), dimension(n) :: b,c,d
c        end subroutine FMMsplineSingle
c      END INTERFACE

c      n=SIZE(x)
c      allocate(b(n),c(n),d(n))
      call FMMsplineSingle(x, y, b, c, d, n)

      IF (  (i<1) .OR. (i >= n) ) i=1
      IF ( (u < x(i))  .OR.  (u >= x(i+1)) ) THEN
          i=1   ! binary search
          j=n+1

          DO
            k=(i+j)/2
            IF (u < x(k)) THEN
              j=k
            ELSE
              i=k
            END IF
            IF (j <= i+1) EXIT
          END DO
      END IF

      dx=u-x(i)   ! evaluate the spline
      SevalSingle=y(i)+dx*(b(i)+dx*(c(i)+dx*d(i)))

      RETURN
c      deallocate(b,c,d)
      END Function SevalSingle

c*******************************************************************************

      subroutine FMMsplineSingle(x, y, b, c, d, n)

c      REAL,DIMENSION(:), INTENT(IN)  :: x
c      REAL,DIMENSION(:), INTENT(IN)  :: y
c      REAL,DIMENSION(:), INTENT(OUT) :: b,c,d

      integer :: n
      real, dimension(n) :: x,y
      real, dimension(n) :: b,c,d

      REAL:: t,aux
      INTEGER:: k
      REAL,PARAMETER:: ZERO=0.0, TWO=2.0, THREE=3.0

c      n=SIZE(x)

       IF (n < 3) THEN
         b(1)=ZERO
         IF (n == 2) b(1)=(y(2)-y(1))/(x(2)-x(1))
         c(1)=ZERO
         d(1)=ZERO
         IF (n < 2) RETURN
         b(2)=b(1)
         c(2)=ZERO
         d(2)=ZERO
         RETURN
       END IF

        d(1)=x(2)-x(1)
        c(2)=(y(2)-y(1))/d(1)
       DO k=2,n-1
         d(k)=x(k+1)-x(k)
         b(k)=TWO*(d(k-1)+d(k))
         c(k+1)=(y(k+1)-y(k))/d(k)
         c(k)=c(k+1)-c(k)
       END DO

       b(1)=-d(1)
       b(n)=-d(n-1)
       c(1)=ZERO
       c(n)=ZERO
       IF (n > 3) THEN
         c(1)=c(3)/(x(4)-x(2))-c(2)/(x(3)-x(1))
         c(n)=c(n-1)/(x(n)-x(n-2))-c(n-2)/(x(n-1)-x(n-3))
         c(1)=c(1)*d(1)*d(1)/(x(4)-x(1))
         c(n)=-c(n)*d(n-1)*d(n-1)/(x(n)-x(n-3))
       END IF

       DO k=2,n
         t=d(k-1)/b(k-1)
         b(k)=b(k)-t*d(k-1)
         c(k)=c(k)-t*c(k-1)
       END DO

       c(n)=c(n)/b(n)
       DO k=n-1,1,-1
         c(k)=(c(k)-d(k)*c(k+1))/b(k)
       END DO

       b(n)=(y(n)-y(n-1))/d(n-1)+d(n-1)*(c(n-1)+c(n)+c(n))
       DO k=1,n-1
         b(k)=(y(k+1)-y(k))/d(k)-d(k)*(c(k+1)+c(k)+c(k))
         d(k)=(c(k+1)-c(k))/d(k)
         c(k)=THREE*c(k)
       END DO
       c(n)=THREE*c(n)
       d(n)=d(n-1)

       RETURN
       end subroutine FMMsplineSingle

c---------------------------------------------------------------------------------

      subroutine resample(taus,tauR,T,Pe,Pg,xit,rr,xkapref)
      implicit  none
      integer :: nlinemod,file,nfile,k,i
      real,dimension(:,:) :: taus,tauR,T,Pe,Pg,xit,rr,xkapref
      real,dimension(:,:),allocatable :: taubas
      real,dimension(:),allocatable :: tauresample,taustemp,tauRtemp,
     & Ttemp,Petemp,Pgtemp,xittemp,rrtemp,xkapreftemp

      INTERFACE
      function SevalSingle(u,x,y,n)
      REAL,INTENT(IN) :: u
      REAL,INTENT(IN),DIMENSION(:) :: x
      REAL,INTENT(IN),DIMENSION(:):: y
      integer, intent(in) :: n
      real SevalSingle
      end
      END INTERFACE

      nlinemod=size(taus,1)
      nfile=size(taus,2)-3

      allocate(tauresample(nlinemod),taustemp(nlinemod),
     &  tauRtemp(nlinemod),Ttemp(nlinemod)
     & ,Petemp(nlinemod),Pgtemp(nlinemod),xittemp(nlinemod),
     & rrtemp(nlinemod),xkapreftemp(nlinemod),
     &   taubas(nlinemod,size(taus,2)))

      taubas=tauR
      write(*,*) 'resample models on common depth basis: tauRoss'

      call common_depth_basis(tauresample,taubas,nlinemod,nfile)
c now do the resampling with the common tau
       do file=1,nfile
         do k=1,nlinemod

       taustemp(k)=SevalSingle(tauresample(k),taubas(:,file),
     &             taus(:,file), size(taubas(:,file)))

       tauRtemp(k)=SevalSingle(tauresample(k),taubas(:,file),
     &             tauR(:,file), size(taubas(:,file)))
       Ttemp(k)=SevalSingle(tauresample(k),taubas(:,file),T(:,file),
     &                      size(taubas(:,file)))
       Petemp(k)=SevalSingle(tauresample(k),taubas(:,file),Pe(:,file),
     &                      size(taubas(:,file)))
       Pgtemp(k)=SevalSingle(tauresample(k),taubas(:,file),Pg(:,file),
     &                      size(taubas(:,file)))
       xittemp(k)=SevalSingle(tauresample(k),taubas(:,file),xit(:,file),
     &                      size(taubas(:,file)))
       rrtemp(k)=SevalSingle(tauresample(k),taubas(:,file),rr(:,file),
     &                      size(taubas(:,file)))
       xkapreftemp(k)=SevalSingle(tauresample(k),taubas(:,file),
     &                 xkapref(:,file), size(taubas(:,file)))
         end do

         taus(:,file)=taustemp
         tauR(:,file)=tauRtemp
         T(:,file)=Ttemp
         Pe(:,file)=Petemp
         Pg(:,file)=Pgtemp
         xit(:,file)=xittemp
         rr(:,file)=rrtemp
         xkapref(:,file)=xkapreftemp
       end do

       deallocate(tauresample,taustemp,tauRtemp,Ttemp,Petemp
     &,Pgtemp,xittemp,rrtemp,xkapreftemp,taubas)

       end


!>@brief The module 'pln2eo_a_stochy_mod' contains the subroutine pln2eo_a_stochy
      module pln2eo_a_stochy_mod

      implicit none

      contains

!>@brief The subroutine 'pln2eo_a_stochy' calculates the assoicate legendre polynomials
!>@details This code is taken from the legacy spectral GFS
      subroutine pln2eo_a_stochy(plnev_a,plnod_a,epse,epso,
     &                    ls_node,num_lat)
!
! use x-number method to archieve accuracy due to recursive to avoid
! underflow and overflow if necessary by henry juang 2012 july
!
      use spectral_layout_mod
      use kinddef
      implicit none
!
! define x number constant for real8 start
      integer,  parameter :: in_f = 960 , in_h = in_f/2
      real(kind=kind_dbl_prec), parameter :: bb_f = 2.d0 ** ( in_f )
      real(kind=kind_dbl_prec), parameter :: bs_f = 2.d0 ** (-in_f )
      real(kind=kind_dbl_prec), parameter :: bb_h = 2.d0 ** ( in_h )
      real(kind=kind_dbl_prec), parameter :: bs_h = 2.d0 ** (-in_h )
! define x number constant end

cc
      real(kind=kind_dbl_prec) plnev_a(len_trie_ls,latg2)
      real(kind=kind_dbl_prec) plnod_a(len_trio_ls,latg2)
cc
      real(kind=kind_dbl_prec)    epse(len_trie_ls)
      real(kind=kind_dbl_prec)    epso(len_trio_ls)
cc
cc
      integer                  ls_node(ls_dim,3)
cc
      integer                  num_lat
cc
!cmr  ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
!cmr  ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
!cmr  ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
cc
      integer                  l,lat,locl,max_l,n
cc
      integer                  indev
      integer                  indod
cc
! need index for alp to be x-number
      integer                  id, ialp1, ialp2, ialp3, iprod
      integer                  ialp10(0:jcap)
      real(kind=kind_dbl_prec) aa, bb, w

      real(kind=kind_dbl_prec) alp1,alp2,alp3
      real(kind=kind_dbl_prec) cos2,fl,prod,sinlat,coslat
cc
      real(kind=kind_dbl_prec) alp10(0:jcap)
cc
      real(kind=kind_dbl_prec) cons0,cons0p5,cons1,cons2,cons3    !constant
cc
cc
      integer                  indlsev,jbasev
      integer                  indlsod,jbasod
cc
      include 'function2'
cc
cc
      cons0=0.0d0       !constant
      cons0p5=0.5d0     !constant
      cons1=1.0d0       !constant
      cons2=2.0d0       !constant
      cons3=3.0d0       !constant
cc
cc
      max_l=-1
      do locl=1,ls_max_node
         max_l = max ( max_l, ls_node(locl,1) )
      enddo
cc
cc
      do lat=1,num_lat
cc
         sinlat = cos(colrad_a(lat))
         cos2=cons1-sinlat*sinlat           !constant
         coslat = sqrt(cos2)

! use x number for alp10
         alp10(0) = sqrt(0.5)
         ialp10(0) = 0

         do l=1,max_l
            fl = l
            prod=coslat*sqrt(cons1+cons1/(cons2*fl))
            iprod=0
            w = abs(prod)
            if( w.ge.bb_h ) then
              prod = prod * bs_f
              iprod = iprod + 1
            elseif( w.lt.bs_h ) then
              prod = prod * bb_f
              iprod = iprod - 1
            endif
            alp10(l)=alp10(l-1)*prod
            ialp10(l)=ialp10(l-1)+iprod
            w = abs(alp10(l))
            if( w.ge.bb_h ) then
              alp10(l) = alp10(l) * bs_f
              ialp10(l) = ialp10(l) + 1
            elseif( w.lt.bs_h ) then
              alp10(l) = alp10(l) * bb_f
              ialp10(l) = ialp10(l) - 1
            endif
         enddo
cc
         do locl=1,ls_max_node
                 l=ls_node(locl,1)
            jbasev=ls_node(locl,2)
            jbasod=ls_node(locl,3)
            n=l
            fl=l
! get m=normalized x number for alp1 start
            alp1=alp10(l)
            ialp1=ialp10(l)

            indev=indlsev(n  ,l)
            indod=indlsod(n+1,l)
! x2f       plnev_a(indev       ,lat)=alp1
! x2f start
            if( ialp1.eq.0 ) then
              plnev_a(indev     ,lat)=alp1
            elseif( ialp1.eq.-1 ) then
              plnev_a(indev     ,lat)=alp1 * bs_f
            elseif( ialp1.lt.-1 ) then
              plnev_a(indev     ,lat)=0.0
!!            plnev_a(indev     ,lat)=alp1 * bs_f * bs_f
            else
              plnev_a(indev     ,lat)=alp1 * bb_f
            endif
! x2f end

! xltime    alp2=sqrt(cons2*fl+cons3)*sinlat*alp1     !constant
! xltime start
            prod=sqrt(cons2*fl+cons3)*sinlat
            iprod=0
            w = abs(prod)
            if( w.ge.bb_h ) then
              prod = prod * bs_f
              iprod = iprod + 1
            elseif( w.lt.bs_h ) then
              prod = prod * bb_f
              iprod = iprod - 1
            endif
            alp2=alp1*prod
            ialp2 = ialp1 + iprod
! xltime end
! norm alp2 start
            w = abs(alp2)
            if( w.ge.bb_h ) then
              alp2 = alp2*bs_f
              ialp2 = ialp2 + 1
            elseif( w.lt.bs_h ) then
              alp2 = alp2*bb_f
              ialp2 = ialp2 - 1
            endif
! norm alp2 end

! x2f       plnod_a(indod         ,lat)=alp2
! x2f start
            if( ialp2.eq.0 ) then
              plnod_a(indod       ,lat)=alp2
            elseif( ialp2.eq.-1 ) then
              plnod_a(indod       ,lat)=alp2 * bs_f
            elseif( ialp2.lt.-1 ) then
              plnod_a(indod       ,lat)=0.0
!!            plnod_a(indod       ,lat)=alp2 * bs_f * bs_f
            else
              plnod_a(indod       ,lat)=alp2 * bb_f
            endif
! x2f end
cc
            do n=l+2,jcap+1
               if(mod(n+l,2).eq.0) then
                  indev=indev+1
! xlsum2 start
                  aa = sinlat / epse(indev)
                  bb = epso(indod) / epse(indev)
                  id = ialp2 - ialp1
                  if( id.eq.0 ) then
                    alp3 = aa*alp2 - bb*alp1
                    ialp3 = ialp1
                  elseif( id.eq.1 ) then
                    alp3 = aa*alp2 - bb*alp1*bs_f
                    ialp3 = ialp2
                  elseif( id.eq.-1 ) then
                    alp3 = aa*alp2*bs_f - bb*alp1
                    ialp3 = ialp1
                  elseif( id.gt.1 ) then
                    alp3 = aa*alp2
                    ialp3 = ialp2
                  else
                    alp3 = - bb*alp1
                    ialp3 = ialp1
                  endif
! xlsum2 end
! xnorm alp3 start
                  w = abs(alp3)
                  if( w.ge.bb_h ) then
                    alp3 = alp3*bs_f
                    ialp3 = ialp3 + 1
                  elseif( w.lt.bs_h ) then
                    alp3 = alp3*bb_f
                    ialp3 = ialp3 - 1
                  endif
! xnorm alp3 end

! x2f alp3 start
                  if( ialp3.eq.0 ) then
                    plnev_a(indev,lat)=alp3
                  elseif( ialp3.eq.-1 ) then
                    plnev_a(indev,lat)=alp3 * bs_f
                  elseif( ialp3.lt.-1 ) then
                    plnev_a(indev,lat)=0.0
                  else
                    plnev_a(indev,lat)=alp3 * bb_f
                  endif
! x2f alp3 end

               else
                  indod=indod+1

! xlsum2 start
                  aa = sinlat / epso(indod)
                  bb = epse(indev) / epso(indod)
                  id = ialp2 - ialp1
                  if( id.eq.0 ) then
                    alp3 = aa*alp2 - bb*alp1
                    ialp3 = ialp1
                  elseif( id.eq.1 ) then
                    alp3 = aa*alp2 - bb*alp1*bs_f
                    ialp3 = ialp2
                  elseif( id.eq.-1 ) then
                    alp3 = aa*alp2*bs_f - bb*alp1
                    ialp3 = ialp1
                  elseif( id.gt.1 ) then
                    alp3 = aa*alp2
                    ialp3 = ialp2
                  else
                    alp3 = - bb*alp1
                    ialp3 = ialp1
                  endif
! xlsum2 end
! xnorm alp3 start
                  w = abs(alp3)
                  if( w.ge.bb_h ) then
                    alp3 = alp3*bs_f
                    ialp3 = ialp3 + 1
                  elseif( w.lt.bs_h ) then
                    alp3 = alp3*bb_f
                    ialp3 = ialp3 - 1
                  endif
! xnorm alp3 end

! x2f alp3 start
                  if( ialp3.eq.0 ) then
                    plnod_a(indod,lat)=alp3
                  elseif( ialp3.eq.-1 ) then
                    plnod_a(indod,lat)=alp3 * bs_f
                  elseif( ialp3.lt.-1 ) then
                    plnod_a(indod,lat)=0.0
                  else
                    plnod_a(indod,lat)=alp3 * bb_f
                  endif
! x2f alp3 end
               endif
               alp1=alp2
               alp2=alp3
               ialp1 = ialp2
               ialp2 = ialp3
            enddo
cc
         enddo
cc
      enddo
cc
      return
      end

      end module pln2eo_a_stochy_mod


use mod_precision,only:rk => realkind
use mod_spectrum,only:spectrum_type
use mod_spectral_shapes,only:jonswap

type(spectrum_type) :: spec

! initialize a spectrum instance
spec = spectrum_type(fmin=0.04_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1000._rk)

! assign a JONSWAP-shape spectrum to the instance
spec = jonswap(spec % getFrequency(),wspd=10._rk,fetch=1e5_rk,grav=9.8_rk)

write(*,*)'Significant wave height [m]: ',spec % significantWaveHeight()
write(*,*)'       Mean wave period [s]: ',spec % meanPeriod()
write(*,*)'      Mean square slope [-]: ',spec % meanSquareSlope()
write(*,*)'         Stokes drift [m/s]: ',spec % stokesDrift([0._rk])

end


*> \brief  SGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGEEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
*                         LDVR, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOBVL, JOBVR
*       INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
*      $                   WI( * ), WORK( * ), WR( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGEEV computes for an N-by-N real nonsymmetric matrix A, the
*> eigenvalues and, optionally, the left and/or right eigenvectors.
*>
*> The right eigenvector v(j) of A satisfies
*>                  A * v(j) = lambda(j) * v(j)
*> where lambda(j) is its eigenvalue.
*> The left eigenvector u(j) of A satisfies
*>               u(j)**H * A = lambda(j) * u(j)**H
*> where u(j)**H denotes the conjugate-transpose of u(j).
*>
*> The computed eigenvectors are normalized to have Euclidean norm
*> equal to 1 and largest component real.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBVL
*> \verbatim
*>          JOBVL is CHARACTER*1
*>          = 'N': left eigenvectors of A are not computed;
*>          = 'V': left eigenvectors of A are computed.
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*>          JOBVR is CHARACTER*1
*>          = 'N': right eigenvectors of A are not computed;
*>          = 'V': right eigenvectors of A are computed.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the N-by-N matrix A.
*>          On exit, A has been overwritten.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] WR
*> \verbatim
*>          WR is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WI
*> \verbatim
*>          WI is REAL array, dimension (N)
*>          WR and WI contain the real and imaginary parts,
*>          respectively, of the computed eigenvalues.  Complex
*>          conjugate pairs of eigenvalues appear consecutively
*>          with the eigenvalue having the positive imaginary part
*>          first.
*> \endverbatim
*>
*> \param[out] VL
*> \verbatim
*>          VL is REAL array, dimension (LDVL,N)
*>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
*>          after another in the columns of VL, in the same order
*>          as their eigenvalues.
*>          If JOBVL = 'N', VL is not referenced.
*>          If the j-th eigenvalue is real, then u(j) = VL(:,j),
*>          the j-th column of VL.
*>          If the j-th and (j+1)-st eigenvalues form a complex
*>          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
*>          u(j+1) = VL(:,j) - i*VL(:,j+1).
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*>          LDVL is INTEGER
*>          The leading dimension of the array VL.  LDVL >= 1; if
*>          JOBVL = 'V', LDVL >= N.
*> \endverbatim
*>
*> \param[out] VR
*> \verbatim
*>          VR is REAL array, dimension (LDVR,N)
*>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
*>          after another in the columns of VR, in the same order
*>          as their eigenvalues.
*>          If JOBVR = 'N', VR is not referenced.
*>          If the j-th eigenvalue is real, then v(j) = VR(:,j),
*>          the j-th column of VR.
*>          If the j-th and (j+1)-st eigenvalues form a complex
*>          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
*>          v(j+1) = VR(:,j) - i*VR(:,j+1).
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*>          LDVR is INTEGER
*>          The leading dimension of the array VR.  LDVR >= 1; if
*>          JOBVR = 'V', LDVR >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.  LWORK >= max(1,3*N), and
*>          if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N.  For good
*>          performance, LWORK must generally be larger.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  if INFO = i, the QR algorithm failed to compute all the
*>                eigenvalues, and no eigenvectors have been computed;
*>                elements i+1:N of WR and WI contain eigenvalues which
*>                have converged.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup realGEeigen
*
*  =====================================================================
      SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
     $                  LDVR, WORK, LWORK, INFO )
*
*  -- LAPACK driver routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      CHARACTER          JOBVL, JOBVR
      INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   WI( * ), WORK( * ), WR( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
      CHARACTER          SIDE
      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
     $                   MAXWRK, MINWRK, NOUT
      REAL               ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
     $                   SN
*     ..
*     .. Local Arrays ..
      LOGICAL            SELECT( 1 )
      REAL               DUM( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
     $                   SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
     $                   XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV, ISAMAX
      REAL               SLAMCH, SLANGE, SLAPY2, SNRM2
      EXTERNAL           LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
     $                   SNRM2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      WANTVL = LSAME( JOBVL, 'V' )
      WANTVR = LSAME( JOBVR, 'V' )
      IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
         INFO = -9
      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
         INFO = -11
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of workspace needed at that point in the code,
*       as well as the preferred amount for good performance.
*       NB refers to the optimal block size for the immediately
*       following subroutine, as returned by ILAENV.
*       HSWORK refers to the workspace preferred by SHSEQR, as
*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
*       the worst case.)
*
      IF( INFO.EQ.0 ) THEN
         IF( N.EQ.0 ) THEN
            MINWRK = 1
            MAXWRK = 1
         ELSE
            MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
            IF( WANTVL ) THEN
               MINWRK = 4*N
               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
     $                       'SORGHR', ' ', N, 1, N, -1 ) )
               CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
     $                WORK, -1, INFO )
               HSWORK = WORK( 1 )
               MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
               MAXWRK = MAX( MAXWRK, 4*N )
            ELSE IF( WANTVR ) THEN
               MINWRK = 4*N
               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
     $                       'SORGHR', ' ', N, 1, N, -1 ) )
               CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
     $                WORK, -1, INFO )
               HSWORK = WORK( 1 )
               MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
               MAXWRK = MAX( MAXWRK, 4*N )
            ELSE
               MINWRK = 3*N
               CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR,
     $                WORK, -1, INFO )
               HSWORK = WORK( 1 )
               MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
            END IF
            MAXWRK = MAX( MAXWRK, MINWRK )
         END IF
         WORK( 1 ) = MAXWRK
*
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -13
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGEEV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Get machine constants
*
      EPS = SLAMCH( 'P' )
      SMLNUM = SLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL SLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA )
     $   CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
*     Balance the matrix
*     (Workspace: need N)
*
      IBAL = 1
      CALL SGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
*
*     Reduce to upper Hessenberg form
*     (Workspace: need 3*N, prefer 2*N+N*NB)
*
      ITAU = IBAL + N
      IWRK = ITAU + N
      CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
     $             LWORK-IWRK+1, IERR )
*
      IF( WANTVL ) THEN
*
*        Want left eigenvectors
*        Copy Householder vectors to VL
*
         SIDE = 'L'
         CALL SLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
*        Generate orthogonal matrix in VL
*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
         CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
     $                LWORK-IWRK+1, IERR )
*
*        Perform QR iteration, accumulating Schur vectors in VL
*        (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
         IWRK = ITAU
         CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
*
         IF( WANTVR ) THEN
*
*           Want left and right eigenvectors
*           Copy Schur vectors to VR
*
            SIDE = 'B'
            CALL SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
         END IF
*
      ELSE IF( WANTVR ) THEN
*
*        Want right eigenvectors
*        Copy Householder vectors to VR
*
         SIDE = 'R'
         CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
*        Generate orthogonal matrix in VR
*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
*
         CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
     $                LWORK-IWRK+1, IERR )
*
*        Perform QR iteration, accumulating Schur vectors in VR
*        (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
         IWRK = ITAU
         CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
*
      ELSE
*
*        Compute eigenvalues only
*        (Workspace: need N+1, prefer N+HSWORK (see comments) )
*
         IWRK = ITAU
         CALL SHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
      END IF
*
*     If INFO > 0 from SHSEQR, then quit
*
      IF( INFO.GT.0 )
     $   GO TO 50
*
      IF( WANTVL .OR. WANTVR ) THEN
*
*        Compute left and/or right eigenvectors
*        (Workspace: need 4*N)
*
         CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
     $                N, NOUT, WORK( IWRK ), IERR )
      END IF
*
      IF( WANTVL ) THEN
*
*        Undo balancing of left eigenvectors
*        (Workspace: need N)
*
         CALL SGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL,
     $                IERR )
*
*        Normalize left eigenvectors and make largest component real
*
         DO 20 I = 1, N
            IF( WI( I ).EQ.ZERO ) THEN
               SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
               CALL SSCAL( N, SCL, VL( 1, I ), 1 )
            ELSE IF( WI( I ).GT.ZERO ) THEN
               SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
     $               SNRM2( N, VL( 1, I+1 ), 1 ) )
               CALL SSCAL( N, SCL, VL( 1, I ), 1 )
               CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
               DO 10 K = 1, N
                  WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
   10          CONTINUE
               K = ISAMAX( N, WORK( IWRK ), 1 )
               CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
               CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
               VL( K, I+1 ) = ZERO
            END IF
   20    CONTINUE
      END IF
*
      IF( WANTVR ) THEN
*
*        Undo balancing of right eigenvectors
*        (Workspace: need N)
*
         CALL SGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR,
     $                IERR )
*
*        Normalize right eigenvectors and make largest component real
*
         DO 40 I = 1, N
            IF( WI( I ).EQ.ZERO ) THEN
               SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
               CALL SSCAL( N, SCL, VR( 1, I ), 1 )
            ELSE IF( WI( I ).GT.ZERO ) THEN
               SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
     $               SNRM2( N, VR( 1, I+1 ), 1 ) )
               CALL SSCAL( N, SCL, VR( 1, I ), 1 )
               CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
               DO 30 K = 1, N
                  WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
   30          CONTINUE
               K = ISAMAX( N, WORK( IWRK ), 1 )
               CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
               CALL SROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
               VR( K, I+1 ) = ZERO
            END IF
   40    CONTINUE
      END IF
*
*     Undo scaling if necessary
*
   50 CONTINUE
      IF( SCALEA ) THEN
         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
     $                MAX( N-INFO, 1 ), IERR )
         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
     $                MAX( N-INFO, 1 ), IERR )
         IF( INFO.GT.0 ) THEN
            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
     $                   IERR )
            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
     $                   IERR )
         END IF
      END IF
*
      WORK( 1 ) = MAXWRK
      RETURN
*
*     End of SGEEV
*
      END
c $Id$


!--------------------------------- Program Descriptions -----------------------------

! This module contains routines to perform radial distribution function calculations

! Date composed by Jingxiang Guo : 7/2/2020

module RDF
    use system
    use constants, only: pi
    implicit none
    private

    public :: build_homo_pair_distance_histogram, &
            & build_homo_pair_distance_histogram_in_chunk,&
            & normalize_histogram

contains

    subroutine build_homo_pair_distance_histogram(total_atoms,&
                                                 & cutoff,&
                                                 & num_bins,&
                                                 & XYZ,&
                                                 & L_xyz,&
                                                 & rdf_histogram) &
                                                 & bind(c,name="homo_pair_distance_histogram")
        implicit none

        ! Passed
        integer(c_int),intent(in) :: total_atoms,num_bins
        real(c_double),intent(in) :: cutoff
        real(c_float),intent(in),dimension(1:3,1:total_atoms) :: XYZ
        real(c_double),intent(in),dimension(1:3) :: L_xyz

        ! Local
        real(dp),dimension(1:size(L_xyz)) :: xyz_temp,xyz_separate
        integer :: i,j,bin_index
        real(dp) :: distance_sqr,distance,cutoff_sqr,r_interval

        ! Output
        real(c_double),intent(out),dimension(1:num_bins) :: rdf_histogram

        r_interval = cutoff/num_bins

        cutoff_sqr = cutoff*cutoff

        rdf_histogram = 0.0d0

        do i = 1, total_atoms-1

            xyz_temp = xyz(1:3,i)

            do j = i + 1,total_atoms

                ! compute the separation vector between i,j

                xyz_separate = xyz_temp - xyz(1:3,j)

                ! apply minimum image convention

                xyz_separate = xyz_separate - L_xyz*dnint(xyz_separate/L_xyz)

                ! sum of squared separation vector

                distance_sqr = xyz_separate(1)*xyz_separate(1) &
                           & + xyz_separate(2)*xyz_separate(2) &
                           & + xyz_separate(3)*xyz_separate(3)

                if (distance_sqr < cutoff_sqr ) then

                    bin_index = int(dsqrt(distance_sqr)/r_interval) + 1

                    rdf_histogram(bin_index)  =  rdf_histogram(bin_index) + 2

                end if

            end do

        end do

        end subroutine

    subroutine build_homo_pair_distance_histogram_in_chunk(total_atoms,&
                                                 & num_configs,&
                                                 & cutoff,&
                                                 & num_bins,&
                                                 & XYZ,&
                                                 & L_xyz,&
                                                 & rdf_histogram, &
                                                 & sum_volume)&
                                                 & bind(c,name="call_homo_pair_distance_histogram_in_chunk")
        implicit none

        ! Passed
        integer(c_int),intent(in) :: total_atoms,num_bins,num_configs
        real(c_double),intent(in) :: cutoff
        real(c_double),intent(in),dimension(1:3,1:total_atoms,1:num_configs) :: XYZ
        real(c_double),intent(in),dimension(1:3,1:num_configs) :: L_xyz

        ! Local
        real(dp),dimension(1:size(L_xyz)) :: xyz_temp,xyz_separate
        integer :: i,j,bin_index,iconfig
        real(dp) :: distance_sqr,distance,cutoff_sqr,r_interval
        real(dp),dimension(1:3) :: box

        ! Output
        real(c_double),intent(out),dimension(1:num_bins) :: rdf_histogram
        real(c_double),intent(out) :: sum_volume

        r_interval = cutoff/num_bins

        cutoff_sqr = cutoff*cutoff

        rdf_histogram = 0.0d0

        sum_volume = 0.0

        do iconfig = 1, num_configs

            box = L_xyz(:,iconfig)

            sum_volume = sum_volume + product(box)

            do i = 1, total_atoms-1

                xyz_temp = xyz(1:3,i,iconfig)

                do j = i + 1,total_atoms

                    ! compute the separation vector between i,j

                    xyz_separate = xyz_temp - xyz(1:3,j,iconfig)

                    ! apply minimum image convention

                    xyz_separate = xyz_separate - box*dnint(xyz_separate/box)

                    ! sum of squared separation vector

                    distance_sqr = xyz_separate(1)*xyz_separate(1) &
                               & + xyz_separate(2)*xyz_separate(2) &
                               & + xyz_separate(3)*xyz_separate(3)

                    if (distance_sqr < cutoff_sqr ) then

                        bin_index = int(dsqrt(distance_sqr)/r_interval) + 1

                        rdf_histogram(bin_index)  =  rdf_histogram(bin_index) + 2

                    end if

                end do

            end do

        end do

        end subroutine

    subroutine normalize_histogram(rdf_histogram, &
                                 & num_bins,&
                                 & cutoff,&
                                 & natoms,&
                                 & num_configs,&
                                 & bulk_density,&
                                 & gr) bind(c,name="call_normalize_histogram")
        implicit none

        ! Passed
        integer(c_int),intent(in) :: num_bins,natoms,num_configs
        real(c_double),intent(in),dimension(1:num_bins) :: rdf_histogram
        real(c_double),intent(in) :: cutoff,bulk_density

        ! Local
        real(dp) :: preconst,vshell_i,half_interval,upper_r,lower_r,center_r,r_interval
        integer :: i

        ! Output
        real(c_double),dimension(1:num_bins),intent(out) :: gr

        preconst = 4.0d0/3.0d0*pi

        half_interval = r_interval/2.0d0*natoms

        r_interval = cutoff/num_bins

        do i = 1,num_bins

            upper_r = i*r_interval

            lower_r = (i-1)*r_interval

            center_r = half_interval + r_interval*(i-1)

            vshell_i = preconst*( ( upper_r*upper_r*upper_r ) - (lower_r*lower_r*lower_r) )

            gr(i) = rdf_histogram(i)/( vshell_i*bulk_density*natoms*num_configs)

        end do

        end subroutine

end module


      SUBROUTINE MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A,
     $                   LDA, E, LDE, Q, LDQ, Z, LDZ, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform the triangularization of the submatrices having full
C     row and column rank in the pencil s*E(eps,inf)-A(eps,inf) below
C
C                    | s*E(eps,inf)-A(eps,inf) |     X       |
C          s*E - A = |-------------------------|-------------| ,
C                    |            0            | s*E(r)-A(r) |
C
C     using Algorithm 3.3.1 in [1].
C     On entry, it is assumed that the M-by-N matrices A and E have
C     been transformed to generalized Schur form by unitary
C     transformations (see Algorithm 3.2.1 in [1]), and that the pencil
C     s*E(eps,inf)-A(eps,inf) is in staircase form.
C     This pencil contains all Kronecker column indices and infinite
C     elementary divisors of the pencil s*E - A.
C     The pencil s*E(r)-A(r) contains all Kronecker row indices and
C     finite elementary divisors of s*E - A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATQ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Q the orthogonal row transformations, as follows:
C             = .FALSE.: Do not form Q;
C             = .TRUE.:  The given matrix Q is updated by the orthogonal
C                        row transformations used in the reduction.
C
C     UPDATZ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal column transformations, as
C             follows:
C             = .FALSE.: Do not form Z;
C             = .TRUE.:  The given matrix Z is updated by the orthogonal
C                        column transformations used in the reduction.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             Number of rows in A and E.  M >= 0.
C
C     N       (input) INTEGER
C             Number of columns in A and E.  N >= 0.
C
C     NBLCKS  (input) INTEGER
C             Number of submatrices having full row rank (possibly zero)
C             in A(eps,inf).
C
C     INUK    (input) INTEGER array, dimension (NBLCKS)
C             The row dimensions nu(k) (k=1, 2, ..., NBLCKS) of the
C             submatrices having full row rank in the pencil
C             s*E(eps,inf)-A(eps,inf).
C
C     IMUK    (input) INTEGER array, dimension (NBLCKS)
C             The column dimensions mu(k) (k=1, 2, ..., NBLCKS) of the
C             submatrices having full column rank in the pencil.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, this array contains the matrix A to be reduced.
C             On exit, it contains the transformed matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, this array contains the matrix E to be reduced.
C             On exit, it contains the transformed matrix E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,M).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
C             On entry, if UPDATQ = .TRUE., then the leading M-by-M
C             part of this array must contain a given matrix Q (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading M-by-M part of this array contains the
C             product of the input matrix Q and the row transformation
C             matrix that has transformed the rows of the matrices A
C             and E.
C             If UPDATQ = .FALSE., the array Q is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDQ = 1 and declare this array to be Q(1,1) in the calling
C             program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q. If UPDATQ = .TRUE.,
C             LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             On entry, if UPDATZ = .TRUE., then the leading N-by-N
C             part of this array must contain a given matrix Z (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading N-by-N part of this array contains the
C             product of the input matrix Z and the column
C             transformation matrix that has transformed the columns of
C             the matrices A and E.
C             If UPDATZ = .FALSE., the array Z is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDZ = 1 and declare this array to be Z(1,1) in the calling
C             program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If UPDATZ = .TRUE.,
C             LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if incorrect dimensions of a full column rank
C                   submatrix;
C             = 2:  if incorrect dimensions of a full row rank
C                   submatrix.
C
C     REFERENCES
C
C     [1] Beelen, Th.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology,
C         The Netherlands, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB04FY by Th.G.J. Beelen,
C     Philips Glass Eindhoven, Holland.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, orthogonal transformation,
C     staircase form.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      LOGICAL           UPDATQ, UPDATZ
      INTEGER           INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKS
C     .. Array Arguments ..
      INTEGER           IMUK(*), INUK(*)
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      INTEGER           IFICA, IFICE, IFIRE, ISMUK, ISNUK1, K, MUK,
     $                  MUKP1, NUK
C     .. External Subroutines ..
      EXTERNAL          MB04TV, MB04TW
C     .. Executable Statements ..
C
      INFO = 0
      IF ( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
C     ISMUK  = sum(i=1,...,k) MU(i),
C     ISNUK1 = sum(i=1,...,k-1) NU(i).
C
      ISMUK = 0
      ISNUK1 = 0
C
      DO 20 K = 1, NBLCKS
         ISMUK  = ISMUK  + IMUK(K)
         ISNUK1 = ISNUK1 + INUK(K)
   20 CONTINUE
C
C     Note:  ISNUK1 has not yet the correct value.
C
      MUKP1 = 0
C
      DO 40 K = NBLCKS, 1, -1
         MUK = IMUK(K)
         NUK = INUK(K)
         ISNUK1 = ISNUK1 - NUK
C
C        Determine left upper absolute co-ordinates of E(k) in E-matrix
C        and of A(k) in A-matrix.
C
         IFIRE = 1 + ISNUK1
         IFICE = 1 + ISMUK
         IFICA = IFICE - MUK
C
C        Reduce E(k) to upper triangular form using Givens
C        transformations on rows only. Apply the same transformations
C        to the rows of A(k).
C
         IF ( MUKP1.GT.NUK ) THEN
            INFO = 1
            RETURN
         END IF
C
         CALL MB04TW( UPDATQ, M, N, NUK, MUKP1, IFIRE, IFICE, IFICA, A,
     $                LDA, E, LDE, Q, LDQ )
C
C        Reduce A(k) to upper triangular form using Givens
C        transformations on columns only. Apply the same transformations
C        to the columns in the E-matrix.
C
         IF ( NUK.GT.MUK ) THEN
            INFO = 2
            RETURN
         END IF
C
         CALL MB04TV( UPDATZ, N, NUK, MUK, IFIRE, IFICA, A, LDA, E, LDE,
     $                Z, LDZ )
C
         ISMUK = ISMUK - MUK
         MUKP1 = MUK
   40 CONTINUE
C
      RETURN
C *** Last line of MB04TY ***
      END


subroutine interp_driver (nxi, nyi, nzi, numxi, xposi, yposi, zposi, xiziyi, &
                          nxo, nyo, nzo, numxo, xposo, yposo, zposo, xozoyo)
!-----------------------------------------------------------------------
!
! Driver code for linear interpolation
!
!-----------------------------------------------------------------------
  use precision, only: r8

  implicit none
!
! Arguments
!
  integer, intent(in) :: nxi, nyi, nzi            ! dimensions of input grid
  integer, intent(in) :: numxi(nyi)               ! number of x points per y
  real(r8), intent(in) :: xposi(nxi,nyi)          ! x-positions of input grid
  real(r8), intent(in) :: yposi(nyi)              ! y-positions of input grid
  real(r8), intent(in) :: zposi(nzi)              ! z-positions of input grid
  real(r8), intent(in) :: xiziyi(nxi,nzi,nyi)     ! field to be interpolated

  integer, intent(in) :: nxo, nyo, nzo            ! dimensions of output grid
  integer, intent(in) :: numxo(nyo)               ! number of x points per y
  real(r8), intent(in) :: xposo(nxo,nyo)          ! x-positions of output grid
  real(r8), intent(in) :: yposo(nyo)              ! y-positions of output grid
  real(r8), intent(in) :: zposo(nzo)              ! z-positions of output grid
  real(r8), intent(out) :: xozoyo(nxo,nzo,nyo)    ! output field
!
! Local workspace
!
  integer :: i,j,k             ! spatial indices
  integer :: numxis, numxin    ! number of xpoints input to the south, north
  integer :: numxoj            ! numxo(j)
  integer :: jj, jjs, jjn      ! index in y-direction
  integer :: count             ! number of values found

  real(r8) :: wgts, wgtn       ! interpolation weights
!
! Intermediate interpolation arrays
!
  real(r8) :: xizoyi(nxi,nzo,nyi)
  real(r8) :: xtemp(nxo,2)
!
! Interpolate in z
!
  if (nzi == 1 .and. nzo == 1) then
    xizoyi(:,1,:) = xiziyi(:,1,:)
  else
    do j=1,nyi
      do i=1,nxi
        call lininterp (xiziyi(i,1,j), nzi, nxi, zposi, &
                        xizoyi(i,1,j), nzo, nxi, zposo, .false.)
      end do
    end do
  end if
!
! Check monotonicity of y-coordinate variable before interpolating.  z and
! x monotonicity is checked inside lininterp.
!
  count = 0
  do j=1,nyi-1
    if (yposi(j) > yposi(j+1)) count = count + 1
  end do
  do j=1,nyo-1
    if (yposo(j) > yposo(j+1)) count = count + 1
  end do

  if (count > 0) then
    call err_exit ('interp_driver: non-monotonic coordinate array(s) found')
  end if
!
! Interpolate in x and y
!
  do j=1,nyo
    numxoj = numxo(j)

    jjs = -1
    jjn = -1

    if (yposi(1) >= yposo(j)) then          ! extrapolate south
      jjs = 1
      jjn = 1
    else if (yposi(nyi) < yposo(j)) then    ! extrapolate north
      jjs = nyi
      jjn = nyi
    else                                    ! interpolate
      do jj=1,nyi-1
        if (yposi(jj  ) < yposo(j) .and. &
            yposi(jj+1) >= yposo(j)) then
          jjs = jj
          jjn = jj+1
          exit
        end if
      end do
    end if

    if (jjs < 0 .or. jjn < 0) then
      call err_exit ('interp_driver: bad index calculation')
    end if

    numxis = numxi(jjs)
    numxin = numxi(jjn)

    if (jjs /= jjn) then
      wgts = (yposi(jjn) - yposo(j)) / (yposi(jjn) - yposi(jjs))
      wgtn = (yposo(j) - yposi(jjs)) / (yposi(jjn) - yposi(jjs))
      if (abs ((wgts+wgtn)-1.) > 1.e-6) then
        call err_exit ('interp_driver: bad weight calculation')
      end if
    end if

    do k=1,nzo
!
! X interp
!
      call lininterp (xizoyi(1,k,jjs), numxis, 1, xposi(1,jjs), &
                      xtemp(1,1),      numxoj, 1, xposo(1,j), .true.)
      if (jjs == jjn) then
        xozoyo(:numxoj,k,j) = xtemp(:numxoj,1)
      else
        call lininterp (xizoyi(1,k,jjn), numxin, 1, xposi(1,jjn), &
                        xtemp(1,2),      numxoj, 1, xposo(1,j), .true.)
!
! Y interp
!
        xozoyo(:numxoj,k,j) = xtemp(:numxoj,1)*wgts + xtemp(:numxoj,2)*wgtn
      end if
    end do     ! k=1,nzo
  end do       ! j=1,nyo

  return
end subroutine interp_driver


*     FB01QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDK, LDQ, LDR, LDS
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDK = NMAX, LDQ = MMAX, LDR = PMAX,
     $                   LDS = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*(PMAX+NMAX)+2*PMAX,
     $                                 NMAX*(NMAX+MMAX+2), 3*PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, ISTEP, J, M, N, P
      CHARACTER*1      JOBK, MULTBQ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DIAG(PMAX), DWORK(LDWORK), K(LDK,PMAX),
     $                 Q(LDQ,MMAX), R(LDR,PMAX), S(LDS,NMAX)
      INTEGER          IWORK(PMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01QD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBK, TOL, MULTBQ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( S(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( LSAME( MULTBQ, 'N' ) ) READ ( NIN, FMT = *)
     $                               ( ( Q(I,J), J = 1,M ), I = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,P ), I = 1,P )
*              Save the strict lower triangle of R in its strict upper
*              triangle and the diagonal in the array DIAG.
               DO 10 I = 2, P
                  CALL DCOPY( I, R(I,1), LDR, R(1,I), 1 )
   10          CONTINUE
               CALL DCOPY( P, R, LDR+1, DIAG, 1 )
*              Perform three iterations of the (Kalman) filter recursion
*              (in square root covariance form).
               ISTEP = 1
   20          CONTINUE
                  CALL FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA,
     $                         B, LDB, Q, LDQ, C, LDC, R, LDR, K, LDK,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  ISTEP = ISTEP + 1
                  IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN
*                    Restore the lower triangle of R.
                     DO 30 I = 2, P
                        CALL DCOPY( I, R(1,I), 1, R(I,1), LDR )
   30                CONTINUE
                     CALL DCOPY( P, DIAG, 1, R, LDR+1 )
                     GO TO 20
                  END IF
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( S(I,J), J = 1,N )
   40             CONTINUE
                  IF ( LSAME( JOBK, 'K' ) ) THEN
                     WRITE ( NOUT, FMT = 99996 )
                     DO 60 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( K(I,J), J = 1,P )
   60                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01QD = ',I2)
99997 FORMAT (' The square root of the state covariance matrix is ')
99996 FORMAT (/' The Kalman gain matrix is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
      END


 module Propagation_m
 USE NumParameters_m
 USE Op_m

  SUBROUTINE TAYLOR()
   USE NumParameters_m
    USE Basis_m
   USE psi_m, ONLY : psi_t

    !TYPE(Besis_m):: Besis
    TYPE (psi_t)           :: psi, ans
    complex (kind=Rk)   :: vec(6),vec0(6)
    real(kind= Rk)      :: t(12)
    integer:: k, n, kk, Ntps  !(Ntps = nombre de points de grille temporelle)
    real (kind=Rk),parameter:: sigma, scaletps,PI,k0
          real(kind= Rk) :: Rkk,NN
      !allocate(vec(size(Besis%x),vec0(size(Besis%x))
             !allocate(t(N))
             k0 = ONE ;  sigma = FOURTH ; scaletps= ONETENTH; Ntps = 12

             ! scaletps = pas temporel
             ! sigma = largeur de la gaussienne
             !k0 = p0 vitesse initiale
                        !++++++++++++++++++++initialisation+++++++++++++

vec0(:) = (ONE/(PI*sigma*sigma)exp(-EYE*k0*Besis%x)
  vec0(:) vec0(:)*exp(-((Besis%x-ZERO)*(Besis%x-ZERO))/2*sigma*sigma)
     t(:) = (n-1)*scaletps
     ans(:) = vec0(:)
     psi(:) = ZERO
      kk = ONE
       Rkk = ONE

     Do n = 1,Ntps,1
        Do k = 1, 1000
     Rkk = ONE
      vec(:) = vec0(:)
          CALL  calc_OpPsi(Op,vec,vec)
       vec(:) = -EYE*vec(:)
        kk = kk+1 .AND. Rkk = Rkk*(scaletps/kk)
        ans(:) = ans(:) + Rkk*vec(:)
        NN= Rkk*scaleQ*sqrt(matmul(vec(:),transpose(vec(:))))
         IF(NN .lt. TEN**(-TEN ) ) then
             exit
          enddo
     ENDO

   END SUBROUTINE TAYLOR

   end module Propagation_m


subroutine solve_intratemporal(p2_fc,cts,h,l_i,u,l_fc,c)
    use structural_p1; use structural_p2
    implicit none
    real(SP),intent(in)::cts,l_i,p2_fc
    integer,intent(in)::h
    real(SP),intent(out)::u,l_fc,c
    real(SP)::l_fc_min,l_fc_max,l_fc_g,mu_c,mu_l_fc
    real(SP)::TINY=1.0e-3
    integer::it
    character::end_k

    l_fc_min=0.001_sp
    !Check corner at l_fc_min
    l_fc_g=l_fc_min
    c=cts
    mu_c=p2_fc*c**(-sigma)
    if (subs_p==0.0_sp) then
        mu_l_fc=mu(h)*share_p*l_fc_g**(share_p-1.0_sp)*l_i**(1.0_sp-share_p)* &
                (l_fc_g**share_p*l_i**(1.0_sp-share_p))**(-nu)
    else
        mu_l_fc=mu(h)*share_p*l_fc_g**(subs_p-1.0_sp)* &
                (share_p*l_fc_g**subs_p+(1.0_sp-share_p)*l_i**subs_p)**((1.0_sp-nu-subs_p)/subs_p)
    end if
    if (mu_c>mu_l_fc .or. mu(h)==0.0_sp) then
        go to 1
    end if

    !Look for the interior solution
    it=0
    l_fc_max=cts/p2_fc
2   l_fc_g=(l_fc_min+l_fc_max)/2.0_sp
    c=cts-p2_fc*l_fc_g
    mu_c=p2_fc*c**(-sigma)
    if (subs_p==0.0_sp) then
        mu_l_fc=mu(h)*share_p*l_fc_g**(share_p-1.0_sp)*l_i**(1.0_sp-share_p)* &
                (l_fc_g**share_p*l_i**(1.0_sp-share_p))**(-nu)
    else
        mu_l_fc=mu(h)*share_p*l_fc_g**(subs_p-1.0_sp)* &
                (share_p*l_fc_g**subs_p+(1.0_sp-share_p)*l_i**subs_p)**((1.0_sp-nu-subs_p)/subs_p)
    end if
    if (abs(mu_c-mu_l_fc)/mu_c>TINY .and. it<2000) then
        if (mu_c>mu_l_fc) then
            l_fc_max=l_fc_g
        else
            l_fc_min=l_fc_g
        end if
        it=it+1
        go to 2
    elseif (it==5000) then
        print*, 'intratemporal not converged',mu_c,mu_l_fc,l_fc_g,cts,l_fc_max,l_fc_min
        print*, 'intratemporal not converged',mu(h)*share_p*l_fc_g**(subs_p-1.0_sp)* &
            (share_p*l_fc_g**subs_p+(1.0_sp-share_p)*l_i**subs_p)**((1.0_sp-nu-subs_p)/subs_p)
        !read*,end_k
    end if
1   l_fc=l_fc_g

    if (mu(h)<=0.0_sp)then
        u=c**(1.0_sp-sigma)/(1.0_sp-sigma)
    else
        if (subs_p==0.0_sp) then
            u=c**(1.0_sp-sigma)/(1.0_sp-sigma)+mu(h)*(l_fc_g**share_p*l_i**(1.0_sp-share_p))**(1.0_sp-nu)/(1.0_sp-nu)
        else
            u=c**(1.0_sp-sigma)/(1.0_sp-sigma)+mu(h)*((share_p*l_fc_g**subs_p+(1.0_sp-share_p)*l_i**subs_p)**(1.0_sp/subs_p))**(1.0_sp-nu)/(1.0_sp-nu)
        end if
    end if

    if (isnan(u))then
        print*,'problem in intratemporal'
        print*,delta_h(h),c,sigma,mu(h),l_fc,omega*l_i,kappa_h(h),nu
        !read*,end_k
    end if
end subroutine


program nr_test

  use pix_tools
  use, intrinsic :: iso_c_binding
  use nr, only: gasdev
  use ran_state, only: ran_seed

  implicit none
  include 'fftw3.f03'
  real :: rand = 1.d0
  integer :: first, second, third

  double precision, dimension(0:3) :: a_coef = (/1.d0, 2.d0, 3.d0, 4.d0/)
  double precision, dimension(0:3) :: b_coef = (/3.d0, 2.d0, 1.d0, 5.d0/)
  complex, dimension(0:3) :: a_b

  type(C_PTR) :: plan
  complex(C_DOUBLE_COMPLEX), dimension(0:3) :: in, out

  plan = fftw_plan_dft_1d(4, in, out, FFTW_FORWARD, FFTW_ESTIMATE)

  in(0) = (0.d0, 2.d0)
  in(1) = (5.d0, 1.d0)
  in(2) = (0.d0, 0.d0)
  in(3) = (0.d0, 0.d0)

  write(unit=*, fmt=*) in

  call fftw_execute_dft(plan, in, out)

  write(unit=*, fmt=*) out

  call fftw_destroy_plan(plan)

  plan = fftw_plan_dft_1d(4, in, out, FFTW_BACKWARD, FFTW_ESTIMATE) ! FFTW_MEASURE

  call fftw_execute_dft(plan, out, in)

  write(unit=*, fmt=*) in / 4.d0

  call fftw_destroy_plan(plan)

  first = 1203124125
  second = 1234145
  third = first + second

  call ran_seed(third)
  call gasdev(rand)
  write(unit=*, fmt=*) rand
  call gasdev(rand)
  write(unit=*, fmt=*) rand

  write(unit=*, fmt=*)

  call ran_seed(first)
  call gasdev(rand)
  write(unit=*, fmt=*) rand

  call ran_seed(second)
  call gasdev(rand)
  write(unit=*, fmt=*) rand

  a_b = cmplx(a_coef, b_coef)

  write(unit=*, fmt=*) 'a_coef'
  write(unit=*, fmt=*) a_coef
  write(unit=*, fmt=*) 'b_coef'
  write(unit=*, fmt=*) b_coef
  write(unit=*, fmt=*) 'a_b'
  write(unit=*, fmt=*) a_b
  write(unit=*, fmt=*) 'real(a_b)'
  write(unit=*, fmt=*) real(a_b)
  write(unit=*, fmt=*) 'aimag(a_b)'
  write(unit=*, fmt=*) aimag(a_b)

end program nr_test


MODULE FUN_xyzDETERMINANT
!!#### PURPOSE
!! Calculates the determinant of a 3x3 matrix.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzDETERMINANT
 MODULE PROCEDURE xyzDETERMINANT_Rsp
 MODULE PROCEDURE xyzDETERMINANT_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzDETERMINANT

CONTAINS

FUNCTION xyzDETERMINANT_Rsp( M33 ) RESULT(d)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzDETERMINANT.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzDETERMINANT.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzDETERMINANT_Rdp( M33 ) RESULT(d)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzDETERMINANT.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzDETERMINANT.f90.bdy"
!!--end--
END FUNCTION

END MODULE


      integer function idmax(n,sx,incx)
c
c     ******************************************************************
c     *                                                                *
c     *   find the index of element having max value                   *
c     *                                                                *
c     ******************************************************************
c
      integer   i,incx,ix,n
c
c     *****************************************************************
c
      real      sx(n),smax
c
c     *****************************************************************
c
      idmax     = 0
      if (n.lt.1) return

      idmax     = 1
      if (n.eq.1) return

      if (incx.eq.1) go to 11
c
c      code for increment not equal to 1
c
      ix        = 1
      smax      = sx(1)
      ix        = ix + incx
      do i=2,n
         if (sx(ix).gt.smax) then
            idmax     = i
            smax      = sx(ix)
         end if
         ix        = ix + incx
      end do

      return
c
c      code for increment equal to 1
c
   11 smax = sx(1)
      do i=2,n
         if (sx(i).gt.smax)then
            idmax     = i
            smax      = sx(i)
         end if
      end do

      return

      end


	FUNCTION PR_WCCV ( wmoccv )
C************************************************************************
C* PR_WCCV								*
C*									*
C* This function converts WMO cloud cover fraction code to the decimal	*
C* cloud cover fraction.						*
C*									*
C* REAL PR_WCCV ( WMOCCV )						*
C*									*
C* Input parameters:							*
C*	WMOCCV		REAL		WMO cloud cover code		*
C*									*
C* Output parameters:							*
C*	PR_WCCV		REAL		Decimal cloud cover fraction	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/88						*
C* K. Brill/NMC		12/90	Documentation				*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		cover (10)
	INCLUDE		'ERMISS.FNC'
C*
	DATA		cover / 0., .1, .2, .4, .5, .6, .7, .9, 1., 1. /
C------------------------------------------------------------------------
	IF  ( ERMISS ( wmoccv ) ) THEN
	    PR_WCCV = RMISSD
	  ELSE IF ( ( wmoccv .ge. 0. ) .and. ( wmoccv .le. 9. ) ) THEN
	    iccv = NINT ( wmoccv ) + 1
	    PR_WCCV = cover ( iccv )
	  ELSE
	    PR_WCCV = RMISSD
	END IF
C*
	RETURN
	END


module NumType

	save
	integer, parameter :: dp = kind(1.d0)
	real(dp), parameter :: pi = 4*atan(1._dp)
	complex(dp), parameter :: iic = (0._dp,1._dp)

end module NumType