!-----------------------------------------------------------------------
!     Subroutine:    cyl2suv
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          12/15/2011
!     Description:   This subroutine takes a set of vectors in
!                    cylindrical (R,phi,Z) coordinates and calculates
!                    their curvilinear (s,u,v) components.
!-----------------------------------------------------------------------
      SUBROUTINE cyl2suv(k1,k2,nu,nv,r,ar,aphi,az,as,au,av,factor)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY : rprec
      USE pies_realspace, ONLY : rs, zs, ru, zu, rv, zv
!-----------------------------------------------------------------------
!     Input Parameters
!          k1           Starting index of surfaces
!          k2           Ending index of surfaces
!          nu           Number of Poloidal points
!          nv           Number of toroidal points
!          r            R-Vector
!          ar           R-hat component of vector
!          aphi         Phi-hat component of vector
!          az           Z-hat component of vector
!          as           s component of vector
!          au           u component of vector
!          av           v component of vector
!          factor       dphi/dv scaling factor (optional)
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER, INTENT(in)     :: k1
      INTEGER, INTENT(in)     :: k2
      INTEGER, INTENT(in)     :: nu
      INTEGER, INTENT(in)     :: nv
      REAL(rprec), INTENT(in) :: r(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(in) :: ar(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(in) :: aphi(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(in) :: az(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(out) :: as(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(out) :: au(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(out) :: av(k1:k2,1:nu,1:nv)
      REAL(rprec), INTENT(in)  :: factor
!-----------------------------------------------------------------------
!     Local Variables
!          detinv       Inverse of the determinant
!-----------------------------------------------------------------------
      REAL(rprec) ::  detinv(k1:k2,1:nu,1:nv)
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      av(k1:k2,:,:)     = aphi(k1:k2,:,:)/r(k1:k2,:,:)
      av = av / factor
      detinv(k1:k2,:,:) = 1./(rs(k1:k2,:,:)*zu(k1:k2,:,:)-zs(k1:k2,:,:)*ru(k1:k2,:,:))
      as(k1:k2,:,:)     = detinv(k1:k2,:,:)*( zu(k1:k2,:,:)*(ar(k1:k2,:,:)-av(k1:k2,:,:)*rv(k1:k2,:,:))&
                                             -ru(k1:k2,:,:)*(az(k1:k2,:,:)-av(k1:k2,:,:)*zv(k1:k2,:,:)))
      au(k1:k2,:,:)     = detinv(k1:k2,:,:)*(-zs(k1:k2,:,:)*(ar(k1:k2,:,:)-av(k1:k2,:,:)*rv(k1:k2,:,:))&
                                             +rs(k1:k2,:,:)*(az(k1:k2,:,:)-av(k1:k2,:,:)*zv(k1:k2,:,:)))

!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE cyl2suv


PROGRAM main

  USE mo_kind, ONLY: dp, sp
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_mad,  ONLY: mad

  IMPLICIT NONE

  REAL(dp), DIMENSION(26) :: dat
  REAL(sp), DIMENSION(26) :: sat
  LOGICAL,  DIMENSION(26) :: mask, sollmask, mask2

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_mad.f90'

  ! Double precision
  isgood = .true.
  dat = (/ -0.25,0.68,0.94,1.15,2.26,2.35,2.37,2.40,2.47,2.54,2.62, &
       2.64,2.90,2.92,2.92,2.93,3.21,3.26,3.30,3.59,3.68,4.30, &
       4.64,5.34,5.42,8.01 /)
  sollmask(:) = .true.
  mask        = mad(dat)
  if (any(mask .neqv. sollmask)) isgood = .false.
  sollmask(26) = .false.
  mask         = mad(dat,z=4._dp)
  if (any(mask .neqv. sollmask)) isgood = .false.
  sollmask(25) = .false.
  sollmask(1)  = .false.
  mask         = mad(dat,z=3._dp)
  if (any(mask .neqv. sollmask)) isgood = .false.
  sollmask(:)  = .true.
  sollmask(25) = .false.
  mask         = mad(dat,z=4._dp,deriv=2)
  if (any(mask .neqv. sollmask)) isgood = .false.
  sollmask(:)  = .true.
  sollmask(1)  = .false.
  sollmask(25) = .false.
  sollmask(26) = .false.
  mask(:)      = .true.
  mask(1)      = .false.
  mask2        = mad(dat,z=3._dp)
  mask         = mask .and. mask2
  if (any(mask .neqv. sollmask)) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_mad double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_mad double precision ', color('failed!', c_red)
  endif

  ! Single precision
  isgood = .true.
  sat = (/ -0.25,0.68,0.94,1.15,2.26,2.35,2.37,2.40,2.47,2.54,2.62, &
       2.64,2.90,2.92,2.92,2.93,3.21,3.26,3.30,3.59,3.68,4.30, &
       4.64,5.34,5.42,8.01 /)
  sollmask(:) = .true.
  mask        = mad(sat)
  if (.not. all(mask .eqv. sollmask)) isgood = .false.
  sollmask(26) = .false.
  mask         = mad(sat,z=4._sp)
  if (.not. all(mask .eqv. sollmask)) isgood = .false.
  sollmask(25) = .false.
  sollmask(1)  = .false.
  mask         = mad(sat,z=3._sp)
  if (.not. all(mask .eqv. sollmask)) isgood = .false.
  sollmask(:)  = .true.
  sollmask(25) = .false.
  mask         = mad(sat,z=4._sp,deriv=2)
  if (.not. all(mask .eqv. sollmask)) isgood = .false.
  sollmask(:)  = .true.
  sollmask(1)  = .false.
  sollmask(25) = .false.
  sollmask(26) = .false.
  mask(:)      = .true.
  mask(1)      = .false.
  mask2        = mad(sat, z=3._sp)
  mask         = mask .and. mask2
  if (.not. all(mask .eqv. sollmask)) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_mad single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_mad single precision ', color('failed!', c_red)
  endif

END PROGRAM main


      SUBROUTINE RODS
C
C     THIS ROUTINE PROCESSES ROD ELEMENT DATA TO PRODUCE STIFFNESS AND
C     MASS MATRICES. IF THE HEAT TRANSFER OPTION IS ON, CONDUCTIVITY AND
C     CAPACITY MATRICES ARE PRODUCED
C
C     THIS ROUTINE CAN COMPUTE BOTH CONVENTIONAL AND CONSISTENT
C     MASS MATRICES
C
C     SINGLE PRECISION VERSION
C
C     THIS VERSION WAS SPECIALLY CODED TO ILLUSTRATE A GENERAL
C     USE OF THE IMPROVED MATRIX GENERATOR.
C
C     THE EST ENTRY FOR THIS ELEMENT CONTAINS
C
C     POSITION     NAME       DESCRIPTION
C     *****        *****      *******************************
C     1             EID       ELEMENT ID NO.
C     2             SIL1      SCALAR INDEX OF POINT A
C     3             SIL2      SCALAR INDEX OF POINT B
C     4             MID       MATERIAL DATA ID
C     5             AFACT     AREA OF CROSS SECTION
C     6             JFACT     TORSIONAL STIFFNESS COEFFICIENT
C     7             CFACT     TORSIONAL STRESS RECOVERY DISTANCE
C     8             MU        NON-STRUCTURAL MASS PER LENGTH
C     9-16          BGPDT     BASIC GRID POINT DATA. COORDINATE SYSTEM
C                             NUMBER AND  X,Y,Z LOCATION FOR 2 POINTS
C     17            TBAR      AVERAGE ELEMENT TEMPERATURE
C
C
      LOGICAL         NOGO
      INTEGER         SIL1     ,SIL2     ,IEST(13)  ,EID     ,GE       ,
     1                DICT(7)  ,ELID     ,ESTID
      REAL            JFACT    ,MU       ,KCON     ,EST(200) ,K        ,
     1                EVECT(3) ,EL       ,KE       ,ME       ,TE       ,
     2                HA(3)    ,HB(3)    ,KHA(3)   ,KHB(3)   ,TA(9)    ,
     3                TB(9)    ,SCALE
      REAL            MASSII(9),MASSJJ(9),MASSIJ(9),MASSJI(9),MIJDUM(9),
     1                MJIDUM(9)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /MATIN / MATID    ,INFLAG   ,ELTEMP   ,DUM(3)
      COMMON /MATOUT/ E        ,G        ,NU       ,RHO      ,ALFA     ,
     1                TSUB0    ,GE
      COMMON /HMTOUT/ KCON
      COMMON /EMGPRM/ IXTRA    ,IZR      ,NZR      ,DUMY(12) ,KMBGG(3) ,
     1                IPREC    ,NOGO     ,HEAT     ,ICMBAR
      COMMON /EMGDIC/ DUM2(2)  ,NLOCS    ,ELID     ,ESTID
      COMMON /ZZZZZZ/ K(1)
C
C     THE VARIABLE K IS OPEN CORE. OPEN SPACE EXISTS FROM Z(IZ) TO Z(NZ)
C     THIS IS INTENDED AS AN EXAMPLE. NORMALLY FOR SMALL ARRAYS
C     LOCAL VARIABLES MAY BE USED.
C
      COMMON /EMGEST/ EID      ,SIL1     ,SIL2     ,MID      ,AFACT    ,
     1                JFACT    ,CFACT    ,MU       ,BGPDT(4,2),TBAR
      COMMON /SYSTEM/ KSYSTM(63)
      EQUIVALENCE     (KSYSTM( 2),IOUTPT),(KSYSTM(56),IHEAT) ,
     1                (EID,EST(1),IEST(1)),(CP,KCON)
C
C     FOR DOUBLE PRECISION THE POINTERS TO OPEN CORE MUST BE MODIFIED.
C
      IZ = (IZR-2)/IPREC + 2
      NZ = NZR/IPREC
      IF (NZ -IZ .LE. 144) GO TO 290
      DICT(1) = ESTID
C
C     SUBTRACT BASIC LOCATIONS TO OBTAIN LENGTH ETC.
C
      DO 10 I = 1,3
   10 EVECT(I) = BGPDT(I+1,2) - BGPDT(I+1,1)
C
      EL = SQRT(EVECT(1)**2 + EVECT(2)**2 + EVECT(3)**2)
      IF (EL .LE. 0.0) GO TO 270
C
C     IF HEAT TRANSFER PROBLEM TRANSFER.  CALL MATERIAL SUBROUTINE
C
      INFLAG = 1
      MATID  = MID
      ELTEMP = TBAR
      IF (IHEAT .EQ. 1) GO TO 240
      CALL MAT (EID)
      KE = (E*AFACT)/EL
      ME = (RHO*AFACT+MU)*EL/2.0
      TE = (G*JFACT)/EL
C
C     PROCESS STIFFNESS HERE
C
      IF (KMBGG(1) .EQ. 0) GO TO 220
      IF (KE.EQ.0.0 .AND. TE.EQ.0.) GO TO 220
C
C     GENERATE   HA  =  (E*TA)/EL   AND  HB = (E*TB)/EL
C
      IF (IEST(9).EQ. 0) GO TO 30
      CALL TRANSS (BGPDT(1,1),TA)
      CALL GMMATS (EVECT,1,3,0, TA,3,3,0, HA)
      DO 20 I = 1,3
   20 HA(I) = HA(I)/EL
      GO TO 50
   30 DO 40 I = 1,3
   40 HA(I) = EVECT(I)/EL
   50 IF (IEST(13).EQ. 0) GO TO 70
      CALL TRANSS (BGPDT(1,2),TB)
      CALL GMMATS (EVECT,1,3,0, TB,3,3,0, HB)
      DO 60 I = 1,3
   60 HB(I) = HB(I)/EL
      GO TO 90
   70 DO 80 I = 1,3
   80 HB(I) = EVECT(I)/EL
C
C     THE GENERAL 12X12  MATRIX FOR THE ROD ELEMENT IS
C                             -                            -
C                            1HA K HA1   0  1HA K HB1       1
C                **   **     1 ------1------1-------1-------1
C                *  K  *   = 1   0   1HA T A1       1HA T HB1
C                **   **     1 ------1------1-------1-------1
C                            1HB K HA       1HB K HB1       1
C                            1 ------1------1-------1-------1
C                            1       1HB T A1       1HB T HB1
C                            1       1      1       1       1
C                             -                            -
C                      EACH BLOCK  ABOVE IS A 3 BY 3 MATRIX
C
C     TEST AND SET COMPONENT CODE    111= 7     111000=56
C
   90 ICODE = 0
      NDOF  = 0
      IF (TE .NE. 0.) GO TO 100
      ICODE = 7
      NDOF  = 6
      GO TO 120
  100 IF (KE .NE. 0.) GO TO 110
      ICODE = 56
      NDOF  = 6
      GO TO 120
  110 ICODE = 63
      NDOF  = 12
  120 NSQ   = NDOF**2
      NG    = NDOF/2
      NPART = NG*NDOF
      IZERO = IZ -1
      IPASS = 1
      DO  130 I = 1,NSQ
      IZPI  = IZ + I - 1
  130 K(IZPI) = 0.0
C
C     EXTENSIONAL STIFFNESS TERMS ARE COMPUTED HERE.
C
      IF (ICODE .EQ. 56) GO TO 200
      SCALE = KE
  140 DO 150 I = 1,3
      KHA(I) = SCALE*HA(I)
  150 KHB(I) = SCALE*HB(I)
C
C     THE MATRIX COLUMNS AND ROWS MUST BE IN THE NUMERICAL ORDER
C     OF TH SIL VALUES. THE POINTERS INTO THE MATRIX ARE VARIABLES.
C
      IF (SIL2-SIL1) 160,270,170
  160 IBBZ = IZERO
      IABZ = IZERO + NG
      IBAZ = IZERO + NPART
      IAAZ = IBAZ  + NG
      GO TO 180
  170 IAAZ = IZERO
      IBAZ = IZERO + NG
      IABZ = IZERO + NPART
      IBBZ = IABZ  + NG
  180 CONTINUE
      DO 190 J = 1,3
      DO 190 I = 1,3
      IJ   = NDOF*(J-1) + I
      IAA  = IJ + IAAZ
      K(IAA) = KHA(I)*HA(J)
      IBA  = IJ + IBAZ
      K(IBA) =-KHB(I)*HA(J)
      IAB  = IJ + IABZ
      K(IAB) =-KHA(I)* HB(J)
      IBB  = IJ + IBBZ
      K(IBB) = KHB(I)* HB(J)
  190 CONTINUE
C
C     THE TORSIONAL STIFFNESS TERMS ARE FORMED USING TE INSTEAD OF KE
C     THEY ARE INSERTED IN THE MATRIX WITH  A CONSTANT OFFSET, 3*12+3.
C
  200 IF (IPASS .EQ. 2) GO TO 210
      IF (NDOF .EQ. 12) IZERO = 38 + IZ
      IPASS = 2
      SCALE = TE
      IF (ICODE .NE. 7) GO TO 140
  210 IPART   = IZ
      DICT(2) = 1
      DICT(3) = NDOF
      DICT(4) = ICODE
      DICT(5) = GE
      CALL EMGOUT (K(IPART),K(IPART),NSQ,1,DICT,1,IPREC)
C
C     THE MASS MATRIX TERMS ARE CALCULATED HERE.
C
  220 IF (KMBGG(2).EQ.0 .OR. ME.EQ.0.0) RETURN
      DICT(3) = 6
      DICT(4) = 7
      DICT(5) = 0
C
C     CHECK TO SEE IF CONVENTIONAL OR CONSISTENT MASS MATRIX IS REQUIRED
C
      IF (ICMBAR .GT. 0) GO TO 400
C
C     CONVENTIONAL MASS MATRIX TERMS ARE COMPUTED HERE
C
      DICT(2) = 2
      LDATA = 6
      IZP5  = IZ + 5
      DO 230 I = IZ,IZP5
  230 K(I)  = ME
      GO TO 600
C
C     CONSISTENT MASS MATRIX TERMS ARE COMPUTED HERE
C
  400 DICT(2) = 1
      LDATA   = 36
      DO 420 I = 1,9
      MASSII(I) = 0.0
      MASSJJ(I) = 0.0
      MASSIJ(I) = 0.0
      MASSJI(I) = 0.0
      MIJDUM(I) = 0.0
      MJIDUM(I) = 0.0
  420 CONTINUE
      ME = 2.0*ME
      DO 440 I = 1,9,4
      MASSII(I) = ME/3.0
      MASSJJ(I) = ME/3.0
      MASSIJ(I) = ME/6.0
      MASSJI(I) = ME/6.0
      MIJDUM(I) = ME/6.0
      MJIDUM(I) = ME/6.0
  440 CONTINUE
      IF (SIL2-SIL1) 480,270,460
  460 ITI = 9
      ITJ = 13
      GO TO 500
  480 ITI = 13
      ITJ = 9
  500 IF (IEST(ITI) .EQ. 0) GO TO 520
      CALL TRANSS (IEST(ITI), TA)
      CALL GMMATS (TA,3,3,1, MASSII,3,3,0, K(IZ))
      CALL GMMATS (K(IZ),3,3,0, TA,3,3,0, MASSII)
      CALL GMMATS (TA,3,3,1, MIJDUM,3,3,0, MASSIJ)
      CALL GMMATS (MJIDUM,3,3,0, TA,3,3,0, MASSJI)
  520 IF (IEST(ITJ) .EQ. 0) GO TO 560
      CALL TRANSS (IEST(ITJ), TA)
      CALL GMMATS (TA,3,3,1, MASSJJ,3,3,0, K(IZ))
      CALL GMMATS (K(IZ),3,3,0, TA,3,3,0, MASSJJ)
      CALL GMMATS (MASSIJ,3,3,0, TA,3,3,0, MIJDUM)
      CALL GMMATS (TA,3,3,1, MASSJI,3,3,0, MJIDUM)
      DO 540 I = 1,9
      MASSIJ(I) = MIJDUM(I)
      MASSJI(I) = MJIDUM(I)
  540 CONTINUE
  560 DO 580 I = 1,3
      KZ = IZ + I - 1
      K(KZ   ) = MASSII(I  )
      K(KZ+ 6) = MASSII(I+3)
      K(KZ+12) = MASSII(I+6)
      K(KZ+ 3) = MASSIJ(I  )
      K(KZ+ 9) = MASSIJ(I+3)
      K(KZ+15) = MASSIJ(I+6)
      K(KZ+18) = MASSJI(I  )
      K(KZ+24) = MASSJI(I+3)
      K(KZ+30) = MASSJI(I+6)
      K(KZ+21) = MASSJJ(I  )
      K(KZ+27) = MASSJJ(I+3)
      K(KZ+33) = MASSJJ(I+6)
  580 CONTINUE
  600 CALL EMGOUT (K(IZ),K(IZ),LDATA,1,DICT,2,IPREC)
      RETURN
C
C     HEAT TRANSFER CALCULATIONS ARE PERFORMED HERE
C
  240 INFLAG  = 1
      DICT(2) = 1
      DICT(3) = 2
      DICT(4) = 1
      DICT(5) = 0
      IF (KMBGG(1) .EQ. 0) GO TO 250
      CALL HMAT (EID)
      K(IZ) = (AFACT*KCON)/EL
      IF (K(IZ) .EQ. 0.0) GO TO 250
      K(IZ+1) = -K(IZ)
      K(IZ+2) = -K(IZ)
      K(IZ+3) =  K(IZ)
      CALL EMGOUT (K(IZ),K(IZ),4,1,DICT,1,IPREC)
  250 INFLAG = 4
      IF (KMBGG(1) .EQ. 0) RETURN
      CALL HMAT (EID)
      K(IZ) = (AFACT*CP)*EL/2.0
      IF (K(IZ) .EQ. 0.0) RETURN
      K(IZ+1) = K(IZ)
      DICT(2) = 2
      CALL EMGOUT (K(IZ),K(IZ),2,1,DICT,3,IPREC)
      RETURN
C
  270 NOGO = .TRUE.
      WRITE  (IOUTPT,280) UFM,EID
  280 FORMAT (A23,' 3118, ROD ELEMENT NO.',I9,
     1        ' HAS ILLEGAL GEOMETRY OR CONNECTIONS.')
      RETURN
  290 NOGO = .TRUE.
      WRITE  (IOUTPT,300) UFM
  300 FORMAT (A23,' 3119, INSUFFICIENT CORE TO PROCESS ROD ELEMENTS')
      RETURN
      END


c# cisi.f
      SUBROUTINE CISI (X, CI, SI)
C--------------------------------
C
C X
C CI IS COSINE INTEGRAL OF X
C SI IS SINE   INTEGRAL OF X
C
      IF (X - 1.)100, 120, 120
 100  SQ = X * X
      CI = .5772156649 + ALOG (X)
      TERM = - 1. * SQ / 4.
      G = 4.
 105  CI = CI + TERM
      TERM = - 1. * TERM * SQ * (G - 2.) / ((G - 1.) * G * G)
      G = G + 2.
      IF (ABS (TERM) - .00005)110, 110, 105
 110  SI = 0.
      TERM = X
      G = 3.
 115  SI = SI + TERM
      TERM = - 1. * TERM * SQ * (G - 2.) / ((G - 1.) * G * G)
      G = G + 2.
      IF (ABS (TERM) - .00005)125, 125, 115
 120  X2 = X * X
      T = COS (X)
      S = SIN (X)
      G = ((((X2 + 48.196927) * X2 + 482.485984) * X2 + 1114.978885) * X
     12 + 449.690326) * X2
      G = ((((X2 + 42.252855) * X2 + 302.757865) * X2 + 352.018498) * X2
     1 + 21.821899) / G
      F = ((((X2 + 40.021433) * X2 + 322.624911) * X2 + 570.236280) * X2
     1 + 157.105423) * X
      F = ((((X2 + 38.027264) * X2 + 265.187033) * X2 + 335.677320) * X2
     1 + 38.102495) / F
      SI = 1.5708 - F * T - G * S
      CI = F * S - G * T
 125  RETURN
      END
C--------------------------------


module kernel_module
!*********************************************************
!
! This module contains variables and subroutines used for
! the linear nodal kernel. LN is a TMB method that retains no
! mixed linear cross moments. The LN information is stored
! in the spatial weights that are computed by Pade
! interpolation in a lookup table. This LN kernel uses
! the NEFD algorithm that solves the WDD for the outflow
! fluxes and substitutes the relations into the balance
! equations. The four balance relations are pre-solved for
! efficiency.
!
!*********************************************************
use invar
use solvar
use precision_module, only: dp

implicit none

! sp_weights saves Pade coefficients for the computation of the AHOTN
! spatial weights for AHOTN/LL and AHOTN/LN solvers
real(kind=dp) :: sp_wt0(4,0:1000)
real(kind=dp) :: sp_wt1(4,0:1000)
! spatial weights for AHOTN/NEFD solver
real(kind=dp) :: sp_wts(4,0:1000)

contains

subroutine read_sp_wts_ahotn_l
  integer :: i
  open(unit=9 ,file="w0_LL.dat")
  open(unit=10,file="w1_LL.dat")
  do i=0,1000
     read(9,*)  sp_wt0(1,i),sp_wt0(2,i),sp_wt0(3,i),sp_wt0(4,i)
     read(10,*) sp_wt1(1,i),sp_wt1(2,i),sp_wt1(3,i),sp_wt1(4,i)
  end do
  close(unit=9)
  close(unit=10)
end subroutine

function spwt0(e)
  real(kind=dp) :: spwt0
  real(kind=dp) :: e
  real(kind=dp) :: c(4)
  integer :: pos
  pos=min(idnint(10.0d0*e),1000)
  c=sp_wt0(:,pos)
  spwt0=(c(1)+c(2)*e)/(c(3)+c(4)*e)
end function

function spwt1(e)
  real(kind=dp) :: spwt1
  real(kind=dp) :: e
  real(kind=dp) :: c(4)
  integer :: pos
  pos=min(idnint(10.0d0*e),1000)
  c=sp_wt1(:,pos)
  spwt1=(c(1)+c(2)*e)/(c(3)+c(4)*e)
end function

function wt0(t)
   real(kind=8) :: wt0,t
   wt0=10.0d0/t
end function

function wt1(t)
   real(kind=8) :: wt1,t
   wt1=t/6.0d0
end function

subroutine read_sp_wts_ahotn_nefd(order)
!*********************************************************
!
! This subroutine reads Pade coefficients from files
! w<order>
!
!*********************************************************
  integer :: order
  integer :: i
  if(order==0) then
    open(unit=9,file="w0.dat")
  else if(order==1) then
    open(unit=9,file="w1.dat")
  else if(order==2) then
    open(unit=9,file="w2.dat")
  else if(order==3) then
    open(unit=9,file="w3.dat")
  else if(order==4) then
    open(unit=9,file="w4.dat")
  else
    stop
  end if
  do i=0,1000
     read(9,*) sp_wts(1,i),sp_wts(2,i),sp_wts(3,i),sp_wts(4,i)
  end do
  close(unit=9)
end subroutine

function spwt(e)
!*********************************************************
!
! Given the optical thickness e this functions computes
! the spatial weight.
!
!*********************************************************
  real(kind=dp) :: spwt
  real(kind=dp) :: e
  real(kind=dp) :: c(4)
  integer :: pos
  pos=min(idnint(10.0d0*e),1000)
  c=sp_wts(:,pos)
  spwt=(c(1)+c(2)*e)/(c(3)+c(4)*e)
end function

subroutine ahotn_ln_kernel(x,y,z,mu,eta,xi,sgm,sge,sgx,sig,c,inflow_x,inflow_y,inflow_z,b)
!*********************************************************
!
! This subroutine solves the AHOTN equations for a single
! cell. Given the cell source and inflow fluxes, it computes
! the volume moments and the outflow fluxes.
!
!*********************************************************

   ! Arguments

   real(kind=8) :: x,y,z,sig,c,mu,eta,xi
   real(kind=8), dimension(3) :: inflow_x,inflow_y,inflow_z
   real(kind=8), dimension(4) :: b
   integer :: sgm, sge, sgx               ! =incx,incy,incz

   ! Local variables

   real(kind=8) :: alpha0, beta0, gamma0,alpha1, beta1, gamma1
   real(kind=8) :: ex, ey, ez, ex0, ey0 ,ez0, ex1, ey1 ,ez1
   real(kind=8) :: a11,a12,a13,a14,a22,a33,a44,a21,a31,a41,b1,b2,b3,b4
   real(kind=8) :: den

   ! Call for the calculation of the spatial weights
   ex = sig*x/mu
   ey = sig*y/eta
   ez = sig*z/xi
!   alpha0 = wt0(ex) ; alpha1 = wt1(ex)
!   beta0  = wt0(ey) ; beta1  = wt1(ey)
!   gamma0 = wt0(ez) ; gamma1 = wt1(ez)
   alpha0 = spwt0(ex) ; alpha1 = spwt1(ex)
   beta0  = spwt0(ey) ; beta1  = spwt1(ey)
   gamma0 = spwt0(ez) ; gamma1 = spwt1(ez)
   ex0 = 2.0d0/(ex*(1.0d0+alpha0))
   ey0 = 2.0d0/(ey*(1.0d0+beta0 ))
   ez0 = 2.0d0/(ez*(1.0d0+gamma0))
   ex1 = 2.0d0/(ex*(1.0d0+alpha1))
   ey1 = 2.0d0/(ey*(1.0d0+beta1 ))
   ez1 = 2.0d0/(ez*(1.0d0+gamma1))

!write(6,101) ex,ey,ez
!write(6,101) inflow_x
!write(6,101) inflow_y
!write(6,101) inflow_z
!write(6,101) alpha0,beta0,gamma0
!write(6,101) alpha1,beta1,gamma1
!write(6,101) real(sgm),real(sge),real(sgx)
!write(6,101) b
!101 FORMAT(1X,4ES25.16)

!write(8,*) spwt0(ex)
!write(8,*) ex,ey,ez
!write(8,*) inflow_x
!write(8,*) inflow_y
!write(8,*) inflow_z
!write(8,*) alpha0,beta0,gamma0
!write(8,*) alpha1,beta1,gamma1
!write(8,*) real(sgm),real(sge),real(sgx)

   ! Define a11 through a44
   a11 = 1.0d0 + ex0 + ey0 + ez0
   a22 = 1.0d0 + ex1 + ey1 + 3.0d0*gamma0*ez0
   a33 = 1.0d0 + ex1 + 3.0d0*beta0 *ey0 + ez1
   a44 = 1.0d0 + 3.0d0*alpha0*ex0 + ey1 + ez1
   a21 = sgx*(ez0-2.0d0/ez)
   a31 = sge*(ey0-2.0d0/ey)
   a41 = sgm*(ex0-2.0d0/ex)
   a12 = 3.0d0*sgx*gamma0*ez0
   a13 = 3.0d0*sge*beta0 *ey0
   a14 = 3.0d0*sgm*alpha0*ex0

   ! Construct rhs
   b1 = b(1) + ex0*inflow_x(1) + ey0*inflow_y(1) + ez0*inflow_z(1)
   b2 = b(2) + ex1*inflow_x(2) + ey1*inflow_y(2) - sgx*gamma0*ez0*inflow_z(1)
   b3 = b(3) + ex1*inflow_x(3) - sge*beta0*ey0*inflow_y(1)  + ez1*inflow_z(2)
   b4 = b(4) - sgm*alpha0*ex0*inflow_x(1) + ey1*inflow_y(3) + ez1*inflow_z(3)

   ! Solve the matrix
   den  = a14*a22*a33*a41 + a44*(a13*a22*a31+a12*a21*a33-a11*a22*a33)
   b(1) = a12*a33*a44*b2 + a22*(-a33*a44*b1 + a13*a44*b3 + a14*a33*b4)
   b(1) = b(1)/den
   b(2) = a21*a33*a44*b1 + a14*a33*a41*b2 + a13*a31*a44*b2 - a11*a33*a44*b2 - a13*a21*a44*b3 - a14*a21*a33*b4
   b(2) = b(2)/den
   b(3) = a12*a44*(-a31*b2 + a21*b3) + a22*(a31*a44*b1 + a14*a41*b3 - a11*a44*b3 - a14*a31*b4)
   b(3) = b(3)/den
   b(4) = a12*a33*(-a41*b2 + a21*b4) + a22*(a33*a41*b1 - a13*a41*b3 + a13*a31*b4 - a11*a33*b4)
   b(4) = b(4)/den

   ! compute outflow - x-direction
   inflow_x(1) = (inflow_x(1)*(alpha0-1.0d0)+2.0d0*b(1)+6.0d0*sgm*alpha0*b(4))/(1.0d0+alpha0)
   inflow_x(2) = (inflow_x(2)*(alpha1-1.0d0)+2.0d0*b(2))                      /(1.0d0+alpha1)
   inflow_x(3) = (inflow_x(3)*(alpha1-1.0d0)+2.0d0*b(3))                      /(1.0d0+alpha1)

   ! compute outflow - y-direction
   inflow_y(1) = (inflow_y(1)*(beta0-1.0d0) +2.0d0*b(1)+6.0d0*sge*beta0 *b(3))/(1.0d0+beta0 )
   inflow_y(2) = (inflow_y(2)*(beta1-1.0d0) +2.0d0*b(2))                      /(1.0d0+beta1 )
   inflow_y(3) = (inflow_y(3)*(beta1-1.0d0) +2.0d0*b(4))                      /(1.0d0+beta1 )

   ! compute outflow - z-direction
   inflow_z(1) = (inflow_z(1)*(gamma0-1.0d0)+2.0d0*b(1)+6.0d0*sgx*gamma0*b(2))/(1.0d0+gamma0)
   inflow_z(2) = (inflow_z(2)*(gamma1-1.0d0)+2.0d0*b(3))                      /(1.0d0+gamma1)
   inflow_z(3) = (inflow_z(3)*(gamma1-1.0d0)+2.0d0*b(4))                      /(1.0d0+gamma1)

!write(6,*)
!write(6,101) b
!write(6,101) inflow_x
!write(6,101) inflow_y
!write(6,101) inflow_z
!stop
end subroutine

subroutine ahotn_ll_kernel(x,y,z,mu,eta,xi,sgm,sge,sgx,sig,c,inflow_x,inflow_y,inflow_z,b)
!*********************************************************
!
! This subroutine solves the AHOTN equations for a single
! cell. Given the cell source and inflow fluxes, it computes
! the volume moments and the outflow fluxes.
!
!*********************************************************

   ! Arguments

   real(kind=8) :: x,y,z,sig,c,mu,eta,xi
   real(kind=8), dimension(3) :: inflow_x,inflow_y,inflow_z
   real(kind=8), dimension(4) :: b
   integer :: sgm, sge, sgx               ! =incx,incy,incz

   ! Local variables

   real(kind=8) :: alpha0, beta0, gamma0,alpha1, beta1, gamma1
   real(kind=8) :: ex, ey, ez, ex0, ey0 ,ez0
   real(kind=8) :: dzx,dzy,dyx,dyz,dxz,dxy
   real(kind=8) :: a11,a12,a13,a14,a21,a22,a23,a24,a31,a32,a33,a34,a41,a42,a43,a44
   real(kind=8) :: b1,b2,b3,b4
   real(kind=8) :: den
   real(kind=8), dimension(3) :: inf_x,inf_y,inf_z

   ! Call for the calculation of the spatial weights
   ex = sig*x/mu
   ey = sig*y/eta
   ez = sig*z/xi
   alpha0 = spwt0(ex) ; alpha1 = spwt1(ex)
   beta0  = spwt0(ey) ; beta1  = spwt1(ey)
   gamma0 = spwt0(ez) ; gamma1 = spwt1(ez)
   ex0 = 2.0d0/(ex*(1.0d0+alpha0))
   ey0 = 2.0d0/(ey*(1.0d0+beta0 ))
   ez0 = 2.0d0/(ez*(1.0d0+gamma0))
   dzx = 1.0d0 /  (ex*ez*(gamma1+1.0d0)+alpha1*(ex*ez+gamma1*(ex*ez-36.0d0)))
   dzy = 1.0d0 /  (ey*ez*(gamma1+1.0d0)+ beta1*(ey*ez+gamma1*(ey*ez-36.0d0)))
   dxz = 1.0d0 /  (ex*ez*(alpha1+1.0d0)+gamma1*(ex*ez+alpha1*(ex*ez-36.0d0)))
   dyz = 1.0d0 /  (ey*ez*(beta1 +1.0d0)+gamma1*(ey*ez+ beta1*(ey*ez-36.0d0)))
   dyx = 1.0d0 /  (ex*ey*(beta1 +1.0d0)+alpha1*(ex*ey+ beta1*(ex*ey-36.0d0)))
   dxy = 1.0d0 /  (ex*ey*(alpha1+1.0d0)+beta1 *(ex*ey+alpha1*(ex*ey-36.0d0)))

!write(6,101) ex,ey,ez
!write(6,101) inflow_x
!write(6,101) inflow_y
!write(6,101) inflow_z
!write(6,101) alpha0,beta0,gamma0
!write(6,101) alpha1,beta1,gamma1
!write(6,101) real(sgm),real(sge),real(sgx)
!write(6,101) b
!101 FORMAT(1X,4ES20.10)

   ! Define a11 through a44
   a11 = 1.0d0 + ex0 + ey0 + ez0
   a22 = 1.0d0 + 2.0d0*ez*(dzx+dzy) &
         + 2.0d0*gamma1*((ex*ez-36.0d0*alpha1)*dxz/ex + (ey*ez-36.0d0*beta1)*dyz/ey) &
         + 3.0d0*gamma0*ez0
   a33 = 1.0d0 + 2.0d0*ey*(dyx+dyz) &
         + 2.0d0*beta1*((ex*ey-36.0d0*alpha1)*dxy/ex + (ey*ez-36.0d0*gamma1)*dzy/ez) &
         + 3.0d0*beta0*ey0
   a44 = 1.0d0 + 2.0d0*ex*(dxz+dxy) &
         + 2.0d0*alpha1*((ex*ey-36.0d0*beta1)*dyx/ey + (ex*ez-36.0d0*gamma1)*dzx/ez) &
         + 3.0d0*alpha0*ex0
   a21 = sgx*(ez0-2.0d0/ez)
   a31 = sge*(ey0-2.0d0/ey)
   a41 = sgm*(ex0-2.0d0/ex)
   a12 = 3.0d0*sgx*gamma0*ez0
   a13 = 3.0d0*sge*beta0 *ey0
   a14 = 3.0d0*sgm*alpha0*ex0
   a32 = 12.0d0*sgx*sge*beta1 *gamma1*dzy
   a42 = 12.0d0*sgx*sgm*alpha1*gamma1*dzx
   a23 = 12.0d0*sge*sgx*beta1 *gamma1*dzy
   a43 = 12.0d0*sge*sgm*alpha1*beta1 *dyx
   a24 = 12.0d0*sgm*sgx*alpha1*gamma1*dzx
   a34 = a43

   ! Construct rhs
   b1 = b(1) + inflow_x(1)*ex0 + inflow_y(1)*ey0 + inflow_z(1)*ez0
   b2 = b(2) + inflow_x(2)*2.0d0*(ex*ez+gamma1*(ex*ez-36.0d0*alpha1))*dzx/ex + &
               inflow_y(2)*2.0d0*(ey*ez+gamma1*(ey*ez-36.0d0*beta1 ))*dzy/ey - &
               inflow_z(1)*sgx*gamma0*ez0 + &
               inflow_z(2)*12.0d0*sge*sgx*gamma1*beta1 *dzy + &
               inflow_z(3)*12.0d0*sgm*sgx*gamma1*alpha1*dzx
   b3 = b(3) + inflow_x(3)*2.0d0*(ex*ey+beta1 *(ex*ey-36.0d0*alpha1))*dyx/ex + &
               inflow_z(2)*2.0d0*(ey*ez+beta1 *(ey*ez-36.0d0*gamma1))*dzy/ez - &
               inflow_y(1)*sge*beta0 *ey0 + &
               inflow_y(2)*12.0d0*sge*sgx*gamma1*beta1 *dzy + &
               inflow_y(3)*12.0d0*sge*sgm*beta1 *alpha1*dyx
   b4 = b(4) + inflow_y(3)*2.0d0*(ex*ey+alpha1*(ex*ey-36.0d0*beta1))*dyx/ey + &
               inflow_z(3)*2.0d0*(ex*ez+alpha1*(ex*ez-36.0d0*gamma1))*dzx/ez - &
               inflow_x(1)*sgm*alpha0*ex0 + &
               inflow_x(2)*12.0d0*sgm*sgx*gamma1*alpha1*dzx + &
               inflow_x(3)*12.0d0*sge*sgm*beta1 *alpha1*dyx

   ! Solve the matrix
   den  = a12*a24*a33*a41 - a12*a23*a34*a41 - a11*a24*a33*a42 + a11*a23*a34*a42 -  &
          a12*a24*a31*a43 + a11*a24*a32*a43 + a12*a21*a34*a43 - a11*a22*a34*a43 +  &
          a14*(a23*a32*a41 - a22*a33*a41 - a23*a31*a42 + a21*a33*a42 + a22*a31*a43 &
          - a21*a32*a43) + a12*a23*a31*a44 - a11*a23*a32*a44 - a12*a21*a33*a44  +  &
          a11*a22*a33*a44 + a13*(-(a24*a32*a41) + a22*a34*a41 + a24*a31*a42 -      &
          a21*a34*a42 - a22*a31*a44 + a21*a32*a44)

   b(1) = -(a22*a34*a43*b1) + a22*a33*a44*b1 + a14*a33*a42*b2 - a13*a34*a42*b2     &
          - a14*a32*a43*b2 + a12*a34*a43*b2 + a13*a32*a44*b2 - a12*a33*a44*b2 +    &
          a14*a22*a43*b3 - a13*a22*a44*b3 - a14*a22*a33*b4 + a13*a22*a34*b4 +      &
          a24*(-(a33*a42*b1) + a32*a43*b1 + a13*a42*b3 - a12*a43*b3 - a13*a32*b4 + &
          a12*a33*b4) + a23*(a34*a42*b1 - a32*a44*b1 - a14*a42*b3 + a12*a44*b3 +   &
          a14*a32*b4 - a12*a34*b4)
   b(1) = b(1)/den

   b(2) = a21*a34*a43*b1 - a21*a33*a44*b1 - a14*a33*a41*b2 + a13*a34*a41*b2 +      &
          a14*a31*a43*b2 - a11*a34*a43*b2 - a13*a31*a44*b2 + a11*a33*a44*b2 -      &
          a14*a21*a43*b3 + a13*a21*a44*b3 + a14*a21*a33*b4 - a13*a21*a34*b4 +      &
          a24*(a33*a41*b1 - a31*a43*b1 - a13*a41*b3 + a11*a43*b3 + a13*a31*b4 -    &
          a11*a33*b4) + a23*(-(a34*a41*b1) + a31*a44*b1 + a14*a41*b3 -             &
          a11*a44*b3 - a14*a31*b4 + a11*a34*b4)
   b(2) = b(2)/den

   b(3) = -(a21*a34*a42*b1) + a21*a32*a44*b1 + a14*a32*a41*b2 - a12*a34*a41*b2 -    &
          a14*a31*a42*b2 + a11*a34*a42*b2 + a12*a31*a44*b2 - a11*a32*a44*b2 +       &
          a14*a21*a42*b3 - a12*a21*a44*b3 - a14*a21*a32*b4 + a12*a21*a34*b4 +       &
          a24*(-(a32*a41*b1) + a31*a42*b1 + a12*a41*b3 - a11*a42*b3 - a12*a31*b4 +  &
          a11*a32*b4) + a22*(a34*a41*b1 - a31*a44*b1 - a14*a41*b3 + a11*a44*b3 +    &
          a14*a31*b4 - a11*a34*b4)
   b(3) = b(3)/den

   b(4) = a21*a33*a42*b1 - a21*a32*a43*b1 - a13*a32*a41*b2 + a12*a33*a41*b2 +       &
          a13*a31*a42*b2 - a11*a33*a42*b2 - a12*a31*a43*b2 + a11*a32*a43*b2 -       &
          a13*a21*a42*b3 + a12*a21*a43*b3 + a13*a21*a32*b4 - a12*a21*a33*b4 +       &
          a23*(a32*a41*b1 - a31*a42*b1 - a12*a41*b3 + a11*a42*b3 + a12*a31*b4 -     &
          a11*a32*b4) + a22*(-(a33*a41*b1) + a31*a43*b1 + a13*a41*b3 -              &
          a11*a43*b3 - a13*a31*b4 + a11*a33*b4)
   b(4) = b(4)/den

   ! Copy inflow data in separate arrays
   inf_x=inflow_x
   inf_y=inflow_y
   inf_z=inflow_z

   ! compute outflow - x-direction
   inflow_x(1) = (inf_x(1)*(alpha0-1.0d0)+2.0d0*b(1)+6.0d0*sgm*alpha0*b(4))/(alpha0+1.0d0)
   inflow_x(2) = inf_x(2)*(-ex*ez*(1.0d0+gamma1)+alpha1*(ex*ez+gamma1*(ex*ez+36.0d0)))*dzx + &
                 b(2)*2.0d0*(ex*ez+gamma1*(ex*ez-36.0d0*alpha1))*dzx                          - &
                 inf_z(3)*12.0d0*sgm*sgx*ex*alpha1*gamma1*dzx                              + &
                 b(4)       *12.0d0*sgm*sgx*ex*alpha1*gamma1*dzx
   inflow_x(3) = inf_x(3)*(-ex*ey*(1.0d0+beta1 )+alpha1*(ex*ey+beta1* (ex*ey+36.0d0)))*dyx + &
                 b(3)*2.0d0*(ex*ey+beta1 *(ex*ey-36.0d0*alpha1))*dyx                          - &
                 inf_y(3)*12.0d0*sgm*sge*ex*alpha1*beta1 *dyx                              + &
                 b(4)       *12.0d0*sgm*sge*ex*alpha1*beta1 *dyx

   ! compute outflow - y-direction
   inflow_y(1) = (inf_y(1)*(beta0 -1.0d0)+2.0d0*b(1)+6.0d0*sge*beta0 *b(3))/(beta0+1.0d0)
   inflow_y(2) = inf_y(2)*(-ey*ez*(1.0d0+gamma1)+beta1* (ey*ez+gamma1*(ey*ez+36.0d0)))*dzy + &
                 b(2)*2.0d0*(ey*ez+gamma1*(ey*ez-36.0d0*beta1 ))*dzy                          - &
                 inf_z(2)*12.0d0*sge*sgx*ey*beta1 *gamma1*dzy                              + &
                 b(3)       *12.0d0*sge*sgx*ey*beta1 *gamma1*dzy
   inflow_y(3) = inf_y(3)*(ey*ex*(-1.0d0+beta1)+alpha1*(-ey*ex+beta1*(ey*ex+36.0d0)))*dyx  + &
                 b(4)*2.0d0*(ey*ex+alpha1*(ey*ex-36.0d0*beta1 ))*dyx                          - &
                 inf_x(3)*12.0d0*sge*sgm*ey*beta1 *alpha1*dyx                              + &
                 b(3)       *12.0d0*sge*sgm*ey*beta1 *alpha1*dyx

   ! compute outflow - z-direction

   inflow_z(1) = (inf_z(1)*(gamma0-1.0d0)+2.0d0*b(1)+6.0d0*sgx*gamma0*b(2))/(gamma0+1.0d0)
   inflow_z(2) = inf_z(2)*(ey*ez*(-1.0d0+gamma1)+beta1* (-ey*ez+gamma1*(ey*ez+36.0d0)))*dzy + &
                 b(3)*2.0d0*(ey*ez+beta1 *(ey*ez-36.0d0*gamma1 ))*dzy                       - &
                 inf_y(2)*12.0d0*sge*sgx*ez*beta1 *gamma1*dzy                               + &
                 b(2)*12.0d0*sge*sgx*ez*beta1 *gamma1*dzy
   inflow_z(3) = inf_z(3)*(ex*ez*(-1.0d0+gamma1)+alpha1*(-ex*ez+gamma1*(ex*ez+36.0d0)))*dzx + &
                 b(4)*2.0d0*(ex*ez+alpha1*(ex*ez-36.0d0*gamma1 ))*dzx                       - &
                 inf_x(2)*12.0d0*sgx*sgm*ez*gamma1*alpha1*dzx                               + &
                 b(2)*12.0d0*sgx*sgm*ez*gamma1*alpha1*dzx

!write(6,*)
!write(6,101) b
!write(6,101) inflow_x
!write(6,101) inflow_y
!write(6,101) inflow_z
!stop
end subroutine

subroutine ahotn_nefd_kernel(x,y,z,mu,eta,xi,sgm,sge,sgx,sig,c,inflow_x,inflow_y,inflow_z,b,lambda,ordcb)
!*********************************************************
!
! This subroutine solves the AHOTN equations for a single
! cell. Given the cell source and inflow fluxes, it computes
! the volume moments and the outflow fluxes.
!
!*********************************************************

   ! Arguments
    Integer :: lambda, ordcb
   real(kind=8) :: x,y,z,sig,c,mu,eta,xi
   real(kind=8), dimension(0:lambda, 0:lambda) :: inflow_x,inflow_y,inflow_z
   real(kind=8), dimension(ordcb) :: b
   integer :: sgm, sge, sgx               ! =incx,incy,incz

   ! Local variables

   real(kind=8) :: alpha, beta, gamma, ex, ey, ez,factor,sgn
   integer :: ieq, tt, col, indx, jndx, kndx, info, tmp1, tmp2
   integer :: i, j, k, t, u, v, m, n
   integer :: mltx, mlty, mltz
   real(kind=8), dimension(ordcb, ordcb) :: a
   real(kind=8), dimension(ordcb) ::  wrk
   integer, dimension(ordcb) :: piv

   ! Call for the calculation of the spatial weights
   ex = 0.5*sig*x/mu
   ey = 0.5*sig*y/eta
   ez = 0.5*sig*z/xi
   alpha = spwt(ex)
   beta  = spwt(ey)
   gamma = spwt(ez)

   ! Begin constructing Matrix Equation
   ieq = 0

   ! Initialize 'a' matrix
   a = 0.0

   DO t = 0, lambda
      mltx = sgm**t

      DO u = 0, lambda
         mlty = sge**u

         DO v = 0, lambda
            mltz = sgx**v
            ieq = ieq + 1

            ! Contributions from outgoing fluxes
            ! Even summations
            DO tt = 0, lambda, 2
               ! x-constant surface
               col = ordsq*tt + order*u + v + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*tt+1.0)/(ex*(1.0+alpha))
               ! y-constant surface
               col = ordsq*t + order*tt + v + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*tt+1.0)/(ey*(1.0+beta))
               ! z-constant surface
               col = ordsq*t + order*u + tt + 1
               a(ieq,col) = a(ieq,col) + mltz*(2.0*tt+1.0)/(ez*(1.0+gamma))
            END DO

            ! Odd summations
            DO tt = 1, lambda, 2
               ! x-constant surface
               col = ordsq*tt + order*u + v + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*tt+1.0)*sgm*alpha/(ex*(1.0+alpha))
               ! y-constant surface
               col = ordsq*t + order*tt + v + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*tt+1.0)*sge*beta/(ey*(1.0+beta))
               ! z-constant surface
               col = ordsq*t + order*u + tt + 1
               a(ieq,col) = a(ieq,col) + mltz*(2.0*tt+1.0)*sgx*gamma/(ez*(1.0+gamma))
            END DO

            ! Contributions from three summations
            ! x-summations
            DO tt = MOD((t+1),2), (t-1), 2
               col = ordsq*tt + order*u + v + 1
               a(ieq,col) = a(ieq,col) - sgm*(2.0*tt+1.0)/ex
            END DO
            ! y-summations
            DO tt = MOD((u+1),2), (u-1), 2
               col = ordsq*t + order*tt + v + 1
               a(ieq,col) = a(ieq,col) - sge*(2.0*tt+1.0)/ey
            END DO
            ! z-summations
            DO tt = MOD((v+1),2), (v-1), 2
               col = ordsq*t + order*u + tt + 1
               a(ieq,col) = a(ieq,col) - sgx*(2.0*tt+1.0)/ez
            END DO

            ! Contribution along the diagonal -- total interaction
            a(ieq,ieq) = a(ieq,ieq) + 1.0
            ! Finished calculating the 'a' matrix LHS

            ! Begin composing the RHS vector
            ! Add contributions from incoming fluxes due to elimination
            b(ieq) = b(ieq) + mltx*(1.0-alpha)*inflow_x(u,v)/(2.0*ex*(1.0+alpha))
            b(ieq) = b(ieq) + mlty*(1.0-beta) *inflow_y(t,v)/(2.0*ey*(1.0+beta))
            b(ieq) = b(ieq) + mltz*(1.0-gamma)*inflow_z(t,u)/(2.0*ez*(1.0+gamma))
            ! Add contributions from incoming fluxes
            b(ieq) = b(ieq) + mltx*((-1)**t)*inflow_x(u,v)/(2.0*ex)
            b(ieq) = b(ieq) + mlty*((-1)**u)*inflow_y(t,v)/(2.0*ey)
            b(ieq) = b(ieq) + mltz*((-1)**v)*inflow_z(t,u)/(2.0*ez)
            ! Finished calculating the b vector, RHS
         END DO
      END DO
   END DO

   ! Solve the matrix
   ! Lapack standard solver => symmetric solver is slower for small matrices!!
   call dgesv(ordcb,1,a,ordcb,piv,b,ordcb,info)

   ! Compute the outgoing fluxes with the WDD equations
   ! Outgoing flux moments in x-dir
   DO u = 0, lambda
      DO v = 0, lambda
         ! Contribution from incoming flux
         inflow_x(u,v) = -((1.0 - alpha)/(1.0 + alpha))*inflow_x(u,v)
         ! Contribution from even summation
         DO tt = 0, lambda, 2
            indx = ordsq*tt + order*u + v + 1
            inflow_x(u,v) = inflow_x(u,v) + 2.0*(2.0*tt + 1.0)*b(indx)/(1.0+alpha)
            ! Contribution from odd summation
            IF ((tt+1) <= lambda) THEN
               inflow_x(u,v) = inflow_x(u,v) + 2.0*(2.0*tt+3.0)*sgm*alpha*b(indx+ordsq)/(1.0+alpha)
            END IF
         END DO
      END DO
   END DO

   ! Outgoing flux moments in y-dir
   DO t = 0, lambda
      DO v = 0, lambda
         ! Contribution from incoming flux
         inflow_y(t,v) = -((1.0-beta)/(1.0+beta))*inflow_y(t,v)
         ! Contribution from even summation
         DO tt = 0, lambda, 2
            indx = ordsq*t + order*tt + v + 1
            inflow_y(t,v) = inflow_y(t,v) + 2.0*(2.0*tt+1.0)*b(indx)/(1.0+beta)
            ! Contribution from odd summation
            IF ((tt+1) <= lambda) THEN
               inflow_y(t,v) = inflow_y(t,v) + 2.0*(2.0*tt+3.0)*sge*beta*b(indx+order)/(1.0+beta)
            END IF
         END DO
      END DO
   END DO

   ! Outgoing flux moments in z-dir
   DO t = 0, lambda
      DO u = 0, lambda
         ! Contribution from incoming flux
         inflow_z(t,u) = -((1.0-gamma)/(1.0+gamma))*inflow_z(t,u)
         ! Contribution from even summation
         DO tt = 0, lambda, 2
            indx = ordsq*t + order*u + tt + 1
            inflow_z(t,u) = inflow_z(t,u) + 2.0*(2.0*tt+1.0)*b(indx)/(1.0+gamma)
            ! Contribution from odd summation
            IF ((tt+1) <= lambda) THEN
               inflow_z(t,u) = inflow_z(t,u) + 2.0*(2.0*tt+3.0)*sgx*gamma*b(indx+1)/(1.0+gamma)
            END IF
         END DO
      END DO
   END DO

end subroutine

end module


module global_com
  !
  !  This module contains all the constants which are common to the whole code
  !
USE, INTRINSIC :: ISO_C_BINDING
  implicit none
  save
  integer,parameter::dp=kind(0.0d0),sp=kind(0.0)
  complex(kind=dp),parameter::cjj=(0.0_dp,1.0_dp)
  real(kind=dp)::the_sta,the_end,phi_sta,phi_end
  real(kind=dp)::the_sta_degree,the_end_degree,phi_sta_degree,phi_end_degree
  real(kind=dp)::the_sta_degree_nf,the_end_degree_nf,phi_sta_degree_nf,phi_end_degree_nf
  real(kind=dp)::aminx,aminy,aminz,amaxx,amaxy,amaxz,centerx,centery,centerz
  integer::nthe_rcs,nphi_rcs,nthe_nf,nphi_nf
  real(kind=dp)::alpha,veta
  real(kind=dp)::pid,cd,eps0d,rmu0d,loss_sigma
  real(kind=dp)::fre_single
  real(kind=dp)::real_mem=8.0_dp,complex_mem=16.0_dp,int_mem=4.0_dp
  integer::order_tri,nnpt
  integer::order_basis,nipp,order_old
  integer::nhdgqp_far,nhdgqp_near,nlqp,nitermax,ngprcs,denmrcs,nclgp,defile,denscaf,detoj,deonep,nusolver,depconvert
  integer::dejjmie,detotalp, nhd_near
!  real(kind=dp)::aminx,aminy,aminz,amaxx,amaxy,amaxz
  integer(kind = c_int)::ntriangle,nnode
  real(kind=dp)::vwavelength,wavenumkk,rnfobp
  complex(kind=dp)::cjvk
  real(kind=dp)::vkk(3),vee(3),vhh(3)
  integer::it_solv,restart
  real(kind=dp)::precis,nearpd
  integer::no_freqs

  ! TIMING
  real(kind=dp)::time_far_allinc=0.0_dp,time_near_allinc=0.0_dp,&
       time_it_allinc=0.0_dp,time_frcs_allinc=0.0_dp,&
       time_outcur_allinc=0.0_dp,time_solve_allinc=0.0_dp,&
       time_rhs_allinc=0.0_dp,time_pre_allinc=0.0_dp,&
       time_rhs_CKT_allinc=0.0_dp,time_pre_CKT_allinc=0.0_dp,&
       time_CKT_allinc=0.0_dp
  real(kind=dp)::tot_far_time=0.0_dp,tot_near_time=0.0_dp,&
       solve_time_it=0.0_dp,tot_frcs_time=0.0_dp,&
       tot_outcur_time=0.0_dp,tot_solve_time=0.0_dp,&
       rhs_time=0.0_dp,tot_pre_time=0.0_dp,&
       rhs_CKT_time=0.0_dp,tot_pre_CKT_time=0.0_dp,&
       tot_CKT_time=0.0_dp
end module global_com


MODULE m_interpclock_nom

! ----------------------------------------------------------------------
! MODULE: m_interpclock_nom.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the interpclock_nom subroutine used for GNSS satellite clocks interpolation
!
! Subroutines contained within the module:
! - interpclock_nom.f03
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	27 May 2020
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE interpclock_nom (ORB_matrix, CLKmatrix, PRNmatrix, interv_in, NPint, CLKmatrix_int)

! ----------------------------------------------------------------------
! SUBROUTINE: interpclock_nom.f90
! ----------------------------------------------------------------------
! Purpose:
!  GNSS sp3 clocks interpolation based on Lagrange polynomials
! ----------------------------------------------------------------------
! Input arguments:
! - CLKmatrix:		Satellite Clocks' allocatable array (3-dimensional)
!					CLKmatrix(i,j,isat) = [MJD Sec_of_day clock]
!					If clock error (sdev) is available (when Position and Velocity vector are written in orbit sp3 format)
!					CLKmatrix(i,j,isat) = [MJD Sec_of_day clock clock_sdev]
! - PRNmatrix:      Satellites' PRN numbers allocatable array
!
! Output arguments:
! - CLKmatrix_int:  Interpolated Satellite Clocks' allocatable array (3-dimensional)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	27 May 2020
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_sp3
      USE m_lagrange
      !USE mdl_arr
      !USE mdl_write
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:,:,:), ALLOCATABLE :: ORB_matrix, CLKmatrix
	  CHARACTER (LEN=3), ALLOCATABLE, INTENT(IN) :: PRNmatrix(:)
      INTEGER (KIND = prec_int8), INTENT(IN) :: interv_in, NPint
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:,:), ALLOCATABLE :: CLKmatrix_int
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs, epoch_i, interv
      INTEGER (KIND = prec_int8) :: data_rate, Nepoch_int, Norb_int, NPint_1, NPint_2, Nlimit
	  INTEGER (KIND = prec_int8) :: i, j, i1, i2, ti
	  REAL (KIND = prec_d) :: SecDay_i, MJD_i
	  REAL (KIND = prec_d) :: MJD_tint, tint, Xint, Xint_1, Yint, Yint_1, Zint, Zint_1
	  REAL (KIND = prec_d) :: X, Y, Z, Vx, Vy, Vz
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      CHARACTER (LEN=300) :: fname_write
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: X_interp
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: Y_interp
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: clock_sat_prn, clock_int
      INTEGER (KIND = prec_int2) :: Clock_sdev_param
      INTEGER (KIND = prec_int8) :: Nepochs_orb, Nepochs_clk, Nelements_clk, Nsat_clk, Nclock_int
      INTEGER (KIND = prec_int8) :: sz1, sz2, sz3
      INTEGER (KIND = prec_int8) :: i_elements, i_sat, i_clock_epoch, i_CLKmatrix

! ----------------------------------------------------------------------
sz1 = size(ORB_matrix, DIM = 1)
Nepochs_orb = sz1

sz1 = size(CLKmatrix, DIM = 1)
Nepochs_clk = sz1

sz2 = size(CLKmatrix, DIM = 2)
Nelements_clk = sz2

sz3 = size(CLKmatrix, DIM = 3)
Nsat_clk = sz3
! ----------------------------------------------------------------------

! Allocatable arrays for the interpolated clock array per satellite
!ALLOCATE (CLKmatrix_int(Nepochs_orb, Nelements_clk, Nsat_clk) , STAT = AllocateStatus)

! Check the availability of the clock error sdev
IF (Nelements_clk == 4) THEN
! Clock error (sdev) is available
Clock_sdev_param = 1
ELSE
Clock_sdev_param = 0
END IF

! ----------------------------------------------------------------------
! Interpolation epoch limits (24h orbit arc or less):
! 1. Interpolation is applied only within the data points (15 min less than 24h arc):  Set Nlimit to 1
! 2. Interpolation is applied also after the last data point's epoch (23h 45min 00sec) in order to cover a 24h arc:  Set Nlimit to 0
Nlimit = 1
! ----------------------------------------------------------------------

! Data rate of clocks (in sec)
data_rate = 1 ! Initialization
      DO i = 1 , Nepochs_clk - 1
		if ( INT(CLKmatrix(i+1,1,1)) - INT(CLKmatrix(i,1,1)) == 0 ) then
			data_rate = INT( CLKmatrix(i+1,2,1) - CLKmatrix(i,2,1) )
			EXIT
		end if
	  End Do

! ----------------------------------------------------------------------
IF (interv_in < 0 .OR. interv_in > data_rate) THEN
	interv = data_rate
ELSE
	interv = interv_in
END IF
! ----------------------------------------------------------------------

      ! Number of points to be interpolated during the span between two epochs
	  Nepoch_int = data_rate / interv - 1

      ! Number of epochs of interpolated orbit (excluding extrapolation at the last point i.e. the start of the next day's sp3: 00h 00min 00sec)
      Nclock_int = (data_rate / interv) * (Nepochs_clk - Nlimit) + Nlimit

! Allocatable arrays for Lagrange Interpolation (declared in mdl_arr.f90)
      ALLOCATE (X_interp(NPint), STAT = AllocateStatus)
      ALLOCATE (Y_interp(NPint), STAT = AllocateStatus)

! Number of data points (used for the interpolation) before and after of each epoch
      NPint_1 = INT(NPint/2)
      NPint_2 = NPint - NPint_1

! ----------------------------------------------------------------------
! Allocatable arrays for the interpolated clock arrays
ALLOCATE (CLKmatrix_int(Nclock_int, Nelements_clk, Nsat_clk) , STAT = AllocateStatus)
ALLOCATE (clock_int(Nclock_int, Nelements_clk) , STAT = AllocateStatus)
ALLOCATE (clock_sat_prn(Nepochs_clk, Nelements_clk) , STAT = AllocateStatus)
! ----------------------------------------------------------------------

!print *,"Nepochs_orb, Nepochs_clk, Nclock_int", Nepochs_orb, Nepochs_clk, Nclock_int

!clock_int = 0.0D0

Do i_sat = 1 , Nsat_clk
i_clock_epoch = 0
Do i_clock_epoch = 1 , Nepochs_clk
Do i_elements = 1 , Nelements_clk
clock_sat_prn(i_clock_epoch, i_elements) = CLKmatrix(i_clock_epoch, i_elements ,i_sat)
End Do
End Do

	  epoch_i = 0
      DO i = 1 , Nepochs_clk
		epoch_i  = epoch_i + 1
		MJD_i    = clock_sat_prn(i,1)
		SecDay_i = clock_sat_prn(i,2)
! ----------------------------------------------------------------------
! Form arrays with data points to be used in the interpolation
		if ( i < NPint_1 ) then
			i1 = i
			i2 = i + (NPint - 1)
			!print *,"Nepochs_clk, i, epoch_i, i1, i2", Nepochs_clk, i, epoch_i, i1, i2
		else if ( Nepochs_clk - i < NPint_2 ) then
			i2 = Nepochs_clk
			i1 = i2 - (NPint-1)
			!print *,"Nepochs_clk, i, epoch_i, i1, i2", Nepochs_clk, i, epoch_i, i1, i2
		else
			i1 = i - (NPint_1 - 1)
			i2 = i + NPint_2
			!print *,"i,epoch_i,i1,i2", i, epoch_i, i1, i2
		end if

        ! Time array of the data points used for the interpolation: X_interp
!		ti = 1
!		X_interp(1) = clock_sat_prn(i1, 2)
!		Do ti = 2 , NPint
!			X_interp(ti) = X_interp(1) + (ti - 1) * data_rate * 1.D0
!		End Do

		ti = 0
		Do j = i1 , i2
		ti = ti + 1
			X_interp(ti) = SecDay_i + (j-i) * data_rate * 1.D0  !(ti - 1) * data_rate * 1.D0
		End Do
	    j = 0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Data Point - Epoch without interpolation
		clock_int(epoch_i, 1:Nelements_clk) = clock_sat_prn(i, 1:Nelements_clk)
        !clock_err = clock_sat_prn(i,3)
		!IF ( Clock_sdev_param == 1 ) THEN
		!clock_sdev = clock_sat_prn(i,Nelements_clk)
		!END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Lagrange Interpolation applied for the new points
! ----------------------------------------------------------------------
! When Nlimit=0 & i=Nepochs_clk : Extrapolation is performed after the last data point of the sp3 file (for completing 24h arc)
If (i <= Nepochs_clk - Nlimit) then
		DO j = 1 , Nepoch_int
			tint = j * interv * 1.D0 + SecDay_i

		!DO j = t(1) , t(NPint) , interv
			!tint = j * interv + clock_sat_prn(i,2)

		! Lagrange Interpolation
			! Clock error X
			Y_interp = clock_sat_prn(i1:i2, 3)
			Call interp_lag(tint, X_interp, Y_interp, Xint)

			! Clock error standard deviation Y
			IF ( Clock_sdev_param == 1 ) THEN
			Y_interp = clock_sat_prn(i1:i2, Nelements_clk)
			Call interp_lag(tint, X_interp, Y_interp, Yint)
			END IF

! Next epoch
			epoch_i = epoch_i + 1
! MJD epoch
			MJD_tint = INT(MJD_i) * 1.D0 + tint / 86400.D0

! Write interpolated values in array
			! Time arguments at interpolation epoch
			clock_int(epoch_i, 1) = MJD_tint

			If (tint > 86400.D0) then
			   tint = tint - 86400.D0
			End If

			clock_int(epoch_i, 2) = tint

			! Clock error (interpolated)
			clock_int(epoch_i, 3) = Xint
			IF ( Clock_sdev_param == 1 ) THEN
			! Clock sdev (interpolated)
			clock_int(epoch_i, Nelements_clk) = Yint
			END IF
		End DO
End IF
! ----------------------------------------------------------------------
      End Do
!print *,"epoch_i", epoch_i

! Write clockint array to the overall CLKmatrix
i_CLKmatrix = 0
i_elements = 0
Do i_CLKmatrix = 1 , Nclock_int
Do i_elements = 1 , Nelements_clk
CLKmatrix_int(i_CLKmatrix, i_elements ,i_sat) = clock_int(i_CLKmatrix, i_elements)
End Do
End Do
!clock_int = 0.0D0

END DO

	  Deallocate (X_interp)
	  Deallocate (Y_interp)
End subroutine

END Module


!*************************************************
! module
!	RESET2D(alpha_lc,detc,jdata_lc,jct_lc,jmt_lc)
!	FREE2D(detf,rsq2_lc,jdata_lc,jct_lc,jmt_lc)
!	_lc :: local variable
!*************************************************

module mod_rf2d

	implicit none

contains
!==========
subroutine RESET2D(alpha_lc,detc,jdata_lc,jct_lc,jmt_lc)

	use prm_matrix
	use prm_var

	implicit none

	real(8), intent(in) :: alpha_lc
	real(8), intent(out) :: detc
	integer, intent(out) :: jdata_lc, jct_lc, jmt_lc

	integer :: i, k, ii

	do i = 1, itotal
		y2d(i) = gz(i)
		do k = 1, jmp
			z2d(i,k) = rt(i,k)
		end do
	end do

	do ii = itotal +1, itotal + jcp
		y2d(ii) = 0.d0
	end do

	do k = 1, jmp
		do i = 1, jcp
			z2d(i+itotal,k) = cs2d(i,k) * alpha_lc
		end do
	end do

	jmt_lc = jmp
	jct_lc = jcp

	jdata_lc = itotal
	detc = detca

return

end subroutine RESET2D

!==========
subroutine FREE2D(detf,rsq2_lc,jdata_lc,jct_lc,jmt_lc)

	use prm_matrix
	use prm_var
	use mod_qrdec

	implicit none

	integer, intent(in) :: jdata_lc, jct_lc, jmt_lc
	real(8), intent(out) :: rsq2_lc
	real(8), intent(inout) :: detf

	real(8) :: wk1(kdata2)
	integer :: jtotal, jmtt, i

	jtotal = jdata_lc + jct_lc

	CALL QRDEC(z2d, y2d, detf, kdata2, jtotal, jmt_lc, wk1, lu2d, jmtt, 1)

	if(jmtt /= jmt_lc) then
		print *, ' ERROR NO SOLUTION FOR BASIC LSQS/ JMT,JMTT', jmt_lc, jmtt
		stop
	end if

	rsq2_lc = 0.d0

	do i = jmt_lc+1, jtotal
		rsq2_lc = rsq2_lc + y2d(i) * y2d(i)
	end do

	CALL RINV(x2d, y2d, z2d, kdata2, jmt_lc, 0)

return
end subroutine FREE2D

end module mod_rf2d