c
c     file tcuh24cr.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c ... purpose
c
c     test program for the complex MUDPACK solver cuh24cr
c
c ... required MUDPACK files
c
c     cuh24cr.f, cuh2cr.f, cudcom.f
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for cuh24cr
c
c **********************************************************
c **********************************************************
c
c     a sample program/test driver for cuh24cr is below.  it can
c     be executed as an initial test.  the output is listed for
c     the test case described.
c
c     test the driver below by solving the elliptic pde
c
c      cmplx(1.+y*y,1.-y*y)*d(dp/dx)/dx + cmplx(x*y,-x*y)*d(dp/dx)/dy
c
c      cmplx(1.+x*x,1.-x*x)*d(dp/dy)/dy + cmplx(y,-y)*dp/dx +
c
c      cmplx(x,-x)*dp/dy + cmplx(x+y,-x-y)*p(x,y) = r(x,y)
c
c     on the region
c
c       0.25 < x < 1.0, 0.0 < y < 0.50
c
c     with specified boundary conditions at xa=0.25, xb=1.0, yc=0.0
c     and mixed boundary conditions at yd=0.5 of the form:
c
c     cmplx(-x,x)*dp/dx+cmplx(1.+x,1.-x)*dp/dy+cmplx(-x,x)*p(x,yd)=gbdyd(x)
c
c     choose a 45 x 73 grid and use line relaxation in the y direction.
c     forr testing purposes use the exact solution
c
c       p(x,y) = cmplx((x*y)**3,-(x*y)**3) + (1.,1.)
c
c     Choosing grid arguments
c
c       ixp = 11, iex = 3, jyq = 9, jey = 4
c
c     fits the required 45 X 73 grid exactly with the coarsening
c
c       45 X 73 > 23 X 37 > 12 X 19 > 12 X 10
c
c     The 12 X 10 coarsest grid has too many points for effective
c     error reduction with relaxation alone.  cuh2cr maintains
c     multigrid convergence efficiency by utilitzing a direct method
c     (Gaussian elimination) whenever the coarsest grid is encountered
c     within multigrid cycling.  Two cycles with cuh2cr are executed
c     and then cuh24cr is called for a fourth-order estimate
c
c
c ******************************************************
c     output (64 bit floating point arithmetic)
c *******************************************************
c
c     cuh2cr test
c
c     integer input arguments
c     intl =  0 nxa =  1 nxb =  1 nyc =  1 nyd =  2
c     ixp = 11 jyq =  9 iex =  3 jey =  4
c     nx =  45 ny =  73 iguess =  0 maxcy =  2
c     method =  2 work space estimate =   69661
c
c     multigrid option arguments
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  3
c
c     floating point input parameters
c     xa =  0.250 xb =  1.000 yc =  0.000 yd =  0.500
c     tolerance (error control) =    0.000E+00
c
c     discretization call to cuh2cr intl =  0
c     ierror =  0 minimum work space =   69661
c
c     approximation call to cuh2cr
c     intl =  1 method =  2 iguess =  0 maxcy =  2
c     ierror =  0
c     maximum error  =   0.114E-04
c
c     cuh24cr test  ierror =  0
c     maximum error  =   0.739E-07
c
c **********************************************************
c     end of output
c **********************************************************
c
      program tcuh24cr
      implicit none
      integer iixp,jjyq,iiex,jjey,nnx,nny,llw,mmx,mmy
c
c     set grid sizes with parameter statements
c
      parameter (iixp =11 , jjyq = 9 , iiex =3, jjey = 4)
      parameter (mmx = iixp+1,mmy = jjyq+1)
      parameter (nnx=iixp*2**(iiex-1)+1, nny=jjyq*2**(jjey-1)+1)
c
c     set exact minimal required work space (see tcuh2cr.f)
c
      parameter (llw = 69661)
c
c     dimension solution,right hand side, and work arrays
c
      complex p(nnx,nny),r(nnx,nny),w(llw)
      integer iw(mmx,mmy)
c
c     put integer and floating point parameter names in contiguous
c     storeage for labelling purposes
c
      integer iprm(16),mgopt(4)
      real fprm(6)
      integer intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      common/itcuh2cr/intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      real xa,xb,yc,yd,tolmax,relmax
      common/ftcur2/xa,xb,yc,yd,tolmax,relmax
      equivalence(intl,iprm)
      equivalence(xa,fprm)
      integer i,j,ierror
      complex cxx,cxy,cyy,cx,cy,ce,pxx,pxy,pyy,px,py,pe
      real dlx,dly,x,y,errmax
c
c     declare coefficient and boundary condition input subroutines external
c
      external cofcr,bndcr
c
c     set input integer arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 1
      nxb = 1
      nyc = 1
      nyd = 2
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      iex = iiex
      jey = jjey
      nx = nnx
      ny = nny
c
c     set two multigrid cycles
c
      maxcy = 2
c
c     set work space length approximation from parameter statement
c
      nwork = llw
c
c     set point relaxation
c
      method = 2
c
c     flag no initial guess (this sets full multigrid cycling)
c
      iguess = 0
c
c     set end points of solution rectangle in (x,y) space
c
      xa = 0.25
      xb = 1.0
      yc = 0.0
      yd = 0.50
c
c     set mesh increments
c
      dlx = (xb-xa)/float(nx-1)
      dly = (yd-yc)/float(ny-1)
c
c     set for no error control
c
      tolmax = 0.0
c
c     set right hand side in r
c     initialize p to zero
c
      do i=1,nx
	x = xa+float(i-1)*dlx
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call cofcr(x,y,cxx,cxy,cyy,cx,cy,ce)
	  call exact(x,y,pxx,pxy,pyy,px,py,pe)
	  r(i,j) = cxx*pxx+cxy*pxy+cyy*pyy+cx*px+cy*py+ce*pe
	  p(i,j) = (0.0,0.0)
	end do
      end do
c
c     set specified boundaries in p
c
      x = xa
      do j=1,ny
	y = yc+float(j-1)*dly
	call exact(x,y,pxx,pxy,pyy,px,py,pe)
	p(1,j) = pe
      end do
      x = xb
      do j=1,ny
	y = yc+float(j-1)*dly
	call exact(x,y,pxx,pxy,pyy,px,py,pe)
	p(nx,j) = pe
      end do
      y = yc
      do i=1,nx
	x = xa+float(i-1)*dlx
	call exact(x,y,pxx,pxy,pyy,px,py,pe)
	p(i,1) = pe
      end do
c
c     set default multigrid opitons
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     print input arguments
c
      write(6,100)
  100 format(//' cuh2cr test ')
      write (*,101) (iprm(i),i=1,15)
  101 format(/' integer input arguments ',
     +/'intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,' nyd = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' iex = ',i2,' jey = ',i2
     +/' nx = ',i3,' ny = ',i3,' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space estimate = ',i7)
      write (*,102) (mgopt(i),i=1,4)
  102 format(/' multigrid option arguments ',
     +/' kcycle = ',i2,
     +/' iprer = ',i2,
     +/' ipost = ',i2
     +/' intpol = ',i2)
      write(*,103) xa,xb,yc,yd,tolmax
  103 format(/' floating point input parameters ',
     +/' xa = ',f6.3,' xb = ',f6.3,' yc = ',f6.3,' yd = ',f6.3,
     +/' tolerance (error control) =   ',e10.3)
c
c     intiialization call
c
      write(*,104) intl
  104 format(/' discretization call to cuh2cr', ' intl = ', i2)
      call cuh2cr(iprm,fprm,w,iw,cofcr,bndcr,r,p,mgopt,ierror)
c
c     print error parameter and minimum work space requirement
c
      write (*,105) ierror,iprm(16)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     attempt solution
c
      intl = 1
      write(*,106) intl,method,iguess,maxcy
  106 format(/' approximation call to cuh2cr',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2, ' maxcy = ',i2)
      call cuh2cr(iprm,fprm,w,iw,cofcr,bndcr,r,p,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
c
c     compute and print exact maximum error
c
      errmax = 0.0
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+(i-1)*dlx
	  call exact(x,y,pxx,pxy,pyy,px,py,pe)
	  errmax = amax1(errmax,cabs((p(i,j)-pe)))
	end do
      end do
      write(*,108) errmax
  108 format(' maximum error  =  ',e10.3)
c
c     attempt fourth-order estimate with difference corrections
c
      call cuh24cr(w,iw,cofcr,bndcr,p,ierror)
      write (*,109) ierror
  109 format(/ ' cuh24cr test ', ' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
      errmax = 0.0
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+(i-1)*dlx
	  call exact(x,y,pxx,pxy,pyy,px,py,pe)
	  errmax = amax1(errmax,cabs((p(i,j)-pe)))
	end do
      end do
      write(*,108) errmax
      end

      subroutine cofcr(x,y,cxx,cxy,cyy,cx,cy,ce)
c
c     input pde coefficients at any point (x,y) in the solution region
c     (xa.le.x.le.xb,yc.le.y.le.yd) to cuh2cr
c
      implicit none
      complex cxx,cxy,cyy,cx,cy,ce
      real x,y,xa,xb,yc,yd,tolmax,relmax
      common/ftcur2/xa,xb,yc,yd,tolmax,relmax
      cxx = cmplx(1.+y**2,1.-y**2)
      cxy = cmplx(x*y,-x*y)
      cyy = cmplx(1.+x**2,1.-x*x)
      cx = cmplx(y,-y)
      cy = cmplx(x,-x)
      ce = -cmplx((x+y),-x-y)
      return
      end

      subroutine bndcr(kbdy,xory,alfa,beta,gama,gbdy)
c
c     input mixed "oblique" derivative b.c. to cuh2cr
c
      implicit none
      integer kbdy
      real xory,x,y,xa,xb,yc,yd,tolmax,relmax
      complex alfa,beta,gama,gbdy,pe,px,py,pxx,pxy,pyy
      common/ftcur2/xa,xb,yc,yd,tolmax,relmax
      if (kbdy.eq.4) then
c
c     y=yd boundary (nyd must equal 2 if this code is to be executed).
c     b.c. has the form alfyd(x)*px+betyd(x)*py+gamyd(x)*pe = gbdyd(x)
c     where x = yorx.   alfa,beta,gama,gbdy corresponding to alfyd(x),
c     betyd(x),gamyd(x),gbdyd(y) must be output.
c
	y = yd
	x = xory
	alfa = -cmplx(x,-x)
	beta = cmplx(1.+x,1.-x)
	gama = -cmplx(x,-x)
	call exact(x,y,pxx,pxy,pyy,px,py,pe)
	gbdy = alfa*px + beta*py + gama*pe
	return
      end if
      end

      subroutine exact(x,y,pxx,pxy,pyy,px,py,pe)
c
c     this subroutine is used for setting an exact solution in order
c     to test subroutine cuh2cr.
c
      implicit none
      real x,y,xy,xy2,xy3
      complex pxx,pxy,pyy,px,py,pe
      xy = x*y
      xy2 = xy*xy
      xy3 = xy2*xy
      pe = cmplx(xy3,-xy3)
      px = 3.*y*cmplx(xy2,-xy2)
      py = 3.*x*cmplx(xy2,-xy2)
      pxx = 6.*y*y*cmplx(xy,-xy)
      pxy = 9.*xy*cmplx(xy,-xy)
      pyy = 6.*x*x*cmplx(xy,-xy)
      return
      end


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
program main
  use global_variables
  use timer
  implicit none

  write(*,'(A)')'Start qm1d'
  call init_timer
  call input
  call mesh

  call preparation_GS
!  call GS_CG

  call single_particle_GS
!  call IMA_TIME_PROP
  write(*,*)'End single_particle_GS'

  call preparation_RT_collision
!  stop
!  call preparation_RT
  call RT_prop

  call write_results

end program main


program test_arrays
  use mod_arrays
  implicit none

  real(8), allocatable :: y(:)
  real(8), allocatable :: z(:,:)

  integer :: k, l, m, n

  ! Test 1
  m = 15
  call ones_1d(y, m)
  m = size(y, 1)
  call test_vector(y)
  do k = 1, m
    write(*, '(Es11.5)') y(k)
  end do

  print *
  print *

  call ones_2d(z, 3, 2)
  call test_array_2d(z)

  m = size(z, 1)
  n = size(z, 2)

  ! printing columns of z
  do l = 1, n
    do k = 1, m
      write(*, '(Es11.5)') z(k, l)
    end do
    print *
  end do

  deallocate(z)
  deallocate(y)

contains

  subroutine ones_1d(vec, n)
    real(8), allocatable, intent(out) :: vec(:)
    integer, intent(in) :: n
    allocate(vec(n))
    vec = 1.0d0
  end subroutine ones_1d

  subroutine ones_2d(arr, m, n)
    real(8), allocatable, intent(out) :: arr(:,:)
    integer, intent(in) :: m, n
    allocate(arr(m,n))
    arr = 1.0d0
  end subroutine ones_2d

end program test_arrays


C File: arrays-basic-06.f
C This program has a 3-D array with mixed explicit and implicit lower bounds.

      program main
      implicit none

C     A is a 3-D array (5x5x5) of integers with mixed explicit and implicit
C     lower-bounds.
      integer, dimension(-3:1,5,10:14) :: A
      integer :: i, j, k

      do i = -3, 1
        do j = 1,5
          do k = 10, 14
            A(i,j,k) = i+j+k     ! initialize the array
          end do
        end do
      end do

      ! write out the array
      do i = -3, 1
        do j = 1,5
          write (*,10)
     &       A(i,j,10), A(i,j,11), A(i,j,12), A(i,j,13), A(i,j,14)
        end do
      end do

 10   format(5(I5,X))

      stop
      end program main


*> \brief \b SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
*       .. Scalar Arguments ..
*       REAL               A, B, C, D, P, Q
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLADIV performs complex division in  real arithmetic
*>
*>                       a + i*b
*>            p + i*q = ---------
*>                       c + i*d
*>
*> The algorithm is due to Michael Baudin and Robert L. Smith
*> and can be found in the paper
*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is REAL
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is REAL
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL
*>          The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*>          P is REAL
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is REAL
*>          The scalars p and q in the above expression.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date January 2013
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      REAL               A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               BS
      PARAMETER          ( BS = 2.0E0 )
      REAL               HALF
      PARAMETER          ( HALF = 0.5E0 )
      REAL               TWO
      PARAMETER          ( TWO = 2.0E0 )
*
*     .. Local Scalars ..
      REAL               AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLADIV1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
      AA = A
      BB = B
      CC = C
      DD = D
      AB = MAX( ABS(A), ABS(B) )
      CD = MAX( ABS(C), ABS(D) )
      S = 1.0E0

      OV = SLAMCH( 'Overflow threshold' )
      UN = SLAMCH( 'Safe minimum' )
      EPS = SLAMCH( 'Epsilon' )
      BE = BS / (EPS*EPS)

      IF( AB >= HALF*OV ) THEN
         AA = HALF * AA
         BB = HALF * BB
         S  = TWO * S
      END IF
      IF( CD >= HALF*OV ) THEN
         CC = HALF * CC
         DD = HALF * DD
         S  = HALF * S
      END IF
      IF( AB <= UN*BS/EPS ) THEN
         AA = AA * BE
         BB = BB * BE
         S  = S / BE
      END IF
      IF( CD <= UN*BS/EPS ) THEN
         CC = CC * BE
         DD = DD * BE
         S  = S * BE
      END IF
      IF( ABS( D ).LE.ABS( C ) ) THEN
         CALL SLADIV1(AA, BB, CC, DD, P, Q)
      ELSE
         CALL SLADIV1(BB, AA, DD, CC, P, Q)
         Q = -Q
      END IF
      P = P * S
      Q = Q * S
*
      RETURN
*
*     End of SLADIV
*
      END

      SUBROUTINE SLADIV1( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      REAL               A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
*
*     .. Local Scalars ..
      REAL               R, T
*     ..
*     .. External Functions ..
      REAL               SLADIV2
      EXTERNAL           SLADIV2
*     ..
*     .. Executable Statements ..
*
      R = D / C
      T = ONE / (C + D * R)
      P = SLADIV2(A, B, C, D, R, T)
      A = -A
      Q = SLADIV2(B, A, C, D, R, T)
*
      RETURN
*
*     End of SLADIV1
*
      END

      REAL FUNCTION SLADIV2( A, B, C, D, R, T )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      REAL               A, B, C, D, R, T
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
*
*     .. Local Scalars ..
      REAL               BR
*     ..
*     .. Executable Statements ..
*
      IF( R.NE.ZERO ) THEN
         BR = B * R
         if( BR.NE.ZERO ) THEN
            SLADIV2 = (A + BR) * T
         ELSE
            SLADIV2 = A * T + (B * T) * R
         END IF
      ELSE
         SLADIV2 = (A + D * (B / C)) * T
      END IF
*
      RETURN
*
*     End of SLADIV
*
      END


	subroutine stp_interp(s,t,p,n,s0,t0,p0)
ccc
ccc
ccc
ccc	DESCRIPTION :	Interpolate salinity and in situ temperature
ccc			on a cast by linearly interpolating salinity
ccc			and potential temperature
ccc
ccc	PRECISION :	Double
ccc
ccc	INPUT :		s(n)		array of cast salinities
ccc			t(n)		array of cast in situ temperatures
ccc			p(n)		array of cast pressures
ccc			n		length of cast
ccc			p0		pressure for which salinity and
ccc					in situ temperature are required
ccc
ccc	OUTPUT :	s0		interpolated value of salinity
ccc			t0		interpolated value of situ temperature
ccc
ccc	UNITS :		salinities	psu (IPSS-78)
ccc			temperatures	degrees C (IPTS-68)
ccc			pressures	db
ccc
ccc
ccc	AUTHOR :	David Jackett
ccc
ccc	CREATED :	June 1993
ccc
ccc	REVISION :	1.1		30/6/93
ccc
ccc
ccc
	implicit double precision (a-h,o-z)

	dimension s(n),t(n),p(n)

	external indx

	data pr0/0.0/

	call indx(p,n,p0,k)

	r = (p0-p(k))/(p(k+1)-p(k))

	s0 = s(k) + r*(s(k+1)-s(k))

	thk = theta(s(k),t(k),p(k),pr0)

	th0 = thk + r*(theta(s(k+1),t(k+1),p(k+1),pr0)-thk)

	t0 = theta(s0,th0,pr0,p0)

	return
	end


      SUBROUTINE slMXM (A, B, C)
*+
*     - - - -
*      M X M
*     - - - -
*
*  Product of two 3x3 matrices:
*      matrix C  =  matrix A  x  matrix B
*
*  (single precision)
*
*  Given:
*      A      real(3,3)        matrix
*      B      real(3,3)        matrix
*
*  Returned:
*      C      real(3,3)        matrix result
*
*  To comply with the ANSI Fortran 77 standard, A, B and C must
*  be different arrays.  However, the routine is coded so as to
*  work properly on many platforms even if this rule is violated.
*
*  Last revision:   26 December 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL A(3,3),B(3,3),C(3,3)

      INTEGER I,J,K
      REAL W,WM(3,3)

*  Multiply into scratch matrix
      DO I=1,3
         DO J=1,3
            W=0.0
            DO K=1,3
               W=W+A(I,K)*B(K,J)
            END DO
            WM(I,J)=W
         END DO
      END DO

*  Return the result
      DO J=1,3
         DO I=1,3
            C(I,J)=WM(I,J)
         END DO
      END DO

      END


	SUBROUTINE GDXDXY ( grddx, grddy, iret )
C************************************************************************
C* GDXDXY								*
C*									*
C* This subroutine gets the grid increments along x and y directions	*
C* for CED grids.  For all other grids the increments in x and y are	*
C* assumed to be the same and are set to 1.				*
C*									*
C* GDXDXY ( GRDDX, GRDDY, IRET )					*
C*									*
C* Output parameters:							*
C*      GRDDX		REAL		Delta x				*
C*      GRDDY		REAL		Delta y				*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. F. Brill/GSC       7/89  						*
C* S. Jacobs/NMC	 1/95		Fix GRDDX for globe-wrapping grd*
C* T. Lee/SAIC		 3/02		Increased PRJC character size	*
C************************************************************************
	CHARACTER 	prjc*4
C------------------------------------------------------------------------
	iret = 0
C
C*	Call GEMPLT routine to get lat-lon bounds and projection.
C
	CALL GQGPRJ ( prjc, a1, a2, a3, kx, ky, rltll, rlnll,
     +		      rltur, rlnur, iret )
C*
	IF ( iret .ne. 0 ) RETURN
C*
	IF ( prjc .eq. 'CED' .or. prjc .eq. 'MCD' ) THEN
	  rdiff = rlnur - rlnll
	  IF  ( rdiff .eq. 0. )  rdiff = 360.
	  grddx = ABS ( rdiff / FLOAT ( kx - 1 ) )
	  grddy = ABS ( ( rltur - rltll ) / FLOAT ( ky - 1 ) )
	ELSE
          grddx = 1.
	  grddy = 1.
	END IF
C*
	RETURN
	END


program vinay
  print *, (3.0 + 4.0 - 8.2 + 6.666 ** 1)
 end program vinay


! *****************************COPYRIGHT*******************************
! (C) Crown copyright Met Office. All rights reserved.
! For further details please refer to the file COPYRIGHT.txt
! which you should have received as part of this distribution.
! *****************************COPYRIGHT*******************************
! Contains values of all physical constants as parameters
!      CP, R, RATIO_MOL_WTS, G, RLVAP, RLSUB,
! and functions of the above
!      RLVAP_ON_CP, RLSUB_ON_CP, R_ON_CP, G_ON_2
Module physconst

  Use typeKind

  Implicit None

  REAL(WP), PARAMETER :: CP = 1005.
  ! Specific heat of gas at constant pressure
  REAL(WP), PARAMETER :: R = 287.05
  ! Universal gas constant
  REAL(WP), PARAMETER :: RATIO_MOL_WTS = 1.608
  ! Ratio of molecular weights of air and water vapour
  REAL(WP), PARAMETER :: G = 9.81
  ! Acceleration due to gravity
  REAL(WP), PARAMETER :: RLVAP = 2.501e6
  ! Latent heat of vapourisation
  REAL(WP), PARAMETER :: RLSUB = 2.834e6
  ! Latent heat of sublimation
  REAL(WP), PARAMETER :: RLFUS = RLSUB - RLVAP
  ! Latent heat of fusion
  REAL(WP), PARAMETER :: RLVAP_ON_CP = RLVAP/CP
  REAL(WP), PARAMETER :: RLSUB_ON_CP = RLSUB/CP
  REAL(WP), PARAMETER :: RLFUS_ON_CP = RLSUB_ON_CP-RLVAP_ON_CP
  REAL(WP), PARAMETER :: R_ON_CP = R/CP
  REAL(WP), PARAMETER :: G_ON_2 = 0.5*G
  ! Time data which is useful to keep constant
  REAL(WP), PARAMETER ::      &
  &   secinhr   = 3600.   &   ! second in hour
  & , hrinday   = 24.     &   ! hours in day
  & , secsinday = 86400.  &   ! seconds in day
  & , rsecsinday = 1./secsinday

  real(wp), parameter :: p0=100000. ! reference surface pressure
  real(wp), parameter :: pi=3.141592653589793239_wp ! pi

  real(wp), parameter :: tk0c=273.15 ! temperature in Kelvin at
                                     ! 0 degrees C

  real(wp), parameter :: rhoW   = 1000.   ! density of water
  real(wp), parameter :: Rw     = 461.5   ! gas conbstant for water vapour
  real(wp), parameter :: THcond = 0.0243  ! thermal conductivity of air
  real(wp), parameter :: diffWV = 2.26E-5 ! diffusivity of water vapour in air
  real(wp), parameter :: visair = 1.44E-5 ! kinematic viscosity of air
  real(wp), parameter :: Cwater = 4187.   ! specific heat capacity of liquid water
  real(wp), parameter :: Cice   = 2093.   ! specific heat capacity of ice

end Module physconst


module model_sutherlands_law
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: THREE, TWO
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  Sutherland's Law for Laminary Viscosity.
    !!
    !!  Model Fields:
    !!      - Viscosity
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/3/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: sutherlands_law_t

    contains

        procedure   :: init
        procedure   :: compute

    end type sutherlands_law_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(sutherlands_law_t), intent(inout)   :: self

        call self%set_name('Sutherlands Law')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Laminar Viscosity')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing a viscosity contribution from Sutherland's Law.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(sutherlands_law_t),   intent(in)      :: self
        type(chidg_worker_t),       intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: &
            viscosity, T

        real(rk) :: mu0 = 1.7894e-5_rk  ! [kg/(m*s)]
        real(rk) :: T0  = 273.11_rk     ! [K]
        real(rk) :: S   = 110.56_rk     ! [K]

        !
        ! Interpolate solution to quadrature nodes
        !
        T = worker%get_field('Temperature','value')

        !
        ! Sutherlands Law for Laminar Viscosity
        !
        viscosity = mu0*((T/T0)**(THREE/TWO))*(T0+S)/(T+S)

        !
        ! Contribute laminar viscosity
        !
        call worker%store_model_field('Laminar Viscosity', 'value', viscosity)

    end subroutine compute
    !***************************************************************************************

end module model_sutherlands_law


PROGRAM LA_CGGSVD_ET_EXAMPLE
!
!  -- 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 => SP
   USE F95_LAPACK, ONLY: LA_GGSVD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, INFO, M, P, N, K, L
!  .. LOCAL ARRAYS ..
   INTEGER :: IWORK(1:50)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), ALPHA(:), BETA(:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:), B(:,:), U(:,:), V(:,:), Q(:,:), DUMMY(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'CGGSVD ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) M, N, P
   PRINT *, 'M = ', M, ' N = ', N, ' P = ', P
   ALLOCATE ( A(M,N), AA(M,N), B(P,N), BB(P,N), ALPHA(N), BETA(N), &
              U(M,M), V(P,P), Q(N,N) )
!
   READ (NIN, *) AA, BB
   A=AA; B=BB
   WRITE(NOUT,*) 'The matrix A:'
   DO I = 1, M; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:); ENDDO
   WRITE(NOUT,*) 'The matrix B:'
   DO I = 1, P; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) B(I,:); ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_CGGSVD LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U, V, Q, IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U, V, Q,IWORK, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' K = ', K, ' L = ', L
   WRITE(NOUT,*) ' Alpha'
   WRITE(NOUT,FMT) ALPHA
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
   WRITE(NOUT,*) 'U:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) U(:,I); END DO
   WRITE(NOUT,*) 'V:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) V(:,I); END DO
   WRITE(NOUT,*) 'Q:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Q(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B, ALPHA, BETA, INFO=INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA, BETA, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) ' Alpha'
   WRITE(NOUT,FMT) ALPHA
   WRITE(NOUT,*) ' Beta:'
   WRITE(NOUT,FMT) BETA
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( DUMMY, B, ALPHA, BETA, K, L, U, V, Q, IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( DUMMY, B, ALPHA, BETA, K, L, U, V, Q,IWORK, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B(:,1:N-1), ALPHA, BETA, K, L, U, V, Q, IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B(:,1:N-1), ALPHA, BETA, K, L, U, V, Q, IWORK,INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B, ALPHA(1:N-1), BETA, K, L, U, V, Q, IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA(1:N-1), BETA, K, L, U, V, Q, IWORK,INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B, ALPHA, BETA(1:N-1), K, L, U, V, Q,IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA, BETA(1:N-1), K, L, U, V, Q, IWORK,INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U(1:N,:), V, Q,IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U(1:N,:), V, Q, IWORK,INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSV(:,1:M)D( A, B, ALPHA, BETA, K, L, U, V, Q,IWORK, INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U, V(:,1:M), Q, IWORK,INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U, V, Q(:,1:P), IWORK,INFO ) '
   A=AA; B=BB
   CALL LA_GGSVD( A, B, ALPHA, BETA, K, L, U, V, Q(:,1:P),IWORK, INFO)
   WRITE(NOUT,*) 'INFO = ', INFO
!
END PROGRAM LA_CGGSVD_ET_EXAMPLE