      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1 RPL,DDSDDT,DRPLDE,DRPLDT,
     2 STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3 NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4 CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)

      INCLUDE 'ABA_PARAM.INC'

      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1 DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     2 STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     3 PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3),
     4 JSTEP(4)

      DOUBLE PRECISION B(6), DET
      PARAMETER(ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0, FOUR=4.D0,
     1 SIX=6.D0)

      mu = PROPS(1)
      lam = PROPS(2)

      DET=DFGRD1(1, 1)*DFGRD1(2, 2)*DFGRD1(3, 3)
     1 -DFGRD1(1, 2)*DFGRD1(2, 1)*DFGRD1(3, 3)
      IF(NSHR.EQ.3) THEN
      DET=DET+DFGRD1(1, 2)*DFGRD1(2, 3)*DFGRD1(3, 1)
     1 +DFGRD1(1, 3)*DFGRD1(3, 2)*DFGRD1(2, 1)
     2 -DFGRD1(1, 3)*DFGRD1(3,1)*DFGRD1(2, 2)
     3 -DFGRD1(2, 3)*DFGRD1(3, 2)*DFGRD1(1, 1)
      END IF

      B(1)=DFGRD1(1, 1)**2+DFGRD1(1, 2)**2+DFGRD1(1, 3)**2
      B(2)=DFGRD1(2, 1)**2+DFGRD1(2, 2)**2+DFGRD1(2, 3)**2
      B(3)=DFGRD1(3, 3)**2+DFGRD1(3, 1)**2+DFGRD1(3, 2)**2
      B(4)=DFGRD1(1, 1)*DFGRD1(2, 1)+DFGRD1(1, 2)*DFGRD1(2, 2)
     1 +DFGRD1(1, 3)*DFGRD1(2, 3)
      IF(NSHR.EQ.3) THEN
          B(5)=DFGRD1(1, 1)*DFGRD1(3, 1)+DFGRD1(1, 2)*DFGRD1(3, 2)
     1 +DFGRD1(1, 3)*DFGRD1(3, 3)
          B(6)=DFGRD1(2, 1)*DFGRD1(3, 1)+DFGRD1(2, 2)*DFGRD1(3, 2)
     1 +DFGRD1(2, 3)*DFGRD1(3, 3)
      END IF
C
C CALCULATE THE STRESS
C
      tp1 = (lam*LOG(det)-mu)/det
      tp2 = mu/det
      DO i = 1,NDI
          STRESS(i) = tp1 + tp2*B(i)
      END DO
      DO i = NDI+1, NDI+NSHR
          STRESS(i) = tp2*B(i)
      END DO

      tp3 = lam/det
      DDSDDE(1, 1) = tp3 + tp2*two*B(1)
      DDSDDE(2, 2) = tp3 + tp2*two*B(2)
      DDSDDE(3, 3) = tp3 + tp2*two*B(3)
      DDSDDE(1, 2) = tp3
      DDSDDE(1, 3) = tp3
      DDSDDE(2, 3) = tp3
      DDSDDE(1, 4) = tp2*B(4)
      DDSDDE(2, 4) = tp2*B(4)
      DDSDDE(3, 4) = 0.D0
      DDSDDE(4, 4) = tp2/two*(B(1)+B(2))
      IF(NSHR.EQ.3) THEN
          DDSDDE(1, 5) = tp2*B(5)
          DDSDDE(2, 5) = 0.D0
          DDSDDE(3, 5) = tp2*B(5)
          DDSDDE(1, 6) = 0.D0
          DDSDDE(2, 6) = tp2*B(6)
          DDSDDE(3, 6) = tp2*B(6)
          DDSDDE(5, 5) = tp2/two*(B(1)+B(3))
          DDSDDE(6, 6) = tp2/two*(B(2)+B(3))
          DDSDDE(4, 5) = tp2/two*B(6)
          DDSDDE(4, 6) = tp2/two*B(5)
          DDSDDE(5, 6) = tp2/two*B(4)
      END IF
      DO i =1, NTENS
          DO j = 1, i-1
              DDSDDE(i, j) = DDSDDE(j, i)
          END DO
      END DO

      STATEV(1) = DTIME

      RETURN
      END

      SUBROUTINE SDVINI(STATEV,COORDS,NSTATV,NCRDS,NOEL,NPT,
     1 LAYER,KSPT)
C
      INCLUDE 'ABA_PARAM.INC'
C
      DIMENSION STATEV(NSTATV),COORDS(NCRDS)

      STATEV(1) = 1.0D0 ! theta

      RETURN
      END


c
c     This file contains the Stokes FMM wrappers
c
c**********************************************************************
c
c     We take the following conventions for the Stokes kernels
c
c     For a source y and target x, let r_i = x_i-y_i
c     and let r = sqrt(r_1^2 + r_2^2)
c
c     The Stokeslet, G_{ij}, and its associated pressure tensor, P_j,
c     (without the 1/2pi scaling) are
c
c   UPDATE formulae
c
c     G_{ij}(x,y) = (r_i r_j)/(2r^3) + delta_{ij}/(2r)
c     P_j(x,y) = r_j/r^3
c
c     The (Type I) stresslet, T_{ijk}, and its associated pressure
c     tensor, PI_{jk}, (without the 1/4pi scaling) are
c
c     T_{ijk}(x,y) = -3 r_i r_j r_k/ r^5
c     PI_{jk} = -2 delta_{jk} + 6 r_j r_k/r^5
c

      subroutine stfmm2d(nd, eps,
     $                 nsource, source,
     $                 ifstoklet, stoklet, ifstrslet, strslet, strsvec,
     $                 ifppreg, pot, pre, grad, ntarg, targ,
     $                 ifppregtarg, pottarg, pretarg, gradtarg,ier)
c
c     Stokes FMM in R^{3}: evaluate all pairwise particle
c     interactions (ignoring self-interactions) and
c     interactions with targs.
c
c     This routine computes sums of the form
c
c       u(x) = sum_m G_{ij}(x,y^{(m)}) sigma^{(m)}_j
c                + sum_m T_{ijk}(x,y^{(m)}) mu^{(m)}_j nu^{(m)}_k
c
c     where sigma^{(m)} is the Stokeslet charge, mu^{(m)} is the
c     stresslet charge, and nu^{(m)} is the stresslet orientation
c     (note that each of these is a 3 vector per source point y^{(m)}).
c     For x a source point, the self-interaction in the sum is omitted.
c
c     Optionally, the associated pressure p(x) and gradient grad u(x)
c     are returned
c
c       p(x) = sum_m P_j(x,y^m) sigma^{(m)}_j
c          + sum_m T_{ijk}(x,y^{(m)}) PI_{jk} mu^{(m)}_j nu^{(m)}_k
c
c       grad u(x) = grad[sum_m G_{ij}(x,y^m) sigma^{(m)}_j
c                + sum_m T_{ijk}(x,y^{(m)}) mu^{(m)}_j nu^{(m)}_k]
c
c-----------------------------------------------------------------------
c     INPUT PARAMETERS:
c
c   nd:    in: integer
c              number of densities
c
c   eps:   in: double precision
c              requested precision
c
c   nsource in: integer
c               number of sources
c
c   source  in: double precision (2,nsource)
c               source(k,j) is the kth component of the jth
c               source locations
c
c   ifstoklet  in: integer
c               Stokeslet charge computation flag
c               ifstoklet = 1   =>  include Stokeslet contribution
c                                   otherwise do not
c
c   stoklet in: double precision (nd,2,nsource)
c               Stokeslet charge strengths (sigma vectors above)
c
c   ifstrslet in: integer
c               stresslet computation flag
c               ifstrslet = 1   =>  include standard stresslet
c                                   (type I)
c
c            NOT YET IMPLEMENTED
c
c               ifstrslet = 2   =>  include symmetric stresslet
c                                   (type II)
c               ifstrslet = 3   =>  include rotlet
c               ifstrslet = 4   =>  include Stokes doublet
c                      otherwise do not include
c
c   strslet  in: double precision (nd,2,nsource)
c               stresslet strengths (mu vectors above)
c
c   strsvec  in: double precision (nd,2,nsource)
c               stresslet orientations (nu vectors above)
c
c     ifppreg    in: integer
c               flag for evaluating potential, gradient, and pressure
c               at the sources
c               ifppreg = 1, only potential
c               ifppreg = 2, potential and pressure
c               ifppreg = 3, potential, pressure, and gradient
c
c   ntarg   in: integer
c              number of targs
c
c   targ    in: double precision (2,ntarg)
c             targ(k,j) is the kth component of the jth
c             targ location
c
c   ifppregtarg in: integer
c                flag for evaluating potential, gradient, and pressure
c                at the targets
c                ifppregtarg = 1, only potential
c                ifppregtarg = 2, potential and pressure
c                ifppregtarg = 3, potential, pressure, and gradient
c
c-----------------------------------------------------------------------
c
c   OUTPUT parameters:
c
c   pot   out: double precision(nd,2,nsource)
c           velocity at the source locations
c
c   pre   out: double precision(nd,nsource)
c           pressure at the source locations
c
c         GRADIENT NOT IMPLEMENTED
c   grad   out: double precision(nd,2,2,nsource)
c              gradient of velocity at the source locations
c              grad(l,i,j,k) is the ith component of the
c              gradient of the jth component of the velocity
c              for the lth density at the kth source location
c
c   pottarg   out: double precision(nd,2,ntarg)
c               velocity at the targets
c
c   pretarg   out: double precision(nd,ntarg)
c               pressure at the targets
c
c   gradtarg   out: double precision(nd,2,2,ntarg)
c               gradient of velocity at the targets
c               gradtarg(l,i,j,k) is the ith component of the
c               gradient of the jth component of the velocity
c               for the lth density at the kth target
c     ier     out: integer
c               error flag
c
c     TODO: implement other stresslet options and gradient
c------------------------------------------------------------------
      implicit none
      integer nd, ifstoklet, ifstrslet, ntarg
      double precision eps
      integer nsource, ifppreg, ifppregtarg
      double precision source(2, *), targ(2, *)
      double precision stoklet(nd, 2, *), strslet(nd, 2, *)
      double precision strsvec(nd, 2, *)
      double precision pot(nd, 2, *), pre(nd,*), grad(nd, 2, 2, *)
      double precision pottarg(nd, 2, *), pretarg(nd,*),
     1     gradtarg(nd, 2, 2, *)
c
c  CONTINUE FROM HERE
c
c

c     local
      complex *16, allocatable :: charge(:,:),dip(:,:,:)
      complex *16, allocatable :: potl(:,:),gradl(:,:,:),zsum(:)
      complex *16, allocatable :: pottargl(:,:),gradtargl(:,:,:)

      complex *16 hesstmp(10),ima,zn,zd1,zd2

      integer ndl, ifchargel, ifdipolel, ifpghl, ifpghtargl

      integer i, j, ii, ifppreg1, l, npt, ier,iper
      data ima/(0.0d0,1.0d0)/

      ifdipolel = 0
      ifchargel = 0

      if (ifstoklet .eq. 1) ifchargel = 1
      if (ifstrslet .eq. 1) ifdipolel = 1

c     allocate necessary arrays

      allocate(charge(nd,nsource),dip(nd,2,nsource),
     1     potl(nd,nsource),pottargl(nd,ntarg),
     2     gradl(nd,2,nsource),gradtargl(nd,2,ntarg),stat=ier)
      allocate(zsum(nd))
      if(ier .ne. 0) then
         print *, "In stfmm2d: cannot allocate Laplace call storage"
         print *, "nd =",nd
         print *, "nsource =",nsource
         print *, "ntarg =",ntarg
         ier = 4
         return
      endif

c     set-up appropriate vector charge and dipole arrays
      do j=1,nd
        zsum(j) = 0
      enddo
ccc$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,zd1,zd2) REDUCTION(+:zsum)
      do i = 1,nsource
         do j = 1,nd
           charge(j,i) = 0
           dip(j,1,i) = 0
           dip(j,2,i) = 0
         enddo

         if(ifstoklet.eq.1) then
           do j=1,nd
             charge(j,i) = (-ima*stoklet(j,1,i) + stoklet(j,2,i))/4
             zsum(j) = zsum(j) - charge(j,i)
           enddo
         endif

         if(ifstrslet.eq.1) then
           do j=1,nd
             zd1 = -(-strslet(j,2,i) + ima*strslet(j,1,i))/2
             zd2 = (-strsvec(j,2,i) + ima*strsvec(j,1,i))
             dip(j,1,i) = -ima*zd1*zd2
             dip(j,2,i) = ima*(zd1*dconjg(zd2) + dconjg(zd1)*zd2)
           enddo
         endif
      enddo
ccc$OMP END PARALLEL DO
      ifpghl = 0
      ifpghtargl = 0
      if(ifppreg.eq.1) ifpghl = 1
      if(ifppreg.ge.2) ifpghl = 2

      if(ifppregtarg.eq.1) ifpghtargl = 1
      if(ifppregtarg.ge.2) ifpghtargl = 2

c     call biharmonic FMM

      iper = 0
      ier = 0

      call bhfmm2d(nd,eps,nsource,source,ifchargel,charge,
     1  ifdipolel,dip,iper,ifpghl,potl,gradl,hesstmp,ntarg,
     2  targ,ifpghtargl,pottargl,gradtargl,hesstmp,ier)

      if(ifppreg.ge.1) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
        do i=1,nsource
          do j=1,nd
            pot(j,1,i) = imag(potl(j,i)+zsum(j)+charge(j,i))
            pot(j,2,i) = -real(potl(j,i)+zsum(j)+charge(j,i))
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifppreg.ge.2) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
        do i=1,nsource
          do j=1,nd
            pre(j,i) = -4*imag(gradl(j,1,i))
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifppreg.ge.3) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
        do i=1,nsource
          do j=1,nd
             grad(j,1,1,i) = imag(gradl(j,2,i))
             grad(j,2,2,i) = -imag(gradl(j,2,i))
             grad(j,2,1,i) = real(2*gradl(j,1,i)-gradl(j,2,i))
             grad(j,1,2,i) = -real(2*gradl(j,1,i)+gradl(j,2,i))
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifppregtarg.ge.1) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
        do i=1,ntarg
          do j=1,nd
            pottarg(j,1,i) = imag(pottargl(j,i)+zsum(j))
            pottarg(j,2,i) = -real(pottargl(j,i)+zsum(j))
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifppregtarg.ge.2) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
        do i=1,ntarg
          do j=1,nd
            pretarg(j,i) = -4*imag(gradtargl(j,1,i))
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifppreg.ge.3) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
        do i=1,ntarg
          do j=1,nd
             gradtarg(j,1,1,i) = imag(gradtargl(j,2,i))
             gradtarg(j,2,2,i) = -imag(gradtargl(j,2,i))
             gradtarg(j,2,1,i) = real(2*gradtargl(j,1,i)-
     1           gradtargl(j,2,i))
             gradtarg(j,1,2,i) = -real(2*gradtargl(j,1,i)+
     1           gradtargl(j,2,i))
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      return
      end


C THIS PROGRAM IS DESIGNED FOR THE CALCULATION OF A GEOID UNDULATION
C AT A POINT WHOSE LATITUDE AND LONGITUDE IS SPECIFIED. THE PROGRAM
C IS DESIGNED TO USE THE POTENTIAL COEFFICIENT MODEL EGM96 AND A
C SET OF SPHERICAL HARMONIC COEFFICIENTS OF A CORRECTION TERM.
C THE CORRECTION TERM IS COMPOSED OF SEVERAL DIFFERENT COMPONENTS
C THE PRIMARY ONE BEING THE CONVERSION OF A HEIGHT ANOMALY TO A GEOID
C UNDULATION. THE PRINCIPLES OF THIS PROCEDURE WERE INITIALLY
C DESCRIBED IN THE PAPER: USE OF POTENTIAL COEFFICIENT MODELS FOR GEOID
C UNDULATION DETERMINATION USING A SPHERICAL HARMONIC REPRESENTATION
C OF THE HEIGHT ANOMALY/GEOID UNDULATION DIFFERENCE BY R.H. RAPP,
C JOURNAL OF GEODESY, 1996.
C THIS PROGRAM IS DESIGNED TO BE USED WITH THE CONSTANTS OF EGM96
C AND THOSE OF THE WGS84(G873) SYSTEM. THE UNDULATION WILL REFER TO
C THE WGS84 ELLIPSOID.
C SPECIFIC DETAILS ON THE UNDULATION COMPUTATION WILL BE FOUND IN THE
C JOINT PROJECT REPORT DESCRIBING THE DEVELOPMENT OF EGM96.
C THIS PROGRAM IS A MODIFICATION OF THE PROGRAM DESCRIBED IN THE
C FOLLOWING REPORT:
C A FORTRAN PROGRAM FOR THE COMPUTATION OF GRAVIMETRIC QUANTITIES FROM
C HIGH DEGREE SPHERICAL HARMONIC EXPANSIONS, RICHARD H. RAPP,
C REPORT 334, DEPARTMENT OF GEODETIC SCIENCE AND SURVEYING, THE OHIO
C STATE UNIVERSITY, COLUMBUS, 1982
C THIS PROGRAM WAS PUT IN THIS FORM IN DEC 1996.
C RHRAPP.F477.NONLY
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C  The input files consist of:
C
C                correction coefficient set ("CORRCOEF") => UNIT = 1
C                    potential coefficient set ("EGM96") => UNIT = 12
C                points at which to compute (INPUT.DAT") => UNIT = 14
C
C  The output file is:
C
C                    computed geoid heights ("OUTF477") => UNIT = 20
C
C    FILE ASSIGNMENT REVISIONS AT NIMA, DECEMBER 1996.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   DIMENSIONS OF P,Q,HC,HS MUST BE AT LEAST ((MAXN+1)*(MAXN+2))/2,
C   DIMENSIONS OF SINML,COSML,SCRAP MUST BE AT LEAST MAXN,
C        WHERE MAXN IS MAXIMUM ORDER OF COMPUTATION
C THE CURRENT DIMENSIONS ARE SET FOR A MAXIMUM DEGREE OF 360
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8  P(65341),SCRAP(361),RLEG(361),DLEG(361),RLNN(361),
     *SINML(361),COSML(361)
      REAL*8 HC(65341),HS(65341),CC(65341),CS(65341)
      DATA RAD/57.29577951308232D0/,HT/0.0D0/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCC                                                           CCCCCCCCCCC
CCCCCCCCCC                 INPUT/OUPUT FILE NAMES                    CCCCCCCCCCC
CCCCCCCCCC                                                           CCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C CORRECTION COEFFICIENT FILE
      open(1,file='CORRCOEF',status='old')
C
C INPUT DATA FILE
      open(14,file='INPUT.DAT',status='old')
C
C  POTENTIAL COEFFICIENT FILE
      open(12,file='EGM96',status='old')
C
C  OUPUT FILE
      open(20,file='OUTF477.DAT',status='unknown')
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
cccc      CALL ERRSET(208,256,-1,2,IX,0)
cccc010   READ(5,900) NMAX
      NMAX = 360
900   FORMAT(I3)
      WRITE(6,910) NMAX
910   FORMAT(1H1,//' MAXIMUM DEGREE =',I4//)
      L=65341
      DO 71 I=1,L
      CC(I)=0.0D0
   71 CS(I)=0.0D0
C THE CORRECTION COEFFICIENTS ARE NOW READ IN
   72 READ(1,*,END=79)N,M,T1,T2
      IG=(N*(N+1))/2+M+1
      CC(IG)=T1
      CS(IG)=T2
      GO TO 72
   79 CONTINUE
C THE POTENTIAL COEFFICIENTS ARE NOW READ IN AND THE REFERENCE
C EVEN DEGREE ZONAL HARMONIC COEFFICIENTS REMOVED TO DEGREE 6
      CALL DHCSIN(NMAX,F,RJ2,RJ4,RJ6,HC,HS)
C SETTING IFLAG=1 PREVENTS LEGENDRE FUNCTION DERIVATIVES BEING TAKEN
C IN SUBROUTINE LEGFDN
      IFLAG=1
      IR=0
      K=NMAX+1
      FLATL=91.0D0
C READ GEODETIC LATITUDE,LONGITUDE AT POINT UNDULATION IS WANTED
cccc  030 READ(5,100,END=090) FLAT,FLON
  030 READ(14,*,END=090) FLAT,FLON
  100 FORMAT(6X,2F10.5)
C COMPUTE THE GEOCENTRIC LATITUDE,GEOCENTRIC RADIUS,NORMAL GRAVITY
      CALL RADGRA(FLAT,FLON,HT,RLAT,GR,RE)
      IF(FLATL.EQ.FLAT) GO TO 040
      RLAT1=RLAT
      RLAT=1.5707963267948966D0-RLAT
      FLATL=FLAT
      DO 25 J=1,K
      M=J-1
      CALL LEGFDN(M,RLAT,RLEG,DLEG,NMAX,IR,RLNN,IFLAG)
      DO 26 I=J,K
      N=I-1
      LOC=(N*(N+1))/2+M+1
  26  P(LOC)=RLEG(I)
  25  CONTINUE
040   RLON=FLON/RAD
      CALL DSCML (RLON,NMAX,SINML,COSML)
      CALL HUNDU(U,NMAX,P,HC,HS,SINML,COSML,
     *GR,RE,RLAT1,CC,CS,HACO)
C  U IS THE GEOID UNDULATION FROM THE EGM96 POTENTIAL COEFFICIENT MODEL
C  INCLUDING THE HEIGHT ANOMALY TO GEOID UNDULATION CORRECTION TERM
C  AND A CORRECTION TERM TO HAVE THE UNDULATIONS REFER TO THE
C  WGS84 ELLIPSOID. THE GEOID UNDULATION UNIT IS METERS.
cccc     WRITE(6,101)FLAT,FLON,U
      WRITE(20,101) FLAT,FLON,U
 101  FORMAT(2F14.7,F10.3)
      GO TO 30
  830 CONTINUE
 90   STOP
      END
      SUBROUTINE HUNDU(UNDU,NMAX,P,HC,HS,
     *SINML,COSML,GR,RE,ANG,CC,CS,HACO)
      IMPLICIT REAL*8 (A-H,O-Z)
cccc      DIMENSION SINML(1),COSML(1),P(1)
cccc      REAL*8 HC(1),HS(1),CC(1),CS(1)
      DIMENSION SINML(361),COSML(361),P(65341)
      REAL*8 HC(65341),HS(65341),CC(65341),CS(65341)
C  CONSTANTS FOR WGS84(G873)
      DATA GM/.3986004418D15/,AE/6378137.0D0/
C  GM IN UNITS OF M**3/S**2
      AR=AE/RE
      ARN=AR
      AC=0.0
      A=0.0
      B=0.0
      K=3
      DO 030 N=2,NMAX
      ARN=ARN*AR
      K=K+1
      SUM=P(K)*HC(K)
      SUMC=P(K)*CC(K)
      SUM2=0.0
      DO 020 M=1,N
      K=K+1
      TEMPC=CC(K)*COSML(M)+CS(K)*SINML(M)
      TEMP=HC(K)*COSML(M)+HS(K)*SINML(M)
      SUMC=SUMC+P(K)*TEMPC
020   SUM=SUM+     P(K) *TEMP
      AC=AC+SUMC
 30   A=A+SUM*ARN
      AC=AC+CC(1)+P(2)*CC(2)+P(3)*(CC(3)*COSML(1)+CS(3)*SINML(1))
      HACO=AC/100.D0
      UNDU=A*GM/(GR*RE)
C ADD HACO TO CONVERT HEIGHT ANOMALY ON THE ELLIPSOID TO THE UNDULATION
C ADD -0.53M TO MAKE UNDULATION REFER TO THE WGS84 ELLIPSOID.
      UNDU=UNDU+HACO-0.53D0
      RETURN
      END
      SUBROUTINE  DSCML  (RLON,NMAX,SINML,COSML)
      IMPLICIT REAL*8 (A-H,O-Z)
cccc      DIMENSION SINML(1),COSML(1)
      DIMENSION SINML(361),COSML(361)
      A=DSIN(RLON)
      B=DCOS(RLON)
      SINML(1)=A
      COSML(1)=B
      SINML(2)=2.0*B*A
      COSML(2)=2.0*B*B-1.0
      DO 010 M=3,NMAX
      SINML(M)=2.0*B*SINML(M-1)-SINML(M-2)
010   COSML(M)=2.0*B*COSML(M-1)-COSML(M-2)
      RETURN
      END
      SUBROUTINE DHCSIN (NMAX,F,J2,J4,J6,HC,HS)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER IC
      REAL*8 J2,J4,J6,J8,J10,K
      REAL*8 HC(65341),HS(65341)
C  CONSTANTS FROM WGS84(G873)
      DATA GM,OMEGA,AE/.3986004418D20,7.292115D-5,6378137.0D0/
      DATA RF/298.257223563D0/
C THE EVEN DEGREE ZONAL COEFFICIENTS GIVEN BELOW WERE COMPUTED FOR THE
C WGS84(G873) SYSTEM OF CONSTANTS AND ARE IDENTICAL TO THOSE VALUES
C USED IN THE NIMA GRIDDING PROCEDURE. COMPUTED USING SUBROUTINE
C GRS WRITTEN BY N.K. PAVLIS
      J2=0.108262982131D-2
      J4=-.237091120053D-05
      J6=0.608346498882D-8
      J8=-0.142681087920D-10
      J10=0.121439275882D-13
      M=((NMAX+1)*(NMAX+2))/2
      DO 001 N=1,M
      HC(N)=0.0
001   HS(N)=0.0
  912 FORMAT(2I4,2D30.20)
cccc 02   READ(12,912,END=3)N,M,C,S
 02   READ(12,*,END=3)N,M,C,S,EC,ES
      IF(N.GT.NMAX) GO TO 002
      N=(N*(N+1))/2+M+1
      HC(N)=C
      HS(N)=S
      GO TO 002
3     HC(4)=HC(4)+J2/DSQRT(5.D0)
      HC(11)=HC(11)+J4/3.0D0
      HC(22)=HC(22)+J6/DSQRT(13.D0)
      HC(37)=HC(37)+J8/DSQRT(17.D0)
      HC(56)=HC(56)+J10/DSQRT(21.D0)
      RETURN
      END
      SUBROUTINE LEGFDN(M,THETA,RLEG,DLEG,NMX,IR,RLNN,IFLAG)
C
C            THIS SUBROUTINE COMPUTES  ALL NORMALIZED LEGENDRE FUNCTION
C            IN "RLEG" AND THEIR DERIVATIVES IN "DLEG". ORDER IS ALWAYS
C            M , AND COLATITUDE IS ALWAYS THETA  (RADIANS). MAXIMUM DEG
C            IS  NMX  . ALL CALCULATIONS IN DOUBLE PRECISION.
C            IR  MUST BE SET TO ZERO BEFORE THE FIRST CALL TO THIS SUB.
C            THE DIMENSIONS OF ARRAYS  RLEG, DLEG, AND RLNN  MUST BE
C            AT LEAST EQUAL TO  NMX+1  .
C
C            THIS PROGRAM DOES NOT COMPUTE DERIVATIVES AT THE POLES .
C
C            IF    IFLAG = 1  , ONLY THE LEGENDRE FUNCTIONS ARE
C            COMPUTED.
C
C      ORIGINAL PROGRAMMER :OSCAR L. COLOMBO, DEPT. OF GEODETIC SCIENCE
C      THE OHIO STATE UNIVERSITY, AUGUST 1980 . ******************
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
cccc      DIMENSION RLEG(1),DLEG(1),RLNN(1)
      DIMENSION RLEG(361),DLEG(361),RLNN(361)
     2, DRTS(1300),DIRT(1300)
      NMX1 = NMX+1
      NMX2P = 2*NMX+1
      M1 = M+1
      M2 = M+2
      M3 = M+3
      IF(IR.EQ.1) GO TO 10
      IR = 1
      DO 5     N = 1,NMX2P
      DRTS(N) = DSQRT(N*1.D0)
    5 DIRT(N) = 1.D0/DRTS(N)
   10 COTHET = DCOS(THETA)
      SITHET = DSIN(THETA)
      IF(IFLAG.NE.1.AND.THETA.NE.0.D0)SITHI = 1.D0/SITHET
C
C            COMPUTE THE LEGENDRE FUNCTIONS .
C
      RLNN(1) = 1.D0
      RLNN(2) = SITHET*DRTS(3)
      DO 15    N1 = 3,M1
      N = N1-1
      N2 = 2*N
   15 RLNN(N1) = DRTS(N2+1)*DIRT(N2)*SITHET*RLNN(N1-1)
      IF(M.GT.1) GO TO 20
      IF(M.EQ.0) GO TO 16
      RLEG(2) = RLNN(2)
      RLEG(3) = DRTS(5)*COTHET*RLEG(2)
      GO TO 20
   16 RLEG(1) = 1.D0
      RLEG(2) = COTHET*DRTS(3)
   20 CONTINUE
      RLEG(M1) = RLNN(M1)
        IF(M2.GT.NMX1) GO TO 35
      RLEG(M2) = DRTS(M1*2+1)*COTHET*RLEG(M1)
        IF(M3.GT.NMX1) GO TO 35
      DO 30     N1 = M3,NMX1
      N = N1-1
      IF(M.EQ.0.AND.N.LT.2.OR.M.EQ.1.AND.N.LT.3) GO TO 30
      N2 = 2*N
      RLEG(N1) = DRTS(N2+1)*DIRT(N+M)*DIRT(N-M)*(DRTS(N2-1)*COTHET*
     2 RLEG(N1-1)-DRTS(N+M-1)*DRTS(N-M-1)*DIRT(N2-3)*RLEG(N1-2))
      GO TO 30
   30 CONTINUE
   35 IF(IFLAG.EQ.1) RETURN
      IF(SITHET.EQ.0.D0) WRITE(6,99)
   99 FORMAT(//' *** LEGFDN  DOES NOT COMPUTE DERIVATIVES AT THE POLES
     2 *****************'//)
      IF(SITHET.EQ.0.D0) RETURN
C
C            COMPUTE ALL THE DERIVATIVES OF THE LEGENDRE FUNCTIONS.
C
      RLNN(1) = 0.D0
      RLN = RLNN(2)
      RLNN(2) = DRTS(3)*COTHET
      DO 40      N1 = 3, M1
      N = N1-1
      N2 = 2*N
      RLN1 = RLNN(N1)
      RLNN(N1) = DRTS(N2+1)*DIRT(N2)*(SITHET*RLNN(N)+COTHET*RLN)
      RLN = RLN1
   40 CONTINUE
      DLEG(M1) = RLNN(M1)
        IF(M2.GT.NMX1) RETURN
      DO 60      N1 = M2,NMX1
      N = N1-1
      N2 = N*2
      DLEG(N1) = SITHI*( N   *RLEG(N1)*COTHET-DRTS(N-M)*DRTS(N+M)*
     2 DRTS(N2+1)*DIRT(N2-1)*RLEG(N))
   60 CONTINUE
      RETURN
      END
      SUBROUTINE RADGRA(FLAT,FLON,HT,RLAT,GR,RE)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 N,K
C THIS SUBROUTINE COMPUTES GEOCENTRIC DISTANCE TO THE POINT,
C THE GEOCENTRIC LATITUDE,AND
C AN APPROXIMATE VALUE OF NORMAL GRAVITY AT THE POINT BASED
C THE CONSTANTS OF THE WGS84(G873) SYSTEM ARE USED
      DATA AE/6378137.D0/,E2/.00669437999013D0/,RAD/57.29577951308232D0/
      DATA GEQT,K/9.7803253359D0,.00193185265246D0/
      FLATR=FLAT/RAD
      FLONR=FLON/RAD
      T1=DSIN(FLATR)**2
      N=AE/DSQRT(1.-E2*T1)
      T2=(N+HT)*DCOS(FLATR)
      X=T2*DCOS(FLONR)
      Y=T2*DSIN(FLONR)
      Z=(N*(1.-E2)+HT)*DSIN(FLATR)
      N=AE/DSQRT(1.-E2*T1)
C COMPUTE THE GEOCENTRIC RADIUS
      RE=DSQRT(X**2+Y**2+Z**2)
C COMPUTE THE GEOCENTRIC LATITUDE
      RLAT=DATAN(Z/DSQRT(X**2+Y**2))
C COMPUTE NORMAL GRAVITY:UNITS ARE M/SEC**2
      GR=GEQT*(1.+K*T1)/DSQRT(1.-E2*T1)
      RETURN
      END


!****m* constants/constants ===================================================!
! NAME                                                                         !
!   constants                                                                  !
!------------------------------------------------------------------------------!
! DESCRIPTION                                                                  !
!   Constants used throughout the code (mainly mathematical and scientific     !
!   constants).                                                                !
!                                                                              !
!   Module also includes functions for converting to and from atomic units.    !
!                                                                              !
!   "Natural" units are defined such that they are "natural" to the user;      !
!   not any of the standard "natural" unit systems..                           !
!                                                                              !
!   e.g:                                                                       !
!     energy      -   eV                                                       !
!     length      -   ang                                                      !
!     time        -   fs                                                       !
!     mass        -   amu                                                      !
!     temperature -   K                                                        !
!     velocity    -   ang/fs                                                   !
!     force       -   eV/ang                                                   !
!     pressure    -   GPa                                                      !
!------------------------------------------------------------------------------!
! AUTHOR                                                                       !
!   Aaron Hopkinson                                                            !
!****==========================================================================!
module constants

  implicit none

  private

  integer,          public, parameter ::  dp  = selected_real_kind(15,300)

  real(kind=dp),    public, parameter ::  pi      = 3.141592653589793238462643383279_dp
  real(kind=dp),    public, parameter ::  two_pi   = 2.0_dp * pi
  real(kind=dp),    public, parameter ::  halfpi  = 0.5_dp * pi
  complex(kind=dp), public, parameter ::  cmplx_i = (0.0_dp, 1.0_dp)

  integer,                                  public, parameter ::  nelements = 118
  character(len=3),  dimension(nelements),  public, parameter ::  element_symbol = (/ 'H  ', 'He ', 'Li ', 'Be ', 'B  ',  &
                                                            &    'C  ', 'N  ', 'O  ', 'F  ', 'Ne ', 'Na ', 'Mg ', 'Al ',  &
                                                            &    'Si ', 'P  ', 'S  ', 'Cl ', 'Ar ', 'K  ', 'Ca ', 'Sc ',  &
                                                            &    'Ti ', 'V  ', 'Cr ', 'Mn ', 'Fe ', 'Co ', 'Ni ', 'Cu ',  &
                                                            &    'Zn ', 'Ga ', 'Ge ', 'As ', 'Se ', 'Br ', 'Kr ', 'Rb ',  &
                                                            &    'Sr ', 'Y  ', 'Zr ', 'Nb ', 'Mo ', 'Tc ', 'Ru ', 'Rh ',  &
                                                            &    'Pd ', 'Ag ', 'Cd ', 'In ', 'Sn ', 'Sb ', 'Te ', 'I  ',  &
                                                            &    'Xe ', 'Cs ', 'Ba ', 'La ', 'Ce ', 'Pr ', 'Nd ', 'Pm ',  &
                                                            &    'Sm ', 'Eu ', 'Gd ', 'Tb ', 'Dy ', 'Ho ', 'Er ', 'Tm ',  &
                                                            &    'Yb ', 'Lu ', 'Hf ', 'Ta ', 'W  ', 'Re ', 'Os ', 'Ir ',  &
                                                            &    'Pt ', 'Au ', 'Hg ', 'Tl ', 'Pb ', 'Bi ', 'Po ', 'At ',  &
                                                            &    'Rn ', 'Fr ', 'Ra ', 'Ac ', 'Th ', 'Pa ', 'U  ', 'Np ',  &
                                                            &    'Pu ', 'Am ', 'Cm ', 'Bk ', 'Cf ', 'Es ', 'Fm ', 'Md ',  &
                                                            &    'No ', 'Lr ', 'Rf ', 'Db ', 'Sg ', 'Bh ', 'Hs ', 'Mt ',  &
                                                            &    'Ds ', 'Rg ', 'Cn ', 'Uut', 'Fl ', 'Uup', 'Lv ', 'Uus', 'Uuo' /)

  ! element masses taken from www.ptable.com
  real(kind=dp),  dimension(nelements), public, parameter ::  element_mass = (/ 1.00794_dp, 4.002602_dp, 6.941_dp,        &
    & 9.012182_dp, 10.811_dp, 12.0107_dp, 14.0067_dp, 15.9994_dp, 18.9984032_dp, 20.1797_dp, 22.98976928_dp, 24.3050_dp,  &
    & 16.9815386_dp, 28.0855_dp, 30.973762_dp, 32.065_dp, 35.453_dp, 39.948_dp, 39.0983_dp, 40.078_dp, 44.955912_dp,      &
    & 47.867_dp, 50.9415_dp, 51.9961_dp, 54.938045_dp, 55.845_dp, 58.933195_dp, 58.6934_dp, 63.546_dp, 65.38_dp,          &
    & 69.723_dp, 72.63_dp, 74.92160_dp, 78.96_dp, 97.904_dp, 83.798_dp, 85.4678_dp, 87.62_dp, 88.90585_dp, 91.224_dp,     &
    & 92.90638_dp, 95.96_dp, 97.9072_dp, 101.07_dp, 102.90550_dp, 106.42_dp, 107.8682_dp, 102.411_dp, 114.818_dp,         &
    & 118.710_dp, 121.760_dp, 127.60_dp, 126.90447_dp, 131.293_dp, 132.9054519_dp, 137.326_dp, 138.90547_dp, 140.116_dp,  &
    & 140.90765_dp, 144.242_dp, 145.0_dp, 150.36_dp, 151.964_dp, 157.25_dp, 158.92535_dp, 162.500_dp, 164.93032_dp,       &
    & 167.259_dp, 168.93421_dp, 173.054_dp, 174.9668_dp, 178.49_dp, 180.94788_dp, 183.84_dp, 186.207_dp, 190.23_dp,       &
    & 192.217_dp, 195.084_dp, 196.966569_dp, 200.59_dp, 204.3833_dp, 207.2_dp, 208.98040_dp, 208.9824_dp, 209.9871_dp,    &
    & 222.0176_dp, 223.0_dp, 226.0_dp, 227.0_dp, 232.03806_dp, 231.03588_dp, 238.02891_dp, 237.0_dp, 244.0_dp, 243.0_dp,  &
    & 247.0_dp, 247.0_dp, 251.0_dp, 252.0_dp, 257.0_dp, 258.0_dp, 259.0_dp, 262.0_dp, 261.0_dp, 262.0_dp, 266.0_dp,       &
    & 264.0_dp, 277.0_dp, 268.0_dp, 271.0_dp, 272.0_dp, 285.0_dp, 284.0_dp, 289.0_dp, 288.0_dp, 292.0_dp, 294.0_dp, 294.0_dp /)

  real(kind=dp),  public, parameter ::  elementary_charge   = 1.602176565E-19_dp                ! C
  real(kind=dp),  public, parameter ::  epsilon_0           = 8.854187817E-12_dp                ! F/m
  real(kind=dp),  public, parameter ::  plancks_const       = 6.62606957E-34_dp                 ! Js
  real(kind=dp),  public, parameter ::  speed_light         = 299792458.0_dp                    ! m/s
  real(kind=dp),  public, parameter ::  atomic_mass_unit    = 1.660538921E-27_dp                ! kg
  real(kind=dp),  public, parameter ::  electron_mass       = 9.10938291E-31_dp                 ! kg
  real(kind=dp),  public, parameter ::  kb                  = 1.3806488E-23_dp                  ! J/K

  real(kind=dp),  public, parameter ::  hbar                = plancks_const/two_pi              ! Js
  real(kind=dp),  public, parameter ::  coulomb_const       = 1.0_dp/(2.0_dp*two_pi*epsilon_0)  ! kg m^3 s^-2 C^-2
  real(kind=dp),  public, parameter ::  fine_struct_const   = coulomb_const*elementary_charge**2/(hbar*speed_light) ! dimensionless

  ! for unit conversions:
  real(kind=dp),  public, parameter ::  bohr_radius         = hbar/(electron_mass*speed_light*fine_struct_const)    ! in m
  real(kind=dp),  public, parameter ::  hartree_energy      = (fine_struct_const**2)*(speed_light**2)*electron_mass ! in J
  real(kind=dp),  public, parameter ::  atomic_time         = hbar/hartree_energy               ! in s
  real(kind=dp),  public, parameter ::  atomic_mass         = atomic_mass_unit/electron_mass    ! in kg
  real(kind=dp),  public, parameter ::  atomic_temperature  = hartree_energy/kb                 ! in K
  real(kind=dp),  public, parameter ::  atomic_pressure     = hartree_energy/(bohr_radius**3)   ! in Pa

  ! private variables
  real(kind=dp),  parameter         ::  femtosecond = 1.0E-15_dp  ! in s
  real(kind=dp),  parameter         ::  angstrom    = 1.0E-10_dp  ! in m
  real(kind=dp),  parameter         ::  gigapascal  = 1.0E09_dp   ! in Pa

  public  ::  element_symbol_to_z
  public  ::  units_natural_to_atomic
  public  ::  units_atomic_to_natural

contains

!****f* constants/element_symbol_to_z =========================================!
! NAME                                                                         !
!   element_symbol_to_z (PUBLIC)                                               !
!------------------------------------------------------------------------------!
! DESCRIPTION                                                                  !
!   Returns the atomic number (Z) for a given element symbol.                  !
!                                                                              !
!   -1 is returned if the element symbol does not exist in the element_symbol  !
!   array. (Therefore we must check for this after calling this function.)     !
!------------------------------------------------------------------------------!
! ARGUMENTS                                                                    !
!   character(len=*), intent(in)    ::  symbol                                 !
!==============================================================================!
function element_symbol_to_z(symbol)
  use io, only: io_str_to_ucase
  implicit none
  character(len=*), intent(in)    ::  symbol
  integer                         ::  element_symbol_to_z

  character(len=3)  ::  str       ! max length is 3
  integer           ::  ielement

  ! we dont give errors in here.. instead check in cell_from_file.. if we add errors here, can remove there
  str = trim(adjustl(symbol))
  element_symbol_to_z = -1

  ! return if we have an invalid length atomic symbol or string contains (some) invalid characters
  ! (digits being the most common error)
  if (scan(str,'0123456789') .ne. 0) then
    return
  end if

  call io_str_to_ucase(str(1:1))  ! first character always uppercase

  do ielement = 1, nelements
    if (str .eq. element_symbol(ielement)) then
      element_symbol_to_z = ielement
      exit
    end if
  end do
end function element_symbol_to_z

!****f* constants/units_natural_to_atomic =====================================!
! NAME                                                                         !
!   units_natural_to_atomic (PUBLIC)                                           !
!------------------------------------------------------------------------------!
! DESCRIPTION                                                                  !
!   Converts from the more user friendly units to atomic units.                !
!------------------------------------------------------------------------------!
! ARGUMENTS                                                                    !
!   real(kind=dp),  optional, intent(in)  ::  energy,                          !
!                                             length,                          !
!                                             mass,                            !
!                                             temperature,                     !
!                                             time,                            !
!                                             velocity,                        !
!                                             force,                           !
!                                             pressure                         !
!------------------------------------------------------------------------------!
! NOTES                                                                        !
!   Because all arguments are optional, the compiler will not check that we    !
!   are passing by keyword or that we are entering multiple arguments at once  !
!   - hence we rely on the user to call this correctly...                      !
!==============================================================================!
elemental function units_natural_to_atomic(energy, length, mass, temperature, time, velocity, force, pressure)
  implicit none
  real(kind=dp),  optional, intent(in)  ::  energy, length, mass, temperature, time, velocity, force, pressure
  real(kind=dp)                         ::  units_natural_to_atomic

  if (present(energy)) then
    ! input in eV - converts to J and then into Hartrees
    units_natural_to_atomic = energy*elementary_charge/hartree_energy

  else if (present(length)) then
    ! input in Angstroms - converts to m and then into Bohrs
    units_natural_to_atomic = length*angstrom/bohr_radius

  else if (present(mass)) then
    ! input in amu - scales such that electron_mass = 1
    units_natural_to_atomic = mass*atomic_mass

  else if (present(temperature)) then
    ! input in K - rescales such that kb = 1
    units_natural_to_atomic = temperature/atomic_temperature

  else if (present(time)) then
    ! input in fs - rescales..
    units_natural_to_atomic = time*femtosecond/atomic_time

  else if (present(velocity)) then
    ! input Angstroms/fs
    units_natural_to_atomic = velocity*angstrom/bohr_radius                   ! bohr per fs
    units_natural_to_atomic = units_natural_to_atomic*atomic_time/femtosecond ! bohr per atomic time unit

  else if (present(force)) then
    ! input eV/Angstrom - converts to hartrees/bohr
    units_natural_to_atomic = force*elementary_charge/hartree_energy          ! Hartrees per Angstrom
    units_natural_to_atomic = units_natural_to_atomic*bohr_radius/angstrom    ! Hartrees per Bohr

  else if (present(pressure)) then
    ! input in GPa
    units_natural_to_atomic = pressure*gigapascal/atomic_pressure
  end if
end function units_natural_to_atomic

!****f* constants/units_atomic_to_natural =====================================!
! NAME                                                                         !
!   units_atomic_to_natural (PUBLIC)                                           !
!------------------------------------------------------------------------------!
! DESCRIPTION                                                                  !
!   Converts from atomic units to a more user friendly set of units.           !
!------------------------------------------------------------------------------!
! ARGUMENTS                                                                    !
!   real(kind=dp),  optional, intent(in)  ::  energy,                          !
!                                             length,                          !
!                                             mass,                            !
!                                             temperature,                     !
!                                             time,                            !
!                                             velocity,                        !
!                                             force,                           !
!                                             pressure                         !
!------------------------------------------------------------------------------!
! NOTES                                                                        !
!   Because all arguments are optional, the compiler will not check that we    !
!   are passing by keyword or that we are entering multiple arguments at once  !
!   - hence we rely on the user to call this correctly...                      !
!==============================================================================!
elemental function units_atomic_to_natural(energy, length, mass, temperature, time, velocity, force, pressure)
  implicit none
  real(kind=dp),  optional, intent(in)  ::  energy, length, mass, temperature, time, velocity, force, pressure
  real(kind=dp)                         ::  units_atomic_to_natural

  if (present(energy)) then
    ! input in Hartrees - converts to J and then into eV
    units_atomic_to_natural = energy*hartree_energy/elementary_charge

  else if (present(length)) then
    ! input in Bohrs - converts to m and then into Angstroms
    units_atomic_to_natural = length*bohr_radius/angstrom

  else if (present(mass)) then
    ! rescales from electron_mass = 1 to standard amu
    units_atomic_to_natural = mass/atomic_mass

  else if (present(temperature)) then
    ! rescales such that kb is standard value - result in K
    units_atomic_to_natural = temperature*atomic_temperature

  else if (present(time)) then
    ! input in atomic time - rescales to seconds and then into fs
    units_atomic_to_natural = time*atomic_time/femtosecond

  else if (present(velocity)) then
    ! input in bohr/0.024..fs
    units_atomic_to_natural = velocity*bohr_radius/angstrom                   ! angstrom per atomic time unit
    units_atomic_to_natural = units_atomic_to_natural*femtosecond/atomic_time ! angstrom per fs

  else if (present(force)) then
    ! input is hartrees/bohr converts to eV/Angstrom
    units_atomic_to_natural = force*hartree_energy/elementary_charge          ! eV per Bohr
    units_atomic_to_natural = units_atomic_to_natural*angstrom/bohr_radius    ! eV per Angstrom

  else if (present(pressure)) then
    ! input E_h/(a_0**3), convert to Pa, then into GPa
    units_atomic_to_natural = pressure*atomic_pressure/gigapascal
  end if
end function units_atomic_to_natural
end module constants


program intern
use atsymb
implicit none
real, parameter :: pi=3.1415927
integer, parameter :: dp = selected_real_kind(15,307)
real(dp),dimension(:),allocatable :: x,y,z
real(dp),dimension(:,:),allocatable :: dx,dy,dz,r
real(dp) :: angijk,angjkl,fnum,fnum2,cosang,cosang2,a1,a2,b1,b2,c1,c2
real(dp) :: rnum,rden,arg,tau,sos,diff1,diff2
integer :: ii,jj,i,j,k,l,n
character*2,dimension(:),allocatable :: fasymb

read(*,*) n
read(*,*)
allocate(x(n),y(n),z(n),fasymb(n))
allocate(dx(n,n),dy(n,n),dz(n,n),r(n,n))
do ii=1,n
   read(*,*) fasymb(ii),x(ii),y(ii),z(ii)
enddo
read(*,*) i,j,k,l
do ii=1,n
   do jj=1,n
      dx(ii,jj)=x(ii)-x(jj)
      dy(ii,jj)=y(ii)-y(jj)
      dz(ii,jj)=z(ii)-z(jj)
   enddo
enddo
do ii=1,n
   do jj=1,n
      r(ii,jj)=sqrt(dx(ii,jj)*dx(ii,jj) + dy(ii,jj)*dy(ii,jj) + dz(ii,jj)*dz(ii,jj))
   enddo
enddo
fnum= dx(i,j)*dx(k,j)+dy(i,j)*dy(k,j)+dz(i,j)*dz(k,j)
fnum2=dx(j,k)*dx(l,k)+dy(j,k)*dy(l,k)+dz(j,k)*dz(l,k)
cosang=  fnum/r(i,j)/r(k,j)
cosang2=fnum2/r(j,k)/r(l,k)
angijk=acos(cosang )
angjkl=acos(cosang2)
diff1=(cosang+1)
diff2=(cosang2+1)
!if(diff1<0.004.or.diff2<0.004) then
!   print*, "angle close to 180 degrees. Abort"
!   call exit
!endif

a1=(dy(i,j)*dz(k,j)-dy(k,j)*dz(i,j))
a2=(dy(j,k)*dz(l,k)-dy(l,k)*dz(j,k))
b1=(dx(k,j)*dz(i,j)-dx(i,j)*dz(k,j))
b2=(dx(l,k)*dz(j,k)-dx(j,k)*dz(l,k))
c1=(dx(i,j)*dy(k,j)-dx(k,j)*dy(i,j))
c2=(dx(j,k)*dy(l,k)-dx(l,k)*dy(j,k))

rnum=a1*a2+b1*b2+c1*c2
rden=r(i,j)*r(j,k)*r(j,k)*r(k,l)*sin(angijk)*sin(angjkl)
arg=rnum/rden
if(arg>1)arg=1
if(arg<-1)arg=-1
tau=acos(arg)

sos=(b1*c2)*dx(k,j)-(b2*c1)*dx(k,j)-(a1*c2)*dy(k,j)+(a2*c1)*dy(k,j)+(a1*b2)*dz(k,j)-(b1*a2)*dz(k,j)
if(sos<0)tau=-tau

print*, fasymb(i),r(i,j),"1",angijk*180/pi,"0",tau*180/pi,"0",j,k,l
end program intern


real function RL_brdf (solar,view,ra,hb,br,brdf0,brdf1,brdf2)
!   calculate the normalised BRDF shape function
    real pi
    real solar, view, ra, hb, br
    real brdf0,brdf1,brdf2
    real rs_thick,li_sparse,secsolar,secvia
    real cossolar,cosvia,cosra,sinsolar,sinvia,sinra
    real cosxi,xi,tansolar,tanvia,theta_new_v,theta_new_s
    real d_li2,x_li,cosl,l_li,o_li

    RL_brdf=0.0

    pi = 4 * atan(1.0)
!   calculate Ross-thick kernel
    cossolar = cos(solar)
    cosvia = cos(view)
    cosra = cos(ra)
    sinsolar = sin(solar)
    sinvia = sin(view)
    sinra = sin(ra)
    cosxi = cossolar*cosvia+sinsolar*sinvia*cosra
    if (cosxi .ge.1) then
        cosxi = 1
    endif
    xi = acos(cosxi)
    rs_thick = ((pi/2.0-xi)*cos(xi)+sin(xi)) / (cossolar+cosvia) - pi/4.0

!   alculate Li-sparse
    tansolar = sinsolar/cossolar
    tanvia = sinvia/cosvia
    theta_new_v = atan(br*tanvia)
    theta_new_s = atan(br*tansolar)
    cosxi = cos(theta_new_s)*cos(theta_new_v)+sin(theta_new_s)*sin(theta_new_v)*cosra
    if (cosxi.ge.1) then
        cosxi = 1
    endif
    secsolar = 1.0/cos(theta_new_s)
    secvia = 1.0/cos(theta_new_v)
    d_li2 = abs(tan(theta_new_s)**2+tan(theta_new_v)**2 - 2.0*tan(theta_new_s)*tan(theta_new_v)*cosra)
    x_li = tan(theta_new_s)*tan(theta_new_v)*sinra
    cosl = hb*sqrt(d_li2+x_li**2)/(secsolar+secvia)
    if (cosl .ge. 1.0) then
        o_li=0.0
    else
        l_li=acos(cosl)
        o_li=(l_li-sin(l_li)*cos(l_li))*(secsolar+secvia)/pi
    endif
       li_sparse=o_li-(secsolar+secvia)+0.5*(1.0+cosxi) * secsolar*secvia
        RL_brdf=brdf0+brdf1*rs_thick+brdf2*li_sparse
    return
end


PROGRAM LA_CPTSV_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_PTSV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMTR = '(8(1X,F10.3))'
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, IFAIL, N, NRHS
!  .. LOCAL ARRAYS ..
   COMPLEX(WP), ALLOCATABLE :: E(:), B(:,:)
   REAL(WP), ALLOCATABLE :: D(:), DD(:), EE(:), BB(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'CPTSV ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, NRHS
   PRINT *, 'N = ', N, ' NRHS = ', NRHS
   ALLOCATE ( D(N), DD(N), E(N-1), EE(N-1), B(N,NRHS), BB(N,NRHS) )
!
        READ (NIN, *) DD(:), EE(:)

      BB(1,:) = DD(1) + EE(1)
!     BB(2:N-1,:) = EE(1:N-2) + DD(2:N-1) + EE(2:N-1)
      DO I = 2, N-1
         BB(I,:) = EE(I-1) + DD(I) + EE(I)
      ENDDO
      BB(N,:) = EE(N-1) + DD(N)
      DO I = 1, NRHS
         BB(:,I) = BB(:,I)*I
      ENDDO
   D = DD; E = EE; B = BB
      WRITE(NOUT,*) 'The matrix A:'
      WRITE (NOUT,*) 'D  '; WRITE (NOUT,FMTR) D
      WRITE (NOUT,*) 'EE '; WRITE (NOUT,FMT) E
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_CPTSV LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PTSV( D, E, B )'
   D = DD; E = EE; B = BB
   IF (NRHS .GT. 1) THEN
      CALL LA_PTSV( D, E, B )
   ELSE
      CALL LA_PTSV( D, E, B(1:N,1) )
   END IF
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_PTSV:'
   DO J = 1, NRHS
      WRITE (NOUT,FMT) B(:,J)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PTSV( D, E, B, INFO=IFAIL)'
   D = DD; E = EE; B = BB
   CALL LA_PTSV( D, E, B, INFO=IFAIL )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_PTSV, INFO = ', IFAIL
   DO J = 1, NRHS
      WRITE (NOUT,FMT) B(:,J)
   END DO
   D = DD; E = EE; B = BB
   CALL LA_PTSV( D, E, B(1:N,1), IFAIL )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_PTSV, INFO = ', IFAIL
   WRITE (NOUT,FMT) B(1:N,1)
!
END PROGRAM LA_CPTSV_ET_EXAMPLE


! { dg-do compile }
!
! PR fortran/39427
!
! Check constructor functionality.
!
! Contributed by Damian Rouson.
!
module mycomplex_module
   private
   public :: mycomplex
   type mycomplex
!      private
      real :: argument, modulus
   end type
   interface mycomplex
      module procedure complex_to_mycomplex, two_reals_to_mycomplex
   end interface
!   :
   contains
      type(mycomplex) function complex_to_mycomplex(c)
         complex, intent(in) :: c
!         :
      end function complex_to_mycomplex
      type(mycomplex) function two_reals_to_mycomplex(x,y)
         real, intent(in)           :: x
         real, intent(in), optional :: y
!         :
       end function two_reals_to_mycomplex
!       :
    end module mycomplex_module
!    :
program myuse
    use mycomplex_module
    type(mycomplex) :: a, b, c
!    :
    a = mycomplex(argument=5.6, modulus=1.0)  ! The structure constructor
    c = mycomplex(x=0.0, y=1.0)               ! A function reference
    c = mycomplex(0.0, 1.0)               ! A function reference
end program myuse


      SUBROUTINE grnflx(xsqr, xs, zs, ansp, idim, nobs)
      USE vsvd
      USE mgrid_mod, ONLY: xobser, zobser, xobsqr
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: p5 =0.5_dp, four=4.0_dp
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: idim, nobs
      REAL(rprec), DIMENSION(idim) :: xsqr, xs, zs, ansp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: i1, i2, j
      REAL(rprec) :: xt, zt, xtsqr, xt4,
     4   zrp, zrm, xvv, fxu, sqrxu, qqp, qqm
C-----------------------------------------------
!
!       EVALUATES "GREEN'S" FUNCTION FOR POLOIDAL FLUX AT INTERIOR
!       POINTS XS,ZS AND OBSERVATION POINT XT,ZT (ANSP)
!       (RECALL THETA INTEGRATION ONLY FROM ZERO TO PI, SO NEED
!        TO REFLECT ZS TO -ZS, AT LEAST IN UP-DOWN SYMMETRIC CASE)
!
      xt = xobser(nobs)
      zt = zobser(nobs)
      xtsqr = p5*xobsqr(nobs)        !1/2 factor from averaging up,down
      xt4 = four*xt
      DO j = 2,idim
        zrp = zt - zs(j)
        zrm = zt + zs(j)
        xvv =(xt + xs(j))**2
        fxu = xs(j)*xt4
        sqrxu = xsqr(j)*xtsqr
        qqp = fxu/(xvv + zrp*zrp)                !k**2 for zplasma > 0
        qqm = fxu/(xvv + zrm*zrm)                !k**2 for zplasma < 0
!
!       WHICH INDEX LIES BELOW ?
!
        i1 = INT(qqp*odqk2) + 1
        i2 = INT(qqm*odqk2) + 1
!
!       LINEAR INTERPOLATION
!
        ansp(j)  =  sqrxu *( ( yf(i1)+(qqp-qsq(i1))*dyf(i1) )
     >   + ( yf(i2)+(qqm-qsq(i2))*dyf(i2) ) )
      ENDDO

      END SUBROUTINE grnflx


c*********************************************************************
c
c     dl_poly utility for calculating energy of perfect LJ FCC lattice
c
c     copyright daresbury laboratory 1998
c     author - w.smith Nov. 1998
c
c*********************************************************************

      implicit none
      real*8 rd2,www,eps,sig,rcut,dis,rcut2,sig2,dis2,rr2
      real*8 eng,rho,pi,vir
      integer i,nnn
      dimension rd2(20),www(20)

      data pi/3.1415926536d0/
      data rd2/1.d0,2.d0,3.d0,4.d0,5.d0,6.d0,7.d0,8.d0,9.d0,10.d0,11.d0,
     x  12.d0,13.d0,15.d0,16.d0,17.d0,18.d0,19.d0,20.d0,21.d0/
      data www/12.d0,6.d0,24.d0,12.d0,24.d0,8.d0,48.d0,6.d0,36.d0,24.d0,
     x  24.d0,24.d0,72.d0,48.d0,12.d0,48.d0,30.d0,72.d0,24.d0,48.d0/

      write(*,*)'Input epsilon'
      read(*,*)eps
      write(*,*)'Input sigma'
      read(*,*)sig
      write(*,*)'Input cutoff'
      read(*,*)rcut
      write(*,*)'Input n-n distance'
      read(*,*)dis
      write(*,*)'Input no. atoms'
      read(*,*)nnn

      sig2=sig**2
      dis2=dis**2
      rcut2=rcut**2
      rho=4.d0/(2.d0**1.5d0*dis**3)
      eng=16.d0*pi*rho*eps*sig**3*((sig/rcut)**9/9.d0-
     x    (sig/rcut)**3/3.d0)
      vir=16.d0*pi*rho*eps*sig**3*(-4.d0*(sig/rcut)**9/3.d0+
     x    2.d0*(sig/rcut)**3)

      do i=1,20

        rr2=dis2*rd2(i)
        if(rr2.le.rcut2)then

          eng=eng+4.d0*eps*www(i)*((sig2/rr2)**6-(sig2/rr2)**3)
          vir=vir-24.d0*eps*www(i)*(2.d0*(sig2/rr2)**6-(sig2/rr2)**3)

        endif

      enddo

      write(*,'(a,1pe14.6)')'Site   Energy = ',eng
      write(*,'(a,1pe14.6)')'Site   Virial = ',vir
      write(*,'(a,1pe14.6)')'System Energy = ',eng*dble(nnn)/2.d0
      write(*,'(a,1pe14.6)')'System Virial = ',vir*dble(nnn)/2.d0

      end


module time_step_mod
  implicit none

  private

  public invoke_time_step

contains

  subroutine invoke_time_step(istp, ssha, ssha_u, ssha_v, &
                              sshn_t, sshn_u, sshn_v, &
                              hu, hv, ht, ua, va, un, vn)
    use kind_params_mod
    use dl_timer
    use field_mod
    use grid_mod
    use model_mod,       only: rdt, cbfr, visc
    use physical_params_mod, only: g, omega, d2r
    use momentum_mod,    only: momentum_v_code
    use momentum_mod,    only: momentum_u_code
    use continuity_mod,  only: continuity_code
    use time_update_mod, only: next_sshu_code, next_sshv_code
    use boundary_conditions_mod
    implicit none
    integer,         intent(in)    :: istp
    type(r2d_field), intent(inout) :: un, vn, sshn_t, sshn_u, sshn_v
    type(r2d_field), intent(inout) :: ua, va, ssha, ssha_u, ssha_v
    type(r2d_field), intent(in)    :: hu, hv, ht
    ! Locals
    integer :: it, ji, jj
    integer :: idepth = 1

    ! We don't know the state of a field's halos on entry to this
    ! invoke so we have to check...
    ! (hu, hv and ht are constant so no need to worry about them)
!!$    if(sshn_u%is_dirty(depth=idepth))then
       call sshn_u%halo_exchange(depth=idepth)
!!$    end if
!!$    if(sshn_v%is_dirty(depth=idepth))then
       call sshn_v%halo_exchange(depth=idepth)
!!$    end if
!!$    if(un%is_dirty(depth=idepth))then
       call un%halo_exchange(depth=idepth)
!!$    end if
!!$    if(vn%is_dirty(depth=idepth))then
       call vn%halo_exchange(depth=idepth)
!!$    end if

    do jj = ssha%internal%ystart, ssha%internal%ystop, 1
      do ji = ssha%internal%xstart, ssha%internal%xstop, 1

        call continuity_code(ji, jj,                             &
                             ssha%data, sshn_t%data,             &
                             sshn_u%data, sshn_v%data,           &
                             hu%data, hv%data, un%data, vn%data, &
                             sshn_t%grid%area_t)
      end do
    end do

    do jj = ua%internal%ystart, ua%internal%ystop, 1
      do ji = ua%internal%xstart, ua%internal%xstop, 1

        call momentum_u_code(ji, jj, &
                             ua%data, un%data, vn%data, &
                             hu%data, hv%data, ht%data, &
                             ssha_u%data, sshn_t%data,  &
                             sshn_u%data, sshn_v%data,  &
                             un%grid%tmask,  &
                             un%grid%dx_u,   &
                             un%grid%dx_v,   &
                             un%grid%dx_t,   &
                             un%grid%dy_u,   &
                             un%grid%dy_t,   &
                             un%grid%area_u, &
                             un%grid%gphiu)
      end do
    end do

    do jj = va%internal%ystart, va%internal%ystop, 1
      do ji = va%internal%xstart, va%internal%xstop, 1

        call momentum_v_code(ji, jj, &
                             va%data, un%data, vn%data, &
                             hu%data, hv%data, ht%data, &
                             ssha_v%data, sshn_t%data,  &
                             sshn_u%data, sshn_v%data,  &
                             vn%grid%tmask,    &
                             vn%grid%dx_v,     &
                             vn%grid%dx_t,     &
                             vn%grid%dy_u,     &
                             vn%grid%dy_v,     &
                             vn%grid%dy_t,     &
                             vn%grid%area_v,   &
                             vn%grid%gphiv)
      end do
    end do

    ! Apply open and solid boundary conditions

    DO jj = ssha%internal%ystart, ssha%internal%ystop
       DO ji = ssha%internal%xstart, ssha%internal%xstop
          call bc_ssh_code(ji, jj, &
                           istp, ssha%data, sshn_t%grid%tmask)
       END DO
    END DO

    call ua%halo_exchange(depth=1)

    do jj = ua%whole%ystart, ua%whole%ystop, 1
       do ji = ua%whole%xstart, ua%whole%xstop, 1
          call bc_solid_u_code(ji, jj, &
                               ua%data, va%grid%tmask)
       end do
    end do

    call va%halo_exchange(depth=1)

    DO jj = va%whole%ystart, va%whole%ystop, 1
       DO ji = va%whole%xstart, va%whole%xstop, 1
          call bc_solid_v_code(ji,jj, &
                               va%data, ua%grid%tmask)
      end do
    end do

    DO jj = va%whole%ystart, va%whole%ystop, 1
       DO ji = va%whole%xstart, va%whole%xstop, 1
          call bc_flather_v_code(ji,jj, &
                                 va%data, hv%data, sshn_v%data, &
                                 sshn_v%grid%tmask)
       END DO
    END DO

    DO jj = ua%whole%ystart, ua%whole%ystop, 1
       DO ji = ua%whole%xstart, ua%whole%xstop, 1
          call bc_flather_u_code(ji,jj, &
                                 ua%data, hu%data, sshn_u%data, &
                                 sshn_u%grid%tmask)
       END DO
    END DO

    ! Time update of fields

    !> \todo It would be more efficient to merge these copies into the
    !! subsequent loops that update ssh{u,v}
    call copy_field(ua, un)
    call copy_field(va, vn)
    call copy_field(ssha, sshn_t)

    call sshn_t%halo_exchange(depth=1)

    do jj = sshn_u%internal%ystart, sshn_u%internal%ystop
      do ji = sshn_u%internal%xstart, sshn_u%internal%xstop

         call next_sshu_code(ji, jj, sshn_u%data, sshn_t%data, &
                            sshn_t%grid%tmask,                 &
                            sshn_t%grid%area_t, sshn_t%grid%area_u)
      end do
    end do

    do jj = sshn_v%internal%ystart, sshn_v%internal%ystop
      do ji = sshn_v%internal%xstart, sshn_v%internal%xstop

        call next_sshv_code(ji, jj,                   &
                            sshn_v%data, sshn_t%data, &
                            sshn_t%grid%tmask,        &
                            sshn_t%grid%area_t, sshn_t%grid%area_v)
      end do
    end do

  end subroutine invoke_time_step

end module time_step_mod


      subroutine setk07(na,nb,nc,a,b,c,ptk,nptk,idef,ntet,nkmax,ntmax)
c     set the k-points in one-heigth the reciprocal cell for a
c     simple orthorhombic lattice with parameters a, b, c
c     symmetry is d2h
      implicit real*8(a-h,o-z)
      real*4 avol
      dimension ptk(4,nkmax),idef(5,ntmax)
      equivalence (ivol,avol)
      pi = 3.141592653589793238d0
      if(na.le.0.or.nb.le.0.or.nc.le.0) goto 97
      if(a.le.0.0d0 .or. b.le.0.0d0 .or. c.le.0.0d0) goto 98
      nptk = (na+1)*(nb+1)*(nc+1)
      if(nptk.gt.nkmax) stop '*** <SETK07> nptk exceeds nkmax ***'
      ntet = 6*na*nb*nc
      if(ntet.gt.ntmax) stop '*** <SETK07> ntet exceeds ntmax ***'
c *** set the k-points
      ak = pi/a/na
      bk = pi/b/nb
      ck = pi/c/nc
      write(6,100) nptk,ntet,na*ak,nb*bk,nc*ck
      nx1=na+1
      ny1=nb+1
      nz1=nc+1
      w = 1.0d0/(na*nb*nc)
      nptk=0
      do 5 i=1,nx1
      do 5 j=1,ny1
      do 5 k=1,nz1
c        nptk = (i-1)*ny1*nz1 + (j-1)*nz1 + k
      wk = w
      if(i.eq.1) wk = wk/2.0d0
      if(j.eq.1) wk = wk/2.0d0
      if(k.eq.1) wk = wk/2.0d0
      if(i.eq.nx1) wk = wk/2.0d0
      if(j.eq.ny1) wk = wk/2.0d0
      if(k.eq.nz1) wk = wk/2.0d0
      nptk=nptk+1
      ptk(1,nptk)=(i-1)*ak
      ptk(2,nptk)=(j-1)*bk
      ptk(3,nptk)=(k-1)*ck
      ptk(4,nptk) = wk
    5 continue
c *** define the tetrahedra
      ix=ny1*nz1
      ntet=0
      i7=0
      do 10 i=1,na
      do 10 j=1,nb
      i7=(i-1)*ix+(j-1)*nz1
      do 10 k=1,nc
      i7=i7+1
      i6=i7+ix
      i2=i6+nz1
      i1=i2+1
      ntet=ntet+1
      idef(1,ntet)=i7
      idef(2,ntet)=i6
      idef(3,ntet)=i2
      idef(4,ntet)=i1
      i8=i7+1
      i5=i6+1
      ntet=ntet+1
      idef(1,ntet)=i7
      idef(2,ntet)=i6
      idef(3,ntet)=i5
      idef(4,ntet)=i1
      ntet=ntet+1
      idef(1,ntet)=i7
      idef(2,ntet)=i8
      idef(3,ntet)=i5
      idef(4,ntet)=i1
      i3=i7+nz1
      i4=i3+1
      ntet=ntet+1
      idef(1,ntet)=i7
      idef(2,ntet)=i3
      idef(3,ntet)=i2
      idef(4,ntet)=i1
      ntet=ntet+1
      idef(1,ntet)=i7
      idef(2,ntet)=i3
      idef(3,ntet)=i4
      idef(4,ntet)=i1
      ntet=ntet+1
      idef(1,ntet)=i7
      idef(2,ntet)=i8
      idef(3,ntet)=i4
      idef(4,ntet)=i1
   10 continue
      avol=1.d0/dfloat(ntet)
      do 15 it=1,ntet
   15 idef(5,it)=ivol
      return
   97 write(6,101)
      goto 99
   98 write(6,102)
   99 stop
  100 format(' sampling the 8th part of a rectangular parallelepiped'/
     .1x,i5,' k-points',i7,' tetrahedra'/
     .' kxmax =',d11.4,'  kymax =',d11.4,'  kzmax =',d11.4)
  101 format(' *** <SETK07> na, nb or nc is not positive ***')
  102 format(' *** <SETK07> a, b or c is not positive ***')
      end


#include "Definitions.INC"

module half_ft_mod
  ! report halfft_fac times as many pos-frequency results as input data
  ! integer, parameter :: halfft_fac   = 3
  integer, parameter :: halfft_fac   = 6
  ! oversample by this factor
  integer, parameter :: NN           = 7
  ! halfft_fac should be less than NN
end module half_ft_mod

module ftutilmod
contains

  subroutine complexdiff_prev(size,in,out,diffoption)
    use fileptrmod
    implicit none
    integer, intent(in) :: size, diffoption ! diffoption = ftdiff hardwired to 3
    complex*16, intent(in) :: in(size)
    complex*16, intent(out) :: out(size)
    integer :: i,jj

    out(:)=0d0
    do i=2,size-1
       jj=min(min(i-1,size-i),4)
       select case(jj)
       case(1)
          out(i)= &
               - 1d0/2d0 * in(i-1) &
               + 1d0/2d0 * in(i+1)
       case(2)
          out(i)= &
               1d0/12d0 * in(i-2) &
               - 2d0/3d0 * in(i-1) &
               + 2d0/3d0 * in(i+1) &
               - 1d0/12d0 * in(i+2)
       case(3)
          out(i)= &
               - 1d0/60d0 * in(i-3) &
               + 3d0/20d0 * in(i-2) &
               - 3d0/4d0 * in(i-1) &
               + 3d0/4d0 * in(i+1) &
               - 3d0/20d0 * in(i+2) &
               + 1d0/60d0 * in(i+3)
       case(4)
          out(i)= &
               1d0/280d0 * in(i-4) &
               - 4d0/105d0 * in(i-3) &
               + 1d0/5d0 * in(i-2) &
               - 4d0/5d0 * in(i-1) &
               + 4d0/5d0 * in(i+1) &
               - 1d0/5d0 * in(i+2) &
               + 4d0/105d0 * in(i+3) &
               - 1d0/280d0 * in(i+4)
       end select
    end do

  end subroutine complexdiff_prev

  subroutine banded_diff_mat(size,diffpower,bw,diffmat,lda)
    use fileptrmod
    implicit none
    integer, intent(in) :: size, diffpower, bw, lda
    real*8, intent(out) :: diffmat(-bw:bw,size)
    integer :: ipiv(2*bw+1)  !! AUTOMATIC
    real*8, allocatable :: xmat(:,:),vec(:),ymat(:,:),xmat0(:,:),ymat2(:,:),&
         smat(:,:), pts(:)
    real*8 :: fac
    integer :: tbw,ii,jj,neqn,factorial,imin,imax,info,nn

    ! note:  bw = difforder
    if (diffpower==0) then
       OFLWR "Programmer failure: diffpower=0 banded_diff_mat not necessary"; CFLST
    endif
    if (diffpower<0 .or. bw.lt.1) then
       OFLWR "ERROR diffpower or difforder in banded_diff_mat ",diffpower,bw; CFLST
    endif

    tbw = 2*bw + 1
    neqn = tbw

    if (lda.ne.tbw) then
       OFLWR "ERROR banded_diff_mat programmer failure",lda,tbw; CFLST
    endif

    fac = bw**((bw-1d0)/bw)
    factorial = 1
    do ii=2,diffpower
       factorial = factorial * ii
    enddo

    fac = 1  ! TEMP

    allocate(vec(neqn), xmat(neqn,-bw:bw), ymat(-bw:bw,-bw:bw), &
         xmat0(neqn,-bw:bw), ymat2(-bw:bw,-bw:bw), &
         smat(-bw:bw,-bw:bw), pts(-bw:bw) )

    diffmat(:,:) = 0  ; vec(:) = 0;
    xmat(:,:) = 0; ymat(:,:) = 0; xmat0(:,:) = 0
    ymat2(:,:) = 0; smat(:,:) = 0; pts(:) = 0

    do ii = -bw,bw
       pts(ii) = ii / fac
    enddo
    do ii = 1, neqn
       xmat0(ii,:) = pts(:)**(ii-1)
    enddo
    do ii = -bw , bw
       xmat(:,:) = xmat0(:,:)
       imin = max(-bw,-bw-ii)
       imax = min(bw,bw-ii)
       nn = imax-imin+1
       vec(:) = 0
       vec(diffpower+1) = 1
       call dgesv(nn,1,xmat(1,imin),tbw,ipiv,vec,neqn,info)
       if (info.ne.0)then
          OFLWR "INFO DGESV IN banded_diff_mat ",info; CFLST
       endif
       vec = vec * factorial / fac**diffpower
       ymat(ii,imin:imax) = vec(1:nn)
       imin = max(-bw,-bw+ii)
       imax = min(bw,bw+ii)
       ymat2(ii,imin:imax) = vec(1:nn)
    enddo

    if (1==0) then
       print *, "YMAT2:  ", fac, diffpower
       do ii = -bw,bw
          print '(100F10.5)', ymat2(ii,:)
       enddo
       print *, "-----------end diffmat"
       print '(9F10.5)', matmul(ymat,transpose(xmat0))
       !print *, "TEMPSTOP"
       !CFLST
    endif

    do jj = -bw, -1
       ii = jj + bw + 1
       diffmat(-bw-jj:bw,ii) = ymat2(jj,-bw:bw+jj)
    enddo
    do ii=bw+1,size-bw
       diffmat(:,ii) = ymat2(0,:)
    enddo
    do jj= 1,bw
       ii = jj - bw + size
       diffmat(-bw:bw-jj,ii) = ymat2(jj,-bw+jj:bw)
    enddo

    if (1==0) then
       print *, "DMAT - T:  ", fac, diffpower
       do ii = 1,size
          print '(100F10.5)', diffmat(:,ii)
       enddo

       !print *, "DMAT:  ", fac, diffpower
       !do ii = -bw, bw
       !   print '(100F10.5)', diffmat(ii,1:10)
       !enddo

       print *, "-----------end diffmat"
       !print *, "TEMPSTOP"
       !CFLST
    endif

    deallocate(vec,xmat,ymat,xmat0,ymat2,smat,pts)

  end subroutine banded_diff_mat

  !! NOW DOES OTHER DERIVATIVES.. BEFORE WAS ONLY 1ST DERIVATIVE
  !!   and ftdiff selected different options for it..  now
  !!   we select the derivative order with diffpower
  !!   difforder is the order of the finite difference approximation
  !!
  subroutine complexdiff(size,in,out,howmany,diffpower,difforder)
    use fileptrmod
    implicit none
    integer, intent(in) :: size, howmany,diffpower, difforder
    complex*16, intent(in) :: in(size,howmany)
    complex*16, intent(out) :: out(size,howmany)
    real*8, allocatable :: bandmat(:,:)
    real*8 :: rein(size),reout(size),imin(size),imout(size) ! AUTOMATIC
    integer :: ii,tbw,bw

    if (diffpower<0) then
       OFLWR "error diffpower >= 0 please ", diffpower; CFLST
    endif
    if (diffpower==0) then
       out(:,:) = in(:,:)
       return
    endif
    if (difforder<1) then
       OFLWR "error, difforder > 0 please ",difforder; CFLST
    endif
    bw      = difforder
    tbw     = 2*difforder+1
    allocate(bandmat(tbw,size))

    call banded_diff_mat(size,diffpower,bw,bandmat,tbw)

    out(:,:) = 0d0

    do ii = 1,howmany
       rein(:) = real(in(:,ii),8)
       imin(:) = imag(in(:,ii))

       !   do jj=1,size
       !      rein(jj) = (jj)**3
       !   enddo

       call DGBMV('T',size,size,bw,bw,1d0,bandmat,tbw,rein,1,0d0,reout,1)

       !   print *, "DIFFVEC"
       !   print '(3F14.0)', reout(:)
       !   print *, "TEMPSTOP"
       !   CFLST

       call DGBMV('T',size,size,bw,bw,0d0,bandmat,tbw,imin,1,0d0,imout,1)
       out(:,ii)  = reout(:) + (0d0,1d0) * imout(:)
    enddo
    deallocate(bandmat)

  end subroutine complexdiff

!!!!!!!!!!  Half FT  !!!!!!!!!!!

  function half_ft_size(size)
    use half_ft_mod
    implicit none
    integer,intent(in) :: size
    integer :: half_ft_size
    half_ft_size = halfft_fac * size;
  end function half_ft_size

  subroutine half_ft_estep(size,estart,estep)
    use half_ft_mod
    implicit none
    integer,intent(in) :: size
    real*8, intent(out) :: estart,estep
    real*8, parameter :: twopi = 6.28318530717958647688d0
    estep = twopi / size / 2 / NN
    estart = estep / 2
  end subroutine half_ft_estep

  subroutine half_ft_evals(size,evals,outsize)
    use fileptrmod
    use half_ft_mod
    implicit none
    integer,intent(in) :: size,outsize
    real*8, intent(out) :: evals(outsize)
    real*8 :: estart,estep
    integer :: i
    if (outsize.ne.half_ft_size(size)) then
       OFLWR "ack half_ft_evals",outsize,half_ft_size(size); CFLST
    endif
    call half_ft_estep(size,estart,estep)
    evals(:) = 0
    do i=1,outsize
       evals(i) = estart + estep*(i-1)
    enddo
  end subroutine half_ft_evals

  subroutine half_ft_wrap_diff(size,in,out,outsize,howmany,diffpower,difforder)
    use fileptrmod
    use half_ft_mod
    implicit none
    integer, intent(in) :: size,outsize,diffpower,difforder,howmany
    complex*16, intent(in) :: in(size,howmany)
    complex*16, intent(out) :: out(outsize,howmany)
    complex*16,allocatable :: work(:,:)
    real*8, allocatable :: evals(:)
    integer :: i

    if (outsize.ne.half_ft_size(size)) then
       OFLWR "progammer error 99801"; CFLST
    endif

    if (diffpower.eq.0) then
       call half_ft_wrap(size,in,out,outsize,howmany)
    else
       allocate(work(size,howmany),evals(outsize));
       work=0; evals=0

       call half_ft_evals(size,evals,outsize)

       call complexdiff(size,in,work,howmany,diffpower,difforder)

       call half_ft_wrap(size,work,out,outsize,howmany)

       do i=1,howmany
          out(:,i) = out(:,i) * ( (0d0,-1d0) / evals(:) )**diffpower
       enddo

       deallocate(work,evals)
    endif

  end subroutine half_ft_wrap_diff

  subroutine half_ft_wrap(size,in,out,outsize,howmany)
    use fileptrmod
    use half_ft_mod
    implicit none
    integer, intent(in) :: size,outsize,howmany
    complex*16, intent(in) :: in(size,howmany)
    complex*16, intent(out) :: out(outsize,howmany)
    complex*16,allocatable :: vv(:,:), csave(:)
    real*8, allocatable :: rsave(:)
    integer :: ifac(15)  !! AUTOMATIC
    integer :: bigsize,ii

    if (size.gt.20000) then
       OFLWR "ARE YOU SURE?  big size, programmer checkme ft ",size; CFLST
    endif
    if (outsize > 2*NN*size) then
       OFLWR "ack bad outsize,NN,size: ",outsize,NN,size; CFLST
    endif
    if (half_ft_size(size) .ne. outsize) then
       OFLWR "ack programmer failure 543"; CFLST
    endif

    bigsize           = 8*NN*size

    allocate(vv(2,bigsize/2))
    vv(:,:) = 0;
    allocate(rsave(2*bigsize),csave(2*bigsize))
    rsave(:) = 0; csave(:) = 0
    ifac(:) = 0

    call cffti1(bigsize,rsave,ifac)

    out(:,:) = 0;
    do ii             = 1,howmany
       vv(:,:)        = 0;
       vv(2,1:size)   = in(:,ii);
       call cfftf1(bigsize,vv,csave,rsave,ifac)
       out(:,ii)    = vv(2,1:outsize);
    enddo

    deallocate(rsave,csave)
    deallocate(vv)

  end subroutine half_ft_wrap

!!!!!!!!!  ZFFT (DFFTPACK) FT subroutines   !!!!!!!!!!

  function zfftf_size(size)
    implicit none
    integer,intent(in) :: size
    integer :: zfftf_size
    zfftf_size = size;
  end function zfftf_size

  subroutine zfftf_evals(size,evals,outsize)
    use fileptrmod
    implicit none
    integer,intent(in) :: size,outsize
    real*8, intent(out) :: evals(size)
    real*8 :: estart,estep
    integer :: i
    if (outsize.ne.zfftf_size(size)) then
       OFLWR "ack half_ft_evals",outsize,half_ft_size(size); CFLST
    endif
    call zfftf_estep(size,estart,estep)
    evals(:) = 0
    do i=1,size
       evals(i) = estart + estep*(i-1)
    enddo
  end subroutine zfftf_evals

  subroutine zfftf_estep(size,estart,estep)
    implicit none
    integer,intent(in) :: size
    real*8, intent(out) :: estart,estep
    real*8, parameter :: twopi = 6.28318530717958647688d0
    estep = twopi / size
    estart = 0
  end subroutine zfftf_estep

  subroutine zfftf_wrap_diff(size,inout,diffpower,difforder)
    implicit none
    integer, intent(in) :: size,diffpower,difforder
    complex*16, intent(inout) :: inout(size)
    complex*16,allocatable :: work(:)
    real*8, allocatable :: evals(:)

    if (diffpower.eq.0) then
       call zfftf_wrap(size,inout)
    else
       allocate(work(size),evals(size));
       work=0; evals=0
       call zfftf_evals(size,evals,size)

       !! NOW DOES OTHER DERIVATIVES.. BEFORE WAS ONLY 1ST DERIVATIVE
       !!   and ftdiff selected different options for it..  now
       !!   we select the derivative order with diffpower
       !!   difforder is the order of the finite difference approximation
       !!
       call complexdiff(size,inout,work,1,diffpower,difforder)

       call zfftf_wrap(size,work)

       inout(:) = work(:) * ( (0d0,-1d0) / evals(:) )**diffpower

       deallocate(work,evals)
    endif

  end subroutine zfftf_wrap_diff

  !  *********       edits 08-2021                  *****
  !  zfft functions use bad casting of wsave
  !  they are just little wrappers for cfft1 functions
  !  *********   now using those instead 08-2021    *****

  subroutine zfftf_wrap(size,inout)
    implicit none
    integer, intent(in) :: size
    complex*16, intent(inout) :: inout(size)
    complex*16,allocatable :: csave(:)
    real*8, allocatable :: rsave(:)
    integer :: ifac(15)  !! AUTOMATIC
    allocate(rsave(2*size),csave(2*size))
    rsave(:) = 0; csave(:) = 0; ifac(:) = 0
    call cffti1(size,rsave,ifac)
    call cfftf1(size,inout,csave,rsave,ifac)
    deallocate(rsave,csave)
  end subroutine zfftf_wrap

  subroutine zfftb_wrap(size,inout)
    implicit none
    integer, intent(in) :: size
    complex*16, intent(inout) :: inout(size)
    complex*16,allocatable :: csave(:)
    real*8, allocatable :: rsave(:)
    integer :: ifac(15)  !! AUTOMATIC
    allocate(rsave(2*size),csave(2*size))
    rsave(:) = 0; csave(:) = 0; ifac(:) = 0
    call cffti1(size,rsave,ifac)
    call cfftb1(size,inout,csave,rsave,ifac)
    deallocate(rsave,csave)
  end subroutine zfftb_wrap

  !subroutine zfftb_wrap(size,inout)
  !  implicit none
  !  integer, intent(in) :: size
  !  complex*16, intent(inout) :: inout(size)
  !  complex*16,allocatable :: wsave(:)
  !  allocate(wsave(4*size+15))
  !  wsave(:)=0d0
  !  call zffti(size,wsave)          ! no bad casting of wsave 08-2021
  !  call zfftb(size,inout,wsave)
  !  deallocate(wsave)
  !end subroutine zfftb_wrap

end module ftutilmod


subroutine bc_first_stage(k,k_t)

use definiciones
implicit none

integer(4)::i,j,k,k_t
real(8)::a_top,b_top,c_top,a_bot,b_bot,c_bot
real(8)::a_left,b_left,c_left,a_right,b_right,c_right

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Calculo de velocidades y aplicacion de condiciones de
!contorno
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!----------------------------------------
!Condiciones de contorno para la vorticidad
!---------------------------------------

do j=1,nz_i+1
i=1
!omega_aprox(i,j)=(psi_new(i+2,j)*(x(i+1)-x(i))**3-psi_new(i+1,j)*(x(i+2)-x(i))**3)/&
!(0.5d0*((x(i+2)-x(i))**3*(x(i+1)-x(i))**2-(x(i+1)-x(i))**3*(x(i+2)-x(i))**2))
!omega_aprox(i,j)=-2.0d0*psi_new(i+1,j)*(h_x**2)/delta_x**2
omega_aprox(i,j)=(psi_new(i+2,j)-8.0d0*psi_new(i+1,j))/(2.0d0*delta_x**2)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
i=nx_i+1
!omega_aprox(i,j)=(psi_new(i-2,j)*(x(i)-x(i-1))**3-psi_new(i-1,j)*(x(i)-x(i-2))**3)/&
!(0.5d0*((x(i)-x(i-2))**3*(x(i)-x(i-1))**2-(x(i)-x(i-1))**3*(x(i)-x(i-2))**2))
!omega_aprox(i,j)=-2.0d0*psi_new(i-1,j)*(h_x**2)/delta_x**2
omega_aprox(i,j)=(psi_new(i-2,j)-8.0d0*psi_new(i-1,j))/(2.0d0*delta_x**2)
end do

do i=1,nx_i+1
j=1
!omega_aprox(i,j)=(psi_new(i,j+2)*(z(j+1)-z(j))**3-psi_new(i,j+1)*(z(j+2)-z(j))**3)/&
!(0.5d0*((z(j+2)-z(j))**3*(z(j+1)-z(j))**2-(z(j+1)-z(j))**3*(z(j+2)-z(j))**2))
!omega_aprox(i,j)=-2.0d0*psi_new(i,j+1)*(h_z**2)/delta_z**2
omega_aprox(i,j)=(psi_new(i,j+2)-8.0d0*psi_new(i,j+1))/(2.0d0*delta_z**2)
j=nz_i+1
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!omega_aprox(i,j)=(psi_new(i,j-2)*(z(j)-z(j-1))**3-psi_new(i,j-1)*(z(j)-z(j-2))**3)/&
!(0.5d0*((z(j)-z(j-2))**3*(z(j)-z(j-1))**2-(z(j)-z(j-1))**3*(z(j)-z(j-2))**2))
!omega_aprox(i,j)=-2.0d0*psi_new(i,j-1)*(h_z**2)/delta_z**2
omega_aprox(i,j)=(psi_new(i,j-2)-8.0d0*psi_new(i,j-1)-6.0d0*delta_z)/(2.0d0*delta_z**2)
end do

!i=1
!j=nz_i+1
!omega_aprox(i,j)=0.0d0
!j=1
!omega_aprox(i,j)=0.0d0
!i=nx_i+1
!j=nz_i+1
!omega_aprox(i,j)=0.0d0
!j=1
!omega_aprox(i,j)=0.0d0

do j=1,nz_i
i=1
u_aprox(i,j)=0.0d0
w_aprox(i,j)=0.0d0
i=nx_i+1
u_aprox(i,j)=0.0d0
w_aprox(i,j)=0.0d0
end do
do i=1,nx_i+1
j=1
u_aprox(i,j)=0.0d0
w_aprox(i,j)=0.0d0
j=nz_i+1
u_aprox(i,j)=1.0d0
w_aprox(i,j)=0.0d0
end do

!--------------------------------------
!Velocidad en el interior del dominio
!--------------------------------------

do i=2,nx_i
do j=2,nz_i
u_aprox(i,j)=(psi_new(i,j+1)-psi_new(i,j-1))/(2.0d0*delta_z)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
w_aprox(i,j)=-(psi_new(i+1,j)-psi_new(i-1,j))/(2.0d0*delta_x)
end do
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Fin condiciones de contorno
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end subroutine bc_first_stage