program rstest
  use flips
  use rand

  ! This program tests flips_resize in different situations
  ! Single precision real version

  implicit none

  type(flips_d) :: s1,s2,s3,s4

  real(dp), dimension(:), allocatable :: amat,amat2,rr,meas2
  real(dp), dimension(:), allocatable :: meas,erro
  logical, dimension(:), allocatable :: re
  real(dp) :: diff, maxdiff
  real(dp) :: ts,te
  logical, dimension(:), allocatable :: remo
  integer :: i

  call set_rand_seed()

  write(*,*) 'Test 1: Expand 1000 unknowns problem by 1000 new unknowns'
  ! ********************************************************************

  write(*,*) '  Memory storage'

  ! Initialize s1
  call flips_init(s1,1000,1,buffersize=50)
  call flips_init(s3,500,1,buffersize=50)

  ! Create data
  allocate(amat(1000*1000),meas(1000),erro(1000),amat2(1500*500),rr(500*500),meas2(500),remo(1000))
  call random_number(amat)
  call random_number(meas)
  !call random_number(erro)
  erro = 1.0

  ! Feed data in s1
  call flips_add(s1,1000,amat,meas,erro)

  call cpu_time(ts)

  remo = .FALSE.

  call flips_resize(s2,s1,newsize=1500,remove=remo)

 ! write(*,*) s2%ymat
  write(*,*) 'ncols',s2%ncols
  write(*,*) 'nrhs',s2%nrhs
  write(*,*) 'nbuf',s2%nbuf
  write(*,*) 'nrows',s2%nrows
  write(*,*) 'bw',s2%bw
  write(*,*) 'bbw',s2%bbw
  write(*,*) 'common',s2%common
  write(*,*) 'rl',s2%rl
  write(*,*) 'zeroth',s2%zeroth
  write(*,*) 'nrotbuf',s2%nrotbuf

  !s2%nrows = 1000

  call cpu_time(te)

  ! Add some new data

  amat2 = 0.0
  call random_number(rr)
  do i = 1,500
     rr(yind(i,i,500)) = 1.0
  end do

  call random_number(meas2)

  do i = 1,500

     amat2(yind(i,1001,1500):yind(i,1500,1500)) = rr(yind(i,1,500):yind(i,500,500))

     !write(*,*) amat2(yind(i,996,1500):yind(i,1005,1500))

  end do

     !write(*,*) amat2(996:1005)

     !call random_number(meas2)

     call flips_add(s2,500,amat2,meas2,erro(1:500))
     call flips_add(s3,500,rr,meas2,erro(1:500))

  call flips_rotate(s1)
  call flips_rotate(s2)
  call flips_rotate(s3)

 ! call flips_resize(s4,s2,newsize=500)

  !write(*,*) s2%ymat(1:1000)-s1%ymat

  ! Solve all problems
  call flips_solve(s1)

  call flips_solve(s2)

  call flips_solve(s3)

 ! call flips_solve(s4)

write(*,*) s1%solmat(1:5)
write(*,*) s2%solmat(1:5)
write(*,*) s2%solmat(1001:1005)
write(*,*) s3%solmat(1:5)
!write(*,*) s4%solmat(1:5)

  ! Compare results
  diff = sum(s2%solmat(1:1000) - s1%solmat)/1000
  maxdiff = maxval(s2%solmat(1:1000) - s1%solmat)
  write(*,*) '    Mean diff:',diff
  write(*,*) '    Max diff:',maxdiff
  write(*,*) '    Resize time:',te-ts,'\n'

  call flips_kill(s1,.FALSE.)
  call flips_kill(s2,.FALSE.)
  call flips_kill(s3,.FALSE.)
 ! call flips_kill(s4,.FALSE.)
  deallocate(amat,amat2,meas,erro,rr,meas2)

end program rstest


*   Modified form of convect43.f
*     for use in climlab
*   Here we have taken the dry convective adjustment code
*   (everything wrapped within the block IF(IPBL.NE.0)THEN )
*   and wrapped it in its own subroutine to be called by the parent program
*
*   Brian E. J. Rose
*   January 2018

***************************************************************************
*****                       SUBROUTINE CONVECT                        *****
*****                          VERSION 4.3c                           *****
*****                          20 May, 2002                           *****
*****                          Kerry Emanuel                          *****
***************************************************************************
C
        SUBROUTINE DRYADJUSTMENT
     *    (T,   Q,    QS,     U,    V,      TRA,    P,    PH,
     *     ND,  NL,   NTRA,   DELT,
     *     CPD, CPV, CL, RV, RD, LV0, G, ROWL, PRECIP
     *     )
C    ***  THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN   ***
C    ***                OR EQUAL TO  ND + 1                    ***
C
      PARAMETER (NA=70)
C
      REAL T(ND),Q(ND),QS(ND),U(ND),V(ND),TRA(ND,NTRA),P(ND),PH(ND)
      REAL TRATM(NA)
      REAL TH(NA),TOLD(NA)
      REAL LV(NA),LV0,H(NA),HP(NA),GZ(NA),HM(NA)

C  Compute potential temperature
        DO 7 I=1,NL+1
         RDCP=(RD*(1.-Q(I))+Q(I)*RV)/
     1    (CPD*(1.-Q(I))+Q(I)*CPV)
         TH(I)=T(I)*(1000.0/P(I))**RDCP
    7   CONTINUE

C
C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
C
        JC=0
        DO 30 I=NL-1,1,-1
         JN=0
          SUM=TH(I)*(1.+Q(I)*EPSI-Q(I))
         DO 10 J=I+1,NL
          SUM=SUM+TH(J)*(1.+Q(J)*EPSI-Q(J))
          THBAR=SUM/FLOAT(J+1-I)
          IF((TH(J)*(1.+Q(J)*EPSI-Q(J))).LT.THBAR)JN=J
   10    CONTINUE
         IF(I.EQ.1)JN=MAX(JN,2)
         IF(JN.EQ.0)GOTO 30
   12    CONTINUE
         AHM=0.0
         RM=0.0
         UM=0.0
         VM=0.0
         DO K=1,NTRA
          TRATM(K)=0.0
         END DO
         DO 15 J=I,JN
          AHM=AHM+(CPD*(1.-Q(J))+Q(J)*CPV)*T(J)*(PH(J)-PH(J+1))
          RM=RM+Q(J)*(PH(J)-PH(J+1))
          UM=UM+U(J)*(PH(J)-PH(J+1))
          VM=VM+V(J)*(PH(J)-PH(J+1))
          DO K=1,NTRA
           TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1))
          END DO
   15    CONTINUE
         DPHINV=1./(PH(I)-PH(JN+1))
         RM=RM*DPHINV
         UM=UM*DPHINV
         VM=VM*DPHINV
         DO K=1,NTRA
          TRATM(K)=TRATM(K)*DPHINV
         END DO
         A2=0.0
         DO 20 J=I,JN
          Q(J)=RM
          U(J)=UM
          V(J)=VM
          DO K=1,NTRA
           TRA(J,K)=TRATM(K)
          END DO
          RDCP=(RD*(1.-Q(J))+Q(J)*RV)/
     1     (CPD*(1.-Q(J))+Q(J)*CPV)
          X=(0.001*P(J))**RDCP
          TOLD(J)=T(J)
          T(J)=X
          A2=A2+(CPD*(1.-Q(J))+Q(J)*CPV)*X*(PH(J)-PH(J+1))
   20    CONTINUE
         DO 25 J=I,JN
          TH(J)=AHM/A2
          T(J)=T(J)*TH(J)
          TC=TOLD(J)-273.15
          ALV=LV0-CPVMCL*TC
          QS(J)=QS(J)+QS(J)*(1.+QS(J)*(EPSI-1.))*ALV*(T(J)-
     1     TOLD(J))/(RV*TOLD(J)*TOLD(J))
   25    CONTINUE
         IF((TH(JN+1)*(1.+Q(JN+1)*EPSI-Q(JN+1))).LT.
     1    (TH(JN)*(1.+Q(JN)*EPSI-Q(JN))))THEN
          JN=JN+1
          GOTO 12
         END IF
         IF(I.EQ.1)JC=JN
   30   CONTINUE
C
C   ***   Remove any supersaturation that results from adjustment ***
C
      IF(JC.GT.1)THEN
       DO 38 J=1,JC
          IF(QS(J).LT.Q(J))THEN
           ALV=LV0-CPVMCL*(T(J)-273.15)
           TNEW=T(J)+ALV*(Q(J)-QS(J))/(CPD*(1.-Q(J))+
     1      CL*Q(J)+QS(J)*(CPV-CL+ALV*ALV/(RV*T(J)*T(J))))
           ALVNEW=LV0-CPVMCL*(TNEW-273.15)
           QNEW=(ALV*Q(J)-(TNEW-T(J))*(CPD*(1.-Q(J))+CL*Q(J)))/ALVNEW
           PRECIP=PRECIP+24.*3600.*1.0E5*(PH(J)-PH(J+1))*
     1      (Q(J)-QNEW)/(G*DELT*ROWL)
           T(J)=TNEW
           Q(J)=QNEW
           QS(J)=QNEW
          END IF
   38  CONTINUE
      END IF
C
      RETURN
      END


      SUBROUTINE CLIP_S( R, NFP, NLP, DEL, CLIP3M, TL, TR, IOS )

!***********************************************************************
!* CLIP Version 2.1 Subroutine
!*
!* Computes the maximum value that the linear interpolation of a time
!* series, typically a chest resultant acceleration filtered to 300 Hz
!* cutoff, meets or exceeds for an interval of at least 3 msec, based on
!* the linearly interpolated time series.
!*
!* Background:
!*  The original CLIP (v.1.0) program did not require the signal
!*  to remain above the CLIP level in the interior of the CLIP
!*  time span.  CLIP v.2.0 implemented a new algorithm that
!*  conforms with our interpretation of the following code
!*  of federal regulations: "The resultant acceleration at the
!*  center of gravity of the upper thorax shall not exceed 60 G's
!*  except for intervals whos cumulative duration is not more
!*  than 3 milliseconds".  CLIP v.2.0 did not allow for a time
!*  step that was not a divisor of 3 msec.  CLIP v.2.1 added
!*  support for any time step and an interpolation algorithm
!*  that found the CLIP value based on the linearly interpolated
!*  input data.
!*
!* Approach:
!*  CLIP v.2.1 is based on the observation that CLIP solutions
!*  are either vertex values with time spans of any size at least
!*  3 msec, or a constant-y line between two interpolated end
!*  points of exactly 3 msec span and with both end segments
!*  sloping upwards towards the center of the span (tail solutions
!*  of 3 msec length are also possible with only the interior
!*  segment end meeting these conditions).
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP ! Index of first data point

      INTEGER NLP ! Index of last data point

      REAL R(NFP:NLP) ! Resultant acceleration time series array

      REAL DEL ! Time step (delta-t) (sec) of time series data (>0)

      REAL CLIP3M ! CLIP solution value

      REAL TL ! CLIP solution start time

      REAL TR ! CLIP solution end time

      INTEGER IOS ! Status flag returned

      ! Variables ______________________________________________________

      LOGICAL UP, DN, DO_TWO, DO_AGAIN, NEW_CLIP

      INTEGER I, J, K, IDELC, IMAX, IUP, IDN, ISPAN

      REAL DELC, DELCM, DELMUL, YL, YR, ZL, ZR, Y3M, YI, TF, TFMAX,
     & SPAN

      PARAMETER ( DELC = .003 )

      ! Initialization
      CLIP3M = 0.
      TL = 0.
      TR = 0.
      IF ( DEL .LE. 0. ) THEN ! Nonpositive time step error
        IOS = 1
        RETURN
      END IF
      IF ( ( NLP - NFP ) * DEL .LT. DELC ) THEN ! Not enough data error
        IOS = 2
        RETURN
      END IF
      IOS = 0
      DELCM = DELC * ( 1. - 1.E-7 )
      DELMUL = DELC / DEL
      IDELC = INT( DELMUL * ( 1. + 1.E-7 ) )

      ! Compute max non-vertex CLIP3M
      IF ( IDELC * DEL .LT. DELCM ) THEN ! Use 2 segments on right end
        DO_TWO = .TRUE.
      ELSE
        DO_TWO = .FALSE.
      END IF
      DO I = NFP, NLP - IDELC - 1
        DO_AGAIN = DO_TWO
        YL = R(I)
        YR = R(I+1)
        IF ( YR .GT. MAX( YL, CLIP3M ) ) THEN ! Contender
          J = I + IDELC
  102     ZL = R(J)
          ZR = R(J+1)
          IF ( ( ZL .GT. MAX( ZR, YL ) ) .AND. ( ZR .LT. YR ) )
     &       THEN ! Contender
            TFMAX = J + 1 - I - DELMUL
            TF = ( ZL - YL + ( I - J + DELMUL ) * ( ZR - ZL ) ) /
     &         ( YR - YL - ZR + ZL )
            IF ( ( TF .GT. 0. ) .AND. ( TF .LT. TFMAX ) ) THEN
              Y3M = YL + TF * ( YR - YL )
              IF ( Y3M .GT. CLIP3M ) THEN ! Still contender
                NEW_CLIP = .TRUE.
                K = I + 2
                DO WHILE ( ( NEW_CLIP ) .AND. ( K .LE. J-1 ) )
                  IF ( R(K) .LE. Y3M ) NEW_CLIP = .FALSE.
                  K = K + 1
                END DO
                IF ( NEW_CLIP ) THEN
                  CLIP3M = Y3M
                  TL = ( I + TF ) * DEL
                  TR = TL + DELC
                END IF
              END IF
            END IF
          END IF
          IF ( DO_AGAIN ) THEN
            J = J + 1
            DO_AGAIN = .FALSE.
            IF ( J .LT. NLP ) GO TO 102
          END IF
        END IF
      END DO

      ! Check left tail
      J = NFP + INT( DELC / DEL )
      TF = DELMUL - J
      IF ( J .LT. NLP ) THEN
        ZL = R(J)
        ZR = R(J+1)
        IF ( ZL .GT. MAX( ZR, CLIP3M ) ) THEN ! Contender
          Y3M = ZL + TF * ( ZR - ZL )
          IF ( Y3M .GT. CLIP3M ) THEN ! Still contender
            NEW_CLIP = .TRUE.
            K = NFP
            DO WHILE ( ( NEW_CLIP ) .AND. ( K .LE. J-1 ) )
              IF ( R(K) .LE. Y3M ) NEW_CLIP = .FALSE.
              K = K + 1
            END DO
            IF ( NEW_CLIP ) THEN
              CLIP3M = Y3M
              TL = NFP * DEL
              TR = TL + DELC
            END IF
          END IF
        END IF
      END IF

      ! Check right tail
      J = NLP - INT( DELC / DEL )
      IF ( J .GT. NFP ) THEN
        YL = R(J-1)
        YR = R(J)
        IF ( YR .GT. MAX( YL, CLIP3M ) ) THEN ! Contender
          Y3M = YR + TF * ( YL - YR )
          IF ( Y3M .GT. CLIP3M ) THEN ! Still contender
            NEW_CLIP = .TRUE.
            K = NLP
            DO WHILE ( ( NEW_CLIP ) .AND. ( K .GE. J+1 ) )
              IF ( R(K) .LE. Y3M ) NEW_CLIP = .FALSE.
              K = K - 1
            END DO
            IF ( NEW_CLIP ) THEN
              CLIP3M = Y3M
              TR = NLP * DEL
              TL = TR - DELC
            END IF
          END IF
        END IF
      END IF

      ! Compute max vertex-valued CLIP3M
      IMAX = -1
      IDELC = INT( DELC / DEL ) + 1
      DO I = NFP, NLP
        YI = R(I)
        IF ( YI .GT. CLIP3M ) THEN ! Contender
          DN = .TRUE.
          UP = .TRUE.
          IDN = I
          IUP = I
          ISPAN = 0
          DO WHILE ( ( DN .OR. UP ) .AND. ( ISPAN .LT. IDELC ) )
            IF ( DN ) THEN
              IF ( ( IDN .LE. NFP ) .OR.
     &           ( R(IDN-1) .LT. YI ) ) THEN
                DN = .FALSE.
              ELSE
                IDN = IDN - 1
                ISPAN = ISPAN + 1
              END IF
            END IF
            IF ( UP ) THEN
              IF ( ( IUP .GE. NLP ) .OR.
     &           ( R(IUP+1) .LT. YI ) ) THEN
                UP = .FALSE.
              ELSE
                IUP = IUP + 1
                ISPAN = ISPAN + 1
              END IF
            END IF
          END DO
          IF ( ISPAN * DEL .GE. DELCM ) THEN ! More than 3 msec
            CLIP3M = YI
            IMAX = I
          ELSE IF ( ( ISPAN + 2 ) * DEL .GE. DELCM ) THEN
            ! Check full span
            SPAN = ISPAN
            IF ( IDN .GT. NFP ) THEN
              ! Extend downward to seg intersection
              SPAN = SPAN +
     &           ( ( R(IDN) - YI ) / ( R(IDN) - R(IDN-1) ) )
            END IF
            IF ( IUP .LT. NLP ) THEN
              ! Extend upward to seg intersection
              SPAN = SPAN +
     &           ( ( R(IUP) - YI ) / ( R(IUP) - R(IUP+1) ) )
            END IF
            IF ( SPAN * DEL .GE. DELCM ) THEN ! More than 3 msec
              CLIP3M = YI
              IMAX = I
            END IF
          END IF
        END IF
      END DO

      ! Get span of a vertex solution
      IF ( IMAX .GE. 0 ) THEN ! Vertex solution
        I = IMAX
        YI = CLIP3M
        DN = .TRUE.
        UP = .TRUE.
        IDN = I
        IUP = I
        DO WHILE ( DN .OR. UP )
          IF ( DN ) THEN
            IF ( ( IDN .LE. NFP ) .OR.
     &         ( R(IDN-1) .LT. YI ) ) THEN
              DN = .FALSE.
            ELSE
              IDN = IDN - 1
            END IF
          END IF
          IF ( UP ) THEN
            IF ( ( IUP .GE. NLP ) .OR.
     &         ( R(IUP+1) .LT. YI ) ) THEN
              UP = .FALSE.
            ELSE
              IUP = IUP + 1
            END IF
          END IF
        END DO

        TL = IDN
        IF ( IDN .GT. NFP ) THEN ! Extend downward to seg intersection
          TL = TL - ( ( R(IDN) - YI ) / ( R(IDN) - R(IDN-1) ) )
        END IF
        TR = IUP
        IF ( IUP .LT. NLP ) THEN ! Extend upward to seg intersection
          TR = TR + ( ( R(IUP) - YI ) / ( R(IUP) - R(IUP+1) ) )
        END IF
        TL = TL * DEL
        TR = TR * DEL
      END IF

      ! Scale CLIP span endpoints to msec
      TL = TL * 1000
      TR = TR * 1000

      RETURN
      END


!##############################################################################
! PROGRAM HetAg_Dist
!
! ## Heterogeneous agents with direct computation of invariant distribution
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog09_09m.f90"

program HetAg_Dist

    use globals

    implicit none

    ! initialize variables
    call initialize()

    ! set initial guess of the interest rate
    r = 0.040d0

    ! solve initial equilibrium
    call solve_model()

contains

    ! For solving the model
    subroutine solve_model

        use toolbox

        implicit none
        real*8 :: x
        logical :: check

        ! start timer
        call tic()

        write(*, '(a)')'       K/Y         r      diff_K'

        ! set tolerance level for outer optimization
        call settol_root(sig_out)

        ! set initial guess
        x = r
        check = .false.

        ! solve asset market equilibrium
        call fzero(x, asset_market, check)

        if(check)write(*,'(a)')'ERROR IN ROOTFINDING'

        call toc

        ! write output to the screen
        call output

    end subroutine

    ! For initializing variables
    subroutine initialize()

        use toolbox

        implicit none
        integer :: is

        ! calculate the shock process
        call discretize_AR(rho, 0d0, sigma_eps, eta, pi, weights)
        eta = exp(eta)

        ! calculate aggregate labor supply
        LL = sum(eta*weights)

        ! initialize grid
        call grid_Cons_Grow(a, a_l, a_u, a_grow)

        ! initialize policy function
        do is = 1, ns
            c(:, is) = 0.04d0*a(:) + eta(is)
            c_new(:, is) = c(:, is)
        enddo

        ! get an initial guess for the distribution function
        phi = 1d0/dble((NA+1)*NS)

    end subroutine

    ! For creating output plots
    subroutine output()

        use toolbox

        implicit none
        integer :: ia, is
        real*8 :: CV_c, CV_a, CV_eta

        ! aggregate consumption and investment
        CC = sum(phi*c)
        II = delta*KK

        ! calculate coefficients of variation
        CV_eta = 0d0
        CV_c   = 0d0
        CV_a   = 0d0
        do ia = 0, NA
            do is = 1, NS
                CV_eta = CV_eta + phi(ia, is)*(eta(is)   - LL)**2
                CV_c   = CV_c   + phi(ia, is)*(c(ia, is) - CC)**2
                CV_a   = CV_a   + phi(ia, is)*(a(ia)     - KK)**2
            enddo
        enddo
        CV_eta = sqrt(CV_eta)/LL*100d0
        CV_c   = sqrt(CV_c)  /CC*100d0
        CV_a   = sqrt(CV_a)  /AA*100d0

        ! write output to screen
        write(*, '(//a)')'AIYAGARI ECONOMY OUTPUT'
        write(*,'(/a)')'PROD :       K/Y       L/Y         r         w'
        write(*,'(6x,4f10.4)')(/KK, LL/)/YY*100d0, r*100d0, w
        write(*,'(/a)')'GOODS:       C/Y       I/Y       D/Y'
        write(*,'(6x,3f10.4)')(/CC, II, CC+II/)/YY*100d0
        write(*,'(/a)')'               c         a       eta'
        write(*,'(a,4f10.4)')'LEV  :', CC, AA, LL
        write(*,'(a,3f10.4)')'CV   :', CV_c, CV_a, CV_eta
        write(*,'(//)')

        ! plot the distribution of wealth
        call plot(a, sum(phi, 2))
        call execplot(xlim=(/a_l, 30d0/), title='Distribution of Wealth')

        ! plot savings decisions
        do is = 1, 4
            call plot(a, (1+r)*a+w*eta(is)-c(:, is))
        enddo
        call execplot(xlim=(/a_l, 0.5d0/), title='Policy Functions')

    end subroutine

end program


      SUBROUTINE UPDATELINCOA (N,NPT,XPT,BMAT,ZMAT,IDZ,NDIM,SP,STEP,
     1  KOPT,KNEW,VLAG,W)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION XPT(NPT,*),BMAT(NDIM,*),ZMAT(NPT,*),SP(*),STEP(*),
     2  VLAG(*),W(*)
C
C     The arguments N, NPT, XPT, BMAT, ZMAT, IDZ, NDIM ,SP and STEP are
C       identical to the corresponding arguments in SUBROUTINE LINCOB.
C     KOPT is such that XPT(KOPT,.) is the current trust region centre.
C     KNEW on exit is usually positive, and then it is the index of an
C       interpolation point to be moved to the position XPT(KOPT,.)+STEP(.).
C       It is set on entry either to its final value or to 0. In the latter
C       case, the final value of KNEW is chosen to maximize the denominator
C       of the matrix updating formula times a weighting factor.
C     VLAG and W are used for working space, the first NPT+N elements of
C       both of these vectors being required.
C
C     The arrays BMAT and ZMAT with IDZ are updated, the new matrices being
C       the ones that are suitable after the shift of the KNEW-th point to
C       the new position XPT(KOPT,.)+STEP(.). A return with KNEW set to zero
C       occurs if the calculation fails due to a zero denominator in the
C       updating formula, which should never happen.
C
C     Set some constants.
C
      HALF=0.5D0
      ONE=1.0D0
      ZERO=0.0D0
      NPTM=NPT-N-1
C
C     Calculate VLAG and BETA for the current choice of STEP. The first NPT
C       elements of VLAG are set to the values of the Lagrange functions at
C       XPT(KOPT,.)+STEP(.). The first NPT components of W_check are held
C       in W, where W_check is defined in a paper on the updating method.
C
      DO 20 K=1,NPT
      W(K)=SP(NPT+K)*(HALF*SP(NPT+K)+SP(K))
      SUM=ZERO
      DO 10 J=1,N
   10 SUM=SUM+BMAT(K,J)*STEP(J)
   20 VLAG(K)=SUM
      BETA=ZERO
      DO 40 K=1,NPTM
      SUM=ZERO
      DO 30 I=1,NPT
   30 SUM=SUM+ZMAT(I,K)*W(I)
      IF (K .LT. IDZ) THEN
          BETA=BETA+SUM*SUM
          SUM=-SUM
      ELSE
          BETA=BETA-SUM*SUM
      END IF
      DO 40 I=1,NPT
   40 VLAG(I)=VLAG(I)+SUM*ZMAT(I,K)
      BSUM=ZERO
      DX=ZERO
      SSQ=ZERO
      DO 70 J=1,N
      SUM=ZERO
      DO 50 I=1,NPT
   50 SUM=SUM+W(I)*BMAT(I,J)
      BSUM=BSUM+SUM*STEP(J)
      JP=NPT+J
      DO 60 K=1,N
   60 SUM=SUM+BMAT(JP,K)*STEP(K)
      VLAG(JP)=SUM
      BSUM=BSUM+SUM*STEP(J)
      DX=DX+STEP(J)*XPT(KOPT,J)
   70 SSQ=SSQ+STEP(J)**2
      BETA=DX*DX+SSQ*(SP(KOPT)+DX+DX+HALF*SSQ)+BETA-BSUM
      VLAG(KOPT)=VLAG(KOPT)+ONE
C
C     If KNEW is zero initially, then pick the index of the interpolation
C       point to be deleted, by maximizing the absolute value of the
C       denominator of the updating formula times a weighting factor.
C
C
      IF (KNEW .EQ. 0) THEN
          DENMAX=ZERO
          DO 100 K=1,NPT
          HDIAG=ZERO
          DO 80 J=1,NPTM
          TEMP=ONE
          IF (J .LT. IDZ) TEMP=-ONE
   80     HDIAG=HDIAG+TEMP*ZMAT(K,J)**2
          DENABS=DABS(BETA*HDIAG+VLAG(K)**2)
          DISTSQ=ZERO
          DO 90 J=1,N
   90     DISTSQ=DISTSQ+(XPT(K,J)-XPT(KOPT,J))**2
          TEMP=DENABS*DISTSQ*DISTSQ
          IF (TEMP .GT. DENMAX) THEN
              DENMAX=TEMP
              KNEW=K
          END IF
  100     CONTINUE
      END IF
C
C     Apply the rotations that put zeros in the KNEW-th row of ZMAT.
C
      JL=1
      IF (NPTM .GE. 2) THEN
          DO 120 J=2,NPTM
          IF (J .EQ. IDZ) THEN
              JL=IDZ
          ELSE IF (ZMAT(KNEW,J) .NE. ZERO) THEN
              TEMP=DSQRT(ZMAT(KNEW,JL)**2+ZMAT(KNEW,J)**2)
              TEMPA=ZMAT(KNEW,JL)/TEMP
              TEMPB=ZMAT(KNEW,J)/TEMP
              DO 110 I=1,NPT
              TEMP=TEMPA*ZMAT(I,JL)+TEMPB*ZMAT(I,J)
              ZMAT(I,J)=TEMPA*ZMAT(I,J)-TEMPB*ZMAT(I,JL)
  110         ZMAT(I,JL)=TEMP
              ZMAT(KNEW,J)=ZERO
          END IF
  120     CONTINUE
      END IF
C
C     Put the first NPT components of the KNEW-th column of the Z Z^T matrix
C       into W, and calculate the parameters of the updating formula.
C
      TEMPA=ZMAT(KNEW,1)
      IF (IDZ .GE. 2) TEMPA=-TEMPA
      IF (JL .GT. 1) TEMPB=ZMAT(KNEW,JL)
      DO 130 I=1,NPT
      W(I)=TEMPA*ZMAT(I,1)
      IF (JL .GT. 1) W(I)=W(I)+TEMPB*ZMAT(I,JL)
  130 CONTINUE
      ALPHA=W(KNEW)
      TAU=VLAG(KNEW)
      TAUSQ=TAU*TAU
      DENOM=ALPHA*BETA+TAUSQ
      VLAG(KNEW)=VLAG(KNEW)-ONE
      IF (DENOM .EQ. ZERO) THEN
          KNEW=0
          GOTO 180
      END IF
      SQRTDN=DSQRT(DABS(DENOM))
C
C     Complete the updating of ZMAT when there is only one nonzero element
C       in the KNEW-th row of the new matrix ZMAT. IFLAG is set to one when
C       the value of IDZ is going to be reduced.
C
      IFLAG=0
      IF (JL .EQ. 1) THEN
          TEMPA=TAU/SQRTDN
          TEMPB=ZMAT(KNEW,1)/SQRTDN
          DO 140 I=1,NPT
  140     ZMAT(I,1)=TEMPA*ZMAT(I,1)-TEMPB*VLAG(I)
          IF (DENOM .LT. ZERO) THEN
              IF (IDZ .EQ. 1) THEN
                  IDZ=2
              ELSE
                  IFLAG=1
              END IF
          END IF
      ELSE
C
C     Complete the updating of ZMAT in the alternative case.
C
          JA=1
          IF (BETA .GE. ZERO) JA=JL
          JB=JL+1-JA
          TEMP=ZMAT(KNEW,JB)/DENOM
          TEMPA=TEMP*BETA
          TEMPB=TEMP*TAU
          TEMP=ZMAT(KNEW,JA)
          SCALA=ONE/DSQRT(DABS(BETA)*TEMP*TEMP+TAUSQ)
          SCALB=SCALA*SQRTDN
          DO 150 I=1,NPT
          ZMAT(I,JA)=SCALA*(TAU*ZMAT(I,JA)-TEMP*VLAG(I))
  150     ZMAT(I,JB)=SCALB*(ZMAT(I,JB)-TEMPA*W(I)-TEMPB*VLAG(I))
          IF (DENOM .LE. ZERO) THEN
              IF (BETA .LT. ZERO) THEN
                  IDZ=IDZ+1
              ELSE
                  IFLAG=1
              END IF
          END IF
      END IF
C
C     Reduce IDZ when the diagonal part of the ZMAT times Diag(DZ) times
C       ZMAT^T factorization gains another positive element. Then exchange
C       the first and IDZ-th columns of ZMAT.
C
      IF (IFLAG .EQ. 1) THEN
          IDZ=IDZ-1
          DO 160 I=1,NPT
          TEMP=ZMAT(I,1)
          ZMAT(I,1)=ZMAT(I,IDZ)
  160     ZMAT(I,IDZ)=TEMP
      END IF
C
C     Finally, update the matrix BMAT.
C
      DO 170 J=1,N
      JP=NPT+J
      W(JP)=BMAT(KNEW,J)
      TEMPA=(ALPHA*VLAG(JP)-TAU*W(JP))/DENOM
      TEMPB=(-BETA*W(JP)-TAU*VLAG(JP))/DENOM
      DO 170 I=1,JP
      BMAT(I,J)=BMAT(I,J)+TEMPA*VLAG(I)+TEMPB*W(I)
      IF (I .GT. NPT) BMAT(JP,I-NPT)=BMAT(I,J)
  170 CONTINUE
  180 RETURN
      END


*DECK LPDP
      SUBROUTINE LPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS,
     +   IS)
C***BEGIN PROLOGUE  LPDP
C***SUBSIDIARY
C***PURPOSE  Subsidiary to LSEI
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LPDP-S, DLPDP-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Haskell, K. H., (SNLA)
C***DESCRIPTION
C
C     DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1),
C     where N=N1+N2.  This is a slight overestimate for WS(*).
C
C     Determine an N1-vector W, and
C               an N2-vector Z
C     which minimizes the Euclidean length of W
C     subject to G*W+H*Z .GE. Y.
C     This is the least projected distance problem, LPDP.
C     The matrices G and H are of respective
C     dimensions M by N1 and M by N2.
C
C     Called by subprogram LSI( ).
C
C     The matrix
C                (G H Y)
C
C     occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*).
C
C     The solution (W) is returned in X(*).
C                  (Z)
C
C     The value of MODE indicates the status of
C     the computation after returning to the user.
C
C          MODE=1  The solution was successfully obtained.
C
C          MODE=2  The inequalities are inconsistent.
C
C***SEE ALSO  LSEI
C***ROUTINES CALLED  SCOPY, SDOT, SNRM2, SSCAL, WNNLS
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  LPDP
C
C     SUBROUTINES CALLED
C
C     WNNLS         SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST
C                   SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS.
C                   PART OF THIS PACKAGE.
C
C++
C     SDOT,         SUBROUTINES FROM THE BLAS PACKAGE.
C     SSCAL,SNRM2,  SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308.
C     SCOPY
C
      REAL             A(MDA,*), PRGOPT(*), WS(*), WNORM, X(*)
      INTEGER IS(*)
      REAL             FAC, ONE, RNORM, SC, YNORM, ZERO
      REAL             SDOT, SNRM2
      SAVE ZERO, ONE, FAC
      DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/
C***FIRST EXECUTABLE STATEMENT  LPDP
      N = N1 + N2
      MODE = 1
      IF (.NOT.(M.LE.0)) GO TO 20
      IF (.NOT.(N.GT.0)) GO TO 10
      X(1) = ZERO
      CALL SCOPY(N, X, 0, X, 1)
   10 WNORM = ZERO
      RETURN
   20 NP1 = N + 1
C
C     SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE.
      DO 40 I=1,M
        SC = SNRM2(N,A(I,1),MDA)
        IF (.NOT.(SC.NE.ZERO)) GO TO 30
        SC = ONE/SC
        CALL SSCAL(NP1, SC, A(I,1), MDA)
   30   CONTINUE
   40 CONTINUE
C
C     SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO).
      YNORM = SNRM2(M,A(1,NP1),1)
      IF (.NOT.(YNORM.NE.ZERO)) GO TO 50
      SC = ONE/YNORM
      CALL SSCAL(M, SC, A(1,NP1), 1)
C
C     SCALE COLS OF MATRIX H.
   50 J = N1 + 1
   60 IF (.NOT.(J.LE.N)) GO TO 70
      SC = SNRM2(M,A(1,J),1)
      IF (SC.NE.ZERO) SC = ONE/SC
      CALL SSCAL(M, SC, A(1,J), 1)
      X(J) = SC
      J = J + 1
      GO TO 60
   70 IF (.NOT.(N1.GT.0)) GO TO 130
C
C     COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*).
      IW = 0
      DO 80 I=1,M
C
C     MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY.
        CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1)
        IW = IW + N2
C
C     MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY.
        CALL SCOPY(N1, A(I,1), MDA, WS(IW+1), 1)
        IW = IW + N1
C
C     MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY.
        WS(IW+1) = A(I,NP1)
        IW = IW + 1
   80 CONTINUE
      WS(IW+1) = ZERO
      CALL SCOPY(N, WS(IW+1), 0, WS(IW+1), 1)
      IW = IW + N
      WS(IW+1) = ONE
      IW = IW + 1
C
C     SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0.  THE
C     MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR
C     F = TRANSPOSE OF (0,...,0,1).
      IX = IW + 1
      IW = IW + M
C
C     DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ).
      IS(1) = 0
      IS(2) = 0
      CALL WNNLS(WS, NP1, N2, NP1-N2, M, 0, PRGOPT, WS(IX), RNORM,
     1 MODEW, IS, WS(IW+1))
C
C     COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W.
      SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1)
      IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110
      SC = ONE/SC
      DO 90 J=1,N1
        X(J) = SC*SDOT(M,A(1,J),1,WS(IX),1)
   90 CONTINUE
C
C     COMPUTE THE VECTOR Q=Y-GW.  OVERWRITE Y WITH THIS VECTOR.
      DO 100 I=1,M
        A(I,NP1) = A(I,NP1) - SDOT(N1,A(I,1),MDA,X,1)
  100 CONTINUE
      GO TO 120
  110 MODE = 2
      RETURN
  120 CONTINUE
  130 IF (.NOT.(N2.GT.0)) GO TO 180
C
C     COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*).
      IW = 0
      DO 140 I=1,M
        CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1)
        IW = IW + N2
        WS(IW+1) = A(I,NP1)
        IW = IW + 1
  140 CONTINUE
      WS(IW+1) = ZERO
      CALL SCOPY(N2, WS(IW+1), 0, WS(IW+1), 1)
      IW = IW + N2
      WS(IW+1) = ONE
      IW = IW + 1
      IX = IW + 1
      IW = IW + M
C
C     SOLVE RV=S SUBJECT TO V.GE.0.  THE MATRIX R =(TRANSPOSE
C     OF (H Q)), WHERE Q=Y-GW.  THE (N2+1)-VECTOR S =(TRANSPOSE
C     OF (0,...,0,1)).
C
C     DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ).
      IS(1) = 0
      IS(2) = 0
      CALL WNNLS(WS, N2+1, 0, N2+1, M, 0, PRGOPT, WS(IX), RNORM, MODEW,
     1 IS, WS(IW+1))
C
C     COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z.
      SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1)
      IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160
      SC = ONE/SC
      DO 150 J=1,N2
        L = N1 + J
        X(L) = SC*SDOT(M,A(1,L),1,WS(IX),1)*X(L)
  150 CONTINUE
      GO TO 170
  160 MODE = 2
      RETURN
  170 CONTINUE
C
C     ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION.
  180 CALL SSCAL(N, YNORM, X, 1)
      WNORM = SNRM2(N1,X,1)
      RETURN
      END


           !------------------------!
           ! Cubpack User Interface !
           !------------------------!
Module CUI

USE Precision_Model
USE internal_types

Implicit NONE

PRIVATE

PUBLIC :: CUBATR, CUBPACK_INFO
!-----------------------------------------------------------------------
!***BEGIN PROLOGUE CUBATR
!***DATE WRITTEN   901114   (YYMMDD)
!***REVISION DATE  970620   (YYMMDD)
!***REVISION DATE  980406   (YYMMDD) (MDIV removed)
!***REVISION DATE  000809   (YYMMDD)
!***REVISION DATE  010719   (YYMMDD)
!***REVISION DATE  020715   (YYMMDD) (CUBPACK_INFO added)
!***AUTHOR
!          Ronald Cools, Dept. of Computer Science,
!          Katholieke Universiteit Leuven, Celestijnenlaan 200A,
!          B-3001 Heverlee, Belgium
!          Email:  Ronald.Cools@cs.kuleuven.ac.be
!***REVISION DATE  150729   (YYMMDD) (Made threadsafe / re-entrant)
!***MODIFIER
!          Pat Scott, Dept. of Physics, Imperial College London
!          Email: p.scott@imperial
!
!***PURPOSE  Computation of integrals over a collection of regions.
!
!***DESCRIPTION
!          CUBATR is the driver routine for CUBPACK and the only
!          routine that a user has to deal with (at the moment).
!
!-----------------------------------------------------------------------
PRIVATE :: CUBATR_X, CUBATR_1, CUBATR_CLEAR

!
! Module variables
!
INTEGER, SAVE, PRIVATE :: PreJob=0
INTEGER, PRIVATE                :: BOTTIH,BOTTRH
INTEGER,         DIMENSION(:), PRIVATE, ALLOCATABLE  :: IWork
REAL(kind=stnd), DIMENSION(:), PRIVATE, ALLOCATABLE  :: RWork
TYPE(EPSALG_MEM), PRIVATE              :: M
!$omp threadprivate (PreJob, BOTTIH, BOTTRH, IWork, RWork, M)

INTERFACE CUBATR
   MODULE PROCEDURE CUBATR_X, CUBATR_1, CUBATR_CLEAR
END INTERFACE

CONTAINS

SUBROUTINE CUBATR_X     &
     (DIMENS,NumFun,Integrand,NumRgn,Vertices,RgType,Value,AbsErr,    &
!   and optional parameters
IFAIL,Neval,EpsAbs,EpsRel,Restart,MinPts,MaxPts,Key,Job,Tune)
!-----------------------------------------------------------------------
!   Input parameters
!   ----------------
!
!   DIMENS Integer.
!          The dimension of the region of integration.
!
!   NumFun Integer.
!          Number of components of the integrand.
!
!   Integrand
!          Externally declared function for computing all components
!          of the integrand at the given evaluation point.
!          It must have input parameter X:
!              X(1)   The x-coordinate of the evaluation point.
!              X(2)   The y-coordinate of the evaluation point.
!              ...
!              X(DIMENS) The z-coordinate of the evaluation point.
!         and NumFun, the number of components of the integrand.
!         It must be compatible with the following interface:
!           INTERFACE
!              FUNCTION Integrand(NUMFUN,X) RESULT(Value)
!                USE Precision_Model
!                INTEGER, INTENT(IN) :: NUMFUN
!                REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
!                REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
!              END FUNCTION Integrand
!           END INTERFACE
!
!   NumRgn Integer.
!          The number of given regions.
!
!   Vertices
!          Real array of dimension (DIMENS,DIMENS+1,NumRgn).
!          Vertices(1:DIMENS,K,L) are the x, y, ... coordinates
!          respectively of vertex K of region L, where
!          K = 1,...,DIMENS+1 and L = 1,...,NumRgn.
!
!   RgType Integer array of dimension (NumRgn).
!          RgType(L) describes the type of region L.
!
!   Value  Real array of dimension NumFun.
!          Approximations to all components of the integral if
!          the procedure is restarted.
!
!   AbsErr Real array of dimension NumFun.
!          Estimates of absolute errors if the procedure is restarted.
!
!   IFAIL  Optional integer argument.
!          This follows the NAG convention:
!          IFAIL = 1 : soft silent error
!                      Control returned to calling program.
!          IFAIL = -1: soft noisy error
!                      Error message is printed.
!                      Control returned to calling program.
!          IFAIL = 0 : hard noisy error
!                      Error message is printed and program is stopped.
!          Default IFAIL = -1.
!
!   EpsAbs Optional real argument.
!          Requested absolute error.
!          Default  EpsAbs = 0.
!
!   EpsRel Optional real argument.
!          Requested relative error.
!          Default EpsRel = sqrt(machine precision).
!
!   Restart Optional boolean argument.
!          If Restart = FALSE, this is the first attempt to compute
!                              the integral.
!          If Restart = TRUE, then we restart a previous attempt.
!          In this case the only parameters for CUBATR that may
!          be changed (with respect to the previous call of CUBATR)
!          are MinPts, MaxPts, EpsAbs, EpsRel, Key and Restart.
!          Default Restart = FALSE.
!
!   MinPts Optional integer argument.
!          The minimum allowed number of integrand evaluations.
!          Default MinPts = 0.
!
!   MaxPts Optional integer argument.
!          The maximum allowed number of integrand evaluations.
!          Default MaxPts = enough to do 500 subdivisions.
!
!   Key    Optional integer argument.
!          Can be used by Rule_General to choose between several
!          local integration rules.
!          Default Key = 2 if Dimension=1 and extrapolation is used
!                                        (This corresponds to QAGS)
!          Default Key = 0 otherwise
!
!   Job    Optional integer argument.
!          If |Job| = 0, then nothing will be done except freeing all
!                        allocated memory.
!                        This is usefull after a call of CUBATR if no
!                        Restart will be done later and memory usage
!                        might become an issue later.
!                        Equivalently, one can call CUBATR()
!                        without any arguments.
!                   = 1, the global adaptive algorithm is called
!                   = 2, extrapolation using the epsilon algorithm is used.
!                   = 11, a region will be divided in 2**DIMENS subregions
!                        and the global adaptive algorithm is called.
!                        In combination with Key=0, this resembles DUCTRI and DCUTET.
!                   = 12, a region will be divided in 2 subregions
!                        and the global adaptive algorithm is called.
!                        In combination with Key=3 or 4, this resembles DCUHRE.
!          If Job < 0, then an overview of the Region Collection is dumped.
!          This will create the files tmp_integerstore and tmp_realstore.
!          Default Job = 1.
!
!   Tune   Optional real argument.
!          Can be used by Global_Adapt or the local error estimators
!          to influence the reliability. 0 <= Tune <= 1.
!          Tune = 1 is the most reliable available.
!          Default Tune = 1.
!          Note that this is an experimental and controversial parameter.
!          In this version, only Tune = 1 is supported for all regions.
!
!   Output parameters
!   -----------------
!
!   Value  Real array of dimension NumFun.
!          Approximations to all components of the integral
!
!   AbsErr Real array of dimension NumFun.
!          Estimates of absolute errors.
!
!   NEval  Optional Integer.
!          Number of integrand evaluations used by CUBATR for this call.
!
!   IFAIL  Optional Integer.
!          IFAIL = 0 for normal exit.
!
!            AbsErr(K) <=  EpsAbs or
!            AbsErr(K) <=  ABS(Value(K))*EpsRel with MaxPts or less
!            function evaluations for all values of K,
!            1 <= K <= NumFun .
!
!          IFAIL = 1 if MaxPts was too small to obtain the required
!            accuracy. In this case Global_Adapt returns values of
!            Value with estimated absolute errors AbsErr.
!
!          IFAIL > 1 in more serious case of trouble.
!-----------------------------------------------------------------------
! MODULES USED
USE Check_Input
USE Error_Handling
USE DS_ROUTINES, ONLY: DSCOPY, DSINIT, DSUSED, DSSTAT, DSSUM, DSPINT
USE CubatureRule_General, ONLY: Rule_Cost
USE Global_Adaptive_Algorithm
!***END PROLOGUE CUBATR
!-----------------------------------------------------------------------
!
! Global variables
!
INTERFACE
   FUNCTION Integrand(NUMFUN,X) RESULT(Value)
     USE Precision_Model
     INTEGER, INTENT(IN) :: NUMFUN
     REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
     REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
   END FUNCTION Integrand
END INTERFACE
INTEGER, INTENT(IN)               :: DIMENS,NumFun,NumRgn
INTEGER, DIMENSION(:), INTENT(IN) :: RgType
LOGICAL, INTENT(IN),    OPTIONAL  :: Restart
INTEGER, INTENT(OUT),   OPTIONAL  :: NEval
INTEGER, INTENT(IN),    OPTIONAL  :: Job,Key,MaxPts,MinPts
INTEGER, INTENT(IN OUT), OPTIONAL  :: IFAIL
REAL(kind=stnd), INTENT(IN), OPTIONAL :: Tune,EpsAbs,EpsRel
REAL(kind=stnd), INTENT(IN), DIMENSION(:,:,:) :: Vertices
REAL(kind=stnd), INTENT(IN OUT), DIMENSION(:)  :: AbsErr, Value
!
! Named constants
!
INTEGER, PARAMETER ::  NRINFO=1, NIINFO=5
!
!  Local variables
!
INTEGER :: BLOCK,i,Inform,Leval,LJob,LMaxPts,LMinPts,MinCost, &
           NRVERT,NrSub,NRVACA,MAXRGN,RULCLS,STATUS,Tmp
LOGICAL                                     :: EpsAlg,LRestart
REAL(kind=stnd)                             :: LEpsAbs, LEpsRel
REAL(kind=stnd), DIMENSION(:), ALLOCATABLE  :: TmpRWork
INTEGER,    DIMENSION(:), ALLOCATABLE       :: TmpIWork
TYPE(INTEGRATOR_INFO)                       :: CINFO
TYPE(USER_INFO)                             :: UINFO
!-----------------------------------------------------------------------
!
! Check array sizes
!      Array size mismatch results in hard error.
   Inform = 0
   IF (size(rgtype) < numrgn) THEN
       write(unit=*,fmt=*) "Error: size(rgtype) < numrgn"
       Inform = Inform + 1
   END IF
   IF (size(abserr) < numfun) THEN
       write(unit=*,fmt=*) "Error: size(abserr) < numfun"
       Inform = Inform + 1
   END IF
   IF (size(Value) < numfun) THEN
       write(unit=*,fmt=*) "Error: size(Value) < numfun"
       Inform = Inform + 1
   END IF
   IF ((size(vertices,1) /= dimens) .or. (size(vertices,2) /= dimens+1) &
          .or. (size(vertices,3) < numrgn)) THEN
       Inform = Inform + 1
       write(unit=*,fmt=*)"Error: size(vertices) /= (/dimens,dimens+1,numrgn/)"
   END IF
   IF (Inform /= 0) THEN
      WRITE(unit=*,fmt=*)  "Array size mismatch results in hard error."
      STOP   ! "Array size mismatch results in hard error."
   END IF

!-----------------------------------------------------------------------
IF (PRESENT(NEval)) THEN
    NEval = 0
END IF
!-----------------------------------------------------------------------
IF (PRESENT(Job)) THEN
    LJob = Job
    IF (Job == 0) THEN
       CALL CUBATR_CLEAR()
       RETURN
    END IF
 ELSE
    LJob = 1
END IF
!-----------------------------------------------------------------------
!
! Set optional arguments
!
IF ( PRESENT(Restart)) THEN
                              LRestart = Restart
                       ELSE
                              LRestart = .FALSE.
END IF
IF ( PRESENT(Key)) THEN
                        CINFO%Key = Key
                   ELSE
                       IF ((ABS(LJob) == 2) .AND. (DIMENS == 1)) THEN
                           CINFO%Key = 2   ! simulate QAGS
                       ELSE
                           CINFO%Key = 0
                       END IF
END IF
!-----------------------------------------------------------------------
!
!  Check input parameters
!
IF ( .NOT. LRestart) THEN
         CALL CHECK(DIMENS,NumFun,NumRgn,RgType,Inform, &
                    LJob,IFAIL,EpsAbs,EpsRel,MinPts,MaxPts,Tune)
ELSE IF ( ALLOCATED(IWork) ) THEN
         CALL CHECK(DIMENS,NumFun,BOTTRH,BOTTIH,IWork,  &
                    Inform,LJob,IFAIL,EpsAbs,EpsRel,MinPts,MaxPts,Tune)
ELSE
   Inform = 4096  ! There is nothing to restart from
END IF
IF (Inform /= 0) THEN
    CALL Handle_Error(Inform,IFAIL)
    RETURN
END IF
!-----------------------------------------------------------------------
RULCLS = Rule_Cost( DIMENS, RgType(1), CINFO%Key )
MinCost = RULCLS
DO i = 2,NumRgn
   Tmp = Rule_Cost( DIMENS, RgType(i), CINFO%Key)
   RULCLS = max(RULCLS,Tmp)
   MinCost = MinCost + Tmp
END DO
!-----------------------------------------------------------------------
!
! Set optional arguments
!

IF ( PRESENT(MinPts)) THEN
                              LMinPts = MinPts
                      ELSE
                              LMinPts = 0
END IF
IF ( PRESENT(MaxPts)) THEN
                              LMaxPts = MaxPts
                      ELSE
                              LMaxPts = 500*RULCLS
END IF
IF ( PRESENT(Tune)) THEN
                              CINFO%Tune = Tune
                    ELSE
                              CINFO%Tune = 1
END IF
IF ( PRESENT(EpsAbs)) THEN
                              LEpsAbs = EpsAbs
                      ELSE
                              LEpsAbs = 0
END IF
IF ( PRESENT(EpsRel)) THEN
                              LEpsRel = EpsRel
                      ELSE
                              LEpsRel = SQRT(EPSILON(LEpsRel))
END IF
!-----------------------------------------------------------------------
!
! Set other parameters of the Global Adaptive algorithm
!
!
!  NrSub is an upper limit for the number of subregions after subdivision.
!  This influence memory managment, so don't exagerate here.
IF (DIMENS <= 3) THEN
                              NrSub = 2**DIMENS
                 ELSE
                              NrSub = 4
END IF
!
EpsAlg = ( ABS(LJob) == 2 )
CINFO%UNIFORM_SUBDIV = EpsAlg
CINFO%NrSub = NrSub

IF (( ABS(LJob) == 11) .AND. (DIMENS <= 3)) THEN
   ! simulate dcutri and dcutet ; NrSub = 2**DIMENS ; EpsAlg = .FALSE.
   CINFO%UNIFORM_SUBDIV = .TRUE.
END IF

IF ( ABS(LJob) == 12 ) THEN
   ! simulate dcuhre; NrSub = 2 ; EpsAlg = .FALSE.
   CINFO%NrSub = 2
END IF

NRVERT = DIMENS + 1   ! Only cubes and simplices are implemented here.

UINFO%NumFun = NumFun
UINFO%NumRgn = NumRgn
UINFO%MinPts = LMinPts
UINFO%MaxPts = LMaxPts
UINFO%EpsAbs = LEpsAbs
UINFO%EpsRel = LEpsRel
!-----------------------------------------------------------------------
IF (LRestart) THEN
  ! This requires allocating larger arrays and copying
  ! the region collection.
  ALLOCATE(TmpRWork(SIZE(RWork)),STAT=status)
  IF (status /=  0) THEN
     WRITE(unit=*,fmt=*)  "Problem allocating real workspace."
     STOP  !  "Problem allocating real workspace."
  END IF
  ALLOCATE(TmpIWork(SIZE(IWork)),STAT=status)
  IF (status /=  0) THEN
     WRITE(unit=*,fmt=*) "Problem allocating integer workspace."
     STOP  ! "Problem allocating integer workspace."
  END IF
  MAXRGN = DSUSED(IWork)
  CALL DSCOPY(IWork,RWork,TmpIWork,TmpRWork)
ELSE
  MAXRGN = NumRgn
END IF
!-----------------------------------------------------------------------
! NRVACA is the number of regions the global adaptive algorithm
!        removes from the data structure for further processing.
!        In some routines for shared memory parallel machines
!        this is the variable MDIV
NRVACA = 1
! MAXRGN depends on the number of function evalutions
MAXRGN = MAXRGN + 1 + (NrSub-1)*(LMaxPts - RULCLS*NumRgn)/(RULCLS*NrSub)
!
! Compute length of workspace needed.
!
BOTTIH = MAXRGN*(1+NIINFO) + 15 + NRVACA
BLOCK = NRINFO+NRVERT*DIMENS+2*NumFun
IF (NumFun > 1) THEN
    BLOCK = BLOCK + 1
END IF
BOTTRH = MAXRGN*BLOCK
!
! Allocate space for the region collection
!
IF (ALLOCATED(RWork)) THEN
    DEALLOCATE(RWork)
END IF
ALLOCATE(RWork(BOTTRH),STAT=status)
IF (status /=  0) THEN
   WRITE(unit=*,fmt=*) "Problem allocating real workspace."
   STOP  ! "Problem allocating real workspace."
END IF
IF (ALLOCATED(IWork)) THEN
   DEALLOCATE(IWork)
END IF
ALLOCATE(IWork(BOTTIH),STAT=status)
IF (status  /=  0) THEN
   WRITE(unit=*,fmt=*) "Problem allocating integer workspace."
   STOP  ! "Problem allocating integer workspace."
END IF
!
! Initialise region collection
!
IF ( LRestart) THEN
    CALL DSCOPY(TmpIWork,TmpRWork,IWork,RWork)
    DEALLOCATE(TmpIWork,TmpRWork)
ELSE
   IF ( MinCost > LMaxPts ) THEN
       Inform = 128    ! Dit nummer werd al gebruikt !
   ELSE
       CALL DSINIT(DIMENS,NRVERT,NIINFO,NRINFO,NumFun,NRVACA,   &
                   BOTTIH,BOTTRH,IWork,Inform)
   END IF
   IF (Inform /= 0) THEN
       CALL Handle_Error(Inform,IFAIL)
       RETURN
   END IF
END IF
!-----------------------------------------------------------------------
!
!  Call integration routine
!
If (EpsAlg) THEN
   IF ( LRestart .AND. (PreJob /= ABS(LJob))) THEN
      Inform = 3
   ELSE
      ! Observe that only relevant array sections are passed !
      CALL Global_Adapt_Extrap(DIMENS,CINFO,UINFO,NRVERT,NIINFO,    &
                     NRINFO, Vertices(1:DIMENS,1:NRVERT,1:NUMRGN),  &
                     RgType(1:NUMRGN),Integrand,LRestart,           &
                     Value(1:NUMFUN),AbsErr(1:NUMFUN),LEval,Inform, &
                     RWork,IWork,M)
   END IF
ELSE
   IF ( LRestart .AND. (PreJob /= LJob)) THEN
       IF ( ASSOCIATED(M%RESLA)) THEN
           DEALLOCATE(M%RESLA,M%ERLARG,M%RESULT1,M%ABSERR1,M%RCOPY)
       END IF
       CALL DSPINT(IWork,RWork)
       CALL DSSUM(Value,Abserr,IWork,RWork,Inform)
   END IF
   ! Observe that only relevant array sections are passed !
   CALL Global_Adapt(DIMENS,CINFO,UINFO,NRVERT,NIINFO,NRINFO,    &
                  Vertices(1:DIMENS,1:NRVERT,1:NUMRGN),          &
                  RgType(1:NUMRGN),Integrand,LRestart,           &
                  Value(1:NUMFUN),AbsErr(1:NUMFUN),LEval,Inform, &
                  RWork,IWork)
END IF
IF (PRESENT(NEval)) THEN
   NEval = LEval
END IF
!-----------------------------------------------------------------------
 IF (LJob < 0) THEN
    WRITE(unit=*,fmt=*) "Debug mode: dumping region collection overview."
    CALL DSSTAT(IWork(:),RWork(:))          ! For debugging.
 END IF
!-----------------------------------------------------------------------
! IF ((Inform >= 8) .or. (Inform == 3)) THEN
!    Something went wrong but the data structure remains untouched
!    and so this call can be ignored.
IF ((Inform < 8) .AND. (Inform /= 3)) THEN
   PreJob = ABS(LJob)
END IF
CALL Handle_Error(Inform,IFAIL)
RETURN
END SUBROUTINE CUBATR_X

SUBROUTINE CUBATR_1                                              &
     (DIMENS,Integrand,SVertices,SRgType,SValue,SAbsErr,         &
!   and optional parameters                                      &
      IFAIL,Neval,EpsAbs,EpsRel,Restart,MaxPts,Key,Job)
!-----------------------------------------------------------------------
!   Input parameters
!   ----------------
!
!   DIMENS Integer.
!          The dimension of the region of integration.
!
!   Integrand
!          Externally declared function for computing all components
!          of the integrand at the given evaluation point.
!          It must have input parameter X:
!              X(1)   The x-coordinate of the evaluation point.
!              X(2)   The y-coordinate of the evaluation point.
!              ...
!              X(DIMENS) The z-coordinate of the evaluation point.
!         and NumFun, the number of components of the integrand.
!         It must be compatible with the following interface:
!           INTERFACE
!              FUNCTION Integrand(NUMFUN,X) RESULT(Value)
!                USE Precision_Model
!                INTEGER, INTENT(IN) :: NUMFUN
!                REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
!                REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
!              END FUNCTION Integrand
!           END INTERFACE
!
!   SVertices
!          Real array of dimension (DIMENS,DIMENS+1).
!          Vertices(1:DIMENS,K) are the x, y, ... coordinates
!          respectively of vertex K of the region, where
!          K = 1,...,DIMENS+1.
!
!   SRgType Integer.
!          RgType describes the type of region L.
!
!   SValue Real.
!          Approximation to the integral if the procedure is restarted.
!
!   SAbsErr Real.
!          Estimate of the absolute error if the procedure is restarted.
!
!   IFAIL  Optional integer argument.
!          This follows the NAG convention:
!          IFAIL = 1 : soft silent error
!                      Control returned to calling program.
!          IFAIL = -1: soft noisy error
!                      Error message is printed.
!                      Control returned to calling program.
!          IFAIL = 0 : hard noisy error
!                      Error message is printed and program is stopped.
!          Default IFAIL = -1.
!
!   EpsAbs Optional real argument.
!          Requested absolute error.
!          Default  EpsAbs = 0.
!
!   EpsRel Optional real argument.
!          Requested relative error.
!          Default EpsRel = sqrt(machine precision).
!
!   Restart Optional boolean argument.
!          If Restart = FALSE, this is the first attempt to compute
!                              the integral.
!          If Restart = TRUE, then we restart a previous attempt.
!          In this case the only parameters for CUBATR that may
!          be changed (with respect to the previous call of CUBATR)
!          are MinPts, MaxPts, EpsAbs, EpsRel, Key and Restart.
!          Default Restart = FALSE.
!
!   MaxPts Optional integer argument.
!          The maximum allowed number of integrand evaluations.
!          Default MaxPts = enough to do 500 subdivisions.
!
!   Key    Optional integer argument.
!          Can be used by Rule_General to choose between several
!          local integration rules.
!          Default Key = 2 if Dimension=1 and extrapolation is used
!                                        (This corresponds to QAGS)
!          Default Key = 0 otherwise
!
!   Job    Optional integer argument.
!          If |Job| = 0, then nothing will be done except freeing all
!                        allocated memory.
!                        This is usefull after a call of CUBATR if no
!                        Restart will be done later and memory usage
!                        might become an issue later.
!                        Equivalently, one can call CUBATR()
!                        without any arguments.
!                   = 1, the global adaptive algorithm is called
!                   = 2, extrapolation using the epsilon algorithm is used.
!                   = 11, a region will be divided in 2**DIMENS subregions
!                        and the global adaptive algorithm is called.
!                        In combination with Key=0, this resembles DUCTRI and DCUTET.
!                   = 12, a region will be divided in 2 subregions
!                        and the global adaptive algorithm is called.
!                        In combination with Key=3 or 4, this resembles DCUHRE.
!          If Job < 0, then an overview of the Region Collection is dumped.
!          This will create the files tmp_integerstore and tmp_realstore.
!          Default Job = 1.
!
!   Output parameters
!   -----------------
!
!   SValue Real.
!          Approximation to the integral
!
!   AbsErr Real.
!          Estimate of the absolute error.
!
!   NEval  Optional Integer.
!          Number of integrand evaluations used by CUBATR for this call.
!
!   IFAIL  Optional Integer.
!          IFAIL = 0 for normal exit.
!
!            AbsErr(K) <=  EpsAbs or
!            AbsErr(K) <=  ABS(Value(K))*EpsRel with MaxPts or less
!            function evaluations for all values of K,
!            1 <= K <= NumFun .
!
!          IFAIL = 1 if MaxPts was too small to obtain the required
!            accuracy. In this case Global_Adapt returns values of
!            Value with estimated absolute errors AbsErr.
!
!          IFAIL > 1 in more serious case of trouble.
!-----------------------------------------------------------------------
!
! Global variables
!
INTERFACE
   FUNCTION Integrand(NUMFUN,X) RESULT(Value)
      USE Precision_Model
      INTEGER, INTENT(IN) :: NUMFUN
      REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
      REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
   END FUNCTION Integrand
END INTERFACE
LOGICAL, OPTIONAL, INTENT(IN)                 :: Restart
INTEGER, INTENT(IN)                           :: DIMENS,SRgType
INTEGER, INTENT(OUT), OPTIONAL                :: NEval
INTEGER, INTENT(IN), OPTIONAL                 :: Key,MaxPts,Job
INTEGER, INTENT(IN OUT), OPTIONAL             :: IFAIL
REAL(kind=stnd), INTENT(IN), OPTIONAL         :: EpsAbs,EpsRel
REAL(kind=stnd), DIMENSION(:,:), INTENT(IN)   :: SVertices
REAL(kind=stnd), INTENT(IN OUT)               :: SValue,SAbsErr
!
! Local variables
!
INTEGER, DIMENSION(1)                         :: RgType
REAL(kind=stnd), DIMENSION(1)                 :: Value, AbsErr
REAL(kind=stnd), DIMENSION(DIMENS,DIMENS+1,1) :: Vertices
!-------------------
RgType(1) = SRgType
Vertices(:,:,1) = SVertices
IF (PRESENT(Restart)) THEN
    IF ( Restart ) THEN
       Value(1) = SValue
       AbsErr(1) = SAbsErr
    END IF
END IF
CALL CUBATR             &
  (DIMENS,1,Integrand,1,Vertices,RgType,Value,AbsErr,        &
   !   and optional parameters                               &
   ifail=IFAIL,neval=Neval,epsabs=EpsAbs,epsrel=EpsRel,      &
   restart=Restart,maxpts=MaxPts,key=key,job=Job)
SValue = Value(1)
SAbsErr = AbsErr(1)
RETURN
END SUBROUTINE CUBATR_1

SUBROUTINE CUBATR_CLEAR()
  IF ( ALLOCATED(Iwork) ) THEN
     DEALLOCATE(RWork,IWork)
  END IF
  IF ( ASSOCIATED(M%RESLA)) THEN
     DEALLOCATE(M%RESLA,M%ERLARG,M%RESULT1,M%ABSERR1,M%RCOPY)
  END IF
  PreJob = 0
  RETURN
END SUBROUTINE CUBATR_CLEAR

SUBROUTINE CUBPACK_INFO()

REAL(kind=stnd) :: x=1.0e-30  ! lowest accuracy of cubature formula constants

print *," ---------------------------------------------------------------"
print *,"              CUBPACK information"
print *,"              -------------------"
print *," The model for real numbers in the current installed version,"
print *," obtained with the declaration REAL(KIND=stnd), has the"
print *," following characteristics:"
print *,"                base =  ",radix(x)
print *," digits in this base = ", digits(x)
! print *," highest exponent = ", maxexponent(x)
! print *," lowest exponent = "minexponent(x), "(normalized numbers)
print *," This implies:"
print *,"            machine epsilon = ",epsilon(x)
print *,"        largest real number = ", huge(x)
print *," smallest normalized number = ", tiny(x)
print *
print *," The lowest relative error that may be obtained with this"
print "(""  version is about "",G8.2)",max(50*epsilon(x),x)
print *," Asking for lower error will push the routine to use the"
print *," maximal number of function evaluations it is allowed."
print *
print *
print *," This version accepts a collection of hyper-rectangles"
print *,"   (and parallelepipeds) and simplices as integration regions."
print *," Extrapolation using the epsilon-algorithm is available"
print *,"      for dimensions 1, 2 and 3."
print *," The following values of KEY give different integration rules:"
print *," - finite interval: KEY = 1, 2, 3, 4, 5."
print *,"      KEY < 1 defaults to 1; KEY > 5 defaults to 5."
print *," - n-cube:          KEY = 3, 4       uses rule of degree 2*KEY+1"
print *,"           otherwise, uses for a square a rule of degree 13"
print *,"                                 3-cube a rule of degree 11"
print *,"                                        a rule of degree  7"
print *," - n-simplex:       KEY = 1, 2, 3, 4 uses rule of degree 2*KEY+1"
print *,"         otherwise, uses for a triangle a rule of degree 13"
print *,"                            tetrahedron a rule of degree  8"
print *,"                                        a rule of degree  7"
print *," KEY = 0 corresponds to our preferred choice."
print *," ---------------------------------------------------------------"

RETURN
END SUBROUTINE CUBPACK_INFO

END Module CUI


! Contains the functions which allow the user to access the Standard Model Higgs
! Branching ratios, total decay width and cross sections.
!
! This file is part of HiggsBounds
!  -KW
!*********************************
function SMBR_HWW(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_HWW

  call testBRSM(Mh)

  SMBR_HWW=BRSM_HWW(Mh,.True.)

end function SMBR_HWW
!*********************************
function SMBR_HZZ(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_HZZ

  call testBRSM(Mh)

  SMBR_HZZ=BRSM_HZZ(Mh,.True.)

end function SMBR_HZZ
!*********************************
function SMBR_Hbb(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Hbb

  call testBRSM(Mh)

  SMBR_Hbb=BRSM_Hbb(Mh,.True.)

end function SMBR_Hbb
!*********************************
function SMBR_Htautau(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Htautau

  call testBRSM(Mh)

  SMBR_Htautau=BRSM_Htautau(Mh,.True.)

end function SMBR_Htautau
!*********************************
function SMBR_Hgamgam(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Hgamgam

  call testBRSM(Mh)

  SMBR_Hgamgam=BRSM_Hgaga(Mh,.True.)

end function SMBR_Hgamgam
!*********************************
function SMBR_Hgg(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Hgg

  call testBRSM(Mh)

  SMBR_Hgg=BRSM_Hgg(Mh,.True.)
end function SMBR_Hgg
!*********************************
function SMBR_Htoptop(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Htoptop

  call testBRSM(Mh)

  SMBR_Htoptop=BRSM_Htoptop(Mh,.True.)
end function SMBR_Htoptop
!*********************************
function SMBR_Hcc(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Hcc

  call testBRSM(Mh)

  SMBR_Hcc=BRSM_Hcc(Mh,.True.)
 end function SMBR_Hcc
!*********************************
function SMBR_Hss(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Hss

  call testBRSM(Mh)

  SMBR_Hss=BRSM_Hss(Mh,.True.)
end function SMBR_Hss
!*********************************
function SMBR_Hmumu(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_Hmumu

  call testBRSM(Mh)

  SMBR_Hmumu=BRSM_Hmumu(Mh,.True.)
end function SMBR_Hmumu
!*********************************
function SMBR_HZgam(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMBR_HZgam

  call testBRSM(Mh)

  SMBR_HZgam=BRSM_HZga(Mh,.True.)
end function SMBR_HZgam
!*********************************
function SMGamma_h(Mh)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMGamma_h

  call testBRSM(Mh)

  SMGamma_h=BRSM_GammaTot(Mh,.True.)

end function SMGamma_h
!*********************************
function SMGamma_tWpb(mt)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: mt
  double precision :: SMGamma_tWpb

  call testBRSM(mt)

  SMGamma_tWpb=BRSM_Gamma_tWpb(mt,.True.)

end function SMGamma_tWpb
!*********************************
function SMCS_tev_HW(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_HW

  call testBRSM(Mh)

  SMCS_tev_HW=1.0D-3*XS_tev_HW_SM(Mh,.True.)
end function SMCS_tev_HW
!*********************************
function SMCS_tev_HZ(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_HZ

  call testBRSM(Mh)

  SMCS_tev_HZ=1.0D-3*XS_tev_HZ_SM(Mh,.True.)
end function SMCS_tev_HZ
!*********************************
function SMCS_tev_gg_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_gg_H

  call testBRSM(Mh)

!  SMCS_tev_gg_H=1.0D-3*XS_tev_gg_H_SM(Mh) !use this for outdated CS
  SMCS_tev_gg_H=1.0D-3*XS_tev_gg_H_SM(Mh,.True.) !use this for updated (31/03/2011) CS
end function SMCS_tev_gg_H
!*********************************
function SMCS_tev_bb_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_bb_H

  call testBRSM(Mh)

  SMCS_tev_bb_H=1.0D-3*XS_tev_bb_H_SM(Mh,.True.)
end function SMCS_tev_bb_H
!*********************************
function SMCS_tev_vbf_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_vbf_H

  call testBRSM(Mh)

  SMCS_tev_vbf_H=1.0D-3*XS_tev_vbf_SM(Mh,.True.)
end function SMCS_tev_vbf_H
!*********************************
function SMCS_tev_bg_Hb(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_bg_Hb

  call testBRSM(Mh)

  SMCS_tev_bg_Hb=1.0D-3*XS_tev_bg_Hb_SM(Mh,.True.)
end function SMCS_tev_bg_Hb
!*********************************
function SMCS_tev_ttH(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_ttH

  call testBRSM(Mh)

  SMCS_tev_ttH=1.0D-3*XS_tev_ttH_SM(Mh,.True.)
end function SMCS_tev_ttH
!*********************************
function SMCS_lhc7_HW(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc7_HW

  call testBRSM(Mh)

  SMCS_lhc7_HW=XS_lhc7_HW_SM(Mh,.True.)
end function SMCS_lhc7_HW
!*********************************
function SMCS_lhc7_HZ(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc7_HZ

  call testBRSM(Mh)

  SMCS_lhc7_HZ=XS_lhc7_HZ_SM(Mh,.True.)
end function SMCS_lhc7_HZ
!*********************************
function SMCS_lhc7_gg_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc7_gg_H

  call testBRSM(Mh)

  SMCS_lhc7_gg_H=XS_lhc7_gg_H_SM(Mh,.True.)
end function SMCS_lhc7_gg_H
!*********************************
function SMCS_lhc7_bb_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc7_bb_H

  call testBRSM(Mh)

  SMCS_lhc7_bb_H=XS_lhc7_bb_H_SM(Mh,.True.)
end function SMCS_lhc7_bb_H
!*********************************
function SMCS_lhc7_vbf_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc7_vbf_H

  call testBRSM(Mh)

  SMCS_lhc7_vbf_H=XS_lhc7_vbf_SM(Mh,.True.)
end function SMCS_lhc7_vbf_H
!*********************************
function SMCS_lhc7_ttH(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc7_ttH

  call testBRSM(Mh)

  SMCS_lhc7_ttH=XS_lhc7_ttH_SM(Mh,.True.)
end function SMCS_lhc7_ttH
!*********************************

function SMCS_lhc8_HW(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc8_HW

  call testBRSM(Mh)

  SMCS_lhc8_HW=XS_lhc8_HW_SM(Mh,.True.)
end function SMCS_lhc8_HW
!*********************************
function SMCS_lhc8_HZ(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc8_HZ

  call testBRSM(Mh)

  SMCS_lhc8_HZ=XS_lhc8_HZ_SM(Mh,.True.)
end function SMCS_lhc8_HZ
!*********************************
function SMCS_lhc8_gg_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc8_gg_H

  call testBRSM(Mh)

  SMCS_lhc8_gg_H=XS_lhc8_gg_H_SM(Mh,.True.)
end function SMCS_lhc8_gg_H
!*********************************
function SMCS_lhc8_bb_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc8_bb_H

  call testBRSM(Mh)

  SMCS_lhc8_bb_H=XS_lhc8_bb_H_SM(Mh,.True.)
end function SMCS_lhc8_bb_H
!*********************************
function SMCS_lhc8_vbf_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc8_vbf_H

  call testBRSM(Mh)

  SMCS_lhc8_vbf_H=XS_lhc8_vbf_SM(Mh,.True.)
end function SMCS_lhc8_vbf_H
!*********************************
function SMCS_lhc8_ttH(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc8_ttH

  call testBRSM(Mh)

  SMCS_lhc8_ttH=XS_lhc8_ttH_SM(Mh,.True.)
end function SMCS_lhc8_ttH
!*********************************

function SMCS_lhc13_HW(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc13_HW

  call testBRSM(Mh)

  SMCS_lhc13_HW=XS_lhc13_HW_SM(Mh,.True.)
end function SMCS_lhc13_HW
!*********************************
function SMCS_lhc13_HZ(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc13_HZ

  call testBRSM(Mh)

  SMCS_lhc13_HZ=XS_lhc13_HZ_SM(Mh,.True.)
end function SMCS_lhc13_HZ
!*********************************
function SMCS_lhc13_gg_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc13_gg_H

  call testBRSM(Mh)

  SMCS_lhc13_gg_H=XS_lhc13_gg_H_SM(Mh,.True.)
end function SMCS_lhc13_gg_H
!*********************************
function SMCS_lhc13_bb_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc13_bb_H

  call testBRSM(Mh)

  SMCS_lhc13_bb_H=XS_lhc13_bb_H_SM(Mh,.True.)
end function SMCS_lhc13_bb_H
!*********************************
function SMCS_lhc13_vbf_H(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc13_vbf_H

  call testBRSM(Mh)

  SMCS_lhc13_vbf_H=XS_lhc13_vbf_SM(Mh,.True.)
end function SMCS_lhc13_vbf_H
!*********************************
function SMCS_lhc13_ttH(Mh)
!note: in pb
 use theory_XS_SM_functions
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_lhc13_ttH

  call testBRSM(Mh)

  SMCS_lhc13_ttH=XS_lhc13_ttH_SM(Mh,.True.)
end function SMCS_lhc13_ttH
!*********************************
subroutine testBRSM(M)
  use theory_BRfunctions
  implicit none
  double precision,intent(in) :: M

  if(.not.allocated(BRSM))then
   write(*,*)'You can only use this function between'
   write(*,*)'calling the subroutines'
   write(*,*)'initialize_HiggsBounds and'
   write(*,*)'finish_HiggsBounds'
   stop 'error (see standard output for more info)'
  endif

  !if(M.gt.0.0D0)then
   !ok
  !else !M is negative or NaN
  ! stop 'wrong mass given to function'
  !endif
end subroutine testBRSM
!*********************************
! OLD FUNCTIONS
!*********************************
function SMCS_tev_qq_HZ(Mh)
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_qq_HZ
  double precision :: SMCS_tev_HZ

  write(*,*)'Note: function SMCS_tev_qq_HZ has been'
  write(*,*)'superceded by function SMCS_tev_HZ'
  SMCS_tev_qq_HZ=SMCS_tev_HZ(Mh)

end function SMCS_tev_qq_HZ
!*********************************
function SMCS_tev_qq_HW(Mh)
  implicit none
  double precision,intent(in) :: Mh
  double precision :: SMCS_tev_qq_HW
  double precision :: SMCS_tev_HW

  write(*,*)'Note: function SMCS_tev_qq_HW has been'
  write(*,*)'superceded by function SMCS_tev_HW'
  SMCS_tev_qq_HW=SMCS_tev_HW(Mh)

end function SMCS_tev_qq_HW
!*********************************


      subroutine sigte3 (iz1,iz2, sig2, alphat, thetad, reff, sig1,sig3)
c     single scattering only.

c     input: sig2
c     iz1, iz2 are iz at central atom and neighbor
c     alphat coeef of thermal expansion at high T
c     reff

c     output: sig1 sig3
      implicit double precision (a-h, o-z)
      real reff

c     con=hbar**2/kB*amu)*10**20   in ang**2 units
c     hbar = 1.054 572 666 e-34, amu = 1.660 540 e-27,
c     kB = 1.380 6581 d-23
      parameter (con = 48.508 459 393 094)
      parameter (hbar = 1.054 572 666 e-34)
      parameter (amu = 1.660 540 e-27)
      parameter (xkb = 1.380 6581 e-23)

      ami=atwtd(iz1)*amu
      amj=atwtd(iz2)*amu

c     reduced mass
      xmu = 1 / (1/ami + 1/amj)
c     Einstein frequency
      omega = (2 * xkb * thetad) / (3 * hbar)
      xks = xmu * omega**2
      xk3 = xks**2 * reff * alphat / (3 * xkb)
      sig02 = hbar * omega / xks
      sig1 = -3 * (xk3 / xks) * sig2
      sig3 = 2 - (4.0/3.0) * (sig02 / sig2)**2
      sig3 = sig3 * (sig1 * sig2)

      return
      end


      SUBROUTINE SETK01(NA,A,PTK,NPTK,IDEF,NTET,NKMAX,NTMAX)
C     SET THE K-POINTS IN THE IRREDUCTIBLE WEDGE OF THE BRILLOUIN ZONE
C     FOR A SIMPLE CUBIC LATTICE WITH DIRECT LATTICE PARAMETER A,
C     SYMMETRY IS OH
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*4 AVOL
      DIMENSION PTK(4,NKMAX),IDEF(5,NTMAX)
      EQUIVALENCE (IVOL,AVOL)
      PI = 3.141592653589793238D0
      IF(NA.LE.0) GOTO 97
      IF(A.LE.0.0D0) GOTO 98
      NPTK = (NA+1)*(NA+2)*(NA+3)/6
      IF(NPTK.GT.NKMAX) STOP '*** <SETK01> NPTK EXCEEDS NKMAX ***'
      NTET = NA**3
      IF(NTET.GT.NTMAX) STOP '*** <SETK01> NTET EXCEEDS NTMAX ***'
C *** SET THE K-POINTS
      DK=PI/A/NA
      N=NA
      WRITE(6,100) NPTK,NTET,N*DK,N*DK,N*DK
      W = 6.0D0/NA**3
      NPTK=0
      I=0
    1 J=0
    2 K=0
    3 NPTK=NPTK+1
C          NPTK = I*(I+1)*(I+2)/6 + J*(J+1)/2 + K + 1
      WK = W
      IF(I.EQ.J .OR. J.EQ.K .OR. K.EQ.I) WK = WK/2.0D0
      IF(I.EQ.J .AND. J.EQ.K) WK = WK/3.0D0
      IF(K.EQ.0) WK = WK/2.0D0
      IF(J.EQ.0) WK = WK/2.0D0
      IF(J.EQ.NA) WK = WK/2.0D0
      IF(I.EQ.NA) WK = WK/2.0D0
      PTK(1,NPTK)=DFLOAT(I)*DK
      PTK(2,NPTK)=DFLOAT(J)*DK
      PTK(3,NPTK)=DFLOAT(K)*DK
      PTK(4,NPTK) = WK
      K=K+1
      IF(K.LE.J) GOTO 3
      J=J+1
      IF(J.LE.I) GOTO 2
      I=I+1
      IF(I.LE.N) GOTO 1
      PTK(4,1) = W/48.0D0
      PTK(4,NPTK) = W/48.0D0
C *** DEFINE THE TETRAHEDRA
      NTET=0
      I7=0
      I=0
    4 IX=(I+1)*(I+2)/2
      J=0
    5 K=0
    6 I7=I7+1
      I6=I7+IX
      I2=I6+J+1
      I1=I2+1
      I8=I7+1
      I5=I6+1
      I3=I7+J+1
      I4=I3+1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I6
      IDEF(3,NTET)=I2
      IDEF(4,NTET)=I1
      IF(K.EQ.J) GOTO 7
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I6
      IDEF(3,NTET)=I5
      IDEF(4,NTET)=I1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I8
      IDEF(3,NTET)=I5
      IDEF(4,NTET)=I1
    7 IF(J.EQ.I) GOTO 8
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I3
      IDEF(3,NTET)=I2
      IDEF(4,NTET)=I1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I3
      IDEF(3,NTET)=I4
      IDEF(4,NTET)=I1
      IF(K.EQ.J) GOTO 8
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I8
      IDEF(3,NTET)=I4
      IDEF(4,NTET)=I1
    8 K=K+1
      IF(K.LE.J) GOTO 6
      J=J+1
      IF(J.LE.I) GOTO 5
      I=I+1
      IF(I.LT.N) GOTO 4
      AVOL=1.0D0/DFLOAT(NTET)
      DO 15 IT=1,NTET
   15 IDEF(5,IT)=IVOL
      RETURN
   97 WRITE(6,101)
      GOTO 99
   98 WRITE(6,102)
   99 STOP
  100 FORMAT(' SAMPLING THE 48TH PART OF THE B.Z. OF THE',
     ,' SIMPLE CUBIC LATTICE'/1X,I5,' K-POINTS',I7,' TETRAHEDRA'/
     .' KXMAX =',D11.4,'  KYMAX =',D11.4,'  KZMAX =',D11.4)
  101 FORMAT(' *** <SETK01> NA IS NOT A POSITIVE INTEGER ***')
  102 FORMAT(' *** <SETK01> A IS NOT A POSITIVE NUMBER ***')
      END


      subroutine dchud(r,ldr,p,x,z,ldz,nz,y,rho,c,s)
      integer ldr,p,ldz,nz
      double precision rho(nz),c(p)
      double precision r(ldr,p),x(p),z(ldz,nz),y(nz),s(p)
c
c     By G. W. Stewart.  Patched to pass array bounds checks by
c     Madeleine Thompson.  In the public domain in the United States.
c
c     dchud updates an augmented cholesky decomposition of the
c     triangular part of an augmented qr decomposition.  specifically,
c     given an upper triangular matrix r of order p, a row vector
c     x, a column vector z, and a scalar y, dchud determines a
c     untiary matrix u and a scalar zeta such that
c
c
c                              (r  z)     (rr   zz )
c                         u  * (    )  =  (        ) ,
c                              (x  y)     ( 0  zeta)
c
c     where rr is upper triangular.  if r and z have been
c     obtained from the factorization of a least squares
c     problem, then rr and zz are the factors corresponding to
c     the problem with the observation (x,y) appended.  in this
c     case, if rho is the norm of the residual vector, then the
c     norm of the residual vector of the updated problem is
c     dsqrt(rho**2 + zeta**2).  dchud will simultaneously update
c     several triplets (z,y,rho).
c     for a less terse description of what dchud does and how
c     it may be applied, see the linpack guide.
c
c     the matrix u is determined as the product u(p)*...*u(1),
c     where u(i) is a rotation in the (i,p+1) plane of the
c     form
c
c                       (     c(i)      s(i) )
c                       (                    ) .
c                       (    -s(i)      c(i) )
c
c     the rotations are chosen so that c(i) is double precision.
c
c     on entry
c
c         r      double precision(ldr,p), where ldr .ge. p.
c                r contains the upper triangular matrix
c                that is to be updated.  the part of r
c                below the diagonal is not referenced.
c
c         ldr    integer.
c                ldr is the leading dimension of the array r.
c
c         p      integer.
c                p is the order of the matrix r.
c
c         x      double precision(p).
c                x contains the row to be added to r.  x is
c                not altered by dchud.
c
c         z      double precision(ldz,nz), where ldz .ge. p.
c                z is an array containing nz p-vectors to
c                be updated with r.
c
c         ldz    integer.
c                ldz is the leading dimension of the array z.
c
c         nz     integer.
c                nz is the number of vectors to be updated
c                nz may be zero, in which case z, y, and rho
c                are not referenced.
c
c         y      double precision(nz).
c                y contains the scalars for updating the vectors
c                z.  y is not altered by dchud.
c
c         rho    double precision(nz).
c                rho contains the norms of the residual
c                vectors that are to be updated.  if rho(j)
c                is negative, it is left unaltered.
c
c     on return
c
c         rc
c         rho    contain the updated quantities.
c         z
c
c         c      double precision(p).
c                c contains the cosines of the transforming
c                rotations.
c
c         s      double precision(p).
c                s contains the sines of the transforming
c                rotations.
c
c     linpack. this version dated 08/14/78 .
c     g.w. stewart, university of maryland, argonne national lab.
c
c     dchud uses the following functions and subroutines.
c
c     extended blas drotg
c     fortran dsqrt
c
      integer i,j,jm1
      double precision azeta,scale
      double precision t,xj,zeta
c
c     update r.
c
      do 30 j = 1, p
         xj = x(j)
c
c        apply the previous rotations.
c
         jm1 = j - 1
         if (jm1 .lt. 1) go to 20
         do 10 i = 1, jm1
            t = c(i)*r(i,j) + s(i)*xj
            xj = c(i)*xj - s(i)*r(i,j)
            r(i,j) = t
   10    continue
   20    continue
c
c        compute the next rotation.
c
         call drotg(r(j,j),xj,c(j),s(j))
   30 continue
c
c     if required, update z and rho.
c
      if (nz .lt. 1) go to 70
      do 60 j = 1, nz
         zeta = y(j)
         do 40 i = 1, p
            t = c(i)*z(i,j) + s(i)*zeta
            zeta = c(i)*zeta - s(i)*z(i,j)
            z(i,j) = t
   40    continue
         azeta = dabs(zeta)
         if (azeta .eq. 0.0d0 .or. rho(j) .lt. 0.0d0) go to 50
            scale = azeta + rho(j)
            rho(j) = scale*dsqrt((azeta/scale)**2+(rho(j)/scale)**2)
   50    continue
   60 continue
   70 continue
      return
      end


!=============================================================================!
	program pre
!
!  This is a pre processor for the LNS code.  It takes a plot3d grid
!  file as input and computes the metric file needed for LNS.
!
!  Revised:  10-12-00    Switched order of indices, removed B-splines
!
!=============================================================================!
	use const
	implicit none

	integer :: i, j, k, ier, ians
	integer :: nx, ny, nz

	real, allocatable :: xy(:,:,:),  g1xy(:,:,:), g2xy(:,:,:)
	real, allocatable :: g11xy(:,:,:), g12xy(:,:,:), g22xy(:,:,:)
	real, allocatable :: g1m(:,:,:), g2m(:,:,:)
	real, allocatable :: g1n(:,:,:), g2n(:,:,:)
	real, allocatable :: xi(:),      eta(:),      IdetJ(:,:)
	real, allocatable :: m(:,:,:),   m11(:,:),    m12(:,:),     m22(:,:)
	real, allocatable :: n(:,:,:),   n11(:,:),    n12(:,:),     n22(:,:)
	real, allocatable :: q(:,:,:)

	real, allocatable :: f(:,:)
	real, allocatable :: g1(:,:), g2(:,:), g1l(:,:), g2l(:,:)
	real, allocatable :: g11(:,:),  g12(:,:),  g22(:,:)
	real, allocatable :: g11l(:,:), g12l(:,:), g22l(:,:)

	real :: dxi, deta, tmp, kappa

	character*80 :: name, filen

        integer :: optx = -1, opty = -1
	logical :: xper = .false., yper = .false.
        logical :: lsym = .false., rsym = .false.
        logical :: tsym = .false., bsym = .false.
        logical :: carp = .false.

!=============================================================================!
	write(*,"('Hardwire periodicity (1,0) ==> ',$)")
	read(*,*) ians
	if (ians.eq.1) then
	  xper = .true.
	else
	  xper = .false.
	end if

!.... read the physical grid file

 10     filen = 'grid.dat'
	write (*,"('Enter unformatted grid file name [',a,']? ',$)") &
     		    filen(1:index(filen,' '))
	read (*,"(a20)") name
	if (name(1:1) .ne. ' ') filen = name

!.... allocate memory for the physical grid

	open (unit=10, file=filen, form='unformatted', status='unknown')
	read(10) nx, ny, nz
	write(*,"('Nx = ',i4,', Ny = ',i4)") nx, ny
	allocate (xy(2,nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$', &
	    'Insufficient Memory for phys. grid$')
	read(10) (((xy(1,i,j), i = 1, nx), j = 1, ny), k = 1, nz), &
	         (((xy(2,i,j), i = 1, nx), j = 1, ny), k = 1, nz), &
	         (((      tmp, i = 1, nx), j = 1, ny), k = 1, nz)
	close(10)

!.... allocate memory for the computational grid

	allocate (xi(nx), eta(ny), STAT=ier)
	if (ier .ne. 0) call error('pre$', &
	   'Insufficient Memory for comp. grid$')

!.... make the computational grid

	dxi  = one / float(nx-1)
	deta = one / float(ny-1)

	do i = 1, nx
	  xi(i) = (i-1) * dxi
	end do

	do j = 1, ny
	  eta(j) = (j-1) * deta
	end do

!.... allocate space for first derivatives

	allocate (g1xy(2,nx,ny), g2xy(2,nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for gxy$')

!.... compute first derivative metrics using finite differences

	call grad(2, nx, ny, xy, g1xy, g2xy, dxi, deta, optx, opty, &
                  xper, yper, lsym, rsym, bsym, tsym, carp)

!.... form the determinate of the jacobian

	allocate (IdetJ(nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for detJ$')

	IdetJ(:,:) = one / ( g1xy(1,:,:) * g2xy(2,:,:) - &
	                     g2xy(1,:,:) * g1xy(2,:,:) )

!.... allocate memory for the grid metrics

	allocate( m(2,nx,ny),  m11(nx,ny), m12(nx,ny), m22(nx,ny), &
	          n(2,nx,ny),  n11(nx,ny), n12(nx,ny), n22(nx,ny), &
		  STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for metrics$')

!.... form the first derivative metrics

	m(1,:,:) =  g2xy(2,:,:) * IdetJ
	n(1,:,:) = -g1xy(2,:,:) * IdetJ
	m(2,:,:) = -g2xy(1,:,:) * IdetJ
	n(2,:,:) =  g1xy(1,:,:) * IdetJ

	allocate (g1m(2,nx,ny), g2m(2,nx,ny), &
	          g1n(2,nx,ny), g2n(2,nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for gm and gn$')

!.... compute second derivatives of x using finite differences

	allocate (g11xy(2,nx,ny), g12xy(2,nx,ny), g22xy(2,nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for gxy$')

	call grad(2, nx, ny, g1xy, g11xy, g12xy, dxi, deta, &
	          optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)
	call grad(2, nx, ny, g2xy, g12xy, g22xy, dxi, deta, &
	          optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)

!.... compute second derivative metrics using finite difference

	call grad(2, nx, ny, m, g1m, g2m, dxi, deta, &
	          optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)

	call grad(2, nx, ny, n, g1n, g2n, dxi, deta, &
	          optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)

 	m11 = m(1,:,:) * g1m(1,:,:) + n(1,:,:) * g2m(1,:,:)
 	n11 = m(1,:,:) * g1n(1,:,:) + n(1,:,:) * g2n(1,:,:)

 	m22 = m(2,:,:) * g1m(2,:,:) + n(2,:,:) * g2m(2,:,:)
 	n22 = m(2,:,:) * g1n(2,:,:) + n(2,:,:) * g2n(2,:,:)

	m12 = m(1,:,:) * g1m(2,:,:) + n(1,:,:) * g2m(2,:,:)
	n12 = m(1,:,:) * g1n(2,:,:) + n(1,:,:) * g2n(2,:,:)

	j = 1
	do i = 1, nx
	  write(55,21) xy(1,i,j), m12(i,j), &
	              m(2,i,j)*g1m(1,i,j)+n(2,i,j)*g2m(1,i,j), &
		      m12(i,j) - (m(2,i,j)*g1m(1,i,j)+n(2,i,j)*g2m(1,i,j)), &
		      m(1,i,j)*g2m(1,i,j)+m(2,i,j)*g2m(2,i,j), &
		      n(1,i,j)*g1n(1,i,j)+n(2,i,j)*g1n(2,i,j)
	  write(56,21) xy(1,i,j), n(1,i,j), n(2,i,j), n11(i,j), n12(i,j), &
	               n22(i,j)
 21	  format(7(1pe14.7,1x))
	end do

	deallocate( g1m, g2m, g1n, g2n )

!.... write out the metric file

        filen = 'metric.new'
 	write (*,"('Enter grid metric file name [',a,']? ',$)") &
     		    filen(1:index(filen,' '))
	read (*,"(a20)") name
	if (name(1:1) .ne. ' ') filen = name
	open (unit=10, file=filen, form='unformatted', status='unknown')
	write(10) m(1,:,:), m(2,:,:), n(1,:,:), n(2,:,:), &
	          m11, m12, m22, n11, n12, n22
	close(10)

!.... write out plot3d files

	allocate (q(5,nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for q$')

	q(1,:,:) = m(1,:,:)
	q(2,:,:) = n(1,:,:)
	q(3,:,:) = m(2,:,:)
	q(4,:,:) = n(2,:,:)
	q(5,:,:) = IdetJ

!.... diagnostic

	j = 1
	do i = 1, nx
	  write(54,21) xy(1,i,j), &
	             (-m(1,i,j)*m(2,i,j)*m11(i,j) + m(1,i,j)**2*m12(i,j) - &
	             m(2,i,j)**2*m12(i,j) + m(1,i,j)*m(2,i,j)*m22(i,j) ) * &
		     sqrt(n(1,i,j)**2 + n(2,i,j)**2) / 			&
		     sqrt(m(1,i,j)**2 + m(2,i,j)**2) /			&
		     (m(1,i,j)*n(2,i,j)-m(2,i,j)*n(1,i,j)), 		&
		     (n(1,i,j)*n(2,i,j)*n11(i,j) - n(1,i,j)**2*n12(i,j) + &
	             n(2,i,j)**2*n12(i,j) - n(1,i,j)*n(2,i,j)*n22(i,j) ) * &
		     sqrt(m(1,i,j)**2 + m(2,i,j)**2) / 			&
		     sqrt(n(1,i,j)**2 + n(2,i,j)**2) / 			&
		     (m(1,i,j)*n(2,i,j)-m(2,i,j)*n(1,i,j))
	end do

	name = 'm1.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	q(1,:,:) = m(1,:,:) - 2.0 * xy(2,:,:) / ( acos(-1.0) * &
	                      ( (xy(1,:,:)-0.1)**2 + xy(2,:,:)**2 ) )
	q(2,:,:) = n(1,:,:) - (xy(1,:,:) - 0.1) / sqrt( (xy(1,:,:)-0.1)**2 + &
	                       xy(2,:,:)**2 )
	q(3,:,:) = m(2,:,:) - 2.0 * (0.1 - xy(1,:,:)) / ( acos(-1.0) * &
	                      ( (xy(1,:,:)-0.1)**2 + xy(2,:,:)**2 ) )
	q(4,:,:) = n(2,:,:) - xy(2,:,:) / sqrt( (xy(1,:,:)-0.1)**2 + &
	                      xy(2,:,:)**2 )
	q(5,:,:) = IdetJ

	name = 'error.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	q(1,:,:) = m11
	q(2,:,:) = m12
	q(3,:,:) = m12
	q(4,:,:) = m22
	q(5,:,:) = IdetJ

	name = 'm11.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	q(1,:,:) = n11
	q(2,:,:) = n12
	q(3,:,:) = n12
	q(4,:,:) = n22
	q(5,:,:) = IdetJ

	name = 'n11.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	q(1,:,:) = g11xy(1,:,:)
	q(2,:,:) = g11xy(2,:,:)
	q(3,:,:) = g12xy(1,:,:)
	q(4,:,:) = g12xy(2,:,:)
	q(5,:,:) = g22xy(1,:,:)

	name = 'grad.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	deallocate( g1xy, g2xy)

!.... write out the derivatives on the body

	write(*,"('Enter j ==> ',$)")
	read(*,*) j
	do i = 1, nx
	  write(50,20) xi(i), m(1,i,j), m(2,i,j)
	  write(51,20) xi(i), n(1,i,j), n(2,i,j)
	  write(52,20) xi(i), m11(i,j), n11(i,j), m22(i,j), m12(i,j), n12(i,j)
	  write(53,20) xi(i), IdetJ(i,j), one / Idetj(i,j)
	end do

!==============================================================================
!
! Test the derivative operators
!
!==============================================================================

!.... put a sine wave on the mesh

	allocate (f(nx,ny), g1l(nx,ny), g2l(nx,ny), g1(nx,ny), g2(nx,ny), &
             STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for function$')

	kappa = two * pi / 2.5
	f(:,:) = sin( kappa * xy(1,:,:))

!.... compute the gradient with finite differences

	call grad( 1, nx, ny, f, g1l, g2l, dxi, deta, &
	           optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)

!.... transform to physical coordinates

	g1 = g1l(:,:) * m(1,:,:) + g2l(:,:) * n(1,:,:)
	g2 = g1l(:,:) * m(2,:,:) + g2l(:,:) * n(2,:,:)

	q(1,:,:) = f
	q(2,:,:) = g1 / kappa
	q(3,:,:) = g2
	q(4,:,:) = abs(g1 - kappa * cos( kappa * xy(1,:,:) ) )
	q(5,:,:) = abs(g2 - zero)

	name = 'f.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	deallocate( g1, g2)

!... allocate memory for second derivatives

	allocate (g11(nx,ny),  g12(nx,ny),  g22(nx,ny), &
	          g11l(nx,ny), g12l(nx,ny), g22l(nx,ny), STAT=ier)
	if (ier .ne. 0) call error('pre$','Insufficient Memory for g2$')

!.... compute second derivatives using finite differencs

	call grad2( 1, nx, ny, f, g1l, g11l, g12l, g22l, dxi, deta, &
	            optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)

	g11  =  g11l(:,:)        * m(1,:,:) * m(1,:,:)	+ &
		two * g12l(:,:)  * m(1,:,:) * n(1,:,:) 	+ &
		g22l(:,:)        * n(1,:,:) * n(1,:,:)	+ &
		g1l(:,:)         * m11(:,:)    		+ &
		g2l(:,:)         * n11(:,:)

	g12  =  g11l(:,:)        * m(1,:,:) * m(2,:,:)	+ &
		g12l(:,:)        * m(1,:,:) * n(2,:,:)	+ &
		g12l(:,:)        * m(2,:,:) * n(1,:,:) 	+ &
		g22l(:,:)        * n(1,:,:) * n(2,:,:)	+ &
		g1l(:,:)         * m12(:,:)		+ &
		g2l(:,:)         * n12(:,:)

	g22  =  g11l(:,:)        * m(2,:,:) * m(2,:,:)	+ &
		two * g12l(:,:)  * m(2,:,:) * n(2,:,:)	+ &
		g22l(:,:)        * n(2,:,:) * n(2,:,:)	+ &
		g1l(:,:)         * m22(:,:)		+ &
		g2l(:,:)         * n22(:,:)

	q(1,:,:) = g11 / kappa**2
	q(2,:,:) = g12
	q(3,:,:) = g22
	q(4,:,:) = abs(g11/kappa**2 + sin( kappa * xy(1,:,:) ) )
	q(5,:,:) = zero

	name = 'g2.dat'
	call wdata(name, q, nx, ny, 1, 5, 0.0, 0.0, 0.0, 0.0)

	stop

 20	format(8(1pe13.6,1x))

	end