!  *********************************************************************
!  *                                                                   *
!  *                         subroutine simpl3                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.3
!  Written by Gordon A. Fenton, TUNS, Jul 15, 2000
!  Latest Update: Feb 28, 2005
!
!  PURPOSE  simulates soil/rock property fields for MRPILL3D
!
!  DESCRIPTION
!  This routine simulates up to 5 soil property fields (cohesion, friction
!  angle, dilation angle, elastic modulus, and Poisson's ratio), which are
!  possibly intercorrelated. Individual fields are generated as standard
!  Gaussian random fields using the 2-D Local Average Subdivision (LAS)
!  algorithm. These fields are then combined to produce correlated standard
!  Gaussian fields using the Covariance Matrix Decomposition approach.
!  Finally the individual fields are transformed so that they have the
!  desired marginal distributions. These transformations are as follows;
!
!	P(x,y) = mean + sd*G(x,y)		if normally distributed
!
!	P(x,y) = exp{ log-mean + log-sd*G(x,y) }if lognormally distributed
!
!	P(x,y) = a + 0.5*(b-a)*[ 1 + tanh((m + s*G(x,y))/2*pi) ]
!						if bounded
!
!  where P(x,y) is the desired random field (one of the soil properties),
!  G(x,y) is one of the standard correlated Gaussian fields, and (mean,sd)
!  and (a,b,m,s) are parameters of the distributions.
!
!  If the property is deterministic, the entire field is simply set to the
!  mean.
!
!  ARGUMENTS
!
!   istat	unit number connected to a file to which the input data is to
!		echoed if echo is true. (input)
!
!   iterm	unit number connected to the screen. If verbos is true, then
!		error and warning messages are also sent to the screen. (input)
!
!  verbos	logical flag which is true if error, warning, and progress
!		messages are allowed to be sent to the screen. (input)
!
!    cfld	real array of size at least (nrfx x nrfy x nrfz) which on
!		output will contain the (optionally random) cohesion field.
!		(output)
!
! phifld	real array of size at least (nrfx x nrfy x nrfz) which on
!		output will contain the (optionally random) friction angle or
!		tan(friction angle) field. (output)
!
! psifld	real array of size at least (nrfx x nrfy x nrfz) which on
!		output will contain the (optionally random) dilation angle
!		field. (output)
!
!   efld	real array of size at least (nrfx x nrfy x nrfz) which on
!		output will contain the (optionally random) elastic modulus
!		field. (output)
!
!   vfld	real array of size at least (nrfx x nrfy x nrfz) which on
!		output will contain the (optionally random) Poisson's ratio
!		field. (output)
!
!	c	real vector of length at least 7 containing the parameters of
!		the soil cohesion. Notably,
!		   c(1) = mean cohesion,
!		   c(2) = cohesion standard deviation,
!		   c(3) = cohesion distribution type;
!			  = 0.0 if cohesion is deterministic (at mean value)
!			  = 1.0 if cohesion is normally distributed
!			  = 2.0 if cohesion is lognormally distributed (logn)
!			  = 3.0 if cohesion is bounded
!		   c(4) = lower bound (bounded), or mean of log-cohesion (logn)
!		   c(5) = upper bound (bounded), or sd of log-cohesion (logn)
!		   c(6) = m parameter (if bounded)
!		   c(7) = s parameter (if bounded)
!		If c is bounded, then c(1) and c(2) are ignored and the
!		parameters c(4) through c(7) completely describe the
!		distribution. (input)
!
!    phi	real vector of length at least 7 containing the parameters of
!		soil friction angle. See `c' for what the various elements of
!		phi contain. (input)
!
!    psi	real vector of length at least 7 containing the parameters of
!		soil dilation angle. See `c' for what the various elements of
!		psi contain. (input)
!
!	e	real vector of length at least 7 containing the parameters of
!		soil elastic modulus. See `c' for what the various elements of
!		e contain. (input)
!
!	v	real vector of length at least 7 containing the parameters of
!		soil Poisson ratio. See `c' for what the various elements of
!		v contain. (input)
!
!	R	real array of size at least 5 x 5 which, on output, will
!		contain the correlation matrix between the 5 (possibly)
!		random soil properties.  Indexing into R is as follows;
!		  1 = cohesion
!		  2 = friction angle
!		  3 = dilation angle
!		  4 = elastic modulus
!		  5 = Poisson's ratio
!		(input)
!
!   lxfld	logical flag which is true if more than one soil property
!		are cross-correlated. That is, if all soil properties are
!		independent, then lxfld is false. (input)
!
!     thx	real value giving the x-direction scale of fluctuation
!		(or, at least, this is the 1st parameter of the variance
!		function). (input)
!
!     thy	real value giving the y-direction scale of fluctuation
!		(or, at least, this is the 2nd parameter of the variance
!		function). (input)
!
!     thz	real value giving the z-direction scale of fluctuation
!		(or, at least, this is the 3rd parameter of the variance
!		function). (input)
!
!    nrfx	integer giving the number of elements describing the random
!		field in the x-direction (width). (input)
!
!    nrfy	integer giving the number of elements describing the random
!		field in the y-direction (depth). (input)
!
!    nrfz	integer giving the number of elements describing the random
!		field in the z-direction (height). (input)
!
!      dx	real value giving the physical size of an element in the
!		x-direction. (input)
!
!      dy	real value giving the physical size of an element in the
!		y-direction. (input)
!
!      dz	real value giving the physical size of an element in the
!		z-direction. (input)
!
!  dmpfld	logical flag which is true if a random field is to be
!		plotted to *.fld. (input)
!
!    nfld	integer giving the realization number of the random field
!		which is to be plotted to *.fld. (input)
!
!    jfld	integer denoting which random field is to be plotted;
!		 = 1 for the cohesion (c) field,
!		 = 2 for the friction angle (phi) field,
!		 = 3 for the dilation angle (psi) field,
!		 = 4 for the elastic modulus (psi) field,
!		 = 5 for the poisson ratio (psi) field,
!		(input)
!
!   ieplt	integer vector of length at least 3 containing the element
!		indices corresponding to the plane over which the random field
!		plot is to be drawn. The elements of ieplt correspond
!		to the (x,y,z) element indices and zero values in this vector
!		correspond to all elements in that direction. Only one of the
!		components is expected to be non-zero. So, for example, the
!		vector (0,26,0) means that the x-z plane at y-element = 26 is
!		to be drawn. If a 50 x 50 x 30 element domain has two
!		footings, one centered at x-node = 26 and y-node = 15 and
!		the other centered at x-node = 26 and y-node = 35, then
!		normally the y-z plane through x-node = 26 would be drawn
!		to see the random field under the two footings. Thus, in this
!		case, idplt might be (25,0,0) or (26,0,0) (depending on which
!		side of the nodal plane you want to be on). The z-indices are
!		measured from the top surface of the soil mass, thus z = 1 is
!		the top layer of the soil mass and z = nze is the bottom
!		layer, etc. (input)
!
!    ifld	unit number connected to the file to which the random field
!		plot is to be written in the event that dmpfld is true.
!		(input)
!
!     job	character string containing the main title of the run.
!		(input)
!
!    sub1	character string, which on output will contain the first
!		subtitle for this run. (output)
!
!    sub2	character string, which on output will contain the second
!		subtitle for this run. (output)
!
!  varfnc	character string containing the name of the variance
!		function controlling the random fields. Possible variance
!		functions are (input)
!		`dlavx3' - 3-D exponentially decaying (Markov) model
!			   requires X-, Y-, and Z-direction scales of
!			   fluctuation
!		`dlafs3' - 3-D partially separable fractional Gaussian noise
!			   model. Requires (H,G,delta) as parameters. In this
!			   case, thx is H, thy is G, and delta is the minimum
!			   element dimension. G is assumed to apply in the
!			   Y-Z plane.
!		`dlsep3' - 3-D separable (1D x 1D x 1D) Markov model
!			   requires X-, Y-, and Z-direction scales of
!			   fluctuation
!		`dlsfr3' - 3-D separable fractional Gaussian noise model
!			   requires (H_x,H_y,H_z,delta) as parameters. In this
!			   case, thx is H_x, thy is H_y, thz is H_z, and
!			   delta is the minimum element dimension.
!		`dlspx3' - 3-D separable Gaussian decaying model
!			   requires X-, Y-, and Z-direction scales of
!			   fluctuation.
!
!   kseed	integer giving the seed to be used to initialize the
!		pseudo-random number generator. Subsequent runs using
!		the same seed will result in the same sequence of random
!		numbers. (input)
!
!   debug	logical flag which is true if debug information is to be
!		sent to the *.stt file. (input)
!
!  REVISION HISTORY:
!  1.1	eliminate lvarfn, corrected computation of pb, ZL corrected (Feb 13/02)
!  1.2	added ieplt(*) to specify RF output plot plane (Feb 28/05)
!-------------------------------------------------------------------------
      subroutine simpl3(istat,iterm,verbos,cfld,phifld,psifld,gamfld,efld,&
	                   vfld,c,phi,psi,gam,e,v,R,lxfld,thx,thy,thz,nrfx,   &
                       nrfy,nrfz,dx,dy,dz,dmpfld,nfld,jfld,ieplt,         &
                       ifld,job,sub1,sub2,varfnc,kseed,debug)

      real cfld(nrfx,nrfy,*), phifld(nrfx,nrfy,*), psifld(nrfx,nrfy,*),   &
	       gamfld(nrfx,nrfy,*)
      real efld(nrfx,nrfy,*), vfld(nrfx,nrfy,*)
      real c(*), phi(*), psi(*), gam(*),e(*), v(*), R(6,*), thx, thy, thz
      real dx, dy, dz
      integer nrfx, nrfy, nrfz, nfld, ifld, ieplt(*)
      character*(*) job, sub1, sub2, varfnc
      logical verbos, dmpfld, debug, liid, shofld, lxfld
      real*8 dvar, dpb, dthx, dthy, dthz
      real*8 dlavx3, dlsep3, dlspx3, dlafs3, dlsfr3
      save XL, YL, ZL, ienter, liid
      external dlavx3, dlsep3, dlspx3, dlafs3, dlsfr3
      common/dparam/ dvar, dpb, dthx, dthy, dthz
      data zero/0.0/, half/0.5/, one/1.0/, onept5/1.5/, twopt5/2.5/
      data twopi/6.2831853071795864769d0/
      data ienter/0/

   1  format(a,a)

!-------------------------------------- initialize -------------------------
!					compute required field size (once)
      ienter = ienter + 1
      if( ienter .eq. 1 ) then
         liid   = (thx .eq. zero) .and. (thy .eq. zero) .and.             &
                 (thz .eq. zero)
         XL     = float(nrfx)*dx
         YL     = float(nrfy)*dy
         ZL     = float(nrfz)*dz

         if( debug ) then
            write(istat,1)'simpl3: initializing field parameters...'
            call flush(istat)
         endif

         if( .not. liid ) then
!						set covariance fnc parameters
            dvar   = 1.d0
            dthx   = thx
            dthy   = thy
            dthz   = thz
            if( varfnc .eq. 'dlafs3' .or. varfnc .eq. 'dlsfr3' ) then
               pb = dx
               if( dy .lt. pb ) pb = dy
               if( dz .lt. pb ) pb = dz
               dpb = pb
            endif
!						initialize LAS2G
            if( varfnc .eq. 'dlavx3' ) then
               call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,            &
                         kseed,-1,istat)
            elseif( varfnc .eq. 'dlsep3' ) then
               call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,            &
                         kseed,-1,istat)
            elseif( varfnc .eq. 'dlspx3' ) then
               call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,            &
                         kseed,-1,istat)
            elseif( varfnc .eq. 'dlafs3' ) then
               call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,            &
                         kseed,-1,istat)
            elseif( varfnc .eq. 'dlsfr3' ) then
               call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,            &
                         kseed,-1,istat)
            else
               if( verbos ) then
                  write(iterm,1)                                          &
                 '*** Error: unknown variance function name: ', varfnc
               endif
               write(istat,1)                                             &
                 '*** Error: unknown variance function name: ', varfnc
               stop
            endif
         endif
         if( debug ) then
            write(istat,1)'simpl3: finished initialization...'
            call flush(istat)
         endif
      endif
!					are we going to plot anything?
      shofld = dmpfld .and. (nfld .eq. ienter)

!					now produce 6 standard normal fields
!					for cohesion...
      if( c(3) .lt. half ) then			! cohesion is deterministic
         do 10 k = 1, nrfz
         do 10 j = 1, nrfy
         do 10 i = 1, nrfx
            cfld(i,j,k) = zero			! we'll add mean back on later
  10     continue
      elseif( liid ) then			! white noise field
         do 20 k = 1, nrfz
         do 20 j = 1, nrfy
         do 20 i = 1, nrfx
            cfld(i,j,k) = gausv(one)
  20     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx3' ) then
            call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsep3' ) then
            call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlspx3' ) then
            call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlafs3' ) then
            call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr3' ) then
            call las3g(cfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,               &
                      kseed,0,istat)
         endif
      endif
!					for friction angle...
      if( phi(3) .lt. half ) then		! friction is deterministic
         do 30 k = 1, nrfz
         do 30 j = 1, nrfy
         do 30 i = 1, nrfx
            phifld(i,j,k) = zero		! we'll add mean back on later
  30     continue
      elseif( liid ) then			! white noise field
         do 40 k = 1, nrfz
         do 40 j = 1, nrfy
         do 40 i = 1, nrfx
            phifld(i,j,k) = gausv(one)
  40     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx3' ) then
            call las3g(phifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsep3' ) then
            call las3g(phifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlspx3' ) then
            call las3g(phifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlafs3' ) then
            call las3g(phifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr3' ) then
            call las3g(phifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,             &
                      kseed,0,istat)
         endif
      endif
!					for dilation angle...
      if( psi(3) .lt. half ) then		! dilation is deterministic
         do 50 k = 1, nrfz
         do 50 j = 1, nrfy
         do 50 i = 1, nrfx
            psifld(i,j,k) = zero		! we'll add mean back on later
  50     continue
      elseif( liid ) then			! white noise field
         do 60 k = 1, nrfz
         do 60 j = 1, nrfy
         do 60 i = 1, nrfx
            psifld(i,j,k) = gausv(one)
  60     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx3' ) then
            call las3g(psifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsep3' ) then
            call las3g(psifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlspx3' ) then
            call las3g(psifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlafs3' ) then
            call las3g(psifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,             &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr3' ) then
            call las3g(psifld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,             &
                      kseed,0,istat)
         endif
      endif
!					for elastic modulus...
      if( e(3) .lt. half ) then		! modulus is deterministic
         do 70 k = 1, nrfz
         do 70 j = 1, nrfy
         do 70 i = 1, nrfx
            efld(i,j,k) = zero			! we'll add mean back on later
  70     continue
      elseif( liid ) then			! white noise field
         do 80 k = 1, nrfz
         do 80 j = 1, nrfy
         do 80 i = 1, nrfx
            efld(i,j,k) = gausv(one)
  80     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx3' ) then
            call las3g(efld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsep3' ) then
            call las3g(efld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlspx3' ) then
            call las3g(efld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlafs3' ) then
            call las3g(efld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr3' ) then
            call las3g(efld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,               &
                      kseed,0,istat)
         endif
      endif
!					for Poisson's ratio...
      if( v(3) .lt. half ) then		! ratio is deterministic
         do 90 k = 1, nrfz
         do 90 j = 1, nrfy
         do 90 i = 1, nrfx
            vfld(i,j,k) = zero			! we'll add mean back on later
  90     continue
      elseif( liid ) then			! white noise field
         do 100 k = 1, nrfz
         do 100 j = 1, nrfy
         do 100 i = 1, nrfx
            vfld(i,j,k) = gausv(one)
 100     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx3' ) then
            call las3g(vfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsep3' ) then
            call las3g(vfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlspx3' ) then
            call las3g(vfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlafs3' ) then
            call las3g(vfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr3' ) then
            call las3g(vfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,               &
                      kseed,0,istat)
         endif
      endif
!					for Unit weight...
      if( gam(3) .lt. half ) then		! ratio is deterministic
         do 901 k = 1, nrfz
         do 901 j = 1, nrfy
         do 901 i = 1, nrfx
            gamfld(i,j,k) = zero			! we'll add mean back on later
  901     continue
      elseif( liid ) then			! white noise field
         do 1001 k = 1, nrfz
         do 1001 j = 1, nrfy
         do 1001 i = 1, nrfx
            gamfld(i,j,k) = gausv(one)
 1001     continue
      else					! generate standard normal
         if( varfnc .eq. 'dlavx3' ) then
            call las3g(gamfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlavx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsep3' ) then
            call las3g(gamfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsep3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlspx3' ) then
            call las3g(gamfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlspx3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlafs3' ) then
            call las3g(gamfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlafs3,               &
                      kseed,0,istat)
         elseif( varfnc .eq. 'dlsfr3' ) then
            call las3g(gamfld,nrfx,nrfy,nrfz,XL,YL,ZL,dlsfr3,               &
                      kseed,0,istat)
         endif
      endif
!					combine for correlated fields...
      if( lxfld ) then
         do 110 k = 1, nrfz
         do 110 j = 1, nrfy
         do 110 i = 1, nrfx
            vfld(i,j,k)   = R(1,6)*cfld(i,j,k)   + R(2,6)*phifld(i,j,k)   &
                         + R(3,6)*psifld(i,j,k) + R(4,6)*gamfld(i,j,k)    &
						 + R(5,6)*efld(i,j,k)   + R(6,6)*vfld(i,j,k)
            efld(i,j,k)   = R(1,5)*cfld(i,j,k)   + R(2,5)*phifld(i,j,k)   &
                         + R(3,5)*psifld(i,j,k) + R(4,5)*gamfld(i,j,k)    &
						 + R(5,5)*efld(i,j,k)
            gamfld(i,j,k)  = R(1,4)*cfld(i,j,k)   + R(2,4)*phifld(i,j,k)   &
                         + R(3,4)*psifld(i,j,k) + R(4,4)*gamfld(i,j,k)
            psifld(i,j,k) = R(1,3)*cfld(i,j,k)   + R(2,3)*phifld(i,j,k)   &
                         + R(3,3)*psifld(i,j,k)
            phifld(i,j,k) = R(1,2)*cfld(i,j,k)   + R(2,2)*phifld(i,j,k)
 110     continue
      endif
!					plot the random field?
      if( shofld ) then
         if( jfld .eq. 1 ) then
	    call pltfld( job, sub1, sub2, cfld, nrfx, nrfy,                   &
     		         nrfx, nrfy, nrfz, XL, YL, ZL, ieplt,                 &
                     '(Underlying) Cohesion Field', ifld )
         elseif( jfld .eq. 2 ) then
	    call pltfld( job, sub1, sub2, phifld, nrfx, nrfy,                 &
     		         nrfx, nrfy, nrfz, XL, YL, ZL, ieplt,                 &
     		     '(Underlying) Friction Angle Field', ifld )
         elseif( jfld .eq. 3 ) then
	    call pltfld( job, sub1, sub2, psifld, nrfx, nrfy,                 &
     		         nrfx, nrfy, nrfz, XL, YL, ZL, ieplt,                 &
     		     '(Underlying) Dilation Angle Field', ifld )
           elseif( jfld .eq. 4 ) then
	    call pltfld( job, sub1, sub2, gamfld, nrfx, nrfy,                   &
     		         nrfx, nrfy, nrfz, XL, YL, ZL, ieplt,                 &
     		     '(Underlying) Elastic Modulus Field', ifld )
         elseif( jfld .eq. 5 ) then
	    call pltfld( job, sub1, sub2, efld, nrfx, nrfy,                   &
     		         nrfx, nrfy, nrfz, XL, YL, ZL, ieplt,                 &
     		     '(Underlying) Elastic Modulus Field', ifld )
         elseif( jfld .eq. 6 ) then
	    call pltfld( job, sub1, sub2, vfld, nrfx, nrfy,                   &
     		         nrfx, nrfy, nrfz, XL, YL, ZL, ieplt,                 &
     		     '(Underlying) Poisson''s Ratio Field', ifld )
         endif
      endif
!					convert to final fields
!					for cohesion...
      if( c(3) .lt. half ) then				! deterministic
         do 120 k = 1, nrfz
         do 120 j = 1, nrfy
         do 120 i = 1, nrfx
            cfld(i,j,k) = c(1)
 120     continue
      elseif( c(3) .lt. onept5 ) then			! normal
         do 130 k = 1, nrfz
         do 130 j = 1, nrfy
         do 130 i = 1, nrfx
            cfld(i,j,k) = c(1) + c(2)*cfld(i,j,k)
 130     continue
      elseif( c(3) .lt. twopt5 ) then			! lognormal
         do 140 k = 1, nrfz
         do 140 j = 1, nrfy
         do 140 i = 1, nrfx
            cfld(i,j,k) = exp( c(4) + c(5)*cfld(i,j,k) )
 140     continue
      else						! bounded
         do 150 k = 1, nrfz
         do 150 j = 1, nrfy
         do 150 i = 1, nrfx
            cfld(i,j,k) = c(4) + half*(c(5)-c(4))                         &
               *( one + tanh((c(6)+c(7)*cfld(i,j,k))/twopi) )
 150     continue
      endif
!					for friction angle...
      if( phi(3) .lt. half ) then			! deterministic
         do 160 k = 1, nrfz
         do 160 j = 1, nrfy
         do 160 i = 1, nrfx
            phifld(i,j,k) = phi(1)
 160     continue
      elseif( phi(3) .lt. onept5 ) then			! normal
         do 170 k = 1, nrfz
         do 170 j = 1, nrfy
         do 170 i = 1, nrfx
            phifld(i,j,k) = phi(1) + phi(2)*phifld(i,j,k)
 170     continue
      elseif( phi(3) .lt. twopt5 ) then			! lognormal
         do 180 k = 1, nrfz
         do 180 j = 1, nrfy
         do 180 i = 1, nrfx
            phifld(i,j,k) = exp( phi(4) + phi(5)*phifld(i,j,k) )
 180     continue
      else						! bounded
         do 190 k = 1, nrfz
         do 190 j = 1, nrfy
         do 190 i = 1, nrfx
            phifld(i,j,k) = phi(4) + half*(phi(5)-phi(4))                 &
                     *(one + tanh((phi(6)+phi(7)*phifld(i,j,k))/twopi))
 190     continue
      endif
!					for dilation angle...
      if( psi(3) .lt. half ) then			! deterministic
         do 200 k = 1, nrfz
         do 200 j = 1, nrfy
         do 200 i = 1, nrfx
            psifld(i,j,k) = psi(1)
 200     continue
      elseif( psi(3) .lt. onept5 ) then			! normal
         do 210 k = 1, nrfz
         do 210 j = 1, nrfy
         do 210 i = 1, nrfx
            psifld(i,j,k) = psi(1) + psi(2)*psifld(i,j,k)
 210     continue
      elseif( psi(3) .lt. twopt5 ) then			! lognormal
         do 220 k = 1, nrfz
         do 220 j = 1, nrfy
         do 220 i = 1, nrfx
            psifld(i,j,k) = exp( psi(4) + psi(5)*psifld(i,j,k) )
 220     continue
      else						! bounded
         do 230 k = 1, nrfz
         do 230 j = 1, nrfy
         do 230 i = 1, nrfx
            psifld(i,j,k) = psi(4) + half*(psi(5)-psi(4))                 &
                     *(one + tanh((psi(6)+psi(7)*psifld(i,j,k))/twopi))
 230     continue
      endif
!					for elastic modulus...
      if( e(3) .lt. half ) then				! deterministic
         do 240 k = 1, nrfz
         do 240 j = 1, nrfy
         do 240 i = 1, nrfx
            efld(i,j,k) = e(1)
 240     continue
      elseif( e(3) .lt. onept5 ) then			! normal
         do 250 k = 1, nrfz
         do 250 j = 1, nrfy
         do 250 i = 1, nrfx
            efld(i,j,k) = e(1) + e(2)*efld(i,j,k)
 250     continue
      elseif( e(3) .lt. twopt5 ) then			! lognormal
         do 260 k = 1, nrfz
         do 260 j = 1, nrfy
         do 260 i = 1, nrfx
            efld(i,j,k) = exp( e(4) + e(5)*efld(i,j,k) )
 260     continue
      else						! bounded
         do 270 k = 1, nrfz
         do 270 j = 1, nrfy
         do 270 i = 1, nrfx
            efld(i,j,k) = e(4) + half*(e(5)-e(4))                         &
                     *( one + tanh((e(6)+e(7)*efld(i,j,k))/twopi) )
 270     continue
      endif
!					for Poisson's ratio...
      if( v(3) .lt. half ) then				! deterministic
         do 280 k = 1, nrfz
         do 280 j = 1, nrfy
         do 280 i = 1, nrfx
            vfld(i,j,k) = v(1)
 280     continue
      elseif( v(3) .lt. onept5 ) then			! normal
         do 290 k = 1, nrfz
         do 290 j = 1, nrfy
         do 290 i = 1, nrfx
            vfld(i,j,k) = v(1) + v(2)*vfld(i,j,k)
 290     continue
      elseif( v(3) .lt. twopt5 ) then			! lognormal
         do 300 k = 1, nrfz
         do 300 j = 1, nrfy
         do 300 i = 1, nrfx
            vfld(i,j,k) = exp( v(4) + v(5)*vfld(i,j,k) )
 300     continue
      else						! bounded
         do 310 k = 1, nrfz
         do 310 j = 1, nrfy
         do 310 i = 1, nrfx
            vfld(i,j,k) = v(4) + half*(v(5)-v(4))                         &
                     *( one + tanh((v(6)+v(7)*vfld(i,j,k))/twopi) )
 310     continue
      endif
!					for Unit weight...
      if( gam(3) .lt. half ) then				! deterministic
         do 281 k = 1, nrfz
         do 281 j = 1, nrfy
         do 281 i = 1, nrfx
            gamfld(i,j,k) = gam(1)
 281     continue
      elseif( gam(3) .lt. onept5 ) then			! normal
         do 291 k = 1, nrfz
         do 291 j = 1, nrfy
         do 291 i = 1, nrfx
            gamfld(i,j,k) = gam(1) + gam(2)*gamfld(i,j,k)
 291     continue
      elseif( gam(3) .lt. twopt5 ) then			! lognormal
         do 301 k = 1, nrfz
         do 301 j = 1, nrfy
         do 301 i = 1, nrfx
            gamfld(i,j,k) = exp( gam(4) + gam(5)*gamfld(i,j,k) )
 301     continue
      else						! bounded
         do 311 k = 1, nrfz
         do 311 j = 1, nrfy
         do 311 i = 1, nrfx
            gamfld(i,j,k) = gam(4) + half*(gam(5)-gam(4))                         &
                     *( one + tanh((gam(6)+gam(7)*gamfld(i,j,k))/twopi) )
 311     continue
      endif

      if( debug ) then
         write(istat,1)'simpl3: finished everything...'
         call flush(istat)
      endif
      return
      end


!===================================================================================
!================== SUBROUTINE NONLINEAR DERIVATIVE ================================
!===================================================================================

subroutine derive2com(Nx,Ny,Nh,pi,time,rho_k,rho_ux_k,rho_uy_k,E_k,Bx_k,By_k, &
                  d_rho_k_dt_old,d_rho_k_dt_new,d_rho_ux_k_dt_old,d_rho_ux_k_dt_new,d_rho_uy_k_dt_old,d_rho_uy_k_dt_new, &
                  d_E_k_dt_old,d_E_k_dt_new,d_Bx_k_dt_old,d_Bx_k_dt_new,d_By_k_dt_old,d_By_k_dt_new)
implicit none

include "fftw3.f"

integer ( kind = 4 ) Nx,Ny,Nh, i, j, k
real ( kind = 8 ) pi,time,dt,Lx,Ly,kx,ky,mu,ms,CS,mu_0,eta,spheat,kf,A

real ( kind = 8 ) x(Nx), y(Ny)

real ( kind = 8 ) rho(Nx,Ny),ux(Nx,Ny),uy(Nx,Ny),E(Nx,Ny),P(Nx,Ny),Bx(Nx,Ny),By(Nx,Ny),B2(Nx,Ny),Source(Nx,Ny)
real ( kind = 8 ) rho_ux(Nx,Ny),rho_uy(Nx,Ny),Mom_x_1(Nx,Ny),Mom_x_2(Nx,Ny),Mom_y_1(Nx,Ny),Mom_y_2(Nx,Ny)

real ( kind = 8 ) d_ux_dx(Nx,Ny),d_uy_dy(Nx,Ny),Fx(Nx,Ny),Fy(Nx,Ny),ux_dum(Nx,Ny),uy_dum(Nx,Ny)
real ( kind = 8 ) Energy_x(Nx,Ny),Energy_y(Nx,Ny),E_Visc(Nx,Ny),Mag_x(Nx,Ny),Mag_y(Nx,Ny)
real ( kind = 8 ) d_Bx_dy(Nx,Ny),d_By_dx(Nx,Ny),curl_B(Nx,Ny)

complex ( kind = 8 ) rho_k(Nh,Ny),ux_k(Nh,Ny),uy_k(Nh,Ny),rho_ux_k(Nh,Ny),rho_uy_k(Nh,Ny)
complex ( kind = 8 ) rho_ux_k_dum(Nh,Ny),rho_uy_k_dum(Nh,Ny)
complex ( kind = 8 ) P_k(Nh,Ny),E_k(Nh,Ny),Fx_k(Nh,Ny),Fy_k(Nh,Ny),Bx_k(Nh,Ny),By_k(Nh,Ny)
complex ( kind = 8 ) rho_k_dum(Nh,Ny),ux_k_dum(Nh,Ny),uy_k_dum(Nh,Ny)
complex ( kind = 8 ) E_k_dum(Nh,Ny),Bx_k_dum(Nh,Ny),By_k_dum(Nh,Ny)

complex ( kind = 8 ) i_kx_rho_ux_k(Nh,Ny),i_ky_rho_uy_k(Nh,Ny)
complex ( kind = 8 ) Mom_x_1_k(Nh,Ny),Mom_x_2_k(Nh,Ny),Mom_y_1_k(Nh,Ny),Mom_y_2_k(Nh,Ny)
complex ( kind = 8 ) i_kx_Mom_x_1_k(Nh,Ny),i_ky_Mom_x_2_k(Nh,Ny),i_kx_Mom_y_1_k(Nh,Ny),i_ky_Mom_y_2_k(Nh,Ny)
complex ( kind = 8 ) kx2_ux_k(Nh,Ny),ky2_ux_k(Nh,Ny),kx2_uy_k(Nh,Ny),ky2_uy_k(Nh,Ny)
complex ( kind = 8 ) i_kx_ux_k(Nh,Ny),i_ky_uy_k(Nh,Ny)
complex ( kind = 8 ) Energy_x_k(Nh,Ny),Energy_y_k(Nh,Ny),E_Visc_k(Nh,Ny),Mag_x_k(Nh,Ny),Mag_y_k(Nh,Ny)
complex ( kind = 8 ) i_kx_Energy_x_k(Nh,Ny),i_ky_Energy_y_k(Nh,Ny),i_ky_Mag_x_k(Nh,Ny),i_kx_Mag_y_k(Nh,Ny)
complex ( kind = 8 ) i_ky_Bx_k(Nh,Ny),i_kx_By_k(Nh,Ny)
complex ( kind = 8 ) kx2_Bx_k(Nh,Ny),ky2_Bx_k(Nh,Ny),kx2_By_k(Nh,Ny),ky2_By_k(Nh,Ny)

complex ( kind = 8 ) d_rho_k_dt_old(Nh,Ny),d_rho_ux_k_dt_old(Nh,Ny),d_rho_uy_k_dt_old(Nh,Ny)
complex ( kind = 8 ) d_E_k_dt_old(Nh,Ny),d_Bx_k_dt_old(Nh,Ny),d_By_k_dt_old(Nh,Ny)
complex ( kind = 8 ) d_rho_k_dt_new(Nh,Ny),d_rho_ux_k_dt_new(Nh,Ny),d_rho_uy_k_dt_new(Nh,Ny)
complex ( kind = 8 ) d_E_k_dt_new(Nh,Ny),d_Bx_k_dt_new(Nh,Ny),d_By_k_dt_new(Nh,Ny)

integer ( kind = 8 ) plan_forward,plan_backward ! FFTW

common/comm/Lx,Ly,spheat,mu,ms,CS,mu_0,eta,dt,kf,A

! Keep Backup of the Arrays for FFTW.

!$OMP PARALLEL SHARED(rho_k,rho_ux_k,rho_uy_k,E_k,Bx_k,By_k),&
!$OMP & SHARED(rho_k_dum,rho_ux_k_dum,rho_uy_k_dum,E_k_dum,Bx_k_dum,By_k_dum) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny
  rho_k_dum(i,j) = rho_k(i,j)
  rho_ux_k_dum(i,j) = rho_ux_k(i,j)
  rho_uy_k_dum(i,j) = rho_uy_k(i,j)
  E_k_dum(i,j) = E_k(i,j)
  Bx_k_dum(i,j) = Bx_k(i,j)
  By_k_dum(i,j) = By_k(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, rho_k_dum, rho, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, rho_ux_k_dum, rho_ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, rho_uy_k_dum, rho_uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, E_k_dum, E, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, Bx_k_dum, Bx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, By_k_dum, By, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

!$OMP PARALLEL SHARED(A,kf,rho,rho_ux,rho_uy,E,Fx,Fy,Bx,By,B2,ux_dum,uy_dum) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx
  do j = 1,Ny
  ! FFTW Normalisation
  rho(i,j) = rho(i,j)/(dfloat(Nx)*dfloat(Ny))

  rho_ux(i,j) = rho_ux(i,j)/(dfloat(Nx)*dfloat(Ny))
  rho_uy(i,j) = rho_uy(i,j)/(dfloat(Nx)*dfloat(Ny))

  E(i,j) = E(i,j)/(dfloat(Nx)*dfloat(Ny))

  Bx(i,j) = Bx(i,j)/(dfloat(Nx)*dfloat(Ny))
  By(i,j) = By(i,j)/(dfloat(Nx)*dfloat(Ny))

  ! Evaluate Velocity in Real Space.
  ux(i,j) = rho_ux(i,j)/rho(i,j)
  uy(i,j) = rho_uy(i,j)/rho(i,j)

  ! Evaluate Forcing.
  Fx(i,j) = - rho(i,j) * A * dsin(kf*y(j))
  Fy(i,j) = + rho(i,j) * A * dsin(kf*x(i))

  ! Evaluate Square of Magnetic Field.
  B2(i,j) = Bx(i,j)*Bx(i,j) + By(i,j)*By(i,j)

  ! Keep Backup of the Arrays for FFTW.
  ux_dum(i,j) = ux(i,j)
  uy_dum(i,j) = uy(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, ux_dum, ux_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, uy_dum, uy_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Fx, Fx_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Fy, Fy_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

! Evaluate derivatives of Velocity and Magnetic Field.

!$OMP PARALLEL SHARED(Lx,Ly,ux_k,uy_k,Bx_k,By_k),&
!$OMP & SHARED(i_kx_ux_k,i_ky_uy_k,i_ky_Bx_k,i_kx_By_k) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny/2
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat(j-1)/Ly
    i_kx_ux_k(i,j) = (0.0d0,1.0d0)*kx*ux_k(i,j)
    i_ky_uy_k(i,j) = (0.0d0,1.0d0)*ky*uy_k(i,j)
    i_ky_Bx_k(i,j) = (0.0d0,1.0d0)*ky*Bx_k(i,j)
    i_kx_By_k(i,j) = (0.0d0,1.0d0)*kx*By_k(i,j)
  enddo
  do j = Ny/2+1,Ny
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
    i_kx_ux_k(i,j) = (0.0d0,1.0d0)*kx*ux_k(i,j)
    i_ky_uy_k(i,j) = (0.0d0,1.0d0)*ky*uy_k(i,j)
    i_ky_Bx_k(i,j) = (0.0d0,1.0d0)*ky*Bx_k(i,j)
    i_kx_By_k(i,j) = (0.0d0,1.0d0)*kx*By_k(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_kx_ux_k, d_ux_dx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_ky_uy_k, d_uy_dy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_ky_Bx_k, d_Bx_dy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_kx_By_k, d_By_dx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

!$OMP PARALLEL SHARED(d_ux_dx,d_uy_dy,d_Bx_dy,d_By_dx,curl_B,P),&
!$OMP & SHARED(Mom_x_1,Mom_x_2,Mom_y_1,Mom_y_2,Energy_x,Energy_y,E_Visc,Mag_x,Mag_y) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx
  do j = 1,Ny
  ! FFTW Normalisation.
  d_ux_dx(i,j) = d_ux_dx(i,j)/(dfloat(Nx)*dfloat(Ny))
  d_uy_dy(i,j) = d_uy_dy(i,j)/(dfloat(Nx)*dfloat(Ny))

  d_Bx_dy(i,j) = d_ux_dx(i,j)/(dfloat(Nx)*dfloat(Ny))
  d_By_dx(i,j) = d_uy_dy(i,j)/(dfloat(Nx)*dfloat(Ny))

  ! Evaluate Curl of Magnetic Field.
  curl_B(i,j) = d_By_dx(i,j) - d_Bx_dy(i,j)

  ! Evaluate Pressure
  P(i,j) = CS*CS*rho(i,j)!( spheat - 1.0d0 ) * ( E(i,j) - 0.50d0 * ( rho_ux(i,j)*ux(i,j)+rho_uy(i,j)*uy(i,j) - B2(i,j) ) )

  ! Evaluate LHS of Momentum Equation.
  Mom_x_1(i,j) = rho_ux(i,j)*ux(i,j) + P(i,j) + B2(i,j)/2.0d0 - Bx(i,j)*Bx(i,j)
  Mom_x_2(i,j) = rho_ux(i,j)*uy(i,j) - Bx(i,j)*By(i,j)

  Mom_y_1(i,j) = rho_ux(i,j)*uy(i,j) - Bx(i,j)*By(i,j)
  Mom_y_2(i,j) = rho_uy(i,j)*uy(i,j) + P(i,j) + B2(i,j)/2.0d0 - By(i,j)*By(i,j)

  ! Evaluate LHS of Energy Equation.
  Energy_x(i,j) = ( E(i,j) + P(i,j) + B2(i,j)/2.0d0 ) * ux(i,j) - ux(i,j)*Bx(i,j)*Bx(i,j) - uy(i,j)*Bx(i,j)*By(i,j)
  Energy_x(i,j) = Energy_x(i,j) - eta * By(i,j) * curl_B(i,j)
  Energy_y(i,j) = ( E(i,j) + P(i,j) + B2(i,j)/2.0d0 ) * uy(i,j) - ux(i,j)*Bx(i,j)*By(i,j) - uy(i,j)*By(i,j)*By(i,j)
  Energy_y(i,j) = Energy_y(i,j) + eta * Bx(i,j) * curl_B(i,j)

  ! Evaluate RHS of Energy Equation.
  E_Visc(i,j) = ( d_ux_dx(i,j) + d_uy_dy(i,j) )**2

  ! Evaluate LHS of Magnetic Field Equation.
  Mag_x(i,j) = uy(i,j)*Bx(i,j) - By(i,j)*ux(i,j)
  Mag_y(i,j) = ux(i,j)*By(i,j) - Bx(i,j)*uy(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Mom_x_1, Mom_x_1_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Mom_x_2, Mom_x_2_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Mom_y_1, Mom_y_1_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Mom_y_2, Mom_y_2_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Energy_x, Energy_x_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Energy_y, Energy_y_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, E_Visc, E_Visc_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Mag_x, Mag_x_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, Mag_y, Mag_y_k, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

  call dfftw_destroy_plan_ (plan_backward)
  call dfftw_destroy_plan_ (plan_forward)

! Evaluate the Derivatives in Spectral Space.

!$OMP PARALLEL SHARED(Lx,Ly,ux_k,uy_k,rho_ux_k,rho_uy_k,Bx_k,By_k),&
!$OMP & SHARED(Mom_x_1_k,Mom_x_2_k,Mom_y_1_k,Mom_y_2_k),&
!$OMP & SHARED(Energy_x_k,Energy_y_k,Mag_x_k,Mag_y_k),&
!$OMP & SHARED(i_kx_rho_ux_k,i_ky_rho_uy_k),&
!$OMP & SHARED(i_kx_Mom_x_1_k,i_ky_Mom_x_2_k,i_kx_Mom_y_1_k,i_ky_Mom_y_2_k),&
!$OMP & SHARED(i_kx_Energy_x_k,i_ky_Energy_y_k,i_ky_Mag_x_k,i_kx_Mag_y_k),&
!$OMP & SHARED(kx2_ux_k,ky2_ux_k,kx2_uy_k,ky2_uy_k),&
!$OMP & SHARED(kx2_Bx_k,ky2_Bx_k,kx2_By_k,ky2_By_k) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny/2
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat(j-1)/Ly

    i_kx_rho_ux_k(i,j) = (0.0d0,1.0d0)*kx*rho_ux_k(i,j)
    i_ky_rho_uy_k(i,j) = (0.0d0,1.0d0)*ky*rho_uy_k(i,j)

    i_kx_Mom_x_1_k(i,j) = (0.0d0,1.0d0)*kx*Mom_x_1_k(i,j)
    i_ky_Mom_x_2_k(i,j) = (0.0d0,1.0d0)*ky*Mom_x_2_k(i,j)
    i_kx_Mom_y_1_k(i,j) = (0.0d0,1.0d0)*kx*Mom_y_1_k(i,j)
    i_ky_Mom_y_2_k(i,j) = (0.0d0,1.0d0)*ky*Mom_y_2_k(i,j)

    kx2_ux_k(i,j) = kx*kx*ux_k(i,j)
    ky2_ux_k(i,j) = ky*ky*ux_k(i,j)
    kx2_uy_k(i,j) = kx*kx*uy_k(i,j)
    ky2_uy_k(i,j) = ky*ky*uy_k(i,j)

    i_kx_Energy_x_k(i,j) = (0.0d0,1.0d0)*kx*Energy_x_k(i,j)
    i_ky_Energy_y_k(i,j) = (0.0d0,1.0d0)*ky*Energy_y_k(i,j)

    i_ky_Mag_x_k(i,j) = (0.0d0,1.0d0)*ky*Mag_x_k(i,j)
    i_kx_Mag_y_k(i,j) = (0.0d0,1.0d0)*kx*Mag_y_k(i,j)

    kx2_Bx_k(i,j) = kx*kx*Bx_k(i,j)
    ky2_Bx_k(i,j) = ky*ky*Bx_k(i,j)
    kx2_By_k(i,j) = kx*kx*By_k(i,j)
    ky2_By_k(i,j) = ky*ky*By_k(i,j)
  enddo

  do j = Ny/2+1,Ny
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly

    i_kx_rho_ux_k(i,j) = (0.0d0,1.0d0)*kx*rho_ux_k(i,j)
    i_ky_rho_uy_k(i,j) = (0.0d0,1.0d0)*ky*rho_uy_k(i,j)

    i_kx_Mom_x_1_k(i,j) = (0.0d0,1.0d0)*kx*Mom_x_1_k(i,j)
    i_ky_Mom_x_2_k(i,j) = (0.0d0,1.0d0)*ky*Mom_x_2_k(i,j)
    i_kx_Mom_y_1_k(i,j) = (0.0d0,1.0d0)*kx*Mom_y_1_k(i,j)
    i_ky_Mom_y_2_k(i,j) = (0.0d0,1.0d0)*ky*Mom_y_2_k(i,j)

    kx2_ux_k(i,j) = kx*kx*ux_k(i,j)
    ky2_ux_k(i,j) = ky*ky*ux_k(i,j)
    kx2_uy_k(i,j) = kx*kx*uy_k(i,j)
    ky2_uy_k(i,j) = ky*ky*uy_k(i,j)

    i_kx_Energy_x_k(i,j) = (0.0d0,1.0d0)*kx*Energy_x_k(i,j)
    i_ky_Energy_y_k(i,j) = (0.0d0,1.0d0)*ky*Energy_y_k(i,j)

    i_ky_Mag_x_k(i,j) = (0.0d0,1.0d0)*ky*Mag_x_k(i,j)
    i_kx_Mag_y_k(i,j) = (0.0d0,1.0d0)*kx*Mag_y_k(i,j)

    kx2_Bx_k(i,j) = kx*kx*Bx_k(i,j)
    ky2_Bx_k(i,j) = ky*ky*Bx_k(i,j)
    kx2_By_k(i,j) = kx*kx*By_k(i,j)
    ky2_By_k(i,j) = ky*ky*By_k(i,j)
 enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

! De - Aliazing Technique With 2/3 Rule for All the Non-Linear Terms.

!$OMP PARALLEL SHARED(Lx,Ly,i_kx_rho_ux_k,i_ky_rho_uy_k),&
!$OMP & SHARED(i_kx_Mom_x_1_k,i_ky_Mom_x_2_k,i_kx_Mom_y_1_k,i_ky_Mom_y_2_k),&
!$OMP & SHARED(i_kx_Energy_x_k,i_ky_Energy_y_k,E_Visc_k,i_ky_Mag_x_k,i_kx_Mag_y_k),&
!$OMP & SHARED(kx2_ux_k,ky2_ux_k,kx2_uy_k,ky2_uy_k),&
!$OMP & SHARED(kx2_Bx_k,ky2_Bx_k,kx2_By_k,ky2_By_k) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny/2
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat(j-1)/Ly
      if (dsqrt(kx*kx + ky*ky) .ge. (dfloat(Nx+Ny)/2.0)/3.0 + 0) then
      i_kx_rho_ux_k(i,j) = 0.0d0
      i_ky_rho_uy_k(i,j) = 0.0d0
      i_kx_Mom_x_1_k(i,j) = 0.0d0
      i_ky_Mom_x_2_k(i,j) = 0.0d0
      i_kx_Mom_y_1_k(i,j) = 0.0d0
      i_ky_Mom_y_2_k(i,j) = 0.0d0
      kx2_ux_k(i,j) = 0.0d0
      ky2_ux_k(i,j) = 0.0d0
      kx2_uy_k(i,j) = 0.0d0
      ky2_uy_k(i,j) = 0.0d0
      i_kx_Energy_x_k(i,j) = 0.0d0
      i_ky_Energy_y_k(i,j) = 0.0d0
      E_Visc_k(i,j) = 0.0d0
      i_ky_Mag_x_k(i,j) = 0.0d0
      i_kx_Mag_y_k(i,j) = 0.0d0
      kx2_Bx_k(i,j) = 0.0d0
      ky2_Bx_k(i,j) = 0.0d0
      kx2_By_k(i,j) = 0.0d0
      ky2_By_k(i,j) = 0.0d0
      endif
  enddo
  do j = Ny/2+1,Ny
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
      if (dsqrt(kx*kx + ky*ky) .ge. (dfloat(Nx+Ny)/2.0)/3.0 + 0) then
      i_kx_rho_ux_k(i,j) = 0.0d0
      i_ky_rho_uy_k(i,j) = 0.0d0
      i_kx_Mom_x_1_k(i,j) = 0.0d0
      i_ky_Mom_x_2_k(i,j) = 0.0d0
      i_kx_Mom_y_1_k(i,j) = 0.0d0
      i_ky_Mom_y_2_k(i,j) = 0.0d0
      kx2_ux_k(i,j) = 0.0d0
      ky2_ux_k(i,j) = 0.0d0
      kx2_uy_k(i,j) = 0.0d0
      ky2_uy_k(i,j) = 0.0d0
      i_kx_Energy_x_k(i,j) = 0.0d0
      i_ky_Energy_y_k(i,j) = 0.0d0
      E_Visc_k(i,j) = 0.0d0
      i_ky_Mag_x_k(i,j) = 0.0d0
      i_kx_Mag_y_k(i,j) = 0.0d0
      kx2_Bx_k(i,j) = 0.0d0
      ky2_Bx_k(i,j) = 0.0d0
      kx2_By_k(i,j) = 0.0d0
      ky2_By_k(i,j) = 0.0d0
      endif
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL SHARED(mu,eta,i_kx_rho_ux_k,i_ky_rho_uy_k),&
!$OMP & SHARED(i_kx_Mom_x_1_k,i_ky_Mom_x_2_k,i_kx_Mom_y_1_k,i_ky_Mom_y_2_k),&
!$OMP & SHARED(i_kx_Energy_x_k,i_ky_Energy_y_k,E_Visc_k,i_ky_Mag_x_k,i_kx_Mag_y_k),&
!$OMP & SHARED(kx2_ux_k,ky2_ux_k,kx2_uy_k,ky2_uy_k,Fx_k,Fy_k),&
!$OMP & SHARED(kx2_Bx_k,ky2_Bx_k,kx2_By_k,ky2_By_k),&
!$OMP & SHARED(d_rho_k_dt_new,d_rho_ux_k_dt_new,d_rho_uy_k_dt_new),&
!$OMP & SHARED(d_E_k_dt_new,d_Bx_k_dt_new,d_By_k_dt_new) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny
    ! Density Equation.
    d_rho_k_dt_new(i,j) = - ( i_kx_rho_ux_k(i,j) + i_ky_rho_uy_k(i,j) )

    ! Momentum Equation.
    d_rho_ux_k_dt_new(i,j) = - ( i_kx_Mom_x_1_k(i,j) + i_ky_Mom_x_2_k(i,j) )
    d_rho_ux_k_dt_new(i,j) = d_rho_ux_k_dt_new(i,j) - mu * ( kx2_ux_k(i,j) + ky2_ux_k(i,j) ) + Fx_k(i,j)

    d_rho_uy_k_dt_new(i,j) = - ( i_kx_Mom_y_1_k(i,j) + i_ky_Mom_y_2_k(i,j) )
    d_rho_uy_k_dt_new(i,j) = d_rho_uy_k_dt_new(i,j) - mu * ( kx2_uy_k(i,j) + ky2_uy_k(i,j) ) + Fy_k(i,j)

    ! Energy Equation.
    d_E_k_dt_new(i,j) = - ( i_kx_Energy_x_k(i,j) + i_ky_Energy_y_k(i,j) )
    d_E_k_dt_new(i,j) = d_E_k_dt_new(i,j) + mu * E_Visc_k(i,j)

    ! Magnetic Field Equation.
    d_Bx_k_dt_new(i,j) = - i_ky_Mag_x_k(i,j) - eta * ( kx2_Bx_k(i,j) + ky2_Bx_k(i,j) )
    d_By_k_dt_new(i,j) = - i_kx_Mag_y_k(i,j) - eta * ( kx2_By_k(i,j) + ky2_By_k(i,j) )
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

return

end subroutine derive2com


	subroutine acRBsinf(E,y,l1,j1,s1,l2,j2,s2,green,eps00)
		use f90_kind
		use constants
		use parametros
    !
    !     Calculate the gf props between 2-atoms on a semi-infinite ribbon with armchair edges
    !

    !        INPUT (integer) :: l1,j1,s1,l2,j2,s2 -- impurity locations
    !        INPUT (complex) :: E+iy -- complex energy
    !        OUTPUT (complex) :: green -- required propagator

    !     All sites described by triple (l.a1, j.a2,s)
    !     ========================================
    !     a1, a2 are unit vectors of graphene
    !     s=1,2 is the intracell index

    !     First impurity position described by (l1,l2,s1)
    !     Second impurity position described by (l2, j2, s2)

    !     Semi-infinite ribbon with armchair border, quantised along the direction (l,-l) i.e. (l,-l,1)
    !     and has vanishing density of states in directions (l,l,s) and (N+l,-N+l,s) for s=1,2
    !     LDOS also vanishes along the ring (l,-l,1)

    !     (0,1,2) ______(1,1,1)
    !            /      \
    !           /        \
    !   (0,1,1)/          \______
    !          \          /      \
    !           \        /        \
    !     (0,0,2)\______/(1,0,1)   \
    !            /      \          /
    !           /        \        /
    !   (0,0,1)/          \______/
    !          \          /
    !           \        /
    !            \______/
    implicit none

    !     declare inputs
    !     ---------------
    ! impurity locations
	integer, intent(in) :: l1, j1, l2, j2, s1, s2

	integer	:: nn
	integer	:: ds, dl, dj, sl, sj

!	complex energy E+i y
	real(double), intent(in)	:: E,y,eps00
    complex(double)	:: cw
!	required propagator
    complex(double), intent(out)	:: green
    complex(double)	:: numerator, denom, denom2, sinn1, sinn2, k_n

	real(double)	:: arg
   complex(double)	:: cos_pole,sin_pole,exp_pole,exp_minus_pole,cosn,exp_2phi

	cw = cmplx(E,y,double)

!	impurity separation
    dl = l1-l2
    dj = j1-j2
    ds = s1-s2
	sl = l1+l2
	sj = j1+j2

   green = zero

 IF(assm.NE.0 .AND. assm.NE.1) then
 	PRINT *, "acRBsinf.f90: 'assm' should be 0 or 1. Check the inputcard parametros.f90. Stopping!"
 	STOP
 END IF

	do nn=1,2*(P+1+assm)
		if ((assm.EQ.0).AND.(nn.eq.(P+1+assm))) then
			go to 30
		end if
		arg  = nn*pi/(2*(P+1+assm)-assm)
		IF((assm.EQ.1).AND.cos(arg).LE.1.d-14) then
			PRINT *, "acRBsinf.f90: Problem in the assimetric mode. Argument x of 1/cos(x) went zero. Stopping! "
			STOP
		END IF
		cosn = cos(arg)

		cos_pole = (((cw-eps00)/t)**2 - 1)/(4*cosn) - cosn

!		k_n = acos(cos_pole) - imaginary arcosine, to check which pole is inside the countour
		k_n	= -zi*log(cos_pole+zi*sqrt(zum-(cos_pole**2)))

		if (aimag(k_n).lt.0.d0) then
			sin_pole	= -sqrt(zum-(cos_pole**2))
		else
			sin_pole	= sqrt(zum-(cos_pole**2))
		end if

		denom		= cosn*sin_pole
		sinn1		= sin(arg*(l1-j1))
		sinn2		= sin(arg*(l2-j2))
		exp_pole	= cos_pole+zi*sin_pole

		if((s1.eq.1).and.(s2.eq.1)) then
			green = green+sinn1*sinn2*((exp_pole**abs(dl+dj))-(exp_pole**abs(sl+sj)))/denom
		else if((s1.eq.2).and.(s2.eq.2)) then
			exp_minus_pole = (cos_pole-zi*sin_pole)
			exp_2phi = (1.d0+2.d0*cosn*exp_pole)/(1.d0+2.d0*cosn*exp_minus_pole)

			green = green+sinn1*sinn2*(exp_pole**abs(dl+dj)-exp_2phi*(exp_pole**abs(sl+sj)))/denom
		else
			numerator = (exp_pole**abs(dl+dj))-(exp_pole**abs(sl+sj))+(2.d0*cosn*((exp_pole**abs(dl+dj+ds))-(exp_pole**abs(sl+sj+1))))
			green = green + sinn1*sinn2*numerator/denom
		end if

30	continue
	end do

	if(ds.eq.0)then
	   green = zi*(cw-eps00)*green/(4.d0*(P+1+assm)*t**2)
	else
	   green = zi*green/(4.d0*(P+1+assm)*t)
	end if

	denom2	= ((cw-eps00)**2 - t**2)*(P+1+assm)
	sinn1	= sin(pi*(l1-j1)/2.d0)
	sinn2	= sin(pi*(l2-j2)/2.d0)
	if((assm.EQ.0).AND.(dl+dj.eq.0).and.(sl+sj.ne.0)) then
		if(ds.eq.0) then
			green	= green + (sinn1*sinn2*(cw-eps00)/denom2)
		else
			green	= green + (sinn1*sinn2*t/denom2)
		end if
	end if

	return
	end subroutine acRBsinf


c---------------------------------------------------------------------
      subroutine diffusion(ifmortar)
c---------------------------------------------------------------------
c     advance the diffusion term using CG iterations
c---------------------------------------------------------------------

      include 'header.h'

      double precision  rho_aux, rho1, rho2, beta, cona
      logical ifmortar
      integer iter,ie, im,iside,i,j,k

c.....set up diagonal preconditioner
      if (ifmortar) then
        call setuppc
        call setpcmo
      end if

c.....arrays t and umor are accumlators of (am pm) in the CG algorithm
c     (see the specification)

      call r_init_omp(t,ntot,0.d0)
c$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
      do i=1,nmor
        umor(i)=0.d0
      end do
c$OMP END PARALLEL DO

c.....calculate initial am (see specification) in CG algorithm

c.....trhs and rmor are combined to generate r0 in CG algorithm.
c     pdiff and pmorx are combined to generate q0 in the CG algorithm.
c     rho1 is  (qm,rm) in the CG algorithm.

      rho1 = 0.d0
c$OMP PARALLEL DEFAULT(SHARED) PRIVATE(im,ie,i,j,k) REDUCTION(+:rho1)
c$OMP DO
       do ie=1,nelt
         do k=1,lx1
           do j=1,lx1
             do i=1,lx1
               pdiff(i,j,k,ie) = dpcelm(i,j,k,ie)*trhs(i,j,k,ie)
               rho1            = rho1 + trhs(i,j,k,ie)*pdiff(i,j,k,ie)*
     &                                          tmult(i,j,k,ie)
             end do
           end do
         end do
       end do
c$OMP END DO nowait

c$OMP DO
      do im = 1, nmor
        pmorx(im) = dpcmor(im)*rmor(im)
        rho1      = rho1 + rmor(im)*pmorx(im)
      end do
c$OMP END DO nowait
c$OMP END PARALLEL

c.................................................................
c     commence conjugate gradient iteration
c.................................................................

      do iter=1, nmxh
        if(iter.gt.1) then
          rho_aux = 0.d0
c$OMP PARALLEL DEFAULT(SHARED) PRIVATE(im,ie,i,j,k) REDUCTION(+:rho_aux)
c$OMP DO
c.........pdiffp and ppmor are combined to generate q_m+1 in the specification
c         rho_aux is (q_m+1,r_m+1)
          do ie = 1, nelt
            do k=1,lx1
              do j=1,lx1
                do i=1,lx1
                  pdiffp(i,j,k,ie) = dpcelm(i,j,k,ie)*trhs(i,j,k,ie)
                  rho_aux =rho_aux+trhs(i,j,k,ie)*pdiffp(i,j,k,ie)*
     &                                            tmult(i,j,k,ie)
                end do
              end do
            end do
          end do
c$OMP END DO nowait
c$OMP DO
          do im = 1, nmor
            ppmor(im) = dpcmor(im)*rmor(im)
            rho_aux = rho_aux + rmor(im)*ppmor(im)
          end do
c$OMP END DO nowait
c$OMP END PARALLEL

c.........compute bm (beta) in the specification
          rho2 = rho1
          rho1 = rho_aux
          beta = rho1/rho2
c.........update p_m+1 in the specification
          call adds1m1(pdiff, pdiffp, beta,ntot)
          call adds1m1(pmorx, ppmor,  beta, nmor)
        end if

c.......compute matrix vector product: (theta pm) in the specification

        call transf(pmorx,pdiff)

c.......compute pdiffp which is (A theta pm) in the specification
c$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ie)
        do ie=1, nelt
          call laplacian(pdiffp(1,1,1,ie),pdiff(1,1,1,ie),size_e(ie))
        end do
c$OMP END PARALLEL DO

c.......compute ppmor which will be used to compute (thetaT A theta pm)
c       in the specification
        call transfb(ppmor,pdiffp)

c.......apply boundary condition
c$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ie,iside)
        do ie=1,nelt
          do iside=1,nsides
            if(cbc(iside,ie).eq.0)then
              call facev(pdiffp(1,1,1,ie),iside,0.d0)
            end if
          end do
        end do
c$OMP END PARALLEL DO

c.......compute cona which is (pm,theta T A theta pm)
        cona = 0.d0
c$OMP PARALLEL DEFAULT(SHARED) PRIVATE(im,ie,i,j,k) REDUCTION(+:cona)
c$OMP DO
        do ie = 1, nelt
          do k=1,lx1
            do j=1,lx1
              do i=1,lx1
                cona = cona +
     &          pdiff(i,j,k,ie)*pdiffp(i,j,k,ie)*tmult(i,j,k,ie)
              end do
             end do
          end do
        end do
c$OMP END DO nowait
c$OMP DO
        do im = 1, nmor
          ppmor(im) = ppmor(im)*tmmor(im)
          cona = cona + pmorx(im)*ppmor(im)
        end do
c$OMP END DO nowait
c$OMP END PARALLEL

c.......compute am
        cona = rho1/cona
c.......compute (am pm)
        call adds2m1(t,    pdiff,   cona, ntot)
        call adds2m1(umor, pmorx,   cona, nmor)
c.......compute r_m+1
        call adds2m1(trhs, pdiffp, -cona, ntot)
        call adds2m1(rmor, ppmor,  -cona, nmor)

      end do

      call transf(umor,t)

      return
      end

c------------------------------------------------------------------
      subroutine laplacian(r,u,sizei)
c------------------------------------------------------------------
c     compute  r = visc*[A]x +[B]x on a given element.
c------------------------------------------------------------------
      include 'header.h'

      double precision r(lx1,lx1,lx1), u(lx1,lx1,lx1), rdtime
      integer i,j,k, ix,iz, sizei

      double precision tm1(lx1,lx1,lx1),tm2(lx1,lx1,lx1)

      rdtime = 1.d0/dtime

      call r_init(tm1,nxyz,0.d0)
      do iz=1,lx1
        do k = 1, lx1
          do j = 1, lx1
            do i = 1, lx1
              tm1(i,j,iz) = tm1(i,j,iz)+wdtdr(i,k)*u(k,j,iz)
            end do
          end do
        end do
      end do

      call r_init(tm2,nxyz,0.d0)
      do iz=1,lx1
        do k = 1, lx1
          do j = 1, lx1
            do i = 1, lx1
              tm2(i,j,iz) = tm2(i,j,iz)+u(i,k,iz)*wdtdr(k,j)
            end do
          end do
        end do
      end do

      call r_init(r,nxyz,0.d0)
      do k = 1, lx1
        do iz=1, lx1
          do j = 1, lx1
            do i = 1, lx1
              r(i,j,iz) = r(i,j,iz)+u(i,j,k)*wdtdr(k,iz)
            end do
          end do
        end do
      end do

c.....collocate with remaining weights and sum to complete factorization.

c      do ix=1,nxyz
c         r(ix,1,1)=visc*(tm1(ix,1,1)*g4m1_s(ix,1,1,sizei)+
c     &                   tm2(ix,1,1)*g5m1_s(ix,1,1,sizei)+
c     &                     r(ix,1,1)*g6m1_s(ix,1,1,sizei))+
c     &               bm1_s(ix,1,1,sizei)*rdtime*u(ix,1,1)
c      end do
      do k=1,lx1
        do j=1,lx1
          do i=1,lx1
            r(i,j,k)=visc*(tm1(i,j,k)*g4m1_s(i,j,k,sizei)+
     &                   tm2(i,j,k)*g5m1_s(i,j,k,sizei)+
     &                    r(i,j,k)*g6m1_s(i,j,k,sizei))+
     &               bm1_s(i,j,k,sizei)*rdtime*u(i,j,k)
          end do
        end do
      end do

      return
      end


      module MOD_CALCH

      contains

      SUBROUTINE CALCH(ND,NP,NPDIM,OPA,Z,P,U,VL,VJL,RADIUS,HNU,FLUXIN,EMFLUX)

      use MOMENTS

      IMPLICIT REAL*8(A-H,O-Z)

C***
      parameter (two=2.d0, four=4.d0)
C***
      DIMENSION RADIUS(ND),OPA(ND)
      DIMENSION Z(ND,NP),P(NP),U(ND,NP),HNU(ND),VL(NP),VJL(NP,ND)

C***  EVERY L = 1 ... ND
      DO 1 L=1,ND
      JMAX=NP+1-L
      JMM=JMAX-1

      IF(L.EQ.1) THEN
      HNU(1)=EMFLUX/four/RADIUS(1)/RADIUS(1)
      ELSE IF (L.GT.1 .AND. L.LT.ND) THEN
C***  ALL NON-BOUNDARY POINTS  L= 2 ... ND-1
      XP=(OPA(L)+OPA(L+1))/two
      XM=(OPA(L)+OPA(L-1))/two
      DO 2 J=1,JMM
      ZLPLUS=Z(L+1,J)
      ZLJ=Z(L,J)
      ZLMIN=Z(L-1,J)
      DTM=XM*(ZLMIN-ZLJ)
      DTP=XP*(ZLPLUS-ZLJ)
      DUM=U(L-1,J)-U(L,J)
      DUP=U(L+1,J)-U(L,J)
      DDT=DTP-DTM
      DDU=DUM*DTP/DTM-DUP*DTM/DTP
c*** Mihalas p152 6-15 du/dtau=v
      VL(J)=-DDU/DDT
    2 CONTINUE
      VL(JMAX)=0.d0
      DO 3 J=1,JMAX
    3 VJL(J,L)=VL(J)
C*** CALCULATE H = INTEG 0 TO 1  V P/R/R DP
      CALL MOMENT1 (RADIUS(L),JMAX,P,VL,HNU(L))

      ELSE IF(L.EQ.ND) THEN
      HNU(ND)=FLUXIN/four
      ENDIF
    1 CONTINUE
C
      RETURN
      end subroutine
      end module


subroutine apply_mixing(IPP)

    use global, only: Npts,hFacC,xyz,z2k,k2z,Nx,Ny,dt_mld,tt,mld,&
        useMLD,parti_mld,kvdt2,khdt2,dxg_r,dyg_r,drf_r,pi2f
    use random, only: random_normal
    implicit none
    !integer*4, target :: ixyz(Npts,3)
    !    real*4 , dimension(-1:Nx,0:Ny-1) :: mld
    integer*8 :: i,icount

    integer*8 :: ip,jp,kp
    real*8 :: num, z, pz
    logical :: ivok_mld
    integer*8, intent(in) :: IPP

    ivok_mld= (mod(tt,dt_mld) .eq. 0) .and. useMLD

    if (ivok_mld) then
        call load_mld(tt)
        where (mld>1000) mld=1000d0
        parti_mld=0d0
        call random_seed(put=int(pi2f(1:30,1),8))

        icount=0
!$OMP PARALLEL DO PRIVATE(i,ip,jp,kp,pz,num,z)
        do i =1,Npts
            if (xyz(i,2,IPP)<Ny-1) then
                !ip=pi2f(i)
                !jp=pj2f(i)
                !kp=pk2f(i)
                ip=floor(mod(xyz(i,1,IPP),real(Nx-1)))
                jp=floor(xyz(i,2,IPP))
                kp=floor(xyz(i,3,IPP))
                if (hFacC(ip,jp,kp) .eq. 1) then
                    pz = k2z(int(xyz(i,3,IPP)*10))
                    !mixed layer uniform mixing
                    if (pz .lt. mld(ip,jp) .and. ivok_mld) then
                        icount=icount+1
                        call random_number(num)
                        !extend mixing to the level 50 meters below the mixed layer,
                        !or 0.25 of the depth of the mixed layer whichever is smaller.
                        z =  num * (mld(ip,jp) + min(20d0,mld(ip,jp)*0.25))
                        !convert depth to index
                        parti_mld(i,IPP)=z-pz
                        xyz(i,3,IPP) =real(z2k(floor(z)),8)
                    else
                        !random displacement for vertical diffusion
                        xyz(i,3,IPP) = xyz(i,3,IPP)+random_normal()*kvdt2*drf_r(kp)
                        !if (hFacC(ip,jp,kp) .lt. 1) then
                        !    xyz(i,3) = 2*real(floor(xyz(i,3))) - xyz(i,3)
                        !endif
                        !mirror boundary condition at the surface
                        if (xyz(i,3,IPP)<0) then
                            xyz(i,3,IPP)=-xyz(i,3,IPP)
                        endif
                    endif
                    !horizontal mixing
                    xyz(i,1,IPP) = xyz(i,1,IPP)+random_normal()*khdt2*dxg_r(ip,jp)
                    xyz(i,2,IPP) = xyz(i,2,IPP)+random_normal()*khdt2*dyg_r(ip,jp)
                endif
            endif
        enddo
!$OMP END PARALLEL DO
    endif
    if (ivok_mld) then
        print*, "%============================================================"
        print*, "%              MLD            +"
        print*, "%Total ",icount," particles in the mixed layer at day ", tt/86400.
        print*, "%============================================================"
    endif

end subroutine apply_mixing


  module fluid_model_powerlaw
! power law model with inputs in B, T, n, assumes toroidal magnetic field
! and velocity vectors

  use phys_constants, only: c2, pi, mp

  implicit none

  real :: pl_pnth, pl_n0, pl_t0, pl_nnth0, pl_beta, pl_pn, pl_pt, &
       pl_rin, pl_rout, pl_thin, pl_thout, pl_phiin, pl_phiout

  interface powerlaw_vals
    module procedure powerlaw_vals
  end interface

  interface init_powerlaw
     module procedure init_powerlaw
  end interface

  interface del_powerlaw
     module procedure del_powerlaw
  end interface

  contains

    subroutine init_powerlaw(n0,t0,nnth0,pnth,beta,pn,pt,rin,rout,thin,thout, &
         phiin,phiout)
! assign inputs, defaults for one zone model w/ Gaussian height
      real, intent(in), optional :: n0,t0,nnth0,pnth,beta,pn,pt, &
           rin,rout,thin,thout,phiin,phiout
      write(6,*) 'init powerlaw: ',present(n0),present(t0),present(nnth0),&
           present(pnth),present(beta)
      if(present(pnth)) then
         pl_pnth = pnth
      else
         pl_pnth = 0.
      endif
      if(present(pt)) then
         pl_pt = pt
      else
         pl_pt = 0.
      endif
      if(present(pn)) then
         pl_pn = pn
      else
         pl_pn = 0.
      endif
      if(present(n0)) then
         pl_n0 = n0
      else
         pl_n0 = 3e7
      endif
      if(present(t0)) then
         pl_t0 = t0
      else
         pl_t0 = 6e10
      endif
      if(present(nnth0)) then
         pl_nnth0 = nnth0
      else
         pl_nnth0 = 8e4
      endif
      if(present(beta)) then
         pl_beta = beta
      else
         pl_beta = 10.
      endif
      if(present(rin)) then
         pl_rin = rin
      else
         pl_rin = 0.
      endif
      if(present(rout)) then
         pl_rout = rout
      else
         pl_rout = 1e8
      endif
      if(present(thin)) then
         pl_thin = thin
      else
         pl_thin = -10.
      endif
      if(present(thout)) then
         pl_thout = thout
      else
         pl_thout = 10.
      endif
      if(present(phiin)) then
         pl_phiin = phiin
      else
         pl_phiin = 0.
      endif
      if(present(phiout)) then
         pl_phiout = phiout
      else
         pl_phiout = 1e4
      endif
      write(6,*) 'fluid model powerlaw inputs: ',pl_pnth,pl_n0,pl_t0,pl_nnth0,pl_beta,pl_pn,pl_pt
      write(6,*) 'fluid model powerlaw inputs cuts: ',pl_rin,pl_rout,pl_thin,pl_thout
    end subroutine init_powerlaw

    subroutine powerlaw_vals(a,mu,u,neth,te,B,vr,vth,omega, &
         nenth)
      real, intent(in) :: a
      real, dimension(:), intent(in) :: u,mu
      real, dimension(size(u)) :: r, rs,z,a2
      real, dimension(size(u)), intent(out) :: neth, te, B, vr, omega, &
           vth, nenth
      r = 1./u
      rs = r/2.
      z=r*mu
      a2 = sqrt(r**2.-z**2.)
      neth = pl_n0 * ((rs)**(-pl_pn))!*exp(-.5*(z/a2)**2.)
      nenth = pl_nnth0 * ((rs)**(-pl_pnth))!*exp(-.5*(z/a2)**2.)
      te = pl_t0 * (rs)**(-pl_pt)
      ! roughly equipartition from B+09
!      B = sqrt(8.*pi* neth * mp * c2 / rs / 12. / pl_beta)
      vr = 0.*r
      vth = 0.*r
! velocity scaling in terms of c for equatorial plane, default is stationary to mimic non-rel one zone model
      omega = pl_phiin/r
      where(r.gt.pl_rout.or.r.lt.pl_rin.or.mu.lt.pl_thin.or. &
           mu.gt.pl_thout)
         neth = 0.
         nenth = 0.
      endwhere
! changed to use constant rs for constant value of B corresponding to R = 20 M
      B = sqrt(8.*pi* neth * mp * c2 / 10. / 12. / pl_beta)
!      write(6,*) 'powerlaw_vals vals: ',r,z,neth,nenth,te
     end subroutine powerlaw_vals

     subroutine del_powerlaw
       !nothing so far
     end subroutine del_powerlaw

  end module fluid_model_powerlaw