      subroutine gmdsm(conc,musum,na,natmax,nmutmx,nmxi,nmxmax,
     $ nmxx,ns,nstmax,pmu,uspec)
c
c     This subroutine computes the following second order sum used
c     in Pitzer's equations:
c
c       SUM(jk) mu(ijk)*m(j)*m(k)
c
c     where i is represented by the aqueous species index na and
c     overall species index ns.
c
c     This subroutine is called by:
c
c       EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       conc   = array of concentration values
c       na     = aqueous species index (i refers to ns, where ns is
c                  the corresponding species index)
c       nmxi   = range pointer array into the nmxx array:
c                  nmxi(1,na) and nmxi(2,na) are the first and last
c                  values of the second subscript (nmx) of the nmxx
c                  array for entries pertaining to the na-th
c                  aqueous species (ns-th species)
c       nmxx   = pointer array:
c                  nmxx(1,nmx) = the species index of the second
c                  species in the nmu-th triplet, nmxx(2,nmx) is the
c                  species index of the third species, and
c                  nmxx(3,nmx) = nmu
c       ns     = species index corresponding to the aqueous species
c                  index na
c       pmu    = array of mu values
c       uspec  = array of species names
c
c     Principal output:
c
c       musum  = the sum: SUM(jk) mu(ijk)*m(j)*m(k)
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer natmax,nmutmx,nmxmax,nstmax
c
      integer nmxi(2,natmax),nmxx(3,nmxmax)
      integer na,ns
c
      character(len=48) uspec(nstmax)
c
      real(8) conc(nstmax),pmu(nmutmx)
      real(8) musum
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ifx,ilx,nmu,nmx,ns2,ns3
c
      real(8) cx
c
c-----------------------------------------------------------------------
c
      musum = 0.
      ifx = nmxi(1,na)
      ilx = nmxi(2,na)
      if (ilx .ge. ifx) then
        do nmx = ifx,ilx
          ns2 = nmxx(1,nmx)
          ns3 = nmxx(2,nmx)
          nmu = nmxx(3,nmx)
          cx = 2.
          if (ns2 .eq. ns3) cx = 1.
          musum = musum + cx*pmu(nmu)*conc(ns2)*conc(ns3)
        enddo
      endif
c
      end


      SUBROUTINE TRYCK(GRAV,NTAU,TAU,TT,PPE,PP)
*
*-----------------------------------------------------------------------
*
* TRYCK IS A FAST PRESSURE INTEGRATION ROUITINE. IT IS FAST BECAUSE OF
* TWO REASONS: 1) IT INTEGRATES THE DIFFFERENTIAL EQUATION FOR LN(P)
* AS A FUNCTION OF LN(TAU). 2) IT ITERAES DIRECTLY ON THE ELECTRON
* PRESSURE, KEEPING THE NUMBER OF CALLS TO ABSKO TO A MINIMUM.
* ASSUMING A POWER LAW BEHAVIOUR OF PP,TT,PPE,ETC.: PP=C*TAU**DP,ETC.,
* ONE CAN SHOW THAT DP=(1.+DT*(ROSSPE*PGT/PGPE-ROSST)/(1.+ROSSPE/PGPE).
* THE ANSATZ FOR PP IMPLIES PP(1)=TAU(1)*GRAV/(ROSS(1)*DP), WHICH
* SERVES AS A BOUNDARY CONDITION.
* 790516 *NORD*
*
* Export version  1988-03-24  ********* Olof Morell *** Uppsala
*
*-----------------------------------------------------------------------
*
      INCLUDE 'spectrum.inc'
      DIMENSION TAU(NDP),TT(NDP),PPE(NDP),PP(NDP),PPR(NDP),PPT(NDP),
     &           DLNTAU(NDP),ROSS(NDP)
*
      COMMON/CI8/ PGC,RHOC,EC
*
      DATA EPS,RELT,RELPE,PEDEF/1.E-3,1.E-3,1.E-3,1./
*
      DO 1 K=1,NTAU
        PPR(K)=0.
        PPT(K)=0.
        IF(K.EQ.1)GOTO 1
        DLNTAU(K)=ALOG(TAU(K)/TAU(K-1))
    1 CONTINUE
*
* START
*
      PRINT 101
101   FORMAT('1PRESSURE INTEGRATION'/'  K',6X,'TAU',10X,'TT',
     &       9X,'PPE',8X,'PTOT',8X,'ROSS',10X,'DP',9X,'NABSKO')
      DT=0.
*
* USE 'DLNT/DLNTAU'=DT=0. TO BE COMPATIBLE WITH SOLVE. OTHERWISE
* DT=(TT(2)/TT(1)-1.)/DLNTAU(2)
*
      NABSKO=0
      KK=1
      IF(PPE(1).LE.0.) PPE(1)=PEDEF
*
* ITERATE ON BOUNDARY CONDITION, USING PARTIAL DERIVATIVES
*
  100 CONTINUE
        ROSS(1)=ROSSOP(TT(1),PPE(1),1)
        PP(1)=PGC+PPT(1)+PPR(1)
        PG=PGC
        ROSST=ROSSOP(TT(1)*(1.+RELT),PPE(1),1)
        PGT=PGC
        ROSSPE=ROSSOP(TT(1),PPE(1)*(1.+RELPE),1)
        PGPE=PGC
        PGT=(PGT/PG-1.)/RELT
        PGPE=(PGPE/PG-1.)/RELPE
        ROSST=(ROSST/ROSS(1)-1.)/RELT
        ROSSPE=(ROSSPE/ROSS(1)-1.)/RELPE
        NABSKO=NABSKO+3
        DP=(1.+DT*(ROSSPE*PGT/PGPE-ROSST))/(1.+ROSSPE/PGPE)
        DP=AMAX1(DP,.1)
        DLNPE=ALOG(GRAV*TAU(1)/(PG*ROSS(1)*DP))/(PGPE+ROSSPE)
        PPE(1)=PPE(1)*EXP(DLNPE)
      IF(ABS(DLNPE).GT.EPS) GOTO 100
*
* END BOUNDARY CONDITION
*
      ROSS(1)=ROSSOP(TT(1),PPE(1),1)
      NABSKO=NABSKO+1
      PP(1)=PGC+PPT(1)+PPR(1)
      PRINT 102,KK,TAU(1),TT(1),PPE(1),PP(1),ROSS(1),DP,NABSKO
  102 FORMAT(I3,6E12.5,I12)
*
      DPE=(DP-DT*PGT)/PGPE
      DEDLNP=-(PGPE*PG/PP(1)+.5*DLNTAU(2)*GRAV*TAU(1)/(PP(1)*ROSS(1))*
     &       (PGPE*PG/PP(1)+ROSSPE))
*
* TAU LOOP
*
      DO 110 K=2,NTAU
        PPE(K)=PPE(K-1)*EXP(DPE*DLNTAU(K))
        NABSKO=0
*
* ITERATION LOOP
*
        DLNPE=0.
  111   CONTINUE
          ROSS(K)=ROSSOP(TT(K),PPE(K),k)
          PP(K)=PGC+PPT(K)+PPR(K)
          NABSKO=NABSKO+1
          ERROR=(.5*DLNTAU(K)*GRAV*(TAU(K-1)/(PP(K-1)*ROSS(K-1))+
     &          TAU(K)/(PP(K)*ROSS(K)))-ALOG(PP(K)/PP(K-1)))
          CALL ZEROF(ERROR,DLNPE,DEDLNP)
          PPE(K)=PPE(K)*EXP(DLNPE)
        IF(ABS(DLNPE).GT.EPS) GOTO 111
*
        ROSS(K)=ROSSOP(TT(K),PPE(K),k)
        NABSKO=NABSKO+1
        PP(K)=PGC+PPT(K)+PPR(K)
        DP=GRAV*TAU(K)/(PGC*ROSS(K))
        DPE=ALOG(PPE(K)/PPE(K-1))/DLNTAU(K)
        PRINT 102,K,TAU(K),TT(K),PPE(K),PP(K),ROSS(K),DP,NABSKO
  110 CONTINUE
*
* END TAU LOOP
*
      RETURN
      END


      subroutine l2appr ( t, n, k, q, diag, bcoef )
c  from  * a practical guide to splines *  by c. de boor
c  to be called in main program  l 2 m a i n .
calls subprograms  bsplvb, bchfac/slv
c
constructs the (weighted discrete) l2-approximation by splines of order
c  k  with knot sequence  t(1), ..., t(n+k)  to given data points
c  ( tau(i), gtau(i) ), i=1,...,ntau. the b-spline coefficients
c  b c o e f   of the approximating spline are determined from the
c  normal equations using cholesky's method.
c
c******  i n p u t  ******
c  t(1), ..., t(n+k)  the knot sequence
c  n.....the dimension of the space of splines of order k with knots t.
c  k.....the order
c
c  w a r n i n g  . . .  the restriction   k .le. kmax (= 20)	is impo-
c	 sed by the arbitrary dimension statement for  biatx  below, but
c	 is  n o w h e r e   c h e c k e d   for.
c
c******  w o r k  a r r a y s  ******
c  q....a work array of size (at least) k*n. its first	k  rows are used
c	for the  k  lower diagonals of the gramian matrix  c .
c  diag.....a work array of length  n  used in bchfac .
c
c******  i n p u t  via  c o m m o n  /data/  ******
c  ntau.....number of data points
c  (tau(i),gtau(i)), i=1,...,ntau     are the  ntau  data points to be
c	 fitted .
c  weight(i), i=1,...,ntau    are the corresponding weights .
c
c******  o u t p u t  ******
c  bcoef(1), ..., bcoef(n)  the b-spline coeffs. of the l2-appr.
c
c******  m e t h o d  ******
c  the b-spline coefficients of the l2-appr. are determined as the sol-
c  ution of the normal equations
c     sum ( (b(i),b(j))*bcoef(j) : j=1,...,n)  = (b(i),g),
c						i = 1, ..., n .
c  here,  b(i)	denotes the i-th b-spline,  g  denotes the function to
c  be approximated, and the  i n n e r	 p r o d u c t	of two funct-
c  ions  f  and  g  is given by
c      (f,g)  :=  sum ( f(tau(i))*g(tau(i))*weight(i) : i=1,...,ntau) .
c  the arrays  t a u  and  w e i g h t	are given in common block
c   d a t a , as is the array  g t a u	containing the sequence
c  g(tau(i)), i=1,...,ntau.
c  the relevant function values of the b-splines  b(i), i=1,...,n, are
c  supplied by the subprogram  b s p l v b .
c     the coeff.matrix	c , with
c	    c(i,j)  :=	(b(i), b(j)), i,j=1,...,n,
c  of the normal equations is symmetric and (2*k-1)-banded, therefore
c  can be specified by giving its k bands at or below the diagonal. for
c  i=1,...,n,  we store
c   (b(i),b(j))  =  c(i,j)  in	q(i-j+1,j), j=i,...,min0(i+k-1,n)
c  and the right side
c   (b(i), g )	in  bcoef(i) .
c  since b-spline values are most efficiently generated by finding sim-
c  ultaneously the value of  e v e r y	nonzero b-spline at one point,
c  the entries of  c  (i.e., of  q ), are generated by computing, for
c  each ll, all the terms involving  tau(ll)  simultaneously and adding
c  them to all relevant entries.
c     parameter kmax=20,ntmax=200
      integer k,n,   i,j,jj,left,leftmk,ll,mm,ntau
c     real bcoef(n),diag(n),q(k,n),t(1),  biatx(kmax),dw,gtau,tau,weight
      real bcoef(n),diag(n),q(k,n),t(1),  biatx(  20),dw,gtau,tau,weight
c     dimension t(n+k)
current fortran standard makes it impossible to specify the exact dimen-
c  sion of  t  without the introduction of additional otherwise super-
c  fluous arguments.
c     common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax)
      common / data / ntau, tau(  200),gtau(  200),weight(  200)
      do 7 j=1,n
	 bcoef(j) = 0.
	 do 7 i=1,k
    7	    q(i,j) = 0.
      left = k
      leftmk = 0
      do 20 ll=1,ntau
c		    locate  l e f t  s.t. tau(ll) in (t(left),t(left+1))
   10	    if (left .eq. n)		go to 15
	    if (tau(ll) .lt. t(left+1)) go to 15
	    left = left+1
	    leftmk = leftmk + 1
					go to 10
   15	 call bsplvb ( t, k, 1, tau(ll), left, biatx )
c	 biatx(mm) contains the value of b(left-k+mm) at tau(ll).
c	 hence, with  dw := biatx(mm)*weight(ll), the number dw*gtau(ll)
c	 is a summand in the inner product
c	    (b(left-k+mm), g)  which goes into	bcoef(left-k+mm)
c	 and the number biatx(jj)*dw is a summand in the inner product
c	    (b(left-k+jj), b(left-k+mm)), into	q(jj-mm+1,left-k+mm)
c	 since	(left-k+jj) - (left-k+mm) + 1  =  jj - mm + 1 .
	 do 20 mm=1,k
	    dw = biatx(mm)*weight(ll)
	    j = leftmk + mm
	    bcoef(j) = dw*gtau(ll) + bcoef(j)
	    i = 1
	    do 20 jj=mm,k
	       q(i,j) = biatx(jj)*dw + q(i,j)
   20	       i = i + 1
c
c	      construct cholesky factorization for  c  in  q , then use
c	      it to solve the normal equations
c		     c*x  =  bcoef
c	      for  x , and store  x  in  bcoef .
      call bchfac ( q, k, n, diag )
      call bchslv ( q, k, n, bcoef )
					return
      end


!
!  The rest of the 2-d program
!
      double precision function diff2d( a, b, nx, sx, ex, sy, ey )
      integer nx, sx, ex, sy, ey
      double precision a(sx-1:ex+1, sy-1:ey+1), b(sx-1:ex+1, sy-1:ey+1)
!
      double precision sum
      integer i, j
!
      sum = 0.0d0
      do j=sy,ey
         do i=sx,ex
            sum = sum + (a(i,j) - b(i,j)) ** 2
         enddo
      enddo
!
      diff2d = sum
      return
      end


c  main program for least-squares approximation by splines
c  from  * a practical guide to splines *  by c. de boor
calls setdat,l2knts,l2appr(bsplvb,bchfac,bchslv),bsplpp(bsplvb*)
c     ,l2err(ppvalu(interv)),ppvalu*,newnot
c
c  the program, though ostensibly written for l2-approximation, is typ-
c  ical for programs constructing a pp approximation to a function gi-
c  ven in some sense. the subprogram  l 2 a p p r , for instance, could
c  easily be replaced by one carrying out interpolation or some other
c  form of approximation.
c
c******  i n p u t  ******
c  is expected in  s e t d a t	(quo vide), specifying both the data to
c  be approximated and the order and breakpoint sequence of the pp ap-
c  proximating function to be used. further,  s e t d a t  is expected
c  to  t e r m i n a t e  the run (for lack of further input or because
c   i c o u n t  has reached a critical value).
c     the number  n t i m e s  is read in in the main program. it speci
c  fies the number of passes through the knot improvement algorithm in
c  n e w n o t	to be made. also,  a d d b r k	is read in to specify
c  that, on the average, addbrk knots are to be added per pass through
c  newnot. for example,  addbrk = .34  would cause a knot to be added
c  every third pass (as long as  ntimes .lt. 50).
c
c******  p r i n t e d	o u t p u t  ******
c  is governed by the three print control hollerith strings
c  p r b c o  = 2hon  gives printout of b-spline coeffs. of approxim.
c  p r p c o  = 2hon  gives printout of pp repr. of approximation.
c  p r f u n  = 2hon  gives printout of approximation and error at
c		      every data point.
c  the order  k , the number of pieces	l, and the interior breakpoints
c  are always printed out as are (in l2err) the mean, mean square, and
c  maximum errors in the approximation.
c
c     parameter lpkmax=100,ntmax=200,ltkmax=2000
      integer i,icount,ii,j,k,l,lbegin,lnew,ll,n,nt,ntimes,ntau
     *	     ,on,prbco,prfun,prpco
c     real addbrk,bcoef(lpkmax),break,coef,gtau,q(ltkmax),scrtch(ntmax)
c    *	  ,t(ntmax),tau,totalw,weight
c     common / data / ntau, tau(ntmax),gtau(ntmax),weight(ntmax),totalw
      real addbrk,bcoef(100),break,coef,gtau,q(2000),scrtch(200)
     *	  ,t(200),tau,totalw,weight
      common / data / ntau, tau(200),gtau(200),weight(200),totalw
c     common /data/ also occurs in setdat, l2appr and l2err. it is ment-
c     ioned here only because it might otherwise become undefined be-
c     tween calls to those subroutines.
c     common /approx/ break(lpkmax),coef(ltkmax),l,k
      common /approx/ break(100),coef(2000),l,k
c     common /approx/ also occurs in setdat and l2err.
      data on /2hon /
c
      icount = 0
c	 i c o u n t  provides communication with the data-input-and-
c     termination routine  s e t d a t . it is initialized to  0  to
c     signal to setdat when it is being called for the first time. after
c     that, it is up to setdat to use icount for keeping track of the
c     passes through setdat .
c
c     information about the function to be approximated and order and
c     breakpoint sequence of the approximating pp functions is gathered
c     by a
    1 call setdat(icount)
c
c     breakpoints are translated into knots, and the number  n	of
c     b-splines to be used is obtained by a
      call l2knts ( break, l, k, t, n )
c
c     the integer  n t i m e s	and the real  a d d b r k  are requested
c     as well as the print controls  p r b c o ,  p r p c o  and
c     p r f u n .  ntimes  passes  are made through the subroutine new-
c     not, with an increase of	addbrk	knots for every pass .
      print 600
  600 format(52h ntimes,addbrk , prbco,prpco,prfun =? (i3,f10.5/3a2))
      read 500,ntimes,addbrk,prbco,prpco,prfun
  500 format(i3,f10.5/3a2)
c
      lbegin = l
      nt = 1
c	 the b-spline coeffs.  b c o e f  of the l2-approx. are obtain-
c	 ed by a
   10	 call l2appr ( t, n, k, q, scrtch, bcoef )
	 if (prbco .eq. on)  print 609, (bcoef(i),i=1,n)
  609	 format(//22h b-spline coefficients/(5e16.9))
c
c	 convert the b-repr. of the approximation to pp repr.
	 call bsplpp ( t, bcoef, n, k, q, break, coef, l )
	 print 610, k, l, (break(ll),ll=2,l)
  610	 format(//34h approximation by splines of order,i3,4h on ,
     *	       i3,25h intervals. breakpoints -/(5e16.9))
	 if (prpco .ne. on)		go to 15
	 print 611
  611	 format(/36h pp-representation for approximation)
	 do 12 i=1,l
	    ii = (i-1)*k
   12	    print 613,break(i),(coef(ii+j),j=1,k)
  613	 format(f9.3,5e16.9/(11x,5e16.9))
c
c	 compute and print out various error norms by a
   15	 call l2err ( prfun, scrtch, q )
c
c	 if newnot has been applied less than  n t i m e s  times, try
c	 it again to obtain, from the current approx. a possibly improv-
c	 ed sequence of breakpoints with  addbrk  more breakpoints (on
c	 the average) than the current approximation has.
c	    if only an increase in breakpoints is wanted, without the
c	 adjustment that newnot provides, a fake newnot routine could be
c	 used here which merely returns the breakpoints for  l n e w
c	 equal intervals .
	 if (nt .ge. ntimes)		go to 1
	 lnew = lbegin + float(nt)*addbrk
	 call newnot (break, coef, l, k, scrtch, lnew, t )
	 call l2knts ( scrtch, lnew, k, t, n )
	 nt = nt + 1
					go to 10
      end


      program main
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c                  Normal/Lognormal Probability Plot
c                  *********************************
c
c Displays a set of data values on a probability plot with either an
c arithmetic or logarithmic scaling.
c
c INPUT/OUTPUT Parameters:
c
c   datafl         the data file
c   ivr,iwt        columns for the variable and the weight
c   tmin,tmax      trimming limits
c   outfl          output file for PostScript probability plot
c   npts           number of points to plot (negative means plot all)
c   ilog           1=logarithmic scale, 0=arithmetic
c   min, max, inc  min value, max value and increment for labeling
c   title          the title
c
c
c
c PROGRAM NOTES:
c
c 1. The program is executed with no command line arguments.  The user
c    will be prompted for the name of a parameter file.  The parameter
c    file is described in the documentation (see example scatplt.par)
c
c 2. The logarithmic scaling is base 10
c
c 3. All acceptable values outside the plotting limits (including
c    zero or negative values when a logarithmic scale is used) are
c    used to establish the cdf but are not shown.
c
c
c
c AUTHOR: Clayton V. Deutsch                             DATE: 1989-1999
c-----------------------------------------------------------------------
      use       msflib
      parameter(MV=500, NPVAL = 21, ZERO=0.0, BIGNUM=1.0e21,
     +          EPSLON=1.0e-21, VERSION=2.905)

      real      var(MV),xx(MV),yy(MV),pval(NPVAL)
      integer   test
      real*8    pdp
      character datafl*512,outfl*512,varlab*24,title*40,str*512
      logical   testfl,plotall
c
c Dynamic allocation of arrays that depend on the number of data.
c
      real, allocatable :: ar1(:), ar2(:)

      data lin/1/,lpsout/1/,pscl/0.24/,pxmin/0.0/,pxmax/288.0/
     +     pymin/0.0/,pymax/216.0/,xmin/-10.0/,xmax/60.0/,
     +     ymin/-10.0/,ymax/60.0/,hpxmin/1.0/,hpxmax/59.5/,
     +     hpymin/0.0/,hpymax/58.0/

      common /psdata/ lpsout,pscl,pxmin,pxmax,pymin,pymax,xmin,
     +                xmax,ymin,ymax
c
c The probability scaling and labelling:
c
      data pval/0.0001,0.001,0.002,0.01,0.02,0.05,0.10,0.20,0.30,
     +          0.40,0.50,0.60,0.70,0.80,0.90,0.95,0.98,0.99,0.998,
     +          0.999,0.9999/
c
c
c Note VERSION number:
c
      write(*,9999) VERSION
 9999 format(/' PROBPLT Version: ',f5.3/)
c
c Get the name of the parameter file - try the default name if no input:
c
      do i=1,512
            str(i:i) = ' '
      end do
      call getarg(1,str)
      if(str(1:1).eq.' ')then
            write(*,*) 'Which parameter file do you want to use?'
            read (*,'(a)') str
      end if
      if(str(1:1).eq.' ') str(1:20) = 'probplt.par         '
      inquire(file=str,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the parameter file does not exist,'
            write(*,*) '        check for the file and try again  '
            write(*,*)
            if(str(1:20).eq.'probplt.par         ') then
                  write(*,*) '        creating a blank parameter file'
                  call makepar
                  write(*,*)
            end if
            stop
      endif
      open(lin,file=str,status='OLD')
c
c Find Start of Parameters:
c
 1    read(lin,'(a4)',end=97) str(1:4)
      if(str(1:4).ne.'STAR') go to 1
c
c Read Input Parameters:
c
      read(lin,'(a512)',err=97) datafl
      call chknam(datafl,512)
      write(*,*) ' data file = ',datafl(1:40)

      read(lin,*,err=97) ivr,iwt
      write(*,*) ' columns = ',ivr,iwt

      read(lin,*,err=97) tmin,tmax
      write(*,*) ' tmin and tmax = ',tmin,tmax

      read(lin,'(a512)',err=97) outfl
      call chknam(outfl,512)
      write(*,*) ' outfl = ',outfl(1:40)

      read(lin,*,err=97) npts
      write(*,*) ' number of points to plot = ',npts

      read(lin,*,err=97) ilog
      write(*,*) ' logarithm scale option = ',ilog

      read(lin,*,err=97) pmin,pmax,pinc
      write(*,*) ' min, max, increment = ',pmin,pmax,pinc

      read(lin,'(a40)',err=97) title
      call chktitle(title,40)
      write(*,*) ' title = ',title
      write(*,*)

      close(lin)
c
c Check to make sure the data file exists, then either read in the
c data or write an error message and stop:
c
      inquire(file=datafl,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the data file does not exist,'
            write(*,*) '        check for the file and try again  '
            stop
      endif
c
c The data file exists so open the file and read in the header
c information. Initialize the storage that will be used to summarize
c the data found in the file:
c
      open(lin,file=datafl,status='OLD')
      read(lin,*,err=99)
      read(lin,*,err=99)     nvari
      do i=1,nvari
            read(lin,*)
      end do
      maxdat = 0
 20   read(lin,*,end=40,err=99)(var(j),j=1,nvari)
      if(var(ivr).lt.tmin.or.var(ivr).ge.tmax)go to 20
      maxdat = maxdat + 1
      go to 20
 40   continue
c
c Allocate the needed memory.
c
      allocate (ar1(maxdat),stat = test)
      if (test.ne.0) then
            write(*,*) 'Error: Allocation failed due to ',
     +                 'insufficient memory!', test
            stop
      end if
c
      allocate (ar2(maxdat),stat = test)
      if (test.ne.0) then
            write(*,*) 'Error: Allocation failed due to ',
     +                 'insufficient memory!', test
            stop
      end if
c
c Now read the data for real.
c
      rewind(lin)
      read(lin,'(a)',err=99) str
      read(lin,*,err=99)     nvari
      do i=1,nvari
            read(lin,'(a24)',err=99) str(1:24)
            if(i.eq.ivr) varlab = str(1:24)
      end do
      if(ivr.gt.nvari) then
            write(*,*) ' ivr is greater than the number in data file!'
            stop
      end if
c
c Read as much data as possible:
c
      nd = 0
      nt = 0
      vrmin =  BIGNUM
      vrmax = -BIGNUM
 7    read(lin,*,end=8,err=99) (var(j),j=1,nvari)
c
c Trim this data?
c
      if(var(ivr).lt.tmin.or.var(ivr).ge.tmax) then
            nt = nt + 1
            go to 7
      endif
      if(iwt.ge.1) then
            if(var(iwt).le.EPSLON) then
                  nt = nt + 1
                  go to 7
            endif
      endif
c
c Accept this data:
c
      nd = nd + 1
      ar1(nd) = var(ivr)
      vrmin = min(ar1(nd),vrmin)
      vrmax = max(ar1(nd),vrmax)
      if(iwt.ge.1) then
            ar2(nd) = var(iwt)
      else
            ar2(nd) = 1.0
      endif
c
c Go back for another data:
c
      go to 7
 8    close(lin)
      if(nd.lt.1)then
            write(*,*)'Not reading any data.'
            stop
      endif
c
c Get mean and total weight:
c
      xtwt = 0.0
      xmen = 0.0
      do i=1,nd
            xmen = xmen + ar1(i)*ar2(i)
            xtwt = xtwt + ar2(i)
      end do
      if(xtwt.lt.EPSLON) stop 'Cumulative Probability too LOW'
      xtwti = 1.0  / xtwt
      xmen  = xmen * xtwti
c
c Get the variance:
c
      xvar = 0.0
      do i=1,nd
            xvar = xvar + (ar1(i)-xmen) * (ar1(i)-xmen) * ar2(i)
      end do
      xvar  = xvar * xtwti
c
c Sort the Data in Ascending Order:
c
      call sortem(1,nd,ar1,1,ar2,c,d,e,f,g,h)
c
c Get cumulative probability and normalize:
c
      oldcp = 0.0
      cp    = 0.0
      do i=1,nd
            cp     = cp + ar2(i)*xtwti
            ar2(i) = 0.5*(cp+oldcp)
            oldcp  = cp
      end do
      call locate(ar2,nd,1,nd,0.50,i)
      if(i.eq.0) then
            xmed = ar1(1)
      else if(i.eq.nd) then
            xmed = ar1(nd)
      else
            xmed = ar1(i) +      (ar1(i+1)-ar1(i)) *
     +                      (0.50-ar2(i))/(ar2(i+1)-ar2(i))
      endif
c
c Write Some of the Statistics to the screen:
c
      write(*,900) nd,xmen,xmed,sqrt(max(xvar,0.0)),vrmin,vrmax,nt
 900  format(/' There are ',i8,' data with:',/,
     +        '   mean value          = ',f12.5,/,
     +        '   median value        = ',f12.5,/,
     +        '   standard deviation  = ',f12.5,/,
     +        '   minimum and maximum = ',2f12.5,/,
     +        '   number trimmed      = ',i8,/)
c
c Plot the probability plot:
c
      open(lpsout,file=outfl,status='UNKNOWN')
c
c Add a header:
c
      write(lpsout,998) title(1:20)
 998  format('%!PS                                 %    Remove     ',
     +    /, '90 234 translate 1.5 1.5 scale       %  these lines  ',
     +    /, '                                     % for EPSF file ',
     +    /, '%!PS-Adobe-3.0 EPSF-3.0',
     +    /, '%%BoundingBox: 0 0 288 216',
     +    /, '%%Creator: GSLIB',
     +    /, '%%Title:   ',a20,
     +    /, '%%CreationDate: ',
     +    /, '%%EndComments',/,/,/,'%',/,'%',/,'%',/,
     +    /, '/m {moveto} def /l {lineto} def /r {rlineto} def',
     +    /, '/s {stroke} def /n {newpath} def /c {closepath} def',
     +    /, '/rtext{ dup stringwidth pop -1 div 0 rmoveto show } def',
     +    /, '/ctext{ dup stringwidth pop -2 div 0 rmoveto show } def',
     +    /, '/ltext{show} def /gr{grestore} def /gs{gsave} def',
     +    /, '/tr{translate} def /setc{setrgbcolor} def',
     +    /, '/bullet{ 6 0 360 arc c fill } def',/,/,
     +    /, '%72 72 translate',/,/,
     +    /, '0.240000 0.240000 scale')
c
c Adjust the scaling parameters if undefined or if log scaling is used:
c
      if(pmax.le.pmin) then
            pmin = ar1(1)
            pmax = ar1(nd)
            pinc = (pmax-pmin)/10.0
            write(*,*) 'Estimating limits for the plot:',pmin,pmax
      endif
      if(ilog.eq.1) then
c           pmin   = max(ar1(1), 0.0001)
c           pmax   = max(ar1(nd),0.0001)
            istart = int(alog10(pmin)-0.999)
            start  = 10.0**istart
            iend   = int(alog10(pmax)+0.999)
            ncyc   = iend - istart
            pmin   = real(istart)
            pmax   = real(iend)
      endif
c
c Initialize:
c
      xhsmin = pmin
      xhsmax = pmax
      pdp = dble(pval(1))
      call gauinv(pdp,yhsmin,ierr)
      pdp = dble(pval(npval))
      call gauinv(pdp,yhsmax,ierr)
      xrange = hpxmax - hpxmin
      yrange = hpymax - hpymin
c
c Write the title and the labels:
c
      ts   = 7.5
      xloc = hpxmin - 0.15*xrange
      yloc = hpymin + 0.50*yrange
      call pstext(xloc,yloc,22,'Cumulative Probability',ts,
     +                      1,90.0,1)
      xloc = hpxmin + 0.50*xrange
      yloc = hpymin - 0.15*yrange
      call pstext(xloc,yloc,24,varlab,ts,1,0.0,1)
      yloc = hpymax + 0.01*(hpxmax-hpxmin)
      call pstext(hpxmin,yloc,40,title,9.,3,0.,0)
c
c Draw a border box:
c
      xx(1) = hpxmin
      yy(1) = hpymin
      xx(2) = hpxmin
      yy(2) = hpymax
      xx(3) = hpxmax
      yy(3) = hpymax
      xx(4) = hpxmax
      yy(4) = hpymin
      xx(5) = hpxmin
      yy(5) = hpymin
      np    = 5
      siz   = 0.7
      idsh  = 0
      call psline(np,xx,yy,siz,idsh)
c
c Scale and Draw the Probability Axis:
c
      np    = 2
      siz   = 0.4
      xx(1) = hpxmin
      xx(2) = hpxmax
      xloc  = hpxmin - 0.01*xrange
      ts    = 7.0
      do i=1,npval
            pdp = dble(pval(i))
            call gauinv(pdp,yloc,ierr)
            yy(1) = resc(yhsmin,yhsmax,hpymin,hpymax,yloc)
            yy(2) = yy(1)
            call psline(np,xx,yy,siz,idsh)
            yloc = yy(1) - 0.01*yrange
            cp   = pval(i) * 100.0
            write(title(1:5),'(i5)') int(cp)
            if(i.eq.1.or.i.eq.npval) write(title(1:5),'(f5.2)') cp
            if(i.eq.2.or.i.eq.3.or.i.eq.19.or.i.eq.20)
     +          write(title(1:5),'(f5.1)') cp
            call pstext(xloc,yloc,5,title,ts,1,0.0,2)
      end do
c
c Scale and Draw the Variable Axis:
c
      yy(1) = hpymin
      yy(2) = hpymax
      yloc  = hpymin - 0.05*xrange
      if(ilog.eq.1) then
c
c      LOGARITHMIC SCALE:
c
            start  = start / 10.0
            do i=1,ncyc+1
                  start = start * 10.0
                  xloc = alog10(start)
                  xloc = resc(xhsmin,xhsmax,hpxmin,hpxmax,xloc)
                  a = abs(start)
                  s = start
                           write(title(1:8),'(f8.0)')s
                  if(a.lt.10) write(title(1:8),'(f8.1)')s
                  if(a.lt.1.) write(title(1:8),'(f8.2)')s
                  if(a.lt.0.1) write(title(1:8),'(f8.3)')s
                  if(a.lt.0.01) write(title(1:8),'(f8.4)')s
                  if(a.lt.0.001) write(title(1:8),'(f8.5)')s
                  if(a.lt.0.0001) write(title(1:8),'(f8.6)')s
                  if(a.lt.0.00001) write(title(1:8),'(f8.7)')s
                  call pstext(xloc,yloc,8,title,ts,1,0.0,1)
                  if(i.le.ncyc) then
                        do j=1,9
                              xloc = alog10(start*j)
                              xx(1) = resc(xhsmin,xhsmax,
     +                                          hpxmin,hpxmax,xloc)
                              xx(2) = xx(1)
                              call psline(np,xx,yy,siz,idsh)
                        end do
                  endif
            end do
      else
c
c      ARITHMETIC SCALE:
c
            nloop = int((pmax-pmin)/pinc) + 1
            temp  = pmin-pinc
            do i=1,nloop
                  temp = temp + pinc
                  xloc = resc(xhsmin,xhsmax,hpxmin,hpxmax,temp)
                  s = temp
                  a = abs(temp)
                           write(title(1:8),'(f8.0)')s
                  if(a.lt.10) write(title(1:8),'(f8.1)')s
                  if(a.lt.1.) write(title(1:8),'(f8.2)')s
                  if(a.lt.0.1) write(title(1:8),'(f8.3)')s
                  if(a.lt.0.01) write(title(1:8),'(f8.4)')s
                  if(a.lt.0.001) write(title(1:8),'(f8.5)')s
                  if(a.lt.0.0001) write(title(1:8),'(f8.6)')s
                  if(a.lt.0.00001) write(title(1:8),'(f8.7)')s
                  if(s.eq.0.0) write(title(1:8),'(f8.0)')s
                  call pstext(xloc,yloc,8,title,ts,1,0.0,1)
                  xx(1) = xloc
                  xx(2) = xx(1)
                  call psline(np,xx,yy,siz,idsh)
            end do
      endif
c
c Scale and Draw the points on the plot:
c
      nloop   =  nd
      plotall = .true.
      if(npts.le.0) npts = nd
      if(npts.lt.nd) then
            nloop   =  npts
            plotall = .false.
            write(*,901) nloop
 901        format(' Plotting  ',i8,' equally spaced quantiles',/)
      end if
      do i=1,nloop
            if(plotall) then
                  xloc =      ar1(i)
                  pdp  = dble(ar2(i))
            else
                  pp   = (real(i)-0.5)/real(nloop)
                  pdp  = dble(pp)
                  call locate(ar2,nd,1,nd,pp,j)
                  if(j.eq.0) then
                        xloc = ar1(1)
                  else if(j.eq.nd) then
                        xloc = ar1(nd)
                  else
                        xloc = ar1(j) +      (ar1(j+1)-ar1(j)) *
     +                                  (pp-ar2(j))/(ar2(j+1)-ar2(j))
                  end if
            end if
            if(ilog.ne.0) then
                  if(xloc.le.EPSLON) go to 10
                  xloc  = alog10(xloc)
            endif
            call gauinv(pdp,yloc,ierr)
            if(xloc.lt.xhsmin.or.xloc.gt.xhsmax.or.
     +         yloc.lt.yhsmin.or.yloc.gt.yhsmax) go to 10
            xx(1) = resc(xhsmin,xhsmax,hpxmin,hpxmax,xloc)
            yy(1) = resc(yhsmin,yhsmax,hpymin,hpymax,yloc)
            ix = int((resc(xmin,xmax,pxmin,pxmax,xx(1)))/ pscl)
            iy = int((resc(ymin,ymax,pymin,pymax,yy(1)))/ pscl)
            write(lpsout,101) ix,iy
 101        format('n ',i4.4,1x,i4.4,' bullet')
 10         continue
      end do
c
c Add a footer to the Postscript plot file:
c
      write(lpsout,999)
 999  format('%END OF POSTSCRIPT FILE',/,'4.166667 4.166667 scale',/,/,
     +       '%%EOF',/,'showpage')
c
c Finished:
c
      close(lpsout)
      write(*,9998) VERSION
 9998 format(/' PROBPLT Version: ',f5.3, ' Finished'/)
      stop
 97   stop 'ERROR in parameters somewhere'
 99   stop 'ERROR in data somewhere'
      end

      subroutine makepar
c-----------------------------------------------------------------------
c
c                      Write a Parameter File
c                      **********************
c
c
c
c-----------------------------------------------------------------------
      lun = 99
      open(lun,file='probplt.par',status='UNKNOWN')
      write(lun,10)
 10   format('                  Parameters for PROBPLT',/,
     +       '                  **********************',/,/,
     +       'START OF PARAMETERS:')

      write(lun,11)
 11   format('../data/cluster.dat            ',
     +       '-file with data')
      write(lun,12)
 12   format('3   5                          ',
     +       '-  columns for variable and weight')
      write(lun,13)
 13   format('-1.0  1.0e21                   ',
     +       '-  trimming limits')
      write(lun,14)
 14   format('probplt.ps                     ',
     +       '-file for PostScript output')
      write(lun,15)
 15   format('0                              ',
     +       '-number of points to plot (<0 for all)')
      write(lun,16)
 16   format('0                              ',
     +       '-0=arithmetic, 1=log scaling')
      write(lun,17)
 17   format('0.0   30.0   5.0               ',
     +       '-min,max,increment for labeling')
      write(lun,18)
 18   format('Clustered Data                 ',
     +       '-title')

      close(lun)
      return
      end


program test_shape
!! This program shows how netcdf dimension orders are distinct in different languages
use nc4fortran, only: netcdf_file, is_netcdf, NF90_MAX_NAME
use, intrinsic:: iso_fortran_env, only: real64, stdout=>output_unit, stderr=>error_unit

implicit none (type, external)

type(netcdf_file) :: h
character(*), parameter :: path = 'test_shape.nc'
integer, allocatable :: dims(:)
character(NF90_MAX_NAME), allocatable :: dimnames(:)

integer :: d2(3,4), d7(2,1,3,4,7,6,5)

call h%open(path, action='w')
call h%write('d2', d2)
call h%write('d7', d7, dims=['x','y','z', 'p','q','r','s'])

call h%shape('d2', dims)
if (h%ndims('d2') /= size(dims)) error stop 'rank /= size(dims)'
if (any(dims /= shape(d2))) error stop '2-D: file shape not match variable shape'

call h%shape('d7', dims, dimnames)
if (h%ndims('d7') /= size(dims)) error stop 'rank /= size(dims)'
if (any(dims /= shape(d7))) error stop '7-D: file shape not match variable shape'

call h%close()

end program


!---------------------------------------------------------------------------------------------------
! All the coefficients have been taken from the original
! article,the Span-Wagner EoS for CO2.
! The EoS has been published in J. Phys. Chem. Ref. Data, Vol.25,
! pp. 1509-1596, 1996.
!---------------------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------------------
! MODULE   def_constants
! @brief   Module for all coefficents in EoS
! @authors Marco De Lorenzo, Yu Fang
! @date    25-10-2016
!----------------------------------------------------------------------------------------------------
MODULE def_constants

! USE mod_prec_defs, ONLY: pr

  IMPLICIT NONE

  INTEGER, PARAMETER :: pr = selected_real_kind(15,307)  !< working precision consistent with AVBP (here double precision)
!  INTEGER, PARAMETER :: pr = selected_real_kind(32)  !< working precision consistent with AVBP (here double precision)

!-----------------------------------------------------------------------------------------------------
!
! Coefficients for phi_0 (ideal gas part)    FROM p. 1540 of the paper, Table 27
!
!----------------------------------------------------------------------------------------------------

! Coefficient a_i_0
  REAL(pr), PARAMETER :: a1_0= 8.37304456_pr
  REAL(pr), PARAMETER :: a2_0=-3.70454304_pr
  REAL(pr), PARAMETER :: a3_0= 2.50000000_pr
  REAL(pr), PARAMETER :: a4_0= 1.99427042_pr
  REAL(pr), PARAMETER :: a5_0= 0.62105248_pr
  REAL(pr), PARAMETER :: a6_0= 0.41195293_pr
  REAL(pr), PARAMETER :: a7_0= 1.04028922_pr
  REAL(pr), PARAMETER :: a8_0= 0.08327678_pr

! Coefficients thi_0
  REAL(pr), PARAMETER :: th4_0= 3.151630_pr
  REAL(pr), PARAMETER :: th5_0= 6.111900_pr
  REAL(pr), PARAMETER :: th6_0= 6.777080_pr
  REAL(pr), PARAMETER :: th7_0= 11.32384_pr
  REAL(pr), PARAMETER :: th8_0= 27.08792_pr

!-------------------------------------------------------------------------------------------------
! Physical parameters for CO2
!-------------------------------------------------------------------------------------------------
  REAL(pr), PARAMETER :: W      = 0.0440098_pr        ! Molar mass               [kg/mol]
  REAL(pr), PARAMETER :: R      = 188.9241_pr         ! specific gas constant    [J/kg/K]
! Critical Point
  REAL(pr), PARAMETER :: T_cr   = 304.1282_pr         ! critical temperature     [K]
  REAL(pr), PARAMETER :: rho_cr = 467.6_pr            ! critical density         [kg/m3]
  REAL(pr), PARAMETER :: P_cr   = 7377300.0_pr        ! critical pressure        [Pa]
  REAL(pr), PARAMETER :: e_cr   = -190311.39561_pr    ! critical internal energy [J/kg]
  REAL(pr), PARAMETER :: c_cr   = 130_pr              ! singularity in EoS, average of the previous (T,v)
  REAL(pr), PARAMETER :: cp_cr   = 2000e3_pr              ! singularity in EoS, average of the previous (T,v)
! Triple Point
  REAL(pr), PARAMETER :: T_tri  = 216.592_pr          ! triple point temperature [K]
  REAL(pr), PARAMETER :: P_tri  = 517950_pr       ! triple point pressure    [Pa]
! e = h-pv
!  REAL(pr), PARAMETER :: e_tri_L  = -427167.1751487_pr! liquid triple point internal energy      [J/kg]
  REAL(pr), PARAMETER :: e_tri_L  = -427183.310638_pr
  REAL(pr), PARAMETER :: e_tri_R  = -114003.706_pr    ! vapor triple point internal energy       [J/kg]
  REAL(pr), PARAMETER :: rho_tri_R  = 13.761_pr       ! vapor triple point density               [kg/m3]
  REAL(pr), PARAMETER :: rho_tri_L  = 1178.46_pr       ! liquid triple point density              [kg/m3]
  REAL(pr), PARAMETER :: v_tri_R  = 1_pr / 13.761_pr  ! vapor triple point specific volume      [m3/kg]
  REAL(pr), PARAMETER :: v_tri_L  = 1_pr / 1178.4_pr  ! liquid triple point specific volume      [m3/kg]
  REAL(pr), PARAMETER :: c_tri_L  = 975.85_pr         ! liquid triple point speed of sound       [m/s]
  REAL(pr), PARAMETER :: c_tri_R  = 222.78_pr         ! vapor triple point speed of sound        [m/s]
  REAL(pr), PARAMETER :: h_tri_L  = -426740_pr        ! liquid triple point specific enthalpy    [J/kg]
  REAL(pr), PARAMETER :: h_tri_R  = -76364_pr         ! vapor  point liquid specific enthalpy    [J/kg]
!
!  The U maximum point along the saturation curve
  REAL(pr), PARAMETER :: T_umax   = 252.0757_pr       ! Umax temperature     [K]
  REAL(pr), PARAMETER :: rho_umax = 49.9239758_pr     ! Umax density         [kg/m3]
  REAL(pr), PARAMETER :: v_umax   = 2.003045597d-2    ! Umax specific volume [m3/kg]
  REAL(pr), PARAMETER :: P_umax   = 1905180.51_pr     ! Umax pressure        [Pa]
  REAL(pr), PARAMETER :: e_umax   = -107978.7379_pr   ! Umax internal energy [J/kg]
  REAL(pr), PARAMETER :: c_umax   = 220.697963_pr     ! Umax speed of sound  [m/s]

  REAL(pr), PARAMETER :: T_B      = 432_pr
  REAL(pr), PARAMETER :: v_B      = 1.502084e-3_pr
!  REAL(pr), PARAMETER :: T_B      = 336.94_pr         ! values computed by corner_B
!  REAL(pr), PARAMETER :: v_B      = 3.69e-3_pr

  REAL(pr), PARAMETER :: T_C      = 225.553_pr        ! values computed by corner_C
  REAL(pr), PARAMETER :: v_C      = 7.6597e-2_pr
!
  REAL(pr), PARAMETER :: T_D      = 216.59199_pr        ! values computed by corner_D
  REAL(pr), PARAMETER :: v_D      = 5.51702987d-2
!
  REAL(pr), PARAMETER :: T_E      = 278.2886799_pr        ! values computed by corner_E
  REAL(pr), PARAMETER :: v_E      = 8.68527009d-3
!
  REAL(pr), PARAMETER :: e_F      = -111810.3809_pr   ! point F at saturation line before Umax
  REAL(pr), PARAMETER :: v_F      = 1.41627e-2_pr
  REAL(pr), PARAMETER :: P_F      = 1.905180d6
!
  REAL(pr), PARAMETER :: e_G      = -170d3   ! point F at saturation line before Umax
  REAL(pr), PARAMETER :: v_G      = 2.126d-3
!------------------------------------------------------------------------------------------------
!
! Coefficients FOR phi_r (residual part)    FROM p. 1544 of the paper Table 31
!
! Some of the coefficients reported in Table 31 of p. 1544, have not
! been rewritten here as parameters but directly into the formulas.
!
! Namely, coefficients d_i, t_i and c_i are not needed since we will
! express differently the powers of 'tau' and 'delta'.
!
!------------------------------------------------------------------------------------------------
   REAL(pr), PARAMETER :: n1 =  0.38856823203161_pr
   REAL(pr), PARAMETER :: n2 =  0.29385475942740e+1_pr
   REAL(pr), PARAMETER :: n3 = -0.55867188534934e+1_pr
   REAL(pr), PARAMETER :: n4 = -0.76753199592477e+0_pr
   REAL(pr), PARAMETER :: n5 =  0.31729005580416e+0_pr
   REAL(pr), PARAMETER :: n6 =  0.54803315897767e+0_pr
   REAL(pr), PARAMETER :: n7 =  0.12279411220335e+0_pr
   REAL(pr), PARAMETER :: n8 =  0.21658961543220e+1_pr
   REAL(pr), PARAMETER :: n9 =  0.15841735109724e+1_pr
   REAL(pr), PARAMETER :: n10= -0.23132705405503e+0_pr
   REAL(pr), PARAMETER :: n11=  0.58116916431436e-1_pr
   REAL(pr), PARAMETER :: n12= -0.55369137205382e+0_pr
   REAL(pr), PARAMETER :: n13=  0.48946615909422e+0_pr
   REAL(pr), PARAMETER :: n14= -0.24275739843501e-1_pr
   REAL(pr), PARAMETER :: n15=  0.62494790501678e-1_pr
   REAL(pr), PARAMETER :: n16= -0.12175860225246e+0_pr
   REAL(pr), PARAMETER :: n17= -0.37055685270086e+0_pr
   REAL(pr), PARAMETER :: n18= -0.16775879700426e-1_pr
   REAL(pr), PARAMETER :: n19= -0.11960736637987e+0_pr
   REAL(pr), PARAMETER :: n20= -0.45619362508778e-1_pr
   REAL(pr), PARAMETER :: n21=  0.35612789270346e-1_pr
   REAL(pr), PARAMETER :: n22= -0.74427727132052e-2_pr
   REAL(pr), PARAMETER :: n23= -0.17395704902432e-2_pr
   REAL(pr), PARAMETER :: n24= -0.21810121289527e-1_pr
   REAL(pr), PARAMETER :: n25=  0.24332166559236e-1_pr
   REAL(pr), PARAMETER :: n26= -0.37440133423463e-1_pr
   REAL(pr), PARAMETER :: n27=  0.14338715756878e+0_pr
   REAL(pr), PARAMETER :: n28= -0.13491969083286e+0_pr
   REAL(pr), PARAMETER :: n29= -0.23151225053480e-1_pr
   REAL(pr), PARAMETER :: n30=  0.12363125492901e-1_pr
   REAL(pr), PARAMETER :: n31=  0.21058321972940e-2_pr
   REAL(pr), PARAMETER :: n32= -0.33958519026368e-3_pr
   REAL(pr), PARAMETER :: n33=  0.55993651771592e-2_pr
   REAL(pr), PARAMETER :: n34= -0.30335118055646e-3_pr
   REAL(pr), PARAMETER :: n35= -0.21365488688320e+3_pr
   REAL(pr), PARAMETER :: n36=  0.26641569149272e+5_pr
   REAL(pr), PARAMETER :: n37= -0.24027212204557e+5_pr
   REAL(pr), PARAMETER :: n38= -0.28341603423999e+3_pr
   REAL(pr), PARAMETER :: n39=  0.21247284400179e+3_pr
   REAL(pr), PARAMETER :: n40= -0.66642276540751e+0_pr
   REAL(pr), PARAMETER :: n41=  0.72608632349897e+0_pr
   REAL(pr), PARAMETER :: n42=  0.55068668612842e-1_pr
!
!
   REAL(pr), PARAMETER :: d1 =  1.0_pr
   REAL(pr), PARAMETER :: d2 =  1.0_pr
   REAL(pr), PARAMETER :: d3 =  1.0_pr
   REAL(pr), PARAMETER :: d4 =  1.0_pr
   REAL(pr), PARAMETER :: d5 =  2.0_pr
   REAL(pr), PARAMETER :: d6 =  2.0_pr
   REAL(pr), PARAMETER :: d7 =  3.0_pr
   REAL(pr), PARAMETER :: d8 =  1.0_pr
   REAL(pr), PARAMETER :: d9 =  2.0_pr
   REAL(pr), PARAMETER :: d10=  4.0_pr
   REAL(pr), PARAMETER :: d11=  5.0_pr
   REAL(pr), PARAMETER :: d12=  5.0_pr
   REAL(pr), PARAMETER :: d13=  5.0_pr
   REAL(pr), PARAMETER :: d14=  6.0_pr
   REAL(pr), PARAMETER :: d15=  6.0_pr
   REAL(pr), PARAMETER :: d16=  6.0_pr
   REAL(pr), PARAMETER :: d17=  1.0_pr
   REAL(pr), PARAMETER :: d18=  1.0_pr
   REAL(pr), PARAMETER :: d19=  4.0_pr
   REAL(pr), PARAMETER :: d20=  4.0_pr
   REAL(pr), PARAMETER :: d21=  4.0_pr
   REAL(pr), PARAMETER :: d22=  7.0_pr
   REAL(pr), PARAMETER :: d23=  8.0_pr
   REAL(pr), PARAMETER :: d24=  2.0_pr
   REAL(pr), PARAMETER :: d25=  3.0_pr
   REAL(pr), PARAMETER :: d26=  3.0_pr
   REAL(pr), PARAMETER :: d27=  5.0_pr
   REAL(pr), PARAMETER :: d28=  5.0_pr
   REAL(pr), PARAMETER :: d29=  6.0_pr
   REAL(pr), PARAMETER :: d30=  7.0_pr
   REAL(pr), PARAMETER :: d31=  8.0_pr
   REAL(pr), PARAMETER :: d32=  10.0_pr
   REAL(pr), PARAMETER :: d33=  4.0_pr
   REAL(pr), PARAMETER :: d34=  8.0_pr
   REAL(pr), PARAMETER :: d35=  2.0_pr
   REAL(pr), PARAMETER :: d36=  2.0_pr
   REAL(pr), PARAMETER :: d37=  2.0_pr
   REAL(pr), PARAMETER :: d38=  3.0_pr
   REAL(pr), PARAMETER :: d39=  3.0_pr
!
!
!
! Coefficients alpha_i for summation i=35,39
   REAL(pr), PARAMETER :: alp35= 25_pr
   REAL(pr), PARAMETER :: alp36= 25_pr
   REAL(pr), PARAMETER :: alp37= 25_pr
   REAL(pr), PARAMETER :: alp38= 15_pr
   REAL(pr), PARAMETER :: alp39= 20_pr

! Coefficients beta_i for summation i=35,42
   REAL(pr), PARAMETER :: bet35= 325_pr
   REAL(pr), PARAMETER :: bet36= 300_pr
   REAL(pr), PARAMETER :: bet37= 300_pr
   REAL(pr), PARAMETER :: bet38= 275_pr
   REAL(pr), PARAMETER :: bet39= 275_pr
   REAL(pr), PARAMETER :: bet40= 0.3_pr
!   REAL(pr), PARAMETER :: bet41= 0.3d0)
!   REAL(pr), PARAMETER :: bet42= 0.3d0)

! Coefficients gamma_i for summation i=35,39
   REAL(pr), PARAMETER :: gam35= 1.16_pr
   REAL(pr), PARAMETER :: gam36= 1.19_pr
   REAL(pr), PARAMETER :: gam37= 1.19_pr
   REAL(pr), PARAMETER :: gam38= 1.25_pr
   REAL(pr), PARAMETER :: gam39= 1.22_pr

! Coefficients a_i for summation i=40,42
   REAL(pr), PARAMETER :: a40= 3.5_pr
   REAL(pr), PARAMETER :: a41= 3.5_pr
   REAL(pr), PARAMETER :: a42= 3.0_pr

! Coefficients b_i for summation i=40,42
   REAL(pr), PARAMETER :: b40= 0.875_pr
   REAL(pr), PARAMETER :: b41= 0.925_pr
   REAL(pr), PARAMETER :: b42= 0.875_Pr

! Coefficients A_i for summation i=40,42
   REAL(pr), PARAMETER :: AA40= 0.7_pr

! Coefficients B_i for summation i=40,42
   REAL(pr), PARAMETER :: BB40= 0.3_pr
   REAL(pr), PARAMETER :: BB41= 0.3_pr
   REAL(pr), PARAMETER :: BB42= 1.0_pr

! Coefficients C_i for summation i=40,42
   REAL(pr), PARAMETER :: CC40= 10.0_pr
   REAL(pr), PARAMETER :: CC41= 10.0_pr
   REAL(pr), PARAMETER :: CC42= 12.5_pr

! Coefficients D_i for summation i=40,42
   REAL(pr), PARAMETER :: DD40= 275_pr
!
!
! Definition of vertices of the cell in the (x,y) diagram for bicubic
! coefficient construction
!
!REAL(pr) :: x1 = 0d0, y1 = 0d0
!REAL(pr) :: x2 = 0d0, y2 = 1d0
!REAL(pr) :: x3 = 1d0, y3 = 1d0
!--------------------------------------------------------------------
!
! Parameters for the creation of the mesh in physical domains
!
!--------------------------------------------------------------------
! Order of polyfit for spline line
   INTEGER, PARAMETER :: ord_spline = 3
! Left boundary isobar  50MPa
   REAL(pr), PARAMETER :: p_max = 50.0d6
! Residu error
   REAL(pr), PARAMETER :: res_ref = 1.0d-7
! Maximum internal energy smaller than  1000K [J/kg]
   REAL(pr), PARAMETER :: u_end = 540.0e3_pr
!   REAL(pr), PARAMETER :: e_ref = 500.0e3_pr
   REAL(pr), PARAMETER :: e_ref = 506.78993e3_pr ! caliberated with NIST
! delta_R = u_min - u_triple in the Right region
   REAL(pr), PARAMETER, PUBLIC  :: delta_R    = 5e0_pr
! X interval in transformed domain
   REAL(pr), PARAMETER :: x_mesh_max = 101_pr
   REAL(pr), PARAMETER :: x_mesh_min = 1_pr
!
   REAL(pr), PARAMETER :: x_mesh2_max = 101_pr
   REAL(pr), PARAMETER :: x_mesh2_min = 1_pr
! MESH GRID PARAMETERS
   INTEGER, PARAMETER :: NNN_LL = 100, MMM_LL = 100, NNN_sat_LL = 3*(NNN_LL-1)+1
   INTEGER, PARAMETER :: NNN_LH = 100, MMM_LH = 100, NNN_sat_LH = 3*(NNN_LH-1)+1
   INTEGER, PARAMETER :: NNN_R  = 100, MMM_R  = 100, NNN_sat_R  = 3*(NNN_R-1) +1
   INTEGER, PARAMETER :: NNN_HT = 100, MMM_HT = 100, NNN_sat_HT = 3*(NNN_HT-1)+1
!
! MESH GRID PARAMETERS TWO-PHASE REGION
   INTEGER, PARAMETER :: NNN_TPL = 100, MMM_TPL = 100, NNN_isop_TPL = 3*(NNN_TPL-1)+1
   INTEGER, PARAMETER :: NNN_TPM = 100, MMM_TPM = 100, NNN_sat_TPM = 3*(NNN_TPM-1)+1
   INTEGER, PARAMETER :: NNN_TPH = 100, MMM_TPH = 100, NNN_sat_TPH = 3*(NNN_TPH-1)+1
!
! NUMBER OF POINTS ON THE SATURATION CURVE FOR THE TWO-PHASE ANALYSIS
   INTEGER, PARAMETER :: NNN_TP = 600, NNN_sat_TP = 3*(NNN_TP-1)+1
   INTEGER, PARAMETER :: NNN_TP2 = 600, NNN_sat_TP2 = 5*(NNN_TP2-1)+1
!
!
!===========================================================================
!
! Parameters for transport properties
!
!============================================================================
!
!---------------------------------------------------------------
!
! Viscosity, project summary report:
! Thermophysical Properties of CO2 and CO2-Rich Mixture
!
!--------------------------------------------------------------
REAL(pr), PARAMETER :: av_00= 1749.35489318835_pr
REAL(pr), PARAMETER :: av_01=-369.069300007128_pr
REAL(pr), PARAMETER :: av_02= 5423856.34887691_pr
REAL(pr), PARAMETER :: av_03=-2.21283852168356_pr
REAL(pr), PARAMETER :: av_04=-269503.247933569_pr
REAL(pr), PARAMETER :: av_05= 73145.021531826_pr
REAL(pr), PARAMETER :: av_06= 5.34368649509278_pr
!
REAL(pr), PARAMETER :: bv_00=-19.572881_pr
REAL(pr), PARAMETER :: bv_01= 219.73999_pr
REAL(pr), PARAMETER :: bv_02=-1015.3226_pr
REAL(pr), PARAMETER :: bv_03= 2471.0125_pr
REAL(pr), PARAMETER :: bv_04=-3375.1717_pr
REAL(pr), PARAMETER :: bv_05= 2491.6597_pr
REAL(pr), PARAMETER :: bv_06=-787.26086_pr
REAL(pr), PARAMETER :: bv_07= 14.085455_pr
REAL(pr), PARAMETER :: bv_08=-0.34664158_pr
!
REAL(pr), PARAMETER :: tv_01= 0.25_pr
REAL(pr), PARAMETER :: tv_02= 0.5_pr
REAL(pr), PARAMETER :: tv_03= 0.75_pr
REAL(pr), PARAMETER :: tv_04= 1.0_pr
REAL(pr), PARAMETER :: tv_05= 1.25_pr
REAL(pr), PARAMETER :: tv_06= 1.5_pr
REAL(pr), PARAMETER :: tv_07= 2.5_pr
REAL(pr), PARAMETER :: tv_08= 5.5_pr
!
REAL(pr), PARAMETER :: gamm_v= 8.06282737481277_pr
REAL(pr), PARAMETER :: cv_01 = 0.360603235428487_pr
REAL(pr), PARAMETER :: cv_02 = 0.121550806591497_pr
!
!---------------------------------------------------------------
!
! Thermal conductivity, project summary report:
! Thermophysical Properties of CO2 and CO2-Rich Mixture
!
!--------------------------------------------------------------
!
!
REAL(pr), PARAMETER :: lc_00= 0.0151873407_pr
REAL(pr), PARAMETER :: lc_01= 0.0280674040_pr
REAL(pr), PARAMETER :: lc_02= 0.0228564190_pr
REAL(pr), PARAMETER :: lc_03=-0.0074162421_pr
!
REAL(pr), PARAMETER :: b1c_01= 0.0100128_pr
REAL(pr), PARAMETER :: b1c_02= 0.0560488_pr
REAL(pr), PARAMETER :: b1c_03=-0.0811620_pr
REAL(pr), PARAMETER :: b1c_04= 0.0624337_pr
REAL(pr), PARAMETER :: b1c_05=-0.0206336_pr
REAL(pr), PARAMETER :: b1c_06= 0.00253248_pr
!
REAL(pr), PARAMETER :: b2c_01= 0.00430829_pr
REAL(pr), PARAMETER :: b2c_02=-0.0358563_pr
REAL(pr), PARAMETER :: b2c_03= 0.0671480_pr
REAL(pr), PARAMETER :: b2c_04=-0.0522855_pr
REAL(pr), PARAMETER :: b2c_05= 0.0174571_pr
REAL(pr), PARAMETER :: b2c_06=-0.00196414_pr
!

END MODULE def_constants


c /***************************************************
c   exp2dmr.f for dbulhalo
c  5 Jun. 2014  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c calculate and tabulate exp(-R/h-h/R) profile
      subroutine setexp2dmr(mtdisk,mdisk,hd,rdlim)
      include 'define.f'
      double precision mtdisk,mdisk,hd,rdlim
c for work
      integer i
      character filen*60
c *** for radial profile ***
      double precision ri,ro,dr
      double precision rhoro,rhori
      double precision mr,pmr

c integration
      ri=0.0d0
      ro=rdlim
      ndrexp2d=10000
      dr=(ro-ri)/dble(ndrexp2d)

      if(myrank.eq.0) then
        write(6,*) ' adjusting mtdisk for exp2d profile'
        write(6,*) ' ri,ro,dr=',ri,ro,dr
      endif

      ro = 0.0d0
      mr = 0.0d0
      rhoro=0.0d0
      rexp2d(0)=0.0d0
      mrexp2d(0)=0.0d0
      rhorexp2d(0)=0.0d0
      do i=1,ndrexp2d
        rhori=rhoro
        pmr = mr
        ri = ro
        ro = ri+dr
        rhoro=dexp(-ro/hd-hd/ro)
        mr = mr+2.0d0*M_PI*(rhoro*ro+rhori*ri)*dr*0.5d0
        mrexp2d(i)=mr
        rexp2d(i)=ro
        rhorexp2d(i)=rhoro
      enddo
      ndrexp2d=ndrexp2d+1

c *** set common values
      roexp2d=ro/LUKPC
      riexp2d=ri/LUKPC
      drexp2d=dr/LUKPC

      if(myrank.eq.0) then
        write(6,*) ' exp2d profile total vs. <Rlim='
     &   ,3.18884*(hd**2),mrexp2d(ndrexp2d-1)
     &   ,3.18884*(hd**2)/mrexp2d(ndrexp2d-1)
      endif
c increase total mass (R<Inf) to M(<Rlim)=mdisk for constant particle mass
      mtdisk=mdisk*3.18884*(hd**2)/mrexp2d(ndrexp2d-1)
c normalisation for M(<R)
      open(60,file='exp2d.dat',status='unknown')
      do i=0,ndrexp2d-1
        mrexp2d(i)=mrexp2d(i)*mtdisk/(3.18884*(hd**2))
        rhorexp2d(i)=mrexp2d(i)*mtdisk/(3.18884*(hd**2))
c change unit
        rexp2d(i)=rexp2d(i)/LUKPC
        mrexp2d(i)=mrexp2d(i)/MUSM
        write(60,'(3(1pE13.5))') rexp2d(i),rhorexp2d(i),mrexp2d(i)
      enddo
      close(60)

      return
      end

      function mrexp2dr(rp)
      include 'define.f'
      double precision mrexp2dr,rp
      integer idr

      idr=int(rp/drexp2d)
      if(idr.ge.0.and.idr.lt.ndrexp2d-1) then
        mrexp2dr=mrexp2d(idr)+(mrexp2d(idr+1)-mrexp2d(idr))
     &   *(rp-rexp2d(idr))/drexp2d
      else if(idr.lt.0) then
        mrexp2dr=0.0d0
      else
        mrexp2dr=mrexp2d(ndrexp2d-1)
      endif

      return
      end


! SORD main program
program sord

use process
use thread
use globals
use input_output
use setup
use arrays
use grid_generation
use material_model
use boundary_pml
use kinematic_source
use dynamic_rupture
use material_resample
use time_integration
use stress
use acceleration
use utilities
use statistics

implicit none

call system_clock(clock0, clockrate)
call init_process(master)
if (master) print *, clockrate, 'Clock rate'
call read_parameters
call init_thread(nthread)
call setup_dimensions
call allocate_arrays
call init_grid
call init_material
call init_pml
call init_finite_source
call init_rupture
call resample_material
if (master) print *, clock(), 'Loop  ', nt

do it = 1, nt
    call system_clock(clock0)
    timers = 0
    call step_time
    call step_stress
    call step_accel
    call stats
    if (master .and. modulo(it, 10) == 0) print *, clock(), 'Step  ', it
end do

if (master) print *, clock(), 'Finished!'
call finalize_process

end program


subroutine driver(km, jm, im, do_srf_mom_flx, do_srf_sen_flx, do_srf_lat_flx, &
     Cpd, g, Lv, Rd, Rv, Cpv, dt, p, ps, u, v, T, Ts, q, &
     Tinc, Uinc, Vinc, qinc, Tdot, Udot, Vdot, qdot, shflx, lhflx, taux, tauy)
implicit none

! In
integer, intent(in)                      :: km, jm, im, do_srf_mom_flx
integer, intent(in)                      :: do_srf_sen_flx, do_srf_lat_flx
!f2py intent(in,hide) km,jm,im
real(8), intent(in)                      :: Cpd, g, Lv, Rd, Rv, Cpv, dt
real(8), intent(in), dimension(jm,im)    :: ps, Ts
real(8), intent(in), dimension(km,jm,im) :: p, u, v, T, q

! Out
real(8), intent(out), dimension(jm,im)    :: shflx, lhflx, taux, tauy
real(8), intent(out), dimension(km,jm,im) :: Tinc, Uinc, Vinc, qinc
real(8), intent(out), dimension(km,jm,im) :: Tdot, Udot, Vdot, qdot

! Local
integer :: i,j
real(8), dimension(km,jm,im) :: theta

do i=1,im
   do j=1,jm
      call main(km, do_srf_mom_flx, do_srf_sen_flx, do_srf_lat_flx, &
           Cpd, g, Lv, Rd, Rv, Cpv, dt, &
           p(:,j,i), ps(j,i), u(:,j,i), v(:,j,i), T(:,j,i), Ts(j,i), q(:,j,i), &
           uinc(:,j,i), vinc(:,j,i), Tinc(:,j,i), qinc(:,j,i),                 &
           udot(:,j,i), vdot(:,j,i), Tdot(:,j,i), qdot(:,j,i), theta(:,j,i),   &
           shflx(j,i), lhflx(j,i), taux(j,i), tauy)
   enddo
enddo

Tdot = Tdot*86400.
Udot = Udot*86400.
Vdot = Vdot*86400.
qdot = qdot*86400.

end subroutine driver

!-------------------------------------------------------------
integer function get_nlev()

integer get_km
external get_km

get_nlev = get_km()

end function get_nlev


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION SLATER (IA, IB, IC, ID, K)
!                                                                      *
!   The value of this  function is the Slater integral                 *
!                                                                      *
!                               k                                      *
!                              R (abcd)                                *
!                                                                      *
!   Call(s) to: [LIB92]: QUAD, YZK.                                    *
!                                                                      *
!                                         Last revision: 09 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:44   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE DEBUG_C
      USE GRID_C
      USE ORB_C
      USE TATB_C,          ONLY: TA, TB, MTP
      USE WAVE_C,          ONLY: MF, QF, PF
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE yzk_I
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER :: IA
      INTEGER :: IB
      INTEGER :: IC
      INTEGER :: ID
      INTEGER :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: RESULT
!-----------------------------------------------
!
!
      CALL YZK (K, IB, ID)
!
!   Multiply by second term, and obtain result by integration
!
      IF (K==0 .AND. IB==ID) THEN
         MTP = MIN(MF(IA),MF(IC))
      ELSE
         MTP = MIN(MIN(MTP,MF(IA)),MF(IC))
      ENDIF
!
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = (PF(I,IA)*PF(I,IC) + QF(I,IA)*QF(I,IC))*RPOR(I)*TB(I)
      END DO
!
      CALL QUAD (RESULT)
      SLATER = RESULT
!
!   Debug printout
!
      IF (LDBPR(10)) WRITE (99, 300) K, NP(IA), NH(IA), NP(IB), NH(IB), NP(IC)&
         , NH(IC), NP(ID), NH(ID), SLATER
!
      RETURN
!
  300 FORMAT(/,'  (',1I1,')',/,' R   (',1I2,1A2,',',1I2,1A2,';',1I2,1A2,',',1I2&
         ,1A2,') ','= ',1P,D19.12)
      RETURN
!
      END FUNCTION SLATER


!======================================================================!
  subroutine Fr_velocity()
!----------------------------------------------------------------------!
!  Purpose:                                                            !
!  Calculate Yplus in the near wall cells in order to perform swiching !
!  from  wall function approach to up to the wall approach             !
!                                                                      !
!  Authors: Muhamed Hadziabdic and Bojan Niceno                        !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  use all_mod
  use pro_mod
  use rans_mod
!----------------------------------------------------------------------!
  implicit none
!-------------------------------[Locals]-------------------------------!
  integer c1,c2, s
  real :: UtotSq, Unor, UnorSq, Utan
!--------------------------------[CVS]---------------------------------!
!  $Id: Fr_velocity.f90,v 1.2 2017/08/31 21:53:38 mhadziabdic Exp $
!  $Source: /home/mhadziabdic/Dropbox/cvsroot/T-FlowS-CVS/Process/Fr_velocity.f90,v $
!======================================================================!

  do s=1,NS
    c1 = SideC(1,s)
    c2 = SideC(2,s)

    if(c2 < 0 .and. TypeBC(c2) /= BUFFER) then
      if(TypeBC(c2) == WALL .or. TypeBC(c2) == WALLFL) then
        UtotSq = U % n(c1) * U % n(c1) &
               + V % n(c1) * V % n(c1) &
               + W % n(c1) * W % n(c1)
        Unor = ( U % n(c1) * Sx(s)     &
               + V % n(c1) * Sy(s)     &
               + W % n(c1) * Sz(s) )   &
               /(Sx(s)*Sx(s) + Sy(s)*Sy(s) + Sz(s)*Sz(s))**0.5
        UnorSq = Unor*Unor

        if( UtotSq   >  UnorSq) then
          Utan = sqrt(UtotSq - UnorSq)
        else
          Utan = TINY
        end if

        Uf(c1)  = (CmuD*Kin%n(c1)*v_2%n(c1))**0.25
        Ynd(c1) = Uf(c1)*WallDs(c1)/VISc
      end if
    end if
  end do

  call Exchng(VISt)

  RETURN
  end subroutine Fr_velocity


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!----
!---- subroutine to compute poroelastic velocities cpI, cpII, & cs as a function of the dominant frequency
!----

  subroutine get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
             tortl,rhol_s,rhol_f,etal_f,perm,fi,f0,Q0,w_c,ATTENUATION_PORO_FLUID_PART)

  implicit none

  include "constants.h"

  double precision :: f0,w0il
  double precision :: H_biot,C_biot,M_biot
  double precision :: cpIsquare,cpIIsquare
  double precision :: cssquare,att_I,att_II
  double precision :: etal_f,rhol_f,rhol_s,rhol_bar,perm
  double precision :: mul_fr,phil,tortl

  double precision :: a_r,a_i,b_r,b_i,cc,alpha,aa1,aa2
  double precision :: xx,yy, gXI, gYI,gXII,gYII,w_c,f_c
  double precision :: wi,fi,taus,taue,Q0,bbr,bbi

  double precision :: gA,gB,sa,sb,xxs,yys
  logical :: ATTENUATION_PORO_FLUID_PART

    rhol_bar =  (1.d0 - phil)*rhol_s + phil*rhol_f

    w_c = etal_f*phil/(tortl*rhol_f*perm)
    f_c = w_c/(2*pi)

    wi=2.d0*pi*fi

    alpha=10.d0**dlog10(wi)
    w0il =  2.d0*pi*f0
    taue = (sqrt(Q0*Q0+1) +1)/(w0il*Q0)
    taus = (sqrt(Q0*Q0+1) -1)/(w0il*Q0)

     if(ATTENUATION_PORO_FLUID_PART) then
! high frequency, with memory variables
    bbr = etal_f/perm*(1.d0+alpha*alpha*taus*taue)/(1.d0 + alpha*alpha*taus*taus)
    bbi = etal_f/perm*alpha*(taue-taus)/(1.d0 + alpha*alpha*taus*taus)
     else
! low frequency
    bbr = etal_f/perm
    bbi = 0.d0
     endif

! cs
     gA = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 - (bbr**2-bbi**2)/alpha**2*&
          (phil*rhol_f/(rhol_bar*tortl) -1.d0) - bbi/alpha*phil*rhol_f/(rhol_bar*tortl)*&
          (rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
     gB = -2.d0*bbr*bbi/alpha**2*(phil*rhol_f/(rhol_bar*tortl) -1.d0) + bbr/alpha*phil*rhol_f/&
          (rhol_bar*tortl)*(rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
!
     sa = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 + (bbr**2-bbi**2)/alpha**2
     sb = 2.d0*bbr*bbi/alpha**2
!
     xxs = sa*gA + sb*gB
     yys = gA*sb - sa*gB

     cssquare = mul_fr/(rhol_bar-phil*rhol_f/tortl) * 2.d0*(gA**2+gB**2)/(sqrt(xxs**2+yys**2)+xxs)

! cpI & cpII
      a_r = rhol_bar - phil*rhol_f/tortl - phil*rhol_bar/(tortl*rhol_f)*bbi/alpha
      a_i = phil*rhol_bar/(tortl*rhol_f)*bbr
      b_r = H_biot + M_biot*phil*rhol_bar/(tortl*rhol_f) - 2.d0*phil*C_biot/tortl - &
          phil*H_biot/(tortl*rhol_f)*bbi/alpha
      b_i = phil*H_biot/(tortl*rhol_f)*bbr
      cc = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
!
      xx = b_r*b_r - b_i*b_i/(alpha*alpha) - 4.d0*a_r*cc
      yy = 2.d0*b_r*b_i/alpha - 4.d0*a_i/alpha*cc
!
      gXI = a_r*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
            a_i/alpha*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))

      gYI = a_i/alpha*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
            a_r*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
      gYI = -gYI

      gXII = a_r*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
            a_i/alpha*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))

      gYII = a_i/alpha*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
            a_r*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
      gYII = -gYII
!
!
!
      cpIsquare = ((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
                  (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
                  (sqrt(gXI**2+gYI**2) + gXI)

      cpIIsquare = ((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
                  (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
                  (sqrt(gXII**2+gYII**2) + gXII)

! attenuation factors
      att_I = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXI**2+gYI**2)-gXI) / &
               sqrt((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
                   (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
      att_II = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXII**2+gYII**2)-gXII) / &
               sqrt((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
                   (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)

! inverse quality factors
        aa1 = -gYI/gXI
        aa2 = -gYII/gXII

   end subroutine get_poroelastic_velocities


*     SG02ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          NMAX2
      PARAMETER        ( NMAX2 = 2*NMAX )
      INTEGER          LDA, LDB, LDC, LDF, LDH, LDL, LDR, LDS, LDT, LDU,
     $                 LDX, LDXE
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX, LDL = NMAX,
     $                   LDR = MAX(MMAX,PMAX), LDS = NMAX2+MMAX,
     $                   LDT = NMAX2+MMAX, LDU = NMAX2, LDX = NMAX,
     $                   LDF = MMAX, LDH = NMAX, LDXE = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX+3*MMAX+2, 14*NMAX+23,
     $                   16*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL, RCOND, RNORM
      INTEGER          I, INFO1, INFO2, J, M, N, P
      CHARACTER*1      DICO, FACT, JOB, JOBB, JOBE, JOBL, JOBX, SORT,
     $                 TRANS, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION AE(LDA,NMAX), ALFAI(2*NMAX), ALFAR(2*NMAX),
     $                 B(LDB,MMAX), BETA(2*NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), F(LDF,NMAX), H(LDH,MMAX),
     $                 L(LDL,MMAX), R(LDR,MMAX), S(LDS,NMAX2+MMAX),
     $                 T(LDT,NMAX2), U(LDU,NMAX2), X(LDX,NMAX),
     $                 XE(LDXE,NMAX)
      INTEGER          IPIV(LIWORK), IWORK(LIWORK), OUFACT(2)
      LOGICAL          BWORK(NMAX2)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SG02ND, SB02OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBE, JOB, JOBX, FACT,
     $                      JOBL, UPLO, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( AE(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99991 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               IF ( LSAME( FACT, 'D' ) ) THEN
                  READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,P )
               ELSE
                  READ ( NIN, FMT = * ) ( ( R(I,J), J = 1,M ), I = 1,M )
               END IF
               IF ( LSAME( JOBL, 'N' ) )
     $            READ ( NIN, FMT = * ) ( ( L(I,J), J = 1,M ), I = 1,N )
*              Find the solution matrix X.
               JOBB = 'B'
               SORT = 'S'
               CALL SB02OD( DICO, JOBB, 'Both', UPLO, JOBL, SORT, N, M,
     $                      P, AE, LDA, B, LDB, C, LDC, R, LDR, L, LDL,
     $                      RCOND, X, LDX, ALFAR, ALFAI, BETA, S, LDS,
     $                      T, LDT, U, LDU, TOL, IWORK, DWORK, LDWORK,
     $                      BWORK, INFO1 )
*
               IF ( INFO1.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO1
               ELSE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( X(I,J), J = 1,N )
   20             CONTINUE
*                 Compute the optimal feedback matrix F.
                  CALL SG02ND( DICO, JOBE, JOB, JOBX, FACT, UPLO, JOBL,
     $                         TRANS, N, M, P, AE, LDA, AE, LDA, B, LDB,
     $                         R, LDR, IPIV, L, LDL, X, LDX, RNORM, F,
     $                         LDF, H, LDH, XE, LDXE, OUFACT, IWORK,
     $                         DWORK, LDWORK, INFO2 )
*
                  IF ( INFO2.NE.0 ) THEN
                     WRITE ( NOUT, FMT = 99997 ) INFO2
                  ELSE
                     WRITE ( NOUT, FMT = 99995 )
                     DO 40 I = 1, M
                        WRITE ( NOUT, FMT = 99994 ) ( F(I,J), J = 1,N )
   40                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SG02ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02OD = ',I2)
99997 FORMAT (' INFO on exit from SG02ND = ',I2)
99996 FORMAT (' The solution matrix X is ')
99995 FORMAT (/' The optimal feedback matrix F is ')
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END


!---Solve velocity field
!
!---Input: n - element number
!
!---Output:
!
!

subroutine solve_velocity(n,nl_iter)

    USE flags_M
    USE material_info_M
    USE mesh_info_M
    USE time_info_M
    USE global_parameters_M
    USE solution_vectors_M
    USE element_matrices_M

implicit none

!---Dummy
    integer, intent(in) :: n
    integer, intent(in) :: nl_iter

!---Local
    integer :: i, j
    real(dp) :: beta_1, beta_2, mass_flow_1, mass_flow_2, a,b,f
    real(dp) :: temperature_eval, density_eval
    real(dp) :: previous_time
    logical :: beta_change_flag
    real(dp) :: element_ss_density, element_prev_density

    temperature_eval = 0.0_dp
    !---Loop over all nodes in element
    do j = 1, nodes_per_elem
        !---valuate density based on temperature
        temperature_eval = temperature_eval + vol_int(j)*temperature_soln_new(n,j)
    end do

    do j = 1, nodes_per_elem

        call density_corr(temperature_eval, density_eval)
        density_soln_new(n,j)  = density_eval

        !---New velocity
        velocity_soln_new(n,j) = (mass_flow / &
                                 (spatial_area_fcn(n,j)*density_eval))

        !Density_Reactivity_Feedback(n,j) = 0.0
     end do

    element_ss_density   = 0.0_dp
    element_prev_density = 0.0_dp

    if( t0 > 0.0) then
            do j = 1, nodes_per_elem
              element_ss_density = element_ss_density + vol_int(j)*density_soln_ss(n,j)
              element_prev_density = element_prev_density + vol_int(j)*density_soln_prev(n,j)
            end do

            !---Evaluate feedback based on density change
            if( n > Fuel_Inlet_Start .and. n < Fuel_Outlet_End ) then
                Density_Reactivity_Feedback(n) = (spatial_expansion_fcn(n,2) / &
                    (0.02_dp)) * &
                    (element_ss_density/element_prev_density - 1.0_dp)

            end if

        end if
end subroutine solve_velocity


!Trace rays to local XY plane
subroutine flat(x,y,z,l,m,n,ux,uy,uz,num)
  !Declarations
  integer, intent(in) :: num
  real*8, intent(in) :: l(num),m(num),n(num)
  real*8, intent(inout) :: x(num),y(num),z(num),ux(num),uy(num),uz(num)
  integer :: i
  real*8 :: dummy

  !Loop through rays
  !$omp parallel do private(delta)
  do i=1,num
    delta = -z(i)/n(i)
    z(i) = 0.
    x(i) = x(i) + delta*l(i)
    y(i) = y(i) + delta*m(i)
    ux(i) = 0.
    uy(i) = 0.
    uz(i) = 1.
    !print *, x(i),y(i),z(i)
    !print *, l(i),m(i),n(i)
    !print *, ux(i),uy(i),uz(i)
    !read *, dummy
  end do
  !$omp end parallel do

end subroutine flat

!Trace rays to local XY plane
subroutine flatOPD(x,y,z,l,m,n,ux,uy,uz,opd,num,nr)
  !Declarations
  integer, intent(in) :: num
  real*8, intent(in) :: l(num),m(num),n(num),nr
  real*8, intent(inout) :: x(num),y(num),z(num),ux(num),uy(num),uz(num),opd(num)
  integer :: i

  !Loop through rays
  !$omp parallel do private(delta)
  do i=1,num
    delta = -z(i)/n(i)
    z(i) = 0.
    x(i) = x(i) + delta*l(i)
    y(i) = y(i) + delta*m(i)
    ux(i) = 0.
    uy(i) = 0.
    uz(i) = 1.
    opd(i) = opd(i) + delta*nr
  end do
  !$omp end parallel do

end subroutine flatOPD

!Trace rays to spherical surface, center assumed to be at origin
!Intersection taken to be the closest point to ray
subroutine tracesphere(x,y,z,l,m,n,ux,uy,uz,num,rad)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8, intent(in) :: rad
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  integer :: i
  real*8 :: mago, dotol, determinant, d1, d2

  !Loop through rays
  !$omp parallel do private(dotol,mago,determinant,d1,d2)
  do i=1,num
    !Compute dot product
    dotol= l(i)*x(i) + m(i)*y(i) + n(i)*z(i)
    mago = x(i)**2. + y(i)**2. + z(i)**2.
    !Compute distance to move rays
    determinant = dotol**2 - mago + rad**2
    !If ray does not intersect, set position and cosine vector to NaN
    if (determinant < 0) then
      x(i) = 0.
      y(i) = 0.
      z(i) = 0.
      l(i) = 0.
      m(i) = 0.
      n(i) = 0.
    else
      d1 = -dotol + sqrt(determinant)
      d2 = -dotol - sqrt(determinant)
      if (abs(d2) < abs(d1)) then
        d1 = d2
      end if
      x(i) = x(i) + d1*l(i)
      y(i) = y(i) + d1*m(i)
      z(i) = z(i) + d1*n(i)
    end if
    !Compute surface normal, just normalized position vector
    mago = sqrt(x(i)**2 + y(i)**2 + z(i)**2)
    ux(i) = x(i)/mago
    uy(i) = y(i)/mago
    uz(i) = z(i)/mago
  end do
  !$omp end parallel do

end subroutine tracesphere

!Trace rays to spherical surface, center assumed to be at origin
!Intersection taken to be the closest point to ray
subroutine tracesphereOPD(opd,x,y,z,l,m,n,ux,uy,uz,num,rad,nr)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8, intent(in) :: rad,nr
  real*8 , intent(inout) :: opd(num),x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  integer :: i
  real*8 :: mago, dotol, determinant, d1, d2

  !Loop through rays
  !$omp parallel do private(dotol,mago,determinant,d1,d2)
  do i=1,num
    !Compute dot product
    dotol= l(i)*x(i) + m(i)*y(i) + n(i)*z(i)
    mago = x(i)**2. + y(i)**2. + z(i)**2.
    !Compute distance to move rays
    determinant = dotol**2 - mago + rad**2
    !If ray does not intersect, set position and cosine vector to NaN
    if (determinant < 0) then
      x(i) = 0.
      y(i) = 0.
      z(i) = 0.
      l(i) = 0.
      m(i) = 0.
      n(i) = 0.
    else
      d1 = -dotol + sqrt(determinant)
      d2 = -dotol - sqrt(determinant)
      if (abs(d2) < abs(d1)) then
        d1 = d2
      end if
      x(i) = x(i) + d1*l(i)
      y(i) = y(i) + d1*m(i)
      z(i) = z(i) + d1*n(i)
      opd(i) = opd(i) + d1*nr
    end if
    !Compute surface normal, just normalized position vector
    mago = sqrt(x(i)**2 + y(i)**2 + z(i)**2)
    ux(i) = x(i)/mago
    uy(i) = y(i)/mago
    uz(i) = z(i)/mago
  end do
  !$omp end parallel do

end subroutine tracesphereOPD

!Traces onto a cylinder
!Center is assumed to be at origin, y axis is cylindrical axis
subroutine tracecyl(x,y,z,l,m,n,ux,uy,uz,num,rad)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8, intent(in) :: rad
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  integer :: i
  real*8 :: a,b,c,mag,d1,d2,det,dum

  !$omp parallel do private(a,b,c,det,mag,d1,d2)
  !Compute a,b,c terms in quadratic solution for distance to move rays
  do i=1,num
    a = l(i)**2 + n(i)**2
    b = 2*(x(i)*l(i)+z(i)*n(i))
    c = x(i)**2 + z(i)**2 - rad**2
    !Compute determinant, if < 0, set ray to 0's
    det = b**2 - 4*a*c
    if (det < 0) then
      x(i) = 0.
      y(i) = 0.
      z(i) = 0.
      l(i) = 0.
      m(i) = 0.
      n(i) = 0.
    else
      !Find smallest distance to cylinder
      d1 = (-b + sqrt(det))/2/a
      d2 = (-b - sqrt(det))/2/a
      if (abs(d2) < abs(d1)) then
        d1 = d2
      end if
      !Move ray
      x(i) = x(i) + l(i)*d1
      y(i) = y(i) + m(i)*d1
      z(i) = z(i) + n(i)*d1
    end if
    !Compute surface normal
    mag = sqrt(x(i)**2+z(i)**2)
    ux(i) = x(i)/mag
    uz(i) = z(i)/mag
    uy(i) = 0.
  end do
  !$omp end parallel do

end subroutine tracecyl

!Traces onto a cylinder
!Center is assumed to be at origin, y axis is cylindrical axis
subroutine tracecylOPD(opd,x,y,z,l,m,n,ux,uy,uz,num,rad,nr)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8, intent(in) :: rad,nr
  real*8 , intent(inout) :: opd(num),x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  integer :: i
  real*8 :: a,b,c,mag,d1,d2,det,dum

  !$omp parallel do private(a,b,c,det,mag,d1,d2)
  !Compute a,b,c terms in quadratic solution for distance to move rays
  do i=1,num
    a = l(i)**2 + n(i)**2
    b = 2*(x(i)*l(i)+z(i)*n(i))
    c = x(i)**2 + z(i)**2 - rad**2
    !Compute determinant, if < 0, set ray to 0's
    det = b**2 - 4*a*c
    if (det < 0) then
      x(i) = 0.
      y(i) = 0.
      z(i) = 0.
      l(i) = 0.
      m(i) = 0.
      n(i) = 0.
    else
      !Find smallest distance to cylinder
      d1 = (-b + sqrt(det))/2/a
      d2 = (-b - sqrt(det))/2/a
      if (abs(d2) < abs(d1)) then
        d1 = d2
      end if
      !Move ray
      x(i) = x(i) + l(i)*d1
      y(i) = y(i) + m(i)*d1
      z(i) = z(i) + n(i)*d1
      opd(i) = opd(i) + d1*nr
    end if
    !Compute surface normal
    mag = sqrt(x(i)**2+z(i)**2)
    ux(i) = x(i)/mag
    uz(i) = z(i)/mag
    uy(i) = 0.
  end do
  !$omp end parallel do

end subroutine tracecylOPD

!This routine traces rays to a cylindrical conic surface
!z axis is cylindrical axis, rays have been traced to the xy
!plane, and sag is in the y direction
subroutine cylconic(x,y,z,l,m,n,ux,uy,uz,num,rad,k)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  real*8, intent(in) :: rad,k
  real*8 :: low,high,dL,dH
  real*8 :: F,Fx,Fy,Fp,delt,dum
  integer :: i

  !Z derivative of surface function is 0 due to cylindrical symmetry
  !This is essentially a 2D problem

  !Loop through rays and trace to mirror
  !$omp parallel do private(delt,F,Fx,Fy,Fp,low,high,dL,dH)
  do i=1,num
    delt = 100.
    do while(abs(delt)>1.e-10)
      low = 1 + sqrt(1 - (1+k)*rad**2*x(i)**2)
      high = rad*x(i)**2
      dL = -(1+k)*rad**2*x(i) / sqrt(1 - (1+k)*rad**2*x(i)**2)
      dH = 2*rad*x(i)
      F = y(i) - high/low
      Fx = (high*dL - low*dH) / low**2
      Fy = 1.
      Fp = Fx*l(i) + Fy*m(i)
      delt = -F/Fp
      x(i) = x(i) + l(i)*delt
      y(i) = y(i) + m(i)*delt
      z(i) = z(i) + n(i)*delt
      !print *, x(i),y(i),z(i)
      !print *, F, Fp
      !print * ,delt
      !read *, dum
    end do
    Fp = sqrt(Fx*Fx+Fy*Fy)
    ux(i) = Fx/Fp
    uy(i) = Fy/Fp
    uz(i) = 0.
    !print *, x(i),y(i),z(i)
    !print *, ux(i),uy(i),uz(i)
    !read *, dum
  end do
  !$omp end parallel do

end subroutine cylconic

!Function to trace to a general conic
!Vertex assumed at origin, opening up in the +z direction
!Radius of curvature and conic constant are required parameters
!Traces to solution closest to vertex
subroutine conic(x,y,z,l,m,n,ux,uy,uz,num,R,K)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  real*8, intent(in) :: R,K
  real*8 :: s1,s2,s,z1,z2,denom,b,c,disc
  integer :: i

  !Loop through rays and trace to the conic
  !$omp parallel do private(s,R,denom,b,c,disc,s1,s2,z1,z2)
  do i=1,num
    !Compute amount to move ray s
    s = 0.
    if (K .eq. -1 .and. abs(n(i))==1.) then
      s = (x(i)**2 + y(i)**2 - 2*R*z(i)) / (2*R*n(i))
    else
      denom = l(i)**2 + m(i)**2 + (K+1)*n(i)**2
      b = x(i)*l(i) + y(i)*m(i) + ((K+1)*z(i) - R)*n(i)
      b = b/denom
      c = x(i)**2 + y(i)**2 + (K+1)*z(i)**2 - 2*R*z(i)
      c = c/denom
      disc = b**2 - c
      if (disc .ge. 0.) then
        s1 = -b + sqrt(disc)
        s2 = -b - sqrt(disc)
        !Choose smallest positive resulting Z
        z1 = z(i) + s1*n(i)
        z2 = z(i) + s2*n(i)
        if (abs(z1) .le. abs(z2)) then
          s = s1
        else
          s = s2
        end if
      end if
    end if
    !Advance ray
    if (s==0.) then
      l(i) = 0.
      m(i) = 0.
      n(i) = 0.
    else
      x(i) = x(i) + l(i)*s
      y(i) = y(i) + m(i)*s
      z(i) = z(i) + n(i)*s
      !Compute normal derivative
      denom = sqrt(R**2 - K*(x(i)**2+y(i)**2))
      ux(i) = -x(i) / denom
      uy(i) = -y(i) / denom
      uz(i) = -R/abs(R) * sqrt(R**2 - (K+1)*(x(i)**2+y(i)**2))
      uz(i) = -uz(i) / denom
    end if
  end do
  !$omp end parallel do

end subroutine conic

!Function to trace to a general conic
!Vertex assumed at origin, opening up in the +z direction
!Radius of curvature and conic constant are required parameters
!Traces to solution closest to vertex
subroutine conicopd(opd,x,y,z,l,m,n,ux,uy,uz,num,R,K,nr)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num),opd(num)
  real*8, intent(in) :: R,K,nr
  real*8 :: s1,s2,s,z1,z2,denom,b,c,disc
  integer :: i

  !Loop through rays and trace to the conic
  !$omp parallel do private(s,R,denom,b,c,disc,s1,s2,z1,z2)
  do i=1,num
    !Compute amount to move ray s
    s = 0.
    if (K .eq. -1 .and. abs(n(i))==1.) then
      s = (x(i)**2 + y(i)**2 - 2*R*z(i)) / (2*R*n(i))
    else
      denom = l(i)**2 + m(i)**2 + (K+1)*n(i)**2
      b = x(i)*l(i) + y(i)*m(i) + ((K+1)*z(i) - R)*n(i)
      b = b/denom
      c = x(i)**2 + y(i)**2 + (K+1)*z(i)**2 - 2*R*z(i)
      c = c/denom
      disc = b**2 - c
      if (disc .ge. 0.) then
        s1 = -b + sqrt(disc)
        s2 = -b - sqrt(disc)
        !Choose smallest positive resulting Z
        z1 = z(i) + s1*n(i)
        z2 = z(i) + s2*n(i)
        if (abs(z1) .le. abs(z2)) then
          s = s1
        else
          s = s2
        end if
      end if
    end if
    !Advance ray
    if (s==0.) then
      l(i) = 0.
      m(i) = 0.
      n(i) = 0.
    else
      x(i) = x(i) + l(i)*s
      y(i) = y(i) + m(i)*s
      z(i) = z(i) + n(i)*s
      opd(i) = opd(i) + s*nr
      !Compute normal derivative
      denom = sqrt(R**2 - K*(x(i)**2+y(i)**2))
      ux(i) = -x(i) / denom
      uy(i) = -y(i) / denom
      uz(i) = -R/abs(R) * sqrt(R**2 - (K+1)*(x(i)**2+y(i)**2))
      uz(i) = -uz(i) / denom
    end if
  end do
  !$omp end parallel do

end subroutine conicopd

!Trace an ideal paraxial lens
subroutine paraxial(x,y,z,l,m,n,ux,uy,uz,num,F)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  real*8, intent(in) :: F
  integer :: i

  !Loop through rays and apply appropriate perturbations to cosines
  !$omp parallel do
  do i=1,num
    !Compute
    l(i) = l(i) - x(i)/F
    m(i) = m(i) - y(i)/F
  end do
  !$omp end parallel do

end subroutine paraxial

!Trace rays to a torus. Outer radius is in xy plane, inner radius is
!orthogonal. Geometry and equations taken from
!http://www.emeyex.com/site/projects/raytorus.pdf
!Will also need routine to determine groove geometry
!and apply grating equation over torus
subroutine torus(x,y,z,l,m,n,ux,uy,uz,num,rin,rout)
  !Declarations
  implicit none
  integer, intent(in) :: num
  real*8 , intent(inout) :: x(num),y(num),z(num),l(num),m(num),n(num),ux(num),uy(num),uz(num)
  real*8, intent(in) :: rin,rout
  real*8 :: F,Fx,Fy,Fz,Fp,delt,dum
  integer :: i

  Fz = 2*p
  !Loop through rays and trace to surface
  !$omp parallel do private(delt,F,Fx,Fy,Fp)
  do i=1,num
    delt = 100.
    do while(abs(delt)>1.e-8)
      F = (x(i)**2+y(i)**2+z(i)**2-rin**2-rout**2)**2 + 4*rout**2*(z(i)**2-rin**2)

!2*p*z(i) + p**2 + 4*e**2*p*d/(e**2-1) - x(i)**2 - y(i)**2

      Fx = 4*x(i)*(x(i)**2+y(i)**2+z(i)**2-rin**2-rout**2)
      Fy = 4*y(i)*(x(i)**2+y(i)**2+z(i)**2-rin**2-rout**2)
      Fz = 4*z(i)*(x(i)**2+y(i)**2+z(i)**2-rin**2-rout**2)+8*rout**2*z(i)
      Fp = Fx*l(i) + Fy*m(i) + Fz*n(i)
      delt = -F/Fp
      x(i) = x(i) + l(i)*delt
      y(i) = y(i) + m(i)*delt
      z(i) = z(i) + n(i)*delt
      !print *, x(i),y(i),z(i)
      !print *, F
      !print * ,delt
      !read *, dum
    end do
    Fp = sqrt(Fx*Fx+Fy*Fy+Fz*Fz)
    ux(i) = Fx/Fp
    uy(i) = Fy/Fp
    uz(i) = Fz/Fp
    !print *, x(i),y(i),z(i)
    !print *, ux(i),uy(i),uz(i)
    !read *, dum
  end do
  !$omp end parallel do

end subroutine torus


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of lk in forward (tangent) mode:
!   variations   of useful results: lk
!   with respect to varying inputs: *temp *propunit *tsal
!   Plus diff mem management of: temp:in propunit:in tsal:in pres:in
!>    @brief average thermal conductivities on cell faces in z direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return z thermal conductivity (J/mK,ismpl)
DOUBLE PRECISION FUNCTION g_LK(i, j, k, ismpl, lk)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  USE MOD_TEMP
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL LZ
  EXTERNAL g_LZ
  DOUBLE PRECISION :: f1, f2, prod, summ, LZ
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_LZ
  DOUBLE PRECISION :: lk
  lk = 0.d0
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    g_f1 = g_LZ(i, j, k, ismpl, f1)
    g_f2 = g_LZ(i, j, k + 1, ismpl, f2)
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = delz(k+1)*g_f1 + delz(k)*g_f2
    summ = f1*delz(k+1) + f2*delz(k)
    IF (summ .GT. 0.d0) THEN
      g_lk = 2.d0*(g_prod-prod*g_summ/summ)/summ
      lk = 2.d0*prod/summ
    ELSE
      g_lk = 0.D0
    END IF
  ELSE
    g_lk = 0.D0
  END IF
  RETURN
END FUNCTION g_LK


program main
    use sim
    implicit none

    type(FEMDomain_),target :: domain
    type(MaterialProp_) :: YoungsModulus, PoissonRatio,Density,Cohesion,Phi,psi
    type(Boundary_) :: disp_x,disp_y,disp_z
    type(IO_) :: f
    type(FiniteDeform_) :: Solver
    integer(int32) :: i

    call domain%create(meshtype="rectangular3D",x_num=10,y_num=10,z_num=10,&
        x_len=50.0d0,y_len=20.0d0,z_len=10.0d0)

    !call domain%create(meshtype="Sphere3D",x_num=10,y_num=10,z_num=10,&
    !    x_len=50.0d0,y_len=20.0d0,z_len=10.0d0)
    !call domain%gmsh(Name="test")

    call YoungsModulus%create(Name="YoungsModulus",ParaValue=100.0d0,Layer=1)
    call PoissonRatio%create(Name="PoissonRatio",ParaValue=0.20d0,Layer=2)
    call Density%create(Name="Density",ParaValue=0.00d0,Layer=3)
    call Cohesion%create(Name="Cohesion",ParaValue=100000000.0d0,Layer=4)
    call Phi%create(Name="Psi",ParaValue=0.0d0,Layer=5)
    call psi%create(Name="psi",ParaValue=0.0d0,Layer=6)

    call disp_x%create(Category="Dirichlet",BoundValue=0.0d0,x_max=1.0d0,x_min=-1.0d0,Layer=1)!x
    call disp_y%create(Category="Dirichlet",BoundValue=0.0d0,x_max=1.0d0,x_min=-1.0d0,Layer=2)!y
    call disp_z%create(Category="Dirichlet",BoundValue=0.0d0,x_max=1.0d0,x_min=-1.0d0,Layer=3)!z
    call disp_x%create(Category="Dirichlet",BoundValue=5.0d0,x_max=51.0d0,x_min=40.0d0,Layer=1)

    call domain%import(Materials=.true., Material=YoungsModulus)
    call domain%import(Materials=.true., Material=PoissonRatio)
    call domain%import(Materials=.true., Material=Density)
    call domain%import(Materials=.true., Material=Cohesion)
    call domain%import(Materials=.true., Material=Phi)
    call domain%import(Materials=.true., Material=Psi)

    call domain%import(Boundaries=.true. , Boundary=disp_x)
    call domain%import(Boundaries=.true. , Boundary=disp_y)
    call domain%import(Boundaries=.true. , Boundary=disp_z)

    call domain%bake(template="FiniteDeform_")

    solver%FEMDomain => domain

    solver%dt=1.0d0
    solver%infinitesimal = .true.

    call solver%DivideBC()
    call solver%solve(solvertype="BiCGSTAB")
    do i=1,10
        call solver%UpdateInitConfig()
        call solver%UpdateBC()
        call solver%solve(solvertype="BiCGSTAB")
        call solver%display(DisplayMode="gmsh",OptionalStep=i,Name="deform")
    enddo

end program main


c     Defines the functions h1(z,v) and h2(z,v) according to
c     the definition in eq.(14) of hep-ph/0002078

      function h1(z)
      implicit none
      complex *16 h1,z,zz
      real *8 t,v,acc,tmp1,tmp2
      real *8 err,aa
      integer i,j
      common/ij/i,j
      common/v/v
      common/c/zz
      external aa
      include 'const.F'
      zz=z
      acc=1d-3
c     Real part
      h1=(0d0,0d0)
      j=1
      do i=1,3
      call dadapt(aa,0d0,1d0,5,1d-15,1d-8,tmp1,err)
      h1=h1+tmp1
      enddo
c     Imaginary part
      j=2
      do i=1,3
      call dadapt(aa,0d0,1d0,5,1d-15,1d-8,tmp2,err)
      h1=h1+II*tmp2
      enddo
      h1=-h1/pi
      return
      end

      function h2(z)
      implicit none
      complex *16 h2,z,zz
      common/c/zz
      real *8 t,v,acc,tmp1,tmp2
      real *8 err,aa
      integer i,j
      common/ij/i,j
      common/v/v
      include 'const.F'
      external aa
      zz=z
      acc=1d-3
c     Real part
      h2=(0d0,0d0)
      j=1
      do i=4,6
      call dadapt(aa,0d0,1d0,5,1d-15,1d-8,tmp1,err)
      h2=h2+tmp1
      enddo
c     Imaginary part
      j=2
      do i=4,6
      call dadapt(aa,0d0,1d0,5,1d-15,1d-8,tmp2,err)
      h2=h2+II*tmp2
      enddo
      h2=-h2/pi
      return
      end

c     The function aa(t) give the parametrization of the real (j=1)
c     or imaginary (j=2) part of the function Exp[-i z sin(teta)]
c     and includes the jacobian
c     i=1,2,3 needed to compute h1
c     i=4,5,6 needed to compute h2

      function aa(t)
      implicit none
      complex *16 zz,a,teta,jac
      real *8 v,aa,t
      integer i,j
      common/c/zz
      common/ij/i,j
      common/v/v
      include 'const.F'
      if(i.eq.1) then
      teta=-II*pi*v*t
      jac=II*pi*v
      elseif(i.eq.2) then
      teta=-pi*t
      jac=-pi
      elseif(i.eq.3) then
      teta=-Pi+II*v*pi*t
      jac=II*v*pi
      elseif(i.eq.4) then
      teta=pi+II*pi*v*t
      jac=-II*pi*v
      elseif(i.eq.5) then
      teta=pi*t
      jac=-pi
      elseif(i.eq.6) then
      teta=-II*v*pi*t
      jac=-II*v*pi
      endif
      a=jac*exp(-II*zz*sin(teta))
      if(j.eq.1) then
      aa=dreal(a)
      elseif(j.eq.2) then
      aa=dimag(a)
      endif
      return
      end


       SUBROUTINE W3FC06(DIR,SPD,U,V)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FC06         WIND DIR AND SPD TO EARTH U,V COMPONENTS
C   AUTHOR: STACKPOLE        ORG: W324       DATE: 81-12-30
C
C ABSTRACT: GIVEN THE WIND DIRECTION AND SPEED,
C   COMPUTE EARTH-ORIENTED (TRUE) WIND COMPONENTS.
C   INPUT DIRECTION AT THE POLE POINT
C   MUST BE CONSISTENT WITH WMO CONVENTIONS, AND OUTPUT COMPONENTS
C   WILL FOLLOW THOSE CONVENTIONS.
C   (SEE OFFICE NOTE 241 FOR WMO DEFINITION.)
C
C PROGRAM HISTORY LOG:
C   81-12-30  J.STACKPOLE
C   91-03-06  R.E.JONES    CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FC06 (DIR, SPD, U, V)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     DIR  -  REAL*4  -  WIND DIRECTION, DEGREES
C     SPD  -  REAL*4  -  WIND SPEED, ANY UNITS
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     U    -  REAL*4  -  EARTH-ORIENTED U-COMPONENT
C     V    -  REAL*4  -  EARTH-ORIENTED V-COMPONENT
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     SIN COS                                                 SYSTEM
C
C WARNING: THIS CODE WILL NOT VECTORIZE ON CRAY, YOU COULD
C          PUT THE FOUR LINES IN YOUR CODE WITH A COUPLE OF
C          DO LOOPS.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
         XSPD = -SPD
         DIRL = 0.0174533 * DIR
         U    = XSPD * SIN(DIRL)
         V    = XSPD * COS(DIRL)
C
      RETURN
      END


MODULE m_lattHarmsSphHarmsConv

   USE m_types

CONTAINS

   SUBROUTINE lattHarmsRepToSphHarms(sym, atoms, lattHarms, iType, funcLattHarms, funcSphHarms)

      IMPLICIT NONE

      TYPE(t_sym),    INTENT(IN)    :: sym
      TYPE(t_atoms),  INTENT(IN)    :: atoms
      TYPE(t_sphhar), INTENT(IN)    :: lattHarms
      INTEGER,        INTENT(IN)    :: iType
      REAL,           INTENT(IN)    :: funcLattHarms(:,0:) ! (iR,iLH)
      COMPLEX,        INTENT(INOUT) :: funcSphHarms(:,:) ! (iR,lm)

      INTEGER :: iAtom, iLH, ns, l, iM, m, lm, iR

      iAtom = SUM(atoms%neq(:iType-1)) + 1
      ns = sym%ntypsy(iAtom)

      funcSphHarms = CMPLX(0.0,0.0)

      DO iLH = 0, lattHarms%nlh(ns)
         l = lattHarms%llh(iLH,ns)
         DO iM = 1, lattHarms%nmem(iLH,ns)
            m = lattHarms%mlh(iM,iLH,ns)
            lm = l*(l+1) + m + 1
            DO iR = 1, atoms%jri(iType)
               funcSphHarms(iR,lm) = funcSphHarms(iR,lm) + funcLattHarms(iR,iLH) * lattHarms%clnu(iM,iLH,ns)
            END DO
         END DO
      END DO

   END SUBROUTINE lattHarmsRepToSphHarms

SUBROUTINE sphHarmsRepToLattHarms(sym, atoms, lattHarms, iType, funcSphHarms, funcLattHarms)

   IMPLICIT NONE

      TYPE(t_sym),    INTENT(IN)    :: sym
      TYPE(t_atoms),  INTENT(IN)    :: atoms
      TYPE(t_sphhar), INTENT(IN)    :: lattHarms
      INTEGER,        INTENT(IN)    :: iType
      COMPLEX,        INTENT(IN)    :: funcSphHarms(:,:) ! (iR,lm)
      REAL,           INTENT(INOUT) :: funcLattHarms(:,0:) ! (iR,iLH)

      INTEGER :: iAtom, iLH, ns, l, iM, m, lm, iR

      iAtom = SUM(atoms%neq(:iType-1)) + 1
      ns = sym%ntypsy(iAtom)

      funcLattHarms = 0.0

      DO iLH = 0, lattHarms%nlh(ns)
         l = lattHarms%llh(iLH,ns)
         DO iM = 1, lattHarms%nmem(iLH,ns)
            m = lattHarms%mlh(iM,iLH,ns)
            lm = l*(l+1) + m + 1
            DO iR = 1, atoms%jri(iType)
               funcLattHarms(iR,iLH) = funcLattHarms(iR,iLH) + REAL(funcSphHarms(iR,lm) * CONJG(lattHarms%clnu(iM,iLH,ns)))
            END DO
         END DO
      END DO

   END SUBROUTINE sphHarmsRepToLattHarms

END MODULE m_lattHarmsSphHarmsConv