      SUBROUTINE DSPECX(X,NX,IOPT,JAVE,PCT,SCL,WORK,LWORK,FRQ,SPCX,NSPC,
     +                  SINFO,IER)
      DOUBLE PRECISION PCT
      DOUBLE PRECISION SCL
      DOUBLE PRECISION COEF
      DOUBLE PRECISION XINFO
      DOUBLE PRECISION SPVAL
      DOUBLE PRECISION X1X
      DOUBLE PRECISION FRQSP
      DOUBLE PRECISION DOF

      INTEGER NX,IOPT,JAVE,LWORK,NSPC,IER
      DOUBLE PRECISION X(NX),FRQ(*),SPCX(*),WORK(LWORK),SINFO(50)

c specx will perform a spectral analysis on the series x of length nx.

c comment :
c .   common block /spblk3/ contains assorted info the user may find
c .   useful.  it was used primarily to debug this routine.

c nomenclature:

c .   input
c .
c .   x         - real series containing the data (unchanged upon
c .               return)
c .   nx        - number of points in x
c .               nx need not be a power of 2 but the fft will run
c .               optimally if nx is highly factorable.
c .   iopt      - detrending option
c .               iopt<0 : do no detrending.
c .               iopt=0 : remove series mean (minimum recommended
c .                        option)
c .               iopt=1 : remove the series mean and lst sqrs linear
c .                        trend
c .               iopt=2 : remove the series mean and lst sqrs
c .                        quadratic trend
c .                        know what you are doing before applying
c .                        this option
c .   jave      - smoothing to be performed on the periodiogram
c .               this should be an odd number (>=3) , if not, the
c .               routine will force it to the next largest odd number.
c .               jave=0 : do no smoothing
c .                        spcx contains raw spectral estimates
c .                        (periodogram)
c .               jave>0 : average jave periodogram estimates together
c .                        utilizing modified daniell smoothing (good
c .                        stability but may lead to large bias ).
c .                        all weights are 1/jave except wgt(1) and
c .                        wgt(jave) which are 1/(2*jave). this is
c .                        the recommended option.
c .   pct       - % of the series to be tapered [0.<=pct>=1.]
c .               if pct=0. no tapering will be done
c .               if pct=1. the whole series is effected
c .               a pct of 0.10 is common. tapering should always be
c .               done unless the data is strictly periodic.
c .   scl       - scaling factor (there are 4 special cases.)
c .               scl = -1.: spcx estimates are scaled so that the area
c .                          under the curve [ s(f)*df ] equals one.
c .               scl = 0. : spcx estimates are scaled so that the sum
c .                          of the spectral estimates is the same as
c .                          the variance of the detrended (optional)
c .                          input series
c .               scl = 1. : spcx estimates are as calculated  by g13cbf
c .               scl = 2. : spcx estimates are scaled so that the area
c .                          under the curve [ s(f)*df ] equals the
c .                          variance of the detrended (optional)
c .                          input series.
c .               scl= 2 or -1. is recommended
c .   work      - work array
c .               if jave.ne.0 then upon return work(1 thru nspc) will
c .               contain the raw spectral estimates [i.e. ,
c .               periodogram]
c .   lwork     - length of work [ must be >= 5*nx + 17 +iabs(jave) + 1]
c .
c .   output
c .
c .   frq       - frequency vector of length nspc
c .   spcx      - spectrum : vector of length nspc
c .               spcx(1)     - this will be the **mean* of the
c .                             detrended-tapered series. it
c .                             is not a variance. it is not the
c .                             spectral estimate at freq = 0
c .               spcx(2)     - spectral estimate at freq = 1/nx
c .               spcx(3)     - spectral estimate at freq = 2/nx
c .                           .
c .               spcx(nspc) - spectral estimate at freq = 0.5
c .   nspc      - the number of spectral estimates returned (=nx/2+1)
c .   sinfo     - vector of length 10 ==> 23 for NCL
c .        (1)  - equivalent degrees of freedom
c .        (2)  - lag1 autocor of detrended/tapered x series
c .        (3)  - lag1 autocor of detrended/tapered y series for specxy
c .        (4)  - unused
c .        (5)  - freq spacing between estimates
c .        (6)  - band width (=sinfo(1)*sinfo(5)*0.5)
c .        (7)  - mult factor for  5% limit
c .        (8)  - mult factor for 95% limit
c .        (9)  - dof for series via spectrum shape(blackmon-tukey)
c .        (10) - unused
c .   ier       - error code
c .               ier=0 : no error
c .               ier'0 : see code

c sample call :

c .   real x(nx) , frq(nx/2+1) , spcx(nx/2+1)
c .              , workk(5*nx+18+iabs(jave)) , sinfo(50)
c .   iopt = 0     : remove mean
c .   jave = 11    : block average 11 periodogram est together
c .   pct  = 0.10  : taper 10% of the series
c .   scl  = 1.0   : no scaling. leave ``as"
c .   call specx  (x,nx,iopt,jave,pct,scl,work,lwork
c .              ,frq,spcx,nspc,frqsp,dof,ier)

c common block /spblk / contains other potentially useful info

c .   coef      - contains coef utilized to remove trend (if any)
c .   xinfo(1)  - mean of x prior to tapering / detrending
c .        (2)  - variance of x prior to tapering / detrending
c .        (3)  - variance of x after detrending and prior to tapering
c .        (4)  - raw sum of spcx(2 thru nspc) with no scaling or
c .               smoothing
c .               this is the variance of the detrended - tapered
c .               series.
c .        (5)  - raw sum of spcx(2 thru nspc) after smoothing
c .        (6)  - scaling utilized to normalize the spectrum to xinfo(3)
c .        (7)  - white noise level [=scale*xinfo(3)/(nspc-1)]
c .        (8)  - correction factor to dof due to tapering  (cftapr)
c .        (9)  - unused
c .        (10) - unused

      COMMON /SPBLK/COEF(3),XINFO(10)

      DATA SPVAL/1.D+36/

c check input for errors

      IER = 0
      IF (NX.LE.3) IER = 1
      IF (IOPT.GT.2) IER = IER + 20
      IF (PCT.LT.0.D0 .OR. PCT.GT.1.0D0) IER = IER + 300
      IF (LWORK.LT. (5*NX+18+IABS(JAVE))) IER = IER + 4000
      IF (IABS(JAVE).GT. (NX/2)) IER = IER + 50000

c c c do 3 n=1,nx
C check for missing values
c c c if (x(n).ne.spval) go to 4
c c 3 continue
c c c ier = ier+60000
    4 X1X = X(1)
      DO 5 N = 1,NX
C check for series of constant values
          IF (X(N).NE.X1X) GO TO 6
    5 CONTINUE
      IER = IER + 700000

C set common block to spval
    6 DO 7 N = 1,3
    7 COEF(N) = SPVAL
      DO 8 N = 1,10
          SINFO(N) = SPVAL
    8 XINFO(N) = SPVAL
      DO 88 N = 11,50
   88 SINFO(N) = SPVAL

      DO 9 N = 1,(NX/2+1)
          FRQ(N) = SPVAL
C set spectral estimates to spval
    9 SPCX(N) = SPVAL
      NSPC = 0

      IF (IER.NE.0) THEN
C return to calling prog
          RETURN
      END IF

c initilize pointers for work vector

      NX2 = NX/2
      NSPC = NX2 + 1
C pointer to real fourier coef vector
      KPTRC = NX + 1
C pointer to imag fourier coef vector
      KPTIC = KPTRC + NX2
C pointer to work vector for ezfft
      KPTSAV = KPTIC + NX2
C pointer to wgt  vector
      KPTWGT = KPTSAV + (3*NX+17)

c transfer the input series x to the work array

      DO 10 N = 1,NX
   10 WORK(N) = X(N)
      DO 15 N = NX + 1,LWORK
   15 WORK(N) = SPVAL

c initilize fft work space

      CALL DEZFFTI(NX,WORK(KPTSAV))

c spectral driver

      NLAG1 = 2
      CALL DSPECXD(WORK,NX,IOPT,JAVE,PCT,SCL,FRQ,SPCX,NSPC,FRQSP,DOF,
     +            IER,WORK(KPTRC),WORK(KPTIC),WORK(KPTSAV),WORK(KPTWGT),
     +            SPVAL,NX2,COEF,XINFO,SINFO,NLAG1)

C NCL add to sinfo
      DO 133 N = 1,10
          SINFO(10+N) = XINFO(N)
  133 CONTINUE
      DO 134 N = 1,3
          SINFO(30+N) = COEF(N)
  134 CONTINUE

      RETURN
      END
c -------------------------------------------------------------------
      SUBROUTINE DSPECXY(X,Y,NX,IOPT,JAVE,PCT,SCL,WORK,LWORK,FRQ,SPCX,
     +                   SPCY,COSPC,QUSPC,COHER,PHASE,NSPC,SINFO,IER)
      DOUBLE PRECISION PCT
      DOUBLE PRECISION SCL
      DOUBLE PRECISION XCOEF
      DOUBLE PRECISION XINFO
      DOUBLE PRECISION YCOEF
      DOUBLE PRECISION YINFO
      DOUBLE PRECISION SPVAL
      DOUBLE PRECISION X1X
      DOUBLE PRECISION Y1Y
      DOUBLE PRECISION FRQSP
      DOUBLE PRECISION DOF
      DOUBLE PRECISION SCLCS
      DOUBLE PRECISION SCLCOH

c specxy will perform a spectral/cross spc analysis on series x and y.

c nomenclature:

c .   input
c .
c .   x         - real series containing the data (unchanged upon
c .               return)
c .   y         - real series containing the data (unchanged upon
c .               return)
c .   nx        - number of points in x and y (need not be a power of 2)
c .   iopt      - detrending option
c .               iopt<0 : do no detrending.
c .               iopt=0 : remove series mean (minimum recommended
c .                        option)
c .               iopt=1 : remove the series mean and lst sqrs linear
c .                        trend
c .               iopt=2 : remove the series mean and lst sqrs
c .                        quadratic trend
c .                        know what you are doing before applying
c .                        this option
c .   jave      - no. of spectral estimates to be averaged
c .   pct       - % of the series to be tapered [0.<=pct>=1.]
c .               if pct=0. no tapering will be done
c .               if pct=1. the whole series is effected
c .               a pct of 0.10 is common. tapering should always be
c .               done unless the data is strictly periodic.
c .   scl       - scaling factor (there are 4 special cases.)
c .               scl = -1.: spcx estimates are scaled so that the area
c .                          under the curve [ s(f)*df ] equals one.
c .               scl = 0. : spcx estimates are scaled so that the sum
c .                          of the spectral estimates is the same as
c .                          the variance of the detrended (optional)
c .                          input series
c .               scl = 1. : spcx estimates are as calculated  by g13cbf
c .               scl = 2. : spcx estimates are scaled so that the area
c .                          under the curve [ s(f)*df ] equals the
c .                          variance of the detrended (optional)
c .                          input series.
c .   work      - work array
c .   lwork     - length of work [ must be >= 10*nx ]
c .
c .   output
c .
c .   spcx,spcy - spectrum vector of length nspc for x and y series
c .               spcx(1)    - spectral estimate at freq = 0 (ignore)
c .               spcx(nspc) - spectral estimate at freq = 0.5
c .   cospc     - cospectrum : vector of length nspc
c .               this is the real part of the cross spectrum. it
c .               measures the extent to which there are oscillations
c .               with the same phase in the two series (or with
c .               opposite sign ,i.e. , with a phase shift of half a
c .               cycle). In other words : it measures the
c .               contribution of different frequencies to the total
c .               cross-covariance at zero lag.
c .   quspc     - quadrature spectrum  : vector of length nspc
c .               this is the imaginary part of the cross spectrum. it
c .               measures the extent to which there are oscillations
c .               with a phase difference of a quarter cycle in either
c .               direction. i.e., it measures the contribution of
c .               different frequencies to the total cross-covariance
c .               of the series when all harmonics of one series
c .               are delayed a quarter cycle relative to the other
c .               relative to the other series.
c .   coher     - coherence squared  : vector of length nspc
c .               this is analogous to the square of the correlation
c .               coef except that the coherence squared is a
c .               function of frequency.
c .   phase     - phase (in degrees)  : vector of length nspc.
C)
c .               a positive phase indicates that y leads x (i think
c .   nspc      - the number of spectral estimates returned
c .               routine is set up so that nspc=nx/2+1
c .   sinfo     - must be dimensioned at least 10 in calling prog
c .               sinfo(1)  - degrees of freedom  (dof)
c .                           the dof for the cospc,quspc,coher and
c .                            phase is approximately dof-2 .
c .                    (2)  - lag1 autocor of detrended/tapered x series
c .                    (3)  - lag1 autocor of detrended/tapered y series
c .                    (4)  - unused
c .                    (5)  - freq spacing at which values should be
c .                           plotted
c .                    (6)  - `normal' bandwidth
c .                    (7)  - mult factor for  5% limit (imsl)
c .                    (8)  - mult factor for 95% limit (imsl)
c .                    (9)  - unused
c .                    (10) - unused
c .   ier       - error code
c .               ier=0 : no error
c .               ier<0 : error detected by spcng2: see code
c .               ier>0 : error detected by nag routine

c common blocks /spblkx,spblky/ contain other potentially useful info

c .   x/ycoef     - contains coef utilized to remove trend (if any)
c .   x/yinfo(1)  - mean of x prior to tapering / detrending
c .          (2)  - variance of x prior to tapering / detrending
c .          (3)  - variance of x after detrending and prior to tapering
c .          (4)  - raw sum of spcx(2 thru nspc) after smoothing
c .          (5)  - same as xinfo(4)
c .          (6)  - scaling utilized to normalize the spectrum to
c .                 xinfo(3)
c .          (7)  - white noise level [=xinfo(3)/(nspc-1)]
c .          (8)  - correction factor to dof due to tapering  (cftapr)
c .          (9)  - unused
c .          (10) - unused

      DOUBLE PRECISION X(NX),Y(NX),FRQ(*),SPCX(*),SPCY(*),WORK(LWORK),
     +                 COSPC(*),QUSPC(*),PHASE(*),COHER(*),SINFO(50)

      COMMON /SPBLKX/XCOEF(3),XINFO(10)
      COMMON /SPBLKY/YCOEF(3),YINFO(10)

      DATA SPVAL/1.D+36/

c check input for errors

      IER = 0
      IF (NX.LE.3) IER = 1
      IF (IOPT.GT.2) IER = IER + 20
      IF (PCT.LT.0.D0 .OR. PCT.GT.1.0D0) IER = IER + 300
      IF (LWORK.LT.10*NX) IER = IER + 4000
      IF (IABS(JAVE).GT. (NX/2)) IER = IER + 50000

      DO 2 N = 1,NX
C chk for msg values
          IF (X(N).EQ.SPVAL .OR. Y(N).EQ.SPVAL) THEN
              IER = IER + 60000
              GO TO 3
          END IF
    2 CONTINUE
    3 X1X = X(1)
      DO 4 N = 1,NX
C check for series of constant values
          IF (X(N).NE.X1X) GO TO 5
    4 CONTINUE
      IER = IER + 700000
      GO TO 6
    5 Y1Y = Y(1)
      DO 55 N = 1,NX
C check for series of constant values
          IF (Y(N).NE.Y1Y) GO TO 6
   55 CONTINUE
      IER = IER + 700000

    6 IF (IER.NE.0) THEN
C set common block to spval
          DO 7 N = 1,3
              XCOEF(N) = SPVAL
    7     YCOEF(N) = SPVAL
          DO 8 N = 1,10
              SINFO(N) = SPVAL
              YINFO(N) = SPVAL
    8     XINFO(N) = SPVAL
          DO 88 N = 11,50
   88     SINFO(N) = SPVAL
          DO 9 N = 1,(NX/2+1)
              FRQ(N) = SPVAL
              COSPC(N) = SPVAL
              QUSPC(N) = SPVAL
              COHER(N) = SPVAL
              PHASE(N) = SPVAL
              SPCY(N) = SPVAL
    9     SPCX(N) = SPVAL
          NSPC = 0
C return to calling prog
          RETURN
      END IF

c initilize pointers for work vector

      NX2 = NX/2
      NSPC = NX2 + 1
C pointer to real fourier coef vec x
      KPTRCX = NX + 1
C pointer to imag fourier coef vec x
      KPTICX = KPTRCX + NX2
C pointer to real fourier coef vec y
      KPTRCY = KPTICX + NX2
C pointer to imag fourier coef vec y
      KPTICY = KPTRCY + NX2
C pointer to imag fourier coef vec y
      KPTSAV = KPTICY + NX2
C pointer to wgt  vector
      KPTWGT = KPTSAV + (3*NX+17)

c transfer the input series x to the work array

      DO 10 N = 1,NX
   10 WORK(N) = X(N)
      DO 15 N = NX + 1,LWORK
   15 WORK(N) = SPVAL

c initilize fft work space

      CALL DEZFFTI(NX,WORK(KPTSAV))

c spectral driver (x vector)

      NLAG1 = 2
      CALL DSPECXD(WORK,NX,IOPT,JAVE,PCT,SCL,FRQ,SPCX,NSPC,FRQSP,DOF,
     +            IER,WORK(KPTRCX),WORK(KPTICX),WORK(KPTSAV),
     +            WORK(KPTWGT),SPVAL,NX2,XCOEF,XINFO,SINFO,NLAG1)

c transfer the input series y to the work array

      DO 20 N = 1,NX
   20 WORK(N) = Y(N)

c spectral driver (y vector)

      NLAG1 = 3
      CALL DSPECXD(WORK,NX,IOPT,JAVE,PCT,SCL,FRQ,SPCY,NSPC,FRQSP,DOF,
     +            IER,WORK(KPTRCY),WORK(KPTICY),WORK(KPTSAV),
     +            WORK(KPTWGT),SPVAL,NX2,YCOEF,YINFO,SINFO,NLAG1)

c compute the cospectrum and quadrature spectrum

      SCLCS = SQRT(XINFO(6)*YINFO(6))
      COSPC(1) = SPCX(1)*SPCY(1)
      QUSPC(1) = SPCX(1)*SPCY(1)
      DO 60 N = 0,NX2 - 1
          COSPC(N+2) = SCLCS* (WORK(KPTRCX+N)*WORK(KPTRCY+N)+
     +                 WORK(KPTICX+N)*WORK(KPTICY+N))
C minus sign is to match nag output
   60 QUSPC(N+2) = -SCLCS* (WORK(KPTICX+N)*WORK(KPTRCY+N)-
     +             WORK(KPTRCX+N)*WORK(KPTICY+N))

      KOPT = 1
      JAVODD = 2*IABS(JAVE/2) + 1
C can use work again
      CALL DSWRNAV(COSPC(2),NSPC-1,WORK(KPTWGT),JAVODD,KOPT,SPVAL,WORK,
     +            IER)
      CALL DSWRNAV(QUSPC(2),NSPC-1,WORK(KPTWGT),JAVODD,KOPT,SPVAL,WORK,
     +            IER)

c compute the coherence and phase now that the co/quspc have been
c calculated

      SCLCOH = 1.0D0
      DO 70 N = 1,NSPC
          PHASE(N) = ATAN2(QUSPC(N),COSPC(N))*57.29578D0
          IF (SPCX(N).NE.0.D0 .AND. SPCY(N).NE.0.D0) THEN
              COHER(N) = SCLCOH* (COSPC(N)**2+QUSPC(N)**2)/
     +                   (SPCX(N)*SPCY(N))
          ELSE
              COHER(N) = 0.D0
          END IF
   70 CONTINUE

C NCL add to sinfo
      DO 133 N = 1,10
          SINFO(10+N) = XINFO(N)
          SINFO(20+N) = YINFO(N)
  133 CONTINUE
      DO 134 N = 1,3
          SINFO(30+N) = XCOEF(N)
          SINFO(33+N) = YCOEF(N)
  134 CONTINUE

      RETURN
      END
c --------------------------------------------------------------------
      SUBROUTINE DSPECXD(X,NX,IOPT,JAVE,PCT,SCL,FRQ,SPC,NSPC,FRQSP,DOF,
     +                   IER,CR,CI,SAVE,WGT,SPVAL,NX2,COEF,XINFO,SINFO,
     +                   NLAG1)
      DOUBLE PRECISION PCT
      DOUBLE PRECISION SCL
      DOUBLE PRECISION FRQSP
      DOUBLE PRECISION DOF
      DOUBLE PRECISION SPVAL
      DOUBLE PRECISION XMSG
      DOUBLE PRECISION PI
      DOUBLE PRECISION WGTSQ
      DOUBLE PRECISION CFTAPR
      DOUBLE PRECISION SCALE
      DOUBLE PRECISION XMEAN
      DOUBLE PRECISION XMEANX
      DOUBLE PRECISION XVARX
      DOUBLE PRECISION AZERO
      DOUBLE PRECISION WGTSUM

      DOUBLE PRECISION X(NX),FRQ(NSPC),SPC(NSPC),SAVE(*),WGT(*),CR(NX2),
     +                 CI(NX2),COEF(3),XINFO(10),SINFO(50)
      PARAMETER (MXLAG=1,XMSG=1.D+36)
      DOUBLE PRECISION ACV(0:MXLAG),ACR(0:MXLAG)

      DATA PI/3.141592653589D0/

c initilize some constants

      DF   = 1.0D0/DBLE(NX)
      NXP1 = NX + 1
      NXM1 = NX - 1
      NSPCM1 = NSPC - 1
      FRQSP = 1.D0/DBLE(NX)
      WGTSQ = 1.0D0
      DOF = 2.0D0
      CFTAPR = 1.0D0
      SCALE = SCL
      DO 20 N = 1,10
   20 XINFO(N) = SPVAL

c perform detrending option (iopt)
c .   the mean and variance will always be calculated
c .   note : if iopt=1 or 2 then the variance of x on output [xinfo(3)]
c .   may be considerably different (reduced) from the variance of x
c .   on input [xinfo(2)]. xinfo(1) will contain the mean of the
c .   input series.

      CALL DDTRNDX (X,NX,IOPT,XINFO(1),XINFO(2),XINFO(3),COEF,IER)

c perform tapering on detrended x vector
c .   the tapering procedure alters the variance of the input
c .   series and as a result lowers the dof associated with each
c .   spectral estimate. if pct is 0.05 or 0.10 then the effect is
c .   small.
c .   the purpose of tapering when viewed from the frequency domain
c .   is to suppress large side lobes in the effective filter obtained
c .   with the raw transform. in the time domain , the object of
c .   tapering is to round off potential discontinuities at each end
c .   of the finite segment being analyzed.

      IF (PCT.GT.0.0D0) THEN
          IF (IOPT.GE.0) THEN
              XMEAN = 0.0D0
          ELSE
              XMEAN = XINFO(1)
          END IF
          CALL DTAPERX(X,NX,PCT,XMEAN,CFTAPR)
      END IF

c calculate lag1 autocorrelation

      XMEANX = XMSG
      XVARX = XMSG
      CALL DESAUTO(X,NX,XMSG,XMEANX,XVARX,MXLAG,ACV,ACR,IER)
      SINFO(NLAG1) = ACR(1)

c perform an fft on the detrended-tapered series with zeros added

      CALL DEZFFTF(NX,X,AZERO,CR,CI,SAVE)

c calculate the raw spectrum  sum the spectral estimates

      SPC(1) = AZERO
      DO 40 N = 2,NSPC
   40 SPC(N) = (CR(N-1)**2+CI(N-1)**2)

      XINFO(4) = 0.0D0
      DO 41 N = 2,NSPC
   41 XINFO(4) = XINFO(4) + SPC(N)
      XINFO(5) = XINFO(4)

c smooth the raw spectral estimates (if desired)

C make sure its odd
      IF (IABS(JAVE).GT.2) THEN
          JAVODD = 2*IABS(JAVE/2) + 1
          DO 70 N = 2,JAVODD - 1
   70     WGT(N) = 1.00D0
          WGT(1) = 0.5D0
          WGT(JAVODD) = 0.5D0

c normalize the sum of the wgts to one then sum the square of the
c .   normalized wgts to calculate the deg of freedom

          WGTSUM = 0.0D0
          DO 120 N = 1,JAVODD
  120     WGTSUM = WGTSUM + WGT(N)

          DO 123 N = 1,JAVODD
  123     WGT(N) = WGT(N)/WGTSUM

          WGTSQ = 0.0D0
          DO 125 N = 1,JAVODD
  125     WGTSQ = WGTSQ + WGT(N)**2

c perform weighted running ave
c .   kopt = 1 means to utilize symmetric averaging at the ends of
c .   the spectrum. note : spc(1) is not utilized. if the user does
c .   want this estimate included in the averaging change the (2) to
c .   (1) for both spc and x and nspcm1 to nspc.

          KOPT = 1
          X(1) = SPC(1)
          CALL DSWRNAV(SPC(2),NSPCM1,WGT,JAVODD,KOPT,SPVAL,X(2),IER)

      END IF

c sum the spectral estimates
C only half the width

      XINFO(5) = (SPC(2)+SPC(NSPC))*0.5D0*DF
      DO 150 N = 3,NSPC-1
  150 XINFO(5) = XINFO(5) + SPC(N)*DF

      IF (SCL.EQ.0.D0) THEN
C scale sum spcx to input variance
          XINFO(6) = XINFO(3)/XINFO(5)
C white noise level
          XINFO(7) = XINFO(3)/DBLE(NSPC)
      ELSE IF (SCL.EQ.1.D0) THEN
C keep spcx as returned by g13cbf
          XINFO(6) = 1.0D0
C white noise level
          XINFO(7) = XINFO(5)/DBLE(NSPC-1)
      ELSE IF (SCL.EQ.-1.D0) THEN
C scal spcx estimate to 1.0
          XINFO(6) = 1.0D0*DBLE(NX)/XINFO(5)
C white noise level
          XINFO(7) = 1.0D0/DBLE(NSPC)
C white noise level
c        xinfo(7) = 1.0*float(nx)/float(nspc)
      ELSE IF (SCL.EQ.2.D0) THEN
C area under curve=total variance
          XINFO(6) = XINFO(3)/XINFO(5)
C white noise level
          XINFO(7) = XINFO(3)/DBLE(NSPC)
      ELSE
C user specified scaling
          XINFO(6) = SCL
C white noise level
          XINFO(7) = SCL*XINFO(5)/DBLE(NSPC)
      END IF

      DO 250 N = 2,NSPC
  250 SPC(N) = SPC(N)*XINFO(6)

      XINFO(8) = CFTAPR

c correct the dof for :
c .   (1) the tapering , if any  [the factor cftapr]
c .   (2) the weighting utilized [the factor wgtsq]

      DOF = DOF/ (CFTAPR*WGTSQ)

      SINFO(1) = DOF
      SINFO(5) = FRQSP
C see jones pg 202: murphy + katz
      SINFO(6) = SINFO(1)*SINFO(5)*0.5D0
      IF (DOF.GT.0.50D0) THEN
C imsl
c imsl   sinfo(7) = chiin (0.05,dof)/dof
c imsl   sinfo(8) = chiin (0.95,dof)/dof
          IFAIL = 0
          JFAIL = 0
C nag
c nag    sinfo(7) = g01ccf (0.05,dof,ifail)/dof
c nag    sinfo(8) = g01ccf (0.95,dof,jfail)/dof
          SINFO(7) = SPVAL
          SINFO(8) = SPVAL
      ELSE
          SINFO(7) = SPVAL
          SINFO(8) = SPVAL
      END IF

      DO 270 N = 1,NSPC
  270 FRQ(N) = SINFO(5)*DBLE(N-1)

c c c call specdf  (frq,spc,nspc,sinfo(9),ier)

      RETURN
      END
c --------------------------------------------------------------------
      SUBROUTINE DTAPERX(X,N,P,XAV,CFT)
      DOUBLE PRECISION X
      DOUBLE PRECISION P
      DOUBLE PRECISION XAV
      DOUBLE PRECISION CFT
      DOUBLE PRECISION PI
      DOUBLE PRECISION PIM
      DOUBLE PRECISION WEIGHT
c
c this subroutine applies split-cosine-bell tapering tothe series x.
c .   the series will be tapered to the mean of x.
c
c arguments:
c .   x   series to be tapered (tapering done in place)
c .   n   series length
c .   p   the proportion of the time series to be tapered [p=0.10 means
c .   xav mean of the input series x (i.e., value to which the series
c .       should be tapered). if the series mean has been removed then
c .       xav = 0.0
c .   cft correction factor for taper (not used , for info only)
c
      DIMENSION X(N)
      DATA PI/3.141592653589D0/

      M = MAX0(1,INT(P*DBLE(N)+0.5D0)/2)
      PIM = PI/DBLE(M)
      DO I = 1,M
          WEIGHT = 0.5D0 - 0.5D0*COS(PIM* (DBLE(I)-0.5D0))
          X(I) = (X(I)-XAV)*WEIGHT + XAV
          X(N+1-I) = (X(N+1-I)-XAV)*WEIGHT + XAV
      END DO
      CFT = 0.5D0* (128.D0-93.D0*P)/ (8.D0-5.D0*P)**2
      RETURN
      END
c -------------------------------------------------------------------
      SUBROUTINE DSWRNAV(X,NPTS,WGT,NPTAV,KOPT,SPVL,WORK,IER)
      DOUBLE PRECISION X
      DOUBLE PRECISION WGT
      DOUBLE PRECISION SPVL
      DOUBLE PRECISION WORK
      DOUBLE PRECISION WSUM
      DOUBLE PRECISION XNAV
c
c this routine will perform a weighted running average on x
c .   several options are given for end points
c
c nomenclature:
c .   x         - on input the series to be smoothed
c .               on output the smoothed series
c .   npts      - no of pts in x
c .   wgt       - vector of length nptav containing the wgts
c .               e.g. , nptav=3 : wgt(1) = 1. , wgt(2) = 2. , wgt(3) =
c .                             or wgt(1) = .25, wgt(2) = .50, wgt(3) =
c .   nptav     - no. of pts to be utilized in the running average
c .               nptav must be odd and >= 3
c .   kopt      - end-point option
c .               kopt < 0 : utilize cyclic conditions
c .                          e.g.,  nptav=3 at n=1
c .                          x(1)=(wgt(1)*x(npts)+wgt(2)*x(1)+
c .                                wgt(3)*x(2))/(wgt(1)+wgt(2)+wgt(3))
c .               kopt = 0 : set unsmoothed beginning and end pts to
c .                          spvl
c .                          e.g.,  nptav=3 , x(1) = spvl and x(npts) =
c .               kopt > 0 : utilize reflective (symmetric) conditions
c .                          e.g.,  nptav=3 at n=1
c .                          x(1)=(wgt(1)*x(2)+wgt(2)*x(1)+wgt(3)*x(2))
c .                              /(wgt(1)+wgt(2)+wgt(3))
c .   spvl      - if kopt=0 set end points to this special value
c .               spvl = 0. or 1.e+36 or the series mean are common
c .   work      - work vector of length npts
c .               on return this will contain the unsmoothed series
c .   ier       - error flag
c .               ier = 0 : no errors
c .               ier = -11 : npts @ 0
c .               ier = -12 : npts < nptav
c .               ier = -13 : nptav is not odd
c
      DIMENSION X(NPTS),WORK(NPTS),WGT(NPTAV)

      IER = 0
      IF (NPTS.LT.1) IER = -11
      IF (NPTAV.GT.NPTS) IER = -12
      IF (MOD(NPTAV,2).EQ.0) IER = -13
      IF (IER.LT.0) RETURN

c dup the vectors

      DO N = 1,NPTS
          WORK(N) = X(N)
      END DO

      IF (NPTAV.LT.3) RETURN

c sum the wgts

      WSUM = 0.0D0
      DO N = 1,NPTAV
          WSUM = WSUM + WGT(N)
      END DO
      IF (WSUM.GT.1.0D0) THEN
          XNAV = 1.0D0/WSUM
      ELSE
          XNAV = 1.0D0
      END IF

c do the middle pts first

      NAV = NPTAV
      NAV2 = NAV/2
      NSTRT = NAV2 + 1
      NEND = NPTS - NAV2

      DO N = NSTRT,NEND
          MSTRT = N - NAV2
          MEND = N + NAV2
          ML = 0
          WSUM = 0.D0
          DO M = MSTRT,MEND
              ML = ML + 1
              WSUM = WSUM + WORK(M)*WGT(ML)
          END DO
          X(N) = WSUM*XNAV
      END DO
      IF (KOPT.NE.0) THEN
          NAV2P2 = NAV2 + 2
          DO N = 1,NAV2
              MEND = NAV2 + N
              MLSTRT = NAV2P2 - N
              ML = MLSTRT - 1
              WSUM = 0.0D0
              DO M = 1,MEND
                  ML = ML + 1
                  WSUM = WSUM + WORK(M)*WGT(ML)
              END DO

              MEND = NAV2P2 - N
              ML = MLSTRT
              DO M = 2,MEND
                  ML = ML - 1
                  MLOC = M
                  IF (KOPT.LT.0) MLOC = NPTS + 1 - M
                  WSUM = WSUM + WORK(MLOC)*WGT(ML)
              END DO

              X(N) = WSUM*XNAV
          END DO

c do the final portion of x

          NPTS2 = 2*NPTS
          NSTRT = NPTS - NAV2 + 1
          DO N = NSTRT,NPTS
              MSTRT = N - NAV2
              MEND = N + NAV2
              ML = 0
              WSUM = 0.0D0
              DO M = MSTRT,MEND
                  ML = ML + 1
                  MLOC = M
                  IF (MLOC.GT.NPTS .AND. KOPT.GT.0) MLOC = NPTS2 - MLOC
                  IF (MLOC.GT.NPTS .AND. KOPT.LT.0) MLOC = MLOC - NPTS
                  WSUM = WSUM + WORK(MLOC)*WGT(ML)
              END DO
              X(N) = WSUM*XNAV
          END DO
          RETURN
      END IF
      DO N = 1,NAV2
          X(N) = SPVL
      END DO
      NSTRT = NPTS - NAV2 + 1
      DO N = NSTRT,NPTS
          X(N) = SPVL
      END DO

      RETURN
      END


      SUBROUTINE SB10WD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, F, LDF, H, LDH, TU, LDTU, TY, LDTY,
     $                   AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of the H2 optimal controller
C
C              | AK | BK |
C          K = |----|----|,
C              | CK | DK |
C
C     from the state feedback matrix F and output injection matrix H as
C     determined by the SLICOT Library routine SB10VD.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0.
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0.
C             M-NCON >= NMEAS.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B. Only the submatrix
C             B2 = B(:,M-M2+1:M) is used.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C. Only the submatrix
C             C2 = C(NP-NP2+1:NP,:) is used.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system input/output matrix D. Only the submatrix
C             D22 = D(NP-NP2+1:NP,M-M2+1:M) is used.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     F       (input) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading NCON-by-N part of this array must contain the
C             state feedback matrix F.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= max(1,NCON).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,NMEAS)
C             The leading N-by-NMEAS part of this array must contain the
C             output injection matrix H.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     TU      (input) DOUBLE PRECISION array, dimension (LDTU,M2)
C             The leading M2-by-M2 part of this array must contain the
C             control transformation matrix TU, as obtained by the
C             SLICOT Library routine SB10UD.
C
C     LDTU    INTEGER
C             The leading dimension of the array TU.  LDTU >= max(1,M2).
C
C     TY      (input) DOUBLE PRECISION array, dimension (LDTY,NP2)
C             The leading NP2-by-NP2 part of this array must contain the
C             measurement transformation matrix TY, as obtained by the
C             SLICOT Library routine SB10UD.
C
C     LDTY    INTEGER
C             The leading dimension of the array TY.
C             LDTY >= max(1,NP2).
C
C     AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
C             The leading N-by-N part of this array contains the
C             controller state matrix AK.
C
C     LDAK    INTEGER
C             The leading dimension of the array AK.  LDAK >= max(1,N).
C
C     BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
C             The leading N-by-NMEAS part of this array contains the
C             controller input matrix BK.
C
C     LDBK    INTEGER
C             The leading dimension of the array BK.  LDBK >= max(1,N).
C
C     CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
C             The leading NCON-by-N part of this array contains the
C             controller output matrix CK.
C
C     LDCK    INTEGER
C             The leading dimension of the array CK.
C             LDCK >= max(1,NCON).
C
C     DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
C             The leading NCON-by-NMEAS part of this array contains the
C             controller input/output matrix DK.
C
C     LDDK    INTEGER
C             The leading dimension of the array DK.
C             LDDK >= max(1,NCON).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine implements the formulas given in [1], [2].
C
C     REFERENCES
C
C     [1] Zhou, K., Doyle, J.C., and Glover, K.
C         Robust and Optimal Control.
C         Prentice-Hall, Upper Saddle River, NJ, 1996.
C
C     [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
C         Smith, R.
C         mu-Analysis and Synthesis Toolbox.
C         The MathWorks Inc., Natick, Mass., 1995.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of the result depends on the condition numbers of the
C     input and output transformations.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 1999.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal
C     regulator, robust control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS,
     $                   NP
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), AK( LDAK, * ), B( LDB, * ),
     $                   BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DK( LDDK, * ), F( LDF, * ),
     $                   H( LDH, * ), TU( LDTU, * ), TY( LDTY, * )
C     ..
C     .. Local Scalars ..
      INTEGER            M1, M2, NP1, NP2
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLASET, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      M1  = M - NCON
      M2  = NCON
      NP1 = NP - NMEAS
      NP2 = NMEAS
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -4
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -13
      ELSE IF( LDF.LT.MAX( 1, M2 ) ) THEN
         INFO = -15
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN
         INFO = -19
      ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN
         INFO = -21
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -23
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -25
      ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN
         INFO = -27
      ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN
         INFO = -29
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) RETURN
C
C     Compute the transpose of D22*F . BK is used as workspace.
C
      CALL DGEMM( 'T', 'T', N, NP2, M2, ONE, F, LDF, D( NP1+1, M1+1 ),
     $            LDD, ZERO, BK, LDBK )
C
C     Find AK = A + H*C2 + B2*F + H*D22*F .
C
      CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, NP2, ONE, H, LDH, C( NP1+1, 1 ), LDC,
     $            ONE, AK, LDAK )
      CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB,
     $            F, LDF, ONE, AK, LDAK )
      CALL DGEMM( 'N', 'T', N, N, NP2, ONE, H, LDH, BK, LDBK, ONE, AK,
     $            LDAK )
C
C     Find BK = -H*Ty .
C
      CALL DGEMM( 'N', 'N', N, NP2, NP2, -ONE, H, LDH, TY, LDTY, ZERO,
     $            BK, LDBK )
C
C     Find CK = Tu*F .
C
      CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, F, LDF, ZERO, CK,
     $            LDCK )
C
C     Find DK .
C
      CALL DLASET( 'Full', M2, NP2, ZERO, ZERO, DK, LDDK )
C
      RETURN
C *** Last line of SB10WD ***
      END


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!>  This module contains subroutines used in 3d eigen analysis for
module m_dynamic_mass

contains

  subroutine mass_C2(etype, nn, ecoord, gausses, sec_opt, thick, mass, lumped, temperature)
    use mMechGauss
    use m_MatMatrix
    use elementInfo
    implicit none
    type(tGaussStatus), intent(in) :: gausses(:)             !< status of qudrature points
    integer(kind=kint), intent(in) :: etype                  !< element type
    integer(kind=kint), intent(in) :: nn                     !< number of elemental nodes
    real(kind=kreal), intent(in)  :: ecoord(2,nn)           !< coordinates of elemental nodes
    real(kind=kreal), intent(out) :: mass(:,:)              !< mass matrix
    real(kind=kreal), intent(out) :: lumped(:)              !< mass matrix
    real(kind=kreal), intent(in), optional :: temperature(nn) !< temperature
    type(tMaterial), pointer :: matl !< material information
    integer(kind=kint), parameter :: ndof = 2
    integer(kind=kint) :: i, j, LX, sec_opt
    real(kind=kreal) :: naturalCoord(2)
    real(kind=kreal) :: func(nn), thick
    real(kind=kreal) :: det, wg, rho
    real(kind=kreal) :: D(2,2), N(2, nn*ndof), DN(2, nn*ndof)
    real(kind=kreal) :: gderiv(nn,2)
    logical :: is_lumped

    mass(:,:) = 0.0d0
    lumped = 0.0d0
    matl => gausses(1)%pMaterial

    if(sec_opt == 2) thick = 1.0d0

    do LX = 1, NumOfQuadPoints(etype)
      call getQuadPoint(etype, LX, naturalCoord)
      call getShapeFunc(etype, naturalCoord, func)
      call getGlobalDeriv(etype, nn, naturalcoord, ecoord, det, gderiv)

      if(present(temperature))then
        !ina(1) = temperature
        !call fetch_TableData(MC_ISOELASTIC, matl%dict, outa, ierr, ina)
        !if(ierr)then
          rho = matl%variables(M_DENSITY)
        !else
        !  rho = outa(1)
        !endif
      else
        !call fetch_TableData(MC_ISOELASTIC, matl%dict, outa, ierr)
        !if(ierr)then
          rho = matl%variables(M_DENSITY)
        !else
        !  rho = outa(1)
        !endif
      endif

      D = 0.0d0
      D(1,1) = rho*thick
      D(2,2) = rho*thick

      wg = getWeight(etype, LX)*det

      N = 0.0d0
      do i = 1, nn
        N(1,2*i-1) = func(i)
        N(2,2*i  ) = func(i)
      enddo

      DN(1:2, 1:nn*ndof) = matmul(D, N(1:2, 1:nn*ndof))
      forall(i = 1:nn*ndof,  j = 1:nn*ndof)
        mass(i,j) = mass(i,j) + dot_product(N(:,i), DN(:,j))*wg
      end forall
    enddo

    is_lumped = .true.
    if(is_lumped) call get_lumped_mass(nn, ndof, mass, lumped)
  end subroutine mass_C2

  subroutine mass_C3(etype, nn, ecoord, gausses, mass, lumped, temperature)
    use mMechGauss
    use m_MatMatrix
    use elementInfo
    implicit none
    type(tGaussStatus), intent(in) :: gausses(:)             !< status of qudrature points
    integer(kind=kint), intent(in) :: etype                  !< element type
    integer(kind=kint), intent(in) :: nn                     !< number of elemental nodes
    real(kind=kreal), intent(in)  :: ecoord(3,nn)           !< coordinates of elemental nodes
    real(kind=kreal), intent(out) :: mass(:,:)              !< mass matrix
    real(kind=kreal), intent(out) :: lumped(:)              !< mass matrix
    real(kind=kreal), intent(in), optional :: temperature(nn) !< temperature
    type(tMaterial), pointer :: matl !< material information
    integer(kind=kint), parameter :: ndof = 3
    integer(kind=kint) :: i, j, LX
    real(kind=kreal) :: naturalCoord(3)
    real(kind=kreal) :: func(nn)
    real(kind=kreal) :: det, wg, rho
    real(kind=kreal) :: D(3, 3), N(3, nn*ndof), DN(3, nn*ndof)
    real(kind=kreal) :: gderiv(nn, 3)
    logical :: is_lumped

    mass(:,:) = 0.0d0
    lumped = 0.0d0
    matl => gausses(1)%pMaterial

    do LX = 1, NumOfQuadPoints(etype)
      call getQuadPoint(etype, LX, naturalCoord)
      call getShapeFunc(etype, naturalCoord, func)
      call getGlobalDeriv(etype, nn, naturalcoord, ecoord, det, gderiv)

      if(present(temperature))then
        !ina(1) = temperature
        !call fetch_TableData(MC_ISOELASTIC, matl%dict, outa, ierr, ina)
        !if(ierr)then
          rho = matl%variables(M_DENSITY)
        !else
        !  rho = outa(1)
        !endif
      else
        !call fetch_TableData(MC_ISOELASTIC, matl%dict, outa, ierr)
        !if(ierr)then
          rho = matl%variables(M_DENSITY)
        !else
        !  rho = outa(1)
        !endif
      endif

      D = 0.0d0
      D(1,1) = rho
      D(2,2) = rho
      D(3,3) = rho

      wg = getWeight(etype,LX)*det

      N = 0.0d0
      do i = 1, nn
        N(1,3*i-2) = func(i)
        N(2,3*i-1) = func(i)
        N(3,3*i  ) = func(i)
      enddo

      DN(1:3, 1:nn*ndof) = matmul(D, N(1:3, 1:nn*ndof))
      forall(i = 1:nn*ndof,  j = 1:nn*ndof)
        mass(i,j) = mass(i,j) + dot_product(N(:,i), DN(:,j))*wg
      end forall
    enddo

    is_lumped = .true.
    if(is_lumped) call get_lumped_mass(nn, ndof, mass, lumped)
  end subroutine mass_C3

  subroutine get_lumped_mass(nn, ndof, mass, lumped)
    use hecmw
    implicit none
    integer(kind=kint) :: i, j, nn, ndof
    real(kind=kreal) :: lumped(:), mass(:,:)
    real(kind=kreal) :: diag_mass, total_mass

    total_mass = 0.0d0
    do i = 1, nn*ndof, ndof
      do j = 1, nn*ndof, ndof
        total_mass = total_mass + mass(j,i)
      enddo
    enddo

    diag_mass = 0.0d0
    do i = 1, nn*ndof, ndof
      diag_mass = diag_mass + mass(i,i)
    enddo

    diag_mass = 1.0d0/diag_mass
    do i = 1, nn*ndof
      lumped(i) = lumped(i) + mass(i,i)*total_mass*diag_mass
    enddo

    mass = 0.0d0
    do i = 1, nn*ndof
      mass(i,i) = lumped(i)
    enddo
  end subroutine get_lumped_mass

  function get_length(ecoord)
    use hecmw
    implicit none
    real(kind=kreal) :: get_length, ecoord(3,20)

    get_length = dsqrt( &
      (ecoord(1,2) - ecoord(1,1))**2 + &
      (ecoord(2,2) - ecoord(2,1))**2 + &
      (ecoord(3,2) - ecoord(3,1))**2 )
  end function get_length

  function get_face3(ecoord)
    use hecmw
    implicit none
    real(kind=kreal) :: get_face3, ecoord(3,20)
    real(kind=kreal) :: a1, a2, a3
    real(kind=kreal) :: X(3), Y(3), Z(3)

    X(1) = ecoord(1,1); Y(1) = ecoord(2,1); Z(1) = ecoord(3,1)
    X(2) = ecoord(1,2); Y(2) = ecoord(2,2); Z(2) = ecoord(3,2)
    X(3) = ecoord(1,3); Y(3) = ecoord(2,3); Z(3) = ecoord(3,3)

    a1 = (X(2) - X(1))**2 + (Y(2) - Y(1))**2 + (Z(2) - Z(1))**2
    a2 = (X(1) - X(3))*(X(2) - X(1)) &
     & + (Y(1) - Y(3))*(Y(2) - Y(1)) &
     & + (Z(1) - Z(3))*(Z(2) - Z(1))
    a3 = (X(3) - X(1))**2 + (Y(3) - Y(1))**2 + (Z(3) - Z(1))**2

    get_face3 = 0.5d0*dsqrt(a1*a3 - a2*a2)
  end function get_face3

  function get_face4(ecoord)
    use hecmw
    implicit none
    integer(kind=kint) :: LX, LY
    real(kind=kreal) :: get_face4, ecoord(3,20)
    real(kind=kreal) :: XG(2), RI, SI, RP, SP, RM, SM, HR(4), HS(4)
    real(kind=kreal) :: XR, XS, YR, YS, ZR, ZS
    real(kind=kreal) :: X(4), Y(4), Z(4), det

    X(1) = ecoord(1,1); Y(1) = ecoord(2,1); Z(1) = ecoord(3,1)
    X(2) = ecoord(1,2); Y(2) = ecoord(2,2); Z(2) = ecoord(3,2)
    X(3) = ecoord(1,3); Y(3) = ecoord(2,3); Z(3) = ecoord(3,3)
    X(4) = ecoord(1,4); Y(4) = ecoord(2,4); Z(4) = ecoord(3,4)

    XG(1) = -0.5773502691896258D0
    XG(2) = -XG(1)
    get_face4 = 0.0d0

    do LX = 1, 2
      RI = XG(LX)
      do LY = 1, 2
        SI = XG(LY)
        RP = 1.0d0 + RI
        SP = 1.0d0 + SI
        RM = 1.0d0 - RI
        SM = 1.0d0 - SI

        !C*  FOR R-COORDINATE
        HR(1) =  0.25d0*SP
        HR(2) = -0.25d0*SP
        HR(3) = -0.25d0*SM
        HR(4) =  0.25d0*SM

        !C*  FOR S-COORDINATE
        HS(1) =  0.25d0*RP
        HS(2) =  0.25d0*RM
        HS(3) = -0.25d0*RM
        HS(4) = -0.25d0*RP

        !C*JACOBI MATRIX
        XR = HR(1)*X(1) + HR(2)*X(2) + HR(3)*X(3) + HR(4)*X(4)
        XS = HS(1)*X(1) + HS(2)*X(2) + HS(3)*X(3) + HS(4)*X(4)
        YR = HR(1)*Y(1) + HR(2)*Y(2) + HR(3)*Y(3) + HR(4)*Y(4)
        YS = HS(1)*Y(1) + HS(2)*Y(2) + HS(3)*Y(3) + HS(4)*Y(4)
        ZR = HR(1)*Z(1) + HR(2)*Z(2) + HR(3)*Z(3) + HR(4)*Z(4)
        ZS = HS(1)*Z(1) + HS(2)*Z(2) + HS(3)*Z(3) + HS(4)*Z(4)

        det = (YR*ZS - ZR*YS)**2 + (ZR*XS - XR*ZS)**2 + (XR*YS - YR*XS)**2
        det = dsqrt(det)

        get_face4 = get_face4 + det
      enddo
    enddo
  end function get_face4

end module m_dynamic_mass


        subroutine calculbij(nbnn,nbsomtot,xl,num,bij,poro,ip,npgau,
     1   xgau,frgau,dfrgau,poigau,detj,ajm1,aj,df,volume,
     2   volume_sommet,iphi)
        implicit none
        integer nbnn,nbsomtot,num(nbnn),ip,npgau,l,idimg
        real*8 xl(nbnn),bij(nbnn,1,3),poro(1),xgau(npgau,3)
        real*8 FRGAU(NPGAU,NBNN),DFRGAU(NPGAU,NBNN,3)
        real*8 POIGAU(NPGAU)
        real*8 DETJ(NPGAU)
        real*8 AJM1(NPGAU,3,3),AJ(NPGAU,3,3),DF(NPGAU,nbnn,3)
        real*8 volume,volume_sommet(nbsomtot),iphi(nbnn)

        logical JSHORT
        JSHORT = .FALSE.
        l=1
        idimg=3
        CALL JACOB(IDIMG ,NBNN ,NPGAU ,XL     ,XGAU
     1            ,DETJ  ,AJM1 ,AJ     ,JSHORT)
        CALL DERIVE(IDIMG  ,NBNN  ,NPGAU  ,AJM1  ,DFRGAU  ,DF)
        IF (ip.eq.0) THEN
          CALL VOMABT(IDIMG     ,NBNN       ,NBNN,NPGAU  ,l  ,
     1                L         ,POIGAU     ,DETJ  ,FRGAU   ,DF      ,
     2               num, volume, volume_sommet,bij,iphi)
        ELSE
          CALL CALFGR(IDIMG     ,NBNN       ,NBNN,NPGAU  ,l  ,
     1                L         ,POIGAU     ,DETJ  ,FRGAU   ,DF      ,
     2                NUM ,poro, volume, volume_sommet,bij ,iphi)
        ENDIF
90    CONTINUE
C
      RETURN
      END


      SUBROUTINE SOL_OZ (TYEAR,RDAY)

C--
C--   SUBROUTINE SOL_OZ (TYEAR)
C--
C--   Purpose: Compute zonally-averaged fields to be used
C--            in the computation of SW absorption:
C--            FSOL   = flux of incoming solar radiation
C--            OZONE  = flux absorbed by ozone (lower stratos.)
C--            OZUPP  = flux absorbed by ozone (upper stratos.)
C--            ZENIT  = function of solar zenith angle
C--   Input:   TYEAR  = time as fraction of year (0-1, 0 = 1jan.h00)
C--   Updated common blocks: RADZON
C--
C     Resolution parameters
C
      include "atparam.h"
      include "atparam1.h"
C
      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

C     Constants + functions of sigma and latitude
      include "com_physcon.h"

C     Radiation constants
      include "com_radcon.h"

cfk      real topsr(nlat)
      real topsr(nlon,nlat)

      real*4  R4OUT(ngp)

C     ALPHA = year phase ( 0 - 2pi, 0 = winter solstice = 22dec.h00 )
      ALPHA=4.*ASIN(1.)*(TYEAR+10./365.)
      DALPHA=0.
c      DALPHA=ASIN(0.5)

      COZ1= 1.0*MAX(0.,COS(ALPHA-DALPHA))
      COZ2= 1.8
C
      AZEN=1.0
      NZEN=2

      RZEN=-COS(ALPHA)*23.45*ASIN(1.)/90.
      CZEN=COS(RZEN)
      SZEN=SIN(RZEN)

      FS0=6.

C     solar radiation at the top
      call solar (tyear,rday,4.*solc,nlat,nlon,clat,slat,
     &            topsr)

cfk
cfk FSOL longitude dependent
cfk
      do j=1, ngp
         jlat=INT(j/nlon+1)
         j0=j-nlon*(jlat-1)
         FSOL(j)=topsr(j0,jlat)
      enddo

      DO J=1,NLAT

        J0=1+NLON*(J-1)
        FLAT2=1.5*SLAT(J)**2-0.5

C       solar radiation at the top
cfk        FSOL(J0)=topsr(j)

C       ozone depth in upper and lower stratosphere
        OZUPP(J0)=0.5*EPSSW
        OZONE(J0)=0.4*EPSSW*(1.0+COZ1*SLAT(J)+COZ2*FLAT2)

C       zenith angle correction to (downward) absorptivity
        ZENIT(J0)=1.+AZEN*(1.-(CLAT(J)*CZEN+SLAT(J)*SZEN))**NZEN

C       ozone absorption in upper and lower stratosphere
        OZUPP(J0)=FSOL(J0)*OZUPP(J0)*ZENIT(J0)
        OZONE(J0)=FSOL(J0)*OZONE(J0)*ZENIT(J0)

C       Polar night cooling in the stratosphere
        STRATZ(J0)=MAX(FS0-FSOL(J0),0.)

        DO I=1,NLON-1
cfk          FSOL  (I+J0)=FSOL  (J0)
          OZONE (I+J0)=OZONE (J0)
          OZUPP (I+J0)=OZUPP (J0)
          ZENIT (I+J0)=ZENIT (J0)
          STRATZ(I+J0)=STRATZ(J0)
        ENDDO

      ENDDO
cfk
cfk     write FSOL
cfk
cfk        open(90,file='myfile.dat',status='unknown',action='write',
cfk     &       form='unformatted',position="append")
cfk        R4OUT(:) = fsol(:)
cfk        write (90) R4OUT
Cfk
      RETURN
      END

cmbp_s
      subroutine solar(tyear,rday,solarc,nlat,nlon,clat,slat,q0)
c-----------------------------------------------------------------------
c From ECBILT-CLIO model
c Calculates incoming solar radiation as a function of latitude
c for each day of the year, given the orbital parameters (see PMIP)
c One year has 360 days.  Reference: A. Berger, JAS, 35, 2362-2367,1978
c-----------------------------------------------------------------------
c      implicit none

      integer i,j,l,NVE

      real beta,alam,alam0,ala,ala0
      real fac1,fac2,fac3,ro
      real deltal, sindl, cosdl, tandl
      real rkosz, rkosha1, ha1
      real deg2rad, day2rad
      real solard, solarcf

      real q0(nlon,nlat), clat(nlat), slat(nlat)

      deg2rad=2.*asin(1.)/180.
      day2rad=2.*asin(1.)/180.

c Present-day orbital parameters: eccentricity ecc, obliquity obl and
c angle om between Vernal Equinox and Perihelion (angles all given
c in degrees and converted to radians). Solarc is the solar constant.
c NVE is day of the Vernal Equinox, set at 21 MARCH
c Implementatie van Nanne

cmbp_s
      ecc=0.016724
c      ecc=0.016724*3.
cmbp_e
      obl=23.446*deg2rad
cmbp_s
      omweb=(102.04+180.00)*deg2rad
c      omweb=(102.04+180.00-180.0)*deg2rad
cmbp_e
c      solarc=1365.
      NVE=30+30+21
c
c In old SW-routine of ECBilt-model values were as follows:
c
c      ecc=0.0
c      solarc=1353.
c      NVE=90
c
c At 6000 years BP (Before Present) values were as follows:
c
c      ecc=0.018682
c      obl=24.105*deg2rad
c      omweb=(0.87+180.00)*deg2rad
c
c :LGM:
c     ecc=0.018994
c     obl=22.949*deg2rad
c     omweb=(114.42+180.00)*deg2rad

c First compute alam0 (the starting point). Then convert days to
c the true longitude ala, using Berger's formulae.
c Longitude ala loops from 0 (Vernal Equinox) to 359, ro is earth-sun
c distance relative to the major axis, del is declination.
c
      ala0=0.
      beta=(1.-ecc**2.)**0.5
      fac1=(0.5*ecc+0.125*ecc**3.)*(1.+beta)*sin(ala0-omweb)
      fac2=0.25*ecc**2.*(0.5+beta)*sin(2.*(ala0-omweb))
      fac3=0.125*ecc**3.*(1./3.+beta)*sin(3.*(ala0-omweb))
      alam0=ala0-2.*(fac1-fac2+fac3)

c      l=(imonth-1)*30+iday-NVE
      l=tyear*360-NVE

      if (l.lt.0) l=l+360
      alam=alam0+l*1.0*2.*asin(1.)/180.

      fac1=(2.*ecc-0.25*ecc**3.)*sin(alam-omweb)
      fac2=1.25*ecc**2.*sin(2.*(alam-omweb))
      fac3=(13./12.)*ecc**3.*sin(3.*(alam-omweb))
      ala=alam+fac1+fac2+fac3
      ro=(1.-ecc**2.)/(1.+ecc*cos(ala-omweb))
      deltal=asin(sin(obl)*sin(ala))

      sindl=sin(deltal)
      cosdl=cos(deltal)
      tandl=tan(deltal)

c factor voor variable afstand Aarde-Zon (Berger, p.2367; Velds, p. 99)
      solard=1./ro**2.
      solarcf=solarc
c beide effecten samen
      solarf=solarcf*solard

      do i=1,nlon
       do j=1,nlat
c         rkosha1=-tanfi(i)*tandl
         rkosha1=-(slat(j)/clat(j))*tandl
         rkosha1=sign(min(abs(rkosha1),1.),rkosha1)
         ha1=acos(rkosha1)
         rlon=float(i)/float(nlon)
         hangle=2.*acos(-1.)*(tyear+rday+rlon)
         cmu=slat(j)*sindl-clat(j)*cosdl*cos(hangle)
cfk
cfk  NCAR Technical Note NCAR/TN-485+STR (CAM4.0), page 116
cfk  note that only if cmu pos it is counted (Wiki pedia
cfk  Solar Irradiance, https://en.wikipedia.org/wiki/Solar_irradiance)
cfk
cfk   daily mean formulae
cfk
cfk          rkosz=slat(j)*sindl*(ha1 - tan(ha1))/(2.*asin(1.))
cfk   daily variing formulae
cfk
          rkosz =  max(cmu,0.)
c         if (ha1 .ne. 0.) then
c            kosz(j) = rkosz*2.*asin(1.)/ha1
c         else
c            kosz(j) = rkosz
c         endif
c         dayfr(j) = ha1/(2.*asin(1.))
         q0(i,j)=rkosz*solarc*solard
       enddo
      enddo

      return
      end

cmbp_s

cfk      subroutine solar (tyear,csol,nlat,clat,slat,
cfk     &                  topsr)
cfk
C--   Average daily flux of solar radiation, from Hartmann (1994)
cfk
cfk      real clat(nlat), slat(nlat),
cfk     &     topsr(nlat)

C--   1. Compute declination angle and Earth-Sun distance factor

cfk      pigr  = 2.*asin(1.)
cfk      alpha = 2.*pigr*tyear

cfk      ca1 = cos(alpha)
cfk      sa1 = sin(alpha)
cfk      ca2 = ca1*ca1-sa1*sa1
cfk      sa2 = 2.*sa1*ca1
cfk      ca3 = ca1*ca2-sa1*sa2
cfk      sa3 = sa1*ca2+sa2*ca1

cfk      decl = 0.006918-0.399912*ca1+0.070257*sa1
cfk     &               -0.006758*ca2+0.000907*sa2
cfk     &               -0.002697*ca3+0.001480*sa3

cfk      fdis = 1.000110+0.034221*ca1+0.001280*sa1
cfk     &               +0.000719*ca2+0.000077*sa2
cfk
cfk      cdecl = cos(decl)
cfk      sdecl = sin(decl)
cfk      tdecl = sdecl/cdecl
cfk
C--   2. Compute daily-average insolation at the atm. top
cfk
cfk      csolp=csol/pigr
cfk
cfk      do j=1,nlat
cfk
cfk        ch0 = min(1.,max(-1.,-tdecl*slat(j)/clat(j)))
cfk        h0  = acos(ch0)
cfk        sh0 = sin(h0)
cfk
cfk        topsr(j) = csolp*fdis*(h0*slat(j)*sdecl+sh0*clat(j)*cdecl)
cfk
cfk      enddo
cfk
C--
cfk      return
cfk      end

      SUBROUTINE CLOUD (QA,RH,PRECNV,PRECLS,IPTOP,GSE,FMASK,
     &                  ICLTOP,CLOUDC,CLSTR)
C--
C--   SUBROUTINE CLOUD (QA,RH,PRECNV,PRECLS,IPTOP,GSE,FMASK,
C--  &                  ICLTOP,CLOUDC,CLSTR)
C--
C--   Purpose: Compute cloud-top level and cloud cover
C--   Input:   QA     = specific humidity [g/kg]                (3-dim)
C--            RH     = relative humidity                       (3-dim)
C--            PRECNV = convective precipitation                (2-dim)
C--            PRECLS = large-scale precipitation               (2-dim)
C--            IPTOP  = top level of precipitating cloud        (2-dim)
C--            GSE    = gradient of dry st. energy (dSE/dPHI)   (2-dim)
C--            FMASK  = fractional land-sea mask                (2-dim)
C--   Output:  ICLTOP = cloud top level (all clouds)            (2-dim)
C--            CLOUDC = total cloud cover                       (2-dim)
C--            CLSTR  = stratiform cloud cover                  (2-dim)

C     Resolution parameters
C
      include "atparam.h"
      include "atparam1.h"
C
      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )
C
C     Constants + functions of sigma and latitude
C
      include "com_physcon.h"
C
C     Cloud and radiation parameters
C
      include "com_radcon.h"

      INTEGER IPTOP(NGP)
      REAL QA(NGP,NLEV), RH(NGP,NLEV),
     &     PRECNV(NGP),  PRECLS(NGP), GSE(NGP), FMASK(NGP)

      INTEGER ICLTOP(NGP)
      REAL CLOUDC(NGP), CLSTR(NGP)

      NL1  = NLEV-1
      NLP  = NLEV+1
      RRCL = 1./(RHCL2-RHCL1)

C--   1.  Cloud cover, defined as the sum of:
C         - a term proportional to the square-root of precip. rate
C         - a quadratic function of the max. relative humidity
C           in tropospheric layers above PBL where Q > QACL :
C           ( = 0 for RHmax < RHCL1, = 1 for RHmax > RHCL2 )
C         Cloud-top level: defined as the highest (i.e. least sigma)
C           between the top of convection/condensation and
C           the level of maximum relative humidity.

      DO J=1,NGP
        IF (RH(J,NL1).GT.RHCL1) THEN
          CLOUDC(J) = RH(J,NL1)-RHCL1
          ICLTOP(J) = NL1
        ELSE
          CLOUDC(J) = 0.
          ICLTOP(J) = NLP
        ENDIF
      ENDDO

      DO K=3,NLEV-2
        DO J=1,NGP
          DRH = RH(J,K)-RHCL1
          IF (DRH.GT.CLOUDC(J).AND.QA(J,K).GT.QACL) THEN
            CLOUDC(J) = DRH
            ICLTOP(J) = K
          ENDIF
        ENDDO
      ENDDO

      DO J=1,NGP
        CL1 = MIN(1.,CLOUDC(J)*RRCL)
        PR1 = MIN(PMAXCL,86.4*(PRECNV(J)+PRECLS(J)))
        CLOUDC(J) = MIN(1.,WPCL*SQRT(PR1)+CL1*CL1)
        ICLTOP(J) = MIN(IPTOP(J),ICLTOP(J))
      ENDDO

C--   2.  Equivalent specific humidity of clouds

      DO J=1,NGP
        QCLOUD(J) = QA(J,NL1)
      ENDDO

C--   3. Stratiform clouds at the top of PBL

      inew = 1

      if (inew.gt.0) then

c        CLSMAX  = 0.6
c        CLSMINL = 0.15
c        GSE_S0  = 0.25
c        GSE_S1  = 0.40

        CLFACT = 1.2
        RGSE   = 1./(GSE_S1-GSE_S0)

        DO J=1,NGP
c         Stratocumulus clouds over sea
          FSTAB    = MAX(0.,MIN(1.,RGSE*(GSE(J)-GSE_S0)))
          CLSTR(J) = FSTAB*MAX(CLSMAX-CLFACT*CLOUDC(J),0.)
c         Stratocumulus clouds over land
          CLSTRL   = MAX(CLSTR(J),CLSMINL)*RH(J,NLEV)
          CLSTR(J) = CLSTR(J)+FMASK(J)*(CLSTRL-CLSTR(J))
        ENDDO

      else

        CLSMAX  = 0.3
        CLSMINL = 0.1
        ALBCOR  = ALBCL/0.5

        DO J=1,NGP
c         Stratocumulus clouds over sea
          CLSTR(J) = MAX(CLSMAX-CLOUDC(J),0.)
c         Rescale for consistency with previous albedo values
          CLSTR(J) = CLSTR(J)*ALBCOR
c         Correction for aerosols over land
          CLSTR(J) = CLSTR(J)+FMASK(J)*(CLSMINL-CLSTR(J))
        ENDDO

      endif

      RETURN
      END

      SUBROUTINE RADSW (PSA,QA,ICLTOP,CLOUDC,CLSTR,
     &                  FSFCD,FSFC,FTOP,DFABS)
C--
C--   SUBROUTINE RADSW (PSA,QA,ICLTOP,CLOUDC,CLSTR,
C--  &                  FSFCD,FSFC,FTOP,DFABS)
C--
C--   Purpose: Compute the absorption of shortwave radiation and
C--            initialize arrays for longwave-radiation routines
C--   Input:   PSA    = norm. surface pressure [p/p0]           (2-dim)
C--            QA     = specific humidity [g/kg]                (3-dim)
C--            ICLTOP = cloud top level                         (2-dim)
C--            CLOUDC = total cloud cover                       (2-dim)
C--            CLSTR  = stratiform cloud cover                  (2-dim)
C--   Output:  FSFCD  = downward-only flux of sw rad. at the surface (2-dim)
C--            FSFC   = net (downw.) flux of sw rad. at the surface  (2-dim)
C--            FTOP   = net (downw.) flux of sw rad. at the atm. top (2-dim)
C--            DFABS  = flux of sw rad. absorbed by each atm. layer  (3-dim)
C--
C     Resolution parameters
C
      include "atparam.h"
      include "atparam1.h"
C
      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

C     Constants + functions of sigma and latitude

      include "com_physcon.h"

C     Radiation parameters

      include "com_radcon.h"
C
      INTEGER ICLTOP(NGP)
      REAL PSA(NGP), QA(NGP,NLEV), CLOUDC(NGP), CLSTR(NGP)

      REAL FTOP(NGP), FSFC(NGP), FSFCD(NGP), DFABS(NGP,NLEV)

      REAL ACLOUD(NGP), PSAZ(NGP), FREFL(NGP,NLEV)

      EQUIVALENCE (FREFL(1,1),TAU2(1,1,3))

      NL1 = NLEV-1

      FBAND2 = 0.05
      FBAND1 = 1.-FBAND2

c      ALBMINL=0.05
c      ALBCLS = 0.5
C
C--   1.  Initialization

      DO K=1,NLEV
       DO J=1,NGP
         FREFL(J,K)=0.
       ENDDO
      ENDDO

      DO J=1,NGP
cfk-- change to ensure only ICLTOP <= NLEV used
        IF(ICLTOP(J) .LE. NLEV) THEN
          FREFL(J,ICLTOP(J))= ALBCL*CLOUDC(J)
        ENDIF
cfk-- end change
        FREFL(J,NLEV)     = ALBCLS*CLSTR(J)
      ENDDO

C
C--   2. Shortwave transmissivity:
C        function of layer mass, ozone (in the statosphere),
C        abs. humidity and cloud cover (in the troposphere)

      DO J=1,NGP
        PSAZ(J)=PSA(J)*ZENIT(J)
        ACLOUD(J)=CLOUDC(J)*MIN(ABSCL1*QCLOUD(J),ABSCL2)
      ENDDO

      DO J=1,NGP
        DELTAP=PSAZ(J)*DSIG(1)
        TAU2(J,1,1)=EXP(-DELTAP*ABSDRY)
      ENDDO

      DO K=2,NL1
       ABS1=ABSDRY+ABSAER*SIG(K)**2
       DO J=1,NGP
         DELTAP=PSAZ(J)*DSIG(K)
         IF (K.GE.ICLTOP(J)) THEN
           TAU2(J,K,1)=EXP(-DELTAP*
     &                 (ABS1+ABSWV1*QA(J,K)+ACLOUD(J)))
         ELSE
           TAU2(J,K,1)=EXP(-DELTAP*(ABS1+ABSWV1*QA(J,K)))
         ENDIF
       ENDDO
      ENDDO

      ABS1=ABSDRY+ABSAER*SIG(NLEV)**2
      DO J=1,NGP
        DELTAP=PSAZ(J)*DSIG(NLEV)
        TAU2(J,NLEV,1)=EXP(-DELTAP*(ABS1+ABSWV1*QA(J,NLEV)))
      ENDDO

      DO K=2,NLEV
       DO J=1,NGP
         DELTAP=PSAZ(J)*DSIG(K)
         TAU2(J,K,2)=EXP(-DELTAP*ABSWV2*QA(J,K))
       ENDDO
      ENDDO

C
C---  3. Shortwave downward flux

C     3.1 Initialization of fluxes

      DO J=1,NGP
        FTOP(J)  =FSOL(J)
        FLUX(J,1)=FSOL(J)*FBAND1
        FLUX(J,2)=FSOL(J)*FBAND2
      ENDDO

C     3.2 Ozone and dry-air absorption in the stratosphere

      K=1
      DO J=1,NGP
        DFABS(J,K)=FLUX(J,1)
        FLUX (J,1)=TAU2(J,K,1)*(FLUX(J,1)-OZUPP(J)*PSA(J))
        DFABS(J,K)=DFABS(J,K)-FLUX(J,1)
      ENDDO

      K=2
      DO J=1,NGP
        DFABS(J,K)=FLUX(J,1)
        FLUX (J,1)=TAU2(J,K,1)*(FLUX(J,1)-OZONE(J)*PSA(J))
        DFABS(J,K)=DFABS(J,K)-FLUX(J,1)
      ENDDO

C     3.3  Absorption and reflection in the troposphere

      DO K=3,NLEV
       DO J=1,NGP
         FREFL(J,K)=FLUX(J,1)*FREFL(J,K)
         FLUX (J,1)=FLUX(J,1)-FREFL(J,K)
         DFABS(J,K)=FLUX(J,1)
         FLUX (J,1)=TAU2(J,K,1)*FLUX(J,1)
         DFABS(J,K)=DFABS(J,K)-FLUX(J,1)
       ENDDO
      ENDDO

      DO K=2,NLEV
       DO J=1,NGP
         DFABS(J,K)=DFABS(J,K)+FLUX(J,2)
         FLUX (J,2)=TAU2(J,K,2)*FLUX(J,2)
         DFABS(J,K)=DFABS(J,K)-FLUX(J,2)
       ENDDO
      ENDDO

C
C---  4. Shortwave upward flux

C     4.1  Absorption and reflection at the surface

      DO J=1,NGP
        FSFCD(J)  = FLUX(J,1)+FLUX(J,2)
        FLUX(J,1) = FLUX(J,1)*ALBSFC(J)
        FSFC(J)   = FSFCD(J)-FLUX(J,1)
      ENDDO

C     4.2  Absorption of upward flux

      DO K=NLEV,1,-1
       DO J=1,NGP
         DFABS(J,K)=DFABS(J,K)+FLUX(J,1)
         FLUX (J,1)=TAU2(J,K,1)*FLUX(J,1)
         DFABS(J,K)=DFABS(J,K)-FLUX(J,1)
         FLUX (J,1)=FLUX(J,1)+FREFL(J,K)
       ENDDO
      ENDDO

C     4.3  Net solar radiation = incoming - outgoing

      DO J=1,NGP
        FTOP(J)=FTOP(J)-FLUX(J,1)
      ENDDO
C
C---  5.  Initialization of longwave radiation model

C     5.1  Longwave transmissivity:
C          function of layer mass, abs. humidity and cloud cover.

C     Cloud-free levels (stratosphere + PBL)

      K=1
        DO J=1,NGP
          DELTAP=PSA(J)*DSIG(K)
          TAU2(J,K,1)=EXP(-DELTAP*ABLWIN)
          TAU2(J,K,2)=EXP(-DELTAP*ABLCO2)
          TAU2(J,K,3)=1.
          TAU2(J,K,4)=1.
        ENDDO

      DO K=2,NLEV,NLEV-2
        DO J=1,NGP
          DELTAP=PSA(J)*DSIG(K)
          TAU2(J,K,1)=EXP(-DELTAP*ABLWIN)
          TAU2(J,K,2)=EXP(-DELTAP*ABLCO2)
          TAU2(J,K,3)=EXP(-DELTAP*ABLWV1*QA(J,K))
          TAU2(J,K,4)=EXP(-DELTAP*ABLWV2*QA(J,K))
        ENDDO
      ENDDO

C     Cloudy layers (free troposphere)

      DO J=1,NGP
        ACLOUD(J)=CLOUDC(J)*ABLCL2
      ENDDO

      DO K=3,NL1
       DO J=1,NGP
         DELTAP=PSA(J)*DSIG(K)
         IF (K.LT.ICLTOP(J)) THEN
           ACLOUD1=ACLOUD(J)
         ELSE
           ACLOUD1=ABLCL1*CLOUDC(J)
         ENDIF
         TAU2(J,K,1)=EXP(-DELTAP*(ABLWIN+ACLOUD1))
         TAU2(J,K,2)=EXP(-DELTAP*ABLCO2)
         TAU2(J,K,3)=EXP(-DELTAP*MAX(ABLWV1*QA(J,K),ACLOUD(J)))
         TAU2(J,K,4)=EXP(-DELTAP*MAX(ABLWV2*QA(J,K),ACLOUD(J)))
       ENDDO
      ENDDO

C     5.2  Stratospheric correction terms

      EPS1=EPSLW/(DSIG(1)+DSIG(2))
      DO J=1,NGP
        STRATC(J,1)=STRATZ(J)*PSA(J)
        STRATC(J,2)=EPS1*PSA(J)
      ENDDO
C
C---
      RETURN
      END

      SUBROUTINE RADLW (IMODE,TA,TS,
     &                  FSFCD,FSFCU,
     &                  FSFC,FTOP,DFABS)

C--
C--   SUBROUTINE RADLW (IMODE,TA,TS,
C--  &                  FSFCD,FSFCU,
C--  &                  FSFC,FTOP,DFABS)
C--
C--   Purpose: Compute the absorption of longwave radiation
C--   Input:   IMODE  = index for operation mode
C--                     -1 : downward flux only
C--                      0 : downward + upward flux
C--                     +1 : upward flux only
C--            TA     = absolute temperature (3-dim)
C--            TS     = surface temperature                    [if IMODE=0]
C--            FSFCD  = downward flux of lw rad. at the sfc.   [if IMODE=1]
C--            FSFCU  = surface blackbody emission (upward)    [if IMODE=1]
C--            DFABS  = DFABS output from RADLW(-1,... )       [if IMODE=1]
C--   Output:  FSFCD  = downward flux of lw rad. at the sfc.[if IMODE=-1,0]
C--            FSFCU  = surface blackbody emission (upward)  [if IMODE=  0]
C--            FSFC   = net upw. flux of lw rad. at the sfc. [if IMODE=0,1]
C--            FTOP   = outgoing flux of lw rad. at the top  [if IMODE=0,1]
C--            DFABS  = flux of lw rad. absorbed by each atm. layer (3-dim)
C--
C     Resolution parameters
C
      include "atparam.h"
      include "atparam1.h"
C
      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

C     Number of radiation bands with tau < 1
      PARAMETER ( NBAND=4 )

C     Constants + functions of sigma and latitude

      include "com_physcon.h"

C     Radiation parameters

      include "com_radcon.h"

      REAL TA(NGP,NLEV), TS(NGP)

      REAL FSFCD(NGP), FSFCU(NGP)

      REAL FTOP(NGP), FSFC(NGP), DFABS(NGP,NLEV)

C
      NL1=NLEV-1

      REFSFC=1.-EMISFC

      IF (IMODE.EQ.1) GO TO 410

C---  1. Blackbody emission from atmospheric levels.
C        The linearized gradient of the blakbody emission is computed
C        from temperatures at layer boundaries, which are interpolated
C        assuming a linear dependence of T on log_sigma.
C        Above the first (top) level, the atmosphere is assumed isothermal.

C     Temperature at level boundaries
      DO K=1,NL1
       DO J=1,NGP
         ST4A(J,K,1)=TA(J,K)+WVI(K,2)*(TA(J,K+1)-TA(J,K))
       ENDDO
      ENDDO

C     Mean temperature in stratospheric layers
      DO J=1,NGP
        ST4A(J,1,2)=0.75*TA(J,1)+0.25* ST4A(J,1,1)
        ST4A(J,2,2)=0.50*TA(J,2)+0.25*(ST4A(J,1,1)+ST4A(J,2,1))
      ENDDO

C     Temperature gradient in tropospheric layers

      ANIS =1.0
      ANISH=0.5*ANIS

      DO K=3,NL1
       DO J=1,NGP
         ST4A(J,K,2)=ANISH*MAX(ST4A(J,K,1)-ST4A(J,K-1,1),0.)
       ENDDO
      ENDDO

      DO J=1,NGP
        ST4A(J,NLEV,2)=ANIS*MAX(TA(J,NLEV)-ST4A(J,NL1,1),0.)
      ENDDO

C     Blackbody emission in the stratosphere
      DO K=1,2
       DO J=1,NGP
         ST4A(J,K,1)=SBC*ST4A(J,K,2)**4
         ST4A(J,K,2)=0.
       ENDDO
      ENDDO

C     Blackbody emission in the troposphere
      DO K=3,NLEV
       DO J=1,NGP
         ST3A=SBC*TA(J,K)**3
         ST4A(J,K,1)=ST3A*TA(J,K)
         ST4A(J,K,2)=4.*ST3A*ST4A(J,K,2)
       ENDDO
      ENDDO

C---  2. Initialization of fluxes

      DO J=1,NGP
        FSFCD(J)=0.
      ENDDO

      DO K=1,NLEV
       DO J=1,NGP
         DFABS(J,K)=0.
       ENDDO
      ENDDO

C---  3. Emission ad absorption of longwave downward flux.
C        For downward emission, a correction term depending on the
C        local temperature gradient and on the layer transmissivity is
C        added to the average (full-level) emission of each layer.

C     3.1  Stratosphere

      K=1
      DO JB=1,2
       DO J=1,NGP
         EMIS=1.-TAU2(J,K,JB)
         BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)+EMIS*ST4A(J,K,2))
         FLUX(J,JB)=EMIS*BRAD
         DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
       ENDDO
      ENDDO

      DO JB=3,NBAND
       DO J=1,NGP
         FLUX(J,JB)=0.
       ENDDO
      ENDDO

C     3.2  Troposphere

      DO JB=1,NBAND
       DO K=2,NLEV
        DO J=1,NGP
          EMIS=1.-TAU2(J,K,JB)
          BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)+EMIS*ST4A(J,K,2))
          DFABS(J,K)=DFABS(J,K)+FLUX(J,JB)
          FLUX(J,JB)=TAU2(J,K,JB)*FLUX(J,JB)+EMIS*BRAD
          DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
        ENDDO
       ENDDO
      ENDDO

C     3.3 Surface downward flux

      DO JB=1,NBAND
       DO J=1,NGP
         FSFCD(J)=FSFCD(J)+EMISFC*FLUX(J,JB)
       ENDDO
      ENDDO

C     3.4 Correction for "black" band (incl. surface reflection)

      EPS1=EPSLW*EMISFC
      DO J=1,NGP
        CORLW=EPS1*ST4A(J,NLEV,1)
        DFABS(J,NLEV)=DFABS(J,NLEV)-CORLW
        FSFCD(J)     =FSFCD(J)     +CORLW
      ENDDO

      IF (IMODE.EQ.-1) RETURN

C---  4. Emission ad absorption of longwave upward flux.
C        For upward emission, a correction term depending on the
C        local temperature gradient and on the layer transmissivity is
C        subtracted from the average (full-level) emission of each layer.

C     4.1  Surface

C     Black-body (or grey-body) emission
      ESBC=EMISFC*SBC
      DO J=1,NGP
        TSQ=TS(J)*TS(J)
        FSFCU(J)=ESBC*TSQ*TSQ
      ENDDO

C     Entry point for upward-only mode (IMODE=1)
 410  CONTINUE

      DO J=1,NGP
        FSFC(J)=FSFCU(J)-FSFCD(J)
      ENDDO

      DO JB=1,NBAND
       DO J=1,NGP
         FLUX(J,JB)=FBAND(NINT(TS(J)),JB)*FSFCU(J)
     &              +REFSFC*FLUX(J,JB)
       ENDDO
      ENDDO

C     4.2  Troposphere

C     Correction for "black" band
      DO J=1,NGP
        DFABS(J,NLEV)=DFABS(J,NLEV)+EPSLW*FSFCU(J)
      ENDDO

      DO JB=1,NBAND
       DO K=NLEV,2,-1
        DO J=1,NGP
          EMIS=1.-TAU2(J,K,JB)
          BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)-EMIS*ST4A(J,K,2))
          DFABS(J,K)=DFABS(J,K)+FLUX(J,JB)
          FLUX(J,JB)=TAU2(J,K,JB)*FLUX(J,JB)+EMIS*BRAD
          DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
        ENDDO
       ENDDO
      ENDDO

C     4.3  Stratosphere

      K=1
      DO JB=1,2
       DO J=1,NGP
         EMIS=1.-TAU2(J,K,JB)
         BRAD=FBAND(NINT(TA(J,K)),JB)*(ST4A(J,K,1)-EMIS*ST4A(J,K,2))
         DFABS(J,K)=DFABS(J,K)+FLUX(J,JB)
         FLUX(J,JB)=TAU2(J,K,JB)*FLUX(J,JB)+EMIS*BRAD
         DFABS(J,K)=DFABS(J,K)-FLUX(J,JB)
       ENDDO
      ENDDO

C     Correction for "black" band and polar night cooling

      DO J=1,NGP
        CORLW1=DSIG(1)*STRATC(J,2)*ST4A(J,1,1)+STRATC(J,1)
        CORLW2=DSIG(2)*STRATC(J,2)*ST4A(J,2,1)
        DFABS(J,1)=DFABS(J,1)-CORLW1
        DFABS(J,2)=DFABS(J,2)-CORLW2
        FTOP(J)   =CORLW1+CORLW2
      ENDDO

C     4.4  Outgoing longwave radiation

      DO JB=1,NBAND
       DO J=1,NGP
         FTOP(J)=FTOP(J)+FLUX(J,JB)
       ENDDO
      ENDDO

C---
      RETURN
      END

      SUBROUTINE RADSET
C--
C--   SUBROUTINE RADSET
C--
C--   Purpose: compute energy fractions in LW bands
C--            as a function of temperature
C--   Initialized common blocks: RADFIX

C     Resolution parameters

      include "atparam.h"
      include "atparam1.h"

      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

C     Radiation constants
      include "com_radcon.h"

      EPS1=1.-EPSLW

      DO JTEMP=200,320
        FBAND(JTEMP,2)=(0.148-3.0e-6*(JTEMP-247)**2)*EPS1
        FBAND(JTEMP,3)=(0.356-5.2e-6*(JTEMP-282)**2)*EPS1
        FBAND(JTEMP,4)=(0.314+1.0e-5*(JTEMP-315)**2)*EPS1
        FBAND(JTEMP,1)=EPS1-(FBAND(JTEMP,2)+
     &                       FBAND(JTEMP,3)+FBAND(JTEMP,4))
      ENDDO

      DO JB=1,4
        DO JTEMP=100,199
          FBAND(JTEMP,JB)=FBAND(200,JB)
        ENDDO
        DO JTEMP=321,400
          FBAND(JTEMP,JB)=FBAND(320,JB)
        ENDDO
      ENDDO

C--
      RETURN
      END


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine stepyll(r,rmt,wylm,
     >                   lmax,clm,
     >                   ngauss,xgq,wgq,
     >                   xp,xpt,nbnd,
     >                   rcs2,
     >                   edge,edgp,nedge,
     >                   np_index,rp_index,tnode,plm,sumfi)
c     ================================================================
c
      implicit   none
c
      integer    lmax
      integer    ngauss
      integer    nbnd
      integer    nedge
      integer    np_index(2)
      integer    ip
      integer    np
      integer    node
      integer    it
      integer    jl
      integer    l
      integer    sigma
c
      real*8     r
      real*8     xgq(ngauss)
      real*8     wgq(ngauss)
      real*8     xp(3,nbnd)
      real*8     xpt(3,nbnd)
      real*8     rmt
      real*8     rcs2
      real*8     edge(3,nedge)
      real*8     edgp(3,nedge)
      real*8     rp_index(2)
      real*8     tnode(nbnd+2*nedge+2)
      real*8     clm((lmax+1)*(lmax+2)/2)
      real*8     plm((lmax+1)*(lmax+2)/2)
      real*8     pi
      parameter (pi=3.141592653589793d0)
      real*8     begth
      real*8     endth
      real*8     one
      real*8     two,twopi
      parameter  (two=2.0d0)
      parameter  (twopi=two*pi)
      real*8     zero
      real*8     tol
c
      complex*16 wylm((lmax+1)*(lmax+2)/2),sumfi(0:lmax,3)
c
      parameter  (one=1.0d0)
      parameter  (zero=0.0d0)
      parameter  (tol=1.0d-10)
c
c     ****************************************************************
c     this subroutine calculates the expansion coefficients ,        *
c                                       _                            *
c     sigma (r),  of stepfunction sigma(r) on complex spherical      *
c          l                                                         *
c                m _                                                 *
c     harmonics Y (r)                                                *
c                l                                                   *
c                                                                    *
c                 ___                                                *
c            _    \                   m _                            *
c     sigma( r ) = >   sigma ( r ) * Y (r)                           *
c                 /__       l         l                              *
c                 l,l'                                               *
c                                                                    *
c     it calls calsig for calculating the expansion coefficients     *
c     of sigma ( r ) through complex spherical harmonics.            *
c             l                                                      *
c     yang wang:: dept. of physics, FAU, Boca raton, FL 33431        *
c                    ver 2.1 written in Aug. 1992                    *
c     ****************************************************************
c
c     ----------------------------------------------------------------
      call zeroout(wylm,(lmax+1)*(lmax+2))
c     ----------------------------------------------------------------
c
c     ================================================================
c     special case of r being inside the muffin-tin radius............
c     ================================================================
      if ( r .le. rmt ) then
         wylm(1)=two*sqrt(pi)
         return
      endif
c
c     ================================================================
c     special case of r being outside the poyhedron...................
c     ================================================================
      if (r*r .ge. rcs2) then
         return
      end if
c
c     ================================================================
c     case of r being greater than the muffin-tin radius..............
c     ----------------------------------------------------------------
      if(sigma(zero,zero,r,xpt,nbnd,1).eq.1) then
         endth=+one
      else
         endth=two
      endif
c     ----------------------------------------------------------------
      if(sigma(zero,zero,-r,xpt,nbnd,1).eq.1) then
         begth=-one
      else
         begth=-two
      endif
      ip=0
      do np=1,nbnd
         if( (np_index(1).eq.np .and. r.lt.rp_index(1)) .or.
     >       (np_index(2).eq.np .and. r.lt.rp_index(2)) ) then
            if (xpt(3,np).gt.zero .and. xpt(3,np).le.r) then
               endth=xpt(3,np)/r
            else if(xpt(3,np).lt.zero .and. -xpt(3,np).le.r) then
               begth=xpt(3,np)/r
            endif
         else if((np_index(1).ne.np) .and. (np_index(2).ne.np)) then
c           ==========================================================
c           only store those boundaries planes not perpendicular to
c           the z-axis.
c           ==========================================================
            ip=ip+1
            xp(1,ip)=xpt(1,np)
            xp(2,ip)=xpt(2,np)
            xp(3,ip)=xpt(3,np)
         endif
      enddo
c     ----------------------------------------------------------------
      call caltnode(r,xpt,nbnd,
     >              edge,edgp,nedge,
     >              begth,endth,
     >              np_index,tnode,node)
c     ----------------------------------------------------------------
c
      if(abs(tnode(1)+one) .le. tol) then
c        -------------------------------------------------------------
         call intpl0(-one,tnode(2),lmax,plm)
c        -------------------------------------------------------------
         do l=0,lmax
            jl=(l+1)*(l+2)/2-l
            wylm(jl)=wylm(jl)+twopi*plm(l+1)
         enddo
         do it=1,node-1
            tnode(it)=tnode(it+1)
         enddo
         node=node-1
      endif
c
      if(abs(tnode(node)-one) .le. tol.and.node.gt.1) then
c        -------------------------------------------------------------
         call intpl0(tnode(node-1),one,lmax,plm)
c        -------------------------------------------------------------
         do l=0,lmax
            jl=(l+1)*(l+2)/2-l
            wylm(jl)=wylm(jl)+twopi*plm(l+1)
         enddo
         node=node-1
      endif
c
c     ================================================================
c     it calls calsig to calculate  sigma   ( r ) ,
c                                        l,m
c     which are the expansion coefficients of step function on the
c     complex spherical harmonics. the data are stored in wylm(jl).
c     ----------------------------------------------------------------
      call calsig(lmax,r,xp,ip,
     >            tnode,node,wgq,xgq,ngauss,
     >            wylm,plm,sumfi)
c     ----------------------------------------------------------------
      do jl=1,(lmax+1)*(lmax+2)/2
	wylm(jl)=wylm(jl)*clm(jl)
      enddo
c
c     ================================================================
c
      return
      end


MODULE sdata

save

integer, parameter :: dp = selected_real_kind(10, 15)

CHARACTER(LEN=100) :: mode

INTEGER :: ng     ! number of groups
INTEGER :: nmat   ! number of materials

! XSECs Assigned to Nodes
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: sigtr          ! Transport macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: siga           ! Absorption macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: nuf            ! nu* fission macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: sigf           ! fission macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: chi            ! neutron fission spectrum
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: sigs         ! Scattering macroscopic XSEC
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: dc           ! ADF
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: D              ! Diffusion coefficient
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: sigr           ! Removal macroscopic XSEC

! XSECs Assigned to Materials
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: xsigtr          ! Transport macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: xsiga           ! Absorption macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: xnuf            ! nu* fission macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: xsigf           ! fission macroscopic XSEC
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: xD              ! Diffusion coefficient
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: xsigr           ! Removal macroscopic XSEC
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: xsigs         ! Scattering macroscopic XSEC
LOGICAL :: ccnuf = .TRUE.                            ! Logical variable to check the presence of fissile material
LOGICAL :: ccsigf = .TRUE.                           ! Logical variable to check the presence of fissile material

! Geometry
INTEGER :: nx, ny, nz                                ! Number of assemblies in x, y, and z directions
INTEGER :: nxx, nyy, nzz                             ! Number of nodes in x, y, and z directions
INTEGER :: nnod                                      ! Number of nodes
INTEGER, DIMENSION(:), ALLOCATABLE :: ix, iy, iz
INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: xyz
INTEGER, DIMENSION(:), ALLOCATABLE :: xdiv, ydiv, zdiv     ! Assembly division
REAL(DP), DIMENSION(:), ALLOCATABLE :: xdel, ydel, zdel, vdel  ! Delta x, y and z and nodes' volume in cm3
INTEGER :: xwest, xeast, ysouth, ynorth, zbott, ztop       ! Boundary conditions
INTEGER, DIMENSION(:), ALLOCATABLE :: mat                  ! Material assignment to nodes

! FDM Matrix
TYPE :: FDM_MATR
  REAL(DP), DIMENSION(:), ALLOCATABLE :: elmn               ! Non-zero elements of FDM matrix for a row
END TYPE
TYPE(FDM_MATR), DIMENSION(:,:), ALLOCATABLE :: A            ! FDM matrix
TYPE :: FDM_IND
  INTEGER                            :: ncol               ! Number of non-zero column in a row for the FDM Matrix
  INTEGER, DIMENSION(:), ALLOCATABLE :: col                ! Column index for the non-zero element of the FDM matrix
END TYPE
TYPE(FDM_IND), DIMENSION(:), ALLOCATABLE :: ind            ! Index of the FDM matrix

! Keff, flux and currents
REAL(DP) :: Ke
TYPE :: NODE_DATA
  REAL(DP), DIMENSION(6) :: df             ! FDM nodal coupling coefficients (X+,X-,Y+, Y-, Z+, Z-)
  REAL(DP), DIMENSION(6) :: dn             ! Corrected (higher order) nodal coupling coefficients (X+,X-,Y+, Y-, Z+, Z-)
END TYPE
TYPE(NODE_DATA), DIMENSION(:,:), ALLOCATABLE :: nod

REAL(DP), DIMENSION(:,:), ALLOCATABLE :: f0, ft      ! current and previous Fluxes
REAL(DP), DIMENSION(:), ALLOCATABLE :: fs0, fst     ! Fission source
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: c0 ! neutron precusor density
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: s0 ! neutron precusor density

TYPE :: STAGGERED
    INTEGER :: smax, smin                             ! imax and imin along x and y direction for staggered nodes
END TYPE
TYPE(STAGGERED), DIMENSION(:), ALLOCATABLE :: ystag, xstag

! Extra Sources
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: exsrc

! Iteration Control
REAL(DP) :: ferc = 1.e-5    ! Flux Error Criteria
REAL(DP) :: serc = 1.e-5    ! Fission source Error CRITERIA
REAL(DP) :: fer, ser        ! Flux and Fission source error in BCSEARCH calcs.
INTEGER :: nin = 2      ! Maximum inner iteration
INTEGER :: nout = 500   ! Maximum outer iteration
INTEGER :: nac = 5      ! Fission source extrapolation interval
INTEGER :: th_niter = 30   ! Maximum number of thermal-hydraulics iteration
INTEGER :: nth = 20     ! Maximum number of outer iterations per thermal-hydraulics iteration
integer :: nupd         ! Nodal update interval

! OUTPUT PRINT OPTION
INTEGER :: aprad=1, apaxi=1, afrad=1

! FUEL TEMPERATURE
REAL(DP), DIMENSION(:), ALLOCATABLE :: ftem       ! Fuel temperature in Kelvin for each nodes
REAL(DP) :: rftem      ! Fuel temperature Reference in Kelvin
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: fsigtr, fsiga, fnuf, fsigf   ! XSEC changes per fuel temp changes
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: fsigs

! MODERATOR TEMPERATURE
REAL(DP), DIMENSION(:), ALLOCATABLE :: mtem       ! Moderator temperature in Kelvin for each nodes
REAL(DP) :: rmtem      ! Moderator temperature Reference in Kelvin
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: msigtr, msiga, mnuf, msigf   ! XSEC changes per Moderator temp changes
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: msigs

! COOLANT DENSITY
REAL(DP), DIMENSION(:), ALLOCATABLE :: cden       ! Coolant Density in g/cm3 for each nodes
REAL(DP) :: rcden      ! Coolant Density Reference in g/cm3
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: lsigtr, lsiga, lnuf, lsigf   ! XSEC changes per Coolant density changes
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: lsigs

! Crod changes
INTEGER :: nb                                                     ! Number of CR banks
REAL(DP), DIMENSION(:), ALLOCATABLE :: bpos  ! CR bank position
REAL(DP), DIMENSION(:), ALLOCATABLE :: fbpos    ! Final CR bank position
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: dsigtr, dsiga, dnuf, dsigf   ! XSEC incerement or decrement due to CR insertion
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: dsigs
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: ddc   ! increment or decreent for ADF
REAL(DP), DIMENSION(:), ALLOCATABLE :: tmove    ! Time when CR bank starts moving
REAL(DP), DIMENSION(:), ALLOCATABLE :: bspeed   ! CR bank movement speed
INTEGER, DIMENSION(:), ALLOCATABLE :: mdir  ! To indicate CR movement direction (0=do not move, 1=down, 2 = up)
REAL(DP) :: nstep                                         ! Number of steps
REAL(DP)    :: coreh                                      ! Core Height
INTEGER, DIMENSION(:,:), ALLOCATABLE :: fbmap             ! Radial control rod bank map (node wise)
REAL(DP) :: pos0, ssize                                   ! Zero step position and step size

! Boron Concentration
REAL(DP) :: bcon       ! Boron concentration in ppm
REAL(DP) :: rbcon      ! Boron concentration in ppm Reference
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: csigtr, csiga, cnuf, csigf   ! XSEC changes due to boron concentration
REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: csigs                      ! Used only for CBCS card

! Transient parameters
INTEGER, PARAMETER :: nf = 6                           ! Number of delayed neutron precusor family
REAL(DP)           :: sth = 1._dp, bth = 0._dp         ! Small theta and big theta for transient using theta method
REAL(DP), DIMENSION(nf) :: ibeta, lamb                 ! beta (delayed neutron fraction) and precusor decay constant
REAL(DP), DIMENSION(:), ALLOCATABLE :: tbeta           ! total beta
REAL(DP) :: ctbeta                                     ! Core averaged
REAL(DP), DIMENSION(:), ALLOCATABLE :: velo            ! Neutron velocity
REAL(DP) :: ttot                                       ! TOTAL SIMULATION TIME
REAL(DP) :: tstep1                                     ! FIRST TIME STEP
REAL(DP) :: tstep2                                     ! SECOND TIME STEP
REAL(DP) :: tdiv                                       ! WHEN SECOND TIME STEP APPLY
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: omeg          ! Exponential transformation constant
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: sigrp         ! Initial removal cross sections before added by parameters required for transient
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: L             ! Total leakages for node n and group g
REAL(DP), DIMENSION(:), ALLOCATABLE :: dfis
LOGICAL :: tranw = .FALSE.                             ! To activate unconverged  outer iteration warning

! Thermal-hydraulics parameters
REAL(DP) :: pow                                        ! Reactor power for given geometry (watt)
REAL(DP) :: ppow                                       ! Reactor percent power in percent
REAL(DP) :: tpow                                       ! Total reactor power
REAL(DP), DIMENSION(:), ALLOCATABLE :: npow            ! nodes power (watt)
REAL(DP) :: tin                                        ! coolant inlet temperature (kelvin)
REAL(DP) :: cflow                                      ! Sub-channel mass flow rate (kg/s)
REAL(DP) :: rf, tg, tc, ppitch                         ! Fuel meat radius, gap thickness, clad thickness, and pin picth (m)
REAL(DP) :: rg, rc                                     ! Outer radius of gap and cladding
REAL(DP) :: dia, dh, farea                             ! Pi diameter, Hydraulic diameter (m) and sub-channel area (m2)
REAL(DP) :: cf                                         ! heat fraction deposited into coolant
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: node_nf       ! Number of fuel pin per node
INTEGER, PARAMETER :: nm = 10                          ! number of Fuel meat mesh
INTEGER, PARAMETER :: nt = nm+2                          ! Number Total mesh (+2 mesh for gap and clad)
REAL(DP), DIMENSION(:,:), ALLOCATABLE :: tfm           ! Fuel pin mesh temperature for each nodes
REAL(DP), DIMENSION(:), ALLOCATABLE :: rdel            ! mesh delta
REAL(DP), DIMENSION(:), ALLOCATABLE :: rpos            ! mesh position
REAL(DP) :: th_err                                     ! Doppler error
REAL(DP), DIMENSION(:), ALLOCATABLE :: ent             ! Coolant Enthalpy (J/Kg)
REAL(DP), DIMENSION(:), ALLOCATABLE :: heatf           ! Heat flux (W/m2
REAL(DP), DIMENSION(:), ALLOCATABLE :: frate           ! coolant mass flow rate
INTEGER, PARAMETER :: thunit = 300                 ! Unit number to open steam table file
REAL(DP), PARAMETER :: pi = 3.14159265

! Steam Table data
INTEGER, PARAMETER:: ntem = 9   ! Number of temperature in steam table
REAL(DP), DIMENSION(ntem,6) :: stab  ! Steam table matrixs

! Data type for branch xsec data used if XTAB file present
TYPE :: XBRANCH
  REAL(DP), DIMENSION(:), ALLOCATABLE :: sigtr, siga, nuf, sigf   !XSEC
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: sigs
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: dc        !ASSEMBLY DISCONTINUITY FACTOR
END TYPE
! Data Type to store data in XTAB file
TYPE :: MBRANCH
  INTEGER :: nd, nb, nf, nm  ! BRANCH PARAMETER DIMENSION (Coolant dens., boron conc., fuel and moderator temp.)
  REAL(DP), DIMENSION(:), ALLOCATABLE :: pd, pb, pf, pm         !Branch paramaters (Coolant dens., boron conc., fuel and moderator temp.)
  TYPE(XBRANCH), DIMENSION(:,:,:,:), ALLOCATABLE :: xsec        !Unrodded XSEC
  TYPE(XBRANCH), DIMENSION(:,:,:,:), ALLOCATABLE :: rxsec       !Rodded XSEC
  REAL(DP), DIMENSION(:), ALLOCATABLE :: velo   ! Neutron velocity
  REAL(DP), DIMENSION(nf) :: ibeta, lamb          ! beta and decay constant
  INTEGER :: tadf            !Control input: adf
  INTEGER :: trod            !Control input: control rod
END TYPE
TYPE(MBRANCH), DIMENSION(:), ALLOCATABLE :: m

! CMFD
real(dp), dimension(:), allocatable   :: a1n, a2n, a3n, a4n  ! Nodal expansion coefficients for current node
real(dp), dimension(:), allocatable   :: a1p, a2p, a3p, a4p  ! Nodal expansion coefficients for following node
real(dp), dimension(:), allocatable   :: Ln1, Lp1            ! First Transverse leakages moments
real(dp)                              :: ndmax               ! Maximum nodal coupling coefficients
character(len=4)                      :: kern = 'SANM'
integer                               :: im, jm, km

!Timing
real(dp) :: fdm_time = 0., nod_time = 0., xs_time = 0., &
inp_time = 0., th_time = 0.

contains

  function get_time() result (time)

    implicit none

    real(dp) :: time

    call cpu_time(time)

  end function

END MODULE sdata


	SUBROUTINE PC_PVAL  ( thta, level1, level2, pres, iret )
C************************************************************************
C* PC_PVAL								*
C*									*
C* This subroutine computes the value of the pressure in a dataset	*
C* for a given value of theta.  The computation uses the vertical	*
C* vertical data stored internally by the PC package.			*
C*									*
C* PC_PVAL  ( THTA, LEVEL1, LEVEL2, PRES, IRET )			*
C*									*
C* Input parameters:							*
C*	THTA		REAL		Value of theta			*
C*	LEVEL1		INTEGER		Level at or below THTA		*
C*	LEVEL2		INTEGER	  	Level above THTA		*
C*									*
C* Output parameters:							*
C*	PRES		REAL		Pressure			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-23 = bad or missing data	*
C*					-25 = incorrect levels		*
C*					-26 = isentropic data not comp	*
C*					-27 = max iterations done	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/84						*
C* M. desJardins/GSFC	 6/87	Exit loop when guess reaches real	*
C*				precision				*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
	INCLUDE    	'pccmn.cmn'
C*
	REAL       	adata (4), bdata (4), cdata (4)
	LOGICAL    	done, BETWEN
	LOGICAL    	intflg (2), angflg (2)
	PARAMETER  	(EPS = .001)
C
C*      This include for statement function for missing data.
C       Put before other statement functions.
C
        INCLUDE    'ERMISS.FNC'
C

C*
	DATA       	intflg /2*.true./, angflg /2*.false./
	DATA	   	iter /100/
C
C*	Statement function to guess pressure.  It is assumed that theta
C*	varies linearly with log pressure.
C
	PGUESS() = EXP ( ALOG (p1) + ( thta - th1 ) *
     +			 ALOG ( p2 / p1 ) / ( th2 - th1 ) )
C
C*	Statement function to check if x < a < y.
C
	BETWEN (x, y, a) = ( ( .not. ERMISS (x) )
     +                          .and. ( .not. ERMISS (y))
     +				.and. (x .le. a) .and. (a .le. y) )
C------------------------------------------------------------------------
C*	Check that data will be in vertical table.
C
	iret = 0
	pres = RMISSD
	IF  ( ( .not. vcomp (1) ) .or. ( .not. vcomp (2) ) .or.
     +	      ( .not. vcomp (5) ) )  THEN
	    iret = -26
	    RETURN
	END IF
C
C*	Find the bounding values of pressure and theta.  Use index of
C*	1 for lower value of theta and index of 2 for higher value.
C
	IF  ( vdata ( 2, level1 ) .lt. vdata ( 2, level2 ) )  THEN
	    p1  = vdata (1, level1)
	    p2  = vdata (1, level2)
	    th1 = vdata (2, level1)
	    th2 = vdata (2, level2)
	    t1  = vdata (5, level1)
	    t2  = vdata (5, level2)
	  ELSE
	    p1  = vdata (1, level2)
	    p2  = vdata (1, level1)
	    th1 = vdata (2, level2)
	    th2 = vdata (2, level1)
	    t1  = vdata (5, level2)
	    t2  = vdata (5, level1)
	END IF
C
C*	Check that this required data is not missing
C
	IF  ( ERMISS ( p1 )  .or. ERMISS ( p2 )  .or.
     +	      ERMISS ( th1 ) .or. ERMISS ( th2 ) .or.
     +	      ERMISS ( t1 )  .or. ERMISS ( t2 ) )  THEN
	    iret = -23
	  ELSE IF  ( ( p1 .eq. 0. ) .or. ( th1 .eq. th2 ) .or.
     +		     ( .not. BETWEN ( th1, th2, thta ) ) )  THEN
	    iret = -23
	END IF
	IF  ( iret .ne. 0 )  RETURN
C
C*	Make initial guess for pressure and fill adata, bdata with pressure
C*	and temperature for interpolation.
C
	pg    = PGUESS ()
	pgold = RMISSD
	adata (1) = p1
	bdata (1) = p2
	adata (2) = t1
	bdata (2) = t2
	done  = .false.
	kiter = 1
C*
	DO WHILE  ( .not. done )
	    cdata (2) = RMISSD
	    CALL PC_INTP  ( pg, adata, bdata, 2, intflg, angflg, cdata,
     +			    ier )
	    tg  = cdata (2)
	    thg = PR_THTA ( tg, pg )
	    IF  ( ABS ( thg - thta ) .lt. EPS )  THEN
		pres = pg
		done = .true.
	      ELSE IF  ( pg .eq. pgold )  THEN
		pres = pg
		done = .true.
	      ELSE IF  ( BETWEN ( thta, th2, thg ) )  THEN
		p2  = pg
		th2 = thg
	      ELSE IF  ( BETWEN ( th1, thta, thg ) )  THEN
		p1  = pg
		th1 = thg
	      ELSE
		done = .true.
		iret = -27
	    END IF
	    pgold = pg
	    pg    = PGUESS ()
	    kiter = kiter + 1
	    IF  ( kiter .gt. iter )  THEN
		done = .true.
		iret = -27
	    END IF
	END DO
C*
	RETURN
	END


SUBROUTINE beam_gm(gm,ell)
!
! This subroutine forms the beam geometric matrix for stability analysis.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ell
 REAL(iwp),INTENT(OUT)::gm(:,:)
 REAL(iwp)::pt1=0.1_iwp,opt2=1.2_iwp,two=2.0_iwp,d15=15.0_iwp,d30=30.0_iwp
 gm(1,1)=opt2/ell
 gm(1,2)=pt1
 gm(2,1)=pt1
 gm(1,3)=-opt2/ell
 gm(3,1)=-opt2/ell
 gm(1,4)=pt1
 gm(4,1)=pt1
 gm(2,2)=two*ell/d15
 gm(2,3)=-pt1
 gm(3,2)=-pt1
 gm(2,4)=-ell/d30
 gm(4,2)=-ell/d30
 gm(3,3)=opt2/ell
 gm(3,4)=-pt1
 gm(4,3)=-pt1
 gm(4,4)=two*ell/d15
RETURN
END SUBROUTINE beam_gm