c***********************************************************************
c	                    COORD_H2B.F
c***********************************************************************
*     PURPOSE: Converts from Heliocentric to Barycentric coords.
*     ARGUMENTS:  Input is
*                    nbod ==> number of bodies (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==>  masses (real array)
*		     xh(*),yh(*),zh(*) ==> heliocentric particle coords
*                                          (real array)
*		     vxh(*),vyh(*),vzh(*) ==> heliocentric particle velocities
*                                             (real array)
*                 Returned are
*                    xb(*),yb(*),zb(*) ==> bary. particle positions
*                                          (real array)
*                    vxb(*),vyb(*),vzb(*) ==> bary. particle velocities
*                                            (real array)
*                    msys              ==>  Total mass of of system
*                                            (real scalar)
*     Authors:  Martin Duncan
*     ALGORITHM: Obvious
*     WRITTEN:  Jan 27/93
*     REVISIONS: 2/22/94  HFL

	subroutine coord_h2b(nbod,mass,xh,yh,zh,vxh,vyh,vzh,
     &      xb,yb,zb,vxb,vyb,vzb,msys)

      include '../swift.inc'

c...  Inputs:
	integer nbod
	real*8 mass(NPLMAX)
	real*8 xh(NPLMAX),yh(NPLMAX),zh(NPLMAX)
	real*8 vxh(NPLMAX),vyh(NPLMAX),vzh(NPLMAX)

c...  Outputs:
	real*8 xb(NPLMAX),yb(NPLMAX),zb(NPLMAX)
	real*8 vxb(NPLMAX),vyb(NPLMAX),vzb(NPLMAX)

c...  Internals:
	real*8 msys,xtmp,ytmp,ztmp,vxtmp,vytmp,vztmp
	integer n

c----
c...  Executable code

	msys = mass(1)
	xtmp =0.d0
	ytmp =0.d0
	ztmp =0.d0
	vxtmp =0.d0
	vytmp =0.d0
	vztmp =0.d0

	do n=2,nbod
	   msys = msys +mass(n)
	   xtmp = xtmp + mass(n)*xh(n)
	   ytmp = ytmp + mass(n)*yh(n)
	   ztmp = ztmp + mass(n)*zh(n)
	   vxtmp = vxtmp + mass(n)*vxh(n)
	   vytmp = vytmp + mass(n)*vyh(n)
	   vztmp = vztmp + mass(n)*vzh(n)
	enddo

	xb(1) = -xtmp/msys
	yb(1) = -ytmp/msys
	zb(1) = -ztmp/msys
	vxb(1) = -vxtmp/msys
	vyb(1) = -vytmp/msys
	vzb(1) = -vztmp/msys

	do n=2,nbod
	  xb(n) = xh(n) + xb(1)
	  yb(n) = yh(n) + yb(1)
	  zb(n) = zh(n) + zb(1)
	  vxb(n) = vxh(n) + vxb(1)
	  vyb(n) = vyh(n) + vyb(1)
	  vzb(n) = vzh(n) + vzb(1)
	enddo

	return
	end     ! coord_h2b
c--------------------------------------------------------------------------


!  Compliments of netlib   Sun Jul  6 04:10:36 EDT 1986
!  algorithm 615, collected algorithms from acm.
!  algorithm appeared in acm-trans. math. software, vol.10, no. 2, june, 1984,
!  pp. 202-206.  Authors: Armstrong, R.D., Beck, P.O. & Kung, M.T.

MODULE toms615
IMPLICIT NONE

INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)

! Replace the COMMON statements in TOMS615
REAL (dp), SAVE    :: acu, big, bsave(210), lu(20,20), pie(210), sad, sadt,  &
                      savtot(210), sig(6000), sigma(300), zlow, zsave(20)
INTEGER, SAVE      :: ibase(20), ik, ik1, incol(20), index(20), inprob(210), &
                      ipar(20), label(210), level
LOGICAL, SAVE      :: direct, intl

CONTAINS

SUBROUTINE kbest (x, y, m, n, iter, ifault, popt, minin, nmax, mmax, bval, &
                  idex, istat, zl)

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

!  The purpose of this program is to determine the best subset of parameters
!  to fit a linear regression under an least absolute value criterion.
!  This program utilizes the simplex method of linear programming within a
!  branch-and-bound algorithm to solve the best subset problem.

!  The algorithm is based on the publication:
!     Armstrong,R.D. and M.T. Kung "An algorithm to select the best subset for
!     a least absolute value regression problem", Optimization in Statistics,
!     TIMS Studies of the Management Sciences, vol.33, 931-936 (1982).

!   formal parameters

!   x      real array        input:  values of independent variables such that
!          (nmax,mmax)               each row corresponds to an observation

!   y      real array        input:  values of the dependent variables
!            (nmax)

!   m      integer           input:  number of dependent variables

!   n      integer           input:  number of observations

!   iter   integer           output: number of iterations

!   ifault integer           output: failure indicator
!                               = 0  normal termination
!                               = 1  observation matrix does not have full
!                                    row rank (rank m)
!                               = 2  problem size out of range
!                               = 3  no pivot element found implying near
!                                    singular basis

!   popt    real             input:  percentage deviation from
!                                    optimality allowed

!   minin   integer          input:  minimum number of parameters in the
!                                    model.  best subset of size minin t
!                                    m is obtained.

!   nmax    integer          input:  dimension of rows in x (also y)

!   mmax    integer          input:  dimension of columns in x

!   bval    real array       output: array of optimal beta values for each
!                                    subset.  The beta values for the subset
!                                    of size m are stored in positions
!                                    bval(1), bval(2), ..., bval(m), for the
!                                    subset of size m-1 the values are stored
!                                    in positions bval(m+1), bval(m+2), ...,
!                                    bval(2m-1).  In general, the beta values
!                                    for the optimal subset of size k are
!                                    stored in positions bval(l), ...,
!                                    bval(l-k+1) where
!                                    l = (m*(m+1)-k*(k+1))/2 + 1

!  idex     integer array    output: beta index set for the optimal subset.
!        (((mmax+1)*mmax)/2)         This array is a  parallel array for bval;
!                                    i.e., if bval(j) = 2. and idex(j) = 7
!                                    then beta(7) = 2.7 in the associated
!                                    optimal subset.

!  istat    integer array    input:  parameter status array.
!            (mmax)

!                                        1 if beta(j) is required
!                                          in every model
!                     istat(j) =

!                                        0 otherwise

!  zl       real array       output: best objective value for each subse
!            (mmax)
!                                    zl(j) gives the best objective valu
!                                    for the subset with m-j+1 parameter
!***********************************************************************

! implementation notes:

!     1. the routine uses two machine dependent values acu and big.
!        (these are set at the beginning of this subroutine)
!        a) acu is used to test for "zero". acu should be set to approximately
!           100 * the relative machine accuracy of the system in use.
!        b) big is used to initialize the array zl (described above).
!           big should be set to the largest floating point value assignable.

!     2. both single and double precision versions are supplied.  This version
!        is in double precision.

!     3. array dimensions
!        the code is currently dimensioned to solve problems with up to 20
!        parameters and 300 observations. the dimension sizes are
!        determined as follows
!            20 mmax
!           300 nmax
!           210 (nmax+1)*mmax/2
!          6000 nmax*mmax
!            10 maximum value of ik .

!         if the dimension sizes are changed the common and dimension
!         statements will need to be modified in each subroutine.

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

!  subroutines:

!      calbet   - back-solves a sysytem of equations

!      calcpi   - forward-solves a sysytem of equations

!      kbest    - the driver

!      l1norm   - solves the initial regression problem with all
!                 parameters included in the model

!      phase2   - solves the current regression problem with a primal algorithm

!      setup    - determines the form of the current problem by
!                 choosing the parameter to leave based on a penalty

!      update   - updates lu decomposition matrix

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

!     description of variables:

!     ik:    length of candidate list
!     beta:  estimates to the current subproblem
!     sad:   the minimum total absolute deviation
!     ibase: the index array of columns of the basis

!        n,m,nmax,mmax,x,y, are not changed in the subroutine;
!          sad is updated at each iteration

!     lu:    the lu decomposition of the current basis
!     index: the index array of rows of lu
!     tot:   the current rhs of the dual problem
!     sigma: indicator array to specify whether a nonbasic dual variable
!            is at upper or lower bound(+1 implies upper; -1 implies lower)
!     inext: a local array for the sort routine
!     rhs:   a local array for the calbet routine

!     ipar(i) = -k if the k-th parameter (beta) is out of model at level i
!             =  k if the k-th parameter is in

!     label(i)  saves the indices of the basic observations in the
!               predecessor path
!     zsave(i)  saves the objective values on the predecessor path

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

! Conversion to be ELF90 compatible by Alan Miller
! e-mail:  amiller @ bigpond.net.au
! http://users.bigpond.net.au

! Latest revision - 8 December 1998

IMPLICIT NONE

REAL (dp), INTENT(IN)   :: x(300,20), y(300), popt
INTEGER, INTENT(IN)     :: m, n, nmax, mmax
INTEGER, INTENT(IN OUT) :: minin, istat(20)
INTEGER, INTENT(OUT)    :: iter, ifault, idex(210)
REAL (dp), INTENT(OUT)  :: bval(210), zl(20)

! Local variables
REAL (dp) :: beta(20), tot(20), pi(20), repp(20)
INTEGER   :: i, j, jinm, k2, k3, kkk1, l, nfree, numin
REAL (dp) :: popt1, zero = 0.0_dp

!     assign values to machine dependent constants

! acu = SQRT(d1mach(4))
! big = d1mach(2)

acu = SQRT( 2.0_dp * EPSILON(1.0_dp) )
big = HUGE(1.0_dp)

ifault = 0
ik = 5
ik1 = ik-1
popt1 = (100. - popt)/100.

!     test problem size

IF (n <= nmax .AND. m <= mmax) GO TO 10
ifault = 2
RETURN

10 DO i = 1,m
  index(i) = i
  tot(i) = zero
  incol(i) = i
END DO
CALL l1norm (x, y, n, m, ifault, iter, beta, pi, tot)
IF (ifault > 0) RETURN

!     initialization

!     save the initial solution

jinm = 0
DO i = 1,m
  bsave(i) = beta(i)
  bval(i) = beta(i)
  pie(i) = pi(i)
  label(i) = ibase(i)
  idex(i) = i
  inprob(i) = i
  savtot(i) = tot(i)
  zl(i) = big
  jinm = jinm+istat(i)
END DO
sig(1:n) = sigma(1:n)

level = 0
direct = .true.

IF (jinm > minin) minin = jinm

!     initialize number of free parameters in model

nfree = m-jinm

zl(m) = sad
zsave(m) = sad

IF (minin == m) RETURN

!       numin gives the number of parameters in the model

numin = m

!     start the main loop

50 numin = numin-1
level = level+1
IF (numin < minin .OR. nfree == 0) GO TO 120
k2 = (m*(m+1) - (numin+1)*(numin+2))/2
kkk1 = numin+1
zlow = zl(numin)*popt1
IF (direct) GO TO 80
DO i = 1,kkk1
  j = k2+i
  index(i) = i
  ibase(i) = label(j)
  incol(i) = inprob(j)
  pi(i) = pie(j)
  beta(i) = bsave(j)
  tot(i) = savtot(j)
END DO

!     load in the bounds from the immediate predecessor

k3 = (m-kkk1)*n
DO i = 1,n
  k3 = k3+1
  sigma(i) = sig(k3)
END DO
sad = zsave(kkk1)

!     set up a new problem

80 CALL setup (x, kkk1, ifault, istat, beta, tot, pi, repp)
IF (ifault > 0) RETURN
nfree = nfree - 1

!     call primal l.p. code

CALL phase2 (x, y, numin, n, iter, ifault, beta, tot, pi, repp)

!      save the solution data for later recall

k2 = k2 + kkk1 + 1
j = k2
DO i = 1,numin
  l = k2+i
  pie(l) = pi(i)
  label(l) = ibase(i)
  bsave(l) = beta(i)
  inprob(l) = incol(i)
  savtot(l) = tot(i)
END DO

!     save the objective value

zsave(numin) = sad

!     save the nonbasic bounds

k3 = (m-numin)*n
DO i = 1,n
  k3 = k3+1
  sig(k3) = sigma(i)
END DO

direct = .true.

!     check for a better solution

IF (sadt >=  zlow) GO TO 50

!     save the better solution

zl(numin) = sad
k2 = j
DO i = 1,numin
  l = k2 + i
  idex(l) = incol(i)
  bval(l) = beta(i)
END DO

!     go to top of loop

GO TO 50
120 numin = numin + 1

direct = .false.

!     must work back up the tree

level = level - 1
130 IF (ipar(level) > 0) GO TO 140
ipar(level) = -ipar(level)
j = ipar(level)
istat(j) = 1
numin = numin + 1
GO TO 50
140 j = ipar(level)
istat(j) = 0
nfree = nfree + 1
level = level - 1
IF (level > 0) GO TO 130
RETURN

END SUBROUTINE kbest

SUBROUTINE setup (x, m, ifault, istat, beta, tot, pi, repp)

!     this subroutine determines the form of the current subproblem

IMPLICIT NONE
REAL (dp), INTENT(IN)     :: x(300,20), beta(20)
REAL (dp), INTENT(IN OUT) :: tot(20), pi(20), repp(20)
INTEGER, INTENT(OUT)      :: ifault
INTEGER, INTENT(IN OUT)   :: m, istat(20)

! Local variables
INTEGER   :: i, ifixi, ii, iout, isave, kkk, l, leave, ll
REAL (dp) :: beside, one = 1.0_dp, penalt, ratio, rho, rhs(20), side, srepp,  &
             test, zero = 0.0_dp

!     if the immediate predecessor is in memory go on

IF (direct) GO TO 10

!     reconstruct the lu decomposition

kkk = 1
CALL update (kkk, ifault, x, 1, m)
IF (ifault > 0) RETURN

!     recalculate the basic pi values

kkk = 0

CALL calcpi (kkk, pi, tot, m)

!     determine parameter to leave based on penalty

10 penalt = big
kkk = 0
rhs(1:m) = zero

DO i = 1,m
  ii = index(i)
  ll = incol(ii)
  IF (istat(ll) == 1) CYCLE
  rho = SIGN(1._dp, beta(ii))
  rhs(ii) = one
  kkk = i-1
  CALL calcpi (kkk, repp, rhs, m)
  rhs(ii) = zero
  test = big
  DO l = 1,m
    IF (ABS(repp(l)) <= acu) CYCLE
    srepp = SIGN(1._dp,repp(l))
    ratio = ABS((1._dp - rho*srepp*pi(l))/repp(l))
    IF (ratio >= test) CYCLE
    side = rho*srepp
    test = ratio
    iout = l
  END DO

!     see if the penalty is less

  IF (test*ABS(beta(ii)) >= penalt) CYCLE
  leave = iout
  ifixi = ii
  beside = side
  penalt = test*ABS(beta(ii))
END DO

!     update the objective value

sad = sad+penalt

!     parameter incol(ifixi) will leave the model
!     pi(ibase(leave)) will leave the basis and go to bound

!     switch unwanted parameter and pi to the end of list

isave = incol(ifixi)
incol(ifixi) = incol(m)
incol(m) = isave
tot(ifixi) = tot(m)

!     label this node and flag the outgoing parameter

ipar(level) = -isave
istat(isave) = -1

isave = ibase(leave)
ibase(leave) = ibase(m)
ibase(m) = isave

!     place the outgoing pi at the correct bound

sigma(isave) = beside

!     form a new basis

m = m-1

DO i = 1,m
  index(i) = i
END DO

kkk = 1
CALL update (kkk, ifault, x, 1, m)
IF (ifault > 0) RETURN

!     update the tot array

DO i = 1,m
  ll = incol(i)
  tot(i) = tot(i) - beside*x(isave,ll)
END DO

RETURN

END SUBROUTINE setup

SUBROUTINE phase2 (x, y, m, n, iter, ifault, beta, tot, pi, repp)

!     solves lp with primal algorithm

IMPLICIT NONE

INTEGER, INTENT(IN)       :: m, n
INTEGER, INTENT(IN OUT)   :: iter
INTEGER, INTENT(OUT)      :: ifault
REAL (dp), INTENT(IN)     :: x(300,20), y(300)
REAL (dp), INTENT(IN OUT) :: tot(20)
REAL (dp), INTENT(OUT)    :: beta(20), pi(20), repp(20)

! Local variables
INTEGER   :: i, iin, iout, j, k, kan(10), kkk, krow, l, ll
REAL (dp) :: one = 1.0_dp, ratio, rho, rhs(20), srepp, test, xtwo,  &
             z(10), zero = 0.0_dp, zc, zz

!     z(i) stores the reduced cost values on the list
!     kan(i) stores the row number on the list
!     ik is the length of the list

!     calculate the simplex multipliers

DO i = 1,m
  k = ibase(i)
  pi(i) = y(k)
END DO
kkk = 0
CALL calbet (kkk, beta, pi, m)

!     recalculate the basic pi values

kkk = 0
CALL calcpi (kkk, pi, tot, m)

!     store the objective value used for termination check

sadt = sad
IF (sad >= zlow) RETURN

!     generate the candidate list

20 z(1:ik) = acu

!     calculate the reduced costs

DO j = 1,n
  IF (sigma(j) == zero) CYCLE
  zc = zero
  DO i = 1,m
    ll = incol(i)
    zc = zc+beta(i)*x(j,ll)
  END DO
  zz = (zc - y(j))*sigma(j)
  IF (zz <= z(ik)) CYCLE

!     rank the values in z(i), in descending order

  DO k = 1,ik1
    IF (zz <= z(k)) CYCLE
    i = ik
    50 z(i) = z(i-1)
    kan(i) = kan(i-1)
    i = i-1
    IF (i > k) GO TO 50
    z(k) = zz
    kan(k) = j
    CYCLE
  END DO
  z(ik) = zz
  kan(ik) = j
END DO
IF (z(1) <= acu) RETURN
krow = 1
zz = z(1)
iin = kan(1)
zc = zz*sigma(iin)
GO TO 100
80 krow = krow+1
IF (krow > ik) GO TO 20
IF (z(krow) <= acu) GO TO 20

!     determine the entering variable from the candidate list

iin = kan(krow)
zc = zero
DO i = 1,m
  ll = incol(i)
  zc = zc + beta(i)*x(iin,ll)
END DO
zc = zc - y(iin)
zz = zc*sigma(iin)
IF (zz <= acu) GO TO 80
100 rho = sigma(iin)

!     rho: sign of the incoming reduced cost
!     iin: incoming candidate

!     find the representation of the entering variable

DO i = 1,m
  ll = incol(i)
  rhs(i) = x(iin,ll)
END DO
kkk = 0
CALL calcpi (kkk, repp, rhs, m)

!     calculate the min ratio test to determine the leaving variable

test = 2.0
DO i = 1,m
  IF (ABS(repp(i)) <= acu) CYCLE
  srepp = SIGN(1.0_dp,repp(i))
  ratio = ABS((1._dp - rho*srepp*pi(i))/repp(i))
  IF (ratio >= test) CYCLE
  test = ratio
  iout = i
END DO

!     perform fathoming test before pivot

sadt = sad + test*zz
IF (sadt >= zlow) RETURN
sad = sadt

pi(1:m) = pi(1:m) + test*repp(1:m)*rho
IF (test < 2.0) GO TO 150

sigma(iin) = -sigma(iin)
xtwo = sigma(iin) + sigma(iin)
DO i = 1,m
  ll = incol(i)
  tot(i) = tot(i) - xtwo*x(iin,ll)
END DO
GO TO 80
150 k = ibase(iout)
sigma(k) = SIGN(1.0_dp, pi(iout))
pi(iout) = sigma(iin)*(1.0-test)
ibase(iout) = iin

DO i = 1,m
  ll = incol(i)
  tot(i) = tot(i) + sigma(iin)*x(iin,ll) - sigma(k)*x(k,ll)
END DO

kkk = iout
CALL update (iout, ifault, x, 1, m)

rhs(1:m) = zero
rhs(kkk) = one
kkk = kkk - 1
CALL calbet (kkk, repp, rhs, m)
DO l = 1,m
  beta(l) = beta(l) - zc*repp(l)
END DO
sigma(iin) = zero
iter = iter + 1
GO TO 80

END SUBROUTINE phase2

SUBROUTINE l1norm (x, y, n, m, ifault, iter, beta, pi, tot)

!     this routine solves the initial regression problem with all
!     the parameters included in the model

IMPLICIT NONE
INTEGER, INTENT(IN)       :: n, m
INTEGER, INTENT(OUT)      :: ifault, iter
REAL (dp), INTENT(IN)     :: x(300,20), y(300)
REAL (dp), INTENT(IN OUT) :: tot(20)
REAL (dp), INTENT(OUT)    :: beta(20), pi(20)

! Local variables
REAL (dp) :: d(300), delta(300), price(300), rhs(20)
INTEGER   :: i, iin, inext(300), iout, ipt, j, k, k1, kkk, kount, l
REAL (dp) :: ahalf, aone, one = 1.0_dp, ratio, rho, subt, t, test, total,  &
             val, zero = 0.0_dp, zzz

!        initial settings

iter = 0
aone = one + acu
ahalf = .5 + acu

!     set up initial lu decomposition

intl = .true.
k = 1
CALL update (k, ifault, x, n, m)
IF (ifault /= 0) RETURN
intl = .false.
DO i = 1,m
  k1 = ibase(i)
  rhs(i) = y(k1)
END DO
kkk = 0
CALL calbet (kkk, beta, rhs, m)

!        calculate initial d, tot and sigma vectors

DO j = 1,n
  val = DOT_PRODUCT( beta(1:m), x(j,1:m) )
  d(j) = y(j) - val
  sigma(j) = SIGN(1._dp, d(j))
END DO
DO j = 1,m
  rhs(j) = zero
  kkk = ibase(j)
  sigma(kkk) = zero
END DO
DO j = 1,n
  DO i = 1,m
    tot(i) = tot(i) - sigma(j)*x(j,i)
  END DO
END DO

!        main iterative loop begins

70 kkk = 0
CALL calcpi (kkk, pi, tot, m)

t = aone
k = 0
DO j = 1,m
  IF (ABS(pi(j)) < t) CYCLE
  k = j
  t = ABS(pi(j))
  rho = -SIGN(1._dp, pi(j))
END DO
IF (k == 0) GO TO 220
kkk = k - 1
rhs(k) = one
CALL calbet (kkk, beta, rhs, m)
rhs(k) = zero
DO i = 1,n
  delta(i) = zero
  IF (sigma(i) == zero) CYCLE
  DO j = 1,m
    delta(i) = delta(i) + beta(j)*x(i,j)
  END DO
  delta(i) = rho*delta(i)
END DO

!        perform partial sort of ratios

t = t*.5
kount = 0
ratio = big
total = ahalf
subt = zero
DO i = 1,n
  IF (delta(i)*sigma(i) <= acu) CYCLE
  test = d(i)/delta(i)
  IF (test >= ratio) CYCLE
  total = total + ABS(delta(i))
  IF (total - subt >= t) GO TO 110

!     insert i in list

  kount = kount+1
  price(kount) = test
  inext(kount) = i
  CYCLE

!     update sum and kick iin out of the list

  110 total = total - subt
  ratio = test
  ipt = 0
  kkk = 0

!     identify a new iin

  120 kkk = kkk + 1
  IF (kkk > kount) GO TO 130
  IF (price(kkk) <= ratio) GO TO 120
  ratio = price(kkk)
  ipt = kkk
  GO TO 120
  130 IF (ipt == 0) GO TO 150

!     switch values

  kkk = inext(ipt)
  subt = ABS(delta(kkk))
  IF (total - subt < t) GO TO 140
  price(ipt) = price(kount)
  inext(ipt) = inext(kount)
  kount = kount - 1
  GO TO 110
  140 iin = inext(ipt)
  inext(ipt) = i
  price(ipt) = test
  CYCLE
  150 iin = i
  subt = ABS(delta(i))
END DO

!        update basic indicators

DO j = 1,kount
  kkk = inext(j)
  zzz = sigma(kkk)
  DO l = 1,m
    subt = zzz*x(kkk,l)
    tot(l) = tot(l) + subt + subt
  END DO
  sigma(kkk) = -sigma(kkk)
END DO

iout = ibase(k)
delta(iout) = rho
DO l = 1,m
  tot(l) = tot(l) + rho*x(iout,l) + sigma(iin)*x(iin,l)
END DO
sigma(iout) = -rho
ibase(k) = iin
CALL update (k, ifault, x, 1, m)
d(1:n) = d(1:n) - ratio*delta(1:n)
sigma(iin) = zero
iter = iter + 1
GO TO 70

!        calculate optimal beta and sum of absolute deviations

220 DO i = 1,m
  k1 = ibase(i)
  rhs(i) = y(k1)
END DO
kkk = 0
CALL calbet (kkk, beta, rhs, m)
sad = SUM( ABS(d(1:n)) )
RETURN

END SUBROUTINE l1norm

SUBROUTINE calbet (kkk, beta, rhs, m)

!     subroutine calbet for back-solving system of equations

IMPLICIT NONE

INTEGER, INTENT(IN)     :: m
INTEGER, INTENT(IN OUT) :: kkk
REAL (dp), INTENT(IN)   :: rhs(20)
REAL (dp), INTENT(OUT)  :: beta(20)

! Local variables
INTEGER   :: i, ii, ii1, k, k1, k2, kk, kkk1, m1
REAL (dp) :: zero = 0.0_dp

IF (m > 1) GO TO 10
k = index(1)
beta(k) = rhs(1)/lu(k,1)
RETURN

10 m1 = m-1
IF (kkk == 0) GO TO 30
DO i = 1,kkk
  k = index(i)
  beta(k) = zero
END DO
30 kkk = kkk + 1
k = index(kkk)
beta(k) = rhs(kkk)/lu(k,kkk)
IF (kkk == m) GO TO 60
kkk1 = kkk + 1
DO ii = kkk1,m
  k = index(ii)
  beta(k) = rhs(ii)
  ii1 = ii - 1
  DO i = kkk,ii1
    kk = index(i)
    beta(k) = beta(k) - lu(kk,ii)*beta(kk)
  END DO
  beta(k) = beta(k)/lu(k,ii)
END DO

60 DO ii = 1,m1
  k1 = m - ii
  k = index(k1)
  DO i = 1,ii
    kk = m - i + 1
    k2 = index(kk)
    beta(k) = beta(k) - lu(k2,k1)*beta(k2)
  END DO
END DO
RETURN

END SUBROUTINE calbet

SUBROUTINE update (kkk, ifault, x, n, m)

!     subroutine update for updating lu decomposition matrix

IMPLICIT NONE
INTEGER, INTENT(IN)      :: n, m
INTEGER, INTENT(IN OUT)  :: kkk
INTEGER, INTENT(OUT)     :: ifault
REAL (dp), INTENT(IN)    :: x(300,20)

INTEGER   :: i, icol, ii, ii1, irow, isave, j, k, kk, ll
REAL (dp) :: pivot, subt

irow = 0
DO ii = kkk,m
  IF (intl) GO TO 10
  irow = ibase(ii)
  GO TO 20
  10 irow = irow + 1
  ibase(ii) = irow
  IF (irow > n) ifault = 1
  IF (ifault /= 0) RETURN
  20 DO i = 1,m
    ll = incol(i)
    lu(i,ii) = x(irow,ll)
  END DO

!     set up representation of incoming row

  IF (ii == 1) GO TO 60
  ii1 = ii - 1
  DO icol = 1,ii1
    k = index(icol)
    subt = lu(k,ii)
    j = icol + 1
    DO i = j,m
      k = index(i)
      lu(k,ii) = lu(k,ii) - subt*lu(k,icol)
    END DO
  END DO

!     find maximum entry

  60 pivot = acu
  kk = 0
  DO i = ii,m
    k = index(i)
    IF (ABS(lu(k,ii)) <= pivot) CYCLE
    pivot = ABS(lu(k,ii))
    kk = i
  END DO
  IF (kk == 0) GO TO 10

!     switch order

  isave = index(kk)
  index(kk) = index(ii)
  index(ii) = isave

!     put in columns of lu one at a time

  IF (ii == m) CYCLE
  j = ii + 1
  DO i = j,m
    k = index(i)
    lu(k,ii) = lu(k,ii)/lu(isave,ii)
  END DO
END DO
kkk = irow
RETURN

END SUBROUTINE update

SUBROUTINE calcpi (kkk, pi, tot, m)

!     this routine forward solves a linear system

IMPLICIT NONE
INTEGER, INTENT(IN)     :: m
INTEGER, INTENT(IN OUT) :: kkk
REAL (dp), INTENT(IN)   :: tot(20)
REAL (dp), INTENT(OUT)  :: pi(20)

! Local variables
INTEGER   :: i, ii, ii1, k, k1, k2, kkk1, m1
REAL (dp) :: zero = 0.0_dp

m1 = m-1

IF (m > 1) GO TO 10
k = index(m)
pi(m) = tot(k)/lu(k,m)
RETURN

10 pi(1:kkk) = zero

kkk = kkk + 1
k = index(kkk)
pi(kkk) = tot(k)
IF (kkk == m) GO TO 60
kkk1 = kkk + 1
DO ii = kkk1, m
  k = index(ii)
  pi(ii) = tot(k)
  ii1 = ii - 1
  pi(ii) = pi(ii) - DOT_PRODUCT( lu(k, kkk:ii1), pi(kkk:ii1) )
END DO

60 k = index(m)
pi(m) = pi(m)/lu(k,m)
DO ii = 1,m1
  k1 = m - ii
  k = index(k1)
  DO i = 1,ii
    k2 = m - i + 1
    pi(k1) = pi(k1) - lu(k,k2)*pi(k2)
  END DO
  pi(k1) = pi(k1)/lu(k,k1)
END DO

RETURN
END SUBROUTINE calcpi

END MODULE toms615


!| The `numeric_real` module provides constants and procedures related to floating-point number.
!
! The constants include minimum and maximum values of the 4- and 8-byte floating-point number types
! provided by the Fortran standard,
! parameters for specifying the result kind of the intrinsic procedures like `transfera, and the machine epsilons.
! 16-byte floating-point number type is not supported yet.
!
! The procedures include functions to convert a floating-point number to a string in a specified format.
!
module numeric_real
    use, intrinsic :: iso_fortran_env
    implicit none
    private
    public :: to_string

    !&<
    real(real32), public, parameter :: result_type_real32 = 0.0_real32
        !! A constant to represent 4-byte floating-point number.
        !! This constant is used to specify the result kind of the intrinsic functions.
    real(real64), public, parameter :: result_type_real64 = 0.0_real64
        !! A constant to represent 8-byte floating-point number.
        !! This constant is used to specify the result kind of the intrinsic functions.
    !&>

    real(real32), public, parameter :: Real32_Positive_Min = real(Z'00800000', real32)
        !! The positive minimum value of 4-byte floating-point number `≈+1.17549435E-38`
    real(real32), public, parameter :: Real32_Positive_Max = real(Z'7F7FFFFF', real32)
        !! The positive maximum value of 4-byte floating-point number `≈+3.40282347E+38`
    real(real32), public, parameter :: Real32_Negative_Min = real(Z'80800000', real32)
        !! The negative minimum value of 4-byte floating-point number `≈-1.17549435E-38`
    real(real32), public, parameter :: Real32_Negative_Max = real(Z'FF7FFFFF', real32)
        !! The negative maximum value of 4-byte floating-point number `≈-3.40282347E+38`

    real(real64), public, parameter :: Real64_Positive_Min = real(Z'0010000000000000', real64)
        !! The positive maximum value of 8-byte floating-point number `≈+1.7976931348623157E+308`
    real(real64), public, parameter :: Real64_Positive_Max = real(Z'7FEFFFFFFFFFFFFF', real64)
        !! The positive minimum value of 8-byte floating-point number `≈+2.2250738585072014E-308`
    real(real64), public, parameter :: Real64_Negative_Min = real(Z'8010000000000000', real64)
        !! The negative maximum value of 8-byte floating-point number `≈-1.7976931348623157E+308`
    real(real64), public, parameter :: Real64_Negative_Max = real(Z'FFEFFFFFFFFFFFFF', real64)
        !! The negative minimum value of 8-byte floating-point number `≈-2.2250738585072014E-308`

    real(real32), public, parameter :: Real32_Machine_Epsilon = epsilon(result_type_real32)
        !! The machine epsilon of 4-byte floating-point number `≈1.19209290E-07`
    real(real64), public, parameter :: Real64_Machine_Epsilon = epsilon(result_type_real64)
        !! The machine epsilon of 8-byte floating-point number `≈2.2204460492503131E-016`

    interface to_string
        procedure :: real32_to_string
        procedure :: real64_to_string
    end interface

    ! set the default format to recover the internal binary representation when reading decimal representation in ASCII format.
    character(*), private, parameter :: default_real32_format = '(e18.10E3)'
    character(*), private, parameter :: default_real64_format = '(e30.19E4)'

    integer(int32), private, parameter :: MaxLength_of_IOMessage = 255
    integer(int32), private, parameter :: MaxLength_of_Buffer = 255

contains
    !| Converts a 4-byte floating-point number to a string based on a format passed as an argument.
    ! When the format is not given, `'(e18.10E3)'` is used as the format
    ! to recover the internal binary representation when reading decimal representation in ASCII format.
    ! A zero-length string is returned when the convert is failed.
    function real32_to_string(r32, format) result(str)
        implicit none
        !&<
        real(real32), intent(in)            :: r32
            !! 4-byte floating-point number
        character(*), intent(in), optional  :: format
            !! format for string conversion
        !&>
        character(:), allocatable :: str

        character(MaxLength_of_Buffer) :: buffer
        integer :: IOStatus
        character(MaxLength_of_IOMessage) :: IOMessage

        if (present(format)) then
            write (buffer, format, iostat=IOStatus, iomsg=IOMessage) r32
        else
            write (buffer, default_real32_format, iostat=IOStatus, iomsg=IOMessage) r32
        end if
        if (IOStatus /= 0) then
            write (error_unit, '(A)') trim(IOMessage)
            buffer = "" ! returns a zero-length string
        end if

        str = trim(adjustl(buffer))
    end function real32_to_string

    !| Converts an 8-byte floating-point number to a string based on a format passed as an argument.
    ! When the format is not given, `'(e30.19E4)'` is used as the format
    ! to recover the internal binary representation when reading decimal representation in ASCII format.
    ! A zero-length string is returned when the convert is failed.
    function real64_to_string(r64, format) result(str)
        implicit none
        !&<
        real(real64), intent(in)            :: r64
            !! 8-byte floating-point number
        character(*), intent(in), optional  :: format
            !! format for string conversion
        !&>
        character(:), allocatable :: str

        character(MaxLength_of_Buffer) :: buffer
        integer :: IOStatus
        character(MaxLength_of_IOMessage) :: IOMessage

        if (present(format)) then
            write (buffer, format, iostat=IOStatus, iomsg=IOMessage) r64
        else
            write (buffer, default_real64_format, iostat=IOStatus, iomsg=IOMessage) r64
        end if
        if (IOStatus /= 0) then
            write (error_unit, '(A)') trim(IOMessage)
            buffer = "" ! returns a zero-length string
        end if

        str = trim(adjustl(buffer))
    end function real64_to_string
end module numeric_real


! To check impact of non-affine expressions as arguments of min and max

      subroutine minmax5

      if(4.gt.m.or.m.gt.10) stop
      if(5.gt.n.or.n.gt.11) stop

      i = min(m/2, n/2)
      j = max(m/2, n/2)

      print *, i, j

      end


program parameter_04
implicit none
integer, parameter :: l_knd = kind(.true.)
integer, parameter :: sp = selected_real_kind(6)
integer, parameter :: dp = selected_real_kind(14)
integer, parameter :: i32 = selected_int_kind(6)
integer, parameter :: i64 = selected_int_kind(12)
logical(l_knd) :: l
real(sp) :: r1
real(dp) :: r2
integer(i32) :: i1
integer(i64) :: i2
l = .true.
print *, l_knd, sp, dp, i32, i64
end program


program main
  ! Default
  implicit none

  ! Parameters
  integer(4),   parameter :: group_len = 4
  character(*), parameter :: data_file = 'data.txt'

  ! Variables
  integer(4) :: max_prod

  ! Arrays
  integer(4), dimension(20,20) :: array

  ! Read in data
  call read_data(array,data_file)

  ! Check sets of products
  call find_max_prod(array,max_prod)

  ! Write out result
  write(*,*) "Max product of lines of size ",group_len,": ",max_prod

contains

  subroutine read_data(array,data_file)
    ! Default
    implicit none

    ! Subroutine arguments
    integer(4), dimension(:,:), intent(out) :: array
    character(*),               intent(in)  :: data_file

    ! Local variables
    integer(4) :: i
    integer(4), dimension(2) :: arr_shape

    ! Find array size
    arr_shape = shape(array)

    ! Read in data
    open(11,file=data_file)
    do i=1,arr_shape(2)
       read(11,*) array(:,i)
    enddo
    close(11)

    return
  end subroutine read_data

  subroutine find_max_prod(array,max_prod)
    ! Default
    implicit none

    ! Subroutine arguments
    integer(4), dimension(:,:), intent(in)  :: array
    integer(4),                 intent(out) :: max_prod

    ! Local variables
    integer(4) :: i,j,prod,idx
    integer(4), dimension(2) :: arr_shape
    logical :: check_right,check_down,check_up

    ! Get array shape
    arr_shape = shape(array)
    max_prod  = 0

    ! Loop through array
    ! We only compute the product of numbers to the right, down, and diagonally
    !   down-right.
    ! For instance, the product(array(1:4,1)) == product(array(4:1:-1,1))
    ! We also loop over all initial positions, and determine which directions
    !   we can compute
    do j=1,arr_shape(2)
       if (j+group_len-1 > arr_shape(2)) then
          check_down = .false.
       else
          check_down = .true.
       endif

       if (j-group_len < 0) then
          check_up = .false.
       else
          check_up = .true.
       endif

       do i=1,arr_shape(1)
          if (i+group_len-1 > arr_shape(1)) then
             check_right = .false.
          else
             check_right = .true.
          endif

          ! Check 4 in a row
          if (check_right) then
             prod     = product(array(i:i+group_len-1,j))
             max_prod = max(prod,max_prod)
          endif

          ! Check 4 in a column
          if (check_down) then
             prod     = product(array(i,j:j+group_len-1))
             max_prod = max(prod,max_prod)
          endif

          ! Check 4 diagonally down-right
          if (check_right .and. check_down) then
             prod = 1
             do idx=0,group_len-1
                prod = prod*array(i+idx,j+idx)
             enddo
             max_prod = max(prod,max_prod)
          endif

          ! Check 4 diagonally up-right
          if (check_right .and. check_up) then
             prod = 1
             do idx=0,group_len-1
                prod = prod*array(i+idx,j-idx)
             enddo
             max_prod = max(prod,max_prod)
          endif
       enddo
    enddo

    return
  end subroutine find_max_prod

end program main


! /* ----------------------------------------------------------------------
!    fftMPI - library for computing 3d/2d FFTs in parallel
!    http://fftmpi.sandia.gov, Sandia National Laboratories
!    Steve Plimpton, sjplimp@sandia.gov
!
!    Copyright 2018 National Technology & Engineering Solutions of
!    Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
!    NTESS, the U.S. Government retains certain rights in this software.
!    This software is distributed under the modified Berkeley Software
!    Distribution (BSD) License.
!
!    See the README file in the top-level fftMPI directory.
! ------------------------------------------------------------------------- */

! Compute a forward/inverse complex FFT using fftMPI
!   change FFT size by editing 3 "FFT size" lines
!   run on any number of procs

! Run syntax:
! % simple_f90               # run in serial
! % mpirun -np 4 simple_f90  # run in parallel

! main program

program simple_f90

use iso_c_binding
use fft3d_wrap
implicit none

include 'mpif.h'

! data declarations

integer world,me,nprocs
integer i,j,k,n,precision,ierr
integer nfast_user,nmid_user,nslow_user
integer nfast,nmid,nslow
integer npfast,npmid,npslow,npmidslow,ipfast,ipmid,ipslow
integer ilo,ihi,jlo,jhi,klo,khi
integer fftsize,sendsize,recvsize
real*8 timestart,timestop,mydiff,alldiff
type(c_ptr) :: fft

#ifdef FFT_SINGLE
real(4), allocatable, target :: work(:)
#else
real(8), allocatable, target :: work(:)
#endif

! fft size

nfast_user = 128
nmid_user = 128
nslow_user = 128

! setup mpi

call MPI_Init(ierr)
world = MPI_COMM_WORLD

call MPI_Comm_size(world,nprocs,ierr)
call MPI_Comm_rank(world,me,ierr)

! instantiate fft

#ifdef FFT_SINGLE
precision = 1;
#else
precision = 2;
#endif

call fft3d_create(world,precision,fft)

! simple algorithm to factor nprocs into roughly cube roots

npfast = nprocs**(1.0/3.0)
do while (npfast < nprocs)
  if (mod(nprocs,npfast) == 0) exit
  npfast = npfast + 1
enddo

npmidslow = nprocs / npfast
npmid = sqrt(1.0*npmidslow)
do while (npmid < npmidslow)
  if (mod(npmidslow,npmid) == 0) exit
  npmid = npmid + 1
enddo
npslow = nprocs / npfast / npmid

! partition grid into npfast x npmid x npslow bricks

nfast = nfast_user
nmid = nmid_user
nslow = nslow_user

ipfast = mod(me,npfast)
ipmid = mod((me/npfast),npmid)
ipslow = me / (npfast*npmid)

ilo = 1.0*ipfast*nfast/npfast + 1
ihi = 1.0*(ipfast+1)*nfast/npfast
jlo = 1.0*ipmid*nmid/npmid + 1
jhi = 1.0*(ipmid+1)*nmid/npmid
klo = 1.0*ipslow*nslow/npslow + 1
khi = 1.0*(ipslow+1)*nslow/npslow

! setup fft, could replace with tune()

call fft3d_setup(fft,nfast,nmid,nslow, &
        ilo,ihi,jlo,jhi,klo,khi,ilo,ihi,jlo,jhi,klo,khi, &
        0,fftsize,sendsize,recvsize)

! tune fft, could replace with setup()

!call fft3d_tune(fft,nfast,nmid,nslow, &
!        ilo,ihi,jlo,jhi,klo,khi,ilo,ihi,jlo,jhi,klo,khi, &
!        0,fftsize,sendsize,recvsize,0,5,10.0d0,0)

! initialize each proc's local grid
! global initialization is specific to proc count

allocate(work(2*fftsize))

n = 1
do k = klo,khi
  do j = jlo,jhi
    do i = ilo,ihi
      work(n) = n
      n = n + 1
      work(n) = n
      n = n + 1
    enddo
  enddo
enddo

! perform 2 ffts

timestart = mpi_wtime()
call fft3d_compute(fft,c_loc(work),c_loc(work),1)        ! forward fft
call fft3d_compute(fft,c_loc(work),c_loc(work),-1)       ! inverse fft
timestop = mpi_wtime()

if (me == 0) then
  print *,"Two",nfast,"x",nmid,"x",nslow,"ffts on",nprocs, &
          "procs as ",npfast,"x",npmid,"x",npslow,"grid"
  print *,"CPU time =",timestop-timestart,"secs"
endif

! find largest difference between initial/final values
! should be near zero

n = 1
mydiff = 0.0
do k = klo,khi
  do j = jlo,jhi
    do i = ilo,ihi
      if (abs(work(n)-n) > mydiff) mydiff = abs(work(n)-n)
      n = n + 1
      if (abs(work(n)-n) > mydiff) mydiff = abs(work(n)-n)
      n = n + 1
    enddo
  enddo
enddo

call MPI_Allreduce(mydiff,alldiff,1,mpi_double,mpi_max,world,ierr)
if (me == 0) print *,"Max difference in initial/final values =",alldiff

! clean up

deallocate(work)
call fft3d_destroy(fft)
call mpi_finalize()

end program simple_f90


! ==================================================================================================================================
!
! # file created #
! 2020/10/25
!
! # reference #
! https://en.wikipedia.org/wiki/Xorshift
! https://ja.wikipedia.org/wiki/Xorshift
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt64.html
!
! ==================================================================================================================================

module mod_xorshift

    ! <module>s to import
    use, intrinsic :: iso_fortran_env

    ! require all variables to be explicitly declared
    implicit none

    ! accessibility of the <subroutine>s and <function>s in this <module>

    ! kind: function
    private :: concatenate2i32
    private :: ibsetFirst32bit

    ! kind: subroutine
    public  :: random_seed_xorshift32
    public  :: random_seed_xorshift32_default
    public  :: random_seed_xorshift64
    public  :: random_seed_xorshift64_default
    public  :: random_seed_xorshift128
    public  :: random_seed_xorshift128_default
    public  :: random_number_xorshift32
    public  :: random_number_xorshift64
    private :: random_number_xorshift128_i32
    private :: random_number_xorshift128_i64

    ! kind: interface
    public :: random_number_xorshift128

    ! <type>s for this <module>
    type, public :: typ_state_xorshift32
        integer(INT32), private :: y
    end type typ_state_xorshift32

    type, public :: typ_state_xorshift64
        integer(INT64), private :: x
    end type typ_state_xorshift64

    type, public :: typ_state_xorshift128
        integer(INT32), private :: x
        integer(INT32), private :: y
        integer(INT32), private :: z
        integer(INT32), private :: w
    end type typ_state_xorshift128

    ! <interface>s for this <module>
    interface random_number_xorshift128
        module procedure :: random_number_xorshift128_i32
        module procedure :: random_number_xorshift128_i64
    end interface random_number_xorshift128

    ! contained <subroutine>s and <function>s are below
    contains

    pure function concatenate2i32 (front, rear)

        ! arguments for this <function>
        integer(INT32), intent(in) :: front, rear

        ! return value of this <function>
        integer(INT64) :: concatenate2i32

        concatenate2i32 = ibsetFirst32bit(front)
        concatenate2i32 = ishftc(i= concatenate2i32, shift=32_INT32)
        concatenate2i32 = iand(i= concatenate2i32, j= ibsetFirst32bit(rear))

    end function concatenate2i32

    pure function ibsetFirst32bit (i)

        ! arguments for this <function>
        integer(INT32), intent(in) :: i

        ! return value of this <function>
        integer(INT64) :: ibsetFirst32bit

        ibsetFirst32bit = ior(i= Z'FFFFFFFF00000000', j= i)

    end function ibsetFirst32bit

    subroutine random_seed_xorshift32 (state, y)

        ! arguments for this <subroutine>
        type(typ_state_xorshift32), intent(inout) :: state
        integer(INT32),             intent(in)    :: y

        state%y = y

        return

    end subroutine random_seed_xorshift32

    subroutine random_seed_xorshift32_default (state)

        ! arguments for this <subroutine>
        type(typ_state_xorshift32), intent(inout) :: state

        call random_seed_xorshift32(state= state, y=-1831433054_INT32)
        return

    end subroutine random_seed_xorshift32_default

    subroutine random_seed_xorshift64 (state, x)

        ! arguments for this <subroutine>
        type(typ_state_xorshift64), intent(inout) :: state
        integer(INT64),             intent(in)    :: x

        state%x = x
        return

    end subroutine random_seed_xorshift64

    subroutine random_seed_xorshift64_default (state)

        ! arguments for this <subroutine>
        type(typ_state_xorshift64), intent(inout) :: state

        call random_seed_xorshift64(state= state, x= 88172645463325252_INT64)
        return

    end subroutine random_seed_xorshift64_default

    subroutine random_seed_xorshift128 (state, x, y, z, w)

        ! arguments for this <subroutine>
        type(typ_state_xorshift128), intent(inout) :: state
        integer(INT32),              intent(in)    :: x, y, z, w

        state%x = x
        state%y = y
        state%z = z
        state%w = w

        return

    end subroutine random_seed_xorshift128

    subroutine random_seed_xorshift128_default (state)

        ! arguments for this <subroutine>
        type(typ_state_xorshift128), intent(inout) :: state

        call random_seed_xorshift128(state= state, x= 123456789_INT32, y= 362436069_INT32, z= 521288629_INT32, w= 88675123_INT32)
        return

    end subroutine random_seed_xorshift128_default

    subroutine random_number_xorshift32 (state, harvest)

        ! arguments for this <subroutine>
        type(typ_state_xorshift32), intent(inout) :: state
        integer(INT32),             intent(out)   :: harvest

        state%y = ieor( state%y, shiftl(i= state%y, shift= 13_INT32) )
        state%y = ieor( state%y, shiftr(i= state%y, shift=  7_INT32) )
        state%y = ieor( state%y, shiftl(i= state%y, shift=  5_INT32) )
        harvest = state%y

        return

    end subroutine random_number_xorshift32

    subroutine random_number_xorshift64 (state, harvest)

        ! arguments for this <subroutine>
        type(typ_state_xorshift64), intent(inout) :: state
        integer(INT64),             intent(out)   :: harvest

        state%x = ieor( state%x, shiftl(i= state%x, shift= 13_INT64) )
        state%x = ieor( state%x, shiftr(i= state%x, shift=  7_INT64) )
        state%x = ieor( state%x, shiftl(i= state%x, shift= 17_INT64) )
        harvest = state%x

        return

    end subroutine random_number_xorshift64

    subroutine random_number_xorshift128_i32 (state, harvest)

        ! arguments for this <subroutine>
        type(typ_state_xorshift128), intent(inout) :: state
        integer(INT32),              intent(out)   :: harvest

        harvest = ieor(state%x, shiftl(i= state%x, shift= 11_INT32))
        state%x = state%y
        state%y = state%z
        state%z = state%w
        state%w = ieor( ieor(state%w, shiftr(i= state%w, shift= 19_INT32)) , ieor(harvest, shiftr(i= harvest, shift= 8_INT32)) )
        harvest = state%w

        return

    end subroutine random_number_xorshift128_i32

    subroutine random_number_xorshift128_i64 (state, harvest)

        ! arguments for this <subroutine>
        type(typ_state_xorshift128), intent(inout) :: state
        integer(INT64),              intent(out)   :: harvest

        ! variables for this <subroutine>
        integer(INT32) :: harvest_i32_1st
        integer(INT32) :: harvest_i32_2nd

        call random_number_xorshift128(state= state, harvest= harvest_i32_1st)
        call random_number_xorshift128(state= state, harvest= harvest_i32_2nd)

        harvest = concatenate2i32(front= harvest_i32_1st, rear= harvest_i32_2nd)

        return

    end subroutine random_number_xorshift128_i64

end module mod_xorshift

! ==================================================================================================================================
! EOF
! ==================================================================================================================================


! =====================================================================
! subroutine MKTP
!
! This subroutine constructs the angular kinetic energy terms that
! appear in the finite difference operators.
! ---------------------------------------------------------------------
      subroutine MKTP(nR,dP,R,TPD,TPO)
      implicit none

      integer :: nR
      double precision :: dP
      double precision :: R(nR)
      double precision :: TPD(nR)
      double precision :: TPO(nR)

      integer :: i

      do i = 1, nR
         TPD(i) = 1.0d0/(R(i)*dP)**2
         TPO(i) = 0.5d0/(R(i)*dP)**2
      enddo

      return
      end
! =====================================================================


           program demo_spacing
           implicit none
             integer, parameter :: sgl = selected_real_kind(p=6, r=37)
             integer, parameter :: dbl = selected_real_kind(p=13, r=200)

             write(*,*) spacing(1.0_sgl)      ! "1.1920929e-07"          on i686
             write(*,*) spacing(1.0_dbl)      ! "2.220446049250313e-016" on i686
           end program demo_spacing


          program demo_base
          use M_strings, only : base
          implicit none
          integer           :: ba,bd
          character(len=40) :: x,y

          print *,' BASE CONVERSION'
          write(*,'("Start   Base (2 to 36): ")',advance='no'); read *, bd
          write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba
          INFINITE: do
             write(*,'("Enter number in start base (0 to quit): ")',advance='no')
             read *, x
             if(x.eq.'0') exit INFINITE
             if(base(x,bd,y,ba))then
                  write(*,'("In base ",I2,": ",A20)')  ba, y
              else
                print *,'Error in decoding/encoding number.'
              endif
           enddo INFINITE

           end program demo_base


!! R706 level-2-expr
!    is [ [ level-2-expr ] add-op ] add-operand
!
!  level-2-expr is an add-op

a = +1
a = 3 - 1
a = 3 - 1 + 2
end


program heatco
! program untuk menghitung heat transfer pada konduktor
! menggunakan Shooting Method with Runge-Kutta (RK4)
! ndim      array dimension,
! imax      jumlah grid,
! x         variable bebas, x(i)
! y         variable terikat, y(i)
! z         turunan pertama dy/dx, z(i)
! y1, z1    boundary condition kiri
! y2, z2    boundary condition kanan
! by, bz    flag untuk boundary di kanan: 0.0 or 1.0
! za, zb    tebakan pertama dan kedua untuk nilai z
! dx        grid increment
! iter      maximum number of iteration (shoot)
! tol       convergence tolerance
! iw        intermediate results output flag: 0 None, 1 some, 2 all

            dimension x(9), y(9), z(9)
            data ndim, imax, iter, tol, iw / 9, 5, 3, 1.0e-6, 1 /
            data (x(i), i=1,5), dx / 0.0, 0.25, 0.50, 0.75, 1.00, 0.25 /
            data y(1), za, zb / 0.0, 7.5, 12.5 /
            data by, bz, y1, z1, y2, z2 / 1.0, 0.0, 0.0, 0.0, 100.0, 0.0 /
            write (6, 1000)
            call shoot(ndim, imax, x, y, z, by, bz, y1, z1, y2, z2, za, zb, dx, iter, tol, iw)
            if (iw.ne.1) write (6, 1010) (i, x(i), y(i), z(i), i=1, imax)
            stop
1000 format ('Shooting method'/' '/' i', 7x, 'x', 12x, 'y', 12x, 'z' /' ')
1010 format (i3, 3f13.6)
1020 format (' ')
     end

     subroutine shoot(ndim, imax, x, y, z, by, bz, y1, z1, y2, z2, za, zb, dx, iter, tol, iw)
! The shooting method
     dimension x(ndim), y(ndim), z(ndim)
     rhs = by*y2+bz*z2
     z(1) = za
     do it = 1, iter
         call rk2 (ndim, imax, x, y, z, dx, iw)
         if (iw.gt.1) write (6, 1000)
         if (iw.gt.0) write (6, 1010) (i, x(i), y(i), z(i), i=1,imax)
         if (iw.gt.0) write (6, 1000)
         if (it.eq.1) then
             rhs1 = by*y(imax) + bz*z(imax)
             z(1) = zb
         else
             rhs2 = by*y(imax) + bz*z(imax)
             if (abs(rhs2-rhs1).le.tol) return
             zb = z(1)
             slope = (rhs2-rhs1)/(zb-za)
             za = zb
             rhs1=rhs2
             z(1) = z(1) + (rhs-rhs2)/slope
         endif
     end do

     if (iter.gt.3) write (6, 1020) iter
     return

1000 format (' ')
1010 format (i3, 3f13.6)
1020 format (' '/' The solution failed to cenvergence, iter = ', i3)
     end

     subroutine rk2 (ndim, imax, x, y, z, dx, iw)
! Runge-Kutta fourth-order
     dimension x(ndim), y(ndim), z(ndim)
     do i = 2, imax
         dy1 = dx*z(i-1)
         dz1 = dx*f(x(i-1), y(i-1), z(i-1))
         dy2 = dx*(z(i-1)+dz1/2.0)
         dz2 = dx*f(x(i-1)+dx/2.0, y(i-1)+dy1/2.0, z(i-1)+dz1/2.0)
         dy3 = dx*(z(i-1)+dz2/2.0)
         dz3 = dx*f(x(i-1)+dx/2.0, y(i-1)+dy2/2.0, z(i-1)+dz2/2.0)
         dy4 = dx*(z(i-1)+dz3)
         dz4 = dx*f(x(i-1)+dx, y(i-1)+dy3, z(i-1)+dz3)

         y(i) = y(i-1) + (dy1 + 2.0*(dy2+dy3) + dy4)/6.0
         z(i) = z(i-1) + (dz1 + 2.0*(dz2+dz3) + dz4)/6.0

         if (iw.eq.2) write (6, 1000) i, dy1, dy2, dy3, dy4, y(i)
         if (iw.eq.2) write (6, 1000) i, dz1, dz2, dz3, dz4, z(i)
     end do
     return

1000 format (i3, 5f13.6)
     end

     function f(x, y, z)
! fungsi turunannya
! p = koefisien dari yp di ODE
! q = koefisien dari y di ODE
! nonhomogenious term -> fx
     data p, q, fx / 0.0, -16.0, 0.0 /
     f = fx-p*z-q*y
     return
     end

end program heatco


! { dg-do run }
! { dg-options "-ffrontend-optimize" }
! PR 80988 - implied do loops with diagonal elements
! were not written correctly
program main
  implicit none
  integer :: i,j,k
  integer, dimension(3,3) :: a
  integer, dimension(3,3,3) :: b
  character(len=40) :: line
  a = reshape([(((i*10+j),i=1,3),j=1,3)], shape(a))
  i = 2147483548
  write (unit=line,fmt='(10I3)') (a(i,i),i=1,3)
  if (line /= ' 11 22 33') STOP 1
  write (unit=line,fmt='(10I3)') (a(i+1,i+1),i=1,2)
  if (line /= ' 22 33') STOP 2
  do k=1,3
     do j=1,3
        do i=1,3
           b(i,j,k) = i*100 + j*10 + k
        end do
     end do
  end do
  i = -2147483548
  write (unit=line,fmt='(10I4)') ((b(i,j,i),i=1,3),j=1,3)
  if (line /= ' 111 212 313 121 222 323 131 232 333') STOP 3
end program main


    Program ztbrfs_example

!     ZTBRFS Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: ztbrfs, ztbtrs
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: diag = 'N', trans = 'N'
!     .. Local Scalars ..
      Integer :: i, ifail, info, j, kd, ldab, ldb, ldx, n, nrhs
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), b(:, :), work(:), x(:, :)
      Real (Kind=dp), Allocatable :: berr(:), ferr(:), rwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'ZTBRFS Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kd, nrhs
      ldab = kd + 1
      ldb = n
      ldx = n
      Allocate (ab(ldab,n), b(ldb,nrhs), work(2*n), x(ldx,n), berr(nrhs), &
        ferr(nrhs), rwork(n))

!     Read A and B from data file, and copy B to X

      Read (nin, *) uplo
      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(kd+1+i-j,j), j=i, min(n,i+kd))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-kd), i)
        End Do
      End If
      Read (nin, *)(b(i,1:nrhs), i=1, n)
      x(1:n, 1:nrhs) = b(1:n, 1:nrhs)

!     Compute solution in the array X
      Call ztbtrs(uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, info)

!     Compute backward errors and estimated bounds on the
!     forward errors

      Call ztbrfs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, &
        ferr, berr, work, rwork, info)

!     Print solution

      Write (nout, *)
      Flush (nout)

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, nrhs, x, &
        ldx, 'Bracketed', 'F7.4', 'Solution(s)', 'Integer', rlabs, 'Integer', &
        clabs, 80, 0, ifail)

      Write (nout, *)
      Write (nout, *) 'Backward errors (machine-dependent)'
      Write (nout, 100) berr(1:nrhs)
      Write (nout, *) 'Estimated forward error bounds (machine-dependent)'
      Write (nout, 100) ferr(1:nrhs)

100   Format ((5X,1P,4(E11.1,7X)))
    End Program


    Program zsptrf_example

!     ZSPTRF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_packed_comp
      Use lapack_interfaces, Only: zsptrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, j, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:)
      Integer, Allocatable :: ipiv(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZSPTRF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap(n*(n+1)/2), ipiv(n))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

!     Factorize A
      Call zsptrf(uplo, n, ap, ipiv, info)

      Write (nout, *)
      Flush (nout)

!     Print details of factorization

!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_packed_comp(uplo, 'Nonunit', n, ap, &
        'Bracketed', 'F7.4', 'Details of factorization', 'Integer', rlabs, &
        'Integer', clabs, 80, 0, ifail)

!     Print pivot indices

      Write (nout, *)
      Write (nout, *) 'IPIV'
      Write (nout, 100) ipiv(1:n)

      If (info/=0) Then
        Write (nout, *) 'The factor D is singular'
      End If

100   Format ((1X,I12,3I18))
    End Program


program somatorio3
implicit none

integer :: cont, k

cont = 0
do k = 1,10
    cont = cont+((k**2)+5d0*(k**3))
end do

write(*,*) cont

end program somatorio3


! Copyright 2019 NREL

! Licensed under the Apache License, Version 2.0 (the "License"); you may not use
! this file except in compliance with the License. You may obtain a copy of the
! License at http://www.apache.org/licenses/LICENSE-2.0

! Unless required by applicable law or agreed to in writing, software distributed
! under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
! CONDITIONS OF ANY KIND, either express or implied. See the License for the
! specific language governing permissions and limitations under the License.
! -------------------------------------------------------------------------------------------
! This module contains all the filters and related subroutines

! Filters:
!       LPFilter: Low-pass filter
!       SecLPFilter: Second order low-pass filter
!       HPFilter: High-pass filter
!       NotchFilter: Notch filter
!       NotchFilterSlopes: Notch Filter with descending slopes
!       PreFilterMeasuredSignals: Pre-filter signals during each run iteration

MODULE Filters
!...............................................................................................................................
    USE Constants
    IMPLICIT NONE

CONTAINS
!-------------------------------------------------------------------------------------------------------------------------------
    REAL(DbKi) FUNCTION LPFilter(InputSignal, DT, CornerFreq, FP, iStatus, reset, inst)
    ! Discrete time Low-Pass Filter of the form:
    !                               Continuous Time Form:   H(s) = CornerFreq/(1 + CornerFreq)
    !                               Discrete Time Form:     H(z) = (b1z + b0) / (a1*z + a0)
    !
        USE ROSCO_Types, ONLY : FilterParameters
        TYPE(FilterParameters),       INTENT(INOUT)       :: FP

        REAL(DbKi), INTENT(IN)         :: InputSignal
        REAL(DbKi), INTENT(IN)         :: DT                       ! time step [s]
        REAL(DbKi), INTENT(IN)         :: CornerFreq               ! corner frequency [rad/s]
        INTEGER(IntKi), INTENT(IN)      :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(IntKi), INTENT(INOUT)   :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)      :: reset                    ! Reset the filter to the input signal

            ! Initialization
        IF ((iStatus == 0) .OR. reset) THEN
            FP%lpf1_OutputSignalLast(inst) = InputSignal
            FP%lpf1_InputSignalLast(inst) = InputSignal
            FP%lpf1_a1(inst) = 2 + CornerFreq*DT
            FP%lpf1_a0(inst) = CornerFreq*DT - 2
            FP%lpf1_b1(inst) = CornerFreq*DT
            FP%lpf1_b0(inst) = CornerFreq*DT
        ENDIF

        ! Define coefficients

        ! Filter
        LPFilter = 1.0/FP%lpf1_a1(inst) * (-FP%lpf1_a0(inst)*FP%lpf1_OutputSignalLast(inst) + FP%lpf1_b1(inst)*InputSignal + FP%lpf1_b0(inst)*FP%lpf1_InputSignalLast(inst))

        ! Save signals for next time step
        FP%lpf1_InputSignalLast(inst)  = InputSignal
        FP%lpf1_OutputSignalLast(inst) = LPFilter
        inst = inst + 1

    END FUNCTION LPFilter
!-------------------------------------------------------------------------------------------------------------------------------
    REAL(DbKi) FUNCTION SecLPFilter(InputSignal, DT, CornerFreq, Damp, FP, iStatus, reset, inst)
    ! Discrete time Low-Pass Filter of the form:
    !                               Continuous Time Form:   H(s) = CornerFreq^2/(s^2 + 2*CornerFreq*Damp*s + CornerFreq^2)
    !                               Discrete Time From:     H(z) = (b2*z^2 + b1*z + b0) / (a2*z^2 + a1*z + a0)
        USE ROSCO_Types, ONLY : FilterParameters
        TYPE(FilterParameters),       INTENT(INOUT)       :: FP
        REAL(DbKi), INTENT(IN)         :: InputSignal
        REAL(DbKi), INTENT(IN)         :: DT                       ! time step [s]
        REAL(DbKi), INTENT(IN)         :: CornerFreq               ! corner frequency [rad/s]
        REAL(DbKi), INTENT(IN)         :: Damp                     ! Dampening constant
        INTEGER(IntKi), INTENT(IN)      :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(IntKi), INTENT(INOUT)   :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)      :: reset                    ! Reset the filter to the input signal

        ! Initialization
        IF ((iStatus == 0) .OR. reset )  THEN
            FP%lpf2_OutputSignalLast1(inst)  = InputSignal
            FP%lpf2_OutputSignalLast2(inst)  = InputSignal
            FP%lpf2_InputSignalLast1(inst)   = InputSignal
            FP%lpf2_InputSignalLast2(inst)   = InputSignal

            ! Coefficients
            FP%lpf2_a2(inst) = DT**2.0*CornerFreq**2.0 + 4.0 + 4.0*Damp*CornerFreq*DT
            FP%lpf2_a1(inst) = 2.0*DT**2.0*CornerFreq**2.0 - 8.0
            FP%lpf2_a0(inst) = DT**2.0*CornerFreq**2.0 + 4.0 - 4.0*Damp*CornerFreq*DT
            FP%lpf2_b2(inst) = DT**2.0*CornerFreq**2.0
            FP%lpf2_b1(inst) = 2.0*DT**2.0*CornerFreq**2.0
            FP%lpf2_b0(inst) = DT**2.0*CornerFreq**2.0
        ENDIF

        ! Filter
        SecLPFilter = 1.0/FP%lpf2_a2(inst) * (FP%lpf2_b2(inst)*InputSignal + FP%lpf2_b1(inst)*FP%lpf2_InputSignalLast1(inst) + FP%lpf2_b0(inst)*FP%lpf2_InputSignalLast2(inst) - FP%lpf2_a1(inst)*FP%lpf2_OutputSignalLast1(inst) - FP%lpf2_a0(inst)*FP%lpf2_OutputSignalLast2(inst))

        ! Save signals for next time step
        FP%lpf2_InputSignalLast2(inst)   = FP%lpf2_InputSignalLast1(inst)
        FP%lpf2_InputSignalLast1(inst)   = InputSignal
        FP%lpf2_OutputSignalLast2(inst)  = FP%lpf2_OutputSignalLast1(inst)
        FP%lpf2_OutputSignalLast1(inst)  = SecLPFilter

        inst = inst + 1

    END FUNCTION SecLPFilter
!-------------------------------------------------------------------------------------------------------------------------------
    REAL(DbKi) FUNCTION HPFilter( InputSignal, DT, CornerFreq, FP, iStatus, reset, inst)
    ! Discrete time High-Pass Filter
        USE ROSCO_Types, ONLY : FilterParameters
        TYPE(FilterParameters),       INTENT(INOUT)       :: FP

        REAL(DbKi), INTENT(IN)     :: InputSignal
        REAL(DbKi), INTENT(IN)     :: DT                       ! time step [s]
        REAL(DbKi), INTENT(IN)     :: CornerFreq               ! corner frequency [rad/s]
        INTEGER(IntKi), INTENT(IN)     :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(IntKi), INTENT(INOUT)  :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)  :: reset                    ! Reset the filter to the input signal
        ! Local
        REAL(DbKi)                 :: K                        ! Constant gain

        ! Initialization
        IF ((iStatus == 0) .OR. reset)  THEN
            FP%hpf_OutputSignalLast(inst) = InputSignal
            FP%hpf_InputSignalLast(inst) = InputSignal
        ENDIF
        K = 2.0 / DT

        ! Body
        HPFilter = K/(CornerFreq + K)*InputSignal - K/(CornerFreq + K)*FP%hpf_InputSignalLast(inst) - (CornerFreq - K)/(CornerFreq + K)*FP%hpf_OutputSignalLast(inst)

        ! Save signals for next time step
        FP%HPF_InputSignalLast(inst)   = InputSignal
        FP%HPF_OutputSignalLast(inst)  = HPFilter
        inst = inst + 1

    END FUNCTION HPFilter
!-------------------------------------------------------------------------------------------------------------------------------
    REAL(DbKi) FUNCTION NotchFilterSlopes(InputSignal, DT, CornerFreq, Damp, FP, iStatus, reset, inst)
    ! Discrete time inverted Notch Filter with descending slopes, G = CornerFreq*s/(Damp*s^2+CornerFreq*s+Damp*CornerFreq^2)
        USE ROSCO_Types, ONLY : FilterParameters
        TYPE(FilterParameters),       INTENT(INOUT)       :: FP

        REAL(DbKi), INTENT(IN)     :: InputSignal
        REAL(DbKi), INTENT(IN)     :: DT                       ! time step [s]
        REAL(DbKi), INTENT(IN)     :: CornerFreq               ! corner frequency [rad/s]
        REAL(DbKi), INTENT(IN)     :: Damp                     ! Dampening constant
        INTEGER(IntKi), INTENT(IN)     :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(IntKi), INTENT(INOUT)  :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)  :: reset                    ! Reset the filter to the input signal

        ! Initialization
        IF ((iStatus == 0) .OR. reset) THEN
            FP%nfs_OutputSignalLast1(inst)  = InputSignal
            FP%nfs_OutputSignalLast2(inst)  = InputSignal
            FP%nfs_InputSignalLast1(inst)   = InputSignal
            FP%nfs_InputSignalLast2(inst)   = InputSignal
            FP%nfs_b2(inst) = 2.0 * DT * CornerFreq
            FP%nfs_b0(inst) = -FP%nfs_b2(inst)
            FP%nfs_a2(inst) = Damp*DT**2.0*CornerFreq**2.0 + 2.0*DT*CornerFreq + 4.0*Damp
            FP%nfs_a1(inst) = 2.0*Damp*DT**2.0*CornerFreq**2.0 - 8.0*Damp
            FP%nfs_a0(inst) = Damp*DT**2.0*CornerFreq**2.0 - 2*DT*CornerFreq + 4.0*Damp
        ENDIF

        NotchFilterSlopes = 1.0/FP%nfs_a2(inst) * (FP%nfs_b2(inst)*InputSignal + FP%nfs_b0(inst)*FP%nfs_InputSignalLast1(inst) &
                            - FP%nfs_a1(inst)*FP%nfs_OutputSignalLast1(inst)  - FP%nfs_a0(inst)*FP%nfs_OutputSignalLast2(inst))

        ! Save signals for next time step
        FP%nfs_InputSignalLast2(inst)   = FP%nfs_InputSignalLast1(inst)
        FP%nfs_InputSignalLast1(inst)   = InputSignal          !Save input signal for next time step
        FP%nfs_OutputSignalLast2(inst)  = FP%nfs_OutputSignalLast1(inst)      !Save input signal for next time step
        FP%nfs_OutputSignalLast1(inst)  = NotchFilterSlopes
        inst = inst + 1

    END FUNCTION NotchFilterSlopes
!-------------------------------------------------------------------------------------------------------------------------------
    REAL(DbKi) FUNCTION NotchFilter(InputSignal, DT, omega, betaNum, betaDen, FP, iStatus, reset, inst)
    ! Discrete time Notch Filter
    !                               Continuous Time Form: G(s) = (s^2 + 2*omega*betaNum*s + omega^2)/(s^2 + 2*omega*betaDen*s + omega^2)
    !                               Discrete Time Form:   H(z) = (b2*z^2 +b1*z^2 + b0*z)/((z^2 +a1*z^2 + a0*z))
        USE ROSCO_Types, ONLY : FilterParameters
        TYPE(FilterParameters),       INTENT(INOUT)       :: FP

        REAL(DbKi), INTENT(IN)     :: InputSignal
        REAL(DbKi), INTENT(IN)     :: DT                       ! time step [s]
        REAL(DbKi), INTENT(IN)     :: omega                    ! corner frequency [rad/s]
        REAL(DbKi), INTENT(IN)     :: betaNum                  ! Dampening constant in numerator of filter transfer function
        REAL(DbKi), INTENT(IN)     :: betaDen                  ! Dampening constant in denominator of filter transfer function
        INTEGER(IntKi), INTENT(IN)     :: iStatus                  ! A status flag set by the simulation as follows: 0 if this is the first call, 1 for all subsequent time steps, -1 if this is the final call at the end of the simulation.
        INTEGER(IntKi), INTENT(INOUT)  :: inst                     ! Instance number. Every instance of this function needs to have an unique instance number to ensure instances don't influence each other.
        LOGICAL(4), INTENT(IN)  :: reset                    ! Reset the filter to the input signal
        ! Local
        REAL(DbKi)                 :: K                        ! Constant gain

        ! Initialization
        K = 2.0/DT
        IF ((iStatus == 0) .OR. reset) THEN
            FP%nf_OutputSignalLast1(inst)  = InputSignal
            FP%nf_OutputSignalLast2(inst)  = InputSignal
            FP%nf_InputSignalLast1(inst)   = InputSignal
            FP%nf_InputSignalLast2(inst)   = InputSignal
            FP%nf_b2(inst) = (K**2.0 + 2.0*omega*BetaNum*K + omega**2.0)/(K**2.0 + 2.0*omega*BetaDen*K + omega**2.0)
            FP%nf_b1(inst) = (2.0*omega**2.0 - 2.0*K**2.0)  / (K**2.0 + 2.0*omega*BetaDen*K + omega**2.0);
            FP%nf_b0(inst) = (K**2.0 - 2.0*omega*BetaNum*K + omega**2.0) / (K**2.0 + 2.0*omega*BetaDen*K + omega**2.0)
            FP%nf_a1(inst) = (2.0*omega**2.0 - 2.0*K**2.0)  / (K**2.0 + 2.0*omega*BetaDen*K + omega**2.0)
            FP%nf_a0(inst) = (K**2.0 - 2.0*omega*BetaDen*K + omega**2.0)/ (K**2.0 + 2.0*omega*BetaDen*K + omega**2.0)
        ENDIF

        ! Body
        NotchFilter = FP%nf_b2(inst)*InputSignal + FP%nf_b1(inst)*FP%nf_InputSignalLast1(inst) + FP%nf_b0(inst)*FP%nf_InputSignalLast2(inst) - FP%nf_a1(inst)*FP%nf_OutputSignalLast1(inst) - FP%nf_a0(inst)*FP%nf_OutputSignalLast2(inst)

        ! Save signals for next time step
        FP%nf_InputSignalLast2(inst)   = FP%nf_InputSignalLast1(inst)
        FP%nf_InputSignalLast1(inst)   = InputSignal                  ! Save input signal for next time step
        FP%nf_OutputSignalLast2(inst)  = FP%nf_OutputSignalLast1(inst)      ! Save input signal for next time step
        FP%nf_OutputSignalLast1(inst)  = NotchFilter
        inst = inst + 1

    END FUNCTION NotchFilter
!-------------------------------------------------------------------------------------------------------------------------------
    SUBROUTINE PreFilterMeasuredSignals(CntrPar, LocalVar, DebugVar, objInst, ErrVar)
    ! Prefilter measured wind turbine signals to separate the filtering from the actual control actions

        USE ROSCO_Types, ONLY : ControlParameters, LocalVariables, DebugVariables, ObjectInstances, ErrorVariables

        TYPE(ControlParameters), INTENT(INOUT)      :: CntrPar
        TYPE(LocalVariables),    INTENT(INOUT)      :: LocalVar
        TYPE(DebugVariables),    INTENT(INOUT)      :: DebugVar
        TYPE(ObjectInstances),   INTENT(INOUT)      :: objInst
        TYPE(ErrorVariables),   INTENT(INOUT)       :: ErrVar
        INTEGER(IntKi) :: K  ! Integer used to loop through turbine blades

        ! If there's an error, don't even try to run
        IF (ErrVar%aviFAIL < 0) THEN
            RETURN
        ENDIF
        ! Filter the HSS (generator) and LSS (rotor) speed measurement:
        ! Apply Low-Pass Filter (choice between first- and second-order low-pass filter)
        IF (CntrPar%F_LPFType == 1) THEN
            LocalVar%GenSpeedF = LPFilter(LocalVar%GenSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instLPF)
            LocalVar%RotSpeedF = LPFilter(LocalVar%RotSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instLPF)
        ELSEIF (CntrPar%F_LPFType == 2) THEN
            LocalVar%GenSpeedF = SecLPFilter(LocalVar%GenSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, CntrPar%F_LPFDamping, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instSecLPF) ! Second-order low-pass filter on generator speed
            LocalVar%RotSpeedF = SecLPFilter(LocalVar%RotSpeed, LocalVar%DT, CntrPar%F_LPFCornerFreq, CntrPar%F_LPFDamping, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instSecLPF) ! Second-order low-pass filter on generator speed
        ENDIF
        ! Apply Notch Fitler
        IF (CntrPar%F_NotchType == 1 .OR. CntrPar%F_NotchType == 3) THEN
            LocalVar%GenSpeedF = NotchFilter(LocalVar%GenSpeedF, LocalVar%DT, CntrPar%F_NotchCornerFreq, CntrPar%F_NotchBetaNumDen(1), CntrPar%F_NotchBetaNumDen(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instNotch)
        ENDIF

        ! Filtering the tower fore-aft acceleration signal
        IF (CntrPar%Fl_Mode > 0) THEN
            ! Force to start at 0
            LocalVar%NacIMU_FA_AccF = SecLPFilter(LocalVar%NacIMU_FA_Acc, LocalVar%DT, CntrPar%F_FlCornerFreq(1), CntrPar%F_FlCornerFreq(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instSecLPF) ! Fixed Damping
            LocalVar%FA_AccF = SecLPFilter(LocalVar%FA_Acc, LocalVar%DT, CntrPar%F_FlCornerFreq(1), CntrPar%F_FlCornerFreq(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instSecLPF) ! Fixed Damping
            LocalVar%NacIMU_FA_AccF = HPFilter(LocalVar%NacIMU_FA_AccF, LocalVar%DT, CntrPar%F_FlHighPassFreq, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instHPF)
            LocalVar%FA_AccF = HPFilter(LocalVar%FA_AccF, LocalVar%DT, CntrPar%F_FlHighPassFreq, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instHPF)

            IF (CntrPar%F_NotchType >= 2) THEN
                LocalVar%NACIMU_FA_AccF = NotchFilter(LocalVar%NacIMU_FA_AccF, LocalVar%DT, CntrPar%F_NotchCornerFreq, CntrPar%F_NotchBetaNumDen(1), CntrPar%F_NotchBetaNumDen(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instNotch) ! Fixed Damping
                LocalVar%FA_AccF = NotchFilter(LocalVar%FA_AccF, LocalVar%DT, CntrPar%F_NotchCornerFreq, CntrPar%F_NotchBetaNumDen(1), CntrPar%F_NotchBetaNumDen(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instNotch) ! Fixed Damping
            ENDIF
        ENDIF
        LocalVar%FA_AccHPF = HPFilter(LocalVar%FA_Acc, LocalVar%DT, CntrPar%FA_HPFCornerFreq, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instHPF)

        ! Filter Wind Speed Estimator Signal
        LocalVar%We_Vw_F = LPFilter(LocalVar%WE_Vw, LocalVar%DT,CntrPar%F_WECornerFreq, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instLPF) ! 30 second time constant

        ! Blade root bending moment for IPC
        DO K = 1,LocalVar%NumBl
            IF ((CntrPar%IPC_ControlMode > 0) .OR. (CntrPar%Flp_Mode == 3)) THEN
                LocalVar%RootMOOPF(K) = NotchFilterSlopes(LocalVar%rootMOOP(K), LocalVar%DT, LocalVar%RotSpeedF, 0.7_DbKi, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instNotchSlopes)
            ELSEIF ( CntrPar%Flp_Mode == 2 ) THEN
                ! Filter Blade root bending moments
                LocalVar%RootMOOPF(K) = SecLPFilter(LocalVar%rootMOOP(K),LocalVar%DT, CntrPar%F_FlpCornerFreq(1), CntrPar%F_FlpCornerFreq(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart,objInst%instSecLPF)
                LocalVar%RootMOOPF(K) = NotchFilter(LocalVar%RootMOOPF(K), LocalVar%DT, CntrPar%F_NotchCornerFreq, CntrPar%F_NotchBetaNumDen(1), CntrPar%F_NotchBetaNumDen(2), LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instNotch)
                LocalVar%RootMOOPF(K) = HPFilter(LocalVar%rootMOOPF(K),LocalVar%DT, 0.1_DbKi, LocalVar%FP, LocalVar%iStatus, LocalVar%restart,objInst%instHPF)
            ELSE
                LocalVar%RootMOOPF(K) = LocalVar%rootMOOP(K)
            ENDIF
        END DO

        ! Control commands (used by WSE, mostly)
        LocalVar%VS_LastGenTrqF = SecLPFilter(LocalVar%VS_LastGenTrq, LocalVar%DT, CntrPar%F_LPFCornerFreq, 0.7_DbKi, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instSecLPF)
        LocalVar%PC_PitComTF    = SecLPFilter(LocalVar%PC_PitComT, LocalVar%DT, CntrPar%F_LPFCornerFreq*0.25, 0.7_DbKi, LocalVar%FP, LocalVar%iStatus, LocalVar%restart, objInst%instSecLPF)

        ! Debug Variables
        DebugVar%GenSpeedF = LocalVar%GenSpeedF
        DebugVar%RotSpeedF = LocalVar%RotSpeedF
        DebugVar%NacIMU_FA_AccF = LocalVar%NacIMU_FA_AccF
        DebugVar%FA_AccF = LocalVar%FA_AccF
    END SUBROUTINE PreFilterMeasuredSignals
    END MODULE Filters


SUBROUTINE beta_interp (mjd, r_sat, v_sat, fti, ft0, NPint, beta)

! ----------------------------------------------------------------------
! SUBROUTINE: beta_interp.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the beta angle (Sun elevation angle w.r.t. orbtial plane) at a previous of future epoch
!  Orbit numerical interpolation is applied for the computing the orbit point at the input epoch
!  Planetary/Lunar DE Ephemeris data processing is performed for the Sun position computation at the input epoch
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:		Modified Julian Day number in GPS Time (including the fraction of the day)
! - r_sat: 		Satellite position vector (m) in ITRF
! - v_sat: 		Satellite velocity vector (m/sec) in ITRF
! - fti:		Orbit angle (degrees) at the input epoch ti
! - ft0:		Orbit angle (degrees) at the required epoch t0 (forward or backward)
! - NPint:		Number of data points to be used for numerical interpolation (defines the order of the polynomial)
!
! Output arguments:
! - beta:		Sun elevation angle with respect to the orbital plane at the epoch t0 (degrees)
! ----------------------------------------------------------------------
! Note 1:
! - kepler:		Kepler elements array (6)
!   a:       	semi-major axis  (m)
!   e:      	eccentricity
!   i:      	inclination (degrees)
!   Omega:  	right ascension of the ascending node (degrees)
!   omega:  	argument of perigee (degrees)
!   E:      	eccentric anomaly (degrees)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou
! Cooperative Research Centre for Spatial Information, Australia
! Created: 27 June 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_planets
      USE mdl_eop
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd, r_sat(3), v_sat(3)
      REAL (KIND = prec_q), INTENT(IN) :: fti, ft0
      INTEGER (KIND = prec_int8), INTENT(IN) :: NPint
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: beta
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: ti, t0, frate
      REAL (KIND = prec_q) :: mjd_t0 , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC
      INTEGER (KIND = prec_int8) :: Norb, i, sz1, sz2
      REAL (KIND = prec_q) :: GM, kepler_i(6), kepler_0(6), a_semiaxis, ec, n_motion, Ei_rad, Mi_rad, Mo_rad, Mo_deg, Eo_deg
      REAL (KIND = prec_q) :: dt
      REAL (KIND = prec_q), DIMENSION(3) :: rsat_t0, vsat_t0
      REAL (KIND = prec_d) :: r_TRS(3), v_TRS(3), r_CRS(3), v_CRS(3), v_CRS_1(3), v_CRS_2(3)
	  DOUBLE PRECISION EOP_cr(7)
      DOUBLE PRECISION CRS2TRS(3,3), TRS2CRS(3,3), d_CRS2TRS(3,3), d_TRS2CRS(3,3)
! ----------------------------------------------------------------------
! Planetary/Lunar Epehemeris data processing (lib3_planets): Variables declaration
      DOUBLE PRECISION  JD_TT, R_eph(6)
      INTEGER  NTARG, NCTR
!      CHARACTER (LEN=100) :: fname_header, fname_data, fname_out
      REAL (KIND = prec_d) :: rsun_t0(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Current epoch in seconds since start of the day (0h)
ti = (mjd - INT(mjd)) * 86400.D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Computation of the forward/backward epoch t0
! ----------------------------------------------------------------------
! Orbital angle rate (in degrees/sec)
frate = sqrt( (v_sat(1)**2+v_sat(2)**2+v_sat(3)**2) / (r_sat(1)**2+r_sat(2)**2+r_sat(3)**2) ) * (180.0D0 / PI_global)

t0 = ti + (ft0 - fti)/ frate
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time difference (in seconds) since current epoch
dt = t0 - ti
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time System transformation: GPS to TT
! ----------------------------------------------------------------------
! MJD at the epoch t0
mjd_t0 = mjd + dt/86400.0D0

! Time transformation at epoch t0
CALL time_GPS (mjd_t0 , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Sun position vector at reference epoch t0
! ----------------------------------------------------------------------
! Center celestial body : Earth
      NCTR = 3
! Target celestial body : Sun
      NTARG = 11

! JD at the epoch t0 (in TT)
      JD_TT = mjd_TT + 2400000.5D0

! Sun state vector in ICRF (in KM)
      CALL  PLEPH ( JD_TT, NTARG, NCTR, R_eph )

	  ! Km to meters
	  rsun_t0(1) = R_eph(1) * 1000D0
	  rsun_t0(2) = R_eph(2) * 1000D0
	  rsun_t0(3) = R_eph(3) * 1000D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Orbit interpolation for the epoch t0 (ITRF)
Call interp_orb3 (mjd_GPS, NPint, rsat_t0, vsat_t0)
! ----------------------------------------------------------------------
r_TRS = rsat_t0
v_TRS = vsat_t0

! ----------------------------------------------------------------------
! Tranformation: ITRF to ICRF
CALL EOP (mjd_TT, EOP_cr, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)

! r_CRS = TRS2CRS * r_TRS
CALL matrix_Rr (TRS2CRS, r_TRS , r_CRS)

! v_CRS = TRS2CRS * v_TRS + d_TRS2CRS * r_TRS
CALL matrix_Rr (TRS2CRS, v_TRS , v_CRS_1)
CALL matrix_Rr (d_TRS2CRS, r_TRS , v_CRS_2)
v_CRS = v_CRS_1 + v_CRS_2
! ----------------------------------------------------------------------
rsat_t0 = r_CRS
vsat_t0 = v_CRS

! ----------------------------------------------------------------------
! Beta angle (Sun elevation angle) at epoch t0 (in degrees)
CALL beta_angle (rsat_t0, vsat_t0, rsun_t0, beta)
! ----------------------------------------------------------------------

if (1<0) then
PRINT *, "rsat   ", r_sat
PRINT *, "vsat   ", v_sat

PRINT *, "fti,ft0,frate", fti, ft0, frate
PRINT *, "ti, t0, dt", ti, t0, dt
PRINT *, "frate ", frate

PRINT *, "beta", beta
PRINT *, "rsun_t0", rsun_t0
PRINT *, "rsat_t0", rsat_t0
PRINT *, "vsat_t0", vsat_t0

PRINT *, "dt    ", dt
PRINT *, "t0    ", t0
PRINT *, "ti    ", ti
PRINT *, "mjd    ", mjd
PRINT *, "mjd_t0 ", mjd_t0
PRINT *, "mjd_GPS", mjd_GPS

end if

END


       subroutine core
*
*
*     calculate core parameters: rc,vc,nc,smc,roc
*     -------------------------------------------
*
*
      include 'common.h'
*
      real*8 sx,v2x
*
      integer i,n,nx,im,ncut
*
*
      n = nt
*
*       determination number of stars to calculate the central parameters
*
      ncut = 0.01*n
      if(ncor.le.ncut) then
        nx = ncor
      else
        if(ncut.gt.nmin) then
          nx = ncut
        else
          nx = nmin
        endif
      endif
*
*
*       determination of the central parameters
*
      sx = 0.0d0
      v2x = 0.0d0
*
      do 10 i=1,nx
         im = iname(i)
         sx = sx + body(im)
   10    v2x = v2x + body(im)*(vr(im)*vr(im) + vt(im)*vt(im))
*
      v2x = v2x/sx
      roc = 3.0d0*sx/(4.0d0*pi*r(nx)**3)
      rc = 3.0d0*v2x/(4.0d0*pi*roc)
      vc = sqrt(v2x)
      rc = sqrt(rc)
*
      i = 0
      sx = 0.0d0
*
   20 continue
      i = i + 1
      im = iname(i)
      sx = sx + body(im)
      if(rc.gt.r(i)) go to 20
      smc = sx - body(im)
      nc = i-1
*
*
      return
*
      end
*
*
*
*


	SUBROUTINE GCONLM ( mproj, msppj, np, xl, yl, a1, reflon, a3,
     +			    concon, dlat, dlon, iret )
C************************************************************************
C* GCONLM								*
C* 									*
C* This subroutine transforms a point from linear intermediate		*
C* coordinates to latitude-longitude coordinates when conical		*
C* projection has been set up.						*
C*									*
C* GCONLM  ( MPROJ, MSPPJ, NP, XL, YL, A1, REFLON, A3, CONCON,		*
C*           DLAT,  DLON,  IRET )					*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Map class			*
C*	MSPPJ		INTEGER		Map projection			*
C*	NP		INTEGER		Number of points		*
C*	XL (NP)		REAL		X linear coordinates		*
C*	YL (NP)		REAL		Y linear coordinates		*
C*	A1		REAL		Not used			*
C*	REFLON		REAL		Longitude rotation angle	*
C*	A3		REAL		Not used			*
C*	CONCON		REAL		Cone constant			*
C* 									*
C* Output parameters:							*
C* 	DLAT (NP)	REAL		Latitudes			*
C* 	DLON (NP)	REAL		Longitudes			*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 7/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* K. Brill/GSC          1/90   Replaced PRNLON with PRNLNR		*
C* K. Brill/NMC		 4/91	Check for ATAN2 ( 0, 0 )		*
C* K. Brill/EMC		 3/96	Changes for general rotation		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL    	xl (*), yl (*), dlat (*), dlon (*)
C*
	INCLUDE		'ERMISS.FNC'
C-------------------------------------------------------------------------
	iret   = NORMAL
	rconcn = 1. / concon
C
C*	Loop through all the points.
C
	DO  i = 1, np
C
C*	  Check for missing data.
C
	  IF  ( ( ERMISS ( xl (i) ) ) .or. ( ERMISS ( yl (i) ) ) )  THEN
	    dlat (i) = RMISSD
	    dlon (i) = RMISSD
	  ELSE
C*
	    rlat = RMISSD
	    rlon = RMISSD
C
C*	    Compute radius of latitude circle.
C
	    r = SQRT ( xl(i)**2 + yl(i)**2 )
C
C*	    Computation depends on pole of projection.
C
	    IF ( mproj .eq. MPCNOR ) THEN
		ra = r ** rconcn
		rlat = 2.0 * ( PI4TH - ATAN ( ra ) )
		IF ( yl(i) .ne. 0.0 .or. xl(i) .ne. 0.0 ) THEN
		    al = ATAN2 ( xl(i), -yl(i) )
		    rlon = al * rconcn
		ELSE
		    rlon = 0.0
		END IF
C*
	      ELSE IF ( mproj .eq. MPCSOU )  THEN
		ra = r ** rconcn
		rlat = (-2.0) * ( PI4TH - ATAN ( ra ) )
		IF  ( yl(i) .ne. 0.0 .or. xl(i) .ne. 0.0 ) THEN
		    al = ATAN2 ( xl(i), yl(i) )
		    rlon = al * rconcn
		ELSE
		    rlon = 0.0
		END IF
	    END IF
C
C*	    Convert radians to degrees.
C
	    IF  ( ( ERMISS ( rlat ) ) .or. ( ERMISS ( rlon ) ) )  THEN
		dlat (i) = RMISSD
		dlon (i) = RMISSD
	      ELSE
		dlat (i) = rlat * RTD
		dlon (i) = ( rlon + reflon ) * RTD
	    END IF
	  END IF
	END DO
C*
	RETURN
	END


program main
  implicit none
  real(8),parameter :: pi = 4d0*atan(1d0)
  complex(8),parameter :: zi = (0d0, 1d0)
  real(8),parameter :: ev = 1d0/27.2114d0, fs = 1d0/0.024189d0
  integer,parameter :: nt = 10400, nw = 512
  real(8),parameter :: ww_i = 0.1d0/ev, ww_f = 30d0/ev, dw = (ww_f-ww_i)/nw
  real(8),parameter :: tpulse = 20d0/fs
  real(8) :: tt(0:nt),Act(0:nt),jtz(0:nt),jtz_intra(0:nt),jtz_inter(0:nt),Et(0:nt)
  complex(8) :: zEw, zjw, zjw_intra, zjw_inter, zfact
  real(8) :: window(0:nt)
  real(8) :: dt, ww, xx
  integer :: iw, it

  open(20,file='Act_jtz.out')
  do it = 0,nt
    read(20,*)tt(it),Act(it),jtz(it),jtz_intra(it),jtz_inter(it),Et(it)
  end do
  close(20)
  dt = tt(1) - tt(0)

  window = 0d0
  do it = 0, nt
    xx = tt(it) - 0.5d0*tpulse
    if(abs(xx) < 0.5d0*tpulse)then
      window(it) = cos(pi*xx/tpulse)**4
    end if
  end do

  jtz = jtz * window
  jtz_intra = jtz_intra * window
  jtz_inter = jtz_inter * window

  open(30,file='hhg_spec.out')
  do iw = 0, nw
    ww = ww_i + dw*iw

    zEw = 0d0
    zjw = 0d0
    zjw_intra = 0d0
    zjw_inter = 0d0

    do it = 0, nt
      zfact = exp(zi*ww*tt(it))
      zEw = zEw + Et(it)*zfact
      zjw = zjw + jtz(it)*zfact
      zjw_intra = zjw_intra + jtz_intra(it)*zfact
      zjw_inter = zjw_inter + jtz_inter(it)*zfact
    end do

    zEw = zEw*dt
    zjw = zjw*dt
    zjw_intra = zjw_intra*dt
    zjw_inter = zjw_inter*dt

    write(30,"(999e26.16e3)")ww,abs(zEw)**2, abs(zjw)**2, abs(zjw_intra)**2 &
      , abs(zjw_inter)**2

  end do
  close(30)

end program main


      SUBROUTINE DEQTHECALC(QVP,TMK,PRS,ETH,MIY,MJX,MKZH)
      DOUBLE PRECISION EPS
      DOUBLE PRECISION RGAS
      DOUBLE PRECISION RGASMD
      DOUBLE PRECISION CP
      DOUBLE PRECISION CPMD
      DOUBLE PRECISION GAMMA
      DOUBLE PRECISION GAMMAMD
      DOUBLE PRECISION TLCLC1
      DOUBLE PRECISION TLCLC2
      DOUBLE PRECISION TLCLC3
      DOUBLE PRECISION TLCLC4
      DOUBLE PRECISION THTECON1
      DOUBLE PRECISION THTECON2
      DOUBLE PRECISION THTECON3
      DOUBLE PRECISION Q
      DOUBLE PRECISION T
      DOUBLE PRECISION P
      DOUBLE PRECISION E
      DOUBLE PRECISION TLCL
c
c Input variables
c Qvapor [g/kg]
      DOUBLE PRECISION QVP(MIY,MJX,MKZH)
c Temperature [K]
      DOUBLE PRECISION TMK(MIY,MJX,MKZH)
c full pressure (=P+PB) [hPa]
      DOUBLE PRECISION PRS(MIY,MJX,MKZH)
c
c Output variable
c equivalent potential temperature [K]
      DOUBLE PRECISION ETH(MIY,MJX,MKZH)
c
c parameters
      PARAMETER (EPS=0.622D0)

c J/K/kg
      RGAS = 287.04D0
c rgas_moist=rgas*(1.+rgasmd*qvp)
      RGASMD = .608D0
c J/K/kg  Note: not using Bolton's value of 1005.7
      CP = 1004.D0
c cp_moist=cp*(1.+cpmd*qvp)
      CPMD = .887D0
      GAMMA = RGAS/CP
c gamma_moist=gamma*(1.+gammamd*qvp)
      GAMMAMD = RGASMD - CPMD

      TLCLC1 = 2840.D0
      TLCLC2 = 3.5D0
      TLCLC3 = 4.805D0
      TLCLC4 = 55.D0
c K
      THTECON1 = 3376.D0
      THTECON2 = 2.54D0
      THTECON3 = .81D0
c
      DO 1000 K = 1,MKZH
          DO 1000 J = 1,MJX
              DO 1000 I = 1,MIY
                  Q = MAX(QVP(I,J,K),1.D-15)
                  T = TMK(I,J,K)
                  P = PRS(I,J,K)/100.
                  E = Q*P/ (EPS+Q)
                  TLCL = TLCLC1/ (LOG(T**TLCLC2/E)-TLCLC3) + TLCLC4
                  ETH(I,J,K) = T* (1000.D0/P)**
     +                         (GAMMA* (1.D0+GAMMAMD*Q))*
     +                         EXP((THTECON1/TLCL-THTECON2)*Q*
     +                         (1.D0+THTECON3*Q))
 1000 CONTINUE
      RETURN
      END


! Evaluate 1D basis splines and their first two derivatives over their domain
! given lists of knots and control points.
MODULE stellopt_cbspline
  IMPLICIT NONE
  INTEGER, PARAMETER :: CBR8 = selected_real_kind(15,100)

  TYPE cbspline
     REAL(CBR8), DIMENSION(:), ALLOCATABLE :: knot, coef
     INTEGER :: ncoefs
  END type cbspline
CONTAINS
!---------------------------------------------------------------
  SUBROUTINE cbspline_init(cs, n, ierr)
    IMPLICIT NONE
    TYPE(cbspline), INTENT(OUT) :: cs
    INTEGER, INTENT(IN) :: n
    INTEGER, INTENT(OUT) :: ierr

    ierr = 0
    IF (n.LT.1) THEN
       ierr = 1
       RETURN
    ENDIF

    cs%ncoefs = n

    IF (ALLOCATED(cs%knot)) DEALLOCATE(cs%knot)
    ALLOCATE(cs%knot(0:n+3))
    IF (ALLOCATED(cs%coef)) DEALLOCATE(cs%coef)
    ALLOCATE(cs%coef(0:n-1))

    IF (.NOT.ALLOCATED(cs%knot) .OR. .NOT.ALLOCATED(cs%coef)) ierr = 2
  END SUBROUTINE cbspline_init
!---------------------------------------------------------------
  SUBROUTINE cbspline_delete(cs)
    IMPLICIT NONE
    TYPE(cbspline), INTENT(INOUT) :: cs
    cs%ncoefs = 0
    IF (ALLOCATED(cs%knot)) DEALLOCATE(cs%knot)
    IF (ALLOCATED(cs%coef)) DEALLOCATE(cs%coef)
  END SUBROUTINE cbspline_delete
!---------------------------------------------------------------
  SUBROUTINE cbspline_setup(cs, n, kval, cval, ierr)
    IMPLICIT NONE
    TYPE(cbspline), INTENT(INOUT) :: cs
    INTEGER, INTENT(IN) :: n
    REAL(CBR8), DIMENSION(n+4), INTENT(IN) :: kval
    REAL(CBR8), DIMENSION(n), INTENT(IN) :: cval
    INTEGER, INTENT(OUT) :: ierr

    ierr = 0
    IF (n.ne.cs%ncoefs) THEN
       ierr = 1
       RETURN
    ENDIF

    cs%knot(0:n+3) = kval(1:n+4)
    cs%coef(0:n-1) = cval(1:n)
  END SUBROUTINE cbspline_setup
!---------------------------------------------------------------
  SUBROUTINE cbspline_eval(cs, s, f, ierr)
    IMPLICIT NONE
    TYPE(cbspline), INTENT(IN) :: cs
    REAL(CBR8), INTENT(IN) :: s
    REAL(CBR8), INTENT(OUT) :: f
    INTEGER, INTENT(OUT) :: ierr

    REAL(CBR8) :: kms, smk, c2_0, c2_1, c2_2, c1_0, c1_1
    INTEGER mu

    ierr = 0
    IF (cs%ncoefs.LT.1) THEN !Spline object is not properly initialized.
       ierr = 1
       RETURN
    ENDIF

    ! Test whether in-bounds
    IF ((s.LT.cs%knot(2)).OR.(s.GT.cs%knot(cs%ncoefs))) THEN
       ierr = 2
       RETURN
    ENDIF

    ! Find the knot interval containing the point
    DO mu=3,cs%ncoefs-1
       IF (cs%knot(mu).GT.s) EXIT
    ENDDO

    ! Construct the spline at s using three matrix multiplies.
    kms = cs%knot(mu) - s;  smk = s - cs%knot(mu - 1)

    c2_0 = (kms*cs%coef(mu-4) + (s - cs%knot(mu-3))*cs%coef(mu-3))/&
         (cs%knot(mu) - cs%knot(mu-3))
    c2_1 = ((cs%knot(mu+1) - s)*cs%coef(mu-3) + &
         (s - cs%knot(mu-2))*cs%coef(mu-2))/(cs%knot(mu+1) - cs%knot(mu-2))
    c2_2 = ((cs%knot(mu+2) - s)*cs%coef(mu-2) + &
         smk*cs%coef(mu-1))/(cs%knot(mu+2) - cs%knot(mu-1))

    c1_0 = (kms*c2_0 + &
         (s - cs%knot(mu-2))*c2_1)/(cs%knot(mu) - cs%knot(mu-2))
    c1_1 = ((cs%knot(mu+1) - s)*c2_1 + &
         smk*c2_2)/(cs%knot(mu+1) - cs%knot(mu-1))

    f = (kms*c1_0 + smk*c1_1)/(cs%knot(mu) - cs%knot(mu-1))
  END SUBROUTINE cbspline_eval
!---------------------------------------------------------------
  SUBROUTINE cbspline_derivs(cs, s, f, fp, fpp, ierr)
    IMPLICIT NONE
    TYPE(cbspline), INTENT(IN) :: cs
    REAL(CBR8), INTENT(IN) :: s
    REAL(CBR8), INTENT(OUT) :: f, fp, fpp
    INTEGER, INTENT(OUT) :: ierr

    REAL(CBR8) :: kms, smk, c2_0, c2_1, c2_2, c1_0, c1_1
    REAL(CBR8) :: d2_0, d2_1, d2_2, d1_0, d1_1, e1_0, e1_1
    INTEGER mu

    ierr = 0
    IF (cs%ncoefs.LT.1) THEN !Spline object is not properly initialized.
       ierr = 1
       RETURN
    ENDIF

    ! Test whether in-bounds
    IF ((s.LT.cs%knot(2)).OR.(s.GT.cs%knot(cs%ncoefs))) THEN
       ierr = 2
       RETURN
    ENDIF

    ! Find the knot interval containing the point
    DO mu=3,cs%ncoefs-1
       IF (cs%knot(mu).GT.s) EXIT
    ENDDO

    ! Construct the spline & derivs at s using three matrix multiplies.
    kms = cs%knot(mu) - s;  smk = s - cs%knot(mu - 1)

    d2_0 = (cs%coef(mu-3) - cs%coef(mu-4))/(cs%knot(mu) - cs%knot(mu-3))
    d2_1 = (cs%coef(mu-2) - cs%coef(mu-3))/(cs%knot(mu+1) - cs%knot(mu-2))
    d2_2 = (cs%coef(mu-1) - cs%coef(mu-2))/(cs%knot(mu+2) - cs%knot(mu-1))

    c2_0 = (kms*cs%coef(mu-4) + (s - cs%knot(mu-3))*cs%coef(mu-3))/&
         (cs%knot(mu) - cs%knot(mu-3))
    c2_1 = ((cs%knot(mu+1) - s)*cs%coef(mu-3) + &
         (s - cs%knot(mu-2))*cs%coef(mu-2))/(cs%knot(mu+1) - cs%knot(mu-2))
    c2_2 = ((cs%knot(mu+2) - s)*cs%coef(mu-2) + &
         smk*cs%coef(mu-1))/(cs%knot(mu+2) - cs%knot(mu-1))

    e1_0 = 2.0*(d2_1 - d2_0)/(cs%knot(mu) - cs%knot(mu-2))
    e1_1 = 2.0*(d2_2 - d2_1)/(cs%knot(mu+1) - cs%knot(mu-1))

    d1_0 = ((kms*d2_0 - c2_0) + &
         ((s - cs%knot(mu-2))*d2_1 + c2_1))/(cs%knot(mu) - cs%knot(mu-2))
    d1_1 = (((cs%knot(mu+1) - s)*d2_1 - c2_1) + &
         (smk*d2_2 + c2_2))/(cs%knot(mu+1) - cs%knot(mu-1))

    c1_0 = (kms*c2_0 + &
         (s - cs%knot(mu-2))*c2_1)/(cs%knot(mu) - cs%knot(mu-2))
    c1_1 = ((cs%knot(mu+1) - s)*c2_1 + &
         smk*c2_2)/(cs%knot(mu+1) - cs%knot(mu-1))

    f = (kms*c1_0 + smk*c1_1)/(cs%knot(mu) - cs%knot(mu-1))
    fp = ((kms*d1_0 - c1_0) + &
         (smk*d1_1 + c1_1))/(cs%knot(mu) - cs%knot(mu-1))
    fpp = ((kms*e1_0 - 2.0*d1_0) + &
         (smk*e1_1 + 2.0*d1_1))/(cs%knot(mu) - cs%knot(mu-1));
  END SUBROUTINE cbspline_derivs
END MODULE stellopt_cbspline