!!!Some useful subroutines for time integration computation. by Group of XZ LU
subroutine Central_Difference(M, C, M_Inv, dT, U, U1, U0, P, NDOF, NewOrNot) ! Central_Difference
	implicit none;
	integer NDOF;
	integer NewOrNot;
	real*8 M(NDOF,NDOF),C(NDOF,NDOF);
	real*8 M_Inv(NDOF, NDOF)
	real*8 U(NDOF), U1(NDOF), U0(NDOF), P(NDOF), dT;

	integer I, J;
	real*8 M1(NDOF,NDOF), M2(NDOF,NDOF), M3(NDOF,NDOF)
	real*8 M4(NDOF,NDOF), x, y, T(NDOF)

	M1=M/dT/dT+C/2./dT;
	M2=-2.*M/dT/dT;
	M3=M/dT/dT-C/2./dT;

	if(NewOrNot .eq. 0) then
	    call matinv(M1, M4, NDOF);
	    M_Inv = M4
		NewOrNot=1;
	else
	    M4 = M_Inv
	end if

	do I=1, NDOF;
		x=0.;	y=0.;
		do J=1, NDOF;
			U(J)=0;	x=x+M2(I,J)*U1(J);	y=y+M3(I,J)*U0(J);
		end do;
		T(I)=P(I)-x-y;
	end do
	do I=1, NDOF
		do J=1, NDOF; U(I)=U(I)+M4(I,J)*T(J); end do;
	end do

	return;
end subroutine Central_Difference

subroutine matinv(A, B, N)
	implicit none
	integer N
	real(8) ,intent (in)::A(N,N)
	real(8) ::B(N,N)
	integer(4):: I,J,K;	real(8)::D,T
	integer(4)::IS(N),JS(N)
	B=A
	do 	K=1,N
		D=0.0D0
		do I=K,N
			do J=K,N
				if(abs(B(I,J))>D) then
					D=abs(B(I,J)); IS(K)=I; JS(K)=J
				end if
			end do
		end do
		do J=1,N
			T=B(K,J); B(K,J)=B(IS(K),J); B(IS(K),J)=T
		end do
		do I=1,N
			T=B(I,K);	B(I,K)=B(I,JS(K));	B(I,JS(K))=T
		end do
		B(K,K)=1.d0/B(K,K);
		do J=1,N; if(J.NE.K) B(K,J)=B(K,J)*B(K,K);  end do
		do I=1,N
			if(I.NE.K) then
				do J=1,N; if(J.NE.K) B(I,J)=B(I,J)-B(I,K)*B(K,J); end do
			end if
		end do
		do I=1,N; if(I.NE.K) B(I,K)=-B(I,K)*B(K,K);	end do
	end do
	do K=N,1,-1
		do J=1,N
			T=B(K,J); B(K,J)=B(JS(K),J); B(JS(K),J)=T
		end do
		do I=1,N
			T=B(I,K); B(I,K)=B(I,IS(K)); B(I,IS(K))=T
		end do
	end do
	return
end subroutine matinv

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

subroutine ksteel02(props,s,e,de,Et,statev,spd, yield, IDeath,M,ndof)
!
	implicit none
	real*8 E0,sy0,eta,mu,gama,esoft,alpha,beta,a_k,Omega
    real*8 emax,emin,ert,srt,erc,src,Ehc,Eh1,dt,dc,eu
    real*8 de,s,e,s0,et,e_unload,sign,sy,evs,eve,epeak,smax,max
    real*8 sres,eres,x,e_slip,s_slip,e_close,s_close,srel,ET1
    real*8 smin,spd,strain_end

    !real*8 mu
	integer kon, yield, IDeath,ndof
    real*8 M(NDOF,NDOF)!
    real*8 props(10), statev(11)

      E0  = props(1)
      sy0 = props(2)
      eta = props(3)
      mu  = props(4)
      gama= props(5)
      esoft=props(6)
      alpha= props(7)
      beta = props(8)
      a_k= props(9)
      Omega= props(10)
      emax  = statev(1) !maximum strain
      emin  = statev(2) !minimum strain
      ert   = statev(3) !stain at load reversal toward tension
      srt   = statev(4)
      erc   = statev(5) !stain at load reversal toward compression
      src   = statev(6)
      kon   = nint(statev(7)) !
      Ehc   = statev(8) !effective cummulative hysteresis energy
      Eh1   = statev(9) !hysteresis energy in a half cycle
      dt    = statev(10) !damage index for tension
      dc    = statev(11) !damage index for compression

      eu    = mu * sy0/E0 !characteristic ultimate strain

	if(Omega<=0.) Omega=0.5
	if(a_k<0.) a_k=0.
	if(eta<=0.) eta=1.d-6;
	if(esoft>=0.) esoft=-1.d-6

      if (kon.eq.0) then
        emax =  sy0/E0
        emin = -beta*sy0/E0
        if (de.ge.0.0) then
            kon = 1
        else
            kon = 2
        end if
      else if ((kon.eq.1).and.(de.lt.0.0)) then !Load reversal
            kon = 2
            if (s.gt.0.0) then
                erc = e
                src = s
            end if
            Ehc = Ehc + Eh1 * (erc / eu ) ** 2.0
            Eh1 = 0.0 !a new half cycle is to begin
            if (e.gt.emax) emax = e
      else if ((kon.eq.2).and.(de.gt.0.0)) then !Load reversal
            kon = 1
            if (s.lt.0.0) then
                ert = e
                srt = s
            endif
            Ehc = Ehc + Eh1 * (ert / eu ) ** 2.0
            Eh1 = 0.0 !a new half cycle is to begin
            if (e.lt.emin) emin = e
      end if
!
	s0=s
	s = s + E0 * de
	Et = E0

	if(a_k>0.) then
		if(s0>0.) E_unload=E0*(abs(emax/(sy0/E0)))**(-a_k)
		if(s0<0.) E_unload=E0*(abs(emin/(sy0/E0)))**(-a_k)
		if(E_unload<0.1*E0) E_unload=0.1*E0
	else
		E_unload=E0
	end if

	if(s0*de<0.) then
		s = s0 + E_unload * de
		Et = E_unload
		if(s*s0<0.) then
			de=de-s0/E_unload
			s0=1.D-6*sy0*sign(1.d0,s)
			Et=E0
		end if
	end if

      if ( de .ge. 0.0 .and. s0>=0.) then
          sy = (1.0 - dt) * sy0
          !loading envelope
		! Hardening
		if(e+de>sy/E0) then
			evs = max( sy + ( e + de - sy/E0) * eta * E0, 0.)
			evE = eta * E0
	       if (s .ge. evs) then
		      s = evs
		      Et = evE
				yield=1
		   end if
		end if
		! Softening
		epeak=sy/E0+(alpha-1.)*sy/E0/eta
		if(e+0.5*de>epeak) then
			evs=max(sy*alpha+esoft*E0*(e+de-epeak),0.0*sy)
			if(sy*alpha+esoft*E0*(e+de-epeak)<=0.) IDeath=1 ! Complete damage
			evE=esoft*E0
		    if (s .ge. evs) then
			   s = evs
			   Et = evE
			   yield=1
		  end if
		end if

          !reloading envelope
          smax = max(sy, sy + (emax - sy/E0) * eta * E0)
		if(emax>epeak)	then
			smax=max(sy*alpha+esoft*E0*(emax-epeak),0.0*sy)
		end if
          sres = 0.02 * smax
          eres = ert - (srt - sres) / E_unload

		x=emax-smax/E0
		e_slip=gama*emax+(1.-gama)*x
		s_slip=smax*gama
		e_close=e_slip*Omega
		s_close=(e_close-eres)/(e_slip-eres) * (s_slip-sres) + sres

          if (eres .le. emax - smax / E0) then
			if(e+0.5*de<e_close)  then
				srel = (e+de-eres)/(e_slip-eres) * (s_slip-sres) + sres
				Et1=(s_slip-sres)/(e_slip-eres)
			else
				srel=(e+de-e_close)/(emax-e_close)*(smax-s_close)+s_close
				Et1 = (smax - s_close) / (emax - e_close)
			end if
            if (s .gt. srel) then
               s = max( srel, 0.)
               Et = Et1
            end if
          end if

      elseif ( de .lt. 0.0 .and. s0<0. ) then
          sy = (1.0 - dc) * sy0 *beta
          !loading envelope
		! Hardening
		if(e+de<-sy/E0) then
			evs =  min(-sy + ( e + de + sy/E0) * eta * E0,-0.0*sy)
			evE = eta * E0
			if (s .le. evs) then
				s = evs
				Et = evE
				yield=1
			end if
		end if
		! Softening
		epeak=-sy/E0-(alpha-1.)*sy/E0/eta
		if(e+0.5*de<epeak) then
			evs=min(-sy*alpha+esoft*E0*(e+de-epeak),-0.*sy)
			if(-sy*alpha+esoft*E0*(e+de-epeak)>=0.) IDeath=1
			evE=esoft*E0
		    if (s .le. evs) then
			    s = evs
			    Et = evE
				yield=1
		  end if
		end if

          !reloading envelope
          smin = min(-sy, -sy + (emin + sy/E0) * eta * E0)
 		if(emin<epeak)	then
			smin=min(-sy*alpha+esoft*E0*(emin-epeak),0.)
		end if
          sres = 0.02 * smin
          eres = erc - (src - sres) /  E_unload

		x=emin-smin/E0
		e_slip=gama*emin+(1.-gama)*x
		s_slip=smin*gama
		e_close=e_slip*Omega
		s_close=(e_close-eres)/(e_slip-eres) * (s_slip-sres) + sres

          if (eres .ge. emin - smin / E0) then
			if(e+0.5*de>e_close) then
				srel = (e+de-eres)/(e_slip-eres) * (s_slip-sres) + sres
				Et1=(s_slip-sres)/(e_slip-eres)
			else
				srel=(e+de-e_close)/(emin-e_close)*(smin-s_close)+s_close
				Et1 = (smin - s_close) / (emin - e_close)
			end if
            if (s .lt. srel) then
                s = min (srel, 0.)
                Et = Et1
            end if
          end if
      end if

      if (Et.ne.E0 .and. Et.ne. E_unload) then
            spd = spd + s * de
            Eh1 = Eh1 + s * de
            if ( s .ge. 0.0 ) then
                dc = min(Ehc /(3.0 * beta* sy0 * eu), 0.7)
            else
                dt = min(Ehc /(3.0 * sy0 * eu), 0.7)
            end if
      end if

      	x=max(sy0, beta*sy0)
	epeak=x/E0+(alpha-1.)*x/E0/eta
	Strain_End=epeak+abs(x/(esoft*E0))
	x=max(abs(emax),abs(emin),abs(e+de))

	if (IDeath==1) then
		s=0;
		Et=1E-6*E0
	end if
!
	statev(1)   = emax
	statev(2)   = emin
	statev(3)   = ert
	statev(4)   = srt
	statev(5)   = erc
	statev(6)   = src
	statev(7)   = kon
	statev(8)   = Ehc
	statev(9)   = Eh1
	statev(10)  = dt
	statev(11)  = dc
    return
end subroutine ksteel02
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


      recursive subroutine curev(idim,t,n,c,nc,k,u,m,x,mx,ier)
      implicit none
c  subroutine curev evaluates in a number of points u(i),i=1,2,...,m
c  a spline curve s(u) of degree k and dimension idim, given in its
c  b-spline representation.
c
c  calling sequence:
c     call curev(idim,t,n,c,nc,k,u,m,x,mx,ier)
c
c  input parameters:
c    idim : integer, giving the dimension of the spline curve.
c    t    : array,length n, which contains the position of the knots.
c    n    : integer, giving the total number of knots of s(u).
c    c    : array,length nc, which contains the b-spline coefficients.
c    nc   : integer, giving the total number of coefficients of s(u).
c    k    : integer, giving the degree of s(u).
c    u    : array,length m, which contains the points where s(u) must
c           be evaluated.
c    m    : integer, giving the number of points where s(u) must be
c           evaluated.
c    mx   : integer, giving the dimension of the array x. mx >= m*idim
c
c  output parameters:
c    x    : array,length mx,giving the value of s(u) at the different
c           points. x(idim*(i-1)+j) will contain the j-th coordinate
c           of the i-th point on the curve.
c    ier  : error flag
c      ier = 0 : normal return
c      ier =10 : invalid input data (see restrictions)
c
c  restrictions:
c    m >= 1
c    mx >= m*idim
c    t(k+1) <= u(i) <= u(i+1) <= t(n-k) , i=1,2,...,m-1.
c
c  other subroutines required: fpbspl.
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer idim,n,nc,k,m,mx,ier
c  ..array arguments..
      real*8 t(n),c(nc),u(m),x(mx)
c  ..local scalars..
      integer i,j,jj,j1,k1,l,ll,l1,mm,nk1
      real*8 arg,sp,tb,te
c  ..local array..
      real*8 h(6)
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      if (m.lt.1) go to 100
      if (m.eq.1) go to 30
      go to 10
  10  do 20 i=2,m
        if(u(i).lt.u(i-1)) go to 100
  20  continue
  30  if(mx.lt.(m*idim)) go to 100
      ier = 0
c  fetch tb and te, the boundaries of the approximation interval.
      k1 = k+1
      nk1 = n-k1
      tb = t(k1)
      te = t(nk1+1)
      l = k1
      l1 = l+1
c  main loop for the different points.
      mm = 0
      do 80 i=1,m
c  fetch a new u-value arg.
        arg = u(i)
        if(arg.lt.tb) arg = tb
        if(arg.gt.te) arg = te
c  search for knot interval t(l) <= arg < t(l+1)
  40    if(arg.lt.t(l1) .or. l.eq.nk1) go to 50
        l = l1
        l1 = l+1
        go to 40
c  evaluate the non-zero b-splines at arg.
  50    call fpbspl(t,n,k,arg,l,h)
c  find the value of s(u) at u=arg.
        ll = l-k1
        do 70 j1=1,idim
          jj = ll
          sp = 0.
          do 60 j=1,k1
            jj = jj+1
            sp = sp+c(jj)*h(j)
  60      continue
          mm = mm+1
          x(mm) = sp
          ll = ll+n
  70    continue
  80  continue
 100  return
      end


!     Generate a simple rectangular lon/lat grid, and add wrap-around elem. for sphere
!     (a virtual 'earth') so the grid can be used for periodic b.c.
!     After this is done, use ics=2 (and a constant Coriolis if
!     desired), and set rearth_pole and rearth_eq to be r_pole,r_eq below.
!     The grid actually has no boundary at dateline (\pm 180
!     degrees), so no b.c. is needed there (i.e. a periodic construction).
!     The script basically drapes the original Cartesian grid onto a
!     sphere, with lat=[-0.5,0.5] in order to have minimal distortion to
!     the distance along the meridional

!     Inputs: constants below
!     Outputs: hgrid.ll; debug outputs fort.9[89]
!     ifort -Bstatic -O3 -o periodic_grid periodic_grid.f90
      implicit real*8(a-h,o-z)
      parameter(maxdim=9000000) !for dimensioning
      dimension x(maxdim),y(maxdim),ic1(maxdim,3),ic2(maxdim,20)
      dimension nsur(maxdim),x3(maxdim),y3(maxdim),z3(maxdim)
      dimension x3_0(maxdim),y3_0(maxdim),z3_0(maxdim)

      pi=acos(-1.d0)
      !Lengths in x,y (m)
      rlx=100e3; rly=10e3
      !Resolution in x,y (m)
      !# of divisions in x must >=360
      dx=rlx/361; dy=1e3

      !Min/max lat (degr) - use a small meridional band to minimize
      !distorion
      !The global (x,y,z) are calculated via:
      !x=R_e*cos(\phi)*cos(\lambda)
      !y=R_e*cos(\phi)*sin(\lambda)
      !z=R_p*sin(\phi)
      ymin=-0.5; ymax=0.5

      !Radius @ pole to match rly
      r_pole=rly/(ymax-ymin)/pi*180

      nx=rlx/dx+0.01 !# of divisions in x
      ny=rly/dy+0.01 !# of divisions in y
      if(nx<360) stop 'Make sure # of divisions in x >=360!'

      !Back calculate radius of 'earth' @ equator to match length in x
      r_eq=rlx/2/pi

      !Resolutions in lon/lat (degr)
      dx_lon=360./(nx+1)
      dy_lat=(ymax-ymin)/ny
      !Min/max lon (degr)
      xmin=-180
      xmax=180-dx_lon !leave a gap

      print*, 'Radii @ pole and equator=',r_pole,r_eq
      print*, 'nx,ny=',nx,ny
      print*, 'Resolutions in meter=',dx,dy
      print*, 'Resolutions in lon/lat (degr)=',dx_lon,dy_lat

      open(12,file='hgrid.ll',status='replace')
      if((nx+1)*(ny+1).gt.maxdim.or.nx*ny*2.gt.maxdim) then
        write(*,*)'Increase maxdim'
        stop
      endif

      do ix=1,nx+1
      do iy=1,ny+1
        nd=(ny+1)*(ix-1)+iy
        x(nd)=xmin+(xmax-xmin)/nx*(ix-1)
        y(nd)=ymin+(ymax-ymin)/ny*(iy-1)
      enddo
      enddo
      nn=(nx+1)*(ny+1)

      do ix=1,nx
      do iy=1,ny
         !Split into pairs of tri's
         ne=ny*(ix-1)+iy
         nd1=(ny+1)*(ix-1)+iy
         nd2=(ny+1)*ix+iy
         ic1(2*ne-1,1)=nd1
         ic1(2*ne-1,2)=nd2
         ic1(2*ne-1,3)=nd2+1
         ic1(2*ne,1)=nd1
         ic1(2*ne,2)=nd2+1
         ic1(2*ne,3)=nd1+1
      enddo
      enddo
      nt=nx*ny*2
      nt0=nt

!     Add wrap-around elements
      do iy=1,ny
        nt=nt+2
        nd1=nn-ny+iy-1
        nd2=iy
        ic1(nt-1,1)=nd1
        ic1(nt-1,2)=nd2
        ic1(nt-1,3)=nd2+1
        ic1(nt,1)=nd1
        ic1(nt,2)=nd2+1
        ic1(nt,3)=nd1+1
      enddo !iy

      write(12,*)'hgrid.ll'
      write(12,*)nt,nn
      write(10,*)
      write(10,*)nt,nn
      write(9,*)
      write(9,*)nt,nn
      do i=1,nn
        write(12,100)i,x(i),y(i),50.

        !global coord. (SCHISM)
        x3(i)=r_eq*cos(y(i)/180*pi)*cos(x(i)/180*pi)
        y3(i)=r_eq*cos(y(i)/180*pi)*sin(x(i)/180*pi)
        z3(i)=r_pole*sin(y(i)/180*pi)

        write(98,*)i,x3(i),y3(i),z3(i)
      enddo !i
      write(12,101)(j,3,(ic1(j,i),i=1,3),j=1,nt)

      !Calc side lengths
      rl_min=huge(1.d0)
      rl_max=-rl_min
      do i=1,nt
        do j=1,3
          j1=j+1
          if(j1>3) j1=j1-3
          n1=ic1(i,j); n2=ic1(i,j1)
          rl=sqrt((x3(n1)-x3(n2))**2+(y3(n1)-y3(n2))**2+(z3(n1)-z3(n2))**2)
          rl_min=min(rl_min,rl)
          rl_max=max(rl_max,rl)
          write(99,*)i,j,real(rl)
        enddo !j
      enddo !i
      print*, 'Max/min side length=',rl_max,rl_min,sqrt(dx*dx+dy*dy)

      !Bnd
      write(12,*)0,' = open' !# of open bnd
      write(12,*)0 !total # of open bnd  nodes
      write(12,*)4 !# of land bnd
      write(12,*)(nx+3)*2 !total # of land bnd  nodes
      write(12,*)nx+1,0 !1st land bnd
      do i=1,nx+1
        write(12,*)1+(i-1)*(ny+1)
      enddo !i
      write(12,*)2,0 !2nd land bnd, across dateline
      write(12,*)nn-ny
      write(12,*)1
      write(12,*)2,0 !3rd land bnd
      write(12,*)ny+1
      write(12,*)nn
      write(12,*)nx+1,0 !4th bnd
      do i=1,nx+1
        write(12,*)nn-(i-1)*(ny+1)
      enddo !i

      close(12)

 100  format(i10,3(1x,e16.8))
 101  format(i10,1x,i2,1x,3i9)

      stop
      end


      DOUBLE PRECISION FUNCTION DH2RFG(A, B, X, Y, Z)
C
C  ***  DETERMINE X, Y, Z SO  I + (1,Z)**T * (X,Y)  IS A 2X2
C  ***  HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T,
C  ***  WHERE  C = -SIGN(A)*SQRT(A**2 + B**2)  IS THE VALUE DH2RFG
C  ***  RETURNS.
C
      DOUBLE PRECISION A, B, X, Y, Z
C
      DOUBLE PRECISION A1, B1, C, T
      DOUBLE PRECISION ZERO
      DATA ZERO/0.D+0/
C
C  ***  BODY  ***
C
      IF (B .NE. ZERO) GO TO 10
         X = ZERO
         Y = ZERO
         Z = ZERO
         DH2RFG = A
         GO TO 999
 10   T =  ABS(A) +  ABS(B)
      A1 = A / T
      B1 = B / T
      C =  SQRT(A1**2 + B1**2)
      IF (A1 .GT. ZERO) C = -C
      A1 = A1 - C
      Z = B1 / A1
      X = A1 / C
      Y = B1 / C
      DH2RFG = T * C
 999  RETURN
C  ***  LAST LINE OF DH2RFG FOLLOWS  ***
      END


SUBROUTINE DSBGVX_F95( AB, BB,  W, UPLO, Z, VL, VU, IL, IU, &
      & 	M, IFAIL, Q,  ABSTOL, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP =>  DP
      USE LA_AUXMOD, ONLY: ERINFO, LSAME
      USE F77_LAPACK, ONLY: LAMCH_F77 => DLAMCH
      USE F77_LAPACK, ONLY: SBGVX_F77 => LA_SBGVX
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
      INTEGER, INTENT(IN), OPTIONAL :: IL, IU
      INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
      REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
!  .. ARRAY ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IFAIL(:)
      REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:), Q(:,:)
      REAL(WP), INTENT(INOUT) :: AB(:,:), BB(:,:)
      REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_SBGVX and LA_HBGVX compute selected eigenvalues and, optionally,
! the corresponding eigenvectors of the generalized eigenvalue problem
!                      A*z = lambda*B*z,
! where A and B are real symmetric in the case of LA_SBGVX and complex
! Hermitian in the case of LA_HBGVX. In both cases B is positive
! definite. Matrices A and B are stored in a band format. Eigenvalues
! and eigenvectors can be selected by specifying either a range of
! values or a range of indices for the desired eigenvalues.
!
! =========
!
!           SUBROUTINE LA_SBGVX / LA_HBGVX( AB, BB, W, UPLO=uplo, Z=z, &
!                   VL=vl, VU=vu, IL=il, IU=iu, M=m, IFAIL=ifail, Q=q, &
!                   ABSTOL=abstol, INFO=info )
!              <type>(<wp>), INTENT(INOUT) :: AB(:,:), BB(:,:)
!              REAL(<wp>), INTENT(OUT) :: W(:)
!              CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!              <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!              REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
!              INTEGER, INTENT(IN), OPTIONAL :: IL, IU
!              INTEGER, INTENT(OUT), OPTIONAL :: M
!              INTEGER, INTENT(OUT), OPTIONAL :: IFAIL(:)
!              <type>(<wp>), INTENT(OUT), OPTIONAL :: Q(:,:)
!              REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
!              INTEGER, INTENT(OUT), OPTIONAL :: INFO
!           where
!              <type> ::= REAL | COMPLEX
!              <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! AB       (input/output) REAL or COMPLEX array, shape (:,:) with
!          size(AB,1) = ka + 1 and size(AB,2) = n, where ka is the number
! 	 of subdiagonals or superdiagonals in the band of A and n is
! 	 the order of A and B.
!          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
! 	 triangle of A in band storage. The ka + 1 diagonals of A are
! 	 stored in the rows of AB so that the j-th column of A is
! 	 stored in the j-th column of AB as follows:
! 	 if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j,
! 	                                            1<=j<=n
! 	 if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka),
!                  	                            1<=j<=n.
!        On exit, the contents of AB are destroyed.
! BB     (input/output) REAL or COMPLEX array, shape (:,:) with
!        size(BB,1) = kb + 1 and size(BB,2) = n, where kb is the number
! 	 of subdiagonals or superdiagonals in the band of B.
!        On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
! 	 triangle of matrix B in band storage. The kb + 1 diagonals of
! 	 B are stored in the rows of BB so that the j-th column of B
!        is stored in the j-th column of BB as follows:
! 	 if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j,
! 	                                            1<=j<=n
! 	 if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb),
!                                                   1<=j<=n.
!        On exit, the factor S from the split Cholesky factorization
! 	              B = S^H*S.
! W      (output) REAL array, shape (:) with size(W) = n.
!        The first M elements contain the selected eigenvalues in
! 	 ascending order.
! UPLO   Optional (input) CHARACTER(LEN=1).
!            = 'U': Upper triangles of A and B are stored;
!            = 'L': Lower triangles of A and B are stored.
!        Default value: 'U'.
! Z      Optional (output) REAL or COMPLEX square array, shape (:,:)
!        with size(Z,1) = n.
!        The first M columns of Z contain the orthonormal eigenvectors
! 	 corresponding to the selected eigenvalues, with the i-th
!        column of Z containing the eigenvector associated with the
!        eigenvalue in W(i). The eigenvectors are normalized so that
! 	 Z^H*B*Z = I . If an eigenvector fails to converge, then that
! 	 column of Z contains the latest approximation to the
! 	 eigenvector and the index of the eigenvector is returned in
! 	 IFAIL.
! VL,VU  Optional (input) REAL.
!        The lower and upper bounds of the interval to be searched for
! 	 eigenvalues. VL < VU.
!        Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
! 	 <wp> ::= KIND(1.0) | KIND(1.0D0).
!        Note: Neither VL nor VU may be present if IL and/or IU is
! 	 present.
! IL,IU  Optional (input) INTEGER.
!        The indices of the smallest and largest eigenvalues to be
! 	 returned. The IL-th through IU-th eigenvalues will be found.
! 	 1 <= IL <= IU <= size(A,1).
!        Default values: IL = 1 and IU = size(A,1).
!        Note: Neither IL nor IU may be present if VL and/or VU is
! 	 present.
!        Note: All eigenvalues are calculated if none of the arguments
! 	 VL, VU, IL and IU are present.
! M      Optional (output) INTEGER.
!        The total number of eigenvalues found. 0 <= M <= size(A,1).
!        Note: If IL and IU are present then M = IU - IL + 1.
! IFAIL  Optional (output) INTEGER array, shape (:) with size(IFAIL)=n.
!        If INFO = 0, the first M elements of IFAIL are zero.
!        If INFO > 0, then IFAIL contains the indices of the
! 	 eigenvectors that failed to converge.
!        Note: If Z is present then IFAIL should also be present.
! Q      Optional, (Output) REAL or COMPLEX square array, shape(:,:)
!        with size(Q,1) = n.
!        If Z is present, the matrix used in the reduction of
! 	 A*z = lambda*B*z to tridiagonal form.
! ABSTOL Optional (input) REAL.
!        The absolute error tolerance for the eigenvalues. An
! 	 approximate eigenvalue is accepted as converged when it is
! 	 determined to lie in an interval [a,b] of width less than or
! 	 equal to
!              ABSTOL + EPSILON(1.0_<wp>) * max(|a|,|b|),
!        where <wp> is the working precision. If ABSTOL <= 0, then
! 	 EPSILON(1.0_<wp>) * ||T||1 will be used in its place, where
! 	 ||T||1 is the l1 norm of the tridiagonal matrix obtained by
! 	 reducing the generalized eigenvalue problem to tridiagonal
! 	 form. Eigenvalues will be computed most accurately when ABSTOL
! 	 is set to twice the underflow threshold
! 	            2 * LA_LAMCH(1.0_<wp>, 'S'), not zero.
!        Default value: 0.0_<wp>.
!        Note: If this routine returns with 0 < INFO <= n, then some
! 	 eigenvectors did not converge.
!        Try setting ABSTOL to 2 * LA_LAMCH(1.0_<wp>, 'S').
! INFO   Optional (output) INTEGER.
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value
!        > 0: the algorithm failed to converge or matrix B is not
! 	    positive definite:
!           <= n: the algorithm failed to converge; if INFO = i,
! 	      then i eigenvectors failed to converge. Their indices
! 	      are stored in array IFAIL.
!           > n: if INFO = n + i, for 1 <= i <= n, then the leading
! 	      minor of order i of B is not positive definite. The
! 	      factorization of B could not be completed and no
! 	      eigenvalues or eigenvectors were computed.
!        If INFO is not present and an error occurs, then the program
! 	 is terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SBGVX'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBZ, LUPLO, LRANGE
      INTEGER :: N, LINFO, LDAB, LDBB, LIL, LIU, LM, ISTAT, &
     &  SIFAIL, S1Z, S2Z, S1Q, S2Q, KAB, KBB
      INTEGER, TARGET :: ISTAT1(1)
      REAL(WP), TARGET :: LLZ(1,1), LLQ(1,1)
      REAL(WP) :: LABSTOL, LVL, LVU
!  .. LOCAL ARRAYS ..
      INTEGER, POINTER :: IWORK(:), LIFAIL(:)
      REAL(WP), POINTER :: WORK(:), LQ(:,:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC HUGE, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0
   KAB = SIZE(AB,1)-1; KBB = SIZE(BB,1)-1
   N = SIZE(AB,2); LDAB = MAX(1,SIZE(AB,1))
   LDBB = MAX(1, SIZE(BB,1))
   IF( PRESENT(IFAIL) )THEN; SIFAIL = SIZE(IFAIL); ELSE; SIFAIL = N; END IF
   IF( PRESENT(Q) )THEN; S1Q = SIZE(Q,1); S2Q = SIZE(Q,2)
   ELSE; S1Q = N; S2Q = N; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(VL) )THEN; LVL = VL; ELSE; LVL = -HUGE(LVL); ENDIF
   IF( PRESENT(VU) )THEN; LVU = VU; ELSE; LVU = HUGE(LVU); ENDIF
   IF( PRESENT(IL) )THEN; LIL = IL; ELSE; LIL = 1; ENDIF
   IF( PRESENT(IU) )THEN; LIU = IU; ELSE; LIU = N; ENDIF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2)
   ELSE; S1Z = 1; S2Z = 1; ENDIF
!  .. TEST THE ARGUMENTS
      IF( PRESENT(VL) .OR. PRESENT(VU) )THEN; LRANGE = 'V'
      ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN; LRANGE = 'I'
      ELSE; LRANGE = 'A' ; END IF

      IF( KAB < 0 .OR. N < 0 ) THEN; LINFO = -1
      ELSE  IF (KBB < 0) THEN; LINFO = -2
      ELSE IF( SIZE( W ) /= N )THEN; LINFO = -3
      ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
      ELSE IF( PRESENT(Z) .AND. ( S1Z /= N .OR. S2Z /= N ) )THEN; LINFO = -5
      ELSE IF( LVU < LVL )THEN; LINFO = -6
      ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
     &    (PRESENT(IL) .OR. PRESENT(IU)) )THEN; LINFO = -7
      ELSE IF( LRANGE == 'I' .AND. ( LIU.LT.MIN( N, LIL ) .OR. LIU.GT.N)) THEN; LINFO = -8
      ELSE IF( N < LIU )THEN; LINFO = -9
      ELSE IF( SIFAIL /= N .OR. PRESENT(IFAIL).AND..NOT.PRESENT(Z) )THEN; LINFO = -10
      ELSE IF( S1Q /= N .OR. S2Q /= N .OR. PRESENT(Q).AND..NOT.PRESENT(Z) )THEN; LINFO = -11
      ELSE IF( N > 0 )THEN
          IF( PRESENT(Z) ) THEN; LJOBZ = 'V'
            IF( PRESENT(IFAIL) )THEN; LIFAIL => IFAIL
            ELSE; ALLOCATE( LIFAIL(N), STAT=ISTAT ); END IF
            IF( ISTAT == 0 )THEN
              IF( PRESENT(Q) )THEN; LQ => Q
              ELSE; ALLOCATE( LQ(N,N), STAT=ISTAT ); END IF
            END IF
          ELSE; LJOBZ = 'N'; LIFAIL => ISTAT1; LQ => LLQ; S1Q =1; ENDIF
! .. DETERMINE THE WORKSPACE
          IF( ISTAT == 0 ) THEN
            ALLOCATE(IWORK(MAX(1,5*N)), WORK(MAX(1,7*N)), STAT=ISTAT)
            IF( ISTAT == 0 )THEN
              IF( PRESENT(ABSTOL) )THEN; LABSTOL = ABSTOL
              ELSE; LABSTOL = 2*LAMCH_F77('Safe minimum'); ENDIF
	       IF (PRESENT (Z))  THEN
                CALL SBGVX_F77( LJOBZ, LRANGE, LUPLO, N, KAB, KBB, AB, LDAB, &
     &            BB, LDBB, LQ, S1Q, LVL, LVU, LIL, LIU, LABSTOL, LM, W, Z,&
     &            S1Z, WORK, IWORK, LIFAIL, LINFO )
               ELSE
	        CALL SBGVX_F77( LJOBZ, LRANGE, LUPLO, N, KAB, KBB, AB, LDAB, &
     &            BB, LDBB, LQ, S1Q, LVL, LVU, LIL, LIU, LABSTOL, LM, W, LLZ,&
     &            S1Z, WORK, IWORK, LIFAIL, LINFO )
               ENDIF
                  IF( PRESENT(M) ) M = LM
                ELSE; LINFO = -100; END IF
                END IF
        IF( PRESENT(Z) .AND. .NOT.PRESENT(IFAIL) ) DEALLOCATE( LIFAIL, STAT=ISTAT1(1) )
        IF( PRESENT(Z) .AND. .NOT.PRESENT(Q) ) DEALLOCATE( LQ, STAT=ISTAT1(1) )
        DEALLOCATE(IWORK, WORK, STAT=ISTAT1(1))
      END IF
      CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DSBGVX_F95


      module eqn_state_m
c
        use number_def_m
        use matdat_def_m
c
        implicit none
c
      contains
c
      subroutine getthm_ideal_gas (rho,    ei
     &,                            p,      T,     npro, mater
     &,                            h,      cv,    cp
     &,                            alphaP, betaT, gamb, c)
c
        integer, intent(in) :: npro, mater
        real*8, dimension(npro), intent(out) :: rho,ei
        real*8, dimension(npro), intent(out) :: h,cv,cp,alphaP,betaT,gamb,c
        real*8, dimension(npro), intent(in)  :: p, T
c
        real*8 :: Rgas,gamma,gamma1,mw
c
        mw    = mat_prop(mater,iprop_ideal_gas_mw, 1)
        gamma = mat_prop(mater,iprop_ideal_gas_gamma,1)
        Rgas  = 8314.0d0/mw
        gamma1 = gamma - one
c
        rho = P / (Rgas*T)
        ei  = T * Rgas / gamma1
        h   = T * Rgas / gamma1 * gamma
        cv  = Rgas / gamma1
        cp  = Rgas*gamma / gamma1
        alphaP = one / T
        betaT  = one / P
        gamb = gamma1
        c =  sqrt( gamma * Rgas * T )
c
      end subroutine getthm_ideal_gas
c
      function rho_ideal_gas(p,R,T) result(rho)
        implicit none
        real*8 p,R,T,rho
        rho = p / (R*T)
      end function rho_ideal_gas
c
      subroutine getthm_liquid_1 (rho,    ei
     &,                           p,      T,     npro, mater
     &,                           h,      cv,    cp
     &,                           alphaP, betaT, gamb, c)
c
        integer, intent(in) :: npro, mater
        real*8, dimension(npro), intent(out) :: rho,ei
        real*8, dimension(npro), intent(out) :: h,cv,cp,alphaP,betaT,gamb,c
        real*8, dimension(npro), intent(in)  :: p, T
c
        real*8 :: rho_ref, p_ref, T_ref, alpha_P, beta_T, cv_
c
        rho_ref = mat_prop(mater,iprop_liquid_1_rho_ref,1)
        p_ref   = mat_prop(mater,iprop_liquid_1_p_ref,  1)
        T_ref   = mat_prop(mater,iprop_liquid_1_T_ref,  1)
        cv_     = mat_prop(mater,iprop_liquid_1_cv,     1)
        alpha_P = mat_prop(mater,iprop_liquid_1_alphaP, 1)
        beta_T  = mat_prop(mater,iprop_liquid_1_betaT,  1)
c
        rho = rho_ref * (one - alpha_P*(T-T_ref) + beta_T*(P-P_ref))
        ei  = cv_*T
        h   = ei + P/rho
        cv  = cv_
        cp  = cv_
        alphaP = alpha_P
        betaT  = beta_T
c        c =  sqrt(one/(rho_ref*betaT))
        c =  sqrt(one/(rho*betaT))
        gamb = zero
c
      end subroutine getthm_liquid_1
c
      end module eqn_state_m


program test
  integer :: a(10, 10), b(10,10), c(10, 10)
  integer:: i = 1,j =1,d=10,one=1

  do i = 1,10
    do j = 1,10
      a(j,i) = i
      b(j,i) = j

      IF (i >= 5 .and. j >= 5) THEN
        b(j,i) = b(1,1) + j * j
      END IF

    end do
  end do

  IF (b(1,1) >= 0) THEN
    do i = one,d,one
      j = 1
      do while (j <= d)
        c(j,i) = a(j,i) + b(j,i)
        j = j + 1
      end do
    end do
  END IF

  print *, c
end program test


subroutine sum_of_square(x, y, n)
    implicit none
    integer, intent(in) :: n
    integer :: i
    real(kind=8), intent(in) :: x(n)
    real(kind=8), intent(out) :: y
    y = 0
    do i=1, n
          y = y + x(i)**2
    end do
end


! { dg-do run }
! This tests the fix for PR16940, module interfaces to
! contained functions caused ICEs.
! This is a simplified version of the example in the PR
! discussion, which was due to L.Meissner.
!
! Submitted by Paul Thomas  pault@gcc.gnu.org
!
  module Max_Loc_Mod
    implicit none
    interface Max_Location
      module procedure I_Max_Loc
    end interface
  contains
    function I_Max_Loc (Vector) result(Ans)
      integer, intent (in), dimension(:) :: Vector
      integer, dimension(1) :: Ans
      Ans = maxloc(Vector)
      return
    end function I_Max_Loc
  end module Max_Loc_Mod
  program module_interface
    use Max_Loc_Mod
    implicit none
    integer :: Vector (7)
    Vector = (/1,6,3,5,19,1,2/)
    call Selection_Sort (Vector)
  contains
    subroutine Selection_Sort (Unsorted)
      integer, intent (in), dimension(:) :: Unsorted
      integer, dimension (1) :: N
      N = Max_Location (Unsorted)
      if (N(1).ne.5) call abort ()
      return
    end subroutine Selection_Sort
  end program module_interface

! { dg-final { cleanup-modules "max_loc_mod" } }


module utils

implicit none

double precision :: pi
parameter (pi = 3.1415926535d0)

contains

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

!--------
! Generate an array of linearly spaced values...
function linspace(startval, endval, npoints)
   double precision :: startval, endval, delta
   integer :: i,npoints
   double precision :: linspace(npoints)

   delta = (endval - startval)/(1.0*npoints - 1)

   linspace = startval + (/((i*delta),i=0,(npoints-1))/)
end function linspace

 !--------
 ! Count the number of lines in a file.
function count_lines(fname)
    character(len=*) :: fname
    integer :: count_lines

    character(100) :: tmp

    count_lines = 0
    open (90, file = fname)
    do
        read (90,*, END=10) tmp
        if (.not.(tmp(1:1) == '#')) then
            count_lines = count_lines + 1
        end if
    end do
    10 CLOSE (90)

end function count_lines

!------------
! error function in double precision
function erfun(x)
      implicit double precision (a - h, o - z)
      double precision :: erfun, y
      integer :: i, k
      dimension a(0 : 64), b(0 : 64)
      data (a(i), i = 0, 12) / &
      0.00000000005958930743d0, -0.00000000113739022964d0, &
      0.00000001466005199839d0, -0.00000016350354461960d0, &
      0.00000164610044809620d0, -0.00001492559551950604d0, &
     0.00012055331122299265d0, -0.00085483269811296660d0, &
     0.00522397762482322257d0, -0.02686617064507733420d0, &
    0.11283791670954881569d0, -0.37612638903183748117d0, &
     1.12837916709551257377d0 /
      data (a(i), i = 13, 25) / &
         0.00000000002372510631d0, -0.00000000045493253732d0, &
         0.00000000590362766598d0, -0.00000006642090827576d0, &
         0.00000067595634268133d0, -0.00000621188515924000d0, &
         0.00005103883009709690d0, -0.00037015410692956173d0, &
         0.00233307631218880978d0, -0.01254988477182192210d0, &
         0.05657061146827041994d0, -0.21379664776456006580d0, &
         0.84270079294971486929d0 /
      data (a(i), i = 26, 38) / &
          0.00000000000949905026d0, -0.00000000018310229805d0, &
          0.00000000239463074000d0, -0.00000002721444369609d0, &
         0.00000028045522331686d0, -0.00000261830022482897d0, &
         0.00002195455056768781d0, -0.00016358986921372656d0, &
         0.00107052153564110318d0, -0.00608284718113590151d0, &
         0.02986978465246258244d0, -0.13055593046562267625d0, &
         0.67493323603965504676d0 /
      data (a(i), i = 39, 51) / &
         0.00000000000382722073d0, -0.00000000007421598602d0, &
         0.00000000097930574080d0, -0.00000001126008898854d0, &
         0.00000011775134830784d0, -0.00000111992758382650d0, &
         0.00000962023443095201d0, -0.00007404402135070773d0, &
         0.00050689993654144881d0, -0.00307553051439272889d0, &
         0.01668977892553165586d0, -0.08548534594781312114d0, &
         0.56909076642393639985d0 /
      data (a(i), i = 52, 64) / &
         0.00000000000155296588d0, -0.00000000003032205868d0, &
         0.00000000040424830707d0, -0.00000000471135111493d0, &
         0.00000005011915876293d0, -0.00000048722516178974d0, &
         0.00000430683284629395d0, -0.00003445026145385764d0, &
         0.00024879276133931664d0, -0.00162940941748079288d0, &
         0.00988786373932350462d0, -0.05962426839442303805d0, &
         0.49766113250947636708d0 /
      data (b(i), i = 0, 12) / &
         -0.00000000029734388465d0, 0.00000000269776334046d0, &
         -0.00000000640788827665d0, -0.00000001667820132100d0, &
         -0.00000021854388148686d0, 0.00000266246030457984d0, &
         0.00001612722157047886d0, -0.00025616361025506629d0, &
         0.00015380842432375365d0, 0.00815533022524927908d0, &
         -0.01402283663896319337d0, -0.19746892495383021487d0, &
         0.71511720328842845913d0 /
      data (b(i), i = 13, 25) / &
         -0.00000000001951073787d0, -0.00000000032302692214d0, &
         0.00000000522461866919d0, 0.00000000342940918551d0, &
         -0.00000035772874310272d0, 0.00000019999935792654d0, &
         0.00002687044575042908d0, -0.00011843240273775776d0, &
         -0.00080991728956032271d0, 0.00661062970502241174d0, &
         0.00909530922354827295d0, -0.20160072778491013140d0, &
         0.51169696718727644908d0 /
      data (b(i), i = 26, 38) / &
         0.00000000003147682272d0, -0.00000000048465972408d0, &
         0.00000000063675740242d0, 0.00000003377623323271d0, &
         -0.00000015451139637086d0, -0.00000203340624738438d0, &
         0.00001947204525295057d0, 0.00002854147231653228d0, &
         -0.00101565063152200272d0, 0.00271187003520095655d0, &
         0.02328095035422810727d0, -0.16725021123116877197d0, &
         0.32490054966649436974d0 /
      data (b(i), i = 39, 51) / &
         0.00000000002319363370d0, -0.00000000006303206648d0, &
         -0.00000000264888267434d0, 0.00000002050708040581d0, &
         0.00000011371857327578d0, -0.00000211211337219663d0, &
         0.00000368797328322935d0, 0.00009823686253424796d0, &
         -0.00065860243990455368d0, -0.00075285814895230877d0, &
         0.02585434424202960464d0, -0.11637092784486193258d0, &
         0.18267336775296612024d0 /
      data (b(i), i = 52, 64) / &
         -0.00000000000367789363d0, 0.00000000020876046746d0, &
         -0.00000000193319027226d0, -0.00000000435953392472d0, &
         0.00000018006992266137d0, -0.00000078441223763969d0, &
         -0.00000675407647949153d0, 0.00008428418334440096d0, &
         -0.00017604388937031815d0, -0.00239729611435071610d0, &
         0.02064129023876022970d0, -0.06905562880005864105d0, &
         0.09084526782065478489d0 /
      w = abs(x)
      if (w .lt. 2.2d0) then
          t = w * w
          k = int(t)
          t = t - k
          k = k * 13
          y = ((((((((((((a(k) * t + a(k + 1)) * t + &
             a(k + 2)) * t + a(k + 3)) * t + a(k + 4)) * t +  &
             a(k + 5)) * t + a(k + 6)) * t + a(k + 7)) * t + &
             a(k + 8)) * t + a(k + 9)) * t + a(k + 10)) * t + &
             a(k + 11)) * t + a(k + 12)) * w
      else if (w .lt. 6.9d0) then
          k = int(w)
          t = w - k
          k = 13 * (k - 2)
          y = (((((((((((b(k) * t + b(k + 1)) * t + &
             b(k + 2)) * t + b(k + 3)) * t + b(k + 4)) * t + &
             b(k + 5)) * t + b(k + 6)) * t + b(k + 7)) * t + &
             b(k + 8)) * t + b(k + 9)) * t + b(k + 10)) * t + &
             b(k + 11)) * t + b(k + 12)
          y = y * y
          y = y * y
          y = y * y
          y = 1 - y * y
      else
          y = 1
      end if
      if (x .lt. 0) y = -y
      erfun = y
end function erfun
!

!---------------------------------
!-------Integration routines----
!---------------------------------

! Trapezoidal integration
pure function trapz(x, y) result(r)
    !! Calculates the integral of an array y with respect to x using the trapezoid
    !! approximation. Note that the mesh spacing of x does not have to be uniform.
    double precision, intent(in)  :: x(:)         !! Variable x
    double precision, intent(in)  :: y(size(x))   !! Function y(x)
    double precision             :: r            !! Integral ∫y(x)·dx
    integer :: n

    n = size(x)
    ! Integrate using the trapezoidal rule
    r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
 end function trapz

! Cumulative trapezoidal integration
 pure function cumtrapz(x, y) result(r)
    !! Calculates the integral of an array y with respect to x using the trapezoid
    !! approximation. Note that the mesh spacing of x does not have to be uniform.
    double precision, intent(in)  :: x(:)         !! Variable x
    double precision, intent(in)  :: y(size(x))   !! Function y(x)
    double precision             :: r(size(x))           !! Integral ∫y(x)·dx
    integer :: i, n

    ! Integrate using the trapezoidal rule
    n = size(x)
    do i = 1, n
        r(i) = sum((y(1+1:i-0) + y(1+0:i-1))*(x(1+1:i-0) - x(1+0:i-1)))/2
    end do

end function cumtrapz

 !---------------------------------
 !-------Interpolation routines----
 !---------------------------------

 !--------------
 ! Linear interpolation
 ! Note that this routine does not check for monotonically
 ! ascending values...
function linterp(xdata, ydata, xvals) result(yvals)
    double precision, intent(in) :: xdata(:)
    double precision, intent(in) :: ydata(size(xdata))
    double precision :: xvals(:)
    double precision :: yvals(size(xvals))

    double precision :: min_xdata,max_xdata, weight

    integer :: i, data_index

    min_xdata = xdata(1)
    max_xdata = xdata(size(xdata))

    do i = 1, size(xvals)
        if (xvals(i) < min_xdata) then
            yvals(i) = 0
        else if (xvals(i) > max_xdata) then
            yvals(i) = 0
        else
            data_index = 1
            do while (xdata(data_index+1) < xvals(i))
                data_index = data_index + 1
            end do
            weight = (xvals(i) - xdata(data_index))/(xdata(data_index+1)-xdata(data_index))
            yvals(i) = ydata(data_index) + weight*(ydata(data_index + 1) - ydata(data_index))
        end if
    end do

 end function linterp

 ! Same as linterp, but accepts a single, scalar value
 function linterp_scalar(xdata, ydata, xval) result(yval)
     double precision, intent(in) :: xdata(:)
     double precision, intent(in) :: ydata(size(xdata))
     double precision :: xval
     double precision :: yval

     double precision :: min_xdata,max_xdata, weight

     integer :: data_index

     min_xdata = xdata(1)
     max_xdata = xdata(size(xdata))

    if (xval < min_xdata) then
        yval = 0
    else if (xval > max_xdata) then
        yval = 0
    else
        data_index = 1
        do while (xdata(data_index+1) < xval)
            data_index = data_index + 1
        end do
        weight = (xval - xdata(data_index))/(xdata(data_index+1)-xdata(data_index))
        yval = ydata(data_index) + weight*(ydata(data_index + 1) - ydata(data_index))
    end if

  end function linterp_scalar

  !---------------
  ! Grid interpolation - interpolation on a regular grid
  ! Should in principle be faster than linterp,
  ! but I don't really use it, it's probably not worth it
  function gridinterp(xdata, ydata, xvals) result(yvals)
      double precision, intent(in) :: xdata(:)
      double precision, intent(in) :: ydata(size(xdata))
      double precision :: xvals(:)
      double precision :: yvals(size(xvals))

      double precision :: min_xdata,max_xdata, weight, dx

      integer :: i, data_index

      min_xdata = xdata(1)
      max_xdata = xdata(size(xdata))
      dx = (max_xdata - min_xdata)/float(size(xdata)-1)

      do i = 1, size(xvals)
          if (xvals(i) < min_xdata) then
              yvals(i) = 0
          else if (xvals(i) > max_xdata) then
              yvals(i) = 0
          else
              data_index = ceiling((xvals(i) - min_xdata)/dx)
              weight = (xvals(i) - xdata(data_index))/dx
              yvals(i) = ydata(data_index) + weight*(ydata(data_index + 1) - ydata(data_index))
          end if
      end do

   end function gridinterp

!---------------
function gridinterp_scalar(xdata, ydata, xval) result(yval)
    double precision, intent(in) :: xdata(:)
    double precision, intent(in) :: ydata(size(xdata))
    double precision :: xval
    double precision :: yval

    double precision :: min_xdata,max_xdata, weight, dx

    integer :: data_index

    min_xdata = xdata(1)
    max_xdata = xdata(size(xdata))
    dx = (max_xdata - min_xdata)/float(size(xdata)-1)

    if (xval < min_xdata) then
        yval = 0
    else if (xval > max_xdata) then
        yval = 0
    else
        data_index = ceiling((xval - min_xdata)/dx)
        weight = (xval - xdata(data_index))/dx
        yval = ydata(data_index) + weight*(ydata(data_index + 1) - ydata(data_index))
    end if

end function gridinterp_scalar

end module utils


Submodule ( statistical_data_mod ) statistical_median_smod
!
  Use kind_parameters_mod
  Use quick_sort_data_mod
!
  Implicit None
!
Contains
!
  Module Procedure Statistical_Median
!
     Type ( Quick_Sort_Data )                    :: QS
     Real(KIND=rkind), Allocatable, Dimension(:) :: xcopy
     If ( Size(this%data) .ne. 0 ) Then
        Allocate ( xcopy(Size(this%data)), source=this%data )
        Call QS%sort_data ( xcopy )
        If ( mod(Size(this%data),2) .eq. 0 ) Then
           median = ( xcopy(Size(this%data)/2) + xcopy(Size(this%data)/2+1) ) / 2.0_rkind
        Else
           median = xcopy(Size(this%data)/2+1)
        End If
        Deallocate ( xcopy )
     Else
        median = Huge ( median )
     End If
     this%median = median
     this%Dmedian = .true.
!
  End Procedure Statistical_Median
!
End Submodule statistical_median_smod


! inprod_analytic.f90
!
!>  Inner products between the truncated set of basis functions for the
!>  ocean and atmosphere streamfunction fields.
!>  These are partly calculated using the analytical expressions from
!>  Cehelsky, P., & Tung, K. K. : Theories of multiple equilibria and
!>  weather regimes-A critical reexamination. Part II: Baroclinic two-layer
!>  models. Journal of the atmospheric sciences, 44(21), 3282-3303, 1987.
!
!> @copyright
!> 2015 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!
!
!> @remark
!> Generated Fortran90/95 code
!> from inprod_analytic.lua
!
!---------------------------------------------------------------------------!

MODULE inprod_analytic

  !-----------------------------------------------------!
  !                                                     !
  ! Preamble and variables declaration                  !
  !                                                     !
  !-----------------------------------------------------!

  USE params, only: nbatm, nboc, natm, noc, n, oms, ams, pi
  USE util, only: isin,piksrt
  IMPLICIT NONE

  PRIVATE

  PUBLIC :: init_inprod

  !> Atmospheric bloc specification type
  TYPE :: atm_wavenum
     CHARACTER :: typ
     INTEGER :: M=0,P=0,H=0
     REAL(KIND=8) :: Nx=0.,Ny=0.
  END TYPE atm_wavenum

  !> Oceanic bloc specification type
  TYPE :: ocean_wavenum
     INTEGER :: P,H
     REAL(KIND=8) :: Nx,Ny
  END TYPE ocean_wavenum

  !> Type holding the atmospheric inner products tensors
  TYPE :: atm_tensors
     PROCEDURE(calculate_a), POINTER, NOPASS :: a
     PROCEDURE(calculate_b), POINTER, NOPASS :: b
     PROCEDURE(calculate_c_atm), POINTER, NOPASS :: c
     PROCEDURE(calculate_d), POINTER, NOPASS :: d
     PROCEDURE(calculate_g), POINTER, NOPASS :: g
     PROCEDURE(calculate_s), POINTER, NOPASS :: s
  END TYPE atm_tensors

  !> Type holding the oceanic inner products tensors
  TYPE :: ocean_tensors
     PROCEDURE(calculate_K), POINTER, NOPASS :: K
     PROCEDURE(calculate_M), POINTER, NOPASS :: M
     PROCEDURE(calculate_C_oc), POINTER, NOPASS :: C
     PROCEDURE(calculate_N), POINTER, NOPASS :: N
     PROCEDURE(calculate_O), POINTER, NOPASS :: O
     PROCEDURE(calculate_W), POINTER, NOPASS :: W
  END TYPE ocean_tensors

  !> Atmospheric blocs specification
  TYPE(atm_wavenum), DIMENSION(:), ALLOCATABLE, PUBLIC :: awavenum
  !> Oceanic blocs specification
  TYPE(ocean_wavenum), DIMENSION(:), ALLOCATABLE, PUBLIC :: owavenum

  !> Atmospheric tensors
  TYPE(atm_tensors), PUBLIC :: atmos
  !> Oceanic tensors
  TYPE(ocean_tensors), PUBLIC :: ocean

  !-----------------------------------------------------!
  !                                                     !
  ! End of preamble                                     !
  !                                                     !
  !-----------------------------------------------------!

CONTAINS

  !-----------------------------------------------------!
  !                                                     !
  ! Definition of the Helper functions from Cehelsky    !
  ! & Tung                                              !
  !                                                     !
  !-----------------------------------------------------!

  !>  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION B1(Pi, Pj, Pk)
    INTEGER :: Pi,Pj,Pk
    B1 = (Pk + Pj) / REAL(Pi)
  END FUNCTION B1

  !>  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION B2(Pi, Pj, Pk)
    INTEGER :: Pi,Pj,Pk
    B2 = (Pk - Pj) / REAL(Pi)
  END FUNCTION B2

  !>  Integer Dirac delta function
  REAL(KIND=8) FUNCTION delta(r)
    INTEGER :: r
    IF (r==0) THEN
       delta = 1.D0
    ELSE
       delta = 0.D0
    ENDIF
  END FUNCTION delta

  !>  "Odd or even" function
  REAL(KIND=8) FUNCTION flambda(r)
    INTEGER :: r
    IF (mod(r,2)==0) THEN
       flambda = 0.D0
    ELSE
       flambda = 1.D0
    ENDIF
  END FUNCTION flambda

  !>  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S1(Pj, Pk, Mj, Hk)
    INTEGER :: Pk,Pj,Mj,Hk
    S1 = -((Pk * Mj + Pj * Hk)) / 2.D0
  END FUNCTION S1

  !>  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S2(Pj, Pk, Mj, Hk)
    INTEGER :: Pk,Pj,Mj,Hk
    S2 = (Pk * Mj - Pj * Hk) / 2.D0
  END FUNCTION S2

  !>  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S3(Pj, Pk, Hj, Hk)
    INTEGER :: Pj,Pk,Hj,Hk
    S3 = (Pk * Hj + Pj * Hk) / 2.D0
  END FUNCTION S3

  !>  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S4(Pj, Pk, Hj, Hk)
    INTEGER :: Pj,Pk,Hj,Hk
    S4 = (Pk * Hj - Pj * Hk) / 2.D0
  END FUNCTION S4

  !-----------------------------------------------------!
  ! Inner products definition routines                  !
  !--------------------------------------------------------!
  ! 1. Inner products in the equations for the atmosphere  !
  !--------------------------------------------------------!

  !> Eigenvalues of the Laplacian (atmospheric)
  !>
  !> \f$ a_{i,j} = (F_i, \nabla^2 F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_a(i,j)
    INTEGER, INTENT(IN) :: i,j
    TYPE(atm_wavenum) :: Ti

    calculate_a = 0.D0
    IF (i==j) THEN
       Ti = awavenum(i)
       calculate_a = -(n**2) * Ti%Nx**2 - Ti%Ny**2
    END IF
  END FUNCTION calculate_a

  !> Streamfunction advection terms (atmospheric)
  !>
  !> \f$ b_{i,j,k} = (F_i, J(F_j, \nabla^2 F_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_b(i,j,k)
    INTEGER, INTENT(IN) :: i,j,k

    calculate_b = calculate_a(k,k) * calculate_g(i,j,k)

  END FUNCTION calculate_b

  !> Beta term for the atmosphere
  !>
  !> \f$ c_{i,j} = (F_i, \partial_x F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_c_atm(i,j)
    INTEGER, INTENT(IN) :: i,j
    TYPE(atm_wavenum) :: Ti, Tj

    Ti = awavenum(i)
    Tj = awavenum(j)
    calculate_c_atm = 0.D0
    IF ((Ti%typ == "K") .AND. (Tj%typ == "L")) THEN
       calculate_c_atm = n * Ti%M * delta(Ti%M - Tj%H) * delta(Ti%P - Tj%P)
    ELSE IF ((Ti%typ == "L") .AND. (Tj%typ == "K")) THEN
       Ti = awavenum(j)
       Tj = awavenum(i)
       calculate_c_atm = - n * Ti%M * delta(Ti%M - Tj%H) * delta(Ti%P - Tj%P)
    END IF

  END FUNCTION calculate_c_atm

  !> Forcing of the ocean on the atmosphere.
  !>
  !> \f$ d_{i,j} = (F_i, \nabla^2 \eta_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_d(i,j)
    INTEGER, INTENT(IN) :: i,j

    calculate_d=calculate_s(i,j) * calculate_M(j,j)

  END FUNCTION calculate_d

  !> Temperature advection terms (atmospheric)
  !>
  !> \f$ g_{i,j,k} = (F_i, J(F_j, F_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_g(i,j,k)
    INTEGER, INTENT(IN) :: i,j,k
    TYPE(atm_wavenum) :: Ti,Tj,Tk
    REAL(KIND=8) :: val,vb1, vb2, vs1, vs2, vs3, vs4
    INTEGER, DIMENSION(3) :: a,b
    INTEGER, DIMENSION(3,3) :: w
    CHARACTER, DIMENSION(3) :: s
    INTEGER :: par

    Ti = awavenum(i)
    Tj = awavenum(j)
    Tk = awavenum(k)

    a(1)=i
    a(2)=j
    a(3)=k

    val=0.D0

    IF ((Ti%typ == "L") .AND. (Tj%typ == "L") .AND. (Tk%typ == "L")) THEN

       CALL piksrt(3,a,par)

       Ti = awavenum(a(1))
       Tj = awavenum(a(2))
       Tk = awavenum(a(3))

       vs3 = S3(Tj%P,Tk%P,Tj%H,Tk%H)
       vs4 = S4(Tj%P,Tk%P,Tj%H,Tk%H)
       val = vs3 * ((delta(Tk%H - Tj%H - Ti%H) - delta(Tk%H &
            &- Tj%H + Ti%H)) * delta(Tk%P + Tj%P - Ti%P) +&
            & delta(Tk%H + Tj%H - Ti%H) * (delta(Tk%P - Tj%P&
            & + Ti%P) - delta(Tk%P - Tj%P - Ti%P))) + vs4 *&
            & ((delta(Tk%H + Tj%H - Ti%H) * delta(Tk%P - Tj&
            &%P - Ti%P)) + (delta(Tk%H - Tj%H + Ti%H) -&
            & delta(Tk%H - Tj%H - Ti%H)) * (delta(Tk%P - Tj&
            &%P - Ti%P) - delta(Tk%P - Tj%P + Ti%P)))
    ELSE

       s(1)=Ti%typ
       s(2)=Tj%typ
       s(3)=Tk%typ

       w(1,:)=isin("A",s)
       w(2,:)=isin("K",s)
       w(3,:)=isin("L",s)

       IF (ANY(w(1,:)/=0) .AND. ANY(w(2,:)/=0) .AND. ANY(w(3,:)/=0)) THEN
          b=w(:,1)
          Ti = awavenum(a(b(1)))
          Tj = awavenum(a(b(2)))
          Tk = awavenum(a(b(3)))
          call piksrt(3,b,par)
          vb1 = B1(Ti%P,Tj%P,Tk%P)
          vb2 = B2(Ti%P,Tj%P,Tk%P)
          val = -2 * sqrt(2.) / pi * Tj%M * delta(Tj%M - Tk%H) * flambda(Ti%P + Tj%P + Tk%P)
          IF (val /= 0.D0) val = val * (vb1**2 / (vb1**2 - 1) - vb2**2 / (vb2**2 - 1))
       ELSEIF ((w(2,2)/=0) .AND. (w(2,3)==0) .AND. ANY(w(3,:)/=0)) THEN
          Ti = awavenum(a(w(2,1)))
          Tj = awavenum(a(w(2,2)))
          Tk = awavenum(a(w(3,1)))
          b(1)=w(2,1)
          b(2)=w(2,2)
          b(3)=w(3,1)
          call piksrt(3,b,par)
          vs1 = S1(Tj%P,Tk%P,Tj%M,Tk%H)
          vs2 = S2(Tj%P,Tk%P,Tj%M,Tk%H)
          val = vs1 * (delta(Ti%M - Tk%H - Tj%M) * delta(Ti%P -&
               & Tk%P + Tj%P) - delta(Ti%M- Tk%H - Tj%M) *&
               & delta(Ti%P + Tk%P - Tj%P) + (delta(Tk%H - Tj%M&
               & + Ti%M) + delta(Tk%H - Tj%M - Ti%M)) *&
               & delta(Tk%P + Tj%P - Ti%P)) + vs2 * (delta(Ti%M&
               & - Tk%H - Tj%M) * delta(Ti%P - Tk%P - Tj%P) +&
               & (delta(Tk%H - Tj%M - Ti%M) + delta(Ti%M + Tk%H&
               & - Tj%M)) * (delta(Ti%P - Tk%P + Tj%P) -&
               & delta(Tk%P - Tj%P + Ti%P)))
       ENDIF
    ENDIF
    calculate_g=par*val*n

  END FUNCTION calculate_g

  !> Forcing (thermal) of the ocean on the atmosphere.
  !>
  !> \f$ s_{i,j} = (F_i, \eta_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_s(i,j)
    INTEGER, INTENT(IN) :: i,j
    TYPE(atm_wavenum) :: Ti
    TYPE(ocean_wavenum) :: Dj
    REAL(KIND=8) :: val

    Ti = awavenum(i)
    Dj = owavenum(j)
    val=0.D0
    IF (Ti%typ == "A") THEN
       val = flambda(Dj%H) * flambda(Dj%P + Ti%P)
       IF (val /= 0.D0) THEN
          val = val*8*sqrt(2.)*Dj%P/(pi**2 * (Dj%P**2 - Ti%P**2) * Dj%H)
       END IF
    ELSEIF (Ti%typ == "K") THEN
       val = flambda(2 * Ti%M + Dj%H) * delta(Dj%P - Ti%P)
       IF (val /= 0.D0) THEN
          val = val*4*Dj%H/(pi * (-4 * Ti%M**2 + Dj%H**2))
       END IF
    ELSEIF (Ti%typ == "L") THEN
       val = delta(Dj%P - Ti%P) * delta(2 * Ti%H - Dj%H)
    END IF
    calculate_s=val

  END FUNCTION calculate_s

  !--------------------------------------------------------!
  ! 2. Inner products in the equations for the ocean       !
  !--------------------------------------------------------!

  !> Forcing of the atmosphere on the ocean.
  !>
  !> \f$ K_{i,j} = (\eta_i, \nabla^2 F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_K(i,j)
    INTEGER, INTENT(IN) :: i,j

    calculate_K = calculate_s(j,i) * calculate_a(j,j)
  END FUNCTION calculate_K

  !> Forcing of the ocean fields on the ocean.
  !>
  !> \f$ M_{i,j} = (eta_i, \nabla^2 \eta_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_M(i,j)
    INTEGER, INTENT(IN) :: i,j
    TYPE(ocean_wavenum) :: Di

    calculate_M=0.D0
    IF (i==j) THEN
       Di = owavenum(i)
       calculate_M = -(n**2) * Di%Nx**2 - Di%Ny**2
    END IF
  END FUNCTION calculate_M

  !> Beta term for the ocean
  !>
  !> \f$ N_{i,j} = (\eta_i, \partial_x \eta_j) \f$.
  REAL(KIND=8) FUNCTION calculate_N(i,j)
    INTEGER, INTENT(IN) :: i,j
    TYPE(ocean_wavenum) :: Di,Dj
    REAL(KIND=8) :: val

    Di = owavenum(i)
    Dj = owavenum(j)
    calculate_N = 0.D0
    IF (Dj%H/=Di%H) THEN
       val = delta(Di%P - Dj%P) * flambda(Di%H + Dj%H)
       calculate_N = val * (-2) * Dj%H * Di%H * n / ((Dj%H**2 - Di%H**2) * pi)
    ENDIF

  END FUNCTION calculate_N

  !> Temperature advection term (passive scalar)
  !>
  !> \f$ O_{i,j,k} = (\eta_i, J(\eta_j, \eta_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_O(i,j,k)
    INTEGER, INTENT(IN) :: i,j,k
    TYPE(ocean_wavenum) :: Di,Dj,Dk
    REAL(KIND=8) :: vs3,vs4,val
    INTEGER, DIMENSION(3) :: a
    INTEGER :: par

    val=0.D0

    a(1)=i
    a(2)=j
    a(3)=k

    CALL piksrt(3,a,par)

    Di = owavenum(a(1))
    Dj = owavenum(a(2))
    Dk = owavenum(a(3))

    vs3 = S3(Dj%P,Dk%P,Dj%H,Dk%H)
    vs4 = S4(Dj%P,Dk%P,Dj%H,Dk%H)
    val = vs3*((delta(Dk%H - Dj%H - Di%H) - delta(Dk%H - Dj&
         &%H + Di%H)) * delta(Dk%P + Dj%P - Di%P) + delta(Dk&
         &%H + Dj%H - Di%H) * (delta(Dk%P - Dj%P + Di%P) -&
         & delta(Dk%P - Dj%P - Di%P))) + vs4 * ((delta(Dk%H &
         &+ Dj%H - Di%H) * delta(Dk%P - Dj%P - Di%P)) +&
         & (delta(Dk%H - Dj%H + Di%H) - delta(Dk%H - Dj%H -&
         & Di%H)) * (delta(Dk%P - Dj%P - Di%P) - delta(Dk%P &
         &- Dj%P + Di%P)))
    calculate_O = par * val * n / 2
  END FUNCTION calculate_O

  !> Streamfunction advection terms (oceanic)
  !>
  !> \f$ C_{i,j,k} = (\eta_i, J(\eta_j,\nabla^2 \eta_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_C_oc(i,j,k)
    INTEGER, INTENT(IN) :: i,j,k

    calculate_C_oc = calculate_M(k,k) * calculate_O(i,j,k)

  END FUNCTION calculate_C_oc

  !> Short-wave radiative forcing of the ocean
  !>
  !> \f$ W_{i,j} = (\eta_i, F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_W(i,j)
    INTEGER, INTENT(IN) :: i,j

    calculate_W = calculate_s(j,i)

  END FUNCTION calculate_W

  !-----------------------------------------------------!
  !                                                     !
  ! Initialisation routine                              !
  !                                                     !
  !-----------------------------------------------------!

  !> Initialisation of the inner product
  SUBROUTINE init_inprod
    INTEGER :: i,j
    INTEGER :: AllocStat

    IF (natm == 0 ) THEN
       STOP "*** Problem : natm==0 ! ***"
    ELSEIF (noc == 0) then
       STOP "*** Problem : noc==0 ! ***"
    END IF

    ! Definition of the types and wave numbers tables

    ALLOCATE(owavenum(noc),awavenum(natm), STAT=AllocStat)
    IF (AllocStat /= 0) then
      print *, "init_inprod:: AllocStat = ", AllocStat
      STOP "*** Not enough memory ! ***"
    ENDIF

    j=0
    DO i=1,nbatm
       IF (ams(i,1)==1) THEN
          awavenum(j+1)%typ='A'
          awavenum(j+2)%typ='K'
          awavenum(j+3)%typ='L'

          awavenum(j+1)%P=ams(i,2)
          awavenum(j+2)%M=ams(i,1)
          awavenum(j+2)%P=ams(i,2)
          awavenum(j+3)%H=ams(i,1)
          awavenum(j+3)%P=ams(i,2)

          awavenum(j+1)%Ny=REAL(ams(i,2))
          awavenum(j+2)%Nx=REAL(ams(i,1))
          awavenum(j+2)%Ny=REAL(ams(i,2))
          awavenum(j+3)%Nx=REAL(ams(i,1))
          awavenum(j+3)%Ny=REAL(ams(i,2))

          j=j+3
       ELSE
          awavenum(j+1)%typ='K'
          awavenum(j+2)%typ='L'

          awavenum(j+1)%M=ams(i,1)
          awavenum(j+1)%P=ams(i,2)
          awavenum(j+2)%H=ams(i,1)
          awavenum(j+2)%P=ams(i,2)

          awavenum(j+1)%Nx=REAL(ams(i,1))
          awavenum(j+1)%Ny=REAL(ams(i,2))
          awavenum(j+2)%Nx=REAL(ams(i,1))
          awavenum(j+2)%Ny=REAL(ams(i,2))

          j=j+2

       ENDIF
    ENDDO

    DO i=1,noc
       owavenum(i)%H=oms(i,1)
       owavenum(i)%P=oms(i,2)

       owavenum(i)%Nx=oms(i,1)/2.D0
       owavenum(i)%Ny=oms(i,2)

    ENDDO

    ! Pointing to the atmospheric inner products functions

    atmos%a => calculate_a
    atmos%g => calculate_g
    atmos%s => calculate_s
    atmos%b => calculate_b
    atmos%d => calculate_d
    atmos%c => calculate_c_atm

    ! Pointing to the oceanic inner products functions

    ocean%M => calculate_M
    ocean%N => calculate_N
    ocean%O => calculate_O
    ocean%C => calculate_C_oc
    ocean%W => calculate_W
    ocean%K => calculate_K

  END SUBROUTINE init_inprod

END MODULE inprod_analytic


!***********************************************************************
!                                                                      *
      SUBROUTINE BESSJ(W)
!                                                                      *
!   This routine evaluates Bessel fuctions J K ( W*R/C ) at the grid   *
!   points for K=L-1,L,L+1 and stores  them in the  arrays BJ(..,1),   *
!   BJ(..,2),BJ(..,3) respectively. It uses a power series expansion   *
!   for  small  r and switches to sin/cos expansion when more than 4   *
!   terms in power series are required.                                *
!                                         Last revision: 28 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:35:54   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE bess_C, ONLY: BJ, TC, TD
      USE debug_C, ONLY: LDBPR
      USE grid_C
      USE osc_C, ONLY: LK, KK, L=>LK
      USE DEF_C, ONLY: C, CVAC, PI
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE) , INTENT(IN) :: W
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I1, IW, NN, IEND, IPROD, I, JCHAN, J, ISWAP, MODNN4, &
                 JJ, JJJ, II
      REAL(DOUBLE) :: EPSI, DFN, WR, WA, XBESS1, S1, SSN, SCN, SN, CN, B, SKEEP
!-----------------------------------------------
!
!
      EPSI = 1.0D-05
!
      IW = 1
      NN = L - 1
      IF (KK /= 0) THEN
         IW = 2
         NN = L
      ENDIF
    1 CONTINUE
      IEND = 2*NN + 1
      IPROD = 1
      DO I = 1, IEND, 2
         IPROD = IPROD*I
      END DO
      DFN = IPROD
      JCHAN = N
      BJ(1,IW) = 1.0D00
      DO J = 2, N
         WR = W*R(J)
         WA = -WR*WR*0.5D00
         XBESS1 = 1.0D00
         S1 = 1.0D00
         DO I = 1, 4
            XBESS1 = XBESS1*WA/DBLE(I*(2*(NN + I) + 1))
            S1 = S1 + XBESS1
            IF (ABS(XBESS1) < ABS(S1)*EPSI) GO TO 4
         END DO
         JCHAN = J
         EXIT
    4    CONTINUE
         BJ(J,IW) = S1*WR**NN/DFN
      END DO
!
!   Use sin/cos expansion when power series takes longer
!   than 4 terms to converge
!
      IF (JCHAN < N) THEN
         ISWAP = 0
         MODNN4 = MOD(NN - 1,4) + 1
         SELECT CASE (MODNN4)
!
!   NN = 1, 5, 9, ...
!
         CASE DEFAULT
            SSN = -1.0D00
            SCN = 1.0D00
            ISWAP = 1
!
!   N = 2, 6, 10,....
!
         CASE (2)
            SSN = -1.0D00
            SCN = -1.0D00
!
!   NN = 3, 7, 11,...
!
         CASE (3)
            SSN = 1.0D00
            SCN = -1.0D00
            ISWAP = 1
!
!   NN = 0, 4, 8,...
!
         CASE (4)
            SSN = 1.0D00
            SCN = 1.0D00
         END SELECT
!
   13    CONTINUE
         DO J = JCHAN, N
            WA = W*R(J)
            IF (ISWAP <= 0) THEN
               SN = SSN*SIN(WA)
               CN = SCN*COS(WA)
            ELSE
               SN = SSN*COS(WA)
               CN = SCN*SIN(WA)
            ENDIF
            I = -1
            S1 = 0.0D00
            I = I + 1
            I1 = I
            DO I = I1, NN
               IF (I == 0) THEN
                  B = 1.0D00/WA
               ELSE
                  B = B*DBLE((NN + I)*(NN - I + 1))/DBLE(2*I)/WA
               ENDIF
               S1 = S1 + B*SN
               SKEEP = SN
               SN = CN
               CN = -SKEEP
            END DO
            BJ(J,IW) = S1
         END DO
      ENDIF
      IF (NN>=L + 1 .OR. KK==1) THEN
!
!   Print out Bessel functions if (debug) option set
!
         IF (LDBPR(16)) THEN
            DO JJ = 1, 3
               JJJ = L - 2 + JJ
               WRITE (99, 300) JJJ, (BJ(II,JJ),II=1,N)
            END DO
         ENDIF
!
!   All done
!
! zou
         DO JJ = 1, 3
            JJJ = L - 2 + JJ
            BJ(:N,JJ) = BJ(:N,JJ)*(C/CVAC)**JJJ
         END DO
! zou
         RETURN
      ELSE
         NN = NN + 1
         IW = IW + 1
         GO TO 1
      ENDIF
!
  300 FORMAT(/,' Bessel function of order ',I3,/(1P,7D18.10))
      RETURN
!
      END SUBROUTINE BESSJ


!======================================================================!
  subroutine CalcShear(Ui, Vi, Wi, She)
!----------------------------------------------------------------------!
!  Computes the magnitude of the shear stress.                         !
!----------------------------------------------------------------------!
!  She = sqrt( 2 * Sij * Sij )                                       !
!  Sij = 1/2 ( dUi/dXj + dUj/dXi )                                     !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  use all_mod
  use pro_mod
  use les_mod
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  real          :: Ui(-NbC:NC), Vi(-NbC:NC), Wi(-NbC:NC)
  real          :: She(-NbC:NC)
!-------------------------------[Locals]-------------------------------!
  integer :: c, i
  real    :: Sii, Sjk
!--------------------------------[CVS]---------------------------------!
!  $Id: CalcShearD.f90,v 1.2 2017/08/31 21:40:09 mhadziabdic Exp $
!  $Source: /home/mhadziabdic/Dropbox/cvsroot/T-FlowS-CVS/Process/CalcShearD.f90,v $
!======================================================================!

  call Exchng(Ui)
  call Exchng(Vi)
  call Exchng(Wi)

!===================!
!                   !
!     SGS terms     !
!                   !
!===================!
  do i=1,3

    if(i == 1) then
      call GraPhi(Ui,1,PHIx, .TRUE.)  ! dU/dx
      call GraPhi(Wi,2,PHIy, .TRUE.)  ! dW/dy
      call GraPhi(Vi,3,PHIz, .TRUE.)  ! dV/dz
    end if
    if(i == 2) then
      call GraPhi(Wi,1,PHIx, .TRUE.)  ! dW/dx
      call GraPhi(Vi,2,PHIy, .TRUE.)  ! dV/dy
      call GraPhi(Ui,3,PHIz, .TRUE.)  ! dU/dz
    end if
    if(i == 3) then
      call GraPhi(Vi,1,PHIx, .TRUE.)  ! dV/dx
      call GraPhi(Ui,2,PHIy, .TRUE.)  ! dU/dy
      call GraPhi(Wi,3,PHIz, .TRUE.)  ! dW/dz
    end if

    do c=1,NC
      if(i == 1) then
	Sii = PHIx(c)               ! Sxx:           dU/dx
	Sjk = 0.5*(PHIy(c)+PHIz(c)) ! Syz=Szy:  .5(dV/dz+dW/dy)
	She(c) = ( Sii*Sii + 2.0*Sjk*Sjk )
      end if
      if(i == 2) then
	Sii = PHIy(c)               ! Syy:           dV/dy
	Sjk = 0.5*(PHIx(c)+PHIz(c)) ! Sxz=Szx:  .5(dU/dz+dW/dx)
	She(c) = She(c) + ( Sii*Sii + 2.0*Sjk*Sjk )
      end if
      if(i == 3) then
	Sii = PHIz(c)               ! Szz:           dW/dz
	Sjk = 0.5*(PHIx(c)+PHIy(c)) ! Sxy=Syx:  .5(dV/dx+dU/dy)
	She(c) = She(c) + ( Sii*Sii + 2.0*Sjk*Sjk )
      end if
    end do

  end do  ! i

  She = sqrt(2.0 * She)

  end subroutine CalcShear


program arrayProg
implicit none
 real :: number(5) !ine dimensiomnal array
integer :: matrix(3,3),i, j !two dimensional array
!assigning values to the array
do i = 1,5
   number(i) = i * 2
end do
 do i =1,5
print*, number(i)
end do
do i = 1,3
do j = 1,3
matrix(i,j) = i+j
   end do
end do
do i =1,3
do j = 1,3
print*, matrix(i,j)
end do
end do
number =(/1.5,3.2,5.6,7.1,4.6/)
do i =1,5
print*, number(i)
end do
end program arrayProg


program test_kSpace

	use		constants,			only:			dp, pi_dp
	use		k_space
	use		matrix_math,		only:			is_equal_mat, crossp
	use 	test_helpers,		only:			my_exit,								&
	    										push_to_outFile, write_test_results

	implicit none

	logical,			allocatable		::		passed(:)
	character(len=80), 	allocatable		::		label(:)
	integer								::		nTests, succ_cnt, test
	!
	!
	nTests		=	2
	succ_cnt	=	0
	!
	allocate(	label(nTests)		)
	allocate(	passed(nTests)		)
	!
	!-----------------------------------------------------------
	!-----------------------------------------------------------
	!-----------------------------------------------------------
	!			perform the tests
	!-----------------------------------------------------------
	!
	passed		=	.false.
	!-----------------------------------------------------------
	label(	1)	=	'reciprocal lattice generator'
	passed(	1)	=	test_reciprocal()
	!-----------------------------------------------------------
	label(	2)	=	'BZ integration mesh, test'
	passed(	2)	=	test_k_mesh_int()
	!-----------------------------------------------------------
	!
	!
	do test = 1, nTests
		if(	passed(test)	)	succ_cnt= succ_cnt + 1
	end do
	call write_test_results(	'k space tests(creation & mesh)', passed, label, succ_cnt, nTests	)
	!
	call my_exit(	succ_cnt ==	nTests	)

contains

!
!
!
!
!
!			lattice creation test

	logical function test_reciprocal()
		real(dp)					::		recip_latt(3,3), bz_vol, unit_vol
		real(dp),	allocatable		::		a_latt(:,:,:),	recip_sol(:,:,:)
		integer						::		lattice, nLatt, succ_cnt
		character(len=120)			::		msg
		!
		succ_cnt			=	0
		nLatt				= 	get_test_lattices(a_latt, recip_sol)
		!
		!	perform test for each lattice
		loop_latt:	do lattice	=	1, nLatt
			!
			call set_recip_latt(a_latt(:,:,lattice))
			recip_latt	= get_recip_latt()
			write(*,*)	'[test_reciprocal]:	got recip lattice ',recip_latt
			!
			unit_vol		= dot_product(	crossP(a_latt(1,1:3,lattice),a_latt(2,1:3,lattice)),	a_latt(3,1:3,lattice))
			bz_vol			= get_bz_vol()
			!
			if( abs(bz_vol-	8.0_dp*pi_dp**3/unit_vol	) 	>  1e-10_dp) then
				write(msg,*) '[test_reciprocal]: got bz_vol',bz_vol,' expected',	8.0_dp*pi_dp**3/unit_vol
				call push_to_outFile(msg)
				exit loop_latt
			else if(	is_equal_mat(1e-8_dp	,recip_latt, 	recip_sol(:,:,lattice))			) then
				succ_cnt	= succ_cnt + 1
			else
				write(msg,*) '[test_reciprocal]: test lattice #',lattice,' failed '
				exit loop_latt
			end if
		end do loop_latt
		!
		write(msg,*) '[test_reciprocal]: passed test on ',succ_cnt,' of ',nLatt,' tested lattices'
		call push_to_outFile(msg)
		!
		test_reciprocal	= 	(succ_cnt == nLatt)
		!
		return
	end function

	integer function get_test_lattices(a_latt, b_latt)
		real(dp),		allocatable		::	a_latt(:,:,:), b_latt(:,:,:)
		!
		get_test_lattices	=	1
		!
		allocate(		a_latt(3,3,get_test_lattices)	)
		allocate(		b_latt(3,3,get_test_lattices)	)
		!
		!-------------------------------------------------------
		!		#1			- cubic lattice
		a_latt(:,:,1)	=	0.0_dp
		b_latt(:,:,1)	=	0.0_dp
			!
		a_latt(1,1,1)	=	1.0_dp
		b_latt(1,1,1)	=	2.0_dp * pi_dp
			!
		a_latt(2,2,1)	=	2.0_dp
		b_latt(2,2,1)	=	1.0_dp * pi_dp
			!
		a_latt(3,3,1)	=	- 0.5_dp
		b_latt(3,3,1)	=	-4.0_dp * pi_dp

		!-------------------------------------------------------
		!		#2

		!-------------------------------------------------------
		!-------------------------------------------------------
		!-------------------------------------------------------
		!
		return
	end function

!
!
!
!
!
!
!----------------- k-integration tests	--------------------------------------------------------------------------------------

	logical function test_k_mesh_int()
		!
		!	test function:
		!
		integer					::	mp_grid(3),  mesh, n_meshes
		integer, allocatable	::	nk_dim_lst(:)
		real(dp)				::	int_ana, int_num,	&
									xmax, random,			&
									precision,			&
									a_latt(3,3), recip_latt(3,3)
		character(len=120)		::	msg
		!
		test_k_mesh_int	=	.false.
		precision		=	1.0e-4_dp
		n_meshes		=	9
		!
		!
		allocate(	nk_dim_lst(n_meshes)		)
		!
		nk_dim_lst(1)	=	1
		nk_dim_lst(2)	=	2
		nk_dim_lst(3)	=	4
		nk_dim_lst(4)	=	8
		nk_dim_lst(5)	=	16
		nk_dim_lst(6)	=	32
		nk_dim_lst(7)	=	64
		nk_dim_lst(8)	=	128
		nk_dim_lst(9)	=	256
		!nk_dim_lst(10)	=	257
		!nK_dim_lst(11)	=	512
		!
		!	setup real lattice
		call random_number(random)
		xmax		=	.1_dp *  pi_dp
		a_latt		= 	0.0_dp
		a_latt(1,1)	=	xmax
		a_latt(2,2)	=	xmax
		a_latt(3,3)	=	xmax

		call set_recip_latt(a_latt)
		recip_latt	= get_recip_latt()

		write(msg,*)	"[test_k_mesh_int]: recip_latt bx=",recip_latt(1,:)
		call push_to_outFile(msg)
		write(msg,*)	"[test_k_mesh_int]: recip_latt by=",recip_latt(2,:)
		call push_to_outFile(msg)
		write(msg,*)	"[test_k_mesh_int]: recip_latt bz=",recip_latt(3,:)
		call push_to_outFile(msg)

		int_ana			=	1.0_dp
		write(msg,*)	"[test_k_mesh_int]: analytic integral:	",int_ana
		call push_to_outFile(msg)
		!
		!	refine mesh
		loop_mesh:	do mesh = 1, n_meshes
			!
			!	setup new mesh
			mp_grid(1:3)	=	nk_dim_lst(mesh)
			call set_mp_grid(mp_grid)
			!
			!	do numerical integration
			int_num	=	num_3D_gauss()
			!
			!	compare to analytic solution
			if( abs(int_ana-int_num)	< precision	.and. .not. test_k_mesh_int)	then
				test_k_mesh_int	=	.true.
				!exit loop_mesh
			end if

			write(msg,*)	"[test_k_mesh_int]: #nK_per_dim=",nk_dim_lst(mesh),' int_num ',int_num, " delta=",int_ana-int_num
			call push_to_outFile(msg)

		end do loop_mesh
		!
		!
		if(.not. test_k_mesh_int	) then
			write(msg,*) "[test_k_mesh_int]: the numerical integration did not converge for precision=",precision
			call push_to_outFile(msg)
			write(msg,'(a,f16.8,a,f16.8,a)') '[test_k_mesh]: ana_int=',int_ana,' /= ', int_num,'= num_int'
			call push_to_outFile(msg)
		else
			write(msg,*)	'[test_k_mesh_int]: the k_integration converged for precision=',precision,' on mp_grid: ',mp_grid(1)
			call push_to_outFile(msg)
		end if
		!
		return
	end function

	real(dp) function num_3D_gauss()
		integer						::	kix, kiy, kiz, ki_idx, n_ki, mp_grid(3)
		real(dp)					::	abs_kpt(3), rel_kpt(3), recip_latt(3,3), bz_vol, sigma
		character(len=120)			::	msg

		mp_grid	= get_mp_grid()
		num_3D_gauss	=	0.0_dp
		n_ki			=	0
		!
		!
		recip_latt	=	get_recip_latt()
		sigma	=	abs(	recip_latt(1,1)		/	3.0_dp		)
		bz_vol	=	get_bz_vol()
		write(msg,*)	"[num_3D_gauss]:  bz vol=",bz_vol
		call push_to_outFile(msg)
		!
		do kiz	= 1, mp_grid(3)
			do kiy = 1, mp_grid(2)
				do kix = 1, mp_grid(1)
					!get kpt
					n_ki		= n_ki	+ 1
					ki_idx		=get_kpt_idx(kix,kiy,kiz)
					rel_kpt		= get_rel_kpt(ki_idx, kix,kiy,kiz)
					abs_kpt(:)	= matmul(recip_latt,	rel_kpt)
					!
					!get f(kpt)
					num_3D_gauss	= num_3D_gauss + 	exp( 	-0.5_dp * norm2(abs_kpt)**2 ) 	/	sqrt(2.0_dp*pi_dp)**3
				end do
			end do
		end do
		!
		write(msg,*)	'[num_3D_gauss] raw integral sum=', num_3D_gauss
		call push_to_outFile(msg)
		call normalize_k_int(num_3D_gauss)
		write(*,*)	'[num_3D_gauss] normalized integral=', num_3D_gauss
		call push_to_outFile(msg)
		!
		return
	end function

end program


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine inertia  --  principal moments of inertia  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "inertia" computes the principal moments of inertia for the
c     system, and optionally translates the center of mass to the
c     origin and rotates the principal axes onto the global axes
c
c        mode = 1     print the moments and principal axes
c        mode = 2     move coordinates to standard orientation
c        mode = 3     perform both of the above operations
c
c     literature reference:
c
c     Herbert Goldstein, "Classical Mechanics, 2nd Edition",
c     Addison-Wesley, Reading, MA, 1980; see the Euler angle
c     xyz convention in Appendix B
c
c
      subroutine inertia (mode)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'iounit.i'
      include 'math.i'
      integer i,j,k,mode
      real*8 weigh,total,dot
      real*8 xcm,ycm,zcm
      real*8 xx,xy,xz,yy,yz,zz
      real*8 xterm,yterm,zterm
      real*8 phi,theta,psi
      real*8 moment(3),vec(3,3)
      real*8 tensor(3,3),a(3,3)
      logical print,move
c
c
c     decide upon the type of output desired
c
      print = .false.
      move = .false.
      if (mode.eq.1 .or. mode.eq.3)  print = .true.
      if (mode.eq.2 .or. mode.eq.3)  move = .true.
c
c     compute the position of the center of mass
c
      total = 0.0d0
      xcm = 0.0d0
      ycm = 0.0d0
      zcm = 0.0d0
      do i = 1, n
         weigh = mass(i)
         total = total + weigh
         xcm = xcm + x(i)*weigh
         ycm = ycm + y(i)*weigh
         zcm = zcm + z(i)*weigh
      end do
      xcm = xcm / total
      ycm = ycm / total
      zcm = zcm / total
c
c     compute and then diagonalize the inertia tensor
c
      xx = 0.0d0
      xy = 0.0d0
      xz = 0.0d0
      yy = 0.0d0
      yz = 0.0d0
      zz = 0.0d0
      do i = 1, n
         weigh = mass(i)
         xterm = x(i) - xcm
         yterm = y(i) - ycm
         zterm = z(i) - zcm
         xx = xx + xterm*xterm*weigh
         xy = xy + xterm*yterm*weigh
         xz = xz + xterm*zterm*weigh
         yy = yy + yterm*yterm*weigh
         yz = yz + yterm*zterm*weigh
         zz = zz + zterm*zterm*weigh
      end do
      tensor(1,1) = yy + zz
      tensor(2,1) = -xy
      tensor(3,1) = -xz
      tensor(1,2) = -xy
      tensor(2,2) = xx + zz
      tensor(3,2) = -yz
      tensor(1,3) = -xz
      tensor(2,3) = -yz
      tensor(3,3) = xx + yy
      call jacobi (3,tensor,moment,vec)
c
c     select the direction for each principal moment axis
c
      do i = 1, 2
         do j = 1, n
            xterm = vec(1,i) * (x(j)-xcm)
            yterm = vec(2,i) * (y(j)-ycm)
            zterm = vec(3,i) * (z(j)-zcm)
            dot = xterm + yterm + zterm
            if (dot .lt. 0.0d0) then
               do k = 1, 3
                  vec(k,i) = -vec(k,i)
               end do
            end if
            if (dot .ne. 0.0d0)  goto 10
         end do
   10    continue
      end do
c
c     moment axes must give a right-handed coordinate system
c
      xterm = vec(1,1) * (vec(2,2)*vec(3,3)-vec(2,3)*vec(3,2))
      yterm = vec(2,1) * (vec(1,3)*vec(3,2)-vec(1,2)*vec(3,3))
      zterm = vec(3,1) * (vec(1,2)*vec(2,3)-vec(1,3)*vec(2,2))
      dot = xterm + yterm + zterm
      if (dot .lt. 0.0d0) then
         do j = 1, 3
            vec(j,3) = -vec(j,3)
         end do
      end if
c
c     principal moment axes form rows of Euler rotation matrix
c
      if (move) then
         do i = 1, 3
            do j = 1, 3
               a(i,j) = vec(j,i)
            end do
         end do
c
c     translate to origin, then apply Euler rotation matrix
c
         do i = 1, n
            xterm = x(i) - xcm
            yterm = y(i) - ycm
            zterm = z(i) - zcm
            x(i) = a(1,1)*xterm + a(1,2)*yterm + a(1,3)*zterm
            y(i) = a(2,1)*xterm + a(2,2)*yterm + a(2,3)*zterm
            z(i) = a(3,1)*xterm + a(3,2)*yterm + a(3,3)*zterm
         end do
      end if
c
c     print the center of mass and Euler angle values
c
      if (print) then
         write (iout,20)  xcm,ycm,zcm
   20    format (/,' Center of Mass Coordinates :',8x,3f12.6)
         call invert (3,vec)
         call roteuler (vec,phi,theta,psi)
         phi = radian * phi
         theta = radian * theta
         psi = radian * psi
         write (iout,30)  phi,theta,psi
   30    format (' Euler Angles (Phi/Theta/Psi) : ',5x,3f12.3)
c
c     print the moments of inertia and the principal axes
c
         write (iout,40)
   40    format (/,' Moments of Inertia and Principal Axes :',
     &           //,13x,'Moments (amu Ang^2)',
     &              10x,'X-, Y- and Z-Components of Axes')
         write (iout,50)  (moment(i),vec(1,i),vec(2,i),vec(3,i),i=1,3)
   50    format (3(/,11x,f16.3,10x,3f12.6))
      end if
      return
      end


	FUNCTION XPAACold(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE AC CHANNEL OF THE WIND X PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(10)
C
C	COMPONENT DESIGNATIONS ARE SAME AS SCHEMATIC
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2,Y3,Z3,OPAMPIN
	DATA R9,C9,R10,CINP /5.E8,22.E-12,5.E8,4.51E-12/
	DATA C29,R43,C12,R28/ 1.E-7,47.E+3,15.E-9,100.E+3/
	DATA R29,C13,R12,C26/ 470.,3.3E-9,10.E3,100.E-9/
	DATA C15,R32,C27,R11/ 0.,10.E3,470.E-12,1.5E3/
	DATA C25,R39,C30/470.E-9,330.,33.E-9/
	DATA RCOMP,CCOMP /22.1E3,47.E-12/
	DATA TWOPI /6.2831853/
C
C	TO BE CHANGED FOR Y,Z:  R11,R32,C27,R9,C9,R10
C
	C16 = 1.185E-9                            ! ADJUSTING EY
	C9  = 24.5E-12                            ! ADJUSTING EY
	CINP = 4.757E-12                          ! ADJUSTING EY
C
	C30 = 30.9E-9                     ! ADJUSTING EX
	C13 = 3.7E-9                     ! ADJUSTING EX
C
	C30 = CVAR(1)
	C26 = CVAR(2)
	C25 = CVAR(3)
	C13 = CVAR(4)
	C29 = CVAR(5)
	C12 = CVAR(6)
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
C	THIS PART IS USED TO DETERMINE THE INPUT CAPACITANCE, BUT WHEN
C	THE EXPERIMENT IS INTEGRATED, THIS PART IS COMPENSATED BY A
C	CIRCUIT IN THE MAIN BOX, SO IS TO BE COMMENTED OUT, AND REPLACED
C	BY A FIXED GAIN.
C
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C
C	CGAIN = 3.2
C
C	EFFECT OF OUTPUT OP AMP
C
C	FILTERING BEFORE INPUT
	Z1 = R28                 	! LAST LOAD BEFORE OP AMP
	WC12 = W*C12
	Z2 = CMPLX(R28,-1./WC12)        !  LAST RC
	Y1 = 1./CMPLX(R43,0.) + 1./Z2   !  LAST RC IN PARALLEL WITH R43
	WC29 = W*C29
	Z3 = 1./Y1 + CMPLX(0.,-1./WC29) !  LOAD ON FOLLOWER
	OPAMPIN = CGAIN*(Z1/Z2)*(1./Y1/Z3)
C
C	OP AMP GAIN
C
C	Z3 FROM NEG. INPUT TO GROUND
	WC13 = W*C13
	Z1 = CMPLX(R29,-1./WC13)
	WC26 = W*C26
	Z2 = CMPLX(R12,-1./WC26)
	Y1 = 1./Z1 + 1./Z2                  ! Y FROM NEG INPUT TO GROUND
	Z3 = 1./Y1                          ! Z FROM NEG INPUT TO GROUND
C	Z2 FROM OUTPUT TO NEG INPUT
	WC27 = W*C27
	Z1 = CMPLX(R11,-1./WC27)
	WC15 = W*C15
	Y1 = CMPLX(1./R32,WC15)
	Y2 = Y1 + 1./Z1
	Z2 = 1./Y2
	CGAIN = OPAMPIN*(Z3 + Z2)/Z3
C
C	FILTERING AFTER OP AMP OUTPUT
C
	WC30 = W*C30
	Z1 = CMPLX(R39,-1./WC30)
	WC25 = W*C25
	Z2 = CMPLX(0.,-1./WC25)
	CGAIN = CGAIN*CMPLX(0.,-1./WC30)/(Z2+Z1)
C
C	EFFECT OF INPUT BOARD
C
	WCC = W*CCOMP
	Z1 = CMPLX(0.,-1./WCC)
	Z2 = CMPLX(RCOMP,-1./WCC)
	Z3 = Z1/(Z1+Z2)
C*****************
C	CGAIN = CGAIN*Z3*Z3
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPAAC = CABS(CGAIN)
	RETURN
	END


$ Declare
   SUBROUTINE FactorKr ( a, c, B, W, theta, Ym, Yb, Spm, Spb, Ssm, Ssb, K1C, Lr, Kr )
!
! Parameters
   IMPLICIT NONE
   DOUBLE PRECISION, INTENT(IN)    :: a            ! Crack depth
   DOUBLE PRECISION, INTENT(IN)    :: c            ! Crack width
   DOUBLE PRECISION, INTENT(IN)    :: B            ! Plate thickness
   DOUBLE PRECISION, INTENT(IN)    :: W            ! Plate width
   DOUBLE PRECISION, INTENT(IN)    :: theta        ! FT = 2: Angle in radians (0 => c, pi/2 => a)
   DOUBLE PRECISION, INTENT(IN)    :: Ym           ! Geometric Correction Factor for membrane stress
   DOUBLE PRECISION, INTENT(IN)    :: Yb           ! Geometric Correction Factor for bending stress
   DOUBLE PRECISION, INTENT(IN)    :: Spm          ! primary membrane stress
   DOUBLE PRECISION, INTENT(IN)    :: Spb          ! primary bending stress
   DOUBLE PRECISION, INTENT(IN)	   :: Ssm          ! secondary membrane stress
   DOUBLE PRECISION, INTENT(IN)	   :: Ssb          ! secondary bending stress
   DOUBLE PRECISION, INTENT(IN)	   :: K1C          ! fracture toughness
   DOUBLE PRECISION, INTENT(IN)    :: Lr		   ! plasticity factor
   DOUBLE PRECISION, INTENT(OUT)   :: Kr		   ! fracture factor
!
! Declarations
   DOUBLE PRECISION                :: KIp, KIs, KI, chi, rho1, rho
   DOUBLE PRECISION                :: Mm, Mb, Mmmax
!
! Constants
   DOUBLE PRECISION :: pi
   pi = 3.14159265358979D0
!
! Calculate Kr
	  CALL SIMFactorMm ( a, c, B, W, theta, Mm, Mmmax)
	  CALL SIMFactorMb ( a, c, B, W, theta, Mb)
   	  KIp = (Ym * Spm + Yb * Spb) * DSQRT(pi * a)
      KIs = (Mmmax * Ssm + Mb * Ssb) * DSQRT(pi * a)
	  KI = KIp + KIs
	  chi = (KIs * Lr / KIp)
	  rho1 = 0.1D0 * (chi)**0.714D0 - 0.007D0 * chi * chi + 3.D-5 * (chi)**5
	  IF (chi .GT. 4.D0) THEN
		 STOP 'Error in Subroutine FactorKr: KIs*Lr/KIp >4'
	  ELSE IF (Lr .LE. 0.8D0) THEN
		 rho = rho1
	  ELSE IF (Lr .LT. 1.05D0) THEN
		 rho = 4.D0 * rho1 * (1.05D0 - Lr)
	  ELSE
		 rho = 0.D0
	  END IF
	  Kr = KI/K1C + rho
!
! End subroutine
 RETURN
 END


C
C	$Id: lcm.f,v 1.4 2008-07-27 00:59:03 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      FUNCTION LCM(I,J)
      INTEGER REM
      M=IABS(I)
      N=IABS(J)
      LCM=0
      IF (M.LE.0 .OR. N.LE.0) RETURN
  101 REM=MOD(M,N)
      IF (REM.LE.0) GOTO 102
      M=N
      N=REM
      GOTO 101
  102 LCM=IABS(I*J/N)
      RETURN
      END


chapter xiii, example 3 . test of optimal spline interpolation routine
c			  on titanium heat data .
c  from  * a practical guide to splines *  by c. de boor
calls titand,splopt(bsplvb,banfac/slv),splint(*),bvalue(interv)
c
c     lenscr = (n-k)(2k+3)+5k+3  is the length of scrtch required in
c				 splopt .
c     parameter n=12,ntitan=49,k=5,npk=17,lenscr=119
c     integer i,iflag,ipick(n),ipicki,lx,nmk
c     real a(n),gtitan(ntitan),gtau(ntitan),scrtch(lenscr),t(npk),tau(n)
c    *	  ,x(ntitan)
      real bvalue
      integer i,iflag,ipick(12),ipicki,lx,nmk
      real a(12),gtitan(49),gtau(49),scrtch(119),t(17),tau(12)
     *	  ,x(49)
      data n,k /12,5/
      data ipick /1,5,11,21,27,29,31,33,35,40,45,49/
      call titand ( x, gtitan, lx )
      do 10 i=1,n
	 ipicki = ipick(i)
	 tau(i) = x(ipicki)
   10	 gtau(i) = gtitan(ipicki)
      call splopt ( tau, n, k, scrtch, t, iflag )
      if (iflag .gt. 1) 		stop
      call splint ( tau, gtau, t, n, k, scrtch, a, iflag )
      if (iflag .gt. 1) 		stop
      do 20 i=1,lx
	 gtau(i) = bvalue ( t, a, n, k, x(i), 0 )
   20	 scrtch(i) = gtitan(i) - gtau(i)
      print 620,(i,x(i),gtitan(i),gtau(i),scrtch(i),i=1,lx)
  620 format(41h  i, data point, data, interpolant, error//
     2	       (i3,f8.0,f10.4,f9.4,e11.3))
      nmk = n-k
      print 621,(i,t(k+i),i=1,nmk)
  621 format(///16h optimal knots =/(i5,f15.9))
					stop
      end


     program demo_scale
     use M_calcomp

     character * 28 ichr1
     character * 26 ichr2
     character * 10 lbcd1,lbcd2
     dimension xarray(62),yarray(62)
     ICHR1='PLOTTED ON A CALCOMP PLOTTER'
     ICHR2='USING  Y = X -0.7*X +0.1*X'
     LBCD1='X-ABSCISSA'
     LBCD2='Y-ORDINATE'
     call plots(0.0,10.0,0.0,10.0)
     ! PLOT THREE GRAPHS ILLUSTRATING SCALE, AXIS, AND LINE
     deltax=0.04
     i=1
     ! AXIS DRAWS LABELS AS MUCH AS 0.4 INCHES TO THE NEGATIVE OF AXIS CENTER;
     ! EITHER USE AN ORIGIN OFFSET OF AT LEAST THIS VALUE OR DO NOT USE AN
     ! ORIGIN VALUE OF LESS THAN 0.4 OR CLIPPING WILL OCCUR
     call plot(0.4,0.4,-3)
     deltax=2.0*deltax
     xarray(1)=deltax
     do j=1,60
        yarray(j)=xarray(j)**2-0.7*xarray(j)**3+0.1*xarray(j)**4
        xarray(j+1)=xarray(j)+deltax
     enddo
     call scale(xarray(1), 6.5,60,1)
     call scale(yarray(1),10.0,60,1)
     call axis(0.0,0.0,lbcd1,-10, 6.5, 0.0,xarray(61),xarray(62))
     call axis(0.0,0.0,lbcd2, 10,10.0,90.0,yarray(61),yarray(62))
     call newpen(i)
     call line(xarray(1),yarray(1),60,1,2*(i-2),i)
     call newpen(1)
     call symbol(1.3,10.,.14,ichr1,inteq,0.0,28)
     call symbol(1.3,9.7,.14,ichr2,inteq,0.0,26)
     call number(2.98,9.8,.1,2.0,0.,-1)
     call number(3.96,9.8,.1,3.0,0.,-1)
     call number(4.94,9.8,.1,4.0,0.,-1)

     !call plot(10.0,0.0,-3)
     call plot(0.0,0.0,999)
     end program demo_scale