      subroutine area2d_tri(ntri,
     *                      x1,y1,z1,x2,y2,z2,x3,y3,z3,
     *                      xarea_tri,xvol1,xvol2,xvol3,
     *                      xarea12,xarea23,xarea31)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1      This routine calculates the total area of a triangle and
CD1         also the three Voronoi areas along each of the three
CD1         sides. The vertices of the triangle are assumed to be
CD1         ordered counter-clockwise.
CD1
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2  $Log:   /pvcs.config/fehm90/src/area2d_tri.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:18   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 08:54:14   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:04:40   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:21:46   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:55:16   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:38:50 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.2   Mon Mar 31 08:29:28 1997   gaz
CD2 harolds volumes and areas
CD2
CD2    Rev 1.1   Thu Jun 27 11:29:02 1996   gaz
CD2 added prolog
CD2
CD2    Rev 1.0   Fri Apr 26 14:57:56 1996   gaz(H. Trease)
CD2 Initial revision.
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.2 Finite-Element Coefficient Generation
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
C***********************************************************************
C
C     INPUT ARGUMENTS -
C
C        ntri - Number of triangles
C        x1(1:ntri) - The X-coordinates of all the 1st vertices.
C        y1(1:ntri) - The Y-coordinates of all the 1st vertices.
C        z2(1:ntri) - The Z-coordinates of all the 1st vertices.
C        x2(1:ntri) - The X-coordinates of all the 2nd vertices.
C        y2(1:ntri) - The Y-coordinates of all the 2nd vertices.
C        z2(1:ntri) - The Z-coordinates of all the 2nd vertices.
C        x3(1:ntri) - The X-coordinates of all the 3rd vertices.
C        y3(1:ntri) - The Y-coordinates of all the 3rd vertices.
C        z3(1:ntri) - The Z-coordinates of all the 3rd vertices.
C
C     OUTPUT ARGUMENTS -
C
C        xarea_tri(1:ntri) - The total area of the triangles.
C        xvol1(1:ntri)     - The area associated with vertex 1.
C        xvol2(1:ntri)     - The area associated with vertex 2.
C        xvol3(1:ntri)     - The area associated with vertex 3.
C        xarea12(1:ntri) - The area of the Voronoi edge associated
C                              with the 1-2 connection divided by
C                              the length of the 1-2 connection.
C        xarea23(1:ntri) - The area of the Voronoi edge associated
C                              with the 2-3 connection divided by
C                              the length of the 2-3 connection.
C        xarea31(1:ntri) - The area of the Voronoi edge associated
C                              with the 3-1 connection divided by
C                              the length of the 3-1 connection.
C
C
C#######################################################################
C
C
C     integer npts
C
      implicit none
      integer ntri
      real*8 crosx, crosy, crosz, dotpr, vecmag, ds13, ds23
      real*8 xa11, ya11, za11, xa12, ya12, za12, xa21, ya21, za21
      real*8 xa22, ya22, za22, xa31, ya31, za31, xa32, ya32, za32
      real*8 a1x, a1y, a1z, a2x, a2y, a2z, a3x, a3y, a3z, a123x
      real*8 a123y, a123z, area_vor, area_tri, area_error, a1_sign
      real*8 a2_sign, a3_sign, area1, area2, area3
      real*8 x1(ntri), y1(ntri), z1(ntri)
      real*8 x2(ntri), y2(ntri), z2(ntri)
      real*8 x3(ntri), y3(ntri), z3(ntri)
C
      real*8 xarea_tri(ntri),xarea12(ntri),xarea23(ntri),xarea31(ntri)
      real*8 xvol1(ntri), xvol2(ntri), xvol3(ntri)
C
      integer i1
C
      real*8 a, b, c, d, e, f
      real*8 xa, ya, za
      real*8 xb, yb, zb
      real*8 xd, yd, zd
      real*8 xm, ym, zm
      real*8 xn, yn, zn, rn
      real*8 xn1, yn1, zn1
      real*8 xv, yv, zv
      real*8 xl, yl, zl
      real*8 ql
      real*8 x12, y12, z12
      real*8 x23, y23, z23
      real*8 x13, y13, z13
      real*8 dot3, dotb3, xdot, xdot1, xdot2, xdot3
      real*8 xarea1, xarea2, xarea3
      real*8 rb3
      real*8 ds1, ds2, ds3, ds12
      real*8 cmx, cmy, cmz
      real*8 cvx, cvy, cvz
C
C#######################################################################
c
c     Statement functions for cross product, dot product and vector magnitude
c
      crosx(a,b,c,d,e,f)=b*f-c*e
      crosy(a,b,c,d,e,f)=c*d-a*f
      crosz(a,b,c,d,e,f)=a*e-b*d
      dotpr(a,b,c,d,e,f)=a*d + b*e + c*f
      vecmag(a,b,c) = 0.5d0*sqrt(a**2 + b**2 + c**2)
c
C
C#######################################################################
C
C
      do i1=1,ntri
         xa=x1(i1)
         ya=y1(i1)
         za=z1(i1)
         xb=(x2(i1)-xa)
         yb=(y2(i1)-ya)
         zb=(z2(i1)-za)
         xd=(x3(i1)-xa)
         yd=(y3(i1)-ya)
         zd=(z3(i1)-za)
         xm=(x1(i1)+x2(i1)+x3(i1))/3.0d+00
         ym=(y1(i1)+y2(i1)+y3(i1))/3.0d+00
         zm=(z1(i1)+z2(i1)+z3(i1))/3.0d+00
C
C        ***************************************************************
C        Calculate the Voronoi point
C
         xn1=crosx(xb,yb,zb,xd,yd,zd)
         yn1=crosy(xb,yb,zb,xd,yd,zd)
         zn1=crosz(xb,yb,zb,xd,yd,zd)
         xn=crosx(xb,yb,zb,xn1,yn1,zn1)
         yn=crosy(xb,yb,zb,xn1,yn1,zn1)
         zn=crosz(xb,yb,zb,xn1,yn1,zn1)
         rn=1.0/sqrt(xn*xn+yn*yn+zn*zn)
         xn=xn*rn
         yn=yn*rn
         zn=zn*rn
         dotb3=xb*xd+yb*yd+zb*zd
         dot3=dotb3/(xd*xd+yd*yd+zd*zd)
         rb3=1.0/(xb*xb+yb*yb+zb*zb)
         ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3+1.0d-30)
         xl=0.5*(ql*(xd-dotb3*rb3*xb)+xb)
         yl=0.5*(ql*(yd-dotb3*rb3*yb)+yb)
         zl=0.5*(ql*(zd-dotb3*rb3*zb)+zb)
         ds1=sqrt((xl)**2+(yl)**2+(zl)**2)
         ds2=sqrt((xl-xb)**2+(yl-yb)**2+(zl-zb)**2)
         ds3=sqrt((xl-xd)**2+(yl-yd)**2+(zl-zd)**2)
         xv=xl+xa
         yv=yl+ya
         zv=zl+za
C
C        ***************************************************************
C
         x12=0.5*(x1(i1)+x2(i1))
         y12=0.5*(y1(i1)+y2(i1))
         z12=0.5*(z1(i1)+z2(i1))
         x13=0.5*(x1(i1)+x3(i1))
         y13=0.5*(y1(i1)+y3(i1))
         z13=0.5*(z1(i1)+z3(i1))
         x23=0.5*(x2(i1)+x3(i1))
         y23=0.5*(y2(i1)+y3(i1))
         z23=0.5*(z2(i1)+z3(i1))
         xdot1=(x2(i1)-x1(i1))*(x3(i1)-x1(i1))+
     *         (y2(i1)-y1(i1))*(y3(i1)-y1(i1))+
     *         (z2(i1)-z1(i1))*(y3(i1)-y1(i1))
         xdot2=(x1(i1)-x3(i1))*(x2(i1)-x3(i1))+
     *         (y1(i1)-y3(i1))*(y2(i1)-y3(i1))+
     *         (z1(i1)-z3(i1))*(y2(i1)-y3(i1))
         xdot3=(x3(i1)-x2(i1))*(x1(i1)-x2(i1))+
     *         (y3(i1)-y2(i1))*(y1(i1)-y2(i1))+
     *         (z3(i1)-z2(i1))*(y1(i1)-y2(i1))
         xarea1=sqrt((xv-x12)*(xv-x12)+
     *               (yv-y12)*(yv-y12)+
     *               (zv-z12)*(zv-z12))
         xarea2=sqrt((xv-x13)*(xv-x13)+
     *               (yv-y13)*(yv-y13)+
     *               (zv-z13)*(zv-z13))
         xarea3=sqrt((xv-x23)*(xv-x23)+
     *               (yv-y23)*(yv-y23)+
     *               (zv-z23)*(zv-z23))
         ds12=sqrt((x2(i1)-x1(i1))**2+
     *             (y2(i1)-y1(i1))**2+
     *             (z2(i1)-z1(i1))**2)
         cmx=  (y2(i1)-y1(i1))*(zm-z1(i1))-(ym-y1(i1))*(z2(i1)-z1(i1))
         cmy=-((x2(i1)-x1(i1))*(zm-z1(i1))-(xm-x1(i1))*(z2(i1)-z1(i1)))
         cmz=  (x2(i1)-x1(i1))*(ym-y1(i1))-(xm-x1(i1))*(y2(i1)-y1(i1))
         cvx=  (y2(i1)-y1(i1))*(zv-z1(i1))-(yv-y1(i1))*(z2(i1)-z1(i1))
         cvy=-((x2(i1)-x1(i1))*(zv-z1(i1))-(xv-x1(i1))*(z2(i1)-z1(i1)))
         cvz=  (x2(i1)-x1(i1))*(yv-y1(i1))-(xv-x1(i1))*(y2(i1)-y1(i1))
         xdot=cmx*cvx+cmy*cvy+cmz*cvz
         if(xdot.lt.0.0) then
            xarea12(i1)=-xarea1/ds12
         else
            xarea12(i1)= xarea1/ds12
         endif
         ds13=sqrt((x3(i1)-x1(i1))**2+
     *             (y3(i1)-y1(i1))**2+
     *             (z3(i1)-z1(i1))**2)
         cmx=  (y1(i1)-y3(i1))*(zm-z3(i1))-(ym-y3(i1))*(z1(i1)-z3(i1))
         cmy=-((x1(i1)-x3(i1))*(zm-z3(i1))-(xm-x3(i1))*(z1(i1)-z3(i1)))
         cmz=  (x1(i1)-x3(i1))*(ym-y3(i1))-(xm-x3(i1))*(y1(i1)-y3(i1))
         cvx=  (y1(i1)-y3(i1))*(zv-z3(i1))-(yv-y3(i1))*(z1(i1)-z3(i1))
         cvy=-((x1(i1)-x3(i1))*(zv-z3(i1))-(xv-x3(i1))*(z1(i1)-z3(i1)))
         cvz=  (x1(i1)-x3(i1))*(yv-y3(i1))-(xv-x3(i1))*(y1(i1)-y3(i1))
         xdot=cmx*cvx+cmy*cvy+cmz*cvz
         if(xdot.lt.0.0) then
            xarea31(i1)=-xarea2/ds13
         else
            xarea31(i1)= xarea2/ds13
         endif
         ds23=sqrt((x3(i1)-x2(i1))**2+
     *             (y3(i1)-y2(i1))**2+
     *             (z3(i1)-z2(i1))**2)
         cmx=  (y3(i1)-y2(i1))*(zm-z2(i1))-(ym-y2(i1))*(z3(i1)-z2(i1))
         cmy=-((x3(i1)-x2(i1))*(zm-z2(i1))-(xm-x2(i1))*(z3(i1)-z2(i1)))
         cmz=  (x3(i1)-x2(i1))*(ym-y2(i1))-(xm-x2(i1))*(y3(i1)-y2(i1))
         cvx=  (y3(i1)-y2(i1))*(zv-z2(i1))-(yv-y2(i1))*(z3(i1)-z2(i1))
         cvy=-((x3(i1)-x2(i1))*(zv-z2(i1))-(xv-x2(i1))*(z3(i1)-z2(i1)))
         cvz=  (x3(i1)-x2(i1))*(yv-y2(i1))-(xv-x2(i1))*(y3(i1)-y2(i1))
         xdot=cmx*cvx+cmy*cvy+cmz*cvz
         if(xdot.lt.0.0) then
            xarea23(i1)=-xarea3/ds23
         else
            xarea23(i1)= xarea3/ds23
         endif
C
         xarea_tri(i1)=0.5d+00*sqrt(xn1**2+yn1**2+zn1**2)
C
         xa11= crosx((x12-x1(i1)),(y12-y1(i1)),(z12-z1(i1)),
     *               (xv -x1(i1)),(yv -y1(i1)),(zv -z1(i1)))
         ya11= crosy((x12-x1(i1)),(y12-y1(i1)),(z12-z1(i1)),
     *               ( xv-x1(i1)),( yv-y1(i1)),( zv-z1(i1)))
         za11= crosz((x12-x1(i1)),(y12-y1(i1)),(z12-z1(i1)),
     *               ( xv-x1(i1)),( yv-y1(i1)),( zv-z1(i1)))
         xa12=-crosx((x13-x1(i1)),(y13-y1(i1)),(z13-z1(i1)),
     *               ( xv-x1(i1)),( yv-y1(i1)),( zv-z1(i1)))
         ya12=-crosy((x13-x1(i1)),(y13-y1(i1)),(z13-z1(i1)),
     *               ( xv-x1(i1)),( yv-y1(i1)),( zv-z1(i1)))
         za12=-crosz((x13-x1(i1)),(y13-y1(i1)),(z13-z1(i1)),
     *               ( xv-x1(i1)),( yv-y1(i1)),( zv-z1(i1)))
         xa21= crosx((x23-x2(i1)),(y23-y2(i1)),(z23-z2(i1)),
     *               ( xv-x2(i1)),( yv-y2(i1)),( zv-z2(i1)))
         ya21= crosy((x23-x2(i1)),(y23-y2(i1)),(z23-z2(i1)),
     *               ( xv-x2(i1)),( yv-y2(i1)),( zv-z2(i1)))
         za21= crosz((x23-x2(i1)),(y23-y2(i1)),(z23-z2(i1)),
     *               ( xv-x2(i1)),( yv-y2(i1)),( zv-z2(i1)))
         xa22=-crosx((x12-x2(i1)),(y12-y2(i1)),(z12-z2(i1)),
     *               ( xv-x2(i1)),( yv-y2(i1)),( zv-z2(i1)))
         ya22=-crosy((x12-x2(i1)),(y12-y2(i1)),(z12-z2(i1)),
     *               ( xv-x2(i1)),( yv-y2(i1)),( zv-z2(i1)))
         za22=-crosz((x12-x2(i1)),(y12-y2(i1)),(z12-z2(i1)),
     *               ( xv-x2(i1)),( yv-y2(i1)),( zv-z2(i1)))
         xa31= crosx((x13-x3(i1)),(y13-y3(i1)),(z13-z3(i1)),
     *               ( xv-x3(i1)),( yv-y3(i1)),( zv-z3(i1)))
         ya31= crosy((x13-x3(i1)),(y13-y3(i1)),(z13-z3(i1)),
     *               ( xv-x3(i1)),( yv-y3(i1)),( zv-z3(i1)))
         za31= crosz((x13-x3(i1)),(y13-y3(i1)),(z13-z3(i1)),
     *               ( xv-x3(i1)),( yv-y3(i1)),( zv-z3(i1)))
         xa32=-crosx((x23-x3(i1)),(y23-y3(i1)),(z23-z3(i1)),
     *               ( xv-x3(i1)),( yv-y3(i1)),( zv-z3(i1)))
         ya32=-crosy((x23-x3(i1)),(y23-y3(i1)),(z23-z3(i1)),
     *               ( xv-x3(i1)),( yv-y3(i1)),( zv-z3(i1)))
         za32=-crosz((x23-x3(i1)),(y23-y3(i1)),(z23-z3(i1)),
     *               ( xv-x3(i1)),( yv-y3(i1)),( zv-z3(i1)))
c
c     Area vector of triangle
c
      xa= crosx((x2(i1)-x1(i1)),(y2(i1)-y1(i1)),
     *    (z2(i1)-z1(i1)),(x3(i1)-x1(i1)),(y3(i1)-y1(i1)),
     *    (z3(i1)-z1(i1)))
      ya= crosy((x2(i1)-x1(i1)),(y2(i1)-y1(i1)),
     *    (z2(i1)-z1(i1)),(x3(i1)-x1(i1)),(y3(i1)-y1(i1)),
     *    (z3(i1)-z1(i1)))
      za= crosz((x2(i1)-x1(i1)),(y2(i1)-y1(i1)),
     *    (z2(i1)-z1(i1)),(x3(i1)-x1(i1)),(y3(i1)-y1(i1)),
     *    (z3(i1)-z1(i1)))
c
c     Vector sum of Voronoi area vector for each of three nodes in the triangle
c
      a1x = xa11 + xa12
      a1y = ya11 + ya12
      a1z = za11 + za12
      a2x = xa21 + xa22
      a2y = ya21 + ya22
      a2z = za21 + za22
      a3x = xa31 + xa32
      a3y = ya31 + ya32
      a3z = za31 + za32
c
c     Total area vector of triangle formed by summing 6 voronoi contributions
c
      a123x = a1x + a2x + a3x
      a123y = a1y + a2y + a3y
      a123z = a1z + a2z + a3z
c
c     Comparison of area calculated two different ways
c
      area_vor  =0.5*sqrt(a123x**2+a123y**2+a123z**2)
      area_tri  =0.5*sqrt(xa**2+ya**2+za**2)
      area_error=0.5*sqrt((a123x-xa)**2+(a123y-ya)**2+(a123z-za)**2)

      if(area_error .gt. 1.e-9*area_tri)then
        print *,'Error Calculating Voronoi Area'
        print *,area_vor,area_tri,area_error
      endif
c
c     Dot product of voronoi area vector with triangle area vector. This
c     quantity will be positive for positive area contributions and negative
c     for negative area contributions
c
      a1_sign = dotpr(a1x,a1y,a1z,xa,ya,za)
      a2_sign = dotpr(a2x,a2y,a2z,xa,ya,za)
      a3_sign = dotpr(a3x,a3y,a3z,xa,ya,za)
c
c     Find the absolute magnitude of the voronoi contributions
c
      area1   = vecmag(a1x,a1y,a1z)
      area2   = vecmag(a2x,a2y,a2z)
      area3   = vecmag(a3x,a3y,a3z)
c
c     Give the area contributions their correct sign
c
      area1 = sign(area1,a1_sign)
      area2 = sign(area2,a2_sign)
      area3 = sign(area3,a3_sign)
c
c load areas into arrays
c
      xvol1(i1) = area1
      xvol2(i1) = area2
      xvol3(i1) = area3
      enddo
C
      goto 9999
9999  continue
C
      return
      end


subroutine MakeMagGrid2D(rad, phi, theta, total, cilm, r0, a, f, lmax, interval, nlat, nlong, &
	north, south, east, west)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given the Schmidt normalized Spherical Harmonic coefficients cilm, this subroutine
!	will compute a 2D grid with equal latitude and longitude spacings for the radial,
!	phi and theta directions, as well as the total field.  The field is calculated
!	on a flattended ellipsoid with semi-major axis A and flattening F.
!
!	Note that since this is NOT done using FFTs, this routine is relatively SLOW!
!
!	The value at grid(1,1) correspons to 90 degrees latitude and 0 degress
!	longitude. Longitude points are calculated from 0 to 360, with both points
!	being included. If the optional parameters NORTH, SOUTH, EAST and WEST are specified,
!	the upper-left and lower right coordinates of the output grid are (NORTH, WEST) and
!	(SOUTH, EAST), respectively.
!
!	Calling Parameters:
!		IN
!			cilm:		Schmidt Normalized spherical harmonic coefficients with
!					dimensions (2, lmax+1, lmax+1).
!			r0:		Reference radius of cilm coeficients.
!			a:		Semi-major axis of the reference ellipsoid.
!			f:		Flattening of reference radius: (R_eq - R_p)/R_eq, where R_eq = A.
!			lmax:		Maximum spherical harmonic degree of expansions to be performed.
!			interval:	Spacing of output grid in DEGREES.
!
!		OUT
!			rad:	 	Grid of radial magnetic field.
!			phi:		Grid of magnetic field in phi direction.
!			theta:		Grid of magnetic field in theta direction.
!			total:		Grid of magnetic intensity.
!			nlat:		Number of latitude points for the grid.
!			nlong:		Number of longitude points for the grid.
!		OPTIONAL (IN)
!			north		Maximum latitude to compute, in degrees.
!			south		Minimum latitude to compute, in degrees.
!			east		Maximum longitude to compute, in degrees.
!			west		Minimum latitude to compute, in degrees.
!
!	Notes:
!		1.	If lmax is greater than the the maximum spherical harmonic
!			degree of the input file, then this file will be ZERO PADDED!
!			(i.e., those degrees after lmax are assumed to be zero).
!		2. 	Latitude is geocentric latitude.
!
!		Dependencies:	PlmSchmidt_d1, PlSchmidt, PlmIndex
!
!	Written by Mark Wieczorek (2003)
!
!	August 2005 - 	sines and cosines are now precomputed, leading to a savings in time
!			by a factor of up to 15 (if the code is compiled with normal
!			optimizations.
!	May 31, 2006 -  Modified so that the Condon-Shortley phase is never used, regardless of
!			what the default value of CSPHASE_DEFAULT is.
!	June 21, 2007 - Modified routine such that the field is calculated on a flattened
!			ellisoid, using exact equations for the ellipsoid. Previously, only
!			the degree-2 Legendre expansion was utilized. It is now necessary to
!		 	input the semi-major axis of the ellispoid instead of the mean ellipsoid
!			radius.
!	August 19, 2007	Added option to calculate subdomains of a raster grid.
!
!	Copyright (c) 2005-2007, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PlmSchmidt_d1, PlSchmidt, PlmIndex

	implicit none

	real*8, intent(in) :: 	cilm(:,:,:), interval, r0, a, f
	real*8, intent(out) :: 	rad(:,:), phi(:,:), theta(:,:), total(:,:)
	integer, intent(in) :: 	lmax
	integer, intent(out) :: nlat, nlong
	real*8, intent(in), optional :: north, south, east, west
	integer :: 		l, m, j, k, index, l1, m1, lmax_comp, temp, astat(4)
	real*8 :: 		pi, latmax, latmin, longmin, longmax, lat, &
				longitude, x, intervalrad, r_ex, coef
	real*8, allocatable ::	pl(:), dpl(:), cosm(:,:), sinm(:,:)

    	temp = 0
	if (present(north)) temp = temp + 1
	if (present(south)) temp = temp + 1
	if (present(east)) temp = temp + 1
	if (present(west)) temp = temp + 1

	if (temp /=0 .and. temp /=4) then
		print*, "Error --- MakeMagGrid2d"
		print*, "The optional parameters NORTH, SOUTH, EAST, and WEST must all be specified", &
			present(north), present(south), present(east), present(west)
		stop
	endif

	if (temp == 4) then
		latmax = north
		latmin = south
		longmin = west
		longmax = east

		if (latmax < latmin) then
			print*, "Error --- MakeMagGrid2d"
			print*, "NORTH must be larger than SOUTH."
			print*, "NORTH = ", latmax
			print*, "SOUTH = ", latmin
			stop
		endif

		if (latmax > 90.0d0 .or. latmin < -90.0d0) then
			print*, "Error --- MakeMagGrid2d"
			print*, "NORTH and SOUTH must lie between 90 and -90."
			print*, "NORTH = ", latmax
			print*, "SOUTH = ", latmin
			stop
		endif

		if (longmin > longmax) longmax = longmax + 360.0d0

	else
		latmax = 90.0d0
		latmin = -90.0d0
		longmin = 0.0d0
		longmax = 360.d0
	endif

	nlat = (latmax - latmin) / interval + 1
	nlong = (longmax - longmin) / interval + 1

 	if (size(rad(:,1)) < nlat .or. size(rad(1,:)) < nlong ) then
		print*, "Error --- MakeMagGrid2D"
		print*, "RAD must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
		print*, "INTERVAL = ", interval
		print*, "LATMAX = ", latmax
		print*, "LATMIN = ", latmin
		print*, "LONGMIN = ", longmin
		print*, "LONGMAX = ", longmax
		print*, "Input array is dimensioned ", size(rad(:,1)), size(rad(1,:))
		stop
 	elseif (size(phi(:,1)) < nlat .or. size(phi(1,:)) < nlong ) then
		print*, "Error --- MakeMagGrid2D"
		print*, "PHI must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
		print*, "INTERVAL = ", interval
		print*, "LATMAX = ", latmax
		print*, "LATMIN = ", latmin
		print*, "LONGMIN = ", longmin
		print*, "LONGMAX = ", longmax
		print*, "Input array is dimensioned ", size(phi(:,1)), size(phi(1,:))
		stop
 	elseif (size(theta(:,1)) < nlat .or. size(theta(1,:)) < nlong ) then
		print*, "Error --- MakeMagGrid2D"
		print*, "THETA must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
		print*, "INTERVAL = ", interval
		print*, "LATMAX = ", latmax
		print*, "LATMIN = ", latmin
		print*, "LONGMIN = ", longmin
		print*, "LONGMAX = ", longmax
		print*, "Input array is dimensioned ", size(theta(:,1)), size(theta(1,:))
		stop
 	elseif (size(total(:,1)) < nlat .or. size(total(1,:)) < nlong ) then
		print*, "Error --- MakeMagGrid2D"
		print*, "TOTAL must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
		print*, "INTERVAL = ", interval
		print*, "LATMAX = ", latmax
		print*, "LATMIN = ", latmin
		print*, "LONGMIN = ", longmin
		print*, "LONGMAX = ", longmax
		print*, "Input array is dimensioned ", size(total(:,1)), size(total(1,:))
		stop
	elseif (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. size(cilm(1,1,:)) < lmax+1) then
		print*, "Error --- MakeMagGrid2D"
		print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	allocate(pl((lmax+1)*(lmax+2)/2), stat = astat(1))
	allocate(cosm(int(360./interval + 1), lmax+1), stat = astat(2))
	allocate(sinm(int(360./interval + 1), lmax+1), stat = astat(3))
	allocate(dpl((lmax+1)*(lmax+2)/2), stat = astat(4))
	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /=0 .or. astat(4) /= 0) then
		print*, "Error --- MakeMagGrid2D"
		print*, "Problem allocating arrays PL, COSM, SINM, and DPL", astat(1), astat(2), astat(3), astat(4)
		stop
	endif

	pi = acos(-1.0d0)
	rad = 0.0d0
	phi = 0.0d0
	theta = 0.0d0
	total = 0.0d0

	intervalrad = interval*pi/180.0d0

	lmax_comp = min(lmax, size(cilm(1,1,:))-1)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Loop over latitude. Precompute sin and cosine terms.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, nlong

		longitude = longmin*pi/180.0d0 + dble(k-1)*intervalrad
		do m=0, lmax
			cosm(k, m+1) = cos(m*longitude)
			sinm(k, m+1) = sin(m*longitude)
		enddo

	enddo

	do j=1, nlat

		lat = latmax - dble(j-1)*interval
		x = sin(lat*pi/180.0d0)

		if (lat == 90.0d0 .or. lat == -90.0d0) then

			call PlSchmidt(pl, lmax_comp, x)

			r_ex = a * (1.0d0 - f)	! Reference ellipsoid to calculate field

			coef = (r0/r_ex)**2

			do l = 1, lmax_comp, 1
				l1 = l+1
				coef = coef * (r0/r_ex)
				rad(j,1) = rad(j,1) + dble(l+1) * cilm(1,l1,1) * pl(l1) * coef
			enddo

			phi(j,1:nlong) = 0.0d0
			rad(j,2:nlong) = rad(j,1)
			theta(j,1:nlong) = 0.0d0

		else

			r_ex = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
				(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
			r_ex = sqrt(r_ex)

			call PlmSchmidt_d1(pl, dpl, lmax_comp, x, csphase = 1)
			dpl = - dpl * cos(lat*pi/180.0d0)	! convert derivative with respect to z to
								! a derivative with respect to theta.
			do k = 1, nlong

				coef = (r0/r_ex)**2

				do l = 1, lmax_comp, 1
					l1 = l+1
					coef = coef * (r0/r_ex)
					do m = 0, l
						index = PlmIndex(l,m)
						m1 = m+1
						rad(j,k) = rad(j,k) + dble(l+1) * (cilm(1,l1,m1)*cosm(k,m1) + &
							cilm(2,l1,m1)*sinm(k, m1) ) * pl(index) * coef
						phi(j,k) = phi(j,k) + dble(m)*(cilm(1,l1,m1)*sinm(k,m+1) - &
							cilm(2,l1,m1)*cosm(k, m+1) ) * pl(index) * coef &
							/ cos(lat*pi/180.0d0)
						theta(j,k) = theta(j,k) - (cilm(1,l1,m1)*cosm(k,m1) + &
							cilm(2,l1,m1)*sinm(k,m1) ) * dpl(index)  &
							* coef

					enddo
				enddo

			enddo

		endif

	enddo

	total(1:nlat, 1:nlong) = sqrt( rad(1:nlat,1:nlong)**2 + phi(1:nlat,1:nlong)**2 + theta(1:nlat,1:nlong)**2)

	! deallocate memory
	call PlmSchmidt_d1(pl, dpl, -1, x, csphase = 1)
	deallocate(pl)
	deallocate(cosm)
	deallocate(sinm)
	deallocate(dpl)

end subroutine MakeMagGrid2D


      SUBROUTINE ANGLE(XMS,THETA,PHI)
        USE param
        USE struct
      IMPLICIT REAL*8 (A-H,O-Z)
!*******************************************************************
      LOGICAL          ORTHO
!
      COMMON/ORTH/     ORTHO
      DIMENSION XMS(3)

	PI=ACOS(-1.D0)
!---------------------------------------------------------------------
	IF (ORTHO) THEN
        XA=AA*XMS(1)
	XB=BB*XMS(2)
	XC=CC*XMS(3)
        GOTO 200
	END IF

	write(6,*)'LATTICE:',lattic
      IF(LATTIC(1:1).EQ.'H') THEN
	XA=XMS(1)*AA*SQRT(3.D0)/2.d0
	XB=AA*(XMS(2)-XMS(1)/2.d0)
	XC=CC*XMS(3)

      ELSE IF(LATTIC(1:1).EQ.'R') THEN
        XA=(XMS(1)+XMS(2)-2.d0*XMS(3))*AA/(2.d0*SQRT(3.D0))
        XB=(-XMS(1)+XMS(2))*AA/2.d0
        XC=(XMS(1)+XMS(2)+XMS(3))*CC/3.d0

      ELSE
	IF (ABS(ALPHA(3)-PI/2.d0).GT.1.D-4) THEN
        XA=XMS(1)*AA*SIN(ALPHA(3))
        XB=XMS(1)*AA*COS(ALPHA(3))+BB*XMS(2)
        XC=CC*XMS(3)

        ELSE IF (ABS(ALPHA(2)-PI/2.d0).GT.1.D-4) THEN
	XA=XMS(1)*AA*SIN(ALPHA(2))
	XB=XMS(2)*BB
	XC=XMS(1)*AA*COS(ALPHA(2))+CC*XMS(3)

	ELSE
!	WRITE(6,*)'EXCHANGE THE LATTICE VECTORS, ALPHA(1) MUST BE PI/2'
!        END IF

	TT=ABS((ALPHA(1)-PI/2.d0)*(ALPHA(2)-PI/2.d0)*(ALPHA(3)-PI/2.d0))
!	IF (TT.GT.1.D-3) STOP 'TRICLINIC NOT IMPLEMENTED'
        write(6,*) ' Triclinic implemented, but never tested'
        cosg1=(cos(ALPHA(3))-cos(alpha(1))*cos(ALPHA(2)))/sin(alpha(1))/sin(alpha(2))
        gamma0=acos(cosg1)
!      from lapw5
!      BR2(1,1)=A(1)*1.0d0*sin(gamma0)*sin(beta)
!      BR2(1,2)=A(1)*1.0d0*cos(gamma0)*sin(beta)
!      BR2(1,3)=A(1)*1.0d0*cos(beta)
!      BR2(2,1)=0.0d0
!      BR2(2,2)=A(2)*1.0d0*sin(alpha)
!      BR2(2,3)=A(2)*1.0d0*cos(alpha)
!      BR2(3,1)=0.0d0
!      BR2(3,2)=0.0d0
!      BR2(3,3)=A(3)*1.0d0
        XA=XMS(1)*sin(gamma0)*sin(alpha(2))*AA
        XB=XMS(1)*cos(gamma0)*sin(alpha(2))*AA + XMS(2)*sin(alpha(1))*BB
        XC=XMS(1)*cos(alpha(2))*AA + XMS(2)*cos(alpha(1))*BB + XMS(3)*CC
        END IF

      ENDIF

 200    CONTINUE

        XX=SQRT(XA**2+XB**2+XC**2)
        THETA=ACOS(XC/XX)
	XX=SQRT(XA**2+XB**2)
	IF (XX.LT.1.D-5) THEN
	PHI=0.D0
	ELSE
	PHI=ACOS(XA/XX)
	IF (ABS(XB).GT.1.D-5) PHI=PHI*XB/ABS(XB)
	END IF

	END


      SUBROUTINE slDH2E (AZ, EL, PHI, HA, DEC)
*+
*     - - - - -
*      D E 2 H
*     - - - - -
*
*  Horizon to equatorial coordinates:  Az,El to HA,Dec
*
*  (double precision)
*
*  Given:
*     AZ      d     azimuth
*     EL      d     elevation
*     PHI     d     observatory latitude
*
*  Returned:
*     HA      d     hour angle
*     DEC     d     declination
*
*  Notes:
*
*  1)  All the arguments are angles in radians.
*
*  2)  The sign convention for azimuth is north zero, east +pi/2.
*
*  3)  HA is returned in the range +/-pi.  Declination is returned
*      in the range +/-pi/2.
*
*  4)  The latitude is (in principle) geodetic.  In critical
*      applications, corrections for polar motion should be applied.
*
*  5)  In some applications it will be important to specify the
*      correct type of elevation in order to produce the required
*      type of HA,Dec.  In particular, it may be important to
*      distinguish between the elevation as affected by refraction,
*      which will yield the "observed" HA,Dec, and the elevation
*      in vacuo, which will yield the "topocentric" HA,Dec.  If the
*      effects of diurnal aberration can be neglected, the
*      topocentric HA,Dec may be used as an approximation to the
*      "apparent" HA,Dec.
*
*  6)  No range checking of arguments is done.
*
*  7)  In applications which involve many such calculations, rather
*      than calling the present routine it will be more efficient to
*      use inline code, having previously computed fixed terms such
*      as sine and cosine of latitude.
*
*  P.T.Wallace   Starlink   21 February 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION AZ,EL,PHI,HA,DEC

      DOUBLE PRECISION SA,CA,SE,CE,SP,CP,X,Y,Z,R

*  Useful trig functions
      SA=SIN(AZ)
      CA=COS(AZ)
      SE=SIN(EL)
      CE=COS(EL)
      SP=SIN(PHI)
      CP=COS(PHI)

*  HA,Dec as x,y,z
      X=-CA*CE*SP+SE*CP
      Y=-SA*CE
      Z=CA*CE*CP+SE*SP

*  To HA,Dec
      R=SQRT(X*X+Y*Y)
      IF (R.EQ.0D0) THEN
         HA=0D0
      ELSE
         HA=ATAN2(Y,X)
      END IF
      DEC=ATAN2(Z,R)

      END


	SUBROUTINE EBPOL(EN2,ER,EL,EP,COSTK,E,B)
C
C	CALCULATES E (NORMALIZED TO 1.) AND B IN THE WAVES
C
	COMPLEX EN2,ER,EL,EP,EPERP,D,XI,DEN,EN,E(3),B(3)
	DATA XI /(0.,1.)/
C
	SINTK2 = AMAX1(1.-COSTK**2,0.)
	SINTK = SQRT(SINTK2)
	D = .5*(ER-EL)
	EPERP = .5*(ER+EL)
	ENORM = AMAX1(CABS(ER),CABS(EL),CABS(EP))
C	ASSUME EX IS NOT ZERO AND DO RATIOS TO EX
	ERR = 1.E-7*ENORM
	DEN = EN2*SINTK2 - EP
	IF(CABS(DEN).LT.ERR) GO TO 100
	E(3) = EN2*SINTK*COSTK/DEN
   5	DEN = EN2 - EPERP
	IF(CABS(DEN).LT.ERR) GO TO 120
	E(2) = XI*D/DEN
	E(1) = 1.
	GO TO 200
C
 100	CONTINUE
C	EX IS 0. UNLESS N**2*COSTK*SINTK IS 0.
	IF(CABS(EN2)*COSTK*SINTK.GT.ERR) GO TO 110
	E(3) = 0.
	GO TO 5
 110	CONTINUE
C	EX IS 0.
	E(1) = 0.
	E(3) = 1.
	E(2) = -XI*EN2*COSTK*SINTK*E(3)/D
	GO TO 200
 120	CONTINUE
C	A STRANGE CASE. EN2 - EPERP = 0., SO EX = 0.
	E(2) = 1.
	E(1) = 0.
	E(3) = 0.
C	IF(CABS(EP-EN2*SINTK2).GT.ERR) E(3) = EN2*SINTK*COSTK
	DEN = EN2*COSTK*SINTK
	IF(CABS(DEN).GT.ERR) E(3) = XI*D*E(2)/DEN
C
C	NORMALIZE E TO LARGEST COMPONENT = (1.,0.)
C
 200	E1 = CABS(E(1))
	E2 = CABS(E(2))
	E3 = CABS(E(3))
	DEN = E(1)
	IF(E2.GT.E1.AND.E2.GT.E3) DEN = E(2)
	IF(E3.GT.E1.AND.E3.GT.E2) DEN = E(3)
	E(1) = E(1)/DEN
	E(2) = E(2)/DEN
	E(3) = E(3)/DEN
C
C	CALCULATE B
C
	EN = CSQRT(EN2)
	B(3) =  EN*SINTK*E(2)
	B(1) = -EN*COSTK*E(2)
	B(2) = EN*(COSTK*E(1) - SINTK*E(3))
	RETURN
	END


      SUBROUTINE DETFAC(NMAX,N,A,IPIVOT,IDET,DETERM,ISCALE,WK,IERR)
C
C   PURPOSE:
C      Factor a real square matrix A as PA=LU, where P is a permutation
C      matrix representing row pivotal strategy, L is a unit lower tri-
C      angular matrix, and U is an upper triangular matrix.  Options
C      are provided to compute the determinant of A with and without
C      A input in factored form.
C
C   Subroutines employed by DETFAC: None
C   Subroutines employing DETFAC: GELIM
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NMAX,1),IPIVOT(1),WK(1)
C
      DATA R1,R2/1,10/
C
      ISCALE=0
      NM1=N-1
      IERR=0
C
C     DETERMINANT CALCULATION TEST
C
      IF(IDET.EQ.1)GO TO 230
C
C     TEST FOR A SCALAR MATRIX
C
      IF(NM1.GT.0)GO TO 20
      DETERM=A(1,1)
      RETURN
C
C     COMPUTE SCALING FACTORS
C
   20 DO 60 I=1,N
      P=0.0
      DO 30 J=1,N
      Q=DMAX1(P,DABS(A(I,J)))
      IF(Q.GT.P)P=Q
   30 CONTINUE
      IF(P)60,40,60
   60 WK(I)=P
C
      DO 210 M=1,NM1
C
C     PIVOTAL LOGIC SETUP
C
      P=0.0
      DO 110 I=M,N
      Q=DABS(A(I,M)/WK(I))
      IF(Q-P)110,110,100
  100 P=Q
      IP=I
  110 CONTINUE
C
      IPIVOT(M)=IP
C
      IF(P.EQ.0.)GO TO 40
      IF(M.EQ.IP)GO TO 155
C
C     PIVOT THE M-TH ROW OF THE A MATRIX
C
      DO 150 I=1,N
      P=A(IP,I)
      A(IP,I)=A(M,I)
  150 A(M,I)=P
C
      P=WK(IP)
      WK(IP)=WK(M)
      WK(M)=P
C
  155 MP1=M+1
C
C      L/U FACTORIZATION LOGIC
C
      P=A(M,M)
      DO 180 I=MP1,N
      A(I,M)=A(I,M)/P
      Q=A(I,M)
      DO 180 K=MP1,N
  180 A(I,K)=A(I,K)-Q*A(M,K)
C
  210 CONTINUE
C
      IPIVOT(N)=N
      IF (A(N,N) .EQ. 0.0) GO TO 40
C
C     CALCULATION OF THE DETERMINANT OF A
C
      IF(IDET.EQ.0)RETURN
C
  230 CONTINUE
      DETERM=1.0
C
C     ADJUST SIGN OF DETERMINANT DUE TO PIVOTAL STRATEGY
C
      DO 250 I=1,NM1
      IF(I-IPIVOT(I))240,250,240
  240 DETERM = - DETERM
  250 CONTINUE
C
      DO 340 I=1,N
C
C
  290 DETERM = DETERM * A(I,I)
C
  300 CONTINUE
      IF(R1.GT.DABS(DETERM))GO TO 320
      DETERM=DETERM*R2
      ISCALE=ISCALE+1
      GO TO 300
C
  320 CONTINUE
      IF(R2.LT.DABS(DETERM))GO TO 340
      DETERM=DETERM*R1
      ISCALE=ISCALE-1
      GO TO 320
C
  340 CONTINUE
C
      RETURN
   40 DETERM=0.0
      IERR=1
      RETURN
      END


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of tj in forward (tangent) mode:
!   variations   of useful results: tj
!   with respect to varying inputs: *temp *propunit *pres
!   Plus diff mem management of: temp:in propunit:in pres:in
!>    @brief harmonic mean Ky on cell faces in y direction over dely*
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return y hydraulic conductivity over dely*  (1/s)
!>    @details
!>    Compute the harmonic mean of Ky on the cell face in positive
!>    y-direction from the current node (i, j, k) divided by the
!>    y-distance of the current node (i, j, k) to the neighboring node
!>    (i, j+1, k).
!>
!>    dely* = 0.5 ( dely(j) + dely(j+1) )
!>
!>    Ky / dely* = [ 0.5*dely(j+1)/K(j+1) + 0.5*dely(j)/K(j) ]**-1
!>
!>               = [ ( 0.5* K(j)* dely(j+1) + 0.5*K(j+1)* dely(j) ) / ( K(j)*K(j+1) ) ]**-1
!>
!>               = [ ( 0.5 * summ ) / (prod) ]**-1 = 2.0*prod/summ
DOUBLE PRECISION FUNCTION g_TJ(i, j, k, ismpl, tj)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  USE MOD_FLOW
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL KY, RHOF, VISF
  EXTERNAL g_KY, g_RHOF, g_VISF
  DOUBLE PRECISION :: f1, f2, prod, summ, KY, RHOF, &
& VISF
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_KY, &
& g_RHOF, g_VISF
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: g_result1
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: g_result2
  DOUBLE PRECISION :: result3
  DOUBLE PRECISION :: g_result3
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: tj
  tj = 0.d0
  IF (j0 .GT. 1 .AND. j .LT. j0) THEN
    g_result1 = g_KY(i, j, k, ismpl, result1)
    g_result2 = g_RHOF(i, j, k, ismpl, result2)
    g_result3 = g_VISF(i, j, k, ismpl, result3)
    temp0 = result1*result2/result3
    g_f1 = grav*(result2*g_result1+result1*g_result2-temp0*&
&     g_result3)/result3
    f1 = grav*temp0
    g_result1 = g_KY(i, j + 1, k, ismpl, result1)
    g_result2 = g_RHOF(i, j + 1, k, ismpl, result2)
    g_result3 = g_VISF(i, j + 1, k, ismpl, result3)
    temp0 = result1*result2/result3
    g_f2 = grav*(result2*g_result1+result1*g_result2-temp0*&
&     g_result3)/result3
    f2 = grav*temp0
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = dely(j+1)*g_f1 + dely(j)*g_f2
    summ = f1*dely(j+1) + f2*dely(j)
    IF (summ .GT. 0.d0) THEN
      g_tj = 2.d0*(g_prod-prod*g_summ/summ)/summ
      tj = 2.d0*prod/summ
    ELSE
      g_tj = 0.D0
    END IF
  ELSE
    g_tj = 0.D0
  END IF
  RETURN
END FUNCTION g_TJ


!! Copyright (C) 2008 Pavel Sakov
!!
!! This file is part of EnKF-Matlab. EnKF-Matlab is a free software. See
!! LICENSE for details.

! File:           qgflux.f90
!
! Created:        31/08/2007
!
! Last modified:  08/02/2008
!
! Author:         Pavel Sakov
!                 CSIRO Marine and Atmospheric Research
!                 NERSC
!
! Purpose:        Fortran code for QG model. Time derivative.
!
! Description:
!
! Revisions:

module qgflux_mod

  use utils_mod
  use parameters_mod
  use calc_mod, only: arakawa, laplacian
  use helmholtz_mod, only: helmholtz

  implicit none

  public qg_flux

contains

  subroutine calc_psi(PSIGUESS, Q, PSI)
    real(8), dimension(:, :), intent(in) :: PSIGUESS, Q
    real(8), dimension(:, :), intent(out) :: PSI

    call helmholtz(PSIGUESS, Q, F, NX1, NY1, MREFIN, 1.0d0 / NX1, 1, 2, 3, N, M, PSI)
  end subroutine calc_psi

  subroutine qg_flux(t, Q, PSIGUESS, PSI, QFLUX)
    real(8), intent(in) :: t
    real(8), dimension(:, :), intent(in) :: Q, PSIGUESS
    real(8), dimension(:, :), intent(out) :: PSI, QFLUX

    real(8), dimension(N, M) :: JACOBIAN
    real(8), dimension(N, M) :: ZETA, ZETA2, ZETA4

    call calc_psi(PSIGUESS, Q, PSI)
    call arakawa(PSI, Q, dx, dy, JACOBIAN)
    call laplacian(PSI, dx, dy, ZETA)
    call laplacian(ZETA, dx, dy, ZETA2)
    call laplacian(ZETA2, dx, dy, ZETA4)

    QFLUX = - r * JACOBIAN - rkb * ZETA + rkh * ZETA2 - rkh2 * ZETA4 + CURLT
    QFLUX(2 : N - 1, 2 : M - 1) = QFLUX(2 : N - 1, 2 : M - 1)&
         - (0.5d0 / dx) * (PSI(3 : N, 2 : M - 1) - PSI(1 : N - 2, 2 : M - 1))
    QFLUX(1, :) = 0.0d0
    QFLUX(N, :) = 0.0d0
    QFLUX(:, 1) = 0.0d0
    QFLUX(:, M) = 0.0d0
  end subroutine qg_flux

  subroutine qg_flux_tl(t, Q0, PSI0, Q, PSIGUESS, PSI, QFLUX)
    real(8), intent(in) :: t
    real(8), dimension(:, :), intent(in) :: Q, PSIGUESS
    real(8), dimension(:, :), intent(in) :: Q0, PSI0
    real(8), dimension(:, :), intent(out) :: PSI, QFLUX

    real(8), dimension(N, M) :: J1, J2
    real(8), dimension(N, M) :: ZETA, ZETA2, ZETA4

    call calc_psi(PSIGUESS, Q, PSI)
    call arakawa(PSI0, Q, dx, dy, J1)
    call arakawa(PSI, Q0, dx, dy, J2);
    call laplacian(PSI, dx, dy, ZETA)
    call laplacian(ZETA, dx, dy, ZETA2)
    call laplacian(ZETA2, dx, dy, ZETA4)

    QFLUX = - r * J1 - r * J2 - rkb * ZETA + rkh * ZETA2 - rkh2 * ZETA4
    QFLUX(2 : N - 1, 2 : M - 1) = QFLUX(2 : N - 1, 2 : M - 1)&
         - (0.5d0 / dx) * (PSI(3 : N, 2 : M - 1) - PSI(1 : N - 2, 2 : M - 1))
    QFLUX(1, :) = 0.0d0
    QFLUX(N, :) = 0.0d0
    QFLUX(:, 1) = 0.0d0
    QFLUX(:, M) = 0.0d0
  end subroutine qg_flux_tl

end module qgflux_mod


      DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2,
     $                                  LDQ2, RES, LDRES )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute || Q^T Q - I ||_F for a matrix of the form
C
C                       [  op( Q1 )  op( Q2 ) ]
C                  Q =  [                     ],
C                       [ -op( Q2 )  op( Q1 ) ]
C
C     where Q1 and Q2 are N-by-N matrices. This residual can be used to
C     test wether Q is numerically an orthogonal symplectic matrix.
C
C     FUNCTION VALUE
C
C     MA02JD  DOUBLE PRECISION
C             The computed residual.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LTRAN1  LOGICAL
C             Specifies the form of op( Q1 ) as follows:
C             = .FALSE.:  op( Q1 ) = Q1;
C             = .TRUE. :  op( Q1 ) = Q1'.
C
C     LTRAN2  LOGICAL
C             Specifies the form of op( Q2 ) as follows:
C             = .FALSE.:  op( Q2 ) = Q2;
C             = .TRUE. :  op( Q2 ) = Q2'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices Q1 and Q2.  N >= 0.
C
C     Q1      (input) DOUBLE PRECISION array, dimension (LDQ1,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix op( Q1 ).
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.  LDQ1 >= MAX(1,N).
C
C     Q2      (input) DOUBLE PRECISION array, dimension (LDQ2,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix op( Q2 ).
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.  LDQ2 >= MAX(1,N).
C
C     Workspace
C
C     RES     DOUBLE PRECISION array, dimension (LDRES,N)
C
C     LDRES   INTEGER
C             The leading dimension of the array RES.  LDRES >= MAX(1,N).
C
C     METHOD
C
C     The routine computes the residual by simple elementary operations.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS).
C
C     KEYWORDS
C
C     Elementary operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           LTRAN1, LTRAN2
      INTEGER           LDQ1, LDQ2, LDRES, N
C     .. Array Arguments ..
      DOUBLE PRECISION  Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  TEMP
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1)
C     .. External Subroutines ..
      EXTERNAL          DGEMM
C     .. External Functions ..
      DOUBLE PRECISION  DLANGE, DLAPY2
      EXTERNAL          DLANGE, DLAPY2
C     .. Intrinsic Functions ..
      INTRINSIC         SQRT
C
C     .. Executable Statements ..
C
      IF ( LTRAN1 ) THEN
         CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1,
     $               LDQ1, Q1, LDQ1, ZERO, RES, LDRES )
      ELSE
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1,
     $               LDQ1, Q1, LDQ1, ZERO, RES, LDRES )
      END IF
      IF ( LTRAN2 ) THEN
         CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2,
     $               LDQ2, Q2, LDQ2, ONE, RES, LDRES )
      ELSE
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2,
     $               LDQ2, Q2, LDQ2, ONE, RES, LDRES )
      END IF
      DO 10 I = 1, N
         RES(I,I) = RES(I,I) - ONE
   10 CONTINUE
      TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY )
      IF ( LTRAN1 .AND. LTRAN2 ) THEN
         CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2,
     $               LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
         CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1,
     $               LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
      ELSE IF ( LTRAN1 ) THEN
         CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2,
     $               LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
         CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1,
     $               LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
      ELSE IF ( LTRAN2 ) THEN
         CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2,
     $               LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
         CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1,
     $               LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
      ELSE
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2,
     $               LDQ2, Q1, LDQ1, ZERO, RES, LDRES )
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1,
     $               LDQ1, Q2, LDQ2, -ONE, RES, LDRES )
      END IF
      TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES,
     $                             DUMMY ) )
      MA02JD = SQRT( TWO )*TEMP
      RETURN
C *** Last line of MA02JD ***
      END


program modecoupmat_inside

!  compute the convolution matrix due to a mask inside a square patch
!   inf: input file of shear mask field [1:ni,1:nj] (real)
!   inf2: input file of halo mask field [1:ni,1:nj] (real)
!   outf: output field of mode coupling matrix of EE, BB, EB power
!          [1:npmax*3,1:npmax*3] (real)

  use fieldinfo_
  use sub_
  implicit none

  real :: lside_amin
  integer :: i,j,i1,j1,id,jd,id1,jd1,im,jm,nn(2),np1,np2,k,dj,ifac
  integer, parameter :: ikmax=2
  real, pointer :: mask(:,:),mask2(:,:)
  real ::  num_part(npmax),num(npmax),fmask(ni*2,nj),fmask2(ni*2,nj)
  real ::  l,pbl,qbl,powm,ntotpix
  double precision :: lside(2)
  real ::  labs,labs2,g1,g2,cosj,cosj2,sinj,sinj2,lx,ly,l2x,l2y
  double precision ::  mmat_part(npmax,npmax,ikmax),mmat(npmax,npmax,ikmax),dmmat(ikmax)
  double precision :: mmat3(npmax3,npmax3)
  character(150) :: inf,inf2,cform
  character(150) :: outf
  character(20) :: clside_amin

  include 'mpif.h'
  integer :: rank,size,ierror,status(MPI_STATUS_SIZE)
  integer :: jstart,jend

  call getarg(1,inf)
  call getarg(2,inf2)
  call getarg(3,outf)

  call MPI_INIT(ierror)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ierror)
  call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierror)

  print*,'node',rank
  write(*,*) inf,inf2,outf

  call binninginit
  call readmask(inf,mask)
  call readmask(inf2,mask2)

  nn(1)=ni
  nn(2)=nj
  ntotpix=float(ni)*float(nj)

  mmat3=0.d0

  fmask=0.
  do j=1,nj
     do i=1,ni
        fmask(2*i-1,j)=mask(i,j)/ntotpix
     enddo
  enddo
  deallocate(mask)
  call fourn(fmask,nn,2,-1)

  fmask2=0.
  do j=1,nj
     do i=1,ni
        fmask2(2*i-1,j)=mask2(i,j)/ntotpix
     enddo
  enddo
  deallocate(mask2)
  call fourn(fmask2,nn,2,-1)

  lside(1)=rad1
  lside(2)=rad2

  call jstartend2(size,rank,jstart,jend,lside)
  write(*,*) rank,jstart,jend

  num_part=0.
  mmat_part=0.d0

  if (rank==0) then
     write(*,*) 'start calculation of mode coupling matrix &
          due to the simulated mask'
  endif

  dj=jend-jstart+1
  do j=jstart,jend
     if (mod(j,16)==0) write(*,*) 'rank:',rank, int(100.*(j-jstart)/dj),'% finish'
     j1 = j-1
     if (j1>nn(2)/2)  j1 = j1 - nn(2)
     do i=1,nn(1)/2+1
        i1 = i-1

        lx=float(i1)/lside(1)*(2*pi)
        ly=float(j1)/lside(2)*(2*pi)
        g1=sqrt(float(i1*i1+j1*j1))
        labs=sqrt(lx*lx+ly*ly)
        if (labs<llowbin(1)) cycle
        if (labs>=llowbin(npmax+1)) cycle
        pbl=labs*(labs+1)/(2.*pi)

        np1=1
        do while (labs>=llowbin(np1))
           np1=np1+1
        enddo
        np1=np1-1

        if ((i1==0).or.(i1==nn(1)/2)) then
           ifac=1
        else
           ! symmetry between i and nn(1)+2-i
           ifac=2
        endif

        num_part(np1)=num_part(np1)+ifac

        do jd=1,nn(2)
           jd1 = jd-1
           if (jd1>nn(2)/2)  jd1 = jd1 - nn(2)
           do id=1,nn(1)
              id1 = id-1
              if (id1>nn(1)/2)  id1 = id1 - nn(1)

              l2x=float(id1)/lside(1)*2.*pi
              l2y=float(jd1)/lside(2)*2.*pi
              g2=sqrt(float(id1*id1+jd1*jd1))
              labs2=sqrt(l2x*l2x+l2y*l2y)
              if (labs2<llowbin(1)) cycle
              if (labs2>=llowbin(npmax+1)) cycle
              qbl=(2.*pi)/labs2/(labs2+1)

              np2=1
              do while (labs2>=llowbin(np2))
                 np2=np2+1
              enddo
              np2=np2-1

              im=i1-id1
              jm=j1-jd1
!
!!! comment out if aliasing effect is included
!
!              if (abs(im)>nn(1)/2) cycle
!              if (abs(jm)>nn(2)/2) cycle

              im=mod(im+nn(1),nn(1))+1
              jm=mod(jm+nn(2),nn(2))+1

              powm=(fmask(2*im-1,jm)*fmask2(2*im-1,jm)+fmask(2*im,jm)*fmask2(2*im,jm))

              cosj=(i1*id1+j1*jd1)/g1/g2
              cosj2=2.*cosj*cosj-1.
              sinj=(i1*jd1-j1*id1)/g1/g2
              sinj2=2.*sinj*cosj

              dmmat(1)=pbl*qbl*powm*cosj2*cosj2
              dmmat(2)=pbl*qbl*powm*sinj2*sinj2

              do k=1,ikmax
                 mmat_part(np1,np2,k)=mmat_part(np1,np2,k)+ifac*dmmat(k)
              enddo
           enddo
        enddo
     enddo
  enddo

  call MPI_REDUCE(num_part,num,npmax,MPI_REAL,MPI_SUM,0,MPI_COMM_WORLD,ierror)
  do k=1,ikmax
     do np2=1,npmax
        call MPI_REDUCE(mmat_part(:,np2,k),mmat(:,np2,k),npmax,MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD,ierror)
     enddo
  enddo

  if (rank==0) then

     do np2=1,npmax
        do np1=1,npmax
           do k=1,ikmax
              if (num(np1)>0.) then
                 mmat(np1,np2,k)=mmat(np1,np2,k)/num(np1)
              else
!  k=2 is off-diagonal components
                 if (np2==np1.and.k/=2) then
                    mmat(np1,np2,k)=1.d0
                 else
                    mmat(np1,np2,k)=0.d0
                 endif
              endif
           enddo
        enddo
     enddo

     do np2=1,npmax
        do np1=1,npmax
           mmat3(np1,np2)=mmat(np1,np2,1)
           mmat3(np1+npmax,np2+npmax)=mmat(np1,np2,1)
           mmat3(np1+npmax,np2)=mmat(np1,np2,2)
           mmat3(np1,np2+npmax)=mmat(np1,np2,2)
           mmat3(np1+npmax2,np2+npmax2)=mmat(np1,np2,1)-mmat(np1,np2,2)
        enddo
     enddo

  endif

  if (rank==0) then

     cform='(2(i4,1x),(1pe15.8,1x))'

     open(2,file=outf,status='unknown')
     do np2=1,npmax3
        do np1=1,npmax3
           write(2,cform) np1,np2,mmat3(np1,np2)
        enddo
        write(2,*)
     enddo
     close(2)

  endif

  write(*,*) 'finish: rank',rank
  call MPI_FINALIZE(ierror)

contains

  subroutine readmask(inf,mask)

    implicit none

    real, pointer :: mask(:,:)
    character :: inf*150

    allocate(mask(ni,nj))
    open(1,file=inf,status='old',form='unformatted')
    read(1) mask
    close(1)

  end subroutine readmask

  subroutine jstartend2(size,rank,jstart,jend,lside)

    implicit none

    integer :: i,j,i1,j1
    integer, intent(in) :: size,rank
    integer, intent(out) :: jstart,jend
    integer :: nmode,neach
    double precision :: lx,ly,labs
    double precision, intent(in) :: lside(2)

    nmode=0
    do j=1,nj
       j1=j-1
       if (j1>nj/2)  j1 = j1 - nj
       do i=1,ni/2+1
          i1=i-1
          lx=i1*(2*pi/lside(1))
          ly=j1*(2*pi/lside(2))
          labs=sqrt(lx*lx+ly*ly)
          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle
          nmode=nmode+1
       enddo
    enddo
    neach=nmode/size

    nmode=0
    do j=1,nj
       j1=j-1
       if (j1>nj/2)  j1 = j1 - nj
       do i=1,ni/2+1
          i1=i-1
          lx=i1*(2*pi/lside(1))
          ly=j1*(2*pi/lside(2))
          labs=sqrt(lx*lx+ly*ly)
          if (labs<llowbin(1)) cycle
          if (labs>=llowbin(npmax+1)) cycle
          nmode=nmode+1
       enddo
       if (nmode<=neach*rank) jstart=j+1
       if (nmode<=neach*(rank+1)) jend=j
    enddo

    if (rank==0) jstart=1
    if (rank==size-1) jend=nj

  end subroutine jstartend2

end program modecoupmat_inside