c  ***********************  EMC3D.f  ***********************************
c  This program is a modified version of "elas3d.f", which was developed
c  and distributed by Garboczi and others from NIST.
c
c  Adding fuctionalities are not major.
c   (1) File IO (input/output/stress field output files)
c   (2) Calculation of properties assuming isotropic & elastic media.
c
c  Following is the original documentation from NIST.
c
c-----------------------
c  BACKGROUND

c  This program solves the linear elastic equations in a
c  random linear elastic material, subject to an applied macroscopic strain,
c  using the finite element method.  Each pixel in the 3-D digital
c  image is a cubic tri-linear finite element,  having its own
c  elastic moduli tensor. Periodic boundary conditions are maintained.
c  In the comments below, (USER) means that this is a section of code that
c  the user might have to change for his particular problem. Therefore the
c  user is encouraged to search for this string.

c  PROBLEM AND VARIABLE DEFINITION

c  The problem being solved is the minimization of the energy
c  1/2 uAu + b u + C, where A is the Hessian matrix composed of the
c  stiffness matrices (dk) for each pixel/element, b is a constant vector
c  and C is a constant that are determined by the applied strain and
c  the periodic boundary conditions, and u is a vector of
c  all the displacements. The solution
c  method used is the conjugate gradient relaxation algorithm.
c  Other variables are:  gb is the gradient = Au+b, h and Ah are
c  auxiliary variables used in the conjugate gradient algorithm (in dembx),
c  dk(n,i,j) is the stiffness matrix of the n'th phase, cmod(n,i,j) is
c  the elastic moduli tensor of the n'th phase, pix is a vector that gives
c  the phase label of each pixel, ib is a matrix that gives the labels of
c  the 27 (counting itself) neighbors of a given node, prob is the volume
c  fractions of the various phases,
c  strxx, stryy, strzz, strxz, stryz, and strxy are the six Voigt
c  volume averaged total stresses, and
c  sxx, syy, szz, sxz, syz, and sxy are the six Voigt
c  volume averaged total strains.

c  DIMENSIONS

c  The vectors u,gb,b,h, and Ah are dimensioned to be the system size,
c  ns=nx*ny*nz, with three components, where the digital image of the
c  microstructure considered is a rectangular paralleliped, nx x ny x nz
c  in size.  The arrays pix and ib are are also dimensioned to the system size.
c  The array ib has 27 components, for the 27 neighbors of a node.
c  Note that the program is set up at present to have at most 100
c  different phases.  This can easily be changed, simply by changing
c  the dimensions of dk, prob, and cmod. The parameter nphase gives the
c  number of phases being considered in the problem.
c  All arrays are passed between subroutines using simple common statements.

c  STRONGLY SUGGESTED:  READ THE MANUAL BEFORE USING PROGRAM!!

c  (USER) Change these dimensions and in other subroutines at same time.
c  For example, search and replace all occurrences throughout the
c  program of "(64000000" by "(64000", to go from a
c  20 x 20 x 20 system to a 40 x 40 x 40 system.
	real u(64000000,3),gb(64000000,3),b(64000000,3)
      real h(64000000,3),Ah(64000000,3)
	real cmod(100,6,6),dk(100,8,3,8,3)
	real phasemod(100,2),prob(100), density(100)
	real fdensity, fporosity, BulkM, ShearM

	integer in(27),jn(27),kn(27),iwriteFlag
	integer*4 ib(64000000,27), nblank
	integer*2 pix(64000000)
	character*40 poreFileName

	common/list1/strxx,stryy,strzz,strxz,stryz,strxy
	common/list2/exx,eyy,ezz,exz,eyz,exy
	common/list3/ib
        common/list4/pix
	common/list5/dk,b,C
	common/list6/u
	common/list7/gb
        common/list8/cmod
        common/list9/h,Ah
	common/list10/sxx,syy,szz,sxz,syz,sxy

c (USER) Unit 9 is the microstructure input file,
c  unit 7 is the results output file.
	open (unit=8, file='emc3d.pam')

      open (unit=7,file='outputfile.out')

	read(8,'(a40)') poreFileName
	write(*,7901) poreFileName
7901  format(' Pore File Name : ', a40)

	read(8,*) nx, ny, nz
	write(*,7902) nx, ny, nz
7902  format(' (NX, NY, NZ) : ',3i5)

	read(8,*) gtest
	write(*,7903) gtest
7903  format(' Convergence criteria: ',e12.5)

	read(8,*) nblank
	write(*,7904) nblank
7904  format(' No. of Header line : ',i5)

	read(8,*) iwriteFlag
	write(*,7905) iwriteFlag
7905  format(' Write Stress Field (0=no, 1=yes) : ',i3)

	read(8,*) nphase
	write(*,7906) nphase
7906  format(' No. of Phases', i3)

	do 6060 n=1,nphase
		read(8,*) phasemod(n,1), phasemod(n,2), density(n)
		write(*,7907) n, phasemod(n,1), phasemod(n,2), density(n)
6060  continue
7907  format(i2,' phase (K,mu,density) : ', 3(e12.5,1x))

	read(8,*) exx,eyy,ezz,exz,eyz,exy
	print*, 'Applied Strain :'
	write(*,7908) exx,eyy,ezz,exz,eyz,exy
7908  format(3x,6(e12.5,1x))

	close(8)

	open (unit=9,file=poreFileName)

c (USER)  nx,ny,nz give the size of the lattice
c        nx=200
c        ny=200
c        nz=200
c ns=total number of sites
        ns=nx*ny*nz
      write(7,9010) nx,ny,nz,ns
9010  format('nx= ',i4,' ny= ',i4,' nz= ',i4,' ns= ',i8)
      gtest = gtest*ns

c  (USER) nphase is the number of phases being considered in the problem.
c  The values of pix(m) will run from 1 to nphase.
c	nphase=2

c  (USER) gtest is the stopping criterion, the number
c  to which the quantity gg=gb*gb is compared.
c  Usually gtest = abc*ns, so that when gg < gtest, the rms value
c  per pixel of gb is less than sqrt(abc).
c       gtest=1.e-7*ns

c  (USER)
c  The parameter phasemod(i,j) is the bulk (i,1) and shear (i,2) moduli of
c  the i'th phase. These can be input in terms of Young's moduli E(i,1) and
c  Poisson's ratio nu (i,2).  The program, in do loop 1144, then changes them
c  to bulk and shear moduli, using relations for isotropic elastic
c  moduli.  For anisotropic elastic material, one can directly input
c  the elastic moduli tensor cmod in subroutine femat, and skip this part.
c  If you wish to input in terms of bulk (1) and shear (2), then make sure
c  to comment out the do 1144 loop.
c	phasemod(1,1)=2.2
c	phasemod(1,2)=0.0
c	phasemod(2,1)=36.6
c	phasemod(2,2)=44.0

c---------------------------------**********************___________________
c  (USER) Program uses bulk modulus (1) and shear modulus (2), so transform
c  Young's modulis (1) and Poisson's ratio (2).
c        do 1144 i=1,nphase
c        save=phasemod(i,1)
c        phasemod(i,1)=phasemod(i,1)/3./(1.-2.*phasemod(i,2))
c        phasemod(i,2)=save/2./(1.+phasemod(i,2))
c1144    continue

c  Construct the neighbor table, ib(m,n)

c  First construct the 27 neighbor table in terms of delta i, delta j, and
c  delta k information (see Table 3 in manual)
      in(1)=0
      in(2)=1
      in(3)=1
      in(4)=1
      in(5)=0
      in(6)=-1
      in(7)=-1
      in(8)=-1

      jn(1)=1
      jn(2)=1
      jn(3)=0
      jn(4)=-1
      jn(5)=-1
      jn(6)=-1
      jn(7)=0
      jn(8)=1

      do 555 n=1,8
      kn(n)=0
      kn(n+8)=-1
      kn(n+16)=1
      in(n+8)=in(n)
      in(n+16)=in(n)
      jn(n+8)=jn(n)
      jn(n+16)=jn(n)
555   continue
      in(25)=0
      in(26)=0
      in(27)=0
      jn(25)=0
      jn(26)=0
      jn(27)=0
      kn(25)=-1
      kn(26)=1
      kn(27)=0

c  Now construct neighbor table according to 1-d labels
c  Matrix ib(m,n) gives the 1-d label of the n'th neighbor (n=1,27) of
c  the node labelled m.
      nxy=nx*ny
      do 1020 k=1,nz
      do 1020 j=1,ny
      do 1020 i=1,nx
      m=nxy*(k-1)+nx*(j-1)+i
      do 1004 n=1,27
      i1=i+in(n)
      j1=j+jn(n)
      k1=k+kn(n)
      if(i1.lt.1) i1=i1+nx
      if(i1.gt.nx) i1=i1-nx
      if(j1.lt.1) j1=j1+ny
      if(j1.gt.ny) j1=j1-ny
      if(k1.lt.1) k1=k1+nz
      if(k1.gt.nz) k1=k1-nz
      m1=nxy*(k1-1)+nx*(j1-1)+i1
      ib(m,n)=m1
1004  continue
1020  continue

c Compute the average stress and strain in each microstructure.
c (USER) npoints is the number of microstructures to use.

        npoints=1
        do 8000 micro=1,npoints
c  Read in a microstructure in subroutine ppixel, and set up pix(m)
c  with the appropriate phase assignments.
        call ppixel(nx,ny,nz,ns,nphase,nblank)
c Count and output the volume fractions of the different phases
        call assig(ns,nphase,prob)
        do 111 i=1,nphase
        write(7,9020) i,phasemod(i,1),phasemod(i,2)
9020    format(' Phase ',i3,' bulk = ',f12.6,' shear = ',f12.6)
111	continue

	do 8050 i=1,nphase
	write(7,9065) i,prob(i)
9065	format(' Volume fraction of phase ',i3,'  is ',f8.5)
8050	continue
	fporosity = prob(1)

c  (USER) Set applied strains
c  Actual shear strain applied in do 1050 loop is exy, exz, and eyz as
c  given in the statements below.  The engineering shear strain, by which
c  the shear modulus is usually defined, is twice these values.
c        exx=0.002
c        eyy=0.002
c        ezz=0.002
c        exz=0.002/2.
c        eyz=0.004/2.
c        exy=0.006/2.
	exz = exz/2.
	eyz = eyz/2.
	exy	= exy/2.
        write(7,*) 'Applied engineering strains'
        write(7,*) ' exx eyy ezz exz eyz exy'
        write(7,*) exx,eyy,ezz,2.*exz,2.*eyz,2.*exy

c Set up the elastic modulus variables, finite element stiffness matrices,
c the constant, C, and vector, b, required for computing the energy.
c  (USER) If anisotropic elastic moduli tensors are used, these need to be
c  input in subroutine femat.

	call femat(nx,ny,nz,ns,phasemod,nphase)

c Apply chosen strains as a homogeneous macroscopic strain
c as the initial condition.
	do 1050 k=1,nz
	do 1050 j=1,ny
        do 1050 i=1,nx
		m=nxy*(k-1)+nx*(j-1)+i
		x=float(i-1)
		y=float(j-1)
		z=float(k-1)
		u(m,1)=x*exx+y*exy+z*exz
                u(m,2)=x*exy+y*eyy+z*eyz
                u(m,3)=x*exz+y*eyz+z*ezz
1050	continue

c  RELAXATION LOOP
c  (USER) kmax is the maximum number of times dembx will be called, with
c  ldemb conjugate gradient steps performed during each call.  The total
c  number of conjugate gradient steps allowed for a given elastic
c  computation is kmax*ldemb.
        kmax=50
        ldemb=50
        ltot=0
c  Call energy to get initial energy and initial gradient
        call energy(nx,ny,nz,ns,utot)
c  gg is the norm squared of the gradient (gg=gb*gb)
 	gg=0.0
        do 100 m3=1,3
        do 100 m=1,ns
        gg=gg+gb(m,m3)*gb(m,m3)
100     continue
	write(7,*) 'Initial energy = ',utot,' gg = ',gg
c        call flush(7)

        do 5000 kkk=1,kmax
c  call dembx to go into the conjugate gradient solver
        call dembx(ns,Lstep,gg,dk,gtest,ldemb,kkk)
        ltot=ltot+Lstep
c  Call energy to compute energy after dembx call. If gg < gtest, this
c  will be the final energy.  If gg is still larger than gtest, then this
c  will give an intermediate energy with which to check how the
c  relaxation process is coming along.
        call energy(nx,ny,nz,ns,utot)
	write(7,*) 'Energy = ',utot,' gg = ',gg
	write(7,*) 'Number of conjugate steps  = ',ltot
c       call flush(7)
c  If relaxation process is finished, jump out of loop
        if(gg.le.gtest) goto 444
c  If relaxation process will continue, compute and output stresses
c  and strains as an additional aid to judge how the
c  relaxation procedure is progressing.
	call stress(nx,ny,nz,ns,0)
        write(7,*) ' stresses:  xx,yy,zz,xz,yz,xy'
	write(7,*) strxx,stryy,strzz,strxz,stryz,strxy
        write(7,*) ' strains:  xx,yy,zz,xz,yz,xy'
	write(7,*) sxx,syy,szz,sxz,syz,sxy
c        call flush(7)
5000    continue

444     call stress(nx,ny,nz,ns,iwriteFlag)

	write(7,*)
	write(7,*) ' stresses:  xx,yy,zz,xz,yz,xy'
	write(7,6072) strxx,stryy,strzz,strxz,stryz,strxy
      write(7,*) ' strains:  xx,yy,zz,xz,yz,xy'
	write(7,6072) sxx,syy,szz,sxz,syz,sxy
	write(7,*)

6072	format(6(e12.5, 2x))

	BulkM  = (strxx+stryy+strzz)/(sxx+syy+szz)/3.0
	ShearM = (strxz/sxz + stryz/syz + strxy/sxy)/3.0
	fdensity = 0.0;
	do 6061 n=1,nphase
		fdensity = fdensity + density(n)*prob(n)
6061	continue

6071  format(a10,f12.5)
	write(7,6071) 'K       : ', BulkM
	write(7,6071) 'G       : ', ShearM
	write(7,6071) 'density : ', fdensity
	write(7,6071) 'Porosity: ', fporosity
	write(7,6071) 'Vp      : ', sqrt((BulkM+4.0/3.0*ShearM)/fdensity)
	write(7,6071) 'Vs      : ', sqrt(ShearM/fdensity)
	write(7,6071) 'E       : ', 9.0*BulkM*ShearM/(3.0*BulkM+ShearM)
	write(7,6071) 'Poisson : ',(3.*BulkM-2.*ShearM)/
     &                           (6.*BulkM+2.*ShearM)

c	open(unit = 8, file = 'tResult.txt', status = 'unknown')
c	write(8, 6969) fporosity, BulkM, ShearM,
c     &   sqrt((BulkM+4.0/3.0*ShearM)/fdensity),sqrt(ShearM/fdensity)
c6969  format(5(e12.5, 2x))
c	close(8)

8000    continue

        end

c  Subroutine that sets up the elastic moduli variables,
c  the stiffness matrices,dk, the linear term in
c  displacements, b, and the constant term, C, that appear in the total energy
c  due to the periodic boundary conditions

      subroutine femat(nx,ny,nz,ns,phasemod,nphase)
      real dk(100,8,3,8,3),phasemod(100,2),dndx(8),dndy(8),dndz(8)
      real b(64000000,3),g(3,3,3),C,ck(6,6),cmu(6,6),cmod(100,6,6)
      real es(6,8,3),delta(8,3)
      integer is(8)
      integer*4 ib(64000000,27)
      integer*2 pix(64000000)

	common/list2/exx,eyy,ezz,exz,eyz,exy
	common/list3/ib
        common/list4/pix
	common/list5/dk,b,C
        common/list8/cmod

      nxy=nx*ny

c  (USER) NOTE:  complete elastic modulus matrix is used, so an anisotropic
c  matrix could be directly input at any point, since program is written
c  to use a general elastic moduli tensor, but is only explicitly
c  implemented for isotropic materials.

c  initialize stiffness matrices
      do 40 m=1,nphase
      do 40 l=1,3
      do 40 k=1,3
      do 40 j=1,8
      do 40 i=1,8
      dk(m,i,k,j,l)=0.0
40    continue

c set up elastic moduli matrices for each kind of element
c  ck and cmu are the bulk and shear modulus matrices, which need to be
c  weighted by the actual bulk and shear moduli

      ck(1,1)=1.0
      ck(1,2)=1.0
      ck(1,3)=1.0
      ck(1,4)=0.0
      ck(1,5)=0.0
      ck(1,6)=0.0
      ck(2,1)=1.0
      ck(2,2)=1.0
      ck(2,3)=1.0
      ck(2,4)=0.0
      ck(2,5)=0.0
      ck(2,6)=0.0
      ck(3,1)=1.0
      ck(3,2)=1.0
      ck(3,3)=1.0
      ck(3,4)=0.0
      ck(3,5)=0.0
      ck(3,6)=0.0
      ck(4,1)=0.0
      ck(4,2)=0.0
      ck(4,3)=0.0
      ck(4,4)=0.0
      ck(4,5)=0.0
      ck(4,6)=0.0
      ck(5,1)=0.0
      ck(5,2)=0.0
      ck(5,3)=0.0
      ck(5,4)=0.0
      ck(5,5)=0.0
      ck(5,6)=0.0
      ck(6,1)=0.0
      ck(6,2)=0.0
      ck(6,3)=0.0
      ck(6,4)=0.0
      ck(6,5)=0.0
      ck(6,6)=0.0

      cmu(1,1)=4.0/3.0
      cmu(1,2)=-2.0/3.0
      cmu(1,3)=-2.0/3.0
      cmu(1,4)=0.0
      cmu(1,5)=0.0
      cmu(1,6)=0.0
      cmu(2,1)=-2.0/3.0
      cmu(2,2)=4.0/3.0
      cmu(2,3)=-2.0/3.0
      cmu(2,4)=0.0
      cmu(2,5)=0.0
      cmu(2,6)=0.0
      cmu(3,1)=-2.0/3.0
      cmu(3,2)=-2.0/3.0
      cmu(3,3)=4.0/3.0
      cmu(3,4)=0.0
      cmu(3,5)=0.0
      cmu(3,6)=0.0
      cmu(4,1)=0.0
      cmu(4,2)=0.0
      cmu(4,3)=0.0
      cmu(4,4)=1.0
      cmu(4,5)=0.0
      cmu(4,6)=0.0
      cmu(5,1)=0.0
      cmu(5,2)=0.0
      cmu(5,3)=0.0
      cmu(5,4)=0.0
      cmu(5,5)=1.0
      cmu(5,6)=0.0
      cmu(6,1)=0.0
      cmu(6,2)=0.0
      cmu(6,3)=0.0
      cmu(6,4)=0.0
      cmu(6,5)=0.0
      cmu(6,6)=1.0

      do 31 k=1,nphase
      do 21 j=1,6
      do 11 i=1,6
      cmod(k,i,j)=phasemod(k,1)*ck(i,j)+phasemod(k,2)*cmu(i,j)
11    continue
21    continue
31    continue

c  set up Simpson's integration rule weight vector
      do 30 k=1,3
      do 30 j=1,3
      do 30 i=1,3
      nm=0
      if(i.eq.2) nm=nm+1
      if(j.eq.2) nm=nm+1
      if(k.eq.2) nm=nm+1
      g(i,j,k)=4.0**nm
30    continue

c  loop over the nphase kinds of pixels and Simpson's rule quadrature
c  points in order to compute the stiffness matrices.  Stiffness matrices
c  of trilinear finite elements are quadratic in x, y, and z, so that
c  Simpson's rule quadrature gives exact results.
      do 4000 ijk=1,nphase
      do 3000 k=1,3
      do 3000 j=1,3
      do 3000 i=1,3
      x=float(i-1)/2.0
      y=float(j-1)/2.0
      z=float(k-1)/2.0
c  dndx means the negative derivative, with respect to x, of the shape
c  matrix N (see manual, Sec. 2.2), dndy, and dndz are similar.
      dndx(1)=-(1.0-y)*(1.0-z)
      dndx(2)=(1.0-y)*(1.0-z)
      dndx(3)=y*(1.0-z)
      dndx(4)=-y*(1.0-z)
      dndx(5)=-(1.0-y)*z
      dndx(6)=(1.0-y)*z
      dndx(7)=y*z
      dndx(8)=-y*z
      dndy(1)=-(1.0-x)*(1.0-z)
      dndy(2)=-x*(1.0-z)
      dndy(3)=x*(1.0-z)
      dndy(4)=(1.0-x)*(1.0-z)
      dndy(5)=-(1.0-x)*z
      dndy(6)=-x*z
      dndy(7)=x*z
      dndy(8)=(1.0-x)*z
      dndz(1)=-(1.0-x)*(1.0-y)
      dndz(2)=-x*(1.0-y)
      dndz(3)=-x*y
      dndz(4)=-(1.0-x)*y
      dndz(5)=(1.0-x)*(1.0-y)
      dndz(6)=x*(1.0-y)
      dndz(7)=x*y
      dndz(8)=(1.0-x)*y
c  now build strain matrix
      do 2799 n1=1,6
      do 2799 n2=1,8
      do 2799 n3=1,3
      es(n1,n2,n3)=0.0
2799  continue
      do 2797 n=1,8
      es(1,n,1)=dndx(n)
      es(2,n,2)=dndy(n)
      es(3,n,3)=dndz(n)
      es(4,n,1)=dndz(n)
      es(4,n,3)=dndx(n)
      es(5,n,2)=dndz(n)
      es(5,n,3)=dndy(n)
      es(6,n,1)=dndy(n)
      es(6,n,2)=dndx(n)
2797  continue
c  Matrix multiply to determine value at (x,y,z), multiply by
c  proper weight, and sum into dk, the stiffness matrix
      do 900 mm=1,3
      do 900 nn=1,3
      do 900 ii=1,8
      do 900 jj=1,8
c  Define sum over strain matrices and elastic moduli matrix for
c  stiffness matrix
      sum=0.0
      do 890 kk=1,6
      do 890 ll=1,6
      sum=sum+es(kk,ii,mm)*cmod(ijk,kk,ll)*es(ll,jj,nn)
890   continue
      dk(ijk,ii,mm,jj,nn)=dk(ijk,ii,mm,jj,nn)+g(i,j,k)*sum/216.
900   continue
3000  continue
4000  continue

c  Set up vector for linear term, b, and constant term, C,
c  in the elastic energy.  This is done using the stiffness matrices,
c  and the periodic terms in the applied strain that come in at the
c  boundary pixels via the periodic boundary conditions and the
c  condition that an applied macroscopic strain exists (see Sec. 2.2
c  in the manual). It is easier to set b up this way than to analytically
c  write out all the terms involved.

c  Initialize b and C
      do 5000 m3=1,3
      do 5000 m=1,ns
      b(m,m3)=0.0
5000  continue
      C=0.0

c  For all cases, the correspondence between 1-8 finite element node
c  labels and 1-27 neighbor labels is (see Table 4 in manual):
c  1:ib(m,27), 2:ib(m,3),
c  3:ib(m,2),4:ib(m,1),
c  5:ib(m,26),6:ib(m,19)
c  7:ib(m,18),8:ib(m,17)
      is(1)=27
      is(2)=3
      is(3)=2
      is(4)=1
      is(5)=26
      is(6)=19
      is(7)=18
      is(8)=17

c  x=nx face
      do 2001 i3=1,3
      do 2001 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.2.or.i8.eq.3.or.i8.eq.6.or.i8.eq.7) then
      delta(i8,1)=exx*nx
      delta(i8,2)=exy*nx
      delta(i8,3)=exz*nx
      end if
2001  continue
      do 2000 j=1,ny-1
      do 2000 k=1,nz-1
      m=nxy*(k-1)+j*nx
      do 1900 nn=1,3
      do 1900 mm=1,8
      sum=0.0
      do 1899 m3=1,3
      do 1899 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
1899  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1900  continue
2000  continue
c  y=ny face
      do 2011 i3=1,3
      do 2011 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.3.or.i8.eq.4.or.i8.eq.7.or.i8.eq.8) then
      delta(i8,1)=exy*ny
      delta(i8,2)=eyy*ny
      delta(i8,3)=eyz*ny
      end if
2011  continue
      do 2010 i=1,nx-1
      do 2010 k=1,nz-1
      m=nxy*(k-1)+nx*(ny-1)+i
      do 1901 nn=1,3
      do 1901 mm=1,8
      sum=0.0
      do 2099 m3=1,3
      do 2099 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
2099  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1901  continue
2010  continue
c  z=nz face
      do 2021 i3=1,3
      do 2021 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.5.or.i8.eq.6.or.i8.eq.7.or.i8.eq.8) then
      delta(i8,1)=exz*nz
      delta(i8,2)=eyz*nz
      delta(i8,3)=ezz*nz
      end if
2021  continue
      do 2020 i=1,nx-1
      do 2020 j=1,ny-1
      m=nxy*(nz-1)+nx*(j-1)+i
      do 1902 nn=1,3
      do 1902 mm=1,8
      sum=0.0
      do 2019 m3=1,3
      do 2019 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
2019  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1902  continue
2020  continue
c  x=nx y=ny edge
      do 2031 i3=1,3
      do 2031 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.2.or.i8.eq.6) then
      delta(i8,1)=exx*nx
      delta(i8,2)=exy*nx
      delta(i8,3)=exz*nx
      end if
      if(i8.eq.4.or.i8.eq.8) then
      delta(i8,1)=exy*ny
      delta(i8,2)=eyy*ny
      delta(i8,3)=eyz*ny
      end if
      if(i8.eq.3.or.i8.eq.7) then
      delta(i8,1)=exy*ny+exx*nx
      delta(i8,2)=eyy*ny+exy*nx
      delta(i8,3)=eyz*ny+exz*nx
      end if
2031  continue
      do 2030 k=1,nz-1
      m=nxy*k
      do 1903 nn=1,3
      do 1903 mm=1,8
      sum=0.0
      do 2029 m3=1,3
      do 2029 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
2029  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1903  continue
2030  continue
c  x=nx z=nz edge
      do 2041 i3=1,3
      do 2041 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.2.or.i8.eq.3) then
      delta(i8,1)=exx*nx
      delta(i8,2)=exy*nx
      delta(i8,3)=exz*nx
      end if
      if(i8.eq.5.or.i8.eq.8) then
      delta(i8,1)=exz*nz
      delta(i8,2)=eyz*nz
      delta(i8,3)=ezz*nz
      end if
      if(i8.eq.6.or.i8.eq.7) then
      delta(i8,1)=exz*nz+exx*nx
      delta(i8,2)=eyz*nz+exy*nx
      delta(i8,3)=ezz*nz+exz*nx
      end if
2041  continue
      do 2040 j=1,ny-1
      m=nxy*(nz-1)+nx*(j-1)+nx
      do 1904 nn=1,3
      do 1904 mm=1,8
      sum=0.0
      do 2039 m3=1,3
      do 2039 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
2039  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1904  continue
2040  continue
c  y=ny z=nz edge
      do 2051 i3=1,3
      do 2051 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.5.or.i8.eq.6) then
      delta(i8,1)=exz*nz
      delta(i8,2)=eyz*nz
      delta(i8,3)=ezz*nz
      end if
      if(i8.eq.3.or.i8.eq.4) then
      delta(i8,1)=exy*ny
      delta(i8,2)=eyy*ny
      delta(i8,3)=eyz*ny
      end if
      if(i8.eq.7.or.i8.eq.8) then
      delta(i8,1)=exy*ny+exz*nz
      delta(i8,2)=eyy*ny+eyz*nz
      delta(i8,3)=eyz*ny+ezz*nz
      end if
2051  continue
      do 2050 i=1,nx-1
      m=nxy*(nz-1)+nx*(ny-1)+i
      do 1905 nn=1,3
      do 1905 mm=1,8
      sum=0.0
      do 2049 m3=1,3
      do 2049 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
2049  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1905  continue
2050  continue
c  x=nx y=ny z=nz corner
      do 2061 i3=1,3
      do 2061 i8=1,8
      delta(i8,i3)=0.0
      if(i8.eq.2) then
      delta(i8,1)=exx*nx
      delta(i8,2)=exy*nx
      delta(i8,3)=exz*nx
      end if
      if(i8.eq.4) then
      delta(i8,1)=exy*ny
      delta(i8,2)=eyy*ny
      delta(i8,3)=eyz*ny
      end if
      if(i8.eq.5) then
      delta(i8,1)=exz*nz
      delta(i8,2)=eyz*nz
      delta(i8,3)=ezz*nz
      end if
      if(i8.eq.8) then
      delta(i8,1)=exy*ny+exz*nz
      delta(i8,2)=eyy*ny+eyz*nz
      delta(i8,3)=eyz*ny+ezz*nz
      end if
      if(i8.eq.6) then
      delta(i8,1)=exx*nx+exz*nz
      delta(i8,2)=exy*nx+eyz*nz
      delta(i8,3)=exz*nx+ezz*nz
      end if
      if(i8.eq.3) then
      delta(i8,1)=exx*nx+exy*ny
      delta(i8,2)=exy*nx+eyy*ny
      delta(i8,3)=exz*nx+eyz*ny
      end if
      if(i8.eq.7) then
      delta(i8,1)=exx*nx+exy*ny+exz*nz
      delta(i8,2)=exy*nx+eyy*ny+eyz*nz
      delta(i8,3)=exz*nx+eyz*ny+ezz*nz
      end if
2061  continue
      m=nx*ny*nz
      do 1906 nn=1,3
      do 1906 mm=1,8
      sum=0.0
      do 2059 m3=1,3
      do 2059 m8=1,8
      sum=sum+delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)
      C=C+0.5*delta(m8,m3)*dk(pix(m),m8,m3,mm,nn)*delta(mm,nn)
2059  continue
      b(ib(m,is(mm)),nn)=b(ib(m,is(mm)),nn)+sum
1906  continue

      return
      end

c  Subroutine computes the total energy, utot, and the gradient, gb

      subroutine energy(nx,ny,nz,ns,utot)

	real u(64000000,3),gb(64000000,3)
	real b(64000000,3),C,utot
	real dk(100,8,3,8,3)
 	integer*4 ib(64000000,27)
 	integer*2 pix(64000000)

	common/list2/exx,eyy,ezz,exz,eyz,exy
	common/list3/ib
        common/list4/pix
	common/list5/dk,b,C
	common/list6/u
	common/list7/gb

        do 2090 m3=1,3
	do 2090 m=1,ns
	gb(m,m3)=0.0
2090	continue

c  Do global matrix multiply via small stiffness matrices, gb = A * u
c  The long statement below correctly brings in all the terms from
c  the global matrix A using only the small stiffness matrices.

        do 3000 j=1,3
        do 3000 n=1,3
	do 3000 m=1,ns
      gb(m,j)=gb(m,j)+u(ib(m,1),n)*( dk(pix(ib(m,27)),1,j,4,n)
     &+dk(pix(ib(m,7)),2,j,3,n)
     &+dk(pix(ib(m,25)),5,j,8,n)+dk(pix(ib(m,15)),6,j,7,n) )+
     &u(ib(m,2),n)*( dk(pix(ib(m,27)),1,j,3,n)
     &+dk(pix(ib(m,25)),5,j,7,n) )+
     &u(ib(m,3),n)*( dk(pix(ib(m,27)),1,j,2,n)+dk(pix(ib(m,5)),4,j,3,n)+
     &dk(pix(ib(m,13)),8,j,7,n)+dk(pix(ib(m,25)),5,j,6,n) )+
     &u(ib(m,4),n)*( dk(pix(ib(m,5)),4,j,2,n)
     &+dk(pix(ib(m,13)),8,j,6,n) )+
     &u(ib(m,5),n)*( dk(pix(ib(m,6)),3,j,2,n)+dk(pix(ib(m,5)),4,j,1,n)+
     &dk(pix(ib(m,14)),7,j,6,n)+dk(pix(ib(m,13)),8,j,5,n) )+
     &u(ib(m,6),n)*( dk(pix(ib(m,6)),3,j,1,n)
     &+dk(pix(ib(m,14)),7,j,5,n) )+
     &u(ib(m,7),n)*( dk(pix(ib(m,6)),3,j,4,n)+dk(pix(ib(m,7)),2,j,1,n)+
     &dk(pix(ib(m,14)),7,j,8,n)+dk(pix(ib(m,15)),6,j,5,n) )+
     &u(ib(m,8),n)*( dk(pix(ib(m,7)),2,j,4,n)
     &+dk(pix(ib(m,15)),6,j,8,n) )+
     &u(ib(m,9),n)*( dk(pix(ib(m,25)),5,j,4,n)
     &+dk(pix(ib(m,15)),6,j,3,n) )+
     &u(ib(m,10),n)*( dk(pix(ib(m,25)),5,j,3,n) )+
     &u(ib(m,11),n)*( dk(pix(ib(m,13)),8,j,3,n)
     &+dk(pix(ib(m,25)),5,j,2,n) )+
     &u(ib(m,12),n)*( dk(pix(ib(m,13)),8,j,2,n) )+
     &u(ib(m,13),n)*( dk(pix(ib(m,13)),8,j,1,n)
     &+dk(pix(ib(m,14)),7,j,2,n) )+
     &u(ib(m,14),n)*( dk(pix(ib(m,14)),7,j,1,n) )+
     &u(ib(m,15),n)*( dk(pix(ib(m,14)),7,j,4,n)
     &+dk(pix(ib(m,15)),6,j,1,n) )+
     &u(ib(m,16),n)*( dk(pix(ib(m,15)),6,j,4,n) )+
     &u(ib(m,17),n)*( dk(pix(ib(m,27)),1,j,8,n)
     &+dk(pix(ib(m,7)),2,j,7,n) )+
     &u(ib(m,18),n)*( dk(pix(ib(m,27)),1,j,7,n) )+
     &u(ib(m,19),n)*( dk(pix(ib(m,27)),1,j,6,n)
     &+dk(pix(ib(m,5)),4,j,7,n) )+
     &u(ib(m,20),n)*( dk(pix(ib(m,5)),4,j,6,n) )+
     &u(ib(m,21),n)*( dk(pix(ib(m,5)),4,j,5,n)
     &+dk(pix(ib(m,6)),3,j,6,n) )+
     &u(ib(m,22),n)*( dk(pix(ib(m,6)),3,j,5,n) )+
     &u(ib(m,23),n)*( dk(pix(ib(m,6)),3,j,8,n)
     &+dk(pix(ib(m,7)),2,j,5,n) )+
     &u(ib(m,24),n)*( dk(pix(ib(m,7)),2,j,8,n) )+
     &u(ib(m,25),n)*( dk(pix(ib(m,14)),7,j,3,n)
     &+dk(pix(ib(m,13)),8,j,4,n)+
     &dk(pix(ib(m,15)),6,j,2,n)+dk(pix(ib(m,25)),5,j,1,n) )+
     &u(ib(m,26),n)*( dk(pix(ib(m,6)),3,j,7,n)
     &+dk(pix(ib(m,5)),4,j,8,n)+
     &dk(pix(ib(m,27)),1,j,5,n)+dk(pix(ib(m,7)),2,j,6,n) )+
     &u(ib(m,27),n)*( dk(pix(ib(m,27)),1,j,1,n)
     &+dk(pix(ib(m,7)),2,j,2,n)+
     &dk(pix(ib(m,6)),3,j,3,n)+dk(pix(ib(m,5)),4,j,4,n)
     &+dk(pix(ib(m,25)),5,j,5,n)+
     &dk(pix(ib(m,15)),6,j,6,n)+dk(pix(ib(m,14)),7,j,7,n)+
     &dk(pix(ib(m,13)),8,j,8,n) )
3000	continue

	utot=C
        do 3100 m3=1,3
	do 3100 m=1,ns
	utot=utot+0.5*u(m,m3)*gb(m,m3)+b(m,m3)*u(m,m3)
	gb(m,m3)=gb(m,m3)+b(m,m3)
3100	continue

        return
        end

c  Subroutine that carries out the conjugate gradient relaxation process

      subroutine dembx(ns,Lstep,gg,dk,gtest,ldemb,kkk)
      real gb(64000000,3),u(64000000,3),dk(100,8,3,8,3)
      real h(64000000,3),Ah(64000000,3)
      real lambda,gamma
      integer*4 ib(64000000,27)
      integer*2 pix(64000000)

      common/list3/ib
      common/list4/pix
      common/list6/u
      common/list7/gb
      common/list9/h,Ah

c  Initialize the conjugate direction vector on first call to dembx only
c  For calls to dembx after the first, we want to continue using the
c  value of h determined in the previous call. Of course, if npoints is
c  greater than 1, this initialization step will be run for every new
c  microstructure used, as kkk is reset to 1 every time the counter micro
c  is increased.
      if(kkk.eq.1) then
      do 500 m3=1,3
      do 500 m=1,ns
      h(m,m3)=gb(m,m3)
500   continue
      end if
c  Lstep counts the number of conjugate gradient steps taken in
c  each call to dembx
      Lstep=0

      do 800 ijk=1,ldemb
      Lstep=Lstep+1

      do 290 m3=1,3
      do 290 m=1,ns
      Ah(m,m3)=0.0
290   continue
c  Do global matrix multiply via small stiffness matrices, Ah = A * h
c  The long statement below correctly brings in all the terms from
c  the global matrix A using only the small stiffness matrices dk.
        do 400 j=1,3
        do 400 n=1,3
	do 400 m=1,ns
      Ah(m,j)=Ah(m,j)+h(ib(m,1),n)*( dk(pix(ib(m,27)),1,j,4,n)
     &+dk(pix(ib(m,7)),2,j,3,n)
     &+dk(pix(ib(m,25)),5,j,8,n)+dk(pix(ib(m,15)),6,j,7,n) )+
     &h(ib(m,2),n)*( dk(pix(ib(m,27)),1,j,3,n)
     &+dk(pix(ib(m,25)),5,j,7,n) )+
     &h(ib(m,3),n)*( dk(pix(ib(m,27)),1,j,2,n)+dk(pix(ib(m,5)),4,j,3,n)+
     &dk(pix(ib(m,13)),8,j,7,n)+dk(pix(ib(m,25)),5,j,6,n) )+
     &h(ib(m,4),n)*( dk(pix(ib(m,5)),4,j,2,n)
     &+dk(pix(ib(m,13)),8,j,6,n) )+
     &h(ib(m,5),n)*( dk(pix(ib(m,6)),3,j,2,n)+dk(pix(ib(m,5)),4,j,1,n)+
     &dk(pix(ib(m,14)),7,j,6,n)+dk(pix(ib(m,13)),8,j,5,n) )+
     &h(ib(m,6),n)*( dk(pix(ib(m,6)),3,j,1,n)
     &+dk(pix(ib(m,14)),7,j,5,n) )+
     &h(ib(m,7),n)*( dk(pix(ib(m,6)),3,j,4,n)+dk(pix(ib(m,7)),2,j,1,n)+
     &dk(pix(ib(m,14)),7,j,8,n)+dk(pix(ib(m,15)),6,j,5,n) )+
     &h(ib(m,8),n)*( dk(pix(ib(m,7)),2,j,4,n)
     &+dk(pix(ib(m,15)),6,j,8,n) )+
     &h(ib(m,9),n)*( dk(pix(ib(m,25)),5,j,4,n)
     &+dk(pix(ib(m,15)),6,j,3,n) )+
     &h(ib(m,10),n)*( dk(pix(ib(m,25)),5,j,3,n) )+
     &h(ib(m,11),n)*( dk(pix(ib(m,13)),8,j,3,n)
     &+dk(pix(ib(m,25)),5,j,2,n) )+
     &h(ib(m,12),n)*( dk(pix(ib(m,13)),8,j,2,n) )+
     &h(ib(m,13),n)*( dk(pix(ib(m,13)),8,j,1,n)
     &+dk(pix(ib(m,14)),7,j,2,n) )+
     &h(ib(m,14),n)*( dk(pix(ib(m,14)),7,j,1,n) )+
     &h(ib(m,15),n)*( dk(pix(ib(m,14)),7,j,4,n)
     &+dk(pix(ib(m,15)),6,j,1,n) )+
     &h(ib(m,16),n)*( dk(pix(ib(m,15)),6,j,4,n) )+
     &h(ib(m,17),n)*( dk(pix(ib(m,27)),1,j,8,n)
     &+dk(pix(ib(m,7)),2,j,7,n) )+
     &h(ib(m,18),n)*( dk(pix(ib(m,27)),1,j,7,n) )+
     &h(ib(m,19),n)*( dk(pix(ib(m,27)),1,j,6,n)
     &+dk(pix(ib(m,5)),4,j,7,n) )+
     &h(ib(m,20),n)*( dk(pix(ib(m,5)),4,j,6,n) )+
     &h(ib(m,21),n)*( dk(pix(ib(m,5)),4,j,5,n)
     &+dk(pix(ib(m,6)),3,j,6,n) )+
     &h(ib(m,22),n)*( dk(pix(ib(m,6)),3,j,5,n) )+
     &h(ib(m,23),n)*( dk(pix(ib(m,6)),3,j,8,n)
     &+dk(pix(ib(m,7)),2,j,5,n) )+
     &h(ib(m,24),n)*( dk(pix(ib(m,7)),2,j,8,n) )+
     &h(ib(m,25),n)*( dk(pix(ib(m,14)),7,j,3,n)
     &+dk(pix(ib(m,13)),8,j,4,n)+
     &dk(pix(ib(m,15)),6,j,2,n)+dk(pix(ib(m,25)),5,j,1,n) )+
     &h(ib(m,26),n)*( dk(pix(ib(m,6)),3,j,7,n)
     &+dk(pix(ib(m,5)),4,j,8,n)+
     &dk(pix(ib(m,27)),1,j,5,n)+dk(pix(ib(m,7)),2,j,6,n) )+
     &h(ib(m,27),n)*( dk(pix(ib(m,27)),1,j,1,n)
     &+dk(pix(ib(m,7)),2,j,2,n)+
     &dk(pix(ib(m,6)),3,j,3,n)+dk(pix(ib(m,5)),4,j,4,n)
     &+dk(pix(ib(m,25)),5,j,5,n)+
     &dk(pix(ib(m,15)),6,j,6,n)+dk(pix(ib(m,14)),7,j,7,n)+
     &dk(pix(ib(m,13)),8,j,8,n) )
400    continue

      hAh=0.0
      do 530 m3=1,3
      do 530 m=1,ns
      hAh=hAh+h(m,m3)*Ah(m,m3)
530   continue

      lambda=gg/hAh
      do 540 m3=1,3
      do 540 m=1,ns
      u(m,m3)=u(m,m3)-lambda*h(m,m3)
      gb(m,m3)=gb(m,m3)-lambda*Ah(m,m3)
540   continue

      gglast=gg
      gg=0.0
      do 550 m3=1,3
      do 550 m=1,ns
      gg=gg+gb(m,m3)*gb(m,m3)
550   continue
      if(gg.lt.gtest) goto 1000

      gamma=gg/gglast
      do 570 m3=1,3
      do 570 m=1,ns
      h(m,m3)=gb(m,m3)+gamma*h(m,m3)
570   continue

800   continue

1000  continue

      return
      end

c  Subroutine that computes the six average stresses and six
c  average strains.

      subroutine stress(nx,ny,nz,ns,iwriteFlag)
      real u(64000000,3),gb(64000000,3),uu(8,3)
      real dndx(8),dndy(8),dndz(8),es(6,8,3),cmod(100,6,6)
      integer*4 ib(64000000,27)
      integer*2 pix(64000000)

	common/list1/strxx,stryy,strzz,strxz,stryz,strxy
	common/list2/exx,eyy,ezz,exz,eyz,exy
	common/list3/ib
        common/list4/pix
	common/list6/u
	common/list7/gb
        common/list8/cmod
	common/list10/sxx,syy,szz,sxz,syz,sxy

      nxy=nx*ny

c  set up single element strain matrix
c  dndx, dndy, and dndz are the components of the average strain
c  matrix in a pixel

      dndx(1)=-0.25
      dndx(2)=0.25
      dndx(3)=0.25
      dndx(4)=-0.25
      dndx(5)=-0.25
      dndx(6)=0.25
      dndx(7)=0.25
      dndx(8)=-0.25
      dndy(1)=-0.25
      dndy(2)=-0.25
      dndy(3)=0.25
      dndy(4)=0.25
      dndy(5)=-0.25
      dndy(6)=-0.25
      dndy(7)=0.25
      dndy(8)=0.25
      dndz(1)=-0.25
      dndz(2)=-0.25
      dndz(3)=-0.25
      dndz(4)=-0.25
      dndz(5)=0.25
      dndz(6)=0.25
      dndz(7)=0.25
      dndz(8)=0.25
c  Build averaged strain matrix, follows code in femat, but for average
c  strain over the pixel, not the strain at a point.
      do 2799 n1=1,6
      do 2799 n2=1,8
      do 2799 n3=1,3
      es(n1,n2,n3)=0.0
2799  continue
      do 2797 n=1,8
      es(1,n,1)=dndx(n)
      es(2,n,2)=dndy(n)
      es(3,n,3)=dndz(n)
      es(4,n,1)=dndz(n)
      es(4,n,3)=dndx(n)
      es(5,n,2)=dndz(n)
      es(5,n,3)=dndy(n)
      es(6,n,1)=dndy(n)
      es(6,n,2)=dndx(n)
2797  continue

c  Compute components of the average stress and strain tensors in each pixel
      strxx=0.0
      stryy=0.0
      strzz=0.0
      strxz=0.0
      stryz=0.0
      strxy=0.0
      sxx=0.0
      syy=0.0
      szz=0.0
      sxz=0.0
      syz=0.0
      sxy=0.0

	if(iwriteFlag .eq. 1) open(unit=3, file='stressField.dat')

      do 470 k=1,nz
      do 470 j=1,ny
      do 470 i=1,nx
      m=(k-1)*nxy+(j-1)*nx+i
c  load in elements of 8-vector using pd. bd. conds.
      do 9898 mm=1,3
      uu(1,mm)=u(m,mm)
      uu(2,mm)=u(ib(m,3),mm)
      uu(3,mm)=u(ib(m,2),mm)
      uu(4,mm)=u(ib(m,1),mm)
      uu(5,mm)=u(ib(m,26),mm)
      uu(6,mm)=u(ib(m,19),mm)
      uu(7,mm)=u(ib(m,18),mm)
      uu(8,mm)=u(ib(m,17),mm)
9898  continue
c  Correct for periodic boundary conditions, some displacements are wrong
c  for a pixel on a periodic boundary.  Since they come from an opposite
c  face, need to put in applied strain to correct them.
      if(i.eq.nx) then
      uu(2,1)=uu(2,1)+exx*nx
      uu(2,2)=uu(2,2)+exy*nx
      uu(2,3)=uu(2,3)+exz*nx
      uu(3,1)=uu(3,1)+exx*nx
      uu(3,2)=uu(3,2)+exy*nx
      uu(3,3)=uu(3,3)+exz*nx
      uu(6,1)=uu(6,1)+exx*nx
      uu(6,2)=uu(6,2)+exy*nx
      uu(6,3)=uu(6,3)+exz*nx
      uu(7,1)=uu(7,1)+exx*nx
      uu(7,2)=uu(7,2)+exy*nx
      uu(7,3)=uu(7,3)+exz*nx
      end if
      if(j.eq.ny) then
      uu(3,1)=uu(3,1)+exy*ny
      uu(3,2)=uu(3,2)+eyy*ny
      uu(3,3)=uu(3,3)+eyz*ny
      uu(4,1)=uu(4,1)+exy*ny
      uu(4,2)=uu(4,2)+eyy*ny
      uu(4,3)=uu(4,3)+eyz*ny
      uu(7,1)=uu(7,1)+exy*ny
      uu(7,2)=uu(7,2)+eyy*ny
      uu(7,3)=uu(7,3)+eyz*ny
      uu(8,1)=uu(8,1)+exy*ny
      uu(8,2)=uu(8,2)+eyy*ny
      uu(8,3)=uu(8,3)+eyz*ny
      end if
      if(k.eq.nz) then
      uu(5,1)=uu(5,1)+exz*nz
      uu(5,2)=uu(5,2)+eyz*nz
      uu(5,3)=uu(5,3)+ezz*nz
      uu(6,1)=uu(6,1)+exz*nz
      uu(6,2)=uu(6,2)+eyz*nz
      uu(6,3)=uu(6,3)+ezz*nz
      uu(7,1)=uu(7,1)+exz*nz
      uu(7,2)=uu(7,2)+eyz*nz
      uu(7,3)=uu(7,3)+ezz*nz
      uu(8,1)=uu(8,1)+exz*nz
      uu(8,2)=uu(8,2)+eyz*nz
      uu(8,3)=uu(8,3)+ezz*nz
      end if

c  local stresses and strains in a pixel
      str11=0.0
      str22=0.0
      str33=0.0
      str13=0.0
      str23=0.0
      str12=0.0
      s11=0.0
      s22=0.0
      s33=0.0
      s13=0.0
      s23=0.0
      s12=0.0
      do 465 n3=1,3
      do 465 n8=1,8
      s11=s11+es(1,n8,n3)*uu(n8,n3)
      s22=s22+es(2,n8,n3)*uu(n8,n3)
      s33=s33+es(3,n8,n3)*uu(n8,n3)
      s13=s13+es(4,n8,n3)*uu(n8,n3)
      s23=s23+es(5,n8,n3)*uu(n8,n3)
      s12=s12+es(6,n8,n3)*uu(n8,n3)
      do 465 n=1,6
      str11=str11+cmod(pix(m),1,n)*es(n,n8,n3)*uu(n8,n3)
      str22=str22+cmod(pix(m),2,n)*es(n,n8,n3)*uu(n8,n3)
      str33=str33+cmod(pix(m),3,n)*es(n,n8,n3)*uu(n8,n3)
      str13=str13+cmod(pix(m),4,n)*es(n,n8,n3)*uu(n8,n3)
      str23=str23+cmod(pix(m),5,n)*es(n,n8,n3)*uu(n8,n3)
      str12=str12+cmod(pix(m),6,n)*es(n,n8,n3)*uu(n8,n3)
465   continue
c  sum local strains and stresses into global values
      strxx=strxx+str11
      stryy=stryy+str22
      strzz=strzz+str33
      strxz=strxz+str13
      stryz=stryz+str23
      strxy=strxy+str12
      sxx=sxx+s11
      syy=syy+s22
      szz=szz+s33
      sxz=sxz+s13
      syz=syz+s23
      sxy=sxy+s12

	if(iwriteFlag .eq. 1) write(3,6070) str11, str22, str33, str13,
     &	str23, str12

6070	format(6(e12.5, 2x))

470   continue

c  Volume average of global stresses and strains
      strxx=strxx/float(ns)
      stryy=stryy/float(ns)
      strzz=strzz/float(ns)
      strxz=strxz/float(ns)
      stryz=stryz/float(ns)
      strxy=strxy/float(ns)
      sxx=sxx/float(ns)
      syy=syy/float(ns)
      szz=szz/float(ns)
      sxz=sxz/float(ns)
      syz=syz/float(ns)
      sxy=sxy/float(ns)

      return
      end

c  Subroutine that counts volume fractions

      subroutine assig(ns,nphase,prob)
      integer*2 pix(64000000)
      real prob(100)

      common/list4/pix

	do 90 i=1,nphase
	prob(i)=0.0
90      continue

        do 100 m=1,ns
	do 100 i=1,nphase
        if(pix(m).eq.i) then
	prob(i)=prob(i)+1
	end if
100     continue

	do 110 i=1,nphase
	prob(i)=prob(i)/float(ns)
110     continue

        return
        end

c  Subroutine that sets up microstructural image

      subroutine ppixel(nx,ny,nz,ns,nphase,nblank)
      integer*2 pix(64000000)
      common/list4/pix

c  (USER)  If you want to set up a test image inside the program, instead of
c  reading it in from a file, this should be done inside this subroutine.

      nxy=nx*ny

	do 291 k=1,nblank
	read(9,*)
291   continue

      do 200 k=1,nz
      do 200 j=1,ny
      do 200 i=1,nx
      m=nxy*(k-1)+nx*(j-1)+i
      read(9,*) pix(m)
	pix(m) = pix(m) + 1
200   continue

c  Check for wrong phase labels--less than 1 or greater than nphase
       do 500 m=1,ns
       if(pix(m).lt.1) then
        write(7,*) 'Phase label in pix < 1--error at ',m
       end if
       if(pix(m).gt.nphase) then
        write(7,*) 'Phase label in pix > nphase--error at ',m
       end if
500    continue

      return
      end


c=======================================================================
c
c     subroutine KATOAD
c
c     This function computes the Kato decomposition of a symmetric matrix
c     with adaptative esp-Kato sensitivity algorithm (Toufik Bellaj method)
c
c-----------------------------------------------------------------------
      SUBROUTINE katoad ( n, X, nsep, epsin, indpca,
     &                    iwork, dwork,
     &                    epskat, soreig, vpmat, nbkgrp, grpkat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : matrix (n*n)                                double
c            nsep   : step to separate (=1 the next)             integer
c            epsin  : Kato-sensitivity                            double
c            indpca : indicator                                  integer
c
c     WORKSPACE
c            iwork  : vector ( 12*n )                            integer
c            dwork  : matrix ( n*(2*n+27) )                       double
c
c     OUTPUT
c            epskat : Kato sensibility                            double
c            soreig : sorted eigenvalues (n)                      double
c            vpmat  : ordered eigenvectors (n*n)                  double
c            nbkgrp : number of Kato groups                      integer
c            grpkat : Kato groups (n) output size (nbkgrp)       integer
c            info   : diagnostic argument                        integer
c
c     CALL
c           SCHURSO : SCHUR decomposition of a symmetric matrix
c                     sorts eigenvalues and eigenvectors (decrease order)
c           GREPS   : computes groups for a sensibility epsilon
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, nsep, nbkgrp, indpca, info
      INTEGER grpkat(*)
      DOUBLE PRECISION epsin, epskat
      DOUBLE PRECISION soreig(*), X(*), vpmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pdw, peig
c
c     external subroutines
      EXTERNAL schurso, greps, epspca
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     test if nsep in [1,...,n]
      IF ( ( nsep.lt.1 ).or.( nsep.gt.n ) ) THEN
         info = -2002
         RETURN
      ENDIF
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw    : pointer for workspaces SCHURSO needs (12*n)
c     pinext = piw + ( 12*n )
c     pinext : pointer for the next iwork array
c
c     Total size of iwork array ( 12*n )
c
c     pointers for double precision work space  : work(nasmax,*)
c     ----------------------------------------------------------
      peig = 1
c     peig   : pointer for vector(n), so (n) more
      pdw = peig + ( n )
c     pdw    : pointer for workspaces SCHURSO needs ( n*(2*n+26) )
c
c     Total size of dwork array = ( n*(2*n + 27) )
c
c-----------------------------------------------------------------------
c
c     Schur factorization (PCA)
      CALL schurso ( n, X, iwork(piw), dwork(pdw),
     &               dwork(peig), soreig, vpmat, info )
      IF (info .LT. 0) RETURN
c
c     Kato-sensitivity
      CALL epspca ( n, soreig, iwork(piw), dwork(pdw),
     &              nbkgrp, grpkat, epskat, info )
c
c     case Kato-sensitivity as input
      IF (indpca .EQ. 11) THEN
        epskat = epsin
c
c       Kato-groups (structure)
        CALL greps ( n, soreig, epskat, nbkgrp, grpkat, info )
      ENDIF
c
      RETURN
      END


      subroutine spherg(r,nfi,nteta,dx,dy,dz,nlines,nbeg)
           dimension dx(2,nlines),dy(2,nlines),dz(2,nlines)
C  ***************************************************************
C   "nteta-1" gorizontal circles per "nfi" lines.
C   the total number of lines is "nfi*(nteta-1)".
C   "nfi,nteta" - the number of lines per circle or semi-circle.
C  ***************************************************************
      k=nbeg
      dteta=3.14159265/nteta
      dfi=2.*3.14159265/nfi
C
      teta=0.
      nteta1=nteta-1
      do 2 j=1,nteta1
      teta=teta+dteta
      fi=0.
      do 1 i=1,nfi
      dz(1,k)=r*sin(teta)*cos(fi)
      dx(1,k)=r*sin(teta)*sin(fi)
      dy(1,k)=r*cos(teta)
      fi=fi+dfi
      dz(2,k)=r*sin(teta)*cos(fi)
      dx(2,k)=r*sin(teta)*sin(fi)
      dy(2,k)=r*cos(teta)
      k=k+1
1      continue
2      continue
      return
      end


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine cholesky  --  modified Cholesky linear solver  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "cholesky" uses a modified Cholesky method to solve the linear
c     system Ax = b, returning "x" in "b"; "A" is a real symmetric
c     positive definite matrix with its upper triangle (including the
c     diagonal) stored by rows
c
c     literature reference:
c
c     R. S. Martin, G. Peters and J. H. Wilkinson, "Symmetric
c     Decomposition of a Positive Definite Matrix", Numerische
c     Mathematik, 7, 362-383 (1965)
c
c
      subroutine cholesky (nvar,a,b)
      implicit none
      integer i,j,k,nvar
      integer ii,ij,ik,ki,kk
      integer im,jk,jm
      real*8 r,s,t
      real*8 a(*)
      real*8 b(*)
c
c
c     Cholesky factorization to reduce "A" to (L)(D)(L transpose)
c     "L" has a unit diagonal; store 1.0/D on the diagonal of "A"
c
      ii = 1
      do i = 1, nvar
         im = i - 1
         if (i .ne. 1) then
            ij = i
            do j = 1, im
               r = a(ij)
               if (j .ne. 1) then
                  ik = i
                  jk = j
                  jm = j - 1
                  do k = 1, jm
                     r = r - a(ik)*a(jk)
                     ik = nvar - k + ik
                     jk = nvar - k + jk
                  end do
               end if
               a(ij) = r
               ij = nvar - j + ij
            end do
         end if
         r = a(ii)
         if (i .ne. 1) then
            kk = 1
            ik = i
            do k = 1, im
               s = a(ik)
               t = s * a(kk)
               a(ik) = t
               r = r - s*t
               ik = nvar - k + ik
               kk = nvar - k + 1 + kk
            end do
         end if
         a(ii) = 1.0d0 / r
         ii = nvar - i + 1 + ii
      end do
c
c     solve linear equations; first solve Ly = b for y
c
      do i = 1, nvar
         if (i .ne. 1) then
            ik = i
            im = i - 1
            r = b(i)
            do k = 1, im
               r = r - b(k)*a(ik)
               ik = nvar - k + ik
            end do
            b(i) = r
         end if
      end do
c
c     finally, solve (D)(L transpose)(x) = y for x
c
      ii = nvar*(nvar+1)/2
      do j = 1, nvar
         i = nvar + 1 - j
         r = b(i) * a(ii)
         if (j .ne. 1) then
            im = i + 1
            ki = ii + 1
            do k = im, nvar
               r = r - a(ki)*b(k)
               ki = ki + 1
            end do
         end if
         b(i) = r
         ii = ii - j - 1
      end do
      return
      end


      SUBROUTINE TRIDAG(A,B,C,R,U,N)
      PARAMETER (NMAX=100)
      DIMENSION GAM(NMAX),A(N),B(N),C(N),R(N),U(N)
      IF(B(1).EQ.0.)PAUSE
      BET=B(1)
      U(1)=R(1)/BET
      DO 11 J=2,N
        GAM(J)=C(J-1)/BET
        BET=B(J)-A(J)*GAM(J)
        IF(BET.EQ.0.)PAUSE
        U(J)=(R(J)-A(J)*U(J-1))/BET
11    CONTINUE
      DO 12 J=N-1,1,-1
        U(J)=U(J)-GAM(J+1)*U(J+1)
12    CONTINUE
      RETURN
      END


      SUBROUTINE EIGEN(MAX, N, A, ER, EI, ISV, ILV, V, WK, IERR)
C
C   PURPOSE:
C      Compute all the eigenvalues and eigenvectors of a real n x n
C      matrix A stored as a variable-dimensioned two-dimensional array.
C
C   REFERENCES:
C      Parlett, B.N.; and Reinsch, C.: Balancing a Matrix for Calcula-
C        tion of Eigenvalues and Eigenvectors. Numer. Math., Bd 13,
C        Heft 4, 1969, pp. 293-304.
C      Martin, R.S.; and Wilkinson, J.H.: Similarity Reduction of a
C        General Matrix to Hessenberg Form. Numer. Math., Bd. 12, Heft
C        5, 1968, pp. 349-368.
C      Martin, R.S.; Peters, G.; and Wilkinson, J.H.: The QR Algorithm
C        for Real Hesenberg Matrices. Numer. Math., Bd. 14, Heft 3,
C        1970, pp. 219-231.
C      Wilkinson, J.H.; and Reinsch, C.: Handbook for Automatic Compu-
C        tation. Volume II - Linear Algebra. Springer-Verlag, 1971.
C
C   Subroutines employed by EIGEN: BALANC, BALBAK, CDIV, DAMCON, ELMHES,
C      ELTRAN, HQR, HQR2
C   Subroutines employing EIGEN: ASYREG, BILIN, CNTREG, CSTAB, DSTAB,
C      TESTST, POLE
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(MAX,N),ER(N),EI(N),V(MAX,1),WK(N,1)
C
      IF (((ISV .NE. 0) .AND. (ISV .NE. N))
     1   .OR.  (ILV .NE. 0))   GO TO 999
C
C   *** PRELIMINARY REDUCTION ***
      CALL BALANC (MAX,N,A,LOW,IGH,WK)
      CALL ELMHES (MAX,N,LOW,IGH,A,WK(1,2))
      IV = ISV + ILV
C
      IF (IV .EQ. 0) THEN
C        *** COMPUTE ONLY EIGENVALUES ***
         CALL HQR (MAX,N,LOW,IGH,A,ER,EI,IERR)
      ELSE
C        *** COMPUTE EIGENVALUES AND EIGENVECTORS ***
         CALL ELTRAN (MAX,N,LOW,IGH,A,WK(1,2),V)
         CALL HQR2 (MAX,N,LOW,IGH,A,ER,EI,V,IERR)
      END IF
C
      IF (IERR .NE. 0)   GO TO 9999
C
      IF (IV .NE. 0) CALL BALBAK (MAX,N,LOW,IGH,WK,N,V)
C
      DO I = 1,N
         WK(I,1) = ER(I)
         WK(I,2) = EI(I)
         WK(I,3) = ER(I)**2 + EI(I)**2
      END DO
C
C   ***** NORMALIZE EIGENVECTORS *****
      J = 0
      DO WHILE (J .LT. IV)
         J = J + 1
         M = 1
         IF (EI(J) .EQ. 0) THEN
C           *** NORMALIZE REAL EIGENVECTOR ***
            DO I = 2,N
               IF (DABS(V(I,J)) .GT. DABS(V(M,J)))  M = I
            END DO
            IF (V(M,J) .NE. 0.0D0)  THEN
               DO I = 1,N
                  WK(I,J+3) = V(I,J) / V(M,J)
               END DO
            END IF
         ELSE
C           *** NORMALIZE COMPLEX EIGENVECTOR ***
            JP1 = J + 1
            DO I = 2,N
               IF ((DABS(V(I,J)) + DABS(V(I,JP1))) .GT.
     1             (DABS(V(M,J)) + DABS(V(M,JP1))))  M = I
            END DO
            IF ((V(M,J) .NE. 0.0D0) .OR. (V(M,JP1) .NE. 0.0D0)) THEN
               DO I = 1,N
                  CALL CDIV (V(I,J),V(I,JP1),V(M,J),V(M,JP1),
     1                       WK(I,J+3),WK(I,J+4))
               END DO
            END IF
            J = JP1
         END IF
      END DO
C
C   ***** ORDER EIGENVALUES AND EIGENVECTORS FOR OUTPUT *****
C
      DO I = 1,N
         P = DAMCON(1)
         DO J = 1,N
            IF (WK(J,3) .LT. P) THEN
               K = J
               P = WK(J,3)
            END IF
         END DO
         ER(I) = WK(K,1)
         EI(I) = WK(K,2)
         IF (IV .NE. 0) THEN
C           *** MOVE EIGENVECTOR ***
            DO J = 1,N
               V(J,I) = WK(J,K+3)
            END DO
         END IF
         WK(K,3) = DAMCON(1)
      END DO
      RETURN
C   *** ERROR MESSAGES ***
  999 WRITE(6,1001) ISV,ILV,N
 1001 FORMAT (' ILLEGAL USE OF EIGEN: ISV = ',I4,', ILV = ',I4,/,
     1' ISV MUST EQUAL ',I4,' AND ILV MUST EQUAL 0')
 9999 RETURN
      END


*----------------------------------------------------------------------*
      subroutine invsqrt_mat(ndim,mat,mat2,half,umat,get_u,
     &                       singval,icnt_sv,icnt_sv0,
     &                       xmax,xmin,bins)
*----------------------------------------------------------------------*
*     half = true: calculates U*mat^(-0.5) using MAT = U*mat*U^+
*     half = false: calculates both U*mat^(-0.5) and U*1s*U^+
*                   which is a projector matrix for eliminating
*                   linear redundancies
*
*     on input:  mat contains the matrix to be inverted
*     on output: mat contains U*mat^(-0.5)
*                mat2 contains U*1s*U^+ (projector)
*
*     matthias, dec 2009
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'routes.h'
      include 'def_filinf.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00
      character(len=*),parameter::
     &     i_am="invsqrt_mat"
      real(8), parameter ::
     &     warn_sv = 1d-12!5  ! give a warning for small singular values
      integer, intent(in) ::
     &     ndim
      integer, intent(inout) ::
     &     icnt_sv, icnt_sv0, bins(17)
      real(8), intent(inout), target ::
     &     mat(ndim,ndim), mat2(ndim,ndim), xmax, xmin, umat(ndim,ndim)
      real(8), intent(out) ::
     &     singval(ndim)
      logical, intent(in) ::
     &     half, get_u
      real(8) ::
     &     dum1,dum2,expo
      real(8), pointer ::
     &     mat_tmp(:,:),mat_tmpv(:),  !mat_tmpv is only a handler for the mat_tmp memory as memman can only allocate one dimensional vectors
     &     wrk(:)

      type(filinf) ::
     &     ffsv
      integer ::
     &     idx, lwrk, info, idx2, luinp, iostatus,
     &     ifree
      logical ::
     &     l_exist, sv_above, read_file

      if (ndim.eq.0) return

      info = 0
      lwrk=max(1024,ndim**2)
      ifree = mem_setmark('invsqrt_mat')
      ifree = mem_alloc_real(wrk, lwrk,'wrk')

      if (sv_fix) then
        inquire(file='SINGVALS',exist=l_exist)
        call file_init(ffsv,'SINGVALS',ftyp_sq_frm,0)
        call file_open(ffsv)
        luinp = ffsv%unit
        read_file = l_exist !.and.sv_old
        if (read_file) then
          do idx = 1, icnt_sv + 1
            read(luinp,*,iostat=iostatus) idx2, sv_above
          end do
          read_file = iostatus.ge.0
          rewind luinp
          do idx = 1, icnt_sv
            read(luinp,*) idx2, sv_above
          end do
        end if
      end if

      if (ntest.ge.100) then
        write(lulog,'(x,a)') '-------------------'
        write(lulog,'(x,a)') 'invsqrt_mat at work'
        write(lulog,'(x,a)') '-------------------'
        write(lulog,'(x,a,l)') 'half  = ',half
        write(lulog,'(x,a,l)') 'get_u = ',get_u
        write(lulog,*) 'input S matrix:'
        call wrtmat3(mat,ndim,ndim,ndim,ndim)
      end if

      ! check if S is symmetric
      do idx = 2, ndim
        do idx2 = 1,idx-1
          if (abs(mat(idx,idx2)-mat(idx2,idx)).gt.1d-10) then
            write(lulog,*) 'idx,idx2:',idx,idx2
            write(lulog,*) 'mat(idx,idx2): ',mat(idx,idx2)
            write(lulog,*) 'mat(idx2,idx): ',mat(idx2,idx)
            call quit(1,'invsqrt_mat','S must be symmetric!')
          end if
        end do
      end do

      ! calculate U and singular values:
c      call svd_drv(ndim,mat,singval)
      call dgesvd('O','N',ndim,ndim,
     &     mat,ndim,singval,
     &     dum1,1,dum2,1,
     &     wrk,lwrk,info)

      if (info.ne.0) then
        write(lulog,*) 'WARNING in invsqrt_mat: SVD in trouble'
      end if

      if (ntest.ge.100) then
        write(lulog,*) 'eigenvector matrix U:'
        call wrtmat3(mat,ndim,ndim,ndim,ndim)
        write(lulog,*) 'singular values:'
      end if

      if (get_u) umat(1:ndim,1:ndim) = mat(1:ndim,1:ndim)

c      if (half) then
c        mat_tmp => mat
       expo = -0.5d0
c      else

       if (.not.half) then
          ifree = mem_alloc_real(mat_tmpv,ndim*ndim,'mat_tmp')
          mat_tmp(1:ndim, 1:ndim) => mat_tmpv
       end if
cmh        expo = -0.25d0
c        expo = 0d0  ! to obtain matrix to project out lin. dep.
c      end if

      ! square root of (pseudo) inverse:
      ! A^(-1/2) = U D^(-1/2) U^+ = U D^(-1/4) [U D^(-1/4)]^+
      do idx = 1, ndim
        icnt_sv = icnt_sv + 1
        sv_above = .false.
        if (sv_fix.and.read_file) read(luinp,*) idx2, sv_above

        ! binning of singular value
        dum1 = singval(idx)
        do idx2 = 1, 17
          if (dum1.ge.1d0) then
            bins(idx2) = bins(idx2) + 1
            exit
          end if
          dum1 = dum1*10d0
          if (idx2.eq.17) bins(idx2) = bins(idx2) + 1
        end do

        if (.not.(sv_fix.and.read_file)
     &      .and.singval(idx).gt.sv_thresh.or.
     &      sv_above) then
          sv_above = .true.
          if (abs(singval(idx)).lt.abs(xmin)) xmin = singval(idx)
          if (singval(idx).lt.warn_sv)
     &         call warn('invsqrt_mat','small singular values!')
          if (.not.half) mat_tmp(1:ndim,idx) = mat(1:ndim,idx)
c dbg
          if (get_u) umat(1:ndim,idx) = mat(1:ndim,idx)
c dbgend
          mat(1:ndim,idx) = mat(1:ndim,idx)
     &                         * (singval(idx)**expo)
        else
          sv_above = .false.
          icnt_sv0 = icnt_sv0 + 1
          if (abs(singval(idx)).gt.abs(xmax)) xmax = singval(idx)
c dbg
          if (get_u) umat(1:ndim,idx) = 0d0
c dbgend
          mat(1:ndim,idx) = 0d0
          if (.not.half) mat_tmp(1:ndim,idx) = 0d0
        end if
        if (ntest.ge.10) write(lulog,'(x,a,i8,x,f24.12,3x,L1)') 'sv #',
     &                 icnt_sv,singval(idx),sv_above
        if (sv_fix.and..not.read_file) write(luinp,*) icnt_sv, sv_above
      end do

      if (ntest.ge.100) then
        write(lulog,'(a,f5.2,a)') 'U*s^(',expo,')'
        call wrtmat3(mat,ndim,ndim,ndim,ndim)
      end if

      if (.not.half) then
        call dgemm('n','t',ndim,ndim,ndim,
     &             1d0,mat_tmp,ndim,
     &                 mat_tmp,ndim,
     &        0d0,mat2,ndim)
        mat_tmp => null() ! mat_tmpv is automatically deallocated at flushmark.
        if (ntest.ge.100) then
          write(lulog,*) 'U*1s*U^+ projector:'
          call wrtmat3(mat2,ndim,ndim,ndim,ndim)
        end if
      end if

!      if (get_u) umat(1:ndim,1:ndim) = mat(1:ndim,1:ndim)

c dbg  can be used to set 1
c      mat(1:ndim,1:ndim) = 0d0
c      do idx = 1, ndim
c        mat(idx,idx) = 1d0
c      end do
c dbgend

      if (sv_fix) call file_close_keep(ffsv)

      ifree = mem_flushmark()
      return
      contains
      end


subroutine dft_routine
use enforce
use cluster

implicit none

integer :: a,c,b
real :: i
real, allocatable :: dft(:,:),vel(:)
real :: arg,freq,pie
pie = 3.14159265359
!npas = 20000
allocate(vel(npas))
allocate(dft(npas,1:2))
open(11,file = 'fort.56',status = 'old',action = 'read')
do a=1,npas-1
	read(11,*) i, vel(a)
enddo
do a = 1,npas-1
	dft(a,1) = 0.d0
	dft(a,2) = 0.d0
enddo

do b=1,npas-1
	!freq = 1.d0/(b*tstep)
	arg = -(2.d0*pie*dble(b)/npas)
	do c =1,npas-1
		dft(b,1) = dft(b,1) + cos(arg*dble(c))*vel(c)!*vel_act_est(n)
		dft(b,2) = dft(b,2) - sin(arg*dble(c))*vel(c)!*vel_act_est(n)
	enddo

	write(60,*) b,dft(b,1)*dft(b,1) + dft(b,2)*dft(b,2)
enddo

end subroutine dft_routine


c
c -------------------------------------------------------------
c
      subroutine vrmc(qr,ql,rx,ixmin,ixmax,iflip,msize)

      implicit double precision (a-h,o-z)
      include "cuserdt.i"

      dimension qr(4,msize),ql(4,msize)
      dimension ur(4), ul(4)
      dimension rx(4,msize),fl(4),fr(4)
c
c     local lax friedrich with input in conserved vars
c
      if (ixmax .gt. msize) then
         write(6,*)" need to increase m1size in vrm to ", ixmax
         stop
      endif

c
c     # vector Riemann solver
c     # Given conserved variables, compute
c     # conserved variables at interface by solving riemann problem
c     # only solve neighboring vertical interfaces
c     # as in Van Leer MUSCL paper # 5 (1979), JCP
c
c      iflip = 1 indicates the normal velocity is in
c                qr(k,2) and the tangential in qr(k,3)
c            = 0 indicates the reverse.
c
      inorm = 3 - iflip
      itan  = 2 + iflip
      do 10 k = ixmin, ixmax
         rhol = ql(1,k)
         rhoul   = ql(inorm,k)
         rhoutl  = ql(itan,k)
         El   = ql(4,k)
         pl = gamma1*(El-.5d0*(rhoul*rhoul+rhoutl*rhoutl)/rhol)
         cl = dsqrt(gamma * pl / rhol)
         sl = max(dabs(rhoul/rhol + cl), dabs(rhoul/rhol - cl) )

         rhor = qr(1,k)
         rhour   = qr(inorm,k)
         rhoutr  = qr(itan,k)
         Er   = qr(4,k)
         pr = gamma1*(Er-.5d0*(rhour*rhour+rhoutr*rhoutr)/rhor)
         cr = dsqrt(gamma * pr / rhor)
         sr = max(dabs(rhour/rhor + cr), dabs(rhour/rhor - cr) )

         s = max(sl,sr)

         ul(1) = rhol
         ul(inorm) = rhoul
         ul(itan) = rhoutl
         ul(4) = El

         ur(1) = rhor
         ur(inorm) = rhour
         ur(itan) = rhoutr
         ur(4) = Er

         fl(1) = rhoul
         fl(inorm) = rhoul*rhoul/rhol + pl
         fl(itan) = rhoul*rhoutl/rhol
         fl(4) = (El + pl) * rhoul/rhol

         fr(1) = rhour
         fr(inorm) = rhour*rhour/rhor + pr
         fr(itan) = rhour*rhoutr/rhor
         fr(4) = (Er + pr) * rhour/rhor

         rx(:,k) = 0.5d0*(fl(:)+fr(:)) + 0.5d0*s*(ul(:)-ur(:))

  10     continue

      return
      end


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  function random  --  portable random number generator  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "random" generates a random number on [0,1] via a long
c     period generator due to L'Ecuyer with Bays-Durham shuffle
c
c     literature references:
c
c     P. L'Ecuyer, Communications of the ACM, 31, 742-774 (1988)
c
c     W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P.
c     Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge
c     University Press, 1992, Section 7.1
c
c
      function random ()
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      integer im1,ia1,iq1,ir1
      integer im2,ia2,iq2,ir2
      integer big,nshuffle
      integer imm1,ndiv
      real*8 factor
      parameter (im1=2147483563)
      parameter (ia1=40014)
      parameter (iq1=53668)
      parameter (ir1=12211)
      parameter (im2=2147483399)
      parameter (ia2=40692)
      parameter (iq2=52774)
      parameter (ir2=3791)
      parameter (big=141803398)
      parameter (nshuffle=32)
      parameter (imm1=im1-1)
      parameter (ndiv=1+imm1/nshuffle)
      parameter (factor=1.0d0/im1)
      integer i,k,iy,next
      integer seed,seed2
      integer year,month,day
      integer hour,minute,second
      integer ishuffle(nshuffle)
      real*8 random
      logical first
      character*20 keyword
      character*120 record
      character*120 string
      save first
      save seed,seed2
      save iy,ishuffle
      data first  / .true. /
c
c
c     random number seed is first set to a big number,
c     then incremented by the seconds elapsed this decade
c
      if (first) then
         first = .false.
         seed = big
         call calendar (year,month,day,hour,minute,second)
         year = mod(year,10)
         seed = seed + 32140800*year + 2678400*(month-1)
         seed = seed + 86400*(day-1) + 3600*hour
         seed = seed + 60*minute + second
c
c     search the keywords for a random number seed
c
         do i = 1, nkey
            next = 1
            record = keyline(i)
            call gettext (record,keyword,next)
            call upcase (keyword)
            if (keyword(1:11) .eq. 'RANDOMSEED ') then
               string = record(next:120)
               read (string,*,err=10)  seed
               seed = max(1,seed)
            end if
   10       continue
         end do
c
c     print the value used for the random number seed
c
         if (verbose) then
            write (iout,20)  seed
   20       format (/,' Random Number Generator Initialized',
     &                 ' with SEED :',3x,i12)
         end if
c
c     warm up and then load the shuffling table
c
         seed2 = seed
         do i = nshuffle+8, 1, -1
            k = seed / iq1
            seed = ia1 * (seed-k*iq1) - k*ir1
            if (seed .lt. 0)  seed = seed + im1
            if (i .le. nshuffle)  ishuffle(i) = seed
         end do
         iy = ishuffle(1)
      end if
c
c     get a new random number value each call
c
      k = seed / iq1
      seed = ia1*(seed-k*iq1) - k*ir1
      if (seed .lt. 0)  seed = seed + im1
      k = seed2 / iq2
      seed2 = ia2*(seed2-k*iq2) - k*ir2
      if (seed2 .lt. 0)  seed2 = seed2 + im2
      i = 1 + iy/ndiv
      iy = ishuffle(i) - seed2
      ishuffle(i) = seed
      if (iy .lt. 1)  iy = iy + imm1
      random = factor * iy
c
c     print the value of the current random number
c
c     if (debug) then
c        write (iout,30)  random
c  30    format (' RANDOM  --  The Random Number Value is',f12.8)
c     end if
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  function normal  --  random number from normal curve  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "normal" generates a random number from a normal Gaussian
c     distribution with a mean of zero and a variance of one
c
c
      function normal ()
      implicit none
      include 'inform.i'
      include 'iounit.i'
      real*8 random,v1,v2,rsq
      real*8 factor,store,normal
      logical compute
      save compute,store
      data compute  / .true. /
c
c
c     get a pair of random values from the distribution
c
      if (compute) then
   10    continue
         v1 = 2.0d0 * random () - 1.0d0
         v2 = 2.0d0 * random () - 1.0d0
         rsq = v1**2 + v2**2
         if (rsq .ge. 1.0d0)  goto 10
         factor = sqrt(-2.0d0*log(rsq)/rsq)
         store = v1 * factor
         normal = v2 * factor
         compute = .false.
c
c     use the second random value computed at the last call
c
      else
         normal = store
         compute = .true.
      end if
c
c     print the value of the current random number
c
c     if (debug) then
c        write (iout,20)  normal
c  20    format (' NORMAL  --  The Random Number Value is',f12.8)
c     end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ranvec  --  unit vector in random direction  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ranvec" generates a unit vector in 3-dimensional
c     space with uniformly distributed random orientation
c
c     literature references:
c
c     G. Marsaglia, Ann. Math. Stat., 43, 645 (1972)
c
c     R. C. Rapaport, The Art of Molecular Dynamics Simulation,
c     2nd Edition, Cambridge University Press, 2004, Section 18.4
c
c
      subroutine ranvec (vector)
      implicit none
      include 'inform.i'
      include 'iounit.i'
      real*8 x,y,s
      real*8 random
      real*8 vector(3)
c
c
c     get a pair of appropriate components in the plane
c
      s = 2.0d0
      do while (s .ge. 1.0d0)
         x = 2.0d0 * random () - 1.0d0
         y = 2.0d0 * random () - 1.0d0
         s = x**2 + y**2
      end do
c
c     construct the 3-dimensional random unit vector
c
      vector(3) = 1.0d0 - 2.0d0*s
      s = 2.0d0 * sqrt(1.0d0 - s)
      vector(2) = s * y
      vector(1) = s * x
c
c     print the components of the random unit vector
c
c     if (debug) then
c        write (iout,10)  vector(1),vector(2),vector(3)
c  10    format (' RANVEC  --  The Random Vector is',3f10.4)
c     end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine sphere  --  uniform set of points on sphere  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "sphere" finds a specified number of uniformly distributed
c     points on a sphere of unit radius centered at the origin
c
c     literature reference:
c
c     E. B. Saff and A. B. J. Kuijlaars, "Distributing Many
c     Points on a Sphere", The Mathematical Intelligencer,
c     19, 5-11 (1997)
c
c
      subroutine sphere (ndot,dot)
      implicit none
      include 'math.i'
      integer i,ndot
      real*8 theta,phi
      real*8 h,phiold
      real*8 tot,tot1
      real*8 dot(3,*)
c
c
c     find spherical coordinates then convert to Cartesian
c
      tot = dble(ndot)
      tot1 = dble(ndot-1)
      do i = 1, ndot
         h = -1.0d0 + 2.0d0*dble(i-1)/tot1
         theta = acos(h)
         if (i.eq.1 .or. i.eq.ndot) then
            phi = 0.0d0
         else
            phi = mod(phiold+3.6d0/sqrt(tot*(1.0d0-h*h)),2.0d0*pi)
         end if
         dot(1,i) = sin(theta) * cos(phi)
         dot(2,i) = sin(theta) * sin(phi)
         dot(3,i) = cos(theta)
         phiold = phi
      end do
      return
      end


subroutine ev(cash,nrow,ncol,v,nco,prob,n,fy,eyp,grid,secondd,ret,reg_coef,ev_out)
INTEGER, INTENT(IN) :: nrow, ncol, nco, n
REAL, INTENT(IN) :: ret
REAL, INTENT(IN) :: reg_coef
REAL, INTENT(IN) :: cash(nrow,ncol),v(nco,1),prob(n,1)
REAL, INTENT(IN) ::  fy(n,1),eyp(n,1),grid(nco,1),secondd(nco,1)
REAL, INTENT(OUT) :: ev_out(nrow,ncol)
INTEGER :: ind1, ind2
REAL :: inc
REAL, allocatable :: ones(:,:), inc2(:,:), v1(:,:), aux(:,:)
ALLOCATE(ones(nrow,ncol),inc2(nrow,ncol),v1(nrow,ncol),aux(nrow,ncol))
ev_out = 0.0
ones= 1.0
do ind1=1,n
  do ind2=1,n
     inc=(fy(ind1,1)*(eyp(ind2,1)+reg_coef*ret))
     inc2 = inc*ones+cash
     inc2=MIN(inc2,grid(nco,1))
     inc2=MAX(inc2,grid(1,1))
     call splint(grid,v(:,1),secondd(:,1),nco,inc2,nrow,ncol,aux)
     v1=prob(ind1,1)*prob(ind2,1)*aux
     ev_out=ev_out+v1
  end do
end do
DEALLOCATE(ones,inc2,v1,aux)
end subroutine


      SUBROUTINE MTXMUL1(AMAT,BMAT,CMAT,NRA,NCA,NCB)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  FOR N-BY-M MATRICS AMAT, BMAT, AND CMAT, FORM THE PRODUCT
C
C                 CMAT =  AMAT * BMAT
C
C  VAR   DIM       TYPE   I/O   DESCRIPTION
C  ---   ---       ----   ---   -----------
C
C  AMAT  NRA,NCA   R*8    I     INPUT MATRIX.
C
C  BMAT  NCA,NCB   R*8    I     INPUT MATRIX.
C
C  CMAT  NRA,NCB   R*8    O     OUTPUT MATRIX. PRODUCT AMAT*BMAT.
C                               NOTE THAT IN THE CALLING PROGRAM,
C                               CMAT MAY NOT BE ONE OF AMAT AND BMAT.
C                               THAT IS, THE CALL
C                               CALL MTXMUL1(A,B,A,.....) IS INVALID.
C
C  NRA   1         I*4    I     NUMBER OF ROWS IN MATRICES AMAT AND
C                               CMAT.
C
C  NCA   1         I*4    I     NUMBER OF COLUMNS IN AMAT AND ROWS IN
C                               BMAT.
C
C  NCB   1         I*4    I     NUMBER OF COLUMNS IN MATRICES BMAT AND
C                               CMAT.
C
C
C***********************************************************************
C
C  CODED BY C PETRUZZO. 6/82.
C  MODIFIED............
C
C***********************************************************************
C
C
      REAL*8 AMAT(NRA,NCA),BMAT(NCA,NCB),CMAT(NRA,NCB)
C
      DO 100 IRA=1,NRA
      DO 100 ICB=1,NCB
      TEMP=0.D0
      DO 200 ICA=1,NCA
  200 TEMP=TEMP+AMAT(IRA,ICA)*BMAT(ICA,ICB)
  100 CMAT(IRA,ICB)=TEMP
C
      RETURN
      END


      PROGRAM xsprsin
C     driver for routine sprsin
      INTEGER NP,NMAX
      PARAMETER(NP=5,NMAX=2*NP*NP+1)
      INTEGER i,j,msize,ija(NMAX)
      REAL a(NP,NP),aa(NP,NP),sa(NMAX)
      DATA a/3.0,0.0,0.0,0.0,0.0,
     *     0.0,4.0,7.0,0.0,0.0,
     *     1.0,0.0,5.0,0.0,0.0,
     *     0.0,0.0,9.0,0.0,6.0,
     *     0.0,0.0,0.0,2.0,5.0/
      call sprsin(a,NP,NP,0.5,NMAX,sa,ija)
      msize=ija(ija(1)-1)-1
      sa(NP+1)=0.0
      write(*,'(t4,a,t18,a,t24,a)') 'index','ija','sa'
      do 11 i=1,msize
        write(*,'(t2,i4,t16,i4,t20,f12.6)') i,ija(i),sa(i)
11    continue
      do 13 i=1,NP
        do 12 j=1,NP
          aa(i,j)=0.0
12      continue
13    continue
      do 15 i=1,NP
        aa(i,i)=sa(i)
        do 14 j=ija(i),ija(i+1)-1
          aa(i,ija(j))=sa(j)
14      continue
15    continue
      write(*,*) 'Original matrix:'
      write(*,'(5f7.1)') ((a(i,j),j=1,NP),i=1,NP)
      write(*,*) 'Reconstructed matrix:'
      write(*,'(5f7.1)') ((aa(i,j),j=1,NP),i=1,NP)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsprsin.for


     program demo_rgets
     use M_kracken, only: kracken, rgets
     implicit none
     real,allocatable  :: val(:)
     integer           :: i
       ! define command arguments and parse user command
       call kracken('fc','-F -C' )

       ! get any values specified on -C option
       val=rgets('fc_C')
       ! test if have something to print in C ==> F table
       if(size(val).gt.0)then
          ! print the requested values
          write(*,'(a,t14,a)')'celsius','fahrenheit'
          write(*,'(f5.1,t14,f5.1)')( val(i),(val(i)+40.0)*9.0/5.0 - 40.0,i=1,size(val))
       endif

       val=rgets('fc_F')
       ! check for values on -F
       if(size(val).gt.0)then
          write(*,'(a,t14,a)') 'fahrenheit', 'celsius'
          write(*,'(f5.1,t14,f5.1)')(val(i),(val(i)+40.0)*5.0/9.0 - 40.0,i=1,size(val))
       endif
     end program demo_rgets


MODULE ex4_mod
CONTAINS
SUBROUTINE sumation(a,b,d)
IMPLICIT NONE
INTEGER,INTENT(in) :: a(:,:)
INTEGER,INTENT(in) :: b(:,:)
INTEGER,INTENT(out):: d(:,:)
INTEGER :: i,j,nx,ny

nx = size(a,1) ; ny = size(a,2)
DO i=1,nx
DO j=1,ny
d(i,j) = a(i,j)+b(i,j)
END DO
END DO

END SUBROUTINE sumation
END MODULE ex4_mod

!!==========================================
PROGRAM ex4_presentation
USE ex4_mod
IMPLICIT NONE
INTEGER, PARAMETER :: nx=30000000, ny=4
INTEGER :: a(nx,ny),b(nx,ny),d(nx,ny)
a = 10
b = 20

call sumation(a,b,d)

IF(all(d==30)) THEN
      WRITE(* ,*)'**** OK ****'
ELSE
      WRITE(* ,*)'Program Failed'
END IF
END PROGRAM ex4_presentation


MODULE ExtrapolacoesDeUeV

   CONTAINS

      DOUBLE PRECISION FUNCTION Extrapola_u_S_Linear(t, pu, i, Nx, u )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pu, i, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u

         Extrapola_u_S_Linear = 2.0d0*cc_u_s(t, i) - u(pu)

      END FUNCTION Extrapola_u_S_Linear

      DOUBLE PRECISION FUNCTION Extrapola_u_S_Cubica(t, pu, i, Nx, u )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pu, i, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u

         Extrapola_u_S_Cubica = (16.0d0/5.0d0)*cc_u_s(t, i) - 3.0d0*u(pu) + u(pu+Nx) - (1.0d0/5.0d0)*u(pu+2*Nx)

      END FUNCTION Extrapola_u_S_Cubica

      DOUBLE PRECISION FUNCTION Extrapola_u_N_Linear(t, pu, i, Nx, u )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pu, i, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u

         Extrapola_u_N_Linear = 2.0d0*cc_u_n(t, i) - u(pu)

      END FUNCTION Extrapola_u_N_Linear

      DOUBLE PRECISION FUNCTION Extrapola_u_N_Cubica(t, pu, i, Nx, u )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pu, i, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u

         Extrapola_u_N_Cubica = (16.0d0/5.0d0)*cc_u_N(t, i) - 3.0d0*u(pu) + u(pu-Nx) - (1.0d0/5.0d0)*u(pu-2*Nx)

      END FUNCTION Extrapola_u_N_Cubica

      DOUBLE PRECISION FUNCTION Extrapola_v_W_Linear(t, pv, j, Nx, v )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pv, j, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: v

         Extrapola_v_W_Linear = 2.0d0*cc_v_w(t, j) - v(pv)

      END FUNCTION Extrapola_v_W_Linear

      DOUBLE PRECISION FUNCTION Extrapola_v_W_Cubica(t, pv, j, Nx, v )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pv, j, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: v

         Extrapola_v_W_Cubica = (16.0d0/5.0d0)*cc_v_w(t, j) - 3.0d0*v(pv) + v(pv+1) - (1.0d0/5.0d0)*v(pv+2)

      END FUNCTION Extrapola_v_W_Cubica

      DOUBLE PRECISION FUNCTION Extrapola_v_E_Linear(t, pv, j, Nx, v )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pv, j, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: v

         Extrapola_v_E_Linear = 2.0d0*cc_v_e(t, j) - v(pv)

      END FUNCTION Extrapola_v_E_Linear

      DOUBLE PRECISION FUNCTION Extrapola_v_E_Cubica(t, pv, j, Nx, v )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, pv, j, Nx
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: v

         Extrapola_v_E_Cubica = (16.0d0/5.0d0)*cc_v_e(t, j) - 3.0d0*v(pv) + v(pv-1) - (1.0d0/5.0d0)*v(pv-2)

      END FUNCTION Extrapola_v_E_Cubica

END MODULE ExtrapolacoesDeUeV


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       Orthogonal polynomials on the standard square [-1,1]x[-1,1]
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       This file contains a set of subroutines for the handling
c       of the evaluation of othogonal polynomials on the standard
c       square.  It contains 2 user-callable subroutines.
c
c   lege2eva - evaluates at the user-supplied point z
c       a collection of polynomials (of x,y) orthogonal on the
c       standard square
c
c   lege2eva3 - evaluates at the user-supplied point z a collection
c       of polynomials (of x,y) orthogonal on the standard square,
c       together with their derivatives with respect to x and y.

c
c
      subroutine lege2eva(mmax,z,pols,w)
c
c     This subroutine evaluates at the user-supplied point z
c     a collection of polynomials (of x,y) orthogonal on the
c     standard square
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^2 where the polynomials are to be evaluated;
c
c  w - the work array. must be at least mmax+1+(mmax+1) long
c
c                   Output parameters:
c
c  pols - the orthogonal polynomials evaluated at the point z
c       ( (mmax+1)*(mmax+2)/2 of them things)
c
c       . . . allocate memory for the work arrays
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), w(1)
      iw1=1
      iw2=iw1+mmax+10
      iw3=iw2+mmax+10
      call lege2eva0(mmax,z,pols,w(iw1),w(iw2))
      return
      end
c
c
c
c
c
      subroutine lege2eva0(mmax,z,pols,f1,f2)
c
c     evaluate the orthonormal polynomials on the square
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), f1(1), f2(1)
ccc      data init/1/
ccc      save
c
c
      call llegepols1(z(1),mmax,f1)
      call llegepols1(z(2),mmax,f2)
c
      kk=0
      do 2200 m=0,mmax
         do 2000 n=0,m
         kk=kk+1
c
c     ... evaluate the polynomial (m-n, n)
c
         pols(kk)=f1(m-n+1)*f2(n+1)
c
c     ... and normalize it
c
         scale=dsqrt((1.0d0+n+n)*(1.0d0+(m-n)+(m-n))) /2
cccc         scale=1
         pols(kk)=pols(kk)*scale
 2000	 continue
 2200 continue
      return
      end
c
c
c
c
c
      subroutine lege2eva3(mmax,z,pols,dersx,dersy,w)
c
c     This subroutine evaluates at the user-supplied point z
c     a collection of polynomials (of x,y) orthogonal on the
c     standard square, together with their derivatives with
c     respect to x and y.
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^2 where the polynomials are to be evaluated;
c
c  w - the work array. must be at least mmax+1+(mmax+1) long
c
c                   Output parameters:
c
c  pols - the orthogonal polynomials evaluated at the point z
c       ( (mmax+1)*(mmax+2)/2 of them things)
c  dersx - the derivatives with respect to x of the polynomials
c       returned in array pols
c  dersy - the derivatives with respect to y of the polynomials
c       returned in array pols
c
c
c       . . . allocate memory for the work arrays
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), w(1)
      iw1=1
      iw2=iw1+mmax+10
      iw3=iw2+mmax+10
      iw4=iw3+mmax+10
      iw5=iw4+mmax+10
      call lege2eva30(mmax,z,pols,dersx,dersy,
     $     w(iw1),w(iw2),w(iw3),w(iw4))
      return
      end
c
c
c
c
c
      subroutine lege2eva30(mmax,z,pols,dersx,dersy,
     $     f1,f2,f3,f4)
c
c     evaluate the orthonormal polynomials on the square,
c     together with their derivatives with respect to x and y.
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), dersx(1), dersy(1)
      dimension f1(1), f2(1)
      dimension f3(1), f4(1)
ccc      data init/1/
ccc      save
c
c
c
      call llegepols2(z(1),mmax,f1,f3)
      call llegepols2(z(2),mmax,f2,f4)
c
      kk=0
      do 2200 m=0,mmax
         do 2000 n=0,m
         kk=kk+1
c
c     ... evaluate the polynomial (m-n, n)
c
         pols(kk)=f1(m-n+1)*f2(n+1)
c
c     ... and the derivatives with respect in x and y
c
         dersx(kk)=f3(m-n+1)*f2(n+1)
         dersy(kk)=f1(m-n+1)*f4(n+1)
c
c     ... and normalize it
c
         scale=dsqrt((1.0d0+n+n)*(1.0d0+(m-n)+(m-n))) /2
cccc         scale=1
         pols(kk)=pols(kk)*scale
         dersx(kk)=dersx(kk)*scale
         dersy(kk)=dersy(kk)*scale
 2000	 continue
 2200 continue
c
      return
      end
c
c
c
c
c
c
c
        subroutine llegepols1(x,n,pols)
        implicit real *8 (a-h,o-z)
        dimension pols(1)
c
c       evaluates a bunch of Legendre polynomials
c       at the user-provided point x
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=x
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        pols(1)=1
        pols(2)=x
c
        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        pols(k+2)=pkp1
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine llegepols2(x,n,pols,ders)
        implicit real *8 (a-h,o-z)
        dimension pols(1),ders(1)
c
c       evaluates a bunch of Legendre polynomials (together
c       with their derivatives) at the user-provided point x
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        ders(1)=0
        if(n .eq. 0) return
c
        pols(2)=x
        ders(2)=1
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        pols(1)=1
        ders(1)=0
        pols(2)=x
        ders(2)=1
c
        pkm1=1
        pk=x
        dkm1=0
        dk=1
c
        pk=1
        pkp1=x
        dk=0
        dkp1=1
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
        dkm1=dk
        dk=dkp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        dkp1=( (2*k+1)*(x*dk+pk)-k*dkm1 )/(k+1)
        pols(k+2)=pkp1
        ders(k+2)=dkp1
 2000 continue
c
        return
        end

c
        subroutine legegauc(n,vert1,vert2,rnodes,
     1      weights,ifinit,w)
        implicit real *8 (a-h,o-z)
        dimension w(1),vert1(1),vert2(1),rnodes(1),weights(1)
c
c
c       this subroutine constructs a tensor product Gaussian
c       quadrature formula on the square in the plane
c       specified by its vertices.
c

        iw1=1
        iw2=iw1+n+1
        iw3=iw2+n+1
        iw4=iw3+n+1
        iw5=iw4+n+1

        call legegauc0(n,vert1,vert2,rnodes,
     1      weights,ifinit,w(iw1),w(iw2),w(iw3),w(iw4))

        return
        end

        subroutine legegauc0(n,vert1,vert2,rnodes,
     1      weights,ifinit,tsx,wsx,tsy,wsy)
        implicit real *8 (a-h,o-z)
        dimension vert1(2),vert2(2),rnodes(2,n,n),weights(n,n)
        dimension tsx(n),wsx(n),tsy(n),wsy(n)
c
c
c       this subroutine constructs a tensor product Gaussian
c       quadrature formula on the square in the plane
c       specified by its vertices.
c

        if( ifinit.eq.1) then
           ifinit = 1
           call legewhts(n,tsx,wsx,ifinit)
           call legewhts(n,tsy,wsy,ifinit)
        endif

        u1=(vert2(1)-vert1(1))/2
        v1=(vert2(1)+vert1(1))/2
        u2=(vert2(2)-vert1(2))/2
        v2=(vert2(2)+vert1(2))/2

ccc        call prin2('vert1=*',vert1,2)
ccc        call prin2('vert2=*',vert2,2)

        do i=1,n
        do j=1,n
           rnodes(1,i,j)=u1*tsx(i)+v1
           rnodes(2,i,j)=u2*tsy(j)+v2
           weights(i,j)=abs(u1)*abs(u2)*wsx(i)*wsy(j)
        enddo
        enddo

        return
        end