      subroutine fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,
     * ty,ny,p,c,nc,fp,fpx,fpy,mm,mynx,kx1,kx2,ky1,ky2,spx,spy,right,q,
     * ax,ay,bx,by,nrx,nry)
c  ..
c  ..scalar arguments..
      real*8 p,fp
      integer ifsx,ifsy,ifbx,ifby,mx,my,mz,kx,ky,nx,ny,nc,mm,mynx,
     * kx1,kx2,ky1,ky2
c  ..array arguments..
      real*8 x(mx),y(my),z(mz),tx(nx),ty(ny),c(nc),spx(mx,kx1),spy(my,ky
     *1)
     * ,right(mm),q(mynx),ax(nx,kx2),bx(nx,kx2),ay(ny,ky2),by(ny,ky2),
     * fpx(nx),fpy(ny)
      integer nrx(mx),nry(my)
c  ..local scalars..
      real*8 arg,cos,fac,pinv,piv,sin,term,one,half
      integer i,ibandx,ibandy,ic,iq,irot,it,iz,i1,i2,i3,j,k,k1,k2,l,
     * l1,l2,ncof,nk1x,nk1y,nrold,nroldx,nroldy,number,numx,numx1,
     * numy,numy1,n1
c  ..local arrays..
      real*8 h(7)
c  ..subroutine references..
c    fpback,fpbspl,fpgivs,fpdisc,fprota
c  ..
c  the b-spline coefficients of the smoothing spline are calculated as
c  the least-squares solution of the over-determined linear system of
c  equations  (ay) c (ax)' = q       where
c
c               |   (spx)    |            |   (spy)    |
c        (ax) = | ---------- |     (ay) = | ---------- |
c               | (1/p) (bx) |            | (1/p) (by) |
c
c                                | z  ' 0 |
c                            q = | ------ |
c                                | 0  ' 0 |
c
c  with c      : the (ny-ky-1) x (nx-kx-1) matrix which contains the
c                b-spline coefficients.
c       z      : the my x mx matrix which contains the function values.
c       spx,spy: the mx x (nx-kx-1) and  my x (ny-ky-1) observation
c                matrices according to the least-squares problems in
c                the x- and y-direction.
c       bx,by  : the (nx-2*kx-1) x (nx-kx-1) and (ny-2*ky-1) x (ny-ky-1)
c                matrices which contain the discontinuity jumps of the
c                derivatives of the b-splines in the x- and y-direction.
      one = 1
      half = 0.5
      nk1x = nx-kx1
      nk1y = ny-ky1
      if(p.gt.0.) pinv = one/p
c  it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on
c  the value of p whether the matrices (spx),(spy),(bx) and (by) still
c  must be determined.
      if(ifsx.ne.0) go to 50
c  calculate the non-zero elements of the matrix (spx) which is the
c  observation matrix according to the least-squares spline approximat-
c  ion problem in the x-direction.
      l = kx1
      l1 = kx2
      number = 0
      do 40 it=1,mx
        arg = x(it)
  10    if(arg.lt.tx(l1) .or. l.eq.nk1x) go to 20
        l = l1
        l1 = l+1
        number = number+1
        go to 10
  20    call fpbspl(tx,nx,kx,arg,l,h)
        do 30 i=1,kx1
          spx(it,i) = h(i)
  30    continue
        nrx(it) = number
  40  continue
      ifsx = 1
  50  if(ifsy.ne.0) go to 100
c  calculate the non-zero elements of the matrix (spy) which is the
c  observation matrix according to the least-squares spline approximat-
c  ion problem in the y-direction.
      l = ky1
      l1 = ky2
      number = 0
      do 90 it=1,my
        arg = y(it)
  60    if(arg.lt.ty(l1) .or. l.eq.nk1y) go to 70
        l = l1
        l1 = l+1
        number = number+1
        go to 60
  70    call fpbspl(ty,ny,ky,arg,l,h)
        do 80 i=1,ky1
          spy(it,i) = h(i)
  80    continue
        nry(it) = number
  90  continue
      ifsy = 1
 100  if(p.le.0.) go to 120
c  calculate the non-zero elements of the matrix (bx).
      if(ifbx.ne.0 .or. nx.eq.2*kx1) go to 110
      call fpdisc(tx,nx,kx2,bx,nx)
      ifbx = 1
c  calculate the non-zero elements of the matrix (by).
 110  if(ifby.ne.0 .or. ny.eq.2*ky1) go to 120
      call fpdisc(ty,ny,ky2,by,ny)
      ifby = 1
c  reduce the matrix (ax) to upper triangular form (rx) using givens
c  rotations. apply the same transformations to the rows of matrix q
c  to obtain the my x (nx-kx-1) matrix g.
c  store matrix (rx) into (ax) and g into q.
 120  l = my*nk1x
c  initialization.
      do 130 i=1,l
        q(i) = 0.
 130  continue
      do 140 i=1,nk1x
        do 140 j=1,kx2
          ax(i,j) = 0.
 140  continue
      l = 0
      nrold = 0
c  ibandx denotes the bandwidth of the matrices (ax) and (rx).
      ibandx = kx1
      do 270 it=1,mx
        number = nrx(it)
 150    if(nrold.eq.number) go to 180
        if(p.le.0.) go to 260
        ibandx = kx2
c  fetch a new row of matrix (bx).
        n1 = nrold+1
        do 160 j=1,kx2
          h(j) = bx(n1,j)*pinv
 160    continue
c  find the appropriate column of q.
        do 170 j=1,my
          right(j) = 0.
 170    continue
        irot = nrold
        go to 210
c  fetch a new row of matrix (spx).
 180    h(ibandx) = 0.
        do 190 j=1,kx1
          h(j) = spx(it,j)
 190    continue
c  find the appropriate column of q.
        do 200 j=1,my
          l = l+1
          right(j) = z(l)
 200    continue
        irot = number
c  rotate the new row of matrix (ax) into triangle.
 210    do 240 i=1,ibandx
          irot = irot+1
          piv = h(i)
          if(piv.eq.0.) go to 240
c  calculate the parameters of the givens transformation.
          call fpgivs(piv,ax(irot,1),cos,sin)
c  apply that transformation to the rows of matrix q.
          iq = (irot-1)*my
          do 220 j=1,my
            iq = iq+1
            call fprota(cos,sin,right(j),q(iq))
 220      continue
c  apply that transformation to the columns of (ax).
          if(i.eq.ibandx) go to 250
          i2 = 1
          i3 = i+1
          do 230 j=i3,ibandx
            i2 = i2+1
            call fprota(cos,sin,h(j),ax(irot,i2))
 230      continue
 240    continue
 250    if(nrold.eq.number) go to 270
 260    nrold = nrold+1
        go to 150
 270  continue
c  reduce the matrix (ay) to upper triangular form (ry) using givens
c  rotations. apply the same transformations to the columns of matrix g
c  to obtain the (ny-ky-1) x (nx-kx-1) matrix h.
c  store matrix (ry) into (ay) and h into c.
      ncof = nk1x*nk1y
c  initialization.
      do 280 i=1,ncof
        c(i) = 0.
 280  continue
      do 290 i=1,nk1y
        do 290 j=1,ky2
          ay(i,j) = 0.
 290  continue
      nrold = 0
c  ibandy denotes the bandwidth of the matrices (ay) and (ry).
      ibandy = ky1
      do 420 it=1,my
        number = nry(it)
 300    if(nrold.eq.number) go to 330
        if(p.le.0.) go to 410
        ibandy = ky2
c  fetch a new row of matrix (by).
        n1 = nrold+1
        do 310 j=1,ky2
          h(j) = by(n1,j)*pinv
 310    continue
c  find the appropiate row of g.
        do 320 j=1,nk1x
          right(j) = 0.
 320    continue
        irot = nrold
        go to 360
c  fetch a new row of matrix (spy)
 330    h(ibandy) = 0.
        do 340 j=1,ky1
          h(j) = spy(it,j)
 340    continue
c  find the appropiate row of g.
        l = it
        do 350 j=1,nk1x
          right(j) = q(l)
          l = l+my
 350    continue
        irot = number
c  rotate the new row of matrix (ay) into triangle.
 360    do 390 i=1,ibandy
          irot = irot+1
          piv = h(i)
          if(piv.eq.0.) go to 390
c  calculate the parameters of the givens transformation.
          call fpgivs(piv,ay(irot,1),cos,sin)
c  apply that transformation to the colums of matrix g.
          ic = irot
          do 370 j=1,nk1x
            call fprota(cos,sin,right(j),c(ic))
            ic = ic+nk1y
 370      continue
c  apply that transformation to the columns of matrix (ay).
          if(i.eq.ibandy) go to 400
          i2 = 1
          i3 = i+1
          do 380 j=i3,ibandy
            i2 = i2+1
            call fprota(cos,sin,h(j),ay(irot,i2))
 380      continue
 390    continue
 400    if(nrold.eq.number) go to 420
 410    nrold = nrold+1
        go to 300
 420  continue
c  backward substitution to obtain the b-spline coefficients as the
c  solution of the linear system    (ry) c (rx)' = h.
c  first step: solve the system  (ry) (c1) = h.
      k = 1
      do 450 i=1,nk1x
        call fpback(ay,c(k),nk1y,ibandy,c(k),ny)
        k = k+nk1y
 450  continue
c  second step: solve the system  c (rx)' = (c1).
      k = 0
      do 480 j=1,nk1y
        k = k+1
        l = k
        do 460 i=1,nk1x
          right(i) = c(l)
          l = l+nk1y
 460    continue
        call fpback(ax,right,nk1x,ibandx,right,nx)
        l = k
        do 470 i=1,nk1x
          c(l) = right(i)
          l = l+nk1y
 470    continue
 480  continue
c  calculate the quantities
c    res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my
c    fp = sumi=1,mx(sumj=1,my(res(i,j)))
c    fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1
c                  tx(r+kx) <= x(i) <= tx(r+kx+1)
c    fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1
c                  ty(r+ky) <= y(j) <= ty(r+ky+1)
      fp = 0.
      do 490 i=1,nx
        fpx(i) = 0.
 490  continue
      do 500 i=1,ny
        fpy(i) = 0.
 500  continue
      nk1y = ny-ky1
      iz = 0
      nroldx = 0
c  main loop for the different grid points.
      do 550 i1=1,mx
        numx = nrx(i1)
        numx1 = numx+1
        nroldy = 0
        do 540 i2=1,my
          numy = nry(i2)
          numy1 = numy+1
          iz = iz+1
c  evaluate s(x,y) at the current grid point by making the sum of the
c  cross products of the non-zero b-splines at (x,y), multiplied with
c  the appropiate b-spline coefficients.
          term = 0.
          k1 = numx*nk1y+numy
          do 520 l1=1,kx1
            k2 = k1
            fac = spx(i1,l1)
            do 510 l2=1,ky1
              k2 = k2+1
              term = term+fac*spy(i2,l2)*c(k2)
 510        continue
            k1 = k1+nk1y
 520      continue
c  calculate the squared residual at the current grid point.
          term = (z(iz)-term)**2
c  adjust the different parameters.
          fp = fp+term
          fpx(numx1) = fpx(numx1)+term
          fpy(numy1) = fpy(numy1)+term
          fac = term*half
          if(numy.eq.nroldy) go to 530
          fpy(numy1) = fpy(numy1)-fac
          fpy(numy) = fpy(numy)+fac
 530      nroldy = numy
          if(numx.eq.nroldx) go to 540
          fpx(numx1) = fpx(numx1)-fac
          fpx(numx) = fpx(numx)+fac
 540    continue
        nroldx = numx
 550  continue
      return
      end


C-------------------------------------------------------------------------
      SUBROUTINE SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX,
     &                    IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
     &                    NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI,
     &                    LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTRUNGV   SPECTRALLY INTERPOLATE VECTORS TO STATIONS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTORS FIELDS
C           ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS
C           TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE.
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
C           (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
C           THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING.
C           THE TRANSFORMS ARE ALL MULTIPROCESSED.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  OPENMP DIRECTIVES INSERTED
C
C USAGE:    CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX,
C    &                    IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP,
C    &                    NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI,
C    &                    LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     IDRTI    - INTEGER INPUT GRID IDENTIFIER
C                (IDRTI=4 FOR GAUSSIAN GRID,
C                 IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
C                 IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
C     IMAXI    - INTEGER EVEN NUMBER OF INPUT LONGITUDES.
C     JMAXI    - INTEGER NUMBER OF INPUT LATITUDES.
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     NMAX     - INTEGER NUMBER OF STATION POINTS TO RETURN
C     IPRIME   - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN.
C                (DEFAULTS TO 1 IF IPRIME=0)
C                (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.)
C     ISKIPI   - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES
C                (DEFAULTS TO 1 IF ISKIPI=0)
C     JSKIPI   - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH
C                (DEFAULTS TO -IMAXI IF JSKIPI=0)
C     KSKIPI   - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS
C                (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0)
C     KGSKIP   - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS
C                (DEFAULTS TO NMAX IF KGSKIP=0)
C     NRSKIP   - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS
C                (DEFAULTS TO 1 IF NRSKIP=0)
C     NGSKIP   - INTEGER SKIP NUMBER BETWEEN STATION POINTS
C                (DEFAULTS TO 1 IF NGSKIP=0)
C     RLAT     - REAL (*) STATION LATITUDES IN DEGREES
C     RLON     - REAL (*) STATION LONGITUDES IN DEGREES
C     JCPU     - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
C                (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0)
C     GRIDUI   - REAL (*) INPUT GRID U-WINDS
C     GRIDVI   - REAL (*) INPUT GRID V-WINDS
C     LUV      - LOGICAL FLAG WHETHER TO RETURN WINDS
C     LDZ      - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY
C     LPS      - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN
C   OUTPUT ARGUMENTS:
C     UP       - REAL (*) STATION U-WINDS IF LUV
C     VP       - REAL (*) STATION V-WINDS IF LUV
C     DP       - REAL (*) STATION DIVERGENCES IF LDZ
C     ZP       - REAL (*) STATION VORTICITIES IF LDZ
C     PP       - REAL (*) STATION POTENTIALS IF LPS
C     SP       - REAL (*) STATION STREAMFCNS IF LPS
C
C SUBPROGRAMS CALLED:
C   SPWGET       GET WAVE-SPACE CONSTANTS
C   SPLAPLAC     COMPUTE LAPLACIAN IN SPECTRAL SPACE
C   SPTRANV      PERFORM A VECTOR SPHERICAL TRANSFORM
C   SPTGPT       TRANSFORM SPECTRAL SCALAR TO STATION POINTS
C   SPTGPTV      TRANSFORM SPECTRAL VECTOR TO STATION POINTS
C   NCPUS        GETS ENVIRONMENT NUMBER OF CPUS
C
C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
C   DIMENSION                    LINEAR              QUADRATIC
C   -----------------------      ---------           -------------
C   IMAX                         2*MAXWV+2           3*MAXWV/2*2+2
C   JMAX (IDRT=4,IROMB=0)        1*MAXWV+1           3*MAXWV/2+1
C   JMAX (IDRT=4,IROMB=1)        2*MAXWV+1           5*MAXWV/2+1
C   JMAX (IDRT=0,IROMB=0)        2*MAXWV+3           3*MAXWV/2*2+3
C   JMAX (IDRT=0,IROMB=1)        4*MAXWV+3           5*MAXWV/2*2+3
C   JMAX (IDRT=256,IROMB=0)      2*MAXWV+1           3*MAXWV/2*2+1
C   JMAX (IDRT=256,IROMB=1)      4*MAXWV+1           5*MAXWV/2*2+1
C   -----------------------      ---------           -------------
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      LOGICAL LUV,LDZ,LPS
      REAL RLAT(*),RLON(*),GRIDUI(*),GRIDVI(*)
      REAL UP(*),VP(*),DP(*),ZP(*),PP(*),SP(*)
      REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
      REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
      REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
      REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM INPUT GRID TO WAVE
      JC=JCPU
      IF(JC.EQ.0) JC=NCPUS()
      MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
      MDIM=2*MX+1
      JN=-JSKIPI
      IF(JN.EQ.0) JN=IMAXI
      JS=-JN
      INP=(JMAXI-1)*MAX(0,-JN)+1
      ISP=(JMAXI-1)*MAX(0,-JS)+1
      CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,
     &             IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC,
     &             WD,WZ,
     &             GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM WAVE TO OUTPUT WINDS
      IF(LUV) THEN
        CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
     &               RLAT,RLON,WD,WZ,UP,VP)
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY
      IF(LDZ) THEN
        CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
     &              RLAT,RLON,WD,DP)
        CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
     &              RLAT,RLON,WZ,ZP)
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION
      IF(LPS) THEN
        CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
C$OMP PARALLEL DO
        DO K=1,KMAX
          CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1)
          CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1)
          WD(1:2,K)=0.
          WZ(1:2,K)=0.
        ENDDO
        CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
     &              RLAT,RLON,WD,PP)
        CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP,
     &              RLAT,RLON,WZ,SP)
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


!******************************************************************************
!*
!*                     VARIOUS GRAIN OPTICAL PROPERTIES
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 08/2007.
  !    - Add Mie scattering and other related routines (02/2014), and clean-up
  !      the obsolete stuff.
  !    - Update with the HDF5 format.
  !    - 01/2016: add THEMIS data.
  !    - 07/2017: add the revised THEMIS data.
  !    - 07/2019: make read_optics more flexible (interface, Qabs label
  !      aliases, etc.).
  !
  ! 3) DESCRIPTION: Functions returning the X-ray to radio grain
  !                 optical properties.
  !==========================================================================

MODULE grain_optics

  USE constants, ONLY:
  USE arrays, ONLY:
  USE inout, ONLY:
  USE interpolation, ONLY:
  USE integration, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: Mie_scattering, RayleighGans_scattering, Geometric_scattering
  PUBLIC :: grain_cross_section, rho_grain, coll_cross_section
  PUBLIC :: read_optics

  INTERFACE rho_grain
    MODULE PROCEDURE rho_grain_pure, rho_grain_gen
  END INTERFACE rho_grain
  INTERFACE label_alias
    MODULE PROCEDURE label_alias_1D, label_alias_scl
  END INTERFACE label_alias
  INTERFACE read_optics
    MODULE PROCEDURE read_optics_gen, read_optics_scl
  END INTERFACE read_optics

  ! Enthalpy Label
  INTEGER, PARAMETER, PUBLIC :: lendustQ = 30 ! label length

CONTAINS

  !==========================================================================
  ! CALL MIE_SCATTERING (x,refrel,Nang,Qext,Qsca,Qabs,Qback,gsca, &
  !                      S1[2*Nang-1],S2[2*Nang-1])
  !
  !   Returns scattering and absorption by a homogeneous isotropic sphere,
  ! as a function of X = 2*pi*a/lambda, given REFREL, its relative refractive
  ! index (complex refractive index of the sphere divided by the real part
  ! index of the surrounding medium). Nang>1 is the number of scattering angles
  ! between 0 and pi/2 (will calculate 2*Nang-1 directions from 0 to pi/2).
  ! m  = SQRT(eps1+i.eps2);
  ! Qext = C_ext/pi*a**2 = efficiency factor for extinction;
  ! Qsca = C_sca/pi*a**2 = efficiency factor for scattering;
  ! Qabs = Qext - Qsca = efficiency for absorption;
  ! Qback = 4.*pi*(dC_sca/domega)/pi*a**2 =  backscattering efficiency;
  ! gsca = <cos(theta)> = asymetry parameter for scattering.
  ! S1 and S2 are diagonal elements of the amplitude scattering matrix:
  ! S1(1:2*Nang-1) = -i*f_22 (incid. E perp. to scatt. plane,
  !                           scatt. E perp. to scatt. plane);
  ! S2(1:2*NANG-1) = -i*f_11 (incid. E parr. to scatt. plane,
  !                           scatt. E parr. to scatt. plane);
  !
  !   Cf. the book by Bohren & Huffman (Sects. 4.4, 4.8 and appendix A).
  !==========================================================================

  SUBROUTINE Mie_Scattering (x,refrel,Nang,Qext,Qsca,Qabs,Qback,gsca,S1,S2)

    USE utilities, ONLY: DP, CDP, strike
    USE constants, ONLY: dpi => pi
    USE arrays, ONLY: ramp
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: x
    COMPLEX(CDP), INTENT(IN) :: refrel
    INTEGER, INTENT(INOUT) :: Nang
    REAL(DP), INTENT(OUT) :: Qext, Qsca, Qabs, Qback, gsca
    COMPLEX(CDP), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: S1, S2

    INTEGER, PARAMETER :: maxNang = 1000, Nmaxmax = 1500000

    INTEGER :: j, jj, n, Nstop, Nmax
    REAL(DP) :: chi, chi0, chi1, En, Fn, p, psi, psi0, psi1
    REAL(DP) :: xstop, ymod
    REAL(DP), DIMENSION(:), ALLOCATABLE :: mu, pi, pi0, pi1, tau
    COMPLEX(CDP) :: an, an1, bn, bn1, xi, xi1, y
    COMPLEX(CDP), DIMENSION(:), ALLOCATABLE :: D, SS1, SS2

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

    ! Preliminary
    !------------
    ! Scattering angles (mu = COS(theta))
    IF (Nang > maxNang) CALL STRIKE("MIE_SCATTERING","Nang > maxNang")
    IF (Nang < 2) Nang = 2
    ALLOCATE (mu(Nang))
    mu(:) = COS(RAMP(Nang,0._DP,dpi/2._DP))

    ! Initialize the variables
    y = x * refrel
    ymod = ABS(y)

    ! Termination of the series expansion (appendix A)
    xstop = x + 4._DP*x**(1._DP/3._DP) + 2._DP
    Nmax = NINT(MAX(xstop,ymod)) + 15
    Nstop = NINT(xstop)
    IF (Nmax > Nmaxmax) CALL STRIKE("MIE_SCATTERING","Nmax too big")

    ! Series expansion for Mie development
    !-------------------------------------
    ALLOCATE (pi(Nang),pi0(Nang),pi1(Nang),tau(Nang))
    pi0(:) = 0._DP
    pi1(:) = 1._DP
    ALLOCATE (SS1(2*Nang-1),SS2(2*Nang-1))
    SS1(:) = CMPLX(0._DP,0._DP,CDP)
    SS2(:) = CMPLX(0._DP,0._DP,CDP)

    ! Logarithmic derivative D calculated by downward recurrence (Eq. 4.89)
    ALLOCATE (D(Nmax))
    D(Nmax) = CMPLX(0._DP,0._DP,CDP)
    DO n=1,Nmax-1
      En = Nmax - n + 1._DP
      D(Nmax-n) = En/y - 1._DP / ( D(Nmax-n+1) + En/y )
    END DO

    ! Useless initializations to shut up the compilation warnings
    An1 = (0._DP,0._DP)
    Bn1 = (0._DP,0._DP)

    ! Riccati-Bessel functions with real argument X calculated by upward
    ! recurrence
    psi0 = COS(x)
    psi1 = SIN(x)
    chi0 = -SIN(x)
    chi1 = COS(x)
    xi1 = CMPLX(psi1,-chi1,CDP)
    Qsca = 0._DP
    gsca = 0._DP
    p = -1._DP
    DO n=1,Nstop
      En = n
      Fn = (2._DP*En+1._DP) / (En*(En+1._DP))

      ! For given N, psi  = psi_n        chi  = chi_n
      !              psi1 = psi_{n-1}    chi1 = chi_{n-1}
      !              psi0 = psi_{n-2}    chi0 = chi_{n-2}
      psi = (2._DP*En-1._DP) * psi1/x - psi0
      chi = (2._DP*En-1._DP) * chi1/x - chi0
      xi = CMPLX(psi,-chi,CDP)

      ! Compute the scattering coefficients (Eq. 4.88)
      IF (n > 1) THEN
        An1 = An
        Bn1 = Bn
      END IF
      An = ( (D(n)/refrel + En/x) * psi - psi1 ) &
         / ( (D(n)/refrel + En/x) * xi - xi1 )
      Bn = ( (refrel*D(n) + En/x) * psi - psi1 ) &
         / ( (refrel*D(n) + En/x) * xi - xi1 )

      ! Build the scattering quantities
      Qsca = Qsca + REAL(( 2._DP*En + 1._DP ) * ( ABS(An)**2 + ABS(Bn)**2 ), DP)
      gsca = gsca + REAL( ( (2._DP*En + 1._DP) / (En * (En + 1._DP)) ) &
                        * ( REAL(An,DP)*REAL(Bn,DP) + AIMAG(An)*AIMAG(Bn) ), DP)
      IF (n > 1) THEN
        gsca = gsca &
             + REAL( ( (En-1._DP) * (En+1._DP) / En ) &
                   * ( REAL(An1,DP)*REAL(An,DP) + AIMAG(An1)*AIMAG(An) &
             + REAL(Bn1,DP)*REAL(Bn,DP) + AIMAG(Bn1)*AIMAG(Bn) ) )
      END IF

      ! Now calculate scattering intensity pattern
      ! First do angles from 0 to 90
      DO j=1,Nang
        jj = 2*Nang - j
        pi(j) = pi1(j)
        tau(j) = En*mu(j)*pi(j) - (En+1._DP)*pi0(j)
        SS1(j) = SS1(j) + Fn * ( An*pi(j) + Bn*tau(j) )
        SS2(j) = SS2(j) + Fn * ( An*tau(j) + Bn*pi(j) )
      END DO

      ! Now do angles greater than 90 using PI and TAU from angles less than 90.
      ! P=1 for N=1,3,...; P=-1 for N=2,4,...
      p = -p
      DO j=1,Nang-1
        jj = 2*Nang - j
        SS1(jj) = SS1(jj) + Fn*p*( An*pi(j) - Bn*tau(j) )
        SS2(jj) = SS2(jj) + Fn*p*( Bn*pi(j) - An*tau(j) )
      END DO
      psi0 = psi1
      psi1 = psi
      chi0 = chi1
      chi1 = chi
      xi1 = CMPLX(psi1,-chi1,CDP)

      ! Compute pi_n for next value of n
      ! For each angle J, compute pi_n+1 from PI = pi_n , PI0 = pi_n-1
      DO j=1,Nang
        pi1(j) = ( (2._DP*En+1._DP) * mu(j)*pi(j) - (En+1._DP)*pi0(j) ) / En
        pi0(j) = pi(j)
      END DO

    END DO

    ! Efficiencies
    !-------------
    gsca = 2._DP * gsca / Qsca
    Qsca = 2._DP / (x*x) * Qsca
    Qext = 4._DP / (x*x) * REAL(SS1(1),DP)
    Qback = 4._DP * (ABS(SS1(2*Nang-1))/x)**2
    Qabs = Qext - Qsca

    ! Optional
    IF (PRESENT(S1) .AND. PRESENT(S2)) THEN
      ALLOCATE (S1(2*Nang-1),S2(Nang-1))
      S1(:) = SS1(:)
      S2(:) = SS2(:)
    END IF
    DEALLOCATE (mu,pi,pi0,pi1,tau,D,SS1,SS2)

    RETURN

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

  END SUBROUTINE Mie_Scattering

  !==========================================================================
  ! CALL RayleighGans_Scattering(x,refrel,Qext,Qsca,Qabs,gsca)
  !
  ! Rayleigh-Gans Regime approximation. From Laor & Draine (1993, Sect. 2.2.1).
  !==========================================================================

  SUBROUTINE RayleighGans_scattering (x,refrel,Qext,Qsca,Qabs,gsca)

    USE utilities, ONLY: DP, CDP
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: x
    COMPLEX(CDP), INTENT(IN) :: refrel
    REAL(DP), INTENT(OUT) :: Qext, Qsca, Qabs, gsca

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

    ! Eqs. (5,7,8) of Laor & Draine (1993)
    Qabs = 8._DP/3._DP * AIMAG(refrel) * x
    Qsca = 32._DP * ABS(refrel-1)**2 * x**4 / (27._DP+16._DP*x**2)
    gsca = 0.3_DP * x**2 / (1._DP+0.3_DP*x**2)
    Qext = Qabs + Qsca

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

  END SUBROUTINE RayleighGans_scattering

  !==========================================================================
  ! CALL Geometric_Scattering (x,refrel,Qext,Qsca,Qabs,gsca)
  !
  !   Geometrical Optics Regime approximation. From Laor & Draine (1993,
  ! Sect. 2.2.2).
  !==========================================================================

  SUBROUTINE Geometric_Scattering (x,refrel,Qext,Qsca,Qabs,gsca)

    USE utilities, ONLY: DP, CDP
    USE constants, ONLY: pi
    USE arrays, ONLY: ramp
    USE integration, ONLY: integ_tabulated
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: x
    COMPLEX(CDP), INTENT(IN) :: refrel
    REAL(DP), INTENT(OUT) :: Qext, Qsca, Qabs, gsca

    INTEGER, PARAMETER :: Nang = 100, Nn = 2
    INTEGER :: i, n
    COMPLEX(CDP) :: epsilon
    REAL(DP) :: Qabs_RG, Qsca_RG, Qext_RG
    REAL(DP), DIMENSION(Nang) :: theta, ptheta, qtheta, psi, ppsi, qpsi
    REAL(DP), DIMENSION(Nang) :: R0per, R0par, R1per, R1par, A
    REAL(DP), DIMENSION(Nang,Nn) :: hn

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

    ! Angle grid
    theta(:) = RAMP(Nang,0._DP,pi/2._DP)

    ! Absorption efficiency
    !----------------------
    epsilon = refrel**2

    ! 1) Interface reflections
    !  - Eq. (9) of Laor & Draine (1993)
    ptheta(:) = SQRT(0.5_DP*( (SIN(theta(:)))**2 - REAL(epsilon,DP) &
                            + SQRT( (2*AIMAG(epsilon))**2 &
                                  + (REAL(epsilon,DP)-(SIN(theta(:)))**2)**2) ))
    !  - Eq. (10) of Laor & Draine (1993)
    qtheta(:) = SQRT(0.5_DP*( REAL(epsilon,DP) - (SIN(theta(:)))**2 &
                            + SQRT((2*AIMAG(epsilon))**2 &
                                  + (REAL(epsilon,DP)-(SIN(theta(:)))**2)**2) ))
    !  - Eq. (11) of Laor & Draine (1993)
    R0per(:) = ( (qtheta(:)-COS(theta(:)))**2 + ptheta(:)**2 ) &
            / ( (qtheta(:)+COS(theta(:)))**2 + ptheta(:)**2 )
    !  - Eq. (12) of Laor & Draine (1993)
    R0par(:) = R0per(:) * ( (qtheta(:)-SIN(theta(:))*TAN(theta(:)))**2 &
                            + ptheta(:)**2 ) &
                          / ( (qtheta(:)+SIN(theta(:))*TAN(theta(:)))**2 &
                            + ptheta(:)**2 )

    ! 2) Internal reflections (theta->psi,epsilon->1/epsilon)
    !  - Eq. (14) of Laor & Draine (1993)
    psi(:) = ASIN( SIN(theta(:)) / SQRT(qtheta(:)**2+(SIN(theta(:)))**2) )

    !  - Eq. (9) of Laor & Draine (1993)
    ppsi(:) = SQRT(0.5_DP*( (SIN(psi(:)))**2 - REAL(1._DP/epsilon,DP) &
                          + SQRT( (2*AIMAG(1._DP/epsilon))**2 &
                              + (REAL(1._DP/epsilon,DP)-(SIN(psi(:)))**2)**2) ))
    !  - Eq. (10) of Laor & Draine (1993)
    qpsi(:) = SQRT(0.5_DP*( REAL(1._DP/epsilon,DP) - (SIN(psi(:)))**2 &
                          + SQRT( (2*AIMAG(1._DP/epsilon))**2 &
                              + (REAL(1._DP/epsilon,DP)-(SIN(psi(:)))**2)**2) ))
    !  - Eq. (11) of Laor & Draine (1993)
    R1per(:) = ( (qpsi(:)-COS(psi(:)))**2 + ppsi(:)**2 ) &
             / ( (qpsi(:)+COS(psi(:)))**2 + ppsi(:)**2 )
    !  - Eq. (12) of Laor & Draine (1993)
    R1par(:) = R1per(:) * ((qpsi(:)-SIN(psi(:))*TAN(psi(:)))**2 + ppsi(:)**2) &
             / ( (qpsi(:)+SIN(psi(:))*TAN(psi(:)))**2 + ppsi(:)**2 )

    ! Eq. (16) of Laor & Draine (1993)
    A(:) = EXP( -4._DP*x * AIMAG(refrel) * COS(psi(:)) )

    ! Eq. (15) of Laor & Draine (1993)
    Qabs = INTEG_TABULATED( theta(:), &
                            SIN(theta(:))*COS(theta(:))*(1._DP-A(:)) &
                            *( (1._DP-R0per(:))/(1._DP-A(:)*R1per(:)) &
                             + (1._DP-R0par(:))/(1._DP-A(:)*R1par(:)) ), &
                            XRANGE=[0._DP,pi/2._DP] )

    ! Extinction efficiency
    !----------------------
    ! Rayleigh-Gans approximation
    Qabs_RG = 8._DP/3._DP * AIMAG(refrel)*x
    Qsca_RG = 32._DP*(ABS(refrel-1._DP))**2 * x**4 / (27._DP+16._DP*x**2)
    Qext_RG = Qabs_RG + Qsca_RG

    ! Eq. (17) of Laor & Draine (1993)
    Qext = Qext_RG / SQRT(1._DP+0.25_DP*Qext_RG**2)

    ! Scattering terms
    !-----------------
    ! Scattering efficiency
    Qsca = Qext - Qabs

    ! Asymmetry
    DO i=1,Nn
      n = i - 1
      hn(:,i) = A(:)**(n+1._DP) * COS(2*(theta(:)-psi(:)) + n*(pi-2*psi(:))) &
              * ( (1._DP-R0per(:))*R1per(:)**n*(1._DP-R1per(:)) &
                  + (1._DP-R0par(:))*R1par(:)**n*(1._DP-R1par(:)) )
    END DO
    gsca = INTEG_TABULATED( theta(:), &
                            SIN(theta(:))*COS(theta(:)) &
                            * ( (R0per(:)+R0par(:))*COS(2*theta(:)) &
                              + SUM(hn(:,:),DIM=2) ) ) / Qsca

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

  END SUBROUTINE Geometric_scattering

  !==========================================================================
  ! CALL GRAIN_CROSS_SECTION (radius,wave,refrel,Qext,Qsca,Qabs,gsca)
  !
  !   Compute the wavelength dependent cross-sections, for a set of sizes,
  ! using the method of Laor & Draine (1993; three different regimes).
  !==========================================================================

  SUBROUTINE grain_cross_section (radius,wave,refrel,Qext,Qsca,Qabs,gsca, &
                                  timestr)

    USE utilities, ONLY: DP, CDP, trimlr, pring, verbatim, timinfo, time_type
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: radius, wave
    COMPLEX(CDP), DIMENSION(:), INTENT(IN) :: refrel
    REAL(DP), DIMENSION(SIZE(radius),SIZE(wave)), INTENT(OUT) :: Qext, Qsca
    REAL(DP), DIMENSION(SIZE(radius),SIZE(wave)), INTENT(OUT) :: Qabs, gsca
    TYPE(time_type), INTENT(INOUT), OPTIONAL :: timestr

    INTEGER :: i, j, Nw, Nr, Nang
    REAL(DP) :: Qext_wr, Qsca_wr, Qabs_wr, Qback_wr, gsca_wr
    REAL(DP), DIMENSION(SIZE(wave)) :: x, mx, m_1x
    LOGICAL, PARAMETER :: onlyMie = .True.

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

    Nw = SIZE(wave(:))
    Nr = SIZE(radius(:))
    Nang = 2

    ! Loop on the wavelengths
    Cgrain_size: DO i=1,Nr
      IF (verbatim .AND. (MODULO(i,10) == 1 .OR. i == Nr)) THEN
        IF (PRESENT(timestr)) THEN
          PRINT*, "  Calculating grain cross-section for a=" &
                           //TRIMLR(PRING(radius(i),NDEC=6))//" microns" &
                //" ("//TRIMLR(TIMINFO(timestr))//")"
        ELSE
          PRINT*, "  Calculating grain cross-section for a=" &
                           //TRIMLR(PRING(radius(i),NDEC=6))//" microns"
        END IF
      END IF

      ! Size parameter
      x(:) = 2._DP*pi*radius(i) / wave(:)
      mx(:) = ABS(refrel(:)) * x(:)
      m_1x(:) = ABS(refrel(:)-1._DP) * x(:)

      ! Loop on the sizes
      Cgrain_wave: DO j=1,Nw

        ! Actual calculation
        IF (onlyMie) THEN
          ! We implement Mie everywhere, even in the R-G and the geometric
          ! optics regimes
          CALL MIE_SCATTERING(x(j),refrel(j),Nang,Qext_wr,Qsca_wr,Qabs_wr, &
                              Qback_wr,gsca_wr)
        ELSE
          ! Laor & Draine (1993) three regime method
          IF (mx(j) <= 1.E3_DP) THEN
            CALL MIE_SCATTERING(x(j),refrel(j),Nang,Qext_wr,Qsca_wr,Qabs_wr, &
                                Qback_wr,gsca_wr)
          ELSE IF (mx(j) > 1.E3_DP .AND. m_1x(j) <= 1.E-3_DP) THEN
            CALL RAYLEIGHGANS_SCATTERING(x(j),refrel(j),Qext_wr,Qsca_wr, &
                                         Qabs_wr,gsca_wr)
          ELSE IF (mx(j) > 1.E3_DP .AND. m_1x(j) > 1.E-3_DP) THEN
            CALL GEOMETRIC_SCATTERING(x(j),refrel(j),Qext_wr,Qsca_wr,Qabs_wr, &
                                      gsca_wr)
          END IF
        END IF

        ! Final storage
        Qext(i,j) = Qext_wr
        Qsca(i,j) = Qsca_wr
        Qabs(i,j) = Qabs_wr
        gsca(i,j) = gsca_wr

      END DO Cgrain_wave

    END DO Cgrain_size

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

  END SUBROUTINE grain_cross_section

  !==========================================================================
  ! sigma = COLL_CROSS_SECTION(E,a)
  !
  !    Collision cross-section for electrons, following Eq. (4) of Dwek (1986).
  ! E must be in J, a in microns, sigma is returned in m2.
  !==========================================================================

  PURE FUNCTION coll_cross_section (E,a)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi, MKS
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: E
    REAL(DP), INTENT(IN) :: a
    REAL(DP), DIMENSION(SIZE(E)) :: coll_cross_section

    REAL(DP) :: Estar

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

    Estar = 3.7E-15_DP * a**(2._DP/3._DP) ! barrier energy [J]
    WHERE (E(:) > Estar)
      coll_cross_section(:) = pi * (a*MKS%micron)**2 &
        * ( 1._DP - ( 1._DP - (Estar/E(:))**1.5_DP )**(2._DP/3._DP) )
    ELSEWHERE
      coll_cross_section(:) = pi * (a*MKS%micron)**2
    END WHERE

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

  END FUNCTION coll_cross_section

  !==========================================================================
  ! label = LABEL_ALIAS(lab)
  !
  !  Aliases for common optical properties.
  !==========================================================================

  PURE FUNCTION label_alias_1D(lab)

    USE utilities, ONLY: trimeq
    IMPLICIT NONE

    CHARACTER(*), DIMENSION(:), INTENT(IN) :: lab
    CHARACTER(lendustQ), DIMENSION(SIZE(lab)) :: label_alias_1D
    INTEGER :: i, Nspec

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

    Nspec = SIZE(lab(:))
    label_alias_1D(:) = lab(:)
    DO i=1,Nspec
      IF (TRIMEQ(lab(i),"Sil") .OR. TRIMEQ(lab(i),"silicate")) THEN
        label_alias_1D(i) = "Sil_D03"
      ELSE IF (TRIMEQ(lab(i),"SiC")) THEN
        label_alias_1D(i) = "SiC_LD93"
      ELSE IF (TRIMEQ(lab(i),"Gra") .OR. TRIMEQ(lab(i),"graphite")) THEN
        label_alias_1D(i) = "Gra_D03"
      ELSE IF (TRIMEQ(lab(i),"PAHn") .OR. TRIMEQ(lab(i),"PAH0")) THEN
        label_alias_1D(i) = "PAHn_DL07"
      ELSE IF (TRIMEQ(lab(i),"PAHi") .OR. TRIMEQ(lab(i),"PAH+")) THEN
        label_alias_1D(i) = "PAHi_DL07"
      ELSE IF (TRIMEQ(lab(i), "a-C(:H)") .OR. TRIMEQ(lab(i),"HAC")) THEN
        label_alias_1D(i) = "a-C_man20nm_small"
      END IF
    END DO

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

  END FUNCTION label_alias_1D

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

  PURE FUNCTION label_alias_scl(lab)
    IMPLICIT NONE
    CHARACTER(*), INTENT(IN) :: lab
    CHARACTER(lendustQ) :: label_alias_scl
    CHARACTER(lendustQ), DIMENSION(1) :: tmp
    tmp = LABEL_ALIAS_1D([lab])
    label_alias_scl = tmp(1)
  END FUNCTION label_alias_scl

  !==========================================================================
  ! rho = rho_grain(species,name,reference)
  !
  !   Returns the mass per unit volume of material for grain species in kg/m3.
  ! The label of the species should be the same as for the cross-sections.
  !==========================================================================

  PURE FUNCTION rho_grain_pure (species)

    USE utilities, ONLY: DP, trimeq
    IMPLICIT NONE

    CHARACTER(*), INTENT(IN) :: species
    REAL(DP) :: rho_grain_pure
    CHARACTER(lendustQ) :: species0

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

    species0 = (LABEL_ALIAS(species))
    IF (TRIMEQ(species0,"Sil_LD93")) THEN
      rho_grain_pure = 3.3_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_WD01")) THEN
      rho_grain_pure = 3.5_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_LD01")) THEN
      rho_grain_pure = 3.5_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_D03")) THEN
      rho_grain_pure = 3.5_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"SiC_LD93")) THEN
      rho_grain_pure = 3.22_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Gra_D03")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Gra_LD93")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"ACAR_Z96")) THEN
      rho_grain_pure = 1.85_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"ACH2_Z96")) THEN
      rho_grain_pure = 1.85_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"BE_Z96")) THEN
      rho_grain_pure = 1.85_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHn_LD01")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHi_LD01")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHn_DL07")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHi_DL07")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHn_DL07_G11")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHi_DL07_G11")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHn_DL07_C11")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"PAHi_DL07_C11")) THEN
      rho_grain_pure = 2.24_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-C_man20nm_J13")) THEN
      rho_grain_pure = 1.30_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-Forst_Fe_man5nm_J13")) THEN
      rho_grain_pure = 1.60_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-Enst_Fe_man5nm_J13")) THEN
      rho_grain_pure = 1.60_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-C_man20nm_small")) THEN
      rho_grain_pure = 1.60_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-C_man20nm_big")) THEN
      rho_grain_pure = 1.51_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-Forst_Fe_man5nm")) THEN
      rho_grain_pure = 2.19_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"a-Enst_Fe_man5nm")) THEN
      rho_grain_pure = 2.19_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_Mg07_J03")) THEN
      rho_grain_pure = 3.50_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_Mg10_J03")) THEN
      rho_grain_pure = 3.50_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_Mg15_J03")) THEN
      rho_grain_pure = 3.50_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_Mg20_J03")) THEN
      rho_grain_pure = 3.50_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"Sil_Mg24_J03")) THEN
      rho_grain_pure = 3.50_DP * 1.E3_DP ! [kg/m3]
    ELSE IF (TRIMEQ(species0,"FeO_H95")) THEN
      rho_grain_pure = 5.70_DP * 1.E3_DP ! [kg/m3]
    ELSE
      rho_grain_pure = 0._DP
    END IF

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

  END FUNCTION rho_grain_pure

  !==========================================================================

  FUNCTION rho_grain_gen (species,name,reference)

    USE utilities, ONLY: DP, trimeq
    IMPLICIT NONE

    CHARACTER(*), INTENT(IN) :: species
    CHARACTER(*), INTENT(OUT) :: name, reference
    REAL(DP) :: rho_grain_gen
    CHARACTER(lendustQ) :: species0

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

    species0 = LABEL_ALIAS(species)
    IF (TRIMEQ(species0,"Sil_LD93")) THEN
      name = "Original astronomical silicate"
      reference = "(Laor & Draine 1993, ApJ, 402, 441)"
    ELSE IF (TRIMEQ(species0,"Sil_WD01")) THEN
      name = "Smoothed UV astronomical silicate"
      reference = "(Weingartner & Draine 2001, ApJ, 548, 296)"
    ELSE IF (TRIMEQ(species0,"Sil_LD01")) THEN
      name = "Smoothed UV astronomical silicate & submm excess"
      reference = "(Li & Draine 2001, ApJ, 554, 778)"
    ELSE IF (TRIMEQ(species0,"Sil_D03")) THEN
      name = "Astronomical silicate"
      reference = "(Draine 2003, ApJ, 598, 1017)"
    ELSE IF (TRIMEQ(species0,"SiC_LD93")) THEN
      name = "Silicon carbide"
      reference = "(Laor & Draine 1993, ApJ, 402, 441)"
    ELSE IF (TRIMEQ(species0,"Gra_D03")) THEN
      name = "Graphitic carbon (1/3-2/3)"
      reference = "(Draine 2003, ApJ, 598, 1017)"
    ELSE IF (TRIMEQ(species0,"Gra_LD93")) THEN
      name = "Original graphitic carbon (1/3-2/3)"
      reference = "(Laor & Draine 1993, ApJ, 402, 441)"
    ELSE IF (TRIMEQ(species0,"ACAR_Z96")) THEN
      name = "ACAR amorphous carbon"
      reference = "(Zubko et al. 1996, MNRAS, 282, 1321)"
    ELSE IF (TRIMEQ(species0,"ACH2_Z96")) THEN
      name = "ACH2 amorphous carbon"
      reference = "(Zubko et al. 1996, MNRAS, 282, 1321)"
    ELSE IF (TRIMEQ(species0,"BE_Z96")) THEN
      name = "BE amorphous carbon"
      reference = "(Zubko et al. 1996, MNRAS, 282, 1321)"
    ELSE IF (TRIMEQ(species0,"PAHn_LD01")) THEN
      name = "Original neutral PAHs"
      reference = "(Li & Draine 2001, ApJ, 554, 778)"
    ELSE IF (TRIMEQ(species0,"PAHi_LD01")) THEN
      name = "Original ionized PAHs"
      reference = "(Li & Draine 2001, ApJ, 554, 778)"
    ELSE IF (TRIMEQ(species0,"PAHn_DL07")) THEN
      name = "Neutral PAHs"
      reference = "(Draine & Li 2007, ApJ, 657, 810)"
    ELSE IF (TRIMEQ(species0,"PAHi_DL07")) THEN
      name = "Ionized PAHs"
      reference = "(Draine & Li 2007, ApJ, 657, 810)"
    ELSE IF (TRIMEQ(species0,"PAHn_DL07_G11")) THEN
      name = "Neutral PAHs modified for the Z04 model"
      reference = "(Galliano et al. 2011, A&A, 536, A88)"
    ELSE IF (TRIMEQ(species0,"PAHi_DL07_G11")) THEN
      name = "Ionized PAHs modified for the Z04 model"
      reference = "(Galliano et al. 2011, A&A, 536, A88)"
    ELSE IF (TRIMEQ(species0,"PAHn_DL07_C11")) THEN
      name = "Neutral PAHs modified for the C11 model"
      reference = "(Compiegne et al. 2011, A&A, 525, A103)"
    ELSE IF (TRIMEQ(species0,"PAHi_DL07_C11")) THEN
      name = "Ionized PAHs modified for the C11 model"
      reference = "(Compiegne et al. 2011, A&A, 525, A103)"
    ELSE IF (TRIMEQ(species0,"a-C_man20nm_J13")) THEN
      name = "a-C(:H) + 20 nm a-C"
      reference = "(Jones et al. 2013, A&A, 558, A62)"
    ELSE IF (TRIMEQ(species0,"a-Forst_Fe_man5nm_J13")) THEN
      name = "a-Forsterite + 10 % Fe/FeS + 5 nm a-C"
      reference = "(Jones et al. 2013, A&A, 558, A62)"
    ELSE IF (TRIMEQ(species0,"a-Enst_Fe_man5nm_J13")) THEN
      name = "a-Enstatite + 10 % Fe/FeS + 5 nm a-C"
      reference = "(Jones et al. 2013, A&A, 558, A62)"
    ELSE IF (TRIMEQ(species0,"a-C_man20nm_small")) THEN
      name = "Small a-C(:H) + 20 nm a-C"
      reference = "(Jones et al. 2017, A&A, 602, A46)"
    ELSE IF (TRIMEQ(species0,"a-C_man20nm_big")) THEN
      name = "Big a-C(:H) + 20 nm a-C"
      reference = "(Jones et al. 2017, A&A, 602, A46)"
    ELSE IF (TRIMEQ(species0,"a-Forst_Fe_man5nm")) THEN
      name = "a-Forsterite + 10 % Fe/FeS + 5 nm a-C"
      reference = "(Jones et al. 2017, A&A, 602, A46)"
    ELSE IF (TRIMEQ(species0,"a-Enst_Fe_man5nm")) THEN
      name = "a-Enstatite + 10 % Fe/FeS + 5 nm a-C"
      reference = "(Jones et al. 2017, A&A, 602, A46)"
    ELSE IF (TRIMEQ(species0,"Sil_Mg07_J03")) THEN
      name = "Silicate Mg_0.7 Si O_2.7"
      reference = "(Jaeger et al. 2003, A&A, 408, 193)"
    ELSE IF (TRIMEQ(species0,"FeO_H95")) THEN
      name = "Iron Oxide FeO"
      reference = "(Henning et al. 1995, A&AS, 112, 143)"
    END IF
    rho_grain_gen = RHO_GRAIN_PURE(species0)

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

  END FUNCTION rho_grain_gen

  !==========================================================================
  ! CALL READ_OPTICS(lab,Nwall,Nrall,NTall,Nmax,Nrmax,NTmax, &
  !                             waveall,radiusall,tempall, &
  !                             Qabsall,Qscaall,gscall,Qavall, &
  !                             wrange,wave,nu,Nw)
  !
  !   Reads the wavelength, radius and temperature dependent precomputed
  ! optical properties of several species into one big array per quantity,
  ! and optionally reinterpolate them on a common wavelength grid, without
  ! loosing spectral resolution.
  !==========================================================================

  SUBROUTINE read_optics_gen (lab,Nwall,Nrall,NTall,Nwmax,Nrmax,NTmax, &
                               waveall,radiusall,tempall, &
                               Qabsall,Qscaall,gscaall,Qavall, &
                               wrange,wave,nu,Nw)

    USE utilities, ONLY: DP, trimeq, trimlr, lenmax, temproot, strreplace
    USE constants, ONLY: MKS
    USE arrays, ONLY: reallocate, closest
    USE inout, ONLY: read_hdf5, h5ext
    USE interpolation, ONLY: interp_lin_sorted
    IMPLICIT NONE

    CHARACTER(*), DIMENSION(:), INTENT(IN) :: lab
    INTEGER, DIMENSION(SIZE(lab)), INTENT(OUT), OPTIONAL :: Nwall, Nrall, NTall
    INTEGER, INTENT(OUT), OPTIONAL :: Nwmax, Nrmax, NTmax
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: waveall
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: radiusall
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: tempall
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: Qabsall
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: Qscaall
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: Qavall
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: gscaall
    REAL(DP), DIMENSION(2), INTENT(IN), OPTIONAL :: wrange
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: wave, nu
    INTEGER, INTENT(OUT), OPTIONAL :: Nw

    INTEGER :: i, j, Nspec, Nw1
    INTEGER :: Nwmax0, Nrmax0, NTmax0, Nwmax1, Nrmax1, NTmax1, Nw0, Nr0, NT0
    INTEGER, DIMENSION(SIZE(lab)) :: Nwall0, Nrall0, NTall0
    INTEGER, DIMENSION(:), ALLOCATABLE :: ind
    REAL(DP) :: lnwmin, lnwmax, dlnwave, dlnwmax
    REAL(DP), DIMENSION(:), ALLOCATABLE :: wave_r, radius_r, temp_r, wave0
    REAL(DP), DIMENSION(:), ALLOCATABLE :: lnwave, lnwave0
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: dlnwaveall
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: waveall0, radiusall0, tempall0
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: wave1, radius1, temp1
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: Qabs1, Qsca1, gsca1, Qav1
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: Qabs_r, Qsca_r, Qav_r, gsca_r
    CHARACTER(lenmax) :: dirQabs
    CHARACTER(lendustQ), DIMENSION(SIZE(lab)) :: lab0
    LOGICAL :: wavinterp
    LOGICAL, DIMENSION(:), ALLOCATABLE :: boolind

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

    ! 1) Preliminaries
    !-----------------
    Nspec = SIZE(lab(:))
    wavinterp = .True.
    IF (.NOT. PRESENT(wave)) wavinterp = .False.

    ! Solve label degeneracies
    lab0(:) = LABEL_ALIAS(lab(:))

    ! 2) Concatenate the optical properties
    !--------------------------------------
    dirQabs = TRIMLR(temproot())//"Cross_sections/Data/"
    readoptics: DO i=1,Nspec
      nocomp: IF (.NOT. TRIMEQ(lab0(i),"")) THEN

        ! Load the variables
        CALL READ_HDF5(DBLARR1D=wave_r,NAME="Wavelength (microns)", &
                       FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        CALL READ_HDF5(DBLARR1D=radius_r,NAME="Grain radius (microns)", &
                       FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        CALL READ_HDF5(DBLARR1D=temp_r,NAME="Grain temperature (K)", &
                       FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        IF (PRESENT(Qabsall)) &
          CALL READ_HDF5(DBLARR2D=Qabs_r, &
                        NAME="Grain absorption efficiency (Qabs)", &
                        FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        IF (PRESENT(Qscaall)) &
          CALL READ_HDF5(DBLARR2D=Qsca_r, &
                        NAME="Grain scattering efficiency (Qsca)", &
                        FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        IF (PRESENT(gscaall)) &
          CALL READ_HDF5(DBLARR2D=gsca_r, &
                        NAME="Grain asymmetry parameter (<cos(theta)>)", &
                        FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        IF (PRESENT(Qavall)) &
          CALL READ_HDF5(DBLARR2D=Qav_r,NAME="Planck average of Qabs", &
                        FILE=TRIMLR(dirQabs)//"optics_"//TRIMLR(lab0(i))//h5ext)
        Nw0 = SIZE(wave_r(:))
        Nr0 = SIZE(radius_r(:))
        NT0 = SIZE(temp_r(:))
        Nwall0(i) = Nw0
        Nrall0(i) = Nr0
        NTall0(i) = NT0

        ! Put everything in the same array
        IF (i == 1) THEN
          ALLOCATE( waveall0(Nspec,Nw0), radiusall0(Nspec,Nr0), &
                    tempall0(Nspec,NT0) )
          waveall0(i,:) = wave_r(:)
          radiusall0(i,:) = radius_r(:)
          tempall0(i,:) = temp_r(:)
          IF (PRESENT(Qabsall)) THEN
            ALLOCATE(Qabsall(Nspec,Nr0,Nw0))
            Qabsall(i,:,:) = Qabs_r(:,:)
          END IF
          IF (PRESENT(Qscaall)) THEN
            ALLOCATE(Qscaall(Nspec,Nr0,Nw0))
            Qscaall(i,:,:) = Qsca_r(:,:)
          END IF
          IF (PRESENT(gscaall)) THEN
            ALLOCATE(gscaall(Nspec,Nr0,Nw0))
            gscaall(i,:,:) = gsca_r(:,:)
          END IF
          IF (PRESENT(Qavall)) THEN
            ALLOCATE(Qavall(Nspec,Nr0,Nw0))
            Qavall(i,:,:) = Qav_r(:,:)
          END IF
          Nwmax0 = Nw0
          Nrmax0 = Nr0
          NTmax0 = NT0
        ELSE
          ! Concatenate wave
          Nwmax1 = Nwmax0
          Nwmax0 = MAX(Nwmax0,Nw0)
          CALL REALLOCATE(wave1,Nspec,Nwmax0)
          wave1(:,:) = 0._DP
          wave1(1:i-1,1:Nwmax1) = waveall0(1:i-1,:)
          IF (Nwmax0 > Nwmax1) wave1(1:i-1,Nwmax1+1:Nwmax0) = 0._DP
          wave1(i,1:Nw0) = wave_r(:)
          IF (Nw0 > Nwmax0) wave1(i,Nw0+1:Nwmax0) = 0._DP
          CALL REALLOCATE(waveall0,Nspec,Nwmax0)
          waveall0(:,:) = wave1(:,:)
          DEALLOCATE (wave1)
          ! Concatenate radius
          Nrmax1 = Nrmax0
          Nrmax0 = MAX(Nrmax0,Nr0)
          CALL REALLOCATE(radius1,Nspec,Nrmax0)
          radius1(:,:) = 0._DP
          radius1(1:i-1,1:Nrmax1) = radiusall0(1:i-1,:)
          radius1(i,1:Nr0) = radius_r(:)
          CALL REALLOCATE(radiusall0,Nspec,Nrmax0)
          radiusall0(:,:) = radius1(:,:)
          DEALLOCATE(radius1)
          ! Concatenate temp
          NTmax1 = NTmax0
          NTmax0 = MAX(NTmax0,NT0)
          CALL REALLOCATE(temp1,Nspec,NTmax0)
          temp1(:,:) = 0._DP
          temp1(1:i-1,1:NTmax1) = tempall0(1:i-1,:)
          temp1(i,1:NT0) = temp_r(:)
          CALL REALLOCATE(tempall0,Nspec,NTmax0)
          tempall0(:,:) = temp1(:,:)
          DEALLOCATE(temp1)
          ! Concatenate Qabs
          IF (PRESENT(Qabsall)) THEN
            CALL REALLOCATE(Qabs1,Nspec,Nrmax0,Nwmax0)
            Qabs1(:,:,:) = 0._DP
            Qabs1(1:i-1,1:Nrmax1,1:Nwmax1) = Qabsall(1:i-1,:,:)
            Qabs1(i,1:Nr0,1:Nw0) = Qabs_r(:,:)
            CALL REALLOCATE(Qabsall,Nspec,Nrmax0,Nwmax0)
            Qabsall(:,:,:) = Qabs1(:,:,:)
          END IF
          ! Concatenate Qsca
          IF (PRESENT(Qscaall)) THEN
            CALL REALLOCATE(Qsca1,Nspec,Nrmax0,Nwmax0)
            Qsca1(:,:,:) = 0._DP
            Qsca1(1:i-1,1:Nrmax1,1:Nwmax1) = Qscaall(1:i-1,:,:)
            Qsca1(i,1:Nr0,1:Nw0) = Qsca_r(:,:)
            CALL REALLOCATE(Qscaall,Nspec,Nrmax0,Nwmax0)
            Qscaall(:,:,:) = Qsca1(:,:,:)
          END IF
          ! Concatenate gsca
          IF (PRESENT(gscaall)) THEN
            CALL REALLOCATE(gsca1,Nspec,Nrmax0,Nwmax0)
            gsca1(:,:,:) = 0._DP
            gsca1(1:i-1,1:Nrmax1,1:Nwmax1) = gscaall(1:i-1,:,:)
            gsca1(i,1:Nr0,1:Nw0) = gsca_r(:,:)
            CALL REALLOCATE(gscaall,Nspec,Nrmax0,Nwmax0)
            gscaall(:,:,:) = gsca1(:,:,:)
          END IF
          ! Concatenate Qav
          IF (PRESENT(Qavall)) THEN
            CALL REALLOCATE(Qav1,Nspec,Nrmax0,NTmax0)
            Qav1(:,:,:) = 0._DP
            Qav1(1:i-1,1:Nrmax1,1:NTmax1) = Qavall(1:i-1,:,:)
            Qav1(i,1:Nr0,1:NT0) = Qav_r(:,:)
            CALL REALLOCATE(Qavall,Nspec,Nrmax0,NTmax0)
            Qavall(:,:,:) = Qav1(:,:,:)
          END IF
        END IF

        ! Free memory space
        IF (ALLOCATED(wave_r)) DEALLOCATE (wave_r)
        IF (ALLOCATED(radius_r)) DEALLOCATE(radius_r)
        IF (ALLOCATED(temp_r)) DEALLOCATE(temp_r)
        IF (ALLOCATED(Qabs_r)) DEALLOCATE(Qabs_r)
        IF (ALLOCATED(Qsca_r)) DEALLOCATE(Qsca_r)
        IF (ALLOCATED(gsca_r)) DEALLOCATE(gsca_r)

      ELSE

        Nwall0(i) = 1
        Nrall0(i) = 1
        NTall0(i) = 1
        waveall0(i,:) = 0._DP
        radiusall0(i,:) = 0._DP
        tempall0(i,:) = 0._DP
        IF (PRESENT(Qabsall)) Qabsall(i,:,:) = 0._DP
        IF (PRESENT(Qscaall)) Qscaall(i,:,:) = 0._DP
        IF (PRESENT(gscaall)) gscaall(i,:,:) = 0._DP
        IF (PRESENT(Qavall)) Qavall(i,:,:) = 0._DP

      END IF nocomp

    END DO readoptics

    ! 3) Interpolate on a common wavelength grid
    !-------------------------------------------
    commonwave: IF (Nspec > 1 .AND. wavinterp) THEN

      ! Wavelength range
      IF (PRESENT(wrange)) THEN
        lnwmin = LOG(wrange(1))
        lnwmax = LOG(wrange(2))
      ELSE
        lnwmin = LOG(1.E-2_DP)
        lnwmax = LOG(3.E4_DP)
      END IF

      ! Design a common grid, without loosing resolution
      ALLOCATE (dlnwaveall(Nspec,Nwmax0))
      dlnwaveall(:,1:Nwmax0-1) = LOG(waveall0(:,2:Nwmax0)) &
                               - LOG(waveall0(:,1:Nwmax0-1))
      dlnwaveall(:,Nwmax0) = dlnwaveall(:,Nwmax0-1)
      Nw0 = 1
      ALLOCATE (lnwave(Nw0))
      ALLOCATE (ind(Nspec))
      ALLOCATE (boolind(Nspec))
      lnwave(1) = lnwmin
      dlnwmax = MAXVAL(dlnwaveall(:,:),MASK=(waveall0(:,:) > 0._DP))
      DO
        Nw1 = Nw0
        FORALL (i=1:Nspec,.NOT. TRIMEQ(lab0(i),"")) &
          ind(i) = CLOSEST(waveall0(i,1:Nwall0(i)),EXP(lnwave(Nw1)))
        boolind(:) = ( ind(:) < Nwall0(:) )
        dlnwave = dlnwmax
        DO i=1,Nspec
          IF (boolind(i) .AND. (.NOT. TRIMEQ(lab0(i),""))) THEN
            IF (dlnwave > dlnwaveall(i,ind(i))) dlnwave = dlnwaveall(i,ind(i))
          END IF
        END DO
        Nw0 = Nw1 + 1
        CALL REALLOCATE(lnwave0,Nw0)
        lnwave0(1:Nw1) = lnwave(:)
        lnwave0(Nw0) = lnwave(Nw1) + dlnwave
        CALL REALLOCATE(lnwave,Nw0)
        lnwave(:) = lnwave0(:)
        IF (lnwave(Nw0) >= lnwmax-dlnwave/2._DP) THEN
          lnwave(Nw0) = lnwmax
          EXIT
        END IF
      END DO
      CALL REALLOCATE (wave0,Nw0)
      wave0(:) = EXP(lnwave(:))
      DEALLOCATE (ind,boolind)

      ! Interpolate the Qabs
      IF (PRESENT(Qabsall)) THEN
        CALL REALLOCATE(Qabs1,Nspec,Nrmax0,Nw0)
        Qabs1(:,:,:) = 0._DP
        FORALL ( i=1:Nspec, j=1:Nrmax0, &
                (j <= Nrall0(i)) .AND. (.NOT. TRIMEQ(lab0(i),"")) ) &
          Qabs1(i,j,:) = INTERP_LIN_SORTED( Qabsall(i,j,1:Nwall0(i)), &
                                            waveall0(i,1:Nwall0(i)), wave0(:), &
                                            XLOG=.True., YLOG=.True. )
        CALL REALLOCATE(Qabsall,Nspec,Nrmax0,Nw0)
        Qabsall(:,:,:) = Qabs1
      END IF

      ! Interpolate the Qsca
      IF (PRESENT(Qscaall)) THEN
        CALL REALLOCATE(Qsca1,Nspec,Nrmax0,Nw0)
        Qsca1(:,:,:) = 0._DP
        FORALL ( i=1:Nspec, j=1:Nrmax0, &
                (j <= Nrall0(i)) .AND. (.NOT. TRIMEQ(lab0(i),"")) ) &
          Qsca1(i,j,:) = INTERP_LIN_SORTED( Qscaall(i,j,1:Nwall0(i)), &
                                            waveall0(i,1:Nwall0(i)), wave0(:), &
                                            XLOG=.True., YLOG=.True. )
        CALL REALLOCATE(Qscaall,Nspec,Nrmax0,Nw0)
        Qscaall(:,:,:) = Qsca1
      END IF

      ! Interpolate the gsca
      IF (PRESENT(gscaall)) THEN
        CALL REALLOCATE(gsca1,Nspec,Nrmax0,Nw0)
        gsca1(:,:,:) = 0._DP
        FORALL ( i=1:Nspec, j=1:Nrmax0, &
                (j <= Nrall0(i)) .AND. (.NOT. TRIMEQ(lab0(i),"")) ) &
          gsca1(i,j,:) = INTERP_LIN_SORTED( gscaall(i,j,1:Nwall0(i)), &
                                            waveall0(i,1:Nwall0(i)), wave0(:), &
                                            XLOG=.True., YLOG=.False. )
        CALL REALLOCATE(gscaall,Nspec,Nrmax0,Nw0)
        gscaall(:,:,:) = gsca1
      END IF

      ! Free memory space
      IF (ALLOCATED(Qabs1)) DEALLOCATE(Qabs1)
      IF (ALLOCATED(Qsca1)) DEALLOCATE(Qsca1)
      IF (ALLOCATED(gsca1)) DEALLOCATE(gsca1)
      IF (ALLOCATED(Qav1)) DEALLOCATE(Qav1)
      IF (ALLOCATED(lnwave)) DEALLOCATE(lnwave)
      IF (ALLOCATED(dlnwaveall)) DEALLOCATE(dlnwaveall)
      IF (ALLOCATED(lnwave0)) DEALLOCATE(lnwave0)

    ELSE IF (Nspec == 1 .AND. wavinterp) THEN

      CALL REALLOCATE (wave0,Nwmax0)
      wave0(:) = waveall0(1,:)

    END IF commonwave

    ! 4) Optional output
    !-------------------
    IF (PRESENT(Nwmax)) Nwmax = Nwmax0
    IF (PRESENT(Nrmax)) Nrmax = Nrmax0
    IF (PRESENT(NTmax)) NTmax = NTmax0
    IF (PRESENT(Nwall)) Nwall(:) = Nwall0(:)
    IF (PRESENT(Nrall)) Nrall(:) = Nrall0(:)
    IF (PRESENT(NTall)) NTall(:) = NTall0(:)
    IF (PRESENT(waveall)) THEN
      ALLOCATE(waveall(Nspec,Nwmax0))
      waveall(:,:) = waveall0(:,:)
    END IF
    IF (PRESENT(radiusall)) THEN
      ALLOCATE(radiusall(Nspec,Nrmax0))
      radiusall(:,:) = radiusall0(:,:)
    END IF
    IF (PRESENT(tempall)) THEN
      ALLOCATE(tempall(Nspec,NTmax0))
      tempall(:,:) = tempall0(:,:)
    END IF
    IF (PRESENT(Nw)) Nw = Nw0
    IF (PRESENT(wave)) THEN
      ALLOCATE(wave(Nw0))
      wave(:) = wave0(:)
    END IF
    IF (PRESENT(nu)) THEN
      ALLOCATE(nu(Nw0))
      nu(:) = MKS%clight / MKS%micron / wave0(:)
    END IF
    IF (ALLOCATED(wave0)) DEALLOCATE (wave0)
    IF (ALLOCATED(waveall0)) DEALLOCATE(waveall0)
    IF (ALLOCATED(radiusall0)) DEALLOCATE(radiusall0)
    IF (ALLOCATED(tempall0)) DEALLOCATE(tempall0)

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

  END SUBROUTINE read_optics_gen

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

  SUBROUTINE read_optics_scl (lab,Qabs,Qsca,gsca,Qav, &
                               wrange,wave,nu,radius,temp,Nw,Nr,NT)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    CHARACTER(*), INTENT(IN) :: lab
    INTEGER, INTENT(OUT), OPTIONAL :: Nw, Nr, NT
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: Qabs, Qsca
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: Qav, gsca
    REAL(DP), DIMENSION(2), INTENT(IN), OPTIONAL :: wrange
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: wave, nu
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT), OPTIONAL :: radius, temp
    INTEGER :: Nr0, Nw0, NT0
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: radius0, temp0
    REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: Qabs0, Qsca0, Qav0, gsca0
    CALL READ_OPTICS_GEN([lab],NWMAX=Nw0,NRMAX=Nr0,NTMAX=NT0, &
                           RADIUSALL=radius0,TEMPALL=temp0,QABSALL=Qabs0, &
                           QSCAALL=Qsca0,GSCAALL=gsca0,QAVALL=Qav0, &
                           WRANGE=wrange,WAVE=wave,NU=nu)
    IF (PRESENT(Nr)) Nr = Nr0
    IF (PRESENT(Nw)) Nw = Nw0
    IF (PRESENT(NT)) NT = NT0
    IF (PRESENT(radius)) THEN
      ALLOCATE(radius(Nr0))
      radius(:) = radius0(1,:)
    END IF
    IF (PRESENT(temp)) THEN
      ALLOCATE(temp(NT0))
      temp(:) = temp0(1,:)
    ENDIF
    IF (PRESENT(Qabs)) THEN
      ALLOCATE(Qabs(Nr0,Nw0))
      Qabs(:,:) = Qabs0(1,:,:)
    END IF
    IF (PRESENT(Qsca)) THEN
      ALLOCATE(Qsca(Nr0,Nw0))
      Qsca(:,:) = Qsca0(1,:,:)
    END IF
    IF (PRESENT(Qav)) THEN
      ALLOCATE(Qav(Nr0,NT0))
      Qav(:,:) = Qav0(1,:,:)
    END IF
    IF (PRESENT(gsca)) THEN
      ALLOCATE(gsca(Nr0,Nw0))
      gsca(:,:) = gsca0(1,:,:)
    END IF
  END SUBROUTINE read_optics_scl

END MODULE grain_optics


      subroutine SGEFS(A,LDA,N,B,LDB,NB,IPVT,INFO)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SGEFS  Krogh   Declared all vars.
C>> 1994-10-20 SGEFS  Krogh  Changes to use M77CON
C>> 1987-08-18 SGEFS  Lawson  Initial code.
c--S replaces "?": ?GEFS, ?GEFA, ?GESLD
c
c     Solves a system of linear equations,  A * X = B,
c     where A is a square nonsingular matrix of order N and B is an
c     N by NB matrix.  The solution is the N by NB matrix X that will
c     be stored on return in place of B in the array B().
c     ------------------------------------------------------------------
c     Uses subroutines derived from LINPACK.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted for the JPL Math77 library by C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
c                    Subroutine arguments
c
c     A(,)  [inout]  On entry contains the N by N matrix A.
c           On return contains the LU factorization of A as computed by
c           LINPACK subroutines.
c
c     LDA  [in]  Leading dimensioning parameter for the array A(,).
c           Require LDA .ge. N.
c
c     N  [in]  The order of the matrix A and number of rows in the
c           matrices B and X.
c
c     B(,)  [inout]  On entry contains the N by NB matrix, B.  On return
c           contains the N by NB solution matrix, X.  Could be a
c           Singly subscripted array if NB .eq. 1.
c
c     LDB  [in]  Leading dimensioning parameter for the array B(,).
c           Require LDB .ge. N.
c
c     NB  [in]  Number of columns in the matrices B and X.  If NB .lt. 1
c           the matrix, A, will be factored but no reference will be
c           made to the array B(,).
c
c     IPVT()  [out]  Integer array of length at least N.  On return will
c           contain a record of the row interchanges done during
c           factorization of A.
c
c     INFO  [out]  Set to zero if all diagonal elements in the U matrix
c           of the LU factorization are found to be nonzero.  If nonzero
c           it is the index of the first diagonal element of U that was
c           found to be zero.  In this latter case the solution X will
c           not be computed.
c     ------------------------------------------------------------------
c     Subprograms called: SGEFA, SGESLD
c     ------------------------------------------------------------------
      integer LDA, N, LDB, NB, IPVT(N), INFO, J
      real             A(LDA,N), B(LDB,*)
c     ------------------------------------------------------------------
      call SGEFA(A,LDA,N,IPVT,INFO)
      if( INFO .ne. 0) return
      do 10 J = 1,NB
         call SGESLD(A,LDA,N,IPVT,B(1,J))
   10 continue
      return
      END


PROGRAM TI_Schrod
  USE NumParameters_m
  USE Basis_m
  USE psi_m
  USE op_m
  IMPLICIT NONE

  TYPE (Basis_t), target :: Basis
  TYPE (psi_t)           :: psi,Hpsi
  TYPE (op_t)            :: H

  !====================================================================
  ! read some informations (basis set/grid) : numbers of basis functions, grid points ...
  ! the basis/grid informations have to be put in a module
  CALL Read_Basis(Basis,nio=in_unitp)
  !====================================================================

  write(out_unitp,*) 'Initialization of a real psi'

  CALL init_psi(psi,Basis,cplx=.FALSE.) ! to be changed
  psi%RVec(:) = ONE
  CALL Write_psi(psi)

  write(out_unitp,*) 'Initialization of a complex psi'
  CALL init_psi(psi,Basis,cplx=.TRUE.) ! to be changed
  psi%CVec(:) = CONE
  CALL Write_psi(psi)

  write(out_unitp,*) ' | H | Psi > calculation'
  CALL Set_op(H,Basis) ! to be change
  CALL calc_OpPsi(H,psi,Hpsi)
  CALL Write_psi(Hpsi)

  write(out_unitp,*) 'deallocation'
  CALL dealloc_Op(H)
  CALL dealloc_psi(psi)
  CALL dealloc_psi(Hpsi)

END PROGRAM TI_Schrod


!==============================================================================!
!                                    neu_hex                                   !
!                                                                              !
!                      7-----------8             7-----------8                 !
!                     /|          /|            /|          /|                 !
!                    /           / |           /    (6)    / |                 !
!                   /  |    (3) /  |          /  |        /  |                 !
!                  5-----------6   |         5-----------6   |                 !
!                  |(4)|       |(2)|         |   |       |   |                 !
!                  |   3- - - -|- -4         |   3- - - -|- -4                 !
!                  |  / (1)    |  /          |  /        |  /                  !
!                  |           | /           |      (5)  | /                   !
!                  |/          |/            |/          |/                    !
!                  1-----------2             1-----------2                     !
!                                                                              !
!                  (3) and (4) are behind                                      !
!------------------------------------------------------------------------------!
!                                   neu_tet                                    !
!                                                                              !
!                          4-----3                   4-----3                   !
!                         / \  .'|                  / \  .'|                   !
!                        /(4)\(3)|                 /   \'  |                   !
!                       /  .' \  |                /  .' \  |                   !
!                      / .' (1)\ |               / .(2)  \ |                   !
!                     /.'       \|              /.'       \|                   !
!                    1-----------2             1-----------2                   !
!                                                                              !
!                    (1) and (4) are behind                                    !
!------------------------------------------------------------------------------!
!                                  neu_wed                                     !
!                                                                              !
!                        6.                        6.                          !
!                       /| `.                     /| `.                        !
!                      /     `.                  / (5) `.                      !
!                     /  |     `.               /  |     `.                    !
!                    4-----------5             4-----------5                   !
!                    |(3)|  (2)  |             |   |       |                   !
!                    |   3.      |             |   3.      |                   !
!                    |  / (1)    |             |  /  `.    |                   !
!                    |       `.  |             |   (4) `.  |                   !
!                    |/        `.|             |/        `.|                   !
!                    1-----------2             1-----------2                   !
!                                                                              !
!                    (2), (3) and (4) are behind                               !
!                                                                              !
!------------------------------------------------------------------------------!
!                                   neu_pyr                                    !
!                                                                              !
!                                     .5.                                      !
!                                   .'/ \`.                                    !
!                                 .' /   \ `.                                  !
!                               .'  / (4) \  `.                                !
!                             .'(5)/       \(3)`.                              !
!                           3' - -/- - - - -\- - `4                            !
!                           |    /    (2)    \    |                            !
!                           |   /             \   |                            !
!                           |  /      (1)      \  |                            !
!                           | /                 \ |                            !
!                           |/                   \|                            !
!                           1---------------------2                            !
!                                                                              !
!                           (4) is behind                                      !
!                                                                              !
!------------------------------------------------------------------------------!
!   Note:
!
!   neu_tet, neu_pyr, neu_wed and neu_hex hold -1 where unused
!==============================================================================!

  ! tet cell faces nodal connections
  integer, parameter, dimension(6, 4) ::      neu_tet =           &
                               transpose(reshape( (/ 1, 2, 3,-1,  &
                                                     1, 4, 2,-1,  &
                                                     2, 4, 3,-1,  &
                                                     3, 4, 1,-1,  &
                                                    -1,-1,-1,-1,  &
                                                    -1,-1,-1,-1  /), (/4, 6/) ))

  ! hex cell faces nodal connections
  integer, parameter, dimension(6, 4) ::     neu_hex =            &
                               transpose(reshape( (/ 1, 5, 6, 2,  &
                                                     2, 6, 8, 4,  &
                                                     4, 8, 7, 3,  &
                                                     3, 7, 5, 1,  &
                                                     1, 2, 4, 3,  &
                                                     5, 7, 8, 6  /), (/4, 6/) ))

  ! wed cell faces nodal connections
  integer, parameter, dimension(6, 4) ::     neu_wed =            &
                               transpose(reshape( (/ 1, 4, 5, 2,  &
                                                     2, 5, 6, 3,  &
                                                     3, 6, 4, 1,  &
                                                     1, 2, 3,-1,  &
                                                     4, 6, 5,-1,  &
                                                    -1,-1,-1,-1  /), (/4, 6/) ))

  ! pyr cell faces nodal connections
  integer, parameter, dimension(6, 4) ::     neu_pyr =            &
                               transpose(reshape( (/ 1, 2, 4, 3,  &
                                                     1, 5, 2,-1,  &
                                                     2, 5, 4,-1,  &
                                                     4, 5, 3,-1,  &
                                                     3, 5, 1,-1,  &
                                                    -1,-1,-1,-1  /), (/4, 6/) ))


p(1,2).
p(2,4).
p(3,6).
p(4,8).


C
C	$Id$
C
      SUBROUTINE CSGETNP (X,Y,Z,LIST,LPTR,LEND,L, NPTS, DF,
     .                  IER)
      INTEGER LIST(*), LPTR(*), LEND(*), L, NPTS(L), IER
      DOUBLE PRECISION X(*), Y(*), Z(*), DF
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/28/98
C
C   Given a Delaunay triangulation of N nodes on the unit
C sphere and an array NPTS containing the indexes of L-1
C nodes ordered by angular distance from NPTS(1), this sub-
C routine sets NPTS(L) to the index of the next node in the
C sequence -- the node, other than NPTS(1),...,NPTS(L-1),
C that is closest to NPTS(1).  Thus, the ordered sequence
C of K closest nodes to N1 (including N1) may be determined
C by K-1 calls to CSGETNP with NPTS(1) = N1 and L = 2,3,...,K
C for K .GE. 2.
C
C   The algorithm uses the property of a Delaunay triangula-
C tion that the K-th closest node to N1 is a neighbor of one
C of the K-1 closest nodes to N1.
C
C
C On input:
C
C       X,Y,Z = Arrays of length N containing the Cartesian
C               coordinates of the nodes.
C
C       LIST,LPTR,LEND = Triangulation data structure.  Re-
C                        fer to Subroutine CSTRMESH.
C
C       L = Number of nodes in the sequence on output.  2
C           .LE. L .LE. N.
C
C The above parameters are not altered by this routine.
C
C       NPTS = Array of length .GE. L containing the indexes
C              of the L-1 closest nodes to NPTS(1) in the
C              first L-1 locations.
C
C On output:
C
C       NPTS = Array updated with the index of the L-th
C              closest node to NPTS(1) in position L unless
C              IER = 1.
C
C       DF = Value of an increasing function (negative cos-
C            ine) of the angular distance between NPTS(1)
C            and NPTS(L) unless IER = 1.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if L < 2.
C
C Modules required by CSGETNP:  None
C
C Intrinsic function called by CSGETNP:  ABS
C
C***********************************************************
C
      INTEGER I, LM1, LP, LPL, N1, NB, NI, NP
      DOUBLE PRECISION DNB, DNP, X1, Y1, Z1
C
C Local parameters:
C
C DNB,DNP =  Negative cosines of the angular distances from
C              N1 to NB and to NP, respectively
C I =        NPTS index and DO-loop index
C LM1 =      L-1
C LP =       LIST pointer of a neighbor of NI
C LPL =      Pointer to the last neighbor of NI
C N1 =       NPTS(1)
C NB =       Neighbor of NI and candidate for NP
C NI =       NPTS(I)
C NP =       Candidate for NPTS(L)
C X1,Y1,Z1 = Coordinates of N1
C
      LM1 = L - 1
      IF (LM1 .LT. 1) GO TO 6
      IER = 0
C
C Store N1 = NPTS(1) and mark the elements of NPTS.
C
      N1 = NPTS(1)
      X1 = X(N1)
      Y1 = Y(N1)
      Z1 = Z(N1)
      DO 1 I = 1,LM1
        NI = NPTS(I)
        LEND(NI) = -LEND(NI)
    1   CONTINUE
C
C Candidates for NP = NPTS(L) are the unmarked neighbors
C   of nodes in NPTS.  DNP is initially greater than -cos(PI)
C   (the maximum distance).
C
      DNP = 2.D0
C
C Loop on nodes NI in NPTS.
C
      DO 4 I = 1,LM1
        NI = NPTS(I)
        LPL = -LEND(NI)
        LP = LPL
C
C Loop on neighbors NB of NI.
C
    2   NB = ABS(LIST(LP))
          IF (LEND(NB) .LT. 0) GO TO 3
C
C NB is an unmarked neighbor of NI.  Replace NP if NB is
C   closer to N1.
C
          DNB = -(X(NB)*X1 + Y(NB)*Y1 + Z(NB)*Z1)
          IF (DNB .GE. DNP) GO TO 3
          NP = NB
          DNP = DNB
    3     LP = LPTR(LP)
          IF (LP .NE. LPL) GO TO 2
    4   CONTINUE
      NPTS(L) = NP
      DF = DNP
C
C Unmark the elements of NPTS.
C
      DO 5 I = 1,LM1
        NI = NPTS(I)
        LEND(NI) = -LEND(NI)
    5   CONTINUE
      RETURN
C
C L is outside its valid range.
C
    6 IER = 1
      RETURN
      END


      MODULE LapackInterface
      IMPLICIT NONE

!  -- suggested from http://www.siam.org/books/ot134 Numerical Computing with Modern Fortran Richard J.Hanson and Tim Hopkins SIAM
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016

        INTERFACE

         SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )

!     .. Scalar Arguments ..
         CHARACTER          JOBZ, UPLO
         INTEGER            INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
         DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * )
         END SUBROUTINE DSYEV

         SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!     .. Scalar Arguments ..
         INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
         INTEGER            IPIV( * )
         DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
         END SUBROUTINE DGESV

          SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
!     .. Scalar Arguments ..
          INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
          INTEGER            IPIV( * )
          DOUBLE PRECISION   A( LDA, * )
          END SUBROUTINE DGETRF

          SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!     .. Scalar Arguments ..
          CHARACTER          TRANS
          INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
          INTEGER            IPIV( * )
          DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
          END SUBROUTINE DGETRS

          SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
!      .. Scalar Arguments ..
          INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
!      ..
!      .. Array Arguments ..
          INTEGER            IPIV( * )
          DOUBLE PRECISION   AB( ldab, * ), B( ldb, * )

          END SUBROUTINE DGBSV

          SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
!      .. Scalar Arguments ..
          INTEGER            INFO, LDA, LWORK, N
!       ..
!       .. Array Arguments ..
          INTEGER            IPIV( * )
          DOUBLE PRECISION   A( LDA, * ), WORK( * )
          END SUBROUTINE DGETRI

          SUBROUTINE XERBLA( SRNAME, INFO )
!         .. Scalar Arguments ..
          CHARACTER*6        SRNAME
          INTEGER            INFO
          END SUBROUTINE XERBLA

          SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
!         .. Scalar Arguments ..
          DOUBLE PRECISION ALPHA,BETA
          INTEGER K,LDA,LDB,LDC,M,N
          CHARACTER TRANSA,TRANSB
!         .. Array Arguments ..
          DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
          END SUBROUTINE DGEMM

          SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
!         .. Scalar Arguments ..
          DOUBLE PRECISION ALPHA,BETA
          INTEGER INCX,INCY,LDA,M,N
          CHARACTER TRANS
!         .. Array Arguments ..
          DOUBLE PRECISION A(LDA,*),X(*),Y(*)
          END SUBROUTINE DGEMV

        END INTERFACE

      END MODULE LapackInterface


           program demo_minexponent
           implicit none
           real(kind=4) :: x
           real(kind=8) :: y
              print *, minexponent(x), maxexponent(x)
              print *, minexponent(y), maxexponent(y)
           end program demo_minexponent


#! Demonstrates the usage of simple tests.

#:include 'fytest.fypp'

#:block TEST_SUITE('simple')
  use mymath
  implicit none

#:contains

  #! Testing for various special factorial values

  #:block TEST('1')
    @:ASSERT(factorial(1) == 1)
  #:endblock

  #:block TEST('5')
    @:ASSERT(factorial(5) == 120)
  #:endblock

  #:block TEST('6')
    @:ASSERT(factorial(6) == 720)
  #:endblock

  #! This one will fail in order to demonstrate test failing

  #:block TEST('0_failing')
    @:ASSERT(factorial(0) == 0)
  #:endblock

  #! This should pass again

  #:block TEST('7')
    @:ASSERT(factorial(7) == 5040)
  #:endblock

#:endblock TEST_SUITE

@:TEST_DRIVER()


program test_sort
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use testing, only:assert, initialize_tests, report_tests
use functional

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, ntests
real(real32), dimension(1000) :: x

n = 1
ntests = 13
call initialize_tests(tests, ntests)

tests(n) = assert(all(sort([3_int8, 2_int8, 1_int8]) == [1, 2, 3]), &
                  'sort,  int8')
n = n + 1

tests(n) = assert(all(sort([3_int16, 2_int16, 1_int16]) == [1, 2, 3]), &
                  'sort,  int16')
n = n + 1

tests(n) = assert(all(sort([3_int32, 2_int32, 1_int32]) == [1, 2, 3]), &
                  'sort,  int32')
n = n + 1

tests(n) = assert(all(sort([3_int64, 2_int64, 1_int64]) == [1, 2, 3]), &
                  'sort,  int8')
n = n + 1

tests(n) = assert(all(sort([3._real32, 2._real32, 1._real32]) == [1, 2, 3]), &
                  'sort,  real32')
n = n + 1

tests(n) = assert(all(sort([3._real64, 2._real64, 1._real64]) == [1, 2, 3]), &
                  'sort,  real64')
n = n + 1

tests(n) = assert(all(sort([3._real128, 2._real128, 1._real128]) == [1, 2, 3]), &
                  'sort,  real128')
n = n + 1

tests(n) = assert(all(sort(arange(cmplx(3._real32, 0._real32), &
                                  cmplx(1._real32, 0._real32), &
                                  cmplx(-1._real32, 0._real32)))&
                        == arange(cmplx(1._real32, 0._real32), &
                                  cmplx(3._real32, 0._real32))), &
                  'sort,  complex real32')
n = n + 1

tests(n) = assert(all(sort(arange(cmplx(3._real64, 0._real64), &
                                  cmplx(1._real64, 0._real64), &
                                  cmplx(-1._real64, 0._real64)))&
                        == arange(cmplx(1._real64, 0._real64), &
                                  cmplx(3._real64, 0._real64))), &
                  'sort,  complex real64')
n = n + 1

tests(n) = assert(all(sort(arange(cmplx(3._real128, 0._real128), &
                                  cmplx(1._real128, 0._real128), &
                                  cmplx(-1._real128, 0._real128)))&
                        == arange(cmplx(1._real128, 0._real128), &
                                  cmplx(3._real128, 0._real128))), &
                  'sort,  complex real128')
n = n + 1

tests(n) = assert(sort('Sorted') == 'Sdeort', 'sort, character string')
n = n + 1

call random_number(x)
tests(n) = assert(all(tail(sort(x)) >= init(sort(x))), &
                  'all(tail(sort(x)) >= init(sort(x))')
n = n + 1

tests(n) = assert(all(sort(x) == .sort.x), &
                  'sort operator,  .sort.x')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_sort


  !! ----------------------------------------------------------------------- !!
  !>
  !! model size parameter setting
  !<
  !! --
  block

    nx = 400
    ny = 400
    nt = 2000

    title = 'tsunami'

    dx = 500.0
    dy = 500.0
    dt = 1.0

    dxi = 1.0 / dx
    dyi = 1.0 / dy

    xbeg = 0.0
    ybeg = 0.0

  end block


program tests
  implicit none
  integer :: n_trial = 3
  character(len=50) :: results_file_name = 'src/languages/fortran/results.data'
  real :: t0, t1, t_branched, t_branchless

  !--------------num_thresh-------------
  integer :: n = 1e9
  real :: thresh = 0.5
  integer :: n_gt_branched, n_gt_branchless
  integer :: i_trial, i
  integer :: log_int !intermediate variable for logical to int conversion
  real, allocatable, dimension(:) :: v
  allocate(v(n))
  call random_number(v) !fill v with random numbers

  !branched
  call cpu_time(t0)
  do i_trial=1,n_trial !run n_trial trials
    n_gt_branched = 0
    do i=1,n
        if (v(i) > thresh) then
            n_gt_branched = n_gt_branched + 1
        end if
    end do
  end do
  call cpu_time(t1)
  t_branched = t1 - t0

  !branchless
  call cpu_time(t0)
  do i_trial=1,n_trial !run n_trial trials
    n_gt_branchless = 0
    do i=1,n
        log_int = (v(i) > thresh)
        n_gt_branchless = n_gt_branchless + log_int
    end do
  end do
  call cpu_time(t1)
  t_branchless = t1 - t0

  if (n_gt_branched /= n_gt_branchless) then
     print *, 'ERROR: branched and branchless implementations give different results'
  end if

  !write test result to file
  open (unit = 9, file = results_file_name)
  write(9,*) 'num_thresh  ', t_branchless/t_branched
  close(unit = 9)
  !-------------------------------------

end program tests


integer :: i
integer, dimension(10) :: v

forall (i=1:size(v)) v(i) = i


!
! Profile_Utility module
!
! Container module for all the Profile_Utility modules and dependencies.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 05-May-2006
!                       paul.vandelst@ssec.wisc.edu
!

MODULE Profile_Utility
  ! The Utility modules
  USE Type_Kinds
  USE File_Utility
  USE Message_Handler
  USE Fundamental_Constants
  USE Compare_Float_Numbers
  ! The Profile_Utility modules
  USE Atmospheric_Properties
  USE Geopotential
  USE Level_Layer_Conversion
  USE Profile_Utility_Parameters
  USE Units_Conversion
  PUBLIC
END MODULE Profile_Utility


C     SUBROUTINE CFFTI(N,WSAVE)
C
C     SUBROUTINE CFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH CFFTF AND CFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C     STORED IN WSAVE.
C
C     INPUT PARAMETER
C
C     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED
C
C     OUTPUT PARAMETER
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH CFFTF AND CFFTB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF CFFTF OR CFFTB.
C
      SUBROUTINE CFFTI(N,WSAVE)
      DOUBLE PRECISION WSAVE
      DIMENSION WSAVE(*)
C
      IF (N.EQ.1) RETURN
      IW1 = N + N + 1
      IW2 = IW1 + N + N
      CALL CFFTI1(N,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END


module spectral_data
! spectral model state variable data
! Public subroutines:
! init_specdata: allocate arrays.
! destroy_specdata: deallocate arrays.
 use kinds, only: r_kind
 use params, only: ndimspec, nlevs, ntrac
 use iso_c_binding
 implicit none
 private
 public :: init_specdata,destroy_specdata
 complex(r_kind), public, dimension(:,:), pointer :: &
 vrtspec,divspec,virtempspec
 complex(r_kind), public, dimension(:,:,:), pointer :: tracerspec
! ndimspec by nlevs complex arrays (ndimspec = (ntrunc+1)*(ntrunc)/2):
! these arrays are update each timestep in subroutine advance in run.f90.
! vrtspec: vorticity
! divspec: divergence
! virtempspec: virtural temp
! tracerspec: tracers (ntrac=1 is  specific humidity, ntrac=ntoz ozone, ntrac=ntclw cloud
! condensate)
 complex(r_kind), public, dimension(:), pointer :: lnpsspec,topospec
 real(r_kind), public, dimension(:), pointer :: disspec,diff_prof,dmp_prof
! ndimspec 1-d arrays:
! lnpsspec: log(ps) in Pa
! topospec: orography in meters (static, created in init_dyn)
! disspec: hyperdiffusion operator (static, created in init_dyn)
! diff_prof: vertical profile of hyperdiffusion coefficient.
! dmp_prof: vertical profile of linear momentum drag (active
! at top of model).

 contains
!
! Modifying the specdata init routines to accept arrays from python
 subroutine init_specdata(pyVrtSpec, pyDivSpec, pyVirtTempSpec, pyTracerSpec, &
         pyTopoSpec, pyLnPsSpec, pyDissSpec, pyDmpProf, pyDiffProf) &
            bind(c, name='gfs_initialise_spectral_arrays')

    complex(c_double_complex), target, intent(inout) :: pyVrtSpec(ndimspec,nlevs), &
    pyDivSpec(ndimspec, nlevs), pyVirtTempSpec(ndimspec, nlevs), &
    pyTracerSpec(ndimspec, nlevs, ntrac), pyTopoSpec(ndimspec), &
    pyLnPsSpec(ndimspec)

    real(c_double), target, intent(inout) :: pyDmpProf(nlevs), &
            pyDiffProf(nlevs), pyDissSpec(ndimspec)

    !print *, "initialising Spectral arrays"
    !print *, shape(pyVrtSpec), shape(pyTracerSpec)

    vrtspec => pyVrtSpec
    divspec => pyDivSpec
    tracerspec => pyTracerSpec
    virtempspec => pyVirtTempSpec

    topospec => pyTopoSpec
    lnpsspec => pyLnPsSpec

    disspec => pyDissSpec
    dmp_prof => pyDmpProf
    diff_prof => pyDiffProf

 end subroutine init_specdata
 subroutine destroy_specdata()
    !print *, 'Deallocating spectral data'
    nullify(vrtspec,divspec,virtempspec)
    nullify(tracerspec)
    nullify(topospec,lnpsspec,disspec,dmp_prof,diff_prof)
 end subroutine destroy_specdata

end module spectral_data