subroutine poisson_setprob()
    use hsmooth_mod
    implicit none

    INTEGER example
    COMMON /comm_example/ example

    INTEGER beta_choice
    COMMON /comm_beta/ beta_choice

    DOUBLE PRECISION alpha, x0,y0,a,b
    COMMON /comm_rhs/ alpha, x0,y0,a,b

    integer bc_type(0:3)
    common /comm_bc/ bc_type

    DOUBLE PRECISION pi,pi2
    COMMON /compi/ pi, pi2

    integer i

    pi = 4.d0*atan(1.d0)
    pi2 = 2*pi

    open(10,file='setprob.data')
    read(10,*) example
    read(10,*) beta_choice
    read(10,*) alpha
    read(10,*) x0
    read(10,*) y0
    read(10,*) a
    read(10,*) b
    read(10,*) eps_disk
    read(10,*) m_polar

    call allocate_polar_arrays()
    read(10,*) (x0_polar(i),i=1,m_polar)
    read(10,*) (y0_polar(i),i=1,m_polar)
    read(10,*) (r0_polar(i),i=1,m_polar)
    read(10,*) (r1_polar(i),i=1,m_polar)
    read(10,*) (n_polar(i) ,i=1,m_polar)

    read(10,*) bc_type(0)
    read(10,*) bc_type(1)
    read(10,*) bc_type(2)
    read(10,*) bc_type(3)
    close(10)

end subroutine poisson_setprob


module mod_chkdt
  use mpi_f08
  use mod_types
  implicit none
  private
  public chkdt
  contains
  subroutine chkdt(lo,hi,dxc,dxf,dyc,dyf,dzc,dzf,visc,u,v,w,dtmax)
    !
    ! computes maximum allowed time step
    !
    implicit none
    integer , intent(in ), dimension(3) :: lo,hi
    real(rp), intent(in ), dimension(lo(1)-1:) :: dxc,dxf
    real(rp), intent(in ), dimension(lo(2)-1:) :: dyc,dyf
    real(rp), intent(in ), dimension(lo(3)-1:) :: dzc,dzf
    real(rp), intent(in ) :: visc
    real(rp), intent(in ), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: u,v,w
    real(rp), intent(out) :: dtmax
    real(rp) :: ux,uy,uz,vx,vy,vz,wx,wy,wz
    real(rp) :: dtix,dtiy,dtiz,dti,dlmin
    integer :: i,j,k
    !
    dti = 0._rp
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,u,v,w,dxc,dxf,dyc,dyf,dzc,dzf) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(ux,uy,uz,vx,vy,vz,wx,wy,wz,dtix,dtiy,dtiz) &
    !$OMP REDUCTION(max:dti)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          ux = abs(u(i,j,k))
          vx = 0.25_rp*abs( v(i,j,k)+v(i,j-1,k)+v(i+1,j,k)+v(i+1,j-1,k) )
          wx = 0.25_rp*abs( w(i,j,k)+w(i,j,k-1)+w(i+1,j,k)+w(i+1,j,k-1) )
          dtix = ux/dxc(i)+vx/dyf(j)+wx/dzf(k)
          uy = 0.25_rp*abs( u(i,j,k)+u(i,j+1,k)+u(i-1,j+1,k)+u(i-1,j,k) )
          vy = abs(v(i,j,k))
          wy = 0.25_rp*abs( w(i,j,k)+w(i,j+1,k)+w(i,j+1,k-1)+w(i,j,k-1) )
          dtiy = uy/dxf(i)+vy/dyc(j)+wy/dzf(k)
          uz = 0.25_rp*abs( u(i,j,k)+u(i-1,j,k)+u(i-1,j,k+1)+u(i,j,k+1) )
          vz = 0.25_rp*abs( v(i,j,k)+v(i,j-1,k)+v(i,j-1,k+1)+v(i,j,k+1) )
          wz = abs(w(i,j,k))
          dtiz = uz/dxf(i)+vz/dyf(j)+wz/dzc(k)
          dti = max(dti,dtix,dtiy,dtiz)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
    call mpi_allreduce(MPI_IN_PLACE,dti,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD)
    if(dti == 0._rp) dti = 1._rp
    dtmax = sqrt(3._rp)/dti
#ifndef _IMPDIFF
    dlmin     = min(minval(dxf),minval(dyf),minval(dzf))
    call mpi_allreduce(MPI_IN_PLACE,dlmin,1,MPI_REAL_RP,MPI_MIN,MPI_COMM_WORLD)
    dtmax = min(dtmax,1.65_rp/12._rp/visc*dlmin**2)
#endif
  end subroutine chkdt
end module mod_chkdt


SUBROUTINE yaw_gal_foc_nom (r_sat, v_sat, r_sun, satbf, Yangle_nom)

! ----------------------------------------------------------------------
! SUBROUTINE: yaw_gal_foc_nom.f03
! ----------------------------------------------------------------------
! Purpose:
!  Galileo yaw-attitude based on the yaw-steering law provided by the
!  European GNSS Service Center
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:		Modified Julian Day number in GPS Time (including the fraction of the day)
! - r_sat: 		Satellite position vector (m) in ITRF
! - v_sat: 		Satellite velocity vector (m/sec) in ITRF
! - r_sun:		Sun position vector (m) in ITRF
! - satbf:		Body-frame definition type
!				satbf=1 : Body-fixed frame according to the IGS Conventions (GPS Block IIA)
!				satbf=2 : Body-fixed frame X,Y axes reversal; Case of Galileo and GPS Block IIR
!
! Output arguments:
! - Yangle_nom: Yaw angle based on nominal attitude law (in degrees)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	15 April 2020
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: r_sat(3), v_sat(3), r_sun(3)
      INTEGER (KIND = 4), INTENT(IN) :: satbf

! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: Yangle_nom
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: Xsat(3), Xsun(3)
      REAL (KIND = prec_d) :: pcross(3), pcross2(3), pdot
      REAL (KIND = prec_d) :: SVBCOS
      INTEGER (KIND = 4) :: satblk
      REAL (KIND = prec_d) :: eta
      REAL (KIND = prec_d) :: So(3), Sh(3)
      REAL (KIND = prec_d) :: betaX, betaY
      REAL (KIND = prec_d) :: Gama, Soy_to, ft0, fti, ftE, beta_to, beta_te
      LOGICAL GALecl
      LOGICAL NOON, NIGHT
      REAL (KIND = prec_d) :: ANOON, ANIGHT
      REAL (KIND = prec_d) :: delta_Yaw, delta_Yaw_rad
      REAL (KIND = prec_d) :: Rz_yaw(3,3)
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: r_norm, v_norm
      REAL (KIND = prec_q) :: rr_dot, vv_dot
      REAL (KIND = prec_q) :: h_angmom(3), h_dot, h_norm
      REAL (KIND = prec_q) :: er(3), et(3), en(3)
	  REAL (KIND = prec_d) :: sn_dot, rn_cross(3), srn_dot
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Unit Vectors
! ----------------------------------------------------------------------
! Xsat:		Satellite position unit vector
      Xsat = (1D0 / sqrt(r_sat(1)**2 + r_sat(2)**2 + r_sat(3)**2) ) * r_sat

! Xsun:		Sun position unit vector
      Xsun = (1D0 / sqrt(r_sun(1)**2 + r_sun(2)**2 + r_sun(3)**2) ) * r_sun
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Orbit normal vector (cross-track)
! ----------------------------------------------------------------------
! cross product of r,v : angular momentum per unit mass
      CALL productcross(r_sat, v_sat, h_angmom)
      CALL productdot(h_angmom, h_angmom, h_dot)
      h_norm = sqrt(h_dot)

! Cross-track or normal component
     en = (1D0 / h_norm) * h_angmom
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Galileo Attitude Law as provided by the European GNSS Service Centre (GSC) web page
! https://www.gsc-europa.eu/support-to-developers/galileo-iov-satellite-metadata#top
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Galileo yaw steering law for FOC satellites
! ----------------------------------------------------------------------
! Nominal yaw angle (in degrees)

!Yangle_nom = ATAN2( s(t)*n(t) , s(t)*r(t) x n(t) )
CALL productdot(Xsun, en, sn_dot)
CALL productcross(Xsat, en, rn_cross)
CALL productdot(Xsun, rn_cross, srn_dot)
Yangle_nom = ATAN2( sn_dot , srn_dot ) * (180.0D0 / PI_global)

! IGS Conventions
IF (satbf == 1) then
	Yangle_nom = ATAN2( -1.0D0 * sn_dot , -1.0D0 * srn_dot ) * (180.0D0 / PI_global)
END IF
! ----------------------------------------------------------------------

END


c PGPEFROMRHO evalua la presion electronica y gaseosa en un punto
c a partir de la temperatura y la densidad
c_______________________________________________________________
c Basilio Ruiz 28/03/2012
c _______________________________________________________________
	subroutine pgpefromrho(t,ro,pe,pg)

	implicit real*4 (a-h,o-z)
        real*4 t,ro,pe,pg,pmusum,asum,pp(10),change
        parameter (nex=28,cgases=83145100.,avog=6.023e23)
        common/precisoitera/precitera
        common/nmaxitera/nmaxitera
        precitera=1.e-5
        nmaxitera=250

c calculamos el peso molecular medio pmu
	pmusum=0.0
        asum=0.0
	do i=1,92
  	   ii=i
	   call neldatb(ii,0.,wgt,abu,ei1,ei2)
	   pmusum=pmusum+wgt*abu
           asum=asum+abu
	end do

c inicializamos pp(8)=pe/ph'=0.1
c        pp(8)=asum-pmusum/1.302
c        if(pp(8) .lt. 1.e-3)pp(8)=1.e-3
c        pesomedio=pmusum/(asum+pp(8))
        pesomedio=1.302
        pg=ro*cgases*t/pesomedio
c        pgold=pg
        call pefrompg11(t,pg,pe)
        call gasc(t,pe,pg,pp)
        if(pp(8) .lt. 1.e-20)pp(8)=1.e-20
        if(pg .lt. 1.e-8)pg=1.e-8
        pe=pg*1.e-6
        change=100.
        iv=0
        do while (iv .lt. 30 .and. change .gt. 1.e-5)
           iv=iv+1
           pgold=pg
c          print*,iv,pesomedio,ro,pg,pe,change,pe/pg
c            print*,pg,pe,change,pe/pg

           pesomedio=pmusum/(asum+pp(8))
           pg=ro*cgases*t/pesomedio
           call pefrompg11(t,pg,pe)
           call gasc(t,pe,pg,pp)
           if(pp(8) .lt. 1.e-20)pp(8)=1.e-20
           if(pg .lt. 1.e-8)pg=1.e-8
           change=abs(1.-pg/pgold)*100.
        end do
        if(pg. lt. 1.1e-8 .or. iv. eq. 30)then
           print*,'Bad boundary condition in density'
           print*,'We chose pg=',500.
           pg=500.
c           stop
        endif
c        print*,iv,pesomedio,ro,pg,pe,change,pe/pg
c        print*,pg,pe,change,pe/pg
c
c        print*,'estoy en  linea 35 pgpefromrho'

        return
        end


      SUBROUTINE fgauss(x,a,y,dyda,na)
      INTEGER na
      REAL x,y,a(na),dyda(na)
      INTEGER i
      REAL arg,ex,fac
      y=0.
      do 11 i=1,na-1,3
        arg=(x-a(i+1))/a(i+2)
        ex=exp(-arg**2)
        fac=a(i)*ex*2.*arg
        y=y+a(i)*ex
        dyda(i)=ex
        dyda(i+1)=fac/a(i+2)
        dyda(i+2)=fac*arg/a(i+2)
11    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fgauss.for


      SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     $                  NFE,N,IFLAG,PAR,IPAR)
C
C THIS SUBROUTINE BUILDS THE JACOBIAN MATRIX OF THE HOMOTOPY MAP,
C COMPUTES A QR DECOMPOSITION OF THAT MATRIX, AND THEN CALCULATES THE
C (UNIT) TANGENT VECTOR AND THE NEWTON STEP.
C
C ON INPUT:
C
C RHOLEN < 0 IF THE NORM OF THE HOMOTOPY MAP EVALUATED AT
C    (A, LAMBDA, X) IS TO BE COMPUTED.  IF  RHOLEN >= 0  THE NORM IS NOT
C    COMPUTED AND  RHOLEN  IS NOT CHANGED.
C
C Y(1:N+1) = CURRENT POINT (LAMBDA(S), X(S)).
C
C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT PREVIOUS POINT ON THE ZERO
C    CURVE OF THE HOMOTOPY MAP.
C
C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1)  ARE WORK ARRAYS
C    USED FOR THE QR FACTORIZATION.
C
C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS = NUMBER OF HOMOTOPY
C    FUNCTION EVALUATIONS.
C
C N = DIMENSION OF X.
C
C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE.
C
C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJAC.
C
C ON OUTPUT:
C
C RHOLEN = ||RHO(A, LAMBDA(S), X(S)|| IF  RHOLEN < 0  ON INPUT.
C    OTHERWISE  RHOLEN  IS UNCHANGED.
C
C Y, YPOLD, A, N  ARE UNCHANGED.
C
C YP(1:N+1) = DY/DS = UNIT TANGENT VECTOR TO INTEGRAL CURVE OF
C    D(HOMOTOPY MAP)/DS = 0  AT  Y(S) = (LAMBDA(S), X(S)) .
C
C TZ = THE NEWTON STEP = -(PSEUDO INVERSE OF  (D RHO(A,Y(S))/D LAMBDA ,
C    D RHO(A,Y(S))/DX)) * RHO(A,Y(S)) .
C
C NFE  HAS BEEN INCRMENTED BY 1.
C
C IFLAG  IS UNCHANGED, UNLESS THE QR FACTORIZATION DETECTS A RANK < N,
C    IN WHICH CASE THE TANGENT AND NEWTON STEP VECTORS ARE NOT COMPUTED
C    AND  TANGNF  RETURNS WITH  IFLAG = 4 .
C
C
C CALLS  DDOT , DNRM2 , F (OR  RHO ), FJAC (OR  RHOJAC ).
C
      DOUBLE PRECISION ALPHAK,BETA,DDOT,DNRM2,LAMBDA,QRKK,RHOLEN,
     $       SIGMA,SUM,YPNORM
      INTEGER I,IFLAG,J,JBAR,K,KP1,N,NFE,NP1,NP2
C
C *****  ARRAY DECLARATIONS.  *****
C
      DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1)
      INTEGER IPAR(1)
C
C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      DOUBLE PRECISION QR(N,N+2),ALPHA(N),TZ(N+1)
      INTEGER PIVOT(N+1)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
C
      LAMBDA=Y(1)
      NP1=N+1
      NP2=N+2
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
C COMPUTE THE JACOBIAN MATRIX, STORE IT AND HOMOTOPY MAP IN QR.
C
      IF (IFLAG .EQ. -2) THEN
C
C  QR = ( D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX ,
C                                              RHO(A,LAMBDA,X) )  .
C
        DO 30 K=1,NP1
          CALL RHOJAC(A,LAMBDA,Y(2),QR(1,K),K,PAR,IPAR)
30      CONTINUE
        CALL RHO(A,LAMBDA,Y(2),QR(1,NP2),PAR,IPAR)
      ELSE
        CALL F(Y(2),TZ)
        IF (IFLAG .EQ. 0) THEN
C
C      QR = ( A - F(X), I - LAMBDA*DF(X) ,
C                                 X - A + LAMBDA*(A - F(X)) )  .
C
          DO 100 J=1,N
            SIGMA=A(J)
            BETA=SIGMA-TZ(J)
            QR(J,1)=BETA
100       QR(J,NP2)=Y(J+1)-SIGMA+LAMBDA*BETA
          DO 120 K=1,N
            CALL FJAC(Y(2),TZ,K)
            KP1=K+1
            DO 110 J=1,N
110         QR(J,KP1)=-LAMBDA*TZ(J)
120       QR(K,KP1)=1.0+QR(K,KP1)
        ELSE
C
C   QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I ,
C                                  X - A + LAMBDA*(F(X) - X + A) )  .
C
140       DO 150 J=1,N
            SIGMA=Y(J+1)-A(J)
            BETA=TZ(J)-SIGMA
            QR(J,1)=BETA
150       QR(J,NP2)=SIGMA+LAMBDA*BETA
          DO 170 K=1,N
            CALL FJAC(Y(2),TZ,K)
            KP1=K+1
            DO 160 J=1,N
160         QR(J,KP1)=LAMBDA*TZ(J)
170       QR(K,KP1)=1.0-LAMBDA+QR(K,KP1)
        ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C COMPUTE THE NORM OF THE HOMOTOPY MAP IF IT WAS REQUESTED.
      IF (RHOLEN .LT. 0.0) RHOLEN=DNRM2(N,QR(1,NP2),1)
C
C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM.
C
C THE FOLLOWING CODE IS A MODIFICATION OF THE ALGOL PROCEDURE
C DECOMPOSE  IN P. BUSINGER AND G. H. GOLUB, LINEAR LEAST
C SQUARES SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS,
C NUMER. MATH. 7 (1965) 269-276.
C
      DO 220 J=1,NP1
        YP(J)=DDOT(N,QR(1,J),1,QR(1,J),1)
220   PIVOT(J)=J
      DO 300 K=1,N
        SIGMA=YP(K)
        JBAR=K
        KP1=K+1
        DO 240 J=KP1,NP1
          IF (SIGMA .GE. YP(J)) GO TO 240
          SIGMA=YP(J)
          JBAR=J
240     CONTINUE
        IF (JBAR .EQ. K) GO TO 260
        I=PIVOT(K)
        PIVOT(K)=PIVOT(JBAR)
        PIVOT(JBAR)=I
        YP(JBAR)=YP(K)
        YP(K)=SIGMA
        DO 250 I=1,N
          SIGMA=QR(I,K)
          QR(I,K)=QR(I,JBAR)
          QR(I,JBAR)=SIGMA
250     CONTINUE
C   END OF COLUMN INTERCHANGE.
260     SIGMA=DDOT(N-K+1,QR(K,K),1,QR(K,K),1)
        IF (SIGMA .EQ. 0.0) THEN
          IFLAG=4
          RETURN
        ENDIF
270     IF (K .EQ. N) GO TO 300
        QRKK=QR(K,K)
        ALPHAK=-SQRT(SIGMA)
        IF (QRKK .LT. 0.0) ALPHAK=-ALPHAK
        ALPHA(K)=ALPHAK
        BETA=1.0/(SIGMA-QRKK*ALPHAK)
        QR(K,K)=QRKK-ALPHAK
        DO 290 J=KP1,NP2
          SIGMA=BETA*DDOT(N-K+1,QR(K,K),1,QR(K,J),1)
          DO 280 I=K,N
            QR(I,J)=QR(I,J)-QR(I,K)*SIGMA
280       CONTINUE
          IF (J .LT. NP2) YP(J)=YP(J)-QR(K,J)**2
290     CONTINUE
300   CONTINUE
      ALPHA(N)=QR(N,N)
C
C
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS.
      TZ(NP1)=1.0
      DO 340 I=N,1,-1
        SUM=0.0
        DO 330 J=I+1,NP1
330     SUM=SUM+QR(I,J)*TZ(J)
340   TZ(I)=-SUM/ALPHA(I)
      YPNORM=DNRM2(NP1,TZ,1)
      DO 360 K=1,NP1
360   YP(PIVOT(K))=TZ(K)/YPNORM
      IF (DDOT(NP1,YP,1,YPOLD,1) .GE. 0.0) GO TO 380
      DO 370 I=1,NP1
370   YP(I)=-YP(I)
C YP  IS THE UNIT TANGENT VECTOR IN THE CORRECT DIRECTION.
C
C COMPUTE THE MINIMUM NORM SOLUTION OF [D RHO(Y(S))] V = -RHO(Y(S)).
C V IS GIVEN BY  P - (P,Q)Q  , WHERE P IS ANY SOLUTION OF
C [D RHO] V = -RHO  AND Q IS A UNIT VECTOR IN THE KERNEL OF [D RHO].
C
380   DO 440 I=N,1,-1
        SUM=QR(I,NP1)+QR(I,NP2)
        DO 430 J=I+1,N
430     SUM=SUM+QR(I,J)*ALPHA(J)
440   ALPHA(I)=-SUM/ALPHA(I)
      DO 450 K=1,N
450   TZ(PIVOT(K))=ALPHA(K)
      TZ(PIVOT(NP1))=1.0
C TZ NOW CONTAINS A PARTICULAR SOLUTION P, AND YP CONTAINS A VECTOR Q
C IN THE KERNEL(THE TANGENT).
      SIGMA=DDOT(NP1,TZ,1,YP,1)
      DO 470 J=1,NP1
        TZ(J)=TZ(J)-SIGMA*YP(J)
470   CONTINUE
C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (LAMBDA(S), X(S)).
      RETURN
      END


      subroutine impeo(elevm,eo)
c
c     + + + PURPOSE + + +
c
c     SR IMPEO calculates the evaporation from bare soil in
c     an impoundment.  The amount of potential evaporation is
c     computed as if all the soil were bare (EO). Calculations
c     are performed using Ritchie's ET model.
c
c     This routine is based upon SR EVAP, simplified for
c     impoundments, and now in SI (meters).
c
c     Called from: SR WSHIMP
c     Author(s): Baffaut
c     Reference in User Guide:
c
c     Chapter 7.   See also EPIC model documentation (Sept. 1990)
c     and "Microclimate, the Biological Environment" by Rosenberg
c     et al., 1983.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxpln.inc'
      include 'pmxnsl.inc'
      include 'pmxhil.inc'
      include 'pmxtls.inc'
      include 'pmxelm.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real elevm,eo
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     elevm - elevation of climate station in meters
c     eo - calculated potential evaporation
c
c     + + + COMMON BLOCKS + + +
c
      include 'cangie.inc'
c     read: radpot
c
      include 'cclim.inc'
c     read: tave, radly, tdpt, iwind
c     modify: vwind
c
      include 'pmxtil.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real tk, delta, gma, alb, xx, dlt, ed, ee, fwv, pb, ra,
     1    ralb1, rbo, rhd, rn, rso, xl
      integer ievap
c
c     + + + LOCAL DEFINITIONS + + +
c
c     tk     - daily average air temperature (degrees Kelvin)
c     delta  - slope of the saturated vapor pressure
c     gma    - the second part of Priestly Taylor equation
c     alb    - soil albedo (fraction)
c     xx     - soil evaporation (potential of stage 1 and 2)
c     dlt    - slope of the saturation vapor pressure curve
c     ed     - vapor pressure
c     ee     - saturation vapor pressure
c     fwv    - mean daily wind speed
c     pb     - baromatic pressure
c     ra     - radiation
c     ralb1  - radiation
c     rbo    - net outgoing longwave radiation
c     rhd    - relative humidity
c     rn     - net radiation
c     rso    -
c     xl     - latent heat of vaporization
c     ievap  - defined below
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c     convert average daily temp to degrees Kelvin
c
      tk = tave + 273.0
c
c     compute vapor pressure slope (svp) (WEPP Equation 7.2.4
c     or EPIC Equation 2.53)
c
      delta = exp(21.255-5304.0/tk) * 5304.0 / tk ** 2
      gma = delta / (delta+0.68)
c
c     compute corrected soil albedo (alb) assuming lai = 0
c
      alb = 0.25
c
c     compute potential evaporation from bare soil (eo)
c
c     ievap - flag that determines which equation is used for
c     PET calculations
c
c     ievap = 2 for PRIESTLEY-TAYLOR  (wind data not available)
c     ievap = 3 for PENMAN (wind data available)
c
c     if wind data not available use the PRIESTLEY-TAYLOR equation
c
      if (iwind.eq.1) ievap = 2
c
c     if wind data available use the PENMAN equation
c
      if (iwind.eq.0) ievap = 3
c
c     priestley-taylor equation
c
      if (ievap.eq.2) then
c
        eo = 0.00128 * (radly*(1.0-alb)/58.3) * gma
c
      else
c
c       penman equation
c
        ra = radly / 23.9
c
c       estimate latent heat of vaporization (xl)
c       (EPIC Equation 2.38)
c
        xl = 2.501 - 0.0022 * tave
c
c       estimate saturation vapor pressure (ee) using the average
c       temperature in degrees Kelvin (tk) (EPIC Equation 2.39)
c
        ee = 0.1 * exp(54.879-5.029*alog(tk)-6790.5/tk)
c
c       calculate relative humidity (rhd) fraction from dewpoint
c       temperature (tdpt) and average temperature (tave)
c       (Rosenberg et al. (1983), Equations 5.17 & 5.18)
c
        rhd = exp((17.27*tdpt)/(237.3+tdpt)) /
     1      exp((17.27*tave)/(237.3+tave))
c
        if (rhd.gt.1.0) rhd = 1.0
c
c       calculate the vapor pressure (ed) from the saturation vapor
c       pressure (ee) and the relative humidity (rhd)
c       (EPIC Equation 2.40)
c
        ed = ee * rhd
        ralb1 = ra * (1-alb)
c
c       estimate the slope of the saturation vapor pressure
c       curve (dlt)  (EPIC Equation 2.41)
c
        dlt = ee * (6790.5/tk-5.029) / tk
c
c       compute barometric pressure in kpa (pb)
c       (Approximation of EPIC Equation 2.43)
c
        pb = 101.3 - (0.01055*elevm)
c
c       compute psychrometric constant kpa/c (gma)
c       (EPIC Equation 2.42)
c
        gma = 0.00066 * pb
        xx = dlt + gma
        rso = radpot / 23.9
c
c       calculate mean daily wind speed (vwind)
c       (Modified EPIC Equation 2.50)
c
c       the value 1.63 is used below because the wind generated
c       by CLIGEN is for a 10 meter height (not for a 2 meter
c       height as in EPIC equation 2.50)
c
        fwv = 2.7 + 1.63 * vwind
c
c       estimate the net outgoing longwave radiation (rbo)
c       (EPIC Equation 2.46)
c
        rbo = (0.34-0.14*sqrt(ed)) * 4.9e-9 * tk ** 4
c
c       calculate net radiation (rn)
c       (EPIC Equation 2.45)
c
        rn = ralb1 - rbo * (0.9*ra/rso+0.1)
        if (rn.le.0.0) rn = 0.0
c
c       compute potential evaporation (eo)
c
c       (approximation of EPIC Equation 2.37, assuming the
c       soil flux is close to zero, and thus negligible)
c
        eo = ((dlt*rn)/xl+gma*fwv*(ee-ed)) * 0.001 / xx
c
      end if
c
      return
      end


module m_ExpSave

  contains

  pure real function exp_save( x )
    ! replace exp by a function that does not under/overflow dw09
    implicit none
    real, intent(in)      :: x
    real, parameter       :: maxexp = log( 2.0 ) * maxexponent( 2.0 )
    real, parameter       :: minexp = log( 2.0 ) * minexponent( 2.0 )

    if ( abs( x ) > minexp .and. abs( x ) < maxexp ) then
      exp_save = exp( x )
    else
      if ( x > 0 ) then
        if ( x > minexp ) then
          exp_save = exp( maxexp )
        else
          exp_save = exp( minexp )
        endif
      else
        if ( - x > minexp ) then
          exp_save = exp( - maxexp )
        else
          exp_save = exp( - minexp )
        endif
      endif
    endif

  end function exp_save

end module m_ExpSave


             subroutine pot(x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)

c ANT: update info
c   System:                        Al
c   Functional form:               Embedded atom
c   Common name:                   reGold
c   Number of derivatives:         1
c   Number of bodies:              variable
c   Number of electronic surfaces: 1
c   Interface:                     HO-MM-1
c
c   Notes:  Many-body aluminum potential energy function.  The parameters
c           for this PEF have been parameterized against a data set of
c           aluminum cluster energies and bulk data.  This routine includes
c           derivatives.
c
c  References: A. W. Jasper, P. Staszewski, G. Staszewska, N. E. Schultz,
c              and D. G. Truhlar, "Analytic Potentials Energy Functions
c              for Aluminum Clusters," Phys. Rev. B, accepted (2004).
c              H. Gollisch, Surface Science 166 (1986), 87.
c
c  Units:
c       energies    - hartrees
c       coordinates - bohrs
c
c  v       --- energy of the system (output)
c  x,y,z   --- one-dimensional arrays of the Cartesian coordinates
c              of the system (input)
c  natom   --- number of atoms in the system (input)
c  maxatom --- maximal number of atoms (input)

      implicit real*8(a-h,o-z)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      dimension d_u(3,maxatom),d_ud(3,maxatom)    ! ADD OTHER VARS AS NEEDED
      parameter(autoev=27.2113961d0)
      parameter(autoang=0.529177249d0)

c ADD THIS FOR ANT
      v1=0.d0
      do i=1,natom
      dvdx(i)=0.d0
      dvdy(i)=0.d0
      dvdz(i)=0.d0
      enddo
c END

c reparameterized
      aa = 641.335d0  / autoev
      bb = 12.2192d0  / autoev
      a  = 2.9913d0  * autoang
      b  = 1.364d0  * autoang
      en = 0.66258d0

      v=0.d0
      do i=1,natom
c initialize variables need for each i
      u=0.d0
      ud=0.d0
      do k=1,3
      do l=1,natom
      d_u(k,l)=0.d0
      d_ud(k,l)=0.d0
      enddo
      enddo

      do j=1,natom
      if(i.ne.j) then
       dx=x(i)-x(j)
       dy=y(i)-y(j)
       dz=z(i)-z(j)
       rr=dsqrt(dx*dx+dy*dy+dz*dz)

       u=u+dexp(-rr*a)
       ud=ud+dexp(-rr*b)

c ANT:  deriv of parts of PEF WRT rr
       dudr = -a*dexp(-rr*a)
       duddr = -b*dexp(-rr*b)

c ANT:  derivs = sum over all bonds (DV/DRij * DRij/DXi = DV/DRij * (Xi-Xj)/Rij)
      d_u(1,i) = d_u(1,i) + dudr*dx/rr
      d_u(1,j) = d_u(1,j) - dudr*dx/rr
      d_u(2,i) = d_u(2,i) + dudr*dy/rr
      d_u(2,j) = d_u(2,j) - dudr*dy/rr
      d_u(3,i) = d_u(3,i) + dudr*dz/rr
      d_u(3,j) = d_u(3,j) - dudr*dz/rr

      d_ud(1,i) = d_ud(1,i) + duddr*dx/rr
      d_ud(1,j) = d_ud(1,j) - duddr*dx/rr
      d_ud(2,i) = d_ud(2,i) + duddr*dy/rr
      d_ud(2,j) = d_ud(2,j) - duddr*dy/rr
      d_ud(3,i) = d_ud(3,i) + duddr*dz/rr
      d_ud(3,j) = d_ud(3,j) - duddr*dz/rr

      endif
      enddo

      v=v+aa*u-bb*ud**en
      do l=1,natom
      dvdx(l) = dvdx(l) + aa*d_u(1,l) - bb*d_ud(1,l)*en*ud**(en-1.d0)
      dvdy(l) = dvdy(l) + aa*d_u(2,l) - bb*d_ud(2,l)*en*ud**(en-1.d0)
      dvdz(l) = dvdz(l) + aa*d_u(3,l) - bb*d_ud(3,l)*en*ud**(en-1.d0)
      enddo

      enddo
      return
      end


       subroutine pressure(uw,uo3,xps)
       common /sixs_atm/z(34),p(34),t(34),wh(34),wo(34)
       real z,p,t,wh,wo,xa,xb,xalt,xtemp,xwo,xwh,g
       real air,ro3,roair,ds
       integer i,isup,iinf,l,k
       real rmo3(34),rmwh(34)
       real ps,xps,uo3,uw
c      log linear interpolation
           xps=-xps
	   if (xps.ge.100.) xps=99.99
           i=0
 10        i=i+1
           if (z(i).le.xps) goto 10
           isup=i
           iinf=i-1
           xa=(z(isup)-z(iinf))/alog(p(isup)/p(iinf))
           xb=z(isup)-xa*alog(p(isup))
           ps=exp((xps-xb)/xa)
c interpolating temperature wator vapor and ozone profile versus altitud
	   xalt=xps
	   xtemp=(t(isup)-t(iinf))/(z(isup)-z(iinf))
	   xtemp=xtemp*(xalt-z(iinf))+t(iinf)
	   xwo=(wo(isup)-wo(iinf))/(z(isup)-z(iinf))
	   xwo=xwo*(xalt-z(iinf))+wo(iinf)
	   xwh=(wh(isup)-wh(iinf))/(z(isup)-z(iinf))
	   xwh=xwh*(xalt-z(iinf))+wh(iinf)
c uptading atmospheric profile
c  1rst level: target     , complete to 34
c  with interpolated layers
      z(1)=xalt
      p(1)=ps
      t(1)=xtemp
      wh(1)=xwh
      wo(1)=xwo
      do i=2,33-iinf+1
      z(i)=z(i+iinf-1)
      p(i)=p(i+iinf-1)
      t(i)=t(i+iinf-1)
      wh(i)=wh(i+iinf-1)
      wo(i)=wo(i+iinf-1)
      enddo
      l=33-iinf+1
      do i=l+1,34
      z(i)=(z(34)-z(l))*(i-l)/(34-l)+z(l)
      p(i)=(p(34)-p(l))*(i-l)/(34-l)+p(l)
      t(i)=(t(34)-t(l))*(i-l)/(34-l)+t(l)
      wh(i)=(wh(34)-wh(l))*(i-l)/(34-l)+wh(l)
      wo(i)=(wo(34)-wo(l))*(i-l)/(34-l)+wo(l)
      enddo
c compute modified h2o and o3 integrated content
      uw=0.
      uo3=0.
      g=98.1
      air=0.028964/0.0224
      ro3=0.048/0.0224
      do k=1,33
      roair=air*273.16*p(k)/(1013.25*t(k))
      rmwh(k)=wh(k)/(roair*1000.)
      rmo3(k)=wo(k)/(roair*1000.)
      enddo
      do k=2,33
      ds=(p(k-1)-p(k))/p(1)
      uw=uw+((rmwh(k)+rmwh(k-1))/2.)*ds
      uo3=uo3+((rmo3(k)+rmo3(k-1))/2.)*ds
      enddo
      uw=uw*p(1)*100./g
      uo3=uo3*p(1)*100./g
      uo3=1000.*uo3/ro3
      return
      end


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

module basis_functions

!----------------------------------------------------
! This module contains routines to compute the basis functions
!----------------------------------------------------

!----------------------------------------------------
! Other modules used are:

use global
use message_passing, only: fatal
!----------------------------------------------------

implicit none
private
public p_hier_basis_func, h_hier_basis_func, nodal_basis_func

!----------------------------------------------------
! The following generic interfaces are defined:

interface p_hier_basis_func
   module procedure p_hier_basis_func_a, p_hier_basis_func_s
end interface

interface nodal_basis_func
   module procedure nodal_basis_func_a, nodal_basis_func_s
end interface

interface h_hier_basis_func
   module procedure h_hier_basis_func_a, h_hier_basis_func_s
end interface

!----------------------------------------------------
! Defined constants:

! choice between the Szabo-Babuska and Carnevali basis
integer, parameter :: SZABO = 1, CARNEVALI = 2
integer, parameter :: use_basis = SZABO

!----------------------------------------------------

contains

!-------------------------------------------------------
! ROUTINES FOR P-HIERARCHICAL BASIS
!-------------------------------------------------------

!          -------------------
subroutine p_hier_basis_func_a(x,y,xvert,yvert,degree,set,basis,basisx,basisy, &
                               basisxx,basisyy,basisxy)
!          -------------------

!----------------------------------------------------
! This routine computes p-hierarchical basis functions and derivatives at (x,y)
! for the triangle given by (xvert,yvert).  basis, basisx, basisy, basisxx,
! basisyy and basisxy are all optional; only those present are computed.
! degree determines the polynomial degree of the basis functions; degree(1:3)
! is the degree of the edge bases opposite the corresponding vertex, degree(4)
! is the degree of the face bases.
!
! set determines which subset of the bases is returned: "a" requests all
! basis functions, "b" requests only the black bases, and "r" the red bases.
!
!  The order in which the bases are returned:
!  - the vertex bases at vertex 1, then 2, then 3
!  - the edge bases at the side opposite vertex 1, then 2, then 3
!    - for each side, the quadratic basis, then the cubic, ...
!  - the face bases, in order of degree
!
! The basis functions are as defined in
! Adjerid, S., Aiffa, M. and Flaherty, J.E., Hierarchical Finite Element
! Bases for Triangular and Tetrahedral Elements, Comp. Meth. Appl. Mech. Eng.,
! 190, (1999), pp 2925-2941.
! except that for the Carnevali edge bases in equation 2.3d, i is replaced
! by i-1 everywhere, which gives the right polynomial degree and I think
! agrees with the expression in the thesis of Whiting (another RPI student).
!
! There are two choices for the basis functions, selected by a defined
! constant above.  Either the Szabo-Babuska bases defined in
! Szabo, B. and Babuska, I., Introduction to Finite Element Analysis,
! John Wiley and Sons, New York, 1989.
! [Note: I was unable to find this book as cited in Adjerid et al.  Instead
!  I found Finite Element Analysis, John Wiley and Sons, 1991]
! or the Carnevali bases defined in
! Carnevali, P., Morris, R. B., Tsuji, Y. and Taylor, G., New Basis Functions
! and Computational Procedures for the p-Version Finite Element Analysis,
! Int. J. Num. Meth. Engng., 36, (1993), pp. 3759-3779.
!
! Choosing the Szabo-Babuska basis and performing block eliminations of the
! rows/columns corresponding to related face bases in the stiffness matrix
! should be equivalent to using the Adjerid basis for Poisson equations.
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x(:), y(:), xvert(3), yvert(3)
integer, intent(in) :: degree(4)
character(len=1), intent(in) :: set
real(my_real), intent(out), optional :: basis(:,:), basisx(:,:), basisy(:,:), &
                                        basisxx(:,:), basisyy(:,:), basisxy(:,:)

!----------------------------------------------------
! Local variables:

real(my_real) :: zeta(size(x),3), dzdx(3), dzdy(3), zetav1v2(size(x)), &
                 dzdxzeta12(size(x)), dzdyzeta12(size(x)), const, &
                 zetaprod(size(x)), forbasisx(size(x)), forbasisy(size(x)), &
                 forbasisxx(size(x)), forbasisyy(size(x)), forbasisxy(size(x))
real(my_real), allocatable :: legendre_d0(:,:), legendre_d1(:,:), &
                              legendre_d2(:,:), legendre_d3(:,:), &
                              legendre2_d0(:,:), legendre2_d1(:,:), &
                              legendre2_d2(:,:), c(:), lbasis(:,:)
real(my_real) :: Fr1r2(size(x)),dFdL1(size(x)),dFdL2(size(x)),dFdL3(size(x)), &
                 d2FdL(size(x),3,3)
integer :: i, j, nbasis, nedge, npoint, side, v1, v2, isub, astat1, astat2, &
           astat3, r, r1, r2, ik, k, p, nface, nedger, nedgeb, nfacer, nfaceb, &
           nvert

!----------------------------------------------------
! External routines:

interface
   double precision function dbinom(n,m)
   integer :: n,m
   end function dbinom
end interface

!----------------------------------------------------
! Begin executable code

if (present(basis)) basis=0.0_my_real
if (present(basisx)) basisx=0.0_my_real
if (present(basisy)) basisy=0.0_my_real
if (present(basisxx)) basisxx=0.0_my_real
if (present(basisyy)) basisyy=0.0_my_real
if (present(basisxy)) basisxy=0.0_my_real

! check that the size of the return arrays is big enough

npoint = size(x)
nedgeb = 0
nedger = 0
do i=1,3
   if (degree(i) > 1) then
      nedgeb = nedgeb + degree(i)-2
      nedger = nedger + 1
   endif
end do
if (degree(4) > 2) then
   nfaceb = ((degree(4)-2)*(degree(4)-3))/2
   nfacer = degree(4)-2
else
   nfaceb = 0
   nfacer = 0
endif

! always consider the vertex bases to be black, even with degree=1
select case(set)
case ("a")
   nvert = 3
   nedge = nedgeb + nedger
   nface = nfaceb + nfacer
case ("b")
   nvert = 3
   nedge = nedgeb
   nface = nfaceb
case ("r")
   nvert = 0
   nedge = nedger
   nface = nfacer
end select

nbasis = nvert + nedge + nface

if (present(basis)) then
   if (size(basis,1) < nbasis .or. size(basis,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basis array is too small in p_hier_basis_func.", &
                 intlist = (/size(basis,1),size(basis,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisx)) then
   if (size(basisx,1) < nbasis .or. size(basisx,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisx array is too small in p_hier_basis_func.", &
                 intlist = (/size(basisx,1),size(basisx,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisy)) then
   if (size(basisy,1) < nbasis .or. size(basisy,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisy array is too small in p_hier_basis_func.", &
                 intlist = (/size(basisy,1),size(basisy,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisxx)) then
   if (size(basisxx,1) < nbasis .or. size(basisxx,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisxx array is too small in p_hier_basis_func.", &
                 intlist = (/size(basisxx,1),size(basisxx,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisyy)) then
   if (size(basisyy,1) < nbasis .or. size(basisyy,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisyy array is too small in p_hier_basis_func.", &
                 intlist = (/size(basisyy,1),size(basisyy,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisxy)) then
   if (size(basisxy,1) < nbasis .or. size(basisxy,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisxy array is too small in p_hier_basis_func.", &
                 intlist = (/size(basisxy,1),size(basisxy,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basis)) then
   allocate(lbasis(size(basis,1),size(basis,2)),stat=astat1)
elseif (present(basisx)) then
   allocate(lbasis(size(basisx,1),size(basisx,2)),stat=astat1)
elseif (present(basisy)) then
   allocate(lbasis(size(basisy,1),size(basisy,2)),stat=astat1)
elseif (present(basisxx)) then
   allocate(lbasis(size(basisxx,1),size(basisxx,2)),stat=astat1)
elseif (present(basisyy)) then
   allocate(lbasis(size(basisyy,1),size(basisyy,2)),stat=astat1)
elseif (present(basisxy)) then
   allocate(lbasis(size(basisxy,1),size(basisxy,2)),stat=astat1)
else
   ierr = PHAML_INTERNAL_ERROR
   call fatal("no return argument requested in p_hier_basis_func_a")
   stop
endif
if (astat1 /= 0) then
   ierr = ALLOC_FAILED
   call fatal("memory allocation failed in p_hier_basis_func_a")
   stop
endif

! compute the barycentric coordinates of each point

call barycentric(x,y,xvert,yvert,zeta,dzdx,dzdy)

!-------------
! Vertex bases

! These are the usual linear bases

if (set == "a" .or. set == "b") then

   lbasis(1:3,:) = transpose(zeta)

   if (present(basisx)) then
      basisx(1,:) = dzdx(1)
      basisx(2,:) = dzdx(2)
      basisx(3,:) = dzdx(3)
   endif

   if (present(basisy)) then
      basisy(1,:) = dzdy(1)
      basisy(2,:) = dzdy(2)
      basisy(3,:) = dzdy(3)
   endif

   if (present(basisxx)) basisxx = 0.0_my_real
   if (present(basisyy)) basisyy = 0.0_my_real
   if (present(basisxy)) basisxy = 0.0_my_real

endif

!-----------
! Edge bases

if (maxval(degree) > 1) then

 select case (use_basis)

! the Szabo-Babuska basis

 case (SZABO)

   allocate(legendre_d1(size(x),maxval(degree)-1),c(maxval(degree)-1), &
            stat=astat1)
   if (present(basisx) .or. present(basisy) .or. present(basisxx) .or. &
       present(basisyy) .or. present(basisxy)) then
      allocate(legendre_d2(size(x),maxval(degree)-1),stat=astat2)
   else
      astat2 = 0
   endif
   if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
      allocate(legendre_d3(size(x),maxval(degree)-1),stat=astat3)
   else
      astat3 = 0
   endif
   if (astat1 /= 0 .or. astat2 /= 0 .or. astat3 /= 0) then
      ierr = ALLOC_FAILED
      call fatal("memory allocation failed in p_hier_basis_func_a")
      stop
   endif

   do i=1,maxval(degree)-1
      c(i) = -8*sqrt(4*i+2.0_my_real)/(i*(i+1))
   end do

! for each edge ...

   isub = nvert
   do side=1,3

      if (degree(side) > 1) then

! identify the endpoints of the edge

         if (side == 2) then
            v2 = mod(side  ,3)+1
            v1 = mod(side+1,3)+1
         else
            v1 = mod(side  ,3)+1
            v2 = mod(side+1,3)+1
         endif

! evaluate the derivatives of the Legendre polynomials

         if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
            call dlegendre(zeta(:,v2)-zeta(:,v1),degree(side)-1, &
                           deriv1=legendre_d1,deriv2=legendre_d2, &
                           deriv3=legendre_d3)
         elseif (present(basisx) .or. present(basisy)) then
            call dlegendre(zeta(:,v2)-zeta(:,v1),degree(side)-1, &
                           deriv1=legendre_d1,deriv2=legendre_d2)
         else
            call dlegendre(zeta(:,v2)-zeta(:,v1),degree(side)-1, &
                           deriv1=legendre_d1)
         endif

         zetav1v2 = zeta(:,v1)*zeta(:,v2)
         dzdxzeta12 = dzdx(v1)*zeta(:,v2)+dzdx(v2)*zeta(:,v1)
         dzdyzeta12 = dzdy(v1)*zeta(:,v2)+dzdy(v2)*zeta(:,v1)

! compute the basis functions and derivatives as requested

         if (set == "a" .or. set == "b") then
            if (present(basis)) then
               do i=1,degree(side)-2
                  lbasis(isub+i,:) = c(i)*zetav1v2*legendre_d1(:,i)
               end do
            endif

            if (present(basisx)) then
               do i=1,degree(side)-2
                  basisx(isub+i,:) = c(i) * ( dzdxzeta12*legendre_d1(:,i) + &
                  zetav1v2*legendre_d2(:,i)*(dzdx(v2)-dzdx(v1)) )
               end do
            endif

            if (present(basisy)) then
               do i=1,degree(side)-2
                  basisy(isub+i,:) = c(i) * ( dzdyzeta12*legendre_d1(:,i) + &
                  zetav1v2*legendre_d2(:,i)*(dzdy(v2)-dzdy(v1)) )
               end do
            endif

            if (present(basisxx)) then
               do i=1,degree(side)-2
                  basisxx(isub+i,:) = c(i) * ( &
                          2*dzdx(v1)*dzdx(v2)*legendre_d1(:,i) + &
                          2*dzdxzeta12*legendre_d2(:,i)*(dzdx(v2)-dzdx(v1)) + &
                          zetav1v2*legendre_d3(:,i)*(dzdx(v2)-dzdx(v1))**2 )
               end do
            endif

            if (present(basisyy)) then
               do i=1,degree(side)-2
                  basisyy(isub+i,:) = c(i) * ( &
                          2*dzdy(v1)*dzdy(v2)*legendre_d1(:,i) + &
                          2*dzdyzeta12*legendre_d2(:,i)*(dzdy(v2)-dzdy(v1)) + &
                          zetav1v2*legendre_d3(:,i)*(dzdy(v2)-dzdy(v1))**2 )
               end do
            endif

            if (present(basisxy)) then
               do i=1,degree(side)-2
                  basisxy(isub+i,:) = c(i) * ( &
                          (dzdx(v1)*dzdy(v2)+dzdy(v1)*dzdx(v2))*legendre_d1(:,i) + &
                          (dzdxzeta12*(dzdy(v2)-dzdy(v1)) + dzdyzeta12*(dzdx(v2)-dzdx(v1)))*legendre_d2(:,i) + &
                          zetav1v2*legendre_d3(:,i)*(dzdx(v2)-dzdx(v1))*(dzdy(v2)-dzdy(v1)))
               end do
            endif

            isub = isub + degree(side)-2
         endif

         if (set == "a" .or. set == "r") then
            i=degree(side)-1
            if (present(basis)) then
               lbasis(isub+1,:) = zetav1v2*legendre_d1(:,i)*c(i)
            endif
            if (present(basisx)) then
               basisx(isub+1,:) = c(i) * ( dzdxzeta12*legendre_d1(:,i) + &
                  zetav1v2*legendre_d2(:,i)*(dzdx(v2)-dzdx(v1)) )
            endif
            if (present(basisy)) then
               basisy(isub+1,:) = c(i) * ( dzdyzeta12*legendre_d1(:,i) + &
                  zetav1v2*legendre_d2(:,i)*(dzdy(v2)-dzdy(v1)) )
            endif
            if (present(basisxx)) then
               basisxx(isub+1,:) = c(i) * ( &
                       2*dzdx(v1)*dzdx(v2)*legendre_d1(:,i) + &
                       2*dzdxzeta12*legendre_d2(:,i)*(dzdx(v2)-dzdx(v1)) + &
                       zetav1v2*legendre_d3(:,i)*(dzdx(v2)-dzdx(v1))**2 )
            endif
            if (present(basisyy)) then
               basisyy(isub+1,:) = c(i) * ( &
                       2*dzdy(v1)*dzdy(v2)*legendre_d1(:,i) + &
                       2*dzdyzeta12*legendre_d2(:,i)*(dzdy(v2)-dzdy(v1)) + &
                       zetav1v2*legendre_d3(:,i)*(dzdy(v2)-dzdy(v1))**2 )
            endif
            if (present(basisxy)) then
               basisxy(isub+1,:) = c(i) * ( &
                       (dzdx(v1)*dzdy(v2)+dzdy(v1)*dzdx(v2))*legendre_d1(:,i) + &
                       (dzdxzeta12*(dzdy(v2)-dzdy(v1)) + dzdyzeta12*(dzdx(v2)-dzdx(v1)))*legendre_d2(:,i) + &
                       zetav1v2*legendre_d3(:,i)*(dzdx(v2)-dzdx(v1))*(dzdy(v2)-dzdy(v1)))
            endif

            isub = isub + 1
         endif
      endif
   end do

   if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
      deallocate(legendre_d3)
   endif
   if (present(basisx) .or. present(basisy) .or. present(basisxx) .or. &
       present(basisyy) .or. present(basisxy)) then
      deallocate(legendre_d2)
   endif
   deallocate(legendre_d1,c)

! the Carnevali basis

 case (CARNEVALI)

   if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Second derivatives for Carnevali basis not yet written.")
      stop
   endif

! for each edge ...

   isub = nvert
   do side=1,3

      if (degree(side) > 1) then

! identify the endpoints of the edge

         if (side == 2) then
            v2 = mod(side  ,3)+1
            v1 = mod(side+1,3)+1
         else
            v1 = mod(side  ,3)+1
            v2 = mod(side+1,3)+1
         endif

! compute the basis functions and derivatives as requested

         if (set == "a" .or. set == "b") then
            do i=1,degree(side)-2
               lbasis(isub+i,:) = 0.0_my_real
               if (present(basisx)) then
                  basisx(isub+i,:) = 0.0_my_real
               endif
               if (present(basisy)) then
                  basisy(isub+i,:) = 0.0_my_real
               endif
               do k=0,i-1
                  const = (-1)**k * dbinom(i-1,k) * dbinom(i,k) / (k+1)

                     lbasis(isub+i,:) = lbasis(isub+i,:) + &
                                    const * zeta(:,v1)**k * zeta(:,v2)**(i-1-k)

                  if (present(basisx)) then
                     if (k /= 0) then
                        basisx(isub+i,:) = basisx(isub+i,:) + const * &
                             k*dzdx(v1)*zeta(:,v1)**(k-1)*zeta(:,v2)**(i-1-k)
                     endif
                     if (k /= i-1) then
                        basisx(isub+i,:) = basisx(isub+i,:) + const * &
                             (i-1-k)*dzdx(v2)*zeta(:,v2)**(i-k-2)*zeta(:,v1)**k
                     endif
                  endif

                  if (present(basisy)) then
                     if (k /= 0) then
                        basisy(isub+i,:) = basisy(isub+i,:) + const * &
                             k*dzdy(v1)*zeta(:,v1)**(k-1)*zeta(:,v2)**(i-1-k)
                     endif
                     if (k /= i-1) then
                        basisy(isub+i,:) = basisy(isub+i,:) + const * &
                             (i-1-k)*dzdy(v2)*zeta(:,v2)**(i-k-2)*zeta(:,v1)**k
                     endif
                  endif
               end do
               if (present(basisx)) then
                  basisx(isub+i,:) = dzdx(v1)*zeta(:,v2)*lbasis(isub+i,:) + &
                                     dzdx(v2)*zeta(:,v1)*lbasis(isub+i,:) + &
                                     zeta(:,v1)*zeta(:,v2)*basisx(isub+i,:)
               endif
               if (present(basisy)) then
                  basisy(isub+i,:) = dzdy(v1)*zeta(:,v2)*lbasis(isub+i,:) + &
                                     dzdy(v2)*zeta(:,v1)*lbasis(isub+i,:) + &
                                     zeta(:,v1)*zeta(:,v2)*basisy(isub+i,:)
               endif
               lbasis(isub+i,:) = lbasis(isub+i,:)*zeta(:,v1)*zeta(:,v2)
            end do
            isub = isub + degree(side)-2
         endif

         if (set == "a" .or. set == "r") then
            i=degree(side)-1
            lbasis(isub+1,:) = 0.0_my_real
            if (present(basisx)) then
               basisx(isub+1,:) = 0.0_my_real
            endif
            if (present(basisy)) then
               basisy(isub+1,:) = 0.0_my_real
            endif
            do k=0,i-1
               const = (-1)**k * dbinom(i-1,k) * dbinom(i,k) / (k+1)
               lbasis(isub+1,:) = lbasis(isub+1,:) + &
                                    const * zeta(:,v1)**k * zeta(:,v2)**(i-1-k)
               if (present(basisx)) then
                  if (k /= 0) then
                     basisx(isub+1,:) = basisx(isub+1,:) + const * &
                          k*dzdx(v1)*zeta(:,v1)**(k-1)*zeta(:,v2)**(i-1-k)
                  endif
                  if (k /= i-1) then
                     basisx(isub+1,:) = basisx(isub+1,:) + const * &
                          (i-1-k)*dzdx(v2)*zeta(:,v2)**(i-k-2)*zeta(:,v1)**k
                  endif
               endif
               if (present(basisy)) then
                  if (k /= 0) then
                     basisy(isub+1,:) = basisy(isub+1,:) + const * &
                          k*dzdy(v1)*zeta(:,v1)**(k-1)*zeta(:,v2)**(i-1-k)
                  endif
                  if (k /= i-1) then
                     basisy(isub+1,:) = basisy(isub+1,:) + const * &
                          (i-1-k)*dzdy(v2)*zeta(:,v2)**(i-k-2)*zeta(:,v1)**k
                  endif
               endif
            end do
            if (present(basisx)) then
               basisx(isub+1,:) = dzdx(v1)*zeta(:,v2)*lbasis(isub+1,:) + &
                                  dzdx(v2)*zeta(:,v1)*lbasis(isub+1,:) + &
                                  zeta(:,v1)*zeta(:,v2)*basisx(isub+1,:)
            endif
            if (present(basisy)) then
               basisy(isub+1,:) = dzdy(v1)*zeta(:,v2)*lbasis(isub+1,:) + &
                                  dzdy(v2)*zeta(:,v1)*lbasis(isub+1,:) + &
                                  zeta(:,v1)*zeta(:,v2)*basisy(isub+1,:)
            endif
            lbasis(isub+1,:) = lbasis(isub+1,:)*zeta(:,v1)*zeta(:,v2)
            isub = isub + 1
         endif
      endif
   end do
 end select
endif

!-----------
! Face bases

! no face functions for linear and quadratic bases

if (degree(4) > 2) then

! evaluate the derivatives of the Legendre polynomials

if (use_basis == SZABO) then
   allocate(legendre_d0(size(x),degree(4)-3),legendre2_d0(size(x),degree(4)-3),&
            stat=astat1)
   if (present(basisx) .or. present(basisy) .or. present(basisxx) .or. &
       present(basisyy) .or. present(basisxy)) then
      allocate(legendre_d1(size(x),degree(4)-3), &
               legendre2_d1(size(x),degree(4)-3),stat=astat2)
   else
      astat2 = 0
   endif
   if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
      allocate(legendre_d2(size(x),degree(4)-3), &
               legendre2_d2(size(x),degree(4)-3),stat=astat3)
   else
      astat3 = 0
   endif
   if (astat1 /= 0 .or. astat2 /= 0 .or. astat3 /= 0) then
      ierr = ALLOC_FAILED
      call fatal("memory allocation failed in p_hier_basis_func_a")
      stop
   endif
   if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
      call dlegendre(zeta(:,2)-zeta(:,1),degree(4)-3,deriv0=legendre_d0, &
                     deriv1=legendre_d1,deriv2=legendre_d2)
      call dlegendre(2*zeta(:,3)-1,degree(4)-3,deriv0=legendre2_d0, &
                     deriv1=legendre2_d1,deriv2=legendre2_d2)
   elseif (present(basisx) .or. present(basisy)) then
      call dlegendre(zeta(:,2)-zeta(:,1),degree(4)-3,deriv0=legendre_d0, &
                     deriv1=legendre_d1)
      call dlegendre(2*zeta(:,3)-1,degree(4)-3,deriv0=legendre2_d0, &
                     deriv1=legendre2_d1)
   else
      call dlegendre(zeta(:,2)-zeta(:,1),degree(4)-3,deriv0=legendre_d0)
      call dlegendre(2*zeta(:,3)-1,degree(4)-3,deriv0=legendre2_d0)
   endif
endif

! common products

zetaprod = zeta(:,1)*zeta(:,2)*zeta(:,3)
forbasisx = dzdx(1)*zeta(:,2)*zeta(:,3) + dzdx(2)*zeta(:,1)*zeta(:,3) + &
            dzdx(3)*zeta(:,1)*zeta(:,2)
forbasisy = dzdy(1)*zeta(:,2)*zeta(:,3) + dzdy(2)*zeta(:,1)*zeta(:,3) + &
            dzdy(3)*zeta(:,1)*zeta(:,2)
forbasisxx = 2*(dzdx(1)*dzdx(2)*zeta(:,3) + &
                dzdx(1)*zeta(:,2)*dzdx(3) + &
                zeta(:,1)*dzdx(2)*dzdx(3))
forbasisyy = 2*(dzdy(1)*dzdy(2)*zeta(:,3) + &
                dzdy(1)*zeta(:,2)*dzdy(3) + &
                zeta(:,1)*dzdy(2)*dzdy(3))
forbasisxy = dzdx(1)*dzdy(2)*zeta(:,3) + dzdx(1)*zeta(:,2)*dzdy(3) + &
             dzdy(1)*dzdx(2)*zeta(:,3) + zeta(:,1)*dzdx(2)*dzdy(3) + &
             dzdy(1)*zeta(:,2)*dzdx(3) + zeta(:,1)*dzdy(2)*dzdx(3)

! evaluate the face bases and derivatives

do k=3,degree(4)
   ik = ((k-3)*(k-2))/2
   if (set == "r") ik = 0
   r = nedge + nvert
   do r1 = 0,k-3
      r2 = k-3-r1
      r = r+1

      select case (use_basis)

      case (SZABO)
         if (r1==0 .and. r2==0) then
            Fr1r2 = 1
         elseif (r1==0) then
            Fr1r2 = legendre2_d0(:,r2)
         elseif (r2==0) then
            Fr1r2 = legendre_d0(:,r1)
         else
            Fr1r2 = legendre_d0(:,r1)*legendre2_d0(:,r2)
         endif
         if (present(basisx) .or. present(basisy) .or. present(basisxx) .or. &
             present(basisyy) .or. present(basisxy)) then
            if (r1==0 .and. r2==0) then
               dFdL1 = 0.0_my_real
               dFdL2 = 0.0_my_real
               dFdL3 = 0.0_my_real
            elseif (r1==0) then
               dFdL1 = 0.0_my_real
               dFdL2 = 0.0_my_real
               dFdL3 = 2*legendre2_d1(:,r2)
            elseif (r2==0) then
               dFdL1 = -legendre_d1(:,r1)
               dFdL2 =  legendre_d1(:,r1)
               dFdL3 = 0.0_my_real
            else
               dFdL1 = -legendre_d1(:,r1)*legendre2_d0(:,r2)
               dFdL2 = -dFdL1
               dFdL3 = 2*legendre_d0(:,r1)*legendre2_d1(:,r2)
            endif
         endif
         if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
            if (r1==0 .and. r2==0) then
               d2FdL = 0.0_my_real
            elseif (r1==0) then
               d2FdL = 0.0_my_real
               d2FdL(:,3,3) = 4*legendre2_d2(:,r2)
            elseif (r2==0) then
               d2FdL = 0.0_my_real
               d2FdL(:,1,1) = legendre_d2(:,r1)
               d2FdL(:,2,2) = d2FdL(:,1,1)
               d2FdL(:,1,2) = -d2FdL(:,1,1)
               d2FdL(:,2,1) = d2FdL(:,1,2)
            else
               d2FdL(:,1,1) = legendre_d2(:,r1)*legendre2_d0(:,r2)
               d2FdL(:,1,2) = -d2FdL(:,1,1)
               d2FdL(:,2,1) = d2FdL(:,1,2)
               d2FdL(:,2,2) = d2FdL(:,1,1)
               d2FdL(:,1,3) = -2*legendre_d1(:,r1)*legendre2_d1(:,r2)
               d2FdL(:,3,1) = d2FdL(:,1,3)
               d2FdL(:,2,3) = -d2FdL(:,1,3)
               d2FdL(:,3,2) = d2FdL(:,2,3)
               d2FdL(:,3,3) = 4*legendre_d0(:,r1)*legendre2_d2(:,r2)
            endif
         endif

      case (CARNEVALI)
         Fr1r2 = 0.0_my_real
         dFdL1 = 0.0_my_real
         dFdL2 = 0.0_my_real
         dFdL3 = 0.0_my_real
         do i=0,r2
            do j=0,r1
               const = 1.0_my_real
               do p=1,i+j
                  const = const * (p*(r1+r2+2) - (p*(p-1))/2)
               end do
               const = (-0.5_my_real)**(i+j) * dbinom(r1,j) * dbinom(r1+1,j) * &
                       dbinom(r2,i) * dbinom(r2+1,i) * factorial(i) * &
                       factorial(j) * factorial(i+j) / const

               Fr1r2 = Fr1r2 + const * zeta(:,1)**(r1-j) * zeta(:,2)**(r2-i)
               if (present(basisx) .or. present(basisy)) then
                  if (j /= r1) then
                     dFdL1 = dFdL1 + const * &
                                  (r1-j)*zeta(:,1)**(r1-j-1) * zeta(:,2)**(r2-i)
                  endif
                  if (i /= r2) then
                     dFdL2 = dFdL2 + const * &
                                  zeta(:,1)**(r1-j) * (r2-i)*zeta(:,2)**(r2-i-1)
                  endif
               endif
            end do
         end do
      end select

      if (set == "a" .or. (set == "b" .and. k < degree(4)) .or. &
          (set == "r" .and. k == degree(4))) then
         if (present(basis)) then
            lbasis(ik+r,:) = zetaprod*Fr1r2
         endif
         if (present(basisx)) then
            basisx(ik+r,:) = Fr1r2*forbasisx + &
                            zetaprod*(dFdL1*dzdx(1)+dFdL2*dzdx(2)+dFdL3*dzdx(3))
         endif
         if (present(basisy)) then
            basisy(ik+r,:) = Fr1r2*forbasisy + &
                            zetaprod*(dFdL1*dzdy(1)+dFdL2*dzdy(2)+dFdL3*dzdy(3))
         endif
         if (present(basisxx)) then
            basisxx(ik+r,:) = forbasisxx*Fr1r2 + &
                        2*forbasisx*(dFdL1*dzdx(1)+dFdL2*dzdx(2)+dFdL3*dzdx(3))
            do i=1,size(x)
               basisxx(ik+r,i) = basisxx(ik+r,i) + &
                         zetaprod(i)*dot_product(dzdx,matmul(d2FdL(i,:,:),dzdx))
            end do
         endif
         if (present(basisyy)) then
            basisyy(ik+r,:) = forbasisyy*Fr1r2 + &
                        2*forbasisy*(dFdL1*dzdy(1)+dFdL2*dzdy(2)+dFdL3*dzdy(3))
            do i=1,size(x)
               basisyy(ik+r,i) = basisyy(ik+r,i) + &
                         zetaprod(i)*dot_product(dzdy,matmul(d2FdL(i,:,:),dzdy))
            end do
         endif
         if (present(basisxy)) then
            basisxy(ik+r,:) = forbasisxy*Fr1r2 + &
                       forbasisx*(dFdL1*dzdy(1)+dFdL2*dzdy(2)+dFdL3*dzdy(3)) + &
                       forbasisy*(dFdL1*dzdx(1)+dFdL2*dzdx(2)+dFdL3*dzdx(3))
            do i=1,size(x)
               basisxy(ik+r,i) = basisxy(ik+r,i) + &
                         zetaprod(i)*dot_product(dzdx,matmul(d2FdL(i,:,:),dzdy))
            end do
         endif
      endif
   end do
end do

if (use_basis == SZABO) then
   deallocate(legendre_d0,legendre2_d0)
   if (present(basisx) .or. present(basisy) .or. present(basisxx) .or. &
       present(basisyy) .or. present(basisxy)) then
      deallocate(legendre_d1,legendre2_d1)
   endif
   if (present(basisxx) .or. present(basisyy) .or. present(basisxy)) then
      deallocate(legendre_d2,legendre2_d2)
   endif
endif

endif ! degree(4) > 2

if (present(basis)) basis = lbasis
deallocate(lbasis)

end subroutine p_hier_basis_func_a

!          -------------------
subroutine p_hier_basis_func_s(x,y,xvert,yvert,degree,set,basis,basisx,basisy,&
                               basisxx,basisyy,basisxy)
!          -------------------

!----------------------------------------------------
! This routine is a version of p_hier_basis_func for a single point.  It turns
! it into an array of size 1 and calls the version for an array of points.
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x, y, xvert(3), yvert(3)
integer, intent(in) :: degree(4)
character(len=1), intent(in) :: set
real(my_real), intent(out), optional :: basis(:), basisx(:), basisy(:), &
                                        basisxx(:), basisyy(:), basisxy(:)
!----------------------------------------------------
! Local variables:

real(my_real) :: x_a(1), y_a(1)
real(my_real), allocatable :: basis_a(:,:), basisx_a(:,:), basisy_a(:,:), &
                              basisxx_a(:,:), basisyy_a(:,:), basisxy_a(:,:)
integer :: code, astat1, astat2, astat3
!----------------------------------------------------
! Begin executable code

x_a = x
y_a = y

code = 0
astat1 = 0
astat2 = 0
astat3 = 0

if (present(basis)) then
   allocate(basis_a(size(basis),1),stat=astat1)
   code = code + 1
endif

if (present(basisx) .and. astat1 == 0) then
   allocate(basisx_a(size(basisx),1),stat=astat2)
   code = code + 2
endif

if (present(basisy) .and. astat1 == 0 .and. astat2 == 0) then
   allocate(basisy_a(size(basisy),1),stat=astat3)
   code = code + 4
endif

if (astat1 /= 0 .or. astat2 /= 0 .or. astat3 /= 0) then
   ierr = ALLOC_FAILED
   call fatal("memory allocation failed in p_hier_basis_func_s")
   stop
endif

if (present(basisxx)) then
   allocate(basisxx_a(size(basisxx),1),stat=astat1)
   code = code + 8
endif

if (present(basisyy) .and. astat1 == 0) then
   allocate(basisyy_a(size(basisyy),1),stat=astat2)
   code = code + 16
endif

if (present(basisxy) .and. astat1 == 0 .and. astat2 == 0) then
   allocate(basisxy_a(size(basisxy),1),stat=astat3)
   code = code + 32
endif

if (astat1 /= 0 .or. astat2 /= 0 .or. astat3 /= 0) then
   ierr = ALLOC_FAILED
   call fatal("memory allocation failed in p_hier_basis_func_s")
   stop
endif

select case (code)
case(0)
case(1)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a)
case(2)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a)
case(3)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a)
case(4)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a)
case(5)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a)
case(6)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a)
case(7)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a)
case(8)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisxx=basisxx_a)
case(9)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisxx=basisxx_a)
case(10)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisxx=basisxx_a)
case(11)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisxx=basisxx_a)
case(12)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisxx=basisxx_a)
case(13)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisxx=basisxx_a)
case(14)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisxx=basisxx_a)
case(15)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisxx=basisxx_a)
case(16)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisyy=basisyy_a)
case(17)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisyy=basisyy_a)
case(18)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisyy=basisyy_a)
case(19)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisyy=basisyy_a)
case(20)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisyy=basisyy_a)
case(21)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisyy=basisyy_a)
case(22)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisyy=basisyy_a)
case(23)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisyy=basisyy_a)
case(24)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisxx=basisxx_a, &
                            basisyy=basisyy_a)
case(25)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisxx=basisxx_a,basisyy=basisyy_a)
case(26)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisxx=basisxx_a,basisyy=basisyy_a)
case(27)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisxx=basisxx_a,basisyy=basisyy_a)
case(28)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisxx=basisxx_a,basisyy=basisyy_a)
case(29)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisxx=basisxx_a,basisyy=basisyy_a)
case(30)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisxx=basisxx_a,basisyy=basisyy_a)
case(31)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisxx=basisxx_a, &
                            basisyy=basisyy_a)
case(32)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisxy=basisxy_a)
case(33)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisxy=basisxy_a)
case(34)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisxy=basisxy_a)
case(35)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisxy=basisxy_a)
case(36)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisxy=basisxy_a)
case(37)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisxy=basisxy_a)
case(38)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisxy=basisxy_a)
case(39)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisxy=basisxy_a)
case(40)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisxx=basisxx_a, &
                            basisxy=basisxy_a)
case(41)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisxx=basisxx_a,basisxy=basisxy_a)
case(42)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisxx=basisxx_a,basisxy=basisxy_a)
case(43)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisxx=basisxx_a,basisxy=basisxy_a)
case(44)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisxx=basisxx_a,basisxy=basisxy_a)
case(45)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisxx=basisxx_a,basisxy=basisxy_a)
case(46)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisxx=basisxx_a,basisxy=basisxy_a)
case(47)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisxx=basisxx_a, &
                            basisxy=basisxy_a)
case(48)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisyy=basisyy_a, &
                            basisxy=basisxy_a)
case(49)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(50)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(51)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisyy=basisyy_a,basisxy=basisxy_a)
case(52)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(53)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisyy=basisyy_a,basisxy=basisxy_a)
case(54)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisyy=basisyy_a,basisxy=basisxy_a)
case(55)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisyy=basisyy_a, &
                            basisxy=basisxy_a)
case(56)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisxx=basisxx_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(57)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisxx=basisxx_a,basisyy=basisyy_a, &
                            basisxy=basisxy_a)
case(58)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisxx=basisxx_a,basisyy=basisyy_a, &
                            basisxy=basisxy_a)
case(59)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisxx=basisxx_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(60)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a, &
                            basisxx=basisxx_a,basisyy=basisyy_a, &
                            basisxy=basisxy_a)
case(61)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisy=basisy_a,basisxx=basisxx_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(62)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a, &
                            basisy=basisy_a,basisxx=basisxx_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
case(63)
   call p_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis=basis_a, &
                            basisx=basisx_a,basisy=basisy_a,basisxx=basisxx_a, &
                            basisyy=basisyy_a,basisxy=basisxy_a)
end select

if (present(basis) ) basis  = basis_a(:,1)
if (present(basisx)) basisx = basisx_a(:,1)
if (present(basisy)) basisy = basisy_a(:,1)
if (present(basisxx)) basisxx = basisxx_a(:,1)
if (present(basisyy)) basisyy = basisyy_a(:,1)
if (present(basisxy)) basisxy = basisxy_a(:,1)

end subroutine p_hier_basis_func_s

!          -----------
subroutine barycentric(x,y,xvert,yvert,zeta,dzdx,dzdy)
!          -----------

!----------------------------------------------------
! This subroutine returns the barycentric coordinates of each (x,y) and
! their derivatives.
! RESTRICTION triangles
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x(:),y(:),xvert(:),yvert(:)
real(my_real), intent(out) :: zeta(:,:),dzdx(:),dzdy(:)

!----------------------------------------------------
! Local variables:

real(quad_real) :: x1,x2,x3,y1,y2,y3,det,ssump,ssumm
real(quad_real), dimension(size(x)) :: xy1,xy2,xy3,yx1,yx2,yx3,sump,summ
real(quad_real) :: x1y2,x2y3,x3y1,x1y3,x2y1,x3y2

!----------------------------------------------------
! Begin executable code

! Do a faster, less careful barycentric if not using quad precision

if (quad_real == my_real) then
   call fast_barycentric(x,y,xvert,yvert,zeta,dzdx,dzdy)
   return
endif

! put the vertices in local variables to shorten expressions

x1 = real(xvert(1),quad_real)
x2 = real(xvert(2),quad_real)
x3 = real(xvert(3),quad_real)
y1 = real(yvert(1),quad_real)
y2 = real(yvert(2),quad_real)
y3 = real(yvert(3),quad_real)

! compute the barycentric coordinates of the point

! reduce roundoff by summing all the positive parts and negative parts
! separately, and then adding the two partial sums

! products needed for the sums

xy1 = real(x,quad_real)*y1
xy2 = real(x,quad_real)*y2
xy3 = real(x,quad_real)*y3
yx1 = real(y,quad_real)*x1
yx2 = real(y,quad_real)*x2
yx3 = real(y,quad_real)*x3
x1y2 = x1*y2
x2y3 = x2*y3
x3y1 = x3*y1
x1y3 = x1*y3
x2y1 = x2*y1
x3y2 = x3*y2

! compute the determinant

! det = x1*(y2-y3)+x2*(y3-y1)+x3*(y1-y2)

ssump=0.0_quad_real; ssumm=0.0_quad_real
if (x1y2 > 0.0_quad_real) then; ssump=ssump+x1y2; else; ssumm=ssumm+x1y2; endif
if (x1y3 < 0.0_quad_real) then; ssump=ssump-x1y3; else; ssumm=ssumm-x1y3; endif
if (x2y3 > 0.0_quad_real) then; ssump=ssump+x2y3; else; ssumm=ssumm+x2y3; endif
if (x2y1 < 0.0_quad_real) then; ssump=ssump-x2y1; else; ssumm=ssumm-x2y1; endif
if (x3y1 > 0.0_quad_real) then; ssump=ssump+x3y1; else; ssumm=ssumm+x3y1; endif
if (x3y2 < 0.0_quad_real) then; ssump=ssump-x3y2; else; ssumm=ssumm-x3y2; endif
det = ssump + ssumm

! compute the coordinates

! zeta(1) = (x*(y2-y3) + y*(x3-x2) + (x2*y3-x3*y2))/det

sump=0.0_quad_real; summ=0.0_quad_real
where (xy2 > 0.0_quad_real)
   sump=sump+xy2
elsewhere
   summ=summ+xy2
endwhere
where (xy3 < 0.0_quad_real)
   sump=sump-xy3
elsewhere
   summ=summ-xy3
endwhere
where (yx3 > 0.0_quad_real)
   sump=sump+yx3
elsewhere
   summ=summ+yx3
endwhere
where (yx2 < 0.0_quad_real)
   sump=sump-yx2
elsewhere
   summ=summ-yx2
endwhere
if (x2y3 > 0.0_quad_real) then; sump=sump+x2y3; else; summ=summ+x2y3; endif
if (x3y2 < 0.0_quad_real) then; sump=sump-x3y2; else; summ=summ-x3y2; endif
zeta(:,1) = sump/det + summ/det

! zeta(2) = (x*(y3-y1) + y*(x1-x3) + (x3*y1-x1*y3))/det

sump=0.0_quad_real; summ=0.0_quad_real
where (xy3 > 0.0_quad_real)
   sump=sump+xy3
elsewhere
   summ=summ+xy3
endwhere
where (xy1 < 0.0_quad_real)
   sump=sump-xy1
elsewhere
   summ=summ-xy1
endwhere
where (yx1 > 0.0_quad_real)
   sump=sump+yx1
elsewhere
   summ=summ+yx1
endwhere
where (yx3 < 0.0_quad_real)
   sump=sump-yx3
elsewhere
   summ=summ-yx3
endwhere
if (x3y1 > 0.0_quad_real) then; sump=sump+x3y1; else; summ=summ+x3y1; endif
if (x1y3 < 0.0_quad_real) then; sump=sump-x1y3; else; summ=summ-x1y3; endif
zeta(:,2) = sump/det + summ/det

! zeta(3) = (x*(y1-y2) + y*(x2-x1) + (x1*y2-x2*y1))/det

sump=0.0_quad_real; summ=0.0_quad_real
where (xy1 > 0.0_quad_real)
   sump=sump+xy1
elsewhere
   summ=summ+xy1
endwhere
where (xy2 < 0.0_quad_real)
   sump=sump-xy2
elsewhere
   summ=summ-xy2
endwhere
where (yx2 > 0.0_quad_real)
   sump=sump+yx2
elsewhere
   summ=summ+yx2
endwhere
where (yx1 < 0.0_quad_real)
   sump=sump-yx1
elsewhere
   summ=summ-yx1
endwhere
if (x1y2 > 0.0_quad_real) then; sump=sump+x1y2; else; summ=summ+x1y2; endif
if (x2y1 < 0.0_quad_real) then; sump=sump-x2y1; else; summ=summ-x2y1; endif
zeta(:,3) = sump/det + summ/det

! derivatives

dzdx(1) = (y2-y3)/det
dzdx(2) = (y3-y1)/det
dzdx(3) = (y1-y2)/det
dzdy(1) = (x3-x2)/det
dzdy(2) = (x1-x3)/det
dzdy(3) = (x2-x1)/det

end subroutine barycentric

!          ----------------
subroutine fast_barycentric(x,y,xvert,yvert,zeta,dzdx,dzdy)
!          ----------------

!----------------------------------------------------
! This subroutine returns the barycentric coordinates of each (x,y) and
! their derivatives, without using quad precision or being careful about
! the order in which numbers are added.
! RESTRICTION triangles
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x(:),y(:),xvert(:),yvert(:)
real(my_real), intent(out) :: zeta(:,:),dzdx(:),dzdy(:)

!----------------------------------------------------
! Local variables:

real(quad_real) :: x1,x2,x3,y1,y2,y3,det,ssump,ssumm
real(quad_real), dimension(size(x)) :: xy1,xy2,xy3,yx1,yx2,yx3,sump,summ
real(quad_real) :: x1y2,x2y3,x3y1,x1y3,x2y1,x3y2

!----------------------------------------------------
! Begin executable code

! put the vertices in local variables to shorten expressions

x1 = xvert(1)
x2 = xvert(2)
x3 = xvert(3)
y1 = yvert(1)
y2 = yvert(2)
y3 = yvert(3)

! compute the barycentric coordinates of the point

! products needed for the sums

xy1 = x*y1
xy2 = x*y2
xy3 = x*y3
yx1 = y*x1
yx2 = y*x2
yx3 = y*x3
x1y2 = x1*y2
x2y3 = x2*y3
x3y1 = x3*y1
x1y3 = x1*y3
x2y1 = x2*y1
x3y2 = x3*y2

! compute the determinant

det = x1*(y2-y3)+x2*(y3-y1)+x3*(y1-y2)

! compute the coordinates

zeta(:,1) = (x*(y2-y3) + y*(x3-x2) + (x2*y3-x3*y2))/det
zeta(:,2) = (x*(y3-y1) + y*(x1-x3) + (x3*y1-x1*y3))/det
zeta(:,3) = (x*(y1-y2) + y*(x2-x1) + (x1*y2-x2*y1))/det

! derivatives

dzdx(1) = (y2-y3)/det
dzdx(2) = (y3-y1)/det
dzdx(3) = (y1-y2)/det
dzdy(1) = (x3-x2)/det
dzdy(2) = (x1-x3)/det
dzdy(3) = (x2-x1)/det

end subroutine fast_barycentric

!          ---------
subroutine dlegendre(x,degree,deriv0,deriv1,deriv2,deriv3)
!          ---------

!----------------------------------------------------
! This routine optionally returns the Legendre polynomials and first and
! second and third derivatives from degree 1 to degree.
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x(:)
integer, intent(in) :: degree
real(my_real), intent(out), optional :: deriv0(size(x),degree), &
                            deriv1(size(x),degree), deriv2(size(x),degree), &
                            deriv3(size(x),degree)
!----------------------------------------------------
! Local variables:

real(my_real) :: legendre(size(x),0:degree)
real(my_real) :: c1,c2
integer :: d
!----------------------------------------------------
! Begin executable code

if (degree == 0) return

legendre(:,0) = 1
legendre(:,1) = x
if (present(deriv1)) deriv1(:,1) = 1
if (present(deriv2)) deriv2(:,1) = 0
if (present(deriv3)) deriv3(:,1) = 0
if (degree > 1) then
   legendre(:,2) = (3*x*x-1)/2
   if (present(deriv1)) deriv1(:,2) = 3*x
   if (present(deriv2)) deriv2(:,2) = 3
   if (present(deriv3)) deriv3(:,2) = 0
endif

do d=3,degree
   c1 = (2*(d-1.0_my_real)+1)/d
   c2 = (d-1.0_my_real)/d
   legendre(:,d) = c1*x*legendre(:,d-1)
   if (my_real == kind(0.0)) then
      call saxpy(size(x),-c2,legendre(1,d-2),1,legendre(1,d),1)
      if (present(deriv1)) then
         deriv1(:,d) = c1*x*deriv1(:,d-1)
         call saxpy(size(x),c1,legendre(1,d-1),1,deriv1(1,d),1)
         call saxpy(size(x),-c2,deriv1(1,d-2),1,deriv1(1,d),1)
      endif
      if (present(deriv2)) then
         deriv2(:,d) = c1*x*deriv2(:,d-1)
         call saxpy(size(x),2*c1,deriv1(1,d-1),1,deriv2(1,d),1)
         call saxpy(size(x),-c2,deriv2(1,d-2),1,deriv2(1,d),1)
      endif
      if (present(deriv3)) then
         deriv3(:,d) = c1*x*deriv3(:,d-1)
         call saxpy(size(x),3*c1,deriv2(1,d-1),1,deriv3(1,d),1)
         call saxpy(size(x),-c2,deriv3(1,d-2),1,deriv3(1,d),1)
      endif
   elseif (my_real == kind(0.0d0)) then
      call daxpy(size(x),-c2,legendre(1,d-2),1,legendre(1,d),1)
      if (present(deriv1)) then
         deriv1(:,d) = c1*x*deriv1(:,d-1)
         call daxpy(size(x),c1,legendre(1,d-1),1,deriv1(1,d),1)
         call daxpy(size(x),-c2,deriv1(1,d-2),1,deriv1(1,d),1)
      endif
      if (present(deriv2)) then
         deriv2(:,d) = c1*x*deriv2(:,d-1)
         call daxpy(size(x),2*c1,deriv1(1,d-1),1,deriv2(1,d),1)
         call daxpy(size(x),-c2,deriv2(1,d-2),1,deriv2(1,d),1)
      endif
      if (present(deriv3)) then
         deriv3(:,d) = c1*x*deriv3(:,d-1)
         call daxpy(size(x),3*c1,deriv2(1,d-1),1,deriv3(1,d),1)
         call daxpy(size(x),-c2,deriv3(1,d-2),1,deriv3(1,d),1)
      endif
   else
      ierr = PHAML_INTERNAL_ERROR
      call fatal("need single or double precision for BLAS")
      stop
   endif
end do

if (present(deriv0)) deriv0 = legendre(:,1:)

end subroutine dlegendre

!        ---------
function factorial(n)
!        ---------

!----------------------------------------------------
! This routine computes n!
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: n
integer :: factorial
!----------------------------------------------------
! Local variables:

integer :: i
!----------------------------------------------------
! Begin executable code

if (n < 0) then
   ierr = PHAML_INTERNAL_ERROR
   call fatal("attempt to compute factorial of negative number",intlist=(/n/))
   stop
endif

factorial = 1
do i=2,n
   factorial = factorial*i
end do

end function factorial

!-------------------------------------------------------
! ROUTINES FOR NODAL BASIS
!-------------------------------------------------------

!          ------------------
subroutine nodal_basis_func_a(x,y,xvert,yvert,degree,set,basis,basisx,basisy)
!          ------------------

!----------------------------------------------------
! This routine computes nodal basis functions and derivatives at (x,y)
! for the triangle given by (xvert,yvert).  basis, basisx and basisy are all
! optional; only those present are computed.  degree determines the polynomial
! degree of the basis functions;
!
! set determines which subset of the bases is returned: "a" requests all
! basis functions, "b" requests only the black bases, and "r" the red bases.
!
!  The order in which the bases are returned:
!  - those along the edge from vertex 1 to vertex 2
!  - subsequent lines of nodes going towards vertex 3
!  For example, for cubics
! vertex 1  1
!           |\
!           2 5
!           |  \
!           3 6 8
!           |    \
! vertex 2  4-7-9-10  vertex 3
!
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x(:), y(:), xvert(3), yvert(3)
integer, intent(in) :: degree
character(len=1), intent(in) :: set
real(my_real), intent(out), optional :: basis(:,:), basisx(:,:), basisy(:,:)
!----------------------------------------------------
! Local variables:

real(my_real) :: zeta(size(x),3), dzdx(3), dzdy(3), b(size(x)), bx(size(x)), &
                 by(size(x)), factor(size(x)), nf
integer :: i, j, bas, nbasis, npoint, node_bary(3)
!----------------------------------------------------
! Begin executable code

! check that the size of the return arrays is big enough

npoint = size(x)
select case(set)
case("a")
   nbasis = ((degree+1)*(degree+2))/2
case("b")
   if (2*(degree/2) == degree) then
      nbasis = ((degree+2)*(degree+2))/4
   else
      nbasis = ((degree+1)*(degree+3))/4
   endif
case("r")
   if (2*(degree/2) == degree) then
      nbasis = (degree*(degree+2))/4
   else
      nbasis = ((degree+1)*(degree+1))/4
   endif
end select

if (present(basis)) then
   if (size(basis,1) < nbasis .or. size(basis,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basis array is too small in nodal_basis_func.", &
                 intlist = (/size(basis,1),size(basis,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisx)) then
   if (size(basisx,1) < nbasis .or. size(basisx,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisx array is too small in nodal_basis_func.", &
                 intlist = (/size(basisx,1),size(basisx,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisy)) then
   if (size(basisy,1) < nbasis .or. size(basisy,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisy array is too small in nodal_basis_func.", &
                 intlist = (/size(basisy,1),size(basisy,2),nbasis,npoint/))
      stop
   endif
endif

! compute the barycentric coordinates of (x,y)

call barycentric(x,y,xvert,yvert,zeta,dzdx,dzdy)

! for each basis function, characterized by the node barycentric coordinates
! scaled by degree

if (set == "r") then
   node_bary(1) = degree
   node_bary(2) = -1
   node_bary(3) = 1
else
   node_bary(1) = degree + 1
   node_bary(2) = -1
   node_bary(3) = 0
endif

do bas=1,nbasis

! barycentric coordinates of node of next basis

   node_bary(1) = node_bary(1) - 1
   node_bary(2) = node_bary(2) + 1
   if (node_bary(1) < 0) then
      if (set == "a") then
         node_bary(3) = node_bary(3) + 1
      else
         node_bary(3) = node_bary(3) + 2
      endif
      node_bary(2) = 0
      node_bary(1) = degree - node_bary(3)
   endif

! compute basis function and derivatives

   b = 1.0_my_real
   if (present(basisx)) bx = 0.0_my_real
   if (present(basisy)) by = 0.0_my_real
   nf = 1.0_my_real

   do i=1,3
      do j=0,degree-1
         if (j < node_bary(i)) then
            nf = nf*real(node_bary(i)-j,my_real)/degree
            factor = zeta(:,i) - real(j,my_real)/degree
            if (present(basisx)) bx = bx*factor + b*dzdx(i)
            if (present(basisy)) by = by*factor + b*dzdy(i)
            b = b*factor
         endif
      end do
   end do

   if (present(basis)) basis(bas,:) = b/nf
   if (present(basisx)) basisx(bas,:) = bx/nf
   if (present(basisy)) basisy(bas,:) = by/nf

end do

end subroutine nodal_basis_func_a

!          ------------------
subroutine nodal_basis_func_s(x,y,xvert,yvert,degree,set,basis,basisx,basisy)
!          ------------------

!----------------------------------------------------
! This routine is a version of nodal_basis_func for a single point.  It turns
! it into an array of size 1 and calls the version for an array of points.
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x, y, xvert(3), yvert(3)
integer, intent(in) :: degree
character(len=1), intent(in) :: set
real(my_real), intent(out), optional :: basis(:), basisx(:), basisy(:)
!----------------------------------------------------
! Local variables:

real(my_real) :: x_a(1), y_a(1)
real(my_real), allocatable :: basis_a(:,:), basisx_a(:,:), basisy_a(:,:)
integer :: code, astat1, astat2, astat3
!----------------------------------------------------
! Begin executable code

x_a = x
y_a = y

code = 0
astat1 = 0
astat2 = 0
astat3 = 0

if (present(basis)) then
   allocate(basis_a(size(basis),1),stat=astat1)
   code = code + 1
endif

if (present(basisx) .and. astat1 == 0) then
   allocate(basisx_a(size(basisx),1),stat=astat2)
   code = code + 2
endif

if (present(basisy) .and. astat1 == 0 .and. astat2 == 0) then
   allocate(basisy_a(size(basisy),1),stat=astat3)
   code = code + 4
endif

if (astat1 /= 0 .or. astat2 /= 0 .or. astat3 /= 0) then
   ierr = ALLOC_FAILED
   call fatal("memory allocation failed in nodal_basis_func_s")
   stop
endif

select case (code)
case(0)
case(1)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a)
case(2)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a)
case(3)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a,basisx_a)
case(4)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a)
case(5)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a,basisy=basisy_a)
case(6)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx_a,basisy=basisy_a)
case(7)
   call nodal_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a,basisx_a,basisy_a)
end select

if (present(basis) ) basis  = basis_a(:,1)
if (present(basisx)) basisx = basisx_a(:,1)
if (present(basisy)) basisy = basisy_a(:,1)

end subroutine nodal_basis_func_s

!-------------------------------------------------------
! ROUTINES FOR H-HIERARCHICAL BASIS
!-------------------------------------------------------

!          -------------------
subroutine h_hier_basis_func_a(x,y,xvert,yvert,degree,set,basis,basisx,basisy)
!          -------------------

!----------------------------------------------------
! This routine computes h-hierarchical basis functions and derivatives at (x,y)
! for the triangle given by (xvert,yvert).  basis, basisx and basisy are all
! optional; only those present are computed.  degree determines the polynomial
! degree of the basis functions;
!
! set determines which subset of the bases is returned: "a" requests all
! basis functions, "b" requests only the black bases, and "r" the red bases.
!
!  The order in which the bases are returned:
!  - those along the edge from vertex 1 to vertex 2
!  - subsequent lines of black nodes (every other line) going towards vertex 3
!  - the red nodes going along lines parallel to the line from vertex 1 to 2
!  For example, for cubics
! vertex 1  1
!           |\
!           2 7
!           |  \
!           3 8 5
!           |    \
! vertex 2  4-9-6-10  vertex 3
!
! vertex 3 is assumed to be the newest node from a bisection, hence the
! parent triangle would have vertex 1 and 2, and a vertex that is twice
! the distance from vertex 1 as vertex 3
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x(:), y(:), xvert(3), yvert(3)
integer, intent(in) :: degree
character(len=1), intent(in) :: set
real(my_real), intent(out), optional :: basis(:,:), basisx(:,:), basisy(:,:)
!----------------------------------------------------
! Local variables:

real(my_real) :: xvert_par(3), yvert_par(3), &
                 basis_loc(((degree+1)*(degree+2))/2,size(x)), &
                 basisx_loc(((degree+1)*(degree+2))/2,size(x)), &
                 basisy_loc(((degree+1)*(degree+2))/2,size(x))
integer :: i, j, npoint, nbasis, nblack, nred, code, n1, n2
!----------------------------------------------------
! Begin executable code

! number of red and black nodes

if (2*(degree/2) == degree) then
   nblack = ((degree+2)*(degree+2))/4
   nred = (degree*(degree+2))/4
else
   nblack = ((degree+1)*(degree+3))/4
   nred = ((degree+1)*(degree+1))/4
endif

! check that the size of the return arrays is big enough

npoint = size(x)
select case(set)
case("a")
   nbasis = ((degree+1)*(degree+2))/2
case("b")
   nbasis = nblack
case("r")
   nbasis = nred
end select

if (present(basis)) then
   if (size(basis,1) < nbasis .or. size(basis,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basis array is too small in h_hier_basis_func.", &
                 intlist = (/size(basis,1),size(basis,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisx)) then
   if (size(basisx,1) < nbasis .or. size(basisx,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisx array is too small in h_hier_basis_func.", &
                 intlist = (/size(basisx,1),size(basisx,2),nbasis,npoint/))
      stop
   endif
endif

if (present(basisy)) then
   if (size(basisy,1) < nbasis .or. size(basisy,2) < npoint) then
      ierr = PHAML_INTERNAL_ERROR
      call fatal("Size of basisy array is too small in h_hier_basis_func.", &
                 intlist = (/size(basisy,1),size(basisy,2),nbasis,npoint/))
      stop
   endif
endif

! set the code that determines which basis arguments are passed to nodal_basis

code = 0
if (present(basis)) code = code + 1
if (present(basisx)) code = code + 2
if (present(basisy)) code = code + 4

if (set == "a" .or. set == "b") then

! to get the bases associated with black nodes, get the nodal bases from
! the parent triangle

   xvert_par = xvert
   yvert_par = yvert
   xvert_par(3) = 2*xvert(3) - xvert(1)
   yvert_par(3) = 2*yvert(3) - yvert(1)

   select case(code)
   case(0)
   case (1)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a",basis_loc)
   case (2)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a", &
                            basisx=basisx_loc)
   case (3)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a",basis_loc, &
                            basisx_loc)
   case (4)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a", &
                            basisy=basisy_loc)
   case (5)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a",basis_loc, &
                            basisy=basisy_loc)
   case (6)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a", &
                            basisx=basisx_loc,basisy=basisy_loc)
   case (7)
      call nodal_basis_func(x,y,xvert_par,yvert_par,degree,"a",basis_loc, &
                            basisx_loc,basisy_loc)
   end select

! extract those that are in this triangle

   n1 = 0
   n2 = 0

   do i=1,(degree+2)/2
      do j=1,degree+3-2*i
         n1 = n1+1
         n2 = n2+1
         if (present(basis)) basis(n1,1:size(x)) = basis_loc(n2,:)
         if (present(basisx)) basisx(n1,1:size(x)) = basisx_loc(n2,:)
         if (present(basisy)) basisy(n1,1:size(x)) = basisy_loc(n2,:)
      end do
      n2 = n2 + i-1
   end do

endif

if (set == "a" .or. set == "r") then

! to get the bases associated with red nodes, get the nodal bases from
! for the red nodes

   select case(code)
   case(0)
   case (1)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r",basis_loc)
   case (2)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r",basisx=basisx_loc)
   case (3)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r",basis_loc,basisx_loc)
   case (4)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r",basisy=basisy_loc)
   case (5)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r",basis_loc, &
                            basisy=basisy_loc)
   case (6)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r", &
                            basisx=basisx_loc,basisy=basisy_loc)
   case (7)
      call nodal_basis_func(x,y,xvert,yvert,degree,"r",basis_loc, &
                            basisx_loc,basisy_loc)
   end select

! copy them to the result arrays

   if (set == "a") then
      n1 = nblack
   else
      n1 = 0
   endif

   do i=1,nred
      if (present(basis)) basis(i+n1,1:size(x)) = basis_loc(i,:)
      if (present(basisx)) basisx(i+n1,1:size(x)) = basisx_loc(i,:)
      if (present(basisy)) basisy(i+n1,1:size(x)) = basisy_loc(i,:)
   end do

end if

end subroutine h_hier_basis_func_a

!          -------------------
subroutine h_hier_basis_func_s(x,y,xvert,yvert,degree,set,basis,basisx,basisy)
!          -------------------

!----------------------------------------------------
! This routine is a version of h_hier_basis_func for a single point.  It turns
! it into an array of size 1 and calls the version for an array of points.
!----------------------------------------------------

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x, y, xvert(3), yvert(3)
integer, intent(in) :: degree
character(len=1), intent(in) :: set
real(my_real), intent(out), optional :: basis(:), basisx(:), basisy(:)
!----------------------------------------------------
! Local variables:

real(my_real) :: x_a(1), y_a(1)
real(my_real), allocatable :: basis_a(:,:), basisx_a(:,:), basisy_a(:,:)
integer :: code, astat1, astat2, astat3
!----------------------------------------------------
! Begin executable code

x_a = x
y_a = y

code = 0
astat1 = 0
astat2 = 0
astat3 = 0

if (present(basis)) then
   allocate(basis_a(size(basis),1),stat=astat1)
   code = code + 1
endif

if (present(basisx) .and. astat1 == 0) then
   allocate(basisx_a(size(basisx),1),stat=astat2)
   code = code + 2
endif

if (present(basisy) .and. astat1 == 0 .and. astat2 == 0) then
   allocate(basisy_a(size(basisy),1),stat=astat3)
   code = code + 4
endif

if (astat1 /= 0 .or. astat2 /= 0 .or. astat3 /= 0) then
   ierr = ALLOC_FAILED
   call fatal("memory allocation failed in nodal_basis_func_s")
   stop
endif

select case (code)
case(0)
case(1)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a)
case(2)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx=basisx_a)
case(3)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a,basisx_a)
case(4)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisy=basisy_a)
case(5)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a,basisy=basisy_a)
case(6)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basisx_a,basisy=basisy_a)
case(7)
   call h_hier_basis_func_a(x_a,y_a,xvert,yvert,degree,set,basis_a,basisx_a,basisy_a)
end select

if (present(basis) ) basis  = basis_a(:,1)
if (present(basisx)) basisx = basisx_a(:,1)
if (present(basisy)) basisy = basisy_a(:,1)

end subroutine h_hier_basis_func_s

end module basis_functions


! { dg-do run }
! { dg-options "-Warray-temporaries " }

! Check that LBOUND/UBOUND/SIZE/SHAPE of array-expressions get simplified
! in certain cases.
! There should no array-temporaries warnings pop up, as this means that
! the intrinsic call has not been properly simplified.

! Contributed by Daniel Kraft, d@domob.eu.

PROGRAM main
  IMPLICIT NONE

  ! Some explicitely shaped arrays and allocatable ones.
  INTEGER :: a(2, 3), b(0:1, 4:6)
  INTEGER, ALLOCATABLE :: x(:, :), y(:, :)

  ! Allocate to matching sizes and initialize.
  ALLOCATE (x(-1:0, -3:-1), y(11:12, 3))
  a = 0
  b = 1
  x = 2
  y = 3

  ! Run the checks.  This should be simplified without array temporaries,
  ! and additionally correct (of course).

  ! Shape of expressions known at compile-time.
  IF (ANY (LBOUND (a + b) /= 1)) STOP 1
  IF (ANY (UBOUND (2 * b) /= (/ 2, 3 /))) STOP 2
  IF (ANY (SHAPE (- b) /= (/ 2, 3 /))) STOP 3
  IF (SIZE (a ** 2) /= 6) STOP 1

  ! Shape unknown at compile-time.
  IF (ANY (LBOUND (x + y) /= 1)) STOP 4
  IF (SIZE (x ** 2) /= 6) STOP 5

  ! Unfortunately, the array-version of UBOUND and SHAPE keep generating
  ! temporary arrays for their results (not for the operation).  Thus we
  ! can not check SHAPE in this case and do UBOUND in the single-dimension
  ! version.
  IF (UBOUND (2 * y, 1) /= 2 .OR. UBOUND (2 * y, 2) /= 3) STOP 6
  !IF (ANY (SHAPE (- y) /= (/ 2, 3 /))) STOP 7
END PROGRAM main