      SUBROUTINE wtn(a,nn,ndim,isign,wtstep)
      INTEGER isign,ndim,nn(ndim),NMAX
      REAL a(*)
      EXTERNAL wtstep
      PARAMETER (NMAX=1024)
CU    USES wtstep
      INTEGER i1,i2,i3,idim,k,n,nnew,nprev,nt,ntot
      REAL wksp(NMAX)
      ntot=1
      do 11 idim=1,ndim
        ntot=ntot*nn(idim)
11    continue
      nprev=1
      do 16 idim=1,ndim
        n=nn(idim)
        nnew=n*nprev
        if (n.gt.4) then
          do 15 i2=0,ntot-1,nnew
            do 14 i1=1,nprev
              i3=i1+i2
              do 12 k=1,n
                wksp(k)=a(i3)
                i3=i3+nprev
12            continue
              if (isign.ge.0) then
                nt=n
1               if (nt.ge.4) then
                call wtstep(wksp,nt,isign)
                nt=nt/2
                goto 1
                endif
              else
                nt=4
2               if (nt.le.n) then
                call wtstep(wksp,nt,isign)
                nt=nt*2
                goto 2
                endif
              endif
              i3=i1+i2
              do 13 k=1,n
                a(i3)=wksp(k)
                i3=i3+nprev
13            continue
14          continue
15        continue
        endif
        nprev=nnew
16    continue
      return
      END

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


c     program DRDZERO
c>> 1995-05-28 DRDZERO  Krogh  Changes to use M77CON
c>> 1993-05-05 DRDZERO  Krogh  Adjusted to simplify conversion to C.
c>> 1992-03-24 DRDZERO  Krogh  Added "," to format statmement.
c>> 1991-11-25 DRDZERO  Krogh  Cleaned up Fortran version.
c>> 1987-12-09 DRDZERO  Krogh  Initial Code.
c--D replaces "?": DR?ZERO, ?ZERO
c     Demo driver for DZERO.  Univariate zero finder.
c     F. T. Krogh, Sept. 1987.
c     ------------------------------------------------------------------
      double precision X1, X2, F1, F2, A, B, TOL, TWO, EIGHT
      parameter(A = 0.0D0, B = 4.0D0, TOL = 0.0D0)
      parameter(TWO = 2.0D0, EIGHT = 8.0D0)
      integer MODE
   10 format(' Results from subroutine DZERO:'/'    MODE = ', I3/
     *'    Solution:        X1 = ',F11.8/
     *'                  f(X1) = ',1P,G11.3/
     *'    Accuracy:   X1 - X2 = ',G11.3/
     *'                  f(X2) = ',G11.3)
c     ------------------------------------------------------------------
      write(*,'(1x,a)')
     * 'DRDZERO.. Demo driver for DZERO, univariate zero finder.',
     * 'Problem: Find zero of 2**X - 8.   Exact result: X = 3.'
      X2 = B
      F2 = TWO**X2 - EIGHT
      MODE = 0
      X1 = A
   20 F1 = TWO**X1 - EIGHT
      call DZERO(X1, F1, X2, F2, MODE, TOL)
      if ( MODE .eq. 1) go to 20
      write(*,10) MODE, X1, F1, X1-X2, F2
      stop
      end


module sort_n_swap
    implicit none
contains
    function std(x, n)
        real(8), dimension(:,:), intent(in) :: x
        integer, intent(in) :: n
        real(8), dimension(n) :: std
        real(8), dimension(n) :: mean
        integer :: s, i
        s = size(x, 2)
        do i=1,n
            mean(i) = sum(x(i,:)) / s
            std(i) = sqrt(sum((x(i,:) - mean(i))**2)) / s
        end do
    end function std

    function argsort3(x) result(idx)
        real(8), dimension(3), intent(in) :: x
        integer, dimension(3) :: idx
        idx = [1, 2, 3]
        if (x(1) > x(2)) call swapi(idx(1), idx(2))
        if (x(2) > x(3)) call swapi(idx(2), idx(3))
        if (x(1) > x(2)) call swapi(idx(1), idx(2))
    end function

    subroutine sort3r(x, z)
        real(8), dimension(3) :: z
        real(8), dimension(2, 3) :: x
        if (z(1) > z(2)) then
            call swapr(x(1,1), x(1,2))
            call swapr(x(2,1), x(2,2))
            call swapr(z(1), z(2))
        end if
        if (z(2) > z(3)) then
            call swapr(x(1,2), x(1,3))
            call swapr(x(2,2), x(2,3))
            call swapr(z(2), z(3))
        end if
        if (z(1) > z(2)) then
            call swapr(x(1,1), x(1,2))
            call swapr(x(2,1), x(2,2))
            call swapr(z(1), z(2))
        end if
    end subroutine sort3r

    subroutine swapr(a, b)
        real(8) :: a, b, t
        t = a
        a = b
        b = t
    end subroutine swapr

    subroutine swapi(a, b)
        integer :: a, b, t
        t = a
        a = b
        b = t
    end subroutine

end module sort_n_swap


INTEGER FUNCTION jd (year,month,day)

!---COMPUTES THE JULIAN DATE (JD) GIVEN A GREGORIAN CALENDAR DATE (YEAR,MONTH,DAY).

IMPLICIT NONE

INTEGER :: year,month,day,i,j,k

i = year
j = month
k = day

jd = k - 32075 + 1461*(i+4800+(j-14)/12)/4 + 367*(j-2-(j-14)/12*12)/12-3*((i+4900+(j-14)/12)/100)/4

RETURN

END


!>  Example of partitioning a mesh composed of 4 quadrilaterals and 9 nodes
!   based upon its nodal graph.
!
!   Source: https://www.cfd-online.com/Forums/main/112366-using-metis-functions-fortran.html#post404734
!
program test_PartMeshNodal2

    use metis_interface, only: idx_t, METIS_SetDefaultOptions, METIS_PartMeshNodal, METIS_NOPTIONS, &
        METIS_OPTION_NUMBERING, METIS_OPTION_CONTIG, METIS_OK
    implicit none

    integer(idx_t), parameter :: ne = 4    ! number of elements
    integer(idx_t), parameter :: nn = 9    ! number of nodes

    integer(idx_t) :: eptr(ne+1), eind(4*ne)   ! arrays storing mesh structure
    integer(idx_t) :: epart(ne), npart(nn)     ! element and node partition vectors

    integer(idx_t) :: opts(0:METIS_NOPTIONS-1), ios, objval, nparts

    write(*,'(A)') "TEST METIS_PartMeshNodal2"

    !  1---2---5
    !  | 1 | 2 |
    !  4---3---6
    !  | 4 | 3 |
    !  9---8---7

    eptr = [1,5,9,13,17]
    eind = [1,2,3,4,&
            2,5,6,3,&
            3,6,7,8,&
            4,3,8,9]

    ios = METIS_SetDefaultOptions(opts)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_SetDefaultOptions failed with error: ", ios
        error stop 1
    end if
    opts(METIS_OPTION_NUMBERING) = 1    ! Fortran-style numbering
    opts(METIS_OPTION_CONTIG) = 1       ! Force contigous partitions
    ! call print_metis_options(opts)

    nparts = 2
    ios = METIS_PartMeshNodal(ne,nn,eptr,eind,nparts=nparts,options=opts, &
            objval=objval,epart=epart,npart=npart)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_PartMeshNodal failed with error: ", ios
        error stop 1
    end if

    write(*,'(A,I0)') "objval = ", objval
    write(*,'(A,*(I1,:,1X))') "epart = ", epart
    write(*,'(A,*(I1,:,1X))') "npart = ", npart

end program


c=======================================================================
c
c     subroutine RNLS
c
c     Robust Non-Linear Least-Square Solver
c
c-----------------------------------------------------------------------
      SUBROUTINE rnls ( simext, mxpar, xini, nfct, moyobs, covobs,
     &                  skobs, spadim, grid, epsbfg,
     &                  liudat, iudata, ldudat, dudata,
     &                  iwork, dwork,
     &                  xopt, fxopt, gxopt, lopt, glopt, info )
c-----------------------------------------------------------------------
c     INPUT :
c            simext : entry point of an external subroutine
c                     provided by the user
c            mxpar  : number of parameters to find               integer
c            xini   : initial solution (mxpar)                    double
c            nfct   : number of functions (observations)         integer
c            moyobs : mean observations (nfct)                    double
c            covobs : covariance matrix of observations
c                     vectorized matrix(nfct*nfct)                double
c            skobs  : stress coefficient of observations          double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            epsbfg : BFGS precision stop test                    double
c            liudat : size of integer user data for SIMEXT       integer
c            iudata : integer user data for SIMEXT               integer
c                     vector(liudat)
c            ldudat : size of double prec. user data for SIMEXT  integer
c            dudata : double precision user data for SIMEXT       double
c                     vector(ldudat)
c
c     WORKSPACE :
c            iwork  : workspace                                  integer
c                     vector( 2*mxopt + 6 + 12*nfct + liudat )
c            dwork  : double precision  workspace                 double
c                     vector(  mxopt*(mxopt+19)/2
c                            + nfct*(7*nfct+mxpar+spadim+33)
c                            + 2 + ldudat )
c                     with mxopt = mxpar + 1
c
c     OUTPUT :
c            xopt   : optimal point (mxpar)                       double
c            fxopt  : function value at optimal point             double
c            gxopt  : gradient value at optimal point (mxpar)     double
c            lopt   : optimal Lagragian value                     double
c            glopt  : Lagrangian gradient value at optimal        double
c            info   : = 0 successful exit                        integer
c
c     CALL   :
c        IVX     : initialization at a scalar of a vector
c        INIRNLS : initial computing of RNLS
c        YV      : copy a vector in a vector
c        YVI     : copy a vector of integers in a vector of integers
c        PMV     : computing M*V = vector
c                  ( M matrix(n*m), V vector(m), gives M*V vector(n) )
c        BFGSBOXS: quasi-Newton optimizer with BFGS method
c                  ( short call version )
c        SIMRNLS : subroutine used by BFGS to compute the value of the
c                  function and its gradient
c
c-----------------------------------------------------------------------
c
c     SIMEXT SIGNATURE :
c
c     INPUT :
c            nfct   : number of functions                        integer
c            mxopt  : size of the vector solution                integer
c            xopt   : optimal solution (mxopt)                    double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            liudat : size of integers data provided by the user integer
c            iusdat : integers user data provided by the user
c                     vector(liudat)                             integer
c            ldudat : size of doubles data provided by the user  integer
c            dusdat : doubles user data provided by the user
c                     vector(ldudat)                              double
c
c     OUTPUT :
c            funct  : functions   vector(nfct)                    double
c            jacob  : jacobian    matrix(nfct*mx)                 double
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      implicit none
c
      external simext, simrnls, inirnls, bfgsboxs, YV, YVI, IVX
c
      integer mxpar, nfct, spadim, liudat, ldudat, info
      double precision skobs, epsbfg
      integer iudata(*)
      double precision dudata(*)
      double precision moyobs(*), xini(*), grid(*), covobs(nfct,*)
      double precision xopt(*), fxopt, gxopt(*), lopt, glopt
c
      integer iwork(*)
      double precision dwork(*)
c
c-----------------------------------------------------------------------
c     local variables
      integer mxopt, totitr, totsim
      integer piwbf, pnfct, pspad, pliu, pldu, pinfo, piwu
      integer pxopt, pbinf, pbsup, pgrad, pdwbf, pwsnls, pwsext
      integer piwini, pdwini, pxini
      integer pgrid, psk, palpha, pbeta, pvp, prspec, prcov, pdwu
      double precision inilam, lplus, infini, eigmax
c
      parameter ( inilam = 10.0, lplus = 0.7, infini = 1.d20 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info  = 0
      fxopt = 0
      lopt  = 0
      glopt = 0
      mxopt = mxpar + 1
      call YV ( mxpar, xini, gxopt )
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwini = 1
c     piwini : pointer for INIRNLS who needs (12*nfct), so 12*nfct more
      piwbf  = piwini + 12*nfct
c     piwbf  : pointer for BFGSBOXS who needs (2*mxopt + 1),
c              so (2*mxopt + 1) more
      pnfct  = piwbf + (2*mxopt + 1)
c     pnfct  : pointer for the number of functions, communication
c              with SIMEXT ( simulator of user )
      pspad = pnfct + 1
c     pspad  : pointer for the space dimension
      pliu   = pspad + 1
c     pliu   : pointer for size of integers data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pldu   = pliu + 1
c     pldu   : pointer for size of doubles data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pinfo  = pldu + 1
c     pinfo  : pointer for info (errors of simnls)
      piwu   = pinfo + 1
c     piwu   : pointer for user SIMEXT workspace, so (liudat) more
c
c     Total size of iwork array = ( 2*mxopt + 6 + 12*nfct + liudat )
c
c     pointers for double precision work space : dwork
c     ------------------------------------------------
      prcov = 1
c     prcov : pointer for the reverse covariance matrix,
c             so (nfct*nfct) more
      pdwini = prcov + nfct*nfct
c     pdwini: pointer for INIRNLS who needs nfct*(2*nfct+27),
c             so nfct*(2*nfct+27) more
      pxini = pdwini + nfct*(2*nfct+27)
c     pxopt : pointer for vector solution of optmization, so mxopt more
      pxopt = pxini + mxopt
c     pxopt : pointer for vector solution of optmization, so mxopt more
      pbinf = pxopt + mxopt
c     pbinf : pointer for inferior bounds binf, so mxopt more
      pbsup = pbinf + mxopt
c     pbsup : pointer for superior bounds bsup, so mxopt more
      pgrad = pbsup + mxopt
c     pgrad : pointer for gradient at solution, so mxopt more
c
      pdwbf = pgrad + mxopt
c     pdwbf : pointer for BFGSBOXS who needs ( mxopt*(mxopt+11)/2 )
c             so ( mxopt*(mxopt+11)/2 ) more
c
      pwsnls = pdwbf + mxopt*(mxopt+11)/2
c     pwsnls: pointer for internal workspace of SIMRNLS,
c             so (nfct*(3*nfct+mxpar+3)) more
      pwsext = pwsnls + nfct*(3*nfct+mxpar+4)
c     pwsext: pointer for workspace ( communication with SIMRNLS,
c             and SIMEXT ),
c             so ( nfct*(spadim+nfct+2) + 2 + ldudat ) more
      pgrid = pwsext
c     pgrid : pointer for grid matrix ( communication with SIMEXT,
c             user simulator ), so (nfct*spadim) more
      psk = pgrid + (nfct*spadim)
c     psk   : pointer for the stress coefficient k ( communication
c             with SIMRNLS, BFGSBOXS simulator ), so 1 more
      palpha = psk + 1
c     palpha: pointer for the coefficient alpha ( communication
c             with SIMRNLS,  BFGSBOXS simulator ), so 1 more
      pbeta = palpha + 1
c     pbeta : pointer for the vector beta ( communication with SIMRNLS,
c              BFGSBOXS simulator ), so (nfct) more
      pvp = pbeta + nfct
c     pvp   : pointer for the eigenvestors matrix ( communication
c             with SIMRNLS  BFGSBOXS simulator ), so (nfct*nfct) more
      prspec = pvp + nfct*nfct
c     prspec: pointer for eigenvalues reverse vector ( communication
c             with SIMRNLS,  BFGSBOXS simulator ), so nfct more
      pdwu = prspec + nfct
c     pdwu   : pointer for user SIMEXT workspace, so (ldudat) more
c
c     Total size of dwork array = nfct*nfct + nfct*(2*nfct+27)
c                               + 5*mxopt + mxopt*(mxopt+11)/2
c                               + nfct*(3*nfct+mxpar+4)
c                               + nfct*(spadim+nfct+2) + 2 + ldudat
c     = mxopt*(mxopt+21)/2 + nfct*(7*nfct+mxpar+spadim+33) + 2 + ldudat
c            with mxopt = mxpar + 1
c
c-----------------------------------------------------------------------
c
c     initial computing for SIMRNLS
      CALL inirnls ( nfct, moyobs, covobs, skobs,
     &               iwork(piwini), dwork(pdwini),
     &               dwork(palpha), dwork(pbeta), dwork(pvp),
     &               dwork(prspec), dwork(prcov), eigmax, info )
      IF ( info.lt.0 ) RETURN
c
c     initialization of xopt (elem. 1 to mxpar)
      CALL YV ( mxpar, xini, dwork(pxini) )
c
c     initialization of lambda > eigmax + epsilon (elem. mxopt=mxpar+1)
      dwork(pxini+mxpar) = inilam*eigmax
c
c     lower/upper bounds initialization
      CALL IVX ( mxopt, dwork(pbsup), infini )
      CALL IVX ( mxopt-1, dwork(pbinf), -infini )
      dwork(pbinf+mxopt-1) = eigmax * ( 1. + lplus )
c
c     communication with SIMEXT (user simulator)
      iwork(pnfct) = nfct
      iwork(pspad) = spadim
      iwork(pliu)  = liudat
      iwork(pldu)  = ldudat
      iwork(pinfo) = 0
      CALL YV ( nfct*spadim, grid, dwork(pgrid) )
      CALL YV ( ldudat, dudata, dwork(pdwu) )
      CALL YVI ( liudat, iudata, iwork(piwu) )
      dwork(psk) = skobs
c
c     optimization BFGS-box
      CALL bfgsboxs ( simrnls, simext, mxopt, dwork(pxini), epsbfg,
     &                dwork(pbinf), dwork(pbsup),
     &                iwork(piwbf), dwork(pdwbf), dwork(pxopt),
     &                fxopt, dwork(pgrad), totitr, totsim, info)
c
c     optimal point
      CALL YV ( mxpar, dwork(pxopt), xopt )
c
c     optimal Lagragian
      lopt = dwork( pxopt + mxopt )
c
c     gradient value at the minimum
      CALL YV ( mxpar, dwork(pgrad), gxopt )
      glopt = dwork( pgrad + mxopt )
c
c     gestion of SIMRNLS errors
      IF (iwork(pinfo) .NE. 0) THEN
         info = iwork(pinfo)
         RETURN
      ENDIF
c
      RETURN
      END


	FUNCTION PR_CMBC  ( clcl, clcm, clch )
C************************************************************************
C* PR_CMBC								*
C*									*
C* This function computes CMBC, the combined low, mid and high cloud	*
C* coverages, from CLCL, CLCM, and CLCH.  The following equation is 	*
C* used:								*
C*									*
C*           CMBC = (CLCL * 100) + (CLCM * 10) + CLCH			*
C*									*
C* REAL PR_CMBC  ( CLCL, CLCM, CLCH )					*
C*									*
C* Input parameters:							*
C*	CLCL		REAL		Low cloud coverage		*
C*	CLCM		REAL		Medium cloud coverage		*
C*	CLCH		REAL		High cloud coverage		*
C*									*
C* Output parameters:							*
C*	PR_CMBC		REAL		Combined cloud coverage		*
C**									*
C* Log:									*
C* I. Graffman/RDS	12/84						*
C* M. desJardins/GSFC	10/87	Set missing data to 0.			*
C* G. Huffman/GSC       7/88   	Documentation				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
C------------------------------------------------------------------------
C*	Set missing data values to 0.
C
	IF  ( ( clcl .ge. 0 ) .and. ( clcl .le. 9 ) )  THEN
	    iclcl = clcl
	  ELSE
	    iclcl = 0
	END IF
C
	IF  ( ( clcm .ge. 0 ) .and. ( clcm .le. 9 ) )  THEN
	    iclcm = clcm
	  ELSE
	    iclcm = 0
	END IF
C
	IF  ( ( clch .ge. 0 ) .and. ( clch .le. 9 ) )  THEN
	    iclch = clch
	  ELSE
	    iclch = 0
	END IF
C
C*	Combine values into one number.
C
	PR_CMBC = ( iclcl * 100 ) + ( iclcm * 10 ) + iclch
*
	RETURN
	END


      SUBROUTINE cdfnor(which,p,q,x,mean,sd,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFNOR( WHICH, P, Q, X, MEAN, SD, STATUS, BOUND )
C               Cumulative Distribution Function
C               NORmal distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the normal
C     distribution given values for the others.
C
C
C                              Arguments
C
C
C     WHICH  --> Integer indicating  which of the  next  parameter
C     values is to be calculated using values  of the others.
C     Legal range: 1..4
C               iwhich = 1 : Calculate P and Q from X,MEAN and SD
C               iwhich = 2 : Calculate X from P,Q,MEAN and SD
C               iwhich = 3 : Calculate MEAN from P,Q,X and SD
C               iwhich = 4 : Calculate SD from P,Q,X and MEAN
C                    INTEGER WHICH
C
C     P <--> The integral from -infinity to X of the normal density.
C            Input range: (0,1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: (0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C     X < --> Upper limit of integration of the normal-density.
C             Input range: ( -infinity, +infinity)
C                    DOUBLE PRECISION X
C
C     MEAN <--> The mean of the normal density.
C               Input range: (-infinity, +infinity)
C                    DOUBLE PRECISION MEAN
C
C     SD <--> Standard Deviation of the normal density.
C             Input range: (0, +infinity).
C                    DOUBLE PRECISION SD
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C
C
C     A slightly modified version of ANORM from
C
C     Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
C     Package of Special Function Routines and Test Drivers"
C     acm Transactions on Mathematical Software. 19, 22-32.
C
C     is used to calulate the  cumulative standard normal distribution.
C
C     The rational functions from pages  90-95  of Kennedy and Gentle,
C     Statistical  Computing,  Marcel  Dekker, NY,  1980 are  used  as
C     starting values to Newton's Iterations which compute the inverse
C     standard normal.  Therefore no  searches  are necessary for  any
C     parameter.
C
C     For X < -15, the asymptotic expansion for the normal is used  as
C     the starting value in finding the inverse standard normal.
C     This is formula 26.2.12 of Abramowitz and Stegun.
C
C
C                              Note
C
C
C      The normal density is proportional to
C      exp( - 0.5 * (( X - MEAN)/SD)**2)
C
C
C**********************************************************************
C     .. Parameters ..
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,mean,p,q,sd,x
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION z,pq
C     ..
C     .. External Functions ..

      DOUBLE PRECISION dinvnr,spmpar
      EXTERNAL dinvnr,spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL cumnor
C     ..
C     .. Executable Statements ..
C
C     Check arguments
C
      status = 0
      IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 4.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
C
C     P
C
      IF (.NOT. ((p.LE.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LE.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0D0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
C
C     Q
C
      IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LE.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.1) GO TO 150
C
C     P + Q
C
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 140
      IF (.NOT. (pq.LT.0.0D0)) GO TO 120
      bound = 0.0D0
      GO TO 130

  120 bound = 1.0D0
  130 status = 3
      RETURN

  140 CONTINUE
  150 IF (which.EQ.4) GO TO 170
C
C     SD
C
      IF (.NOT. (sd.LE.0.0D0)) GO TO 160
      bound = 0.0D0
      status = -6
      RETURN

  160 CONTINUE
C
C     Calculate ANSWERS
C
  170 IF ((1).EQ. (which)) THEN
C
C     Computing P
C
         z = (x-mean)/sd
         CALL cumnor(z,p,q)

      ELSE IF ((2).EQ. (which)) THEN
C
C     Computing X
C
          z = dinvnr(p,q)
          x = sd*z + mean

      ELSE IF ((3).EQ. (which)) THEN
C
C     Computing the MEAN
C
          z = dinvnr(p,q)
          mean = x - sd*z

      ELSE IF ((4).EQ. (which)) THEN
C
C     Computing SD
C
          z = dinvnr(p,q)
          sd = (x-mean)/z
      END IF

      RETURN

      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine tncg  --  truncated Newton optimization method  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "tncg" implements a truncated Newton optimization algorithm
c     in which a preconditioned linear conjugate gradient method is
c     used to approximately solve Newton's equations; special features
c     include use of an explicit sparse Hessian or finite-difference
c     gradient-Hessian products within the PCG iteration; the exact
c     Newton search directions can be used optionally; by default the
c     algorithm checks for negative curvature to prevent convergence
c     to a stationary point having negative eigenvalues; if a saddle
c     point is desired this test can be removed by disabling "negtest"
c
c     literature references:
c
c     J. W. Ponder and F. M Richards, "An Efficient Newton-like
c     Method for Molecular Mechanics Energy Minimization of
c     Large Molecules", Journal of Computational Chemistry,
c     8, 1016-1024 (1987)
c
c     R. S. Dembo and T. Steihaug, "Truncated-Newton Algorithms
c     for Large-Scale Unconstrained Optimization", Mathematical
c     Programming, 26, 190-212 (1983)
c
c     variables and parameters:
c
c     mode       determines optimization method; choice of
c                  Newton's method, truncated Newton, or
c                  truncated Newton with finite differencing
c     method     determines which type of preconditioning will
c                  be used on the Newton equations; choice
c                  of none, diagonal, 3x3 block diagonal,
c                  SSOR or incomplete Cholesky preconditioning
c     nvar       number of parameters in the objective function
c     minimum    upon return contains the best value of the
c                  function found during the optimization
c     f          contains current best value of function
c     x0         contains starting point upon input, upon
c                  return contains the best point found
c     g          contains gradient of current best point
c     h          contains the Hessian matrix values in an
c                  indexed linear array
c     h_mode     controls amount of Hessian matrix computed;
c                  either the full matrix, diagonal or none
c     h_init     points to the first Hessian matrix element
c                  associated with each parameter
c     h_stop     points to the last Hessian matrix element
c                  associated with each parameter
c     h_index    contains second parameter involved in each
c                  element of the Hessian array
c     h_diag     contains diagonal of the Hessian matrix
c     p          search direction resulting from pcg iteration
c     f_move     function decrease over last tncg iteration
c     f_old      function value at end of last iteration
c     x_move     rms movement per atom over last tn iteration
c     x_old      parameters value at end of last tn iteration
c     g_norm     Euclidian norm of the gradient vector
c     g_rms      root mean square gradient value
c     fg_call    cumulative number of function/gradient calls
c     grdmin     termination criterion based on RMS gradient
c     iprint     print iteration results every iprint iterations
c     iwrite     call user-supplied output every iwrite iterations
c     newhess    number of iterations between the computation
c                  of new Hessian matrix values
c     negtest    determines whether test for negative curvature
c                  is performed during the PCG iterations
c     maxiter    maximum number of tncg iterations to attempt
c
c     parameters used in the line search:
c
c     cappa      accuarcy of line search control  (0 < cappa < 1)
c     stpmin     minimum allowed line search step size
c     stpmax     maximum allowed line search step size
c     angmax     maximum angle between search and -grad directions
c     intmax     maximum number of interpolations in line search
c
c     required external routines:
c
c     fgvalue    function to evaluate function and gradient values
c     hmatrix    subroutine which evaluates Hessian diagonal
c                  and large off-diagonal matrix elements
c     optsave    subroutine to write out info about current status
c
c
      subroutine tncg (mode,method,nvar,x0,minimum,grdmin,
     &                       fgvalue,hmatrix,optsave)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'hescut.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'math.i'
      include 'minima.i'
      include 'output.i'
      include 'piorbs.i'
      include 'potent.i'
      integer i,fg_call
      integer nvar,nmax
      integer iter_tn,iter_cg
      integer next,newhess
      integer nerr,maxerr
      integer, allocatable :: h_init(:)
      integer, allocatable :: h_stop(:)
      integer, allocatable :: h_index(:)
      real*8 f,fgvalue,grdmin
      real*8 minimum,angle,rms
      real*8 x_move,f_move,f_old
      real*8 g_norm,g_rms
      real*8 x0(*)
      real*8, allocatable :: x_old(:)
      real*8, allocatable :: g(:)
      real*8, allocatable :: p(:)
      real*8, allocatable :: h_diag(:)
      real*8, allocatable :: h(:)
      logical done,negtest
      logical automode,automatic
      character*4 h_mode
      character*6 mode,method
      character*9 status
      character*9 info_solve
      character*9 info_search
      character*20 keyword
      character*120 record
      character*120 string
      save h_index,h
      external fgvalue
      external hmatrix
      external optsave
c
c
c     check number of variables and get type of optimization
c
      if (nvar .gt. maxvar) then
         write (iout,10)
   10    format (/,' TNCG  --  Too many Parameters,',
     &              ' Increase the Value of MAXVAR')
         return
      end if
      rms = sqrt(dble(nvar))
      if (coordtype .eq. 'CARTESIAN') then
         rms = rms / sqrt(3.0d0)
      else if (coordtype .eq. 'RIGIDBODY') then
         rms = rms / sqrt(6.0d0)
      end if
c
c     set default parameters for the optimization
c
      if (fctmin .eq. 0.0d0)  fctmin = -10000000.0d0
      if (iwrite .lt. 0)  iwrite = 1
      if (iprint .lt. 0)  iprint = 1
      if (maxiter .eq. 0)  maxiter = 1000
      if (nextiter .eq. 0)  nextiter = 1
      newhess = 1
      maxerr = 3
      done = .false.
      status = '          '
      negtest = .true.
      automode = .false.
      automatic = .false.
      if (mode .eq. 'AUTO')  automode = .true.
      if (method .eq. 'AUTO')  automatic = .true.
c
c     set default parameters for the line search
c
      if (stpmax .eq. 0.0d0)  stpmax = 5.0d0
      stpmin = 1.0d-16
      cappa = 0.1d0
      slpmax = 10000.0d0
      angmax = 180.0d0
      intmax = 8
c
c     search each line of the keyword file for options
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:120)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (string,*,err=20,end=20)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (string,*,err=20,end=20)  maxiter
         else if (keyword(1:9) .eq. 'NEXTITER ') then
            read (string,*,err=20,end=20)  nextiter
         else if (keyword(1:8) .eq. 'NEWHESS ') then
            read (string,*,err=20,end=20)  newhess
         else if (keyword(1:12) .eq. 'SADDLEPOINT ') then
            negtest = .false.
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (string,*,err=20,end=20)  stpmin
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (string,*,err=20,end=20)  stpmax
         else if (keyword(1:6) .eq. 'CAPPA ') then
            read (string,*,err=20,end=20)  cappa
         else if (keyword(1:9) .eq. 'SLOPEMAX ') then
            read (string,*,err=20,end=20)  slpmax
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (string,*,err=20,end=20)  angmax
         else if (keyword(1:7) .eq. 'INTMAX ') then
            read (string,*,err=20,end=20)  intmax
         end if
   20    continue
      end do
c
c     initialize the function call and iteration counters
c
      fg_call = 0
      nerr = 0
      iter_tn = nextiter - 1
      maxiter = iter_tn + maxiter
c
c     print header information about the method used
c
      if (iprint .gt. 0) then
         if (mode .eq. 'NEWTON') then
            write (iout,30)
   30       format (/,' Full-Newton Conjugate-Gradient',
     &                 ' Optimization :')
         else if (mode .eq. 'TNCG') then
            write (iout,40)
   40       format (/,' Truncated-Newton Conjugate-Gradient',
     &                 ' Optimization :')
         else if (mode .eq. 'DTNCG') then
            write (iout,50)
   50       format (/,' Finite-Difference Truncated-Newton',
     &                 ' Conjugate-Gradient Optimization :')
         else if (mode .eq. 'AUTO') then
            write (iout,60)
   60       format (/,' Variable-Mode Truncated-Newton',
     &                 ' Conjugate-Gradient Optimization :')
         end if
         write (iout,70)  mode,method,grdmin
   70    format (/,' Algorithm : ',a6,5x,'Preconditioning : ',a6,5x,
     &              ' RMS Grad :',d9.2)
         write (iout,80)
   80    format (/,' TN Iter    F Value       G RMS     F Move  ',
     &              '  X Move   CG Iter  Solve   FG Call',/)
      end if
c
c     perform dynamic allocation of some local arrays
c
      nmax = 3 * n
      allocate (h_init(nmax))
      allocate (h_stop(nmax))
      allocate (x_old(nmax))
      allocate (g(nmax))
      allocate (p(nmax))
      allocate (h_diag(nmax))
      allocate (h_index((nmax*(nmax-1))/2))
      allocate (h((nmax*(nmax-1))/2))
c
c     evaluate the function and get the initial gradient
c
      iter_cg = 0
      fg_call = fg_call + 1
      f = fgvalue (x0,g)
      f_old = f
      g_norm = 0.0d0
      do i = 1, nvar
         x_old(i) = x0(i)
         g_norm = g_norm + g(i)**2
      end do
      g_norm = sqrt(g_norm)
      f_move = 0.5d0 * stpmax * g_norm
      g_rms = g_norm / rms
c
c     print initial information prior to first iteration
c
      if (iprint .gt. 0) then
         if (f.lt.1.0d7 .and. f.gt.-1.0d6 .and. g_rms.lt.1.0d6) then
            write (iout,90)  iter_tn,f,g_rms,fg_call
   90       format (i6,f13.4,f12.4,41x,i7)
         else
            write (iout,100)  iter_tn,f,g_rms,fg_call
  100       format (i6,d13.4,d12.4,41x,i7)
         end if
      end if
c
c     write initial intermediate prior to first iteration
c
      if (iwrite .gt. 0)  call optsave (iter_tn,f,x0)
c
c     check for termination criteria met by initial point
c
      if (g_rms .le. grdmin) then
         done = .true.
         minimum = f
         if (iprint .gt. 0) then
            write (iout,110)
  110       format (/,' TNCG  --  Normal Termination due to SmallGrad')
         end if
      else if (f .le. fctmin) then
         done = .true.
         minimum = f
         if (iprint .gt. 0) then
            write (iout,120)
  120       format (/,' TNCG  --  Normal Termination due to SmallFct')
         end if
      else if (iter_tn .ge. maxiter) then
         done = .true.
         minimum = f
         if (iprint .gt. 0) then
            write (iout,130)
  130       format (/,' TNCG  --  Incomplete Convergence',
     &                 ' due to IterLimit')
         end if
      end if
c
c     beginning of the outer truncated Newton iteration
c
      do while (.not. done)
         iter_tn = iter_tn + 1
c
c     if pisystem is present, update the molecular orbitals
c
         if (use_orbit) then
            reorbit = 1
            call picalc
            fg_call = fg_call + 1
            f = fgvalue (x0,g)
            reorbit = 0
         end if
c
c     choose the optimization mode based on the gradient value
c
         if (automode) then
            if (g_rms .ge. 3.0d0) then
               mode = 'TNCG'
            else
               mode = 'DTNCG'
            end if
         end if
c
c     decide on an optimal preconditioning based on the gradient
c
         if (automatic) then
            if (nvar .lt. 10) then
               method = 'DIAG'
               hesscut = 0.0d0
            else if (g_rms .ge. 10.0d0) then
               method = 'DIAG'
               hesscut = 1.0d0
            else if (g_rms .ge. 1.0d0) then
               method = 'ICCG'
               hesscut = 0.001d0 * nvar
               if (hesscut .gt. 1.0d0)  hesscut = 1.0d0
            else
               method = 'ICCG'
               hesscut = 0.001d0 * nvar
               if (hesscut .gt. 0.1d0)  hesscut = 0.1d0
            end if
         end if
c
c     compute needed portions of the Hessian matrix
c
         h_mode = 'FULL'
         if (mod(iter_tn-1,newhess) .ne. 0)  h_mode = 'NONE'
         if (mode.eq.'DTNCG' .and. method.eq.'NONE')  h_mode = 'NONE'
         if (mode.eq.'DTNCG' .and. method.eq.'DIAG')  h_mode = 'DIAG'
         call hmatrix (h_mode,x0,h,h_init,h_stop,h_index,h_diag)
c
c     find the next approximate Newton search direction
c
         call tnsolve (mode,method,negtest,nvar,p,x0,g,h,
     &                 h_init,h_stop,h_index,h_diag,iter_tn,
     &                 iter_cg,fg_call,fgvalue,info_solve)
c
c     perform a line search in the chosen direction
c
         info_search = '         '
         call search (nvar,f,g,x0,p,f_move,angle,fg_call,
     &                fgvalue,info_search)
         if (info_search .ne. ' Success ') then
            info_solve = info_search
         end if
c
c     update variables to reflect this iteration
c
         f_move = f_old - f
         f_old = f
         x_move = 0.0d0
         g_norm = 0.0d0
         do i = 1, nvar
            x_move = x_move + (x0(i)-x_old(i))**2
            x_old(i) = x0(i)
            g_norm = g_norm + g(i)**2
         end do
         x_move = sqrt(x_move)
         x_move = x_move / rms
         if (coordtype .eq. 'INTERNAL') then
            x_move = x_move * radian
         end if
         g_norm = sqrt(g_norm)
         g_rms = g_norm / rms
c
c     quit if the maximum number of iterations is exceeded
c
         if (iter_tn .ge. maxiter) then
            done = .true.
            status = 'IterLimit'
         end if
c
c     quit if the function value did not change
c
         if (f_move .eq. 0.0d0) then
            done = .true.
            status = 'NoMotion '
         end if
c
c     quit if either of the normal termination tests are met
c
         if (g_rms .le. grdmin) then
            done = .true.
            status = 'SmallGrad'
         else if (f .le. fctmin) then
            done = .true.
            status = 'SmallFct '
         end if
c
c     quit if the line search encounters successive problems
c
         if (info_search.eq.'BadIntpln' .or.
     &       info_search.eq.'IntplnErr') then
            nerr = nerr + 1
            if (nerr .ge. maxerr) then
               done = .true.
               status = info_search
            end if
         else
            nerr = 0
         end if
c
c     print intermediate results for the current iteration
c
         if (iprint .gt. 0) then
            if (done .or. mod(iter_tn,iprint).eq.0) then
               if (f.lt.1.0d7 .and. f.gt.-1.0d6 .and.
     &             g_rms.lt.1.0d6 .and. f_move.lt.1.0d5) then
                  write (iout,140)  iter_tn,f,g_rms,f_move,x_move,
     &                              iter_cg,info_solve,fg_call
  140             format (i6,f13.4,f12.4,f11.4,f10.4,i8,3x,a9,i7)
               else
                  write (iout,150)  iter_tn,f,g_rms,f_move,x_move,
     &                              iter_cg,info_solve,fg_call
  150             format (i6,d13.4,d12.4,d11.4,f10.4,i8,3x,a9,i7)
               end if
            end if
         end if
c
c     write intermediate results for the current iteration
c
         if (iwrite .gt. 0) then
            if (done .or. mod(iter_tn,iwrite).eq.0) then
               call optsave (iter_tn,f,x0)
            end if
         end if
c
c     print the reason for terminating the optimization
c
         if (done) then
            minimum = f
            if (iprint .gt. 0) then
               if (g_rms.le.grdmin .or. f.le.fctmin) then
                  write (iout,160)  status
  160             format (/,' TNCG  --  Normal Termination due to ',a9)
               else
                  write (iout,170)  status
  170             format (/,' TNCG  --  Incomplete Convergence',
     &                       ' due to ',a9)
               end if
            end if
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (h_init)
      deallocate (h_stop)
      deallocate (x_old)
      deallocate (g)
      deallocate (p)
      deallocate (h_diag)
      deallocate (h_index)
      deallocate (h)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine tnsolve  --  approx linear equation solution   ##
c     ##                                                            ##
c     ################################################################
c
c
c     "tnsolve" uses a linear conjugate gradient method to find
c     an approximate solution to the set of linear equations
c     represented in matrix form by Hp = -g (Newton's equations)
c
c     status codes upon return:
c
c     TruncNewt    convergence to (truncated) Newton criterion
c     NegCurve     termination upon detecting negative curvature
c     OverLimit    maximum number of CG iterations exceeded
c
c
      subroutine tnsolve (mode,method,negtest,nvar,p,x0,g,h,
     &                    h_init,h_stop,h_index,h_diag,cycle,
     &                    iter_cg,fg_call,fgvalue,status)
      implicit none
      include 'sizes.i'
      include 'output.i'
      integer i,j,k,nvar,cycle
      integer iter,iter_cg
      integer fg_call,maxiter
      integer h_init(*)
      integer h_stop(*)
      integer h_index(*)
      real*8 alpha,beta,delta
      real*8 sigma,f_sigma
      real*8 fgvalue,eps
      real*8 g_norm,g_rms
      real*8 hj,gg,dq,rr,dd
      real*8 rs,rs_new,r_norm
      real*8 converge
      real*8 x0(*)
      real*8 g(*)
      real*8 p(*)
      real*8 h_diag(*)
      real*8 h(*)
      real*8, allocatable :: m(:)
      real*8, allocatable :: r(:)
      real*8, allocatable :: s(:)
      real*8, allocatable :: d(:)
      real*8, allocatable :: q(:)
      real*8, allocatable :: x_sigma(:)
      real*8, allocatable :: g_sigma(:)
      logical negtest
      character*6 mode,method
      character*9 status
      external fgvalue
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (m(nvar))
      allocate (r(nvar))
      allocate (s(nvar))
      allocate (d(nvar))
      allocate (q(nvar))
      allocate (x_sigma(nvar))
      allocate (g_sigma(nvar))
c
c     transformation using exact Hessian diagonal
c
      if (mode.ne.'DTNCG' .and. method.ne.'NONE') then
         do i = 1, nvar
            m(i) = 1.0d0 / sqrt(abs(h_diag(i)))
         end do
         do i = 1, nvar
            g(i) = g(i) * m(i)
            h_diag(i) = h_diag(i) * m(i) * m(i)
            do j = h_init(i), h_stop(i)
               k = h_index(j)
               h(j) = h(j) * m(i) * m(k)
            end do
         end do
      end if
c
c     setup prior to linear conjugate gradient iterations
c
      iter = 0
      gg = 0.0d0
      do i = 1, nvar
         p(i) = 0.0d0
         r(i) = -g(i)
         gg = gg + g(i)*g(i)
      end do
      g_norm = sqrt(gg)
      call precond (method,iter,nvar,s,r,h,h_init,
     &                  h_stop,h_index,h_diag)
      rs = 0.0d0
      do i = 1, nvar
         d(i) = s(i)
         rs = rs + r(i)*s(i)
      end do
      if (mode .eq. 'NEWTON') then
         eps = 1.0d-10
         maxiter = nvar
      else if (mode.eq.'TNCG' .or. mode.eq.'DTNCG') then
         delta = 1.0d0
         eps = delta / dble(cycle)
         g_rms = g_norm / sqrt(dble(nvar))
         eps = min(eps,g_rms)
         converge = 1.0d0
         eps = eps**converge
         maxiter = nint(10.0d0*sqrt(dble(nvar)))
      end if
      iter = 1
c
c     evaluate or estimate the matrix-vector product
c
      do while (.true.)
         if (mode.eq.'TNCG' .or. mode.eq.'NEWTON') then
            do i = 1, nvar
               q(i) = 0.0d0
            end do
            do i = 1, nvar
               q(i) = q(i) + h_diag(i)*d(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  hj = h(j)
                  q(i) = q(i) + hj*d(k)
                  q(k) = q(k) + hj*d(i)
               end do
            end do
         else if (mode .eq. 'DTNCG') then
            dd = 0.0d0
            do i = 1, nvar
               dd = dd + d(i)*d(i)
            end do
            sigma = 1.0d-7 / sqrt(dd)
            if (coordtype .eq. 'INTERNAL') then
               sigma = 1.0d-4 / sqrt(dd)
            end if
            do i = 1, nvar
               x_sigma(i) = x0(i) + sigma*d(i)
            end do
            fg_call = fg_call + 1
            f_sigma = fgvalue (x_sigma,g_sigma)
            do i = 1, nvar
               q(i) = (g_sigma(i)-g(i)) / sigma
            end do
         end if
c
c     check for a direction of negative curvature
c
         dq = 0.0d0
         do i = 1, nvar
            dq = dq + d(i)*q(i)
         end do
         if (negtest) then
            if (dq .le. 0.0d0) then
               if (iter .eq. 1) then
                  do i = 1, nvar
                     p(i) = d(i)
                  end do
               end if
               status = ' NegCurve'
               goto 10
            end if
         end if
c
c     test the truncated Newton termination criterion
c
         alpha = rs / dq
         rr = 0.0d0
         do i = 1, nvar
            p(i) = p(i) + alpha*d(i)
            r(i) = r(i) - alpha*q(i)
            rr = rr + r(i)*r(i)
         end do
         r_norm = sqrt(rr)
         if (r_norm/g_norm .le. eps) then
            status = 'TruncNewt'
            goto 10
         end if
c
c     solve the preconditioning equations
c
         call precond (method,iter,nvar,s,r,h,h_init,
     &                     h_stop,h_index,h_diag)
c
c     update the truncated Newton direction
c
         rs_new = 0.0d0
         do i = 1, nvar
            rs_new = rs_new + r(i)*s(i)
         end do
         beta = rs_new / rs
         rs = rs_new
         do i = 1, nvar
            d(i) = s(i) + beta*d(i)
         end do
c
c     check for overlimit, then begin next iteration
c
         if (iter .ge. maxiter) then
            status = 'OverLimit'
            goto 10
         end if
         iter = iter + 1
      end do
c
c     retransform and increment total iterations, then terminate
c
   10 continue
      if (mode.ne.'DTNCG' .and. method.ne.'NONE') then
         do i = 1, nvar
            p(i) = p(i) * m(i)
            g(i) = g(i) / m(i)
         end do
      end if
      iter_cg = iter_cg + iter
c
c     perform deallocation of some local arrays
c
      deallocate (m)
      deallocate (r)
      deallocate (s)
      deallocate (d)
      deallocate (q)
      deallocate (x_sigma)
      deallocate (g_sigma)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine precond  --  precondition linear CG method  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "precond" solves a simplified version of the Newton equations
c     Ms = r, and uses the result to precondition linear conjugate
c     gradient iterations on the full Newton equations in "tnsolve"
c
c     reference for incomplete Cholesky factorization :
c
c     T. A. Manteuffel, "An Incomplete Factorization Technique
c     for Positive Definite Linear Systems", Mathematics of
c     Computation, 34, 473-497 (1980); the present method is
c     based upon the SICCG(0) method described in this paper
c
c     types of preconditioning methods :
c
c     none     use no preconditioning at all
c     diag     exact Hessian diagonal preconditioning
c     block    3x3 block diagonal preconditioning
c     ssor     symmetric successive over-relaxation
c     iccg     shifted incomplete Cholesky factorization
c
c
      subroutine precond (method,iter,nvar,s,r,h,h_init,
     &                       h_stop,h_index,h_diag)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,j,k,ii,kk
      integer iii,kkk,iter
      integer nvar,nblock
      integer ix,iy,iz,icount
      integer h_init(*)
      integer h_stop(*)
      integer h_index(*)
      integer, allocatable :: c_init(:)
      integer, allocatable :: c_stop(:)
      integer, allocatable :: c_index(:)
      integer, allocatable :: c_value(:)
      real*8 f_i,f_k
      real*8 omega,factor
      real*8 maxalpha,alpha
      real*8 a(6),b(3)
      real*8 h_diag(*)
      real*8 h(*)
      real*8 s(*)
      real*8 r(*)
      real*8, allocatable :: diag(:)
      real*8, allocatable :: f_diag(:)
      real*8, allocatable :: f(:)
      logical stable
      character*6 method
      save f,f_diag,stable
c
c
c     perform dynamic allocation of some local arrays
c
      if (method .eq. 'SSOR')  allocate (diag(nvar))
      if (method .eq. 'ICCG') then
         if (iter .eq. 0) then
            allocate (c_init(nvar))
            allocate (c_stop(nvar))
            allocate (c_index((nvar*(nvar-1))/2))
            allocate (c_value((nvar*(nvar-1))/2))
         end if
         if (.not. allocated(f_diag))  allocate (f_diag(nvar))
         if (.not. allocated(f))  allocate (f((nvar*(nvar-1))/2))
      end if
c
c     use no preconditioning, using M = identity matrix
c
      if (method .eq. 'NONE') then
         do i = 1, nvar
            s(i) = r(i)
         end do
      end if
c
c     diagonal preconditioning, using M = abs(Hessian diagonal)
c
      if (method .eq. 'DIAG') then
         do i = 1, nvar
            s(i) = r(i) / abs(h_diag(i))
         end do
      end if
c
c     block diagonal preconditioning with exact atom blocks
c     (using M = 3x3 blocks from diagonal of full Hessian)
c
      if (method .eq. 'BLOCK') then
         nblock = 3
         do i = 1, nvar/3
            iz = 3 * i
            iy = iz - 1
            ix = iz - 2
            a(1) = h_diag(ix)
            if (h_index(h_init(ix)) .eq. iy) then
               a(2) = h(h_init(ix))
            else
               a(2) = 0.0d0
            end if
            if (h_index(h_init(ix)+1) .eq. iz) then
               a(3) = h(h_init(ix)+1)
            else
               a(3) = 0.0d0
            end if
            a(4) = h_diag(iy)
            if (h_index(h_init(iy)) .eq. iz) then
               a(5) = h(h_init(iy))
            else
               a(5) = 0.0d0
            end if
            a(6) = h_diag(iz)
            b(1) = r(ix)
            b(2) = r(iy)
            b(3) = r(iz)
            call cholesky (nblock,a,b)
            s(ix) = b(1)
            s(iy) = b(2)
            s(iz) = b(3)
         end do
      end if
c
c     symmetric successive over-relaxation (SSOR) preconditioning
c     (using M = (D/w+U)T * (D/w)-1 * (D/w+U) with 0 < w < 2)
c
      if (method .eq. 'SSOR') then
         omega = 1.0d0
         factor = 2.0d0 - omega
         do i = 1, nvar
            s(i) = r(i) * factor
            diag(i) = h_diag(i) / omega
         end do
         do i = 1, nvar
            s(i) = s(i) / diag(i)
            do j = h_init(i), h_stop(i)
               k = h_index(j)
               s(k) = s(k) - h(j)*s(i)
            end do
         end do
         do i = nvar, 1, -1
            s(i) = s(i) * diag(i)
            do j = h_init(i), h_stop(i)
               k = h_index(j)
               s(i) = s(i) - h(j)*s(k)
            end do
            s(i) = s(i) / diag(i)
         end do
      end if
c
c     factorization phase of incomplete cholesky preconditioning
c
      if (method.eq.'ICCG' .and. iter.eq.0) then
         call column (nvar,h_init,h_stop,h_index,
     &                c_init,c_stop,c_index,c_value)
         stable = .true.
         icount = 0
         maxalpha = 2.1d0
         alpha = -0.001d0
   10    continue
         if (alpha .le. 0.0d0) then
            alpha = alpha + 0.001d0
         else
            alpha = 2.0d0 * alpha
         end if
         if (alpha .gt. maxalpha) then
            stable = .false.
            if (verbose) then
               write (iout,20)
   20          format (' PRECOND  --  Incomplete Cholesky is',
     &                 ' Unstable, using Diagonal Method')
            end if
         else
            factor = 1.0d0 + alpha
            do i = 1, nvar
               f_diag(i) = factor * h_diag(i)
               do j = c_init(i), c_stop(i)
                  k = c_index(j)
                  f_i = f(c_value(j))
                  f_diag(i) = f_diag(i) - f_i*f_i*f_diag(k)
                  icount = icount + 1
               end do
               if (f_diag(i) .le. 0.0d0)  goto 10
               if (f_diag(i) .lt. 1.0d-7)  f_diag(i) = 1.0d-7
               f_diag(i) = 1.0d0 / f_diag(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  f(j) = h(j)
                  ii = c_init(i)
                  kk = c_init(k)
                  do while (ii.le.c_stop(i) .and. kk.le.c_stop(k))
                     iii = c_index(ii)
                     kkk = c_index(kk)
                     if (iii .lt. kkk) then
                        ii = ii + 1
                     else if (kkk .lt. iii) then
                        kk = kk + 1
                     else
                        f_i = f(c_value(ii))
                        f_k = f(c_value(kk))
                        f(j) = f(j) - f_i*f_k*f_diag(iii)
                        ii = ii + 1
                        kk = kk + 1
                        icount = icount + 1
                     end if
                  end do
               end do
            end do
            if (verbose) then
               write (iout,30)  icount,alpha
   30          format (' PRECOND  --  Incomplete Cholesky',i12,
     &                    ' Operations',f8.3,' Alpha Value')
            end if
         end if
      end if
c
c     solution phase of incomplete cholesky preconditioning
c
      if (method .eq. 'ICCG') then
         if (stable) then
            do i = 1, nvar
               s(i) = r(i)
            end do
            do i = 1, nvar
               s(i) = s(i) * f_diag(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  s(k) = s(k) - f(j)*s(i)
               end do
            end do
            do i = nvar, 1, -1
               s(i) = s(i) / f_diag(i)
               do j = h_init(i), h_stop(i)
                  k = h_index(j)
                  s(i) = s(i) - f(j)*s(k)
               end do
               s(i) = s(i) * f_diag(i)
            end do
         else
            do i = 1, nvar
               s(i) = r(i) / abs(h_diag(i))
            end do
         end if
      end if
c
c     perform deallocation of some local arrays
c
      if (method .eq. 'SSOR')  deallocate (diag)
      if (method .eq. 'ICCG') then
         if (iter .eq. 0) then
            deallocate (c_init)
            deallocate (c_stop)
            deallocate (c_index)
            deallocate (c_value)
         end if
      end if
      return
      end


      SUBROUTINE PTPLDS (PX,PY,PZ, A,B,C,D, XN,YN,ZN, DIST)

C Given a point and plane-coefficients, find nearest
C point on plane and distance from plane to point.

      REAL   PX,PY,PZ, A,B,C,D, XN,YN,ZN, DIST, SQ,SOL,U, VECL2

      SQ   = VECL2 (A,B,C)
      SOL  = A*PX + B*PY + C*PZ + D
      DIST = ABS(SOL) / SQRT(SQ)
      U    = - SOL / SQ
      XN = PX + A*U
      YN = PY + B*U
      ZN = PZ + C*U

      END


	function refrax (w,t,p,h)
	s=1./w**2
	r=6.4328e-5+2.94981e-2/(146.-s)+2.554e-4/(41.-s)
	y=1./(273.15+t)
	alpha=3.67e-3+3.3e-4*exp((0.19-w)/0.12)

	if(t.le.0.)then
	  wvsp=10.**(77.4021323+y*(-9.6982e+4+y*(5.50733046e+7+y*(
     &         -1.70804596e+10+ y*(2.96751446e+12-y*(2.73866936e+14
     &         -1.04883576e+16*y))))))
        else
 	  wvsp=10.**(-55.1132754+y*(1.19551822e+5+y*(-9.70108858e+7+
     &         y*(4.12856913e+10+y*(-9.87931835e+12+ y*(1.25868645e+
     &         15-6.66885272e+16*y))))))
        endif

	wvp=1.e-2*h*wvsp
	refrax = 1.+1.31579e-3*r*p/(1.+alpha*(t-15.)/(1.+15.*alpha))-5.49e-8*wvp/(1.+alpha*t)
c        print*,'refrax=',refrax
	return
	end


      program main_crs2trs

! ----------------------------------------------------------------------
! Program:	main_crs2trs
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the transformation matrix between inertial and terrestrial
!  (ICRF-ITRF) reference frames.
!  The transformation matrix (direct/inverse) is provided for position/velocity vectors
!  The Earth Orientation Matrix is computed based on the EOP data and
!  the consideration of the EOP corrections due to tidal variations
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Geoscience Australia, CRC-SI
! Created:	7 August 2018
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      !USE mdl_eop
      USE m_eop_data
      USE m_eop_cor
      USE m_eop_igu
      USE mdl_param
      USE m_writearray
      use pod_yaml
      IMPLICIT NONE

! ----------------------------------------------------------------------
      CHARACTER (LEN=100) :: filename, EQMfname, VEQfname
! ----------------------------------------------------------------------
      DOUBLE PRECISION arcsec2rad
      INTEGER (KIND = prec_int4) :: time_in
      INTEGER IY, IM, ID, J_flag
      DOUBLE PRECISION DJM0, sec, FD
      REAL (KIND = prec_d) :: mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC, mjd_UT1, mjd_0
      CHARACTER (LEN=512) :: EOP_fname
      CHARACTER (LEN=512) :: ERP_fname
      REAL (KIND = prec_d) :: mjd_igu
      INTEGER (KIND = prec_int4) :: n_interp
      INTEGER (KIND = prec_int8) :: mjd_UTC_day
      INTEGER (KIND = prec_int1) :: EOP_sol, EOP_sol2
      INTEGER (KIND = prec_int2) :: iau_model
      DOUBLE PRECISION EOP_cr(EOP_MAX_ARRAY), EOP_cr2(EOP_MAX_ARRAY)
! ----------------------------------------------------------------------
      DOUBLE PRECISION CRS2TRS(3,3), TRS2CRS(3,3), d_CRS2TRS(3,3), d_TRS2CRS(3,3)
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE :: R_Matrix
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE :: EOP_days, ERP_days

Print *,"ICRF-ITRF transformation matrix and EOP Data processing"

! ----------------------------------------------------------------------
! INPUT:

! ----------------------------------------------------------------------
! Time System of input epoch:
! 1. TT
! 2. GPS time
! 3. UTC
! 4. TAI
time_in = UTC_time
! ----------------------------------------------------------------------
! Date
IY = 2011
IM = 6
ID = 15
sec = 0.0D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! EOP data
! ----------------------------------------------------------------------
! Select EOP solution
! 1. IERS C04
! 2. IERS RS/PC Daily (finals2000A.daily)
! 3. IGS ultra-rapid ERP + IERS RS/PC Daily (dX,dY)
EOP_sol = 1
n_interp = 4   	! number of points for EOP interpolation
! ----------------------------------------------------------------------
! IERS C04
if (EOP_sol == 1) then
	EOP_fname = 'eopc04_08_IAU2000.62-now'

! IERS RS/PC Daily
else if (EOP_sol == 2)  then
	EOP_fname = 'finals2000A.daily'

! IGS ultra-rapid ERP
else if (EOP_sol == 3) then
	ERP_fname = 'igu18543_12.erp'
	EOP_fname = 'finals2000A.daily'
end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! IAU Precession-Nutation model:
! 2. IAU2000A:			iau_model = 2000
! 3. IAU2006/2000A:		iau_model = 2006
iau_model = IAU2000
! ----------------------------------------------------------------------

! End of Input
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! MJD
CALL iau_CAL2JD ( IY, IM, ID, DJM0, mjd, J_flag )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time Systems transformation
! ----------------------------------------------------------------------
      IF (time_in == TT_time) THEN
	     CALL time_TT (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
      ELSE IF (time_in == GPS_time) THEN
	     CALL time_GPS (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
      ELSE IF (time_in == UTC_time) THEN
	     CALL time_UTC (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
      ELSE IF (time_in == TAI_time) THEN
         CALL time_TAI (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Case 1. EOP by IERS data: EOP reading, interpolation and corrections
! ----------------------------------------------------------------------
! - IERS Earth Orientation Center:			C04 solution
! - IERS Rapid Service/Prediction Center:	finals2000A.daily solution
! ----------------------------------------------------------------------
IF (EOP_sol == EOP_C04T .OR. EOP_sol == EOP_FAST) THEN

! ----------------------------------------------------------------------
! EOP data reading
CALL eop_data (mjd_TT, EOP_fname, EOP_sol, 0, n_interp , EOP_days)
!print *,"EOP_days", EOP_days
! ----------------------------------------------------------------------
! EOP data corrections due to tidal variations
CALL eop_cor (mjd_TT, EOP_days , EOP_sol, n_interp, EOP_cr)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Case 2. ERP by IGS ultra-rapid data: EOP reading and interpolation
! ----------------------------------------------------------------------
ELSEIF (EOP_sol == EOP_SUPER_FAST)  THEN
! EOP ultra-rapid: ERP by IGS and dX,dY (IAU 2000A) by IERS RS/PC (finals2000A.daily)
        EOP_sol2 = EOP_FAST
        CALL eop_data (mjd_TT, ERP_fname, EOP_sol2, 0, n_interp, EOP_days)
        CALL eop_data (mjd_TT, ERP_fname, EOP_sol, 0, n_interp, ERP_days)
	CALL eop_igu (mjd_TT, ERP_fname, ERP_days, EOP_days, n_interp, EOP_cr)
END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! ICRF-ITRF transformation matrix (including derivatives)
! ----------------------------------------------------------------------
! CRS-TRS transformation matrix (r,v)
! - CRS2TRS:		GCRS to ITRS transformation matrix (position vector)
! - TRS2CRS:		ITRS to GCRS transformation matrix (position vector)
! - d_CRS2TRS:		Derivative of GCRS to ITRS transformation matrix (velocity vector)
!					v_TRS = TRS2CRS * v_CRS + d_CRS2TRS * r_CRS
! - d_TRS2CRS:		ITRS to GCRS transformation matrix (velocity vector)
!					v_CRS = TRS2CRS * v_TRS + d_TRS2CRS * r_TRS
! ----------------------------------------------------------------------
Print *,"ICRF-ITRF transformation matrix"
CALL crs_trs (mjd_TT, EOP_cr, iau_model, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)
! ----------------------------------------------------------------------
Print *,"CRS2TRS", CRS2TRS
Print *,"TRS2CRS", TRS2CRS
Print *,"d_CRS2TRS", d_CRS2TRS
Print *,"d_TRS2CRS", d_TRS2CRS

! ----------------------------------------------------------------------
! Write matrices to ouput files (ascii)
PRINT *,"Write ICRF-ITRF transformation matrices to output files: CRS2TRS.out, TRS2CRS.out, d_CRS2TRS.out, d_TRS2CRS.out"
! ----------------------------------------------------------------------
! Allocatable arrays
ALLOCATE (R_Matrix(3,3), STAT = AllocateStatus)

filename = "CRS2TRS.out"
R_Matrix = CRS2TRS
Call writearray (R_Matrix, filename)

filename = "TRS2CRS.out"
R_Matrix = TRS2CRS
Call writearray (R_Matrix, filename)

filename = "d_CRS2TRS.out"
R_Matrix = d_CRS2TRS
Call writearray (R_Matrix, filename)

filename = "d_TRS2CRS.out"
R_Matrix = d_TRS2CRS
Call writearray (R_Matrix, filename)
! ----------------------------------------------------------------------

End Program


subroutine spherical_rk5 (n,xo,to,h,xn,uf,RHS)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a fifth-order Runge-Kutta
! ... method is used to advance the solution over an interval h and return
! ... the incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.
! ... Quim Ballabrera, March 2017.

use module_types, only: dp
use module_model

implicit none

integer, intent(in)                  :: n
real(dp), intent(in)                 :: to,h
real(dp), dimension(n), intent(in)   :: xo
real(dp), dimension(n), intent(out)  :: xn
real(dp), dimension(n), intent(out)  :: uf
EXTERNAL                             :: RHS

! ... Local variables
! ...
real(dp), parameter                  :: RNstdev = sqrt(12.0D0)

real(dp) hh,qh,th
real(dp), dimension(n)               :: u1,u2,u3,u4,u5,u6
real(dp), dimension(n)               :: x1,x2,x3,x4,x5
real(dp), dimension(1)               :: noise1
real(dp), dimension(n)               :: noise2

hh = 0.50_dp*h
qh = 0.25_dp*h
th = 0.75_dp*h

CALL RHS(n,to,xo,u1)

call displacement(n,xo,0.25_dp*u1,h,x1)
CALL RHS(n,to+qh,x1,u2)

call displacement(n,xo,(u1+u2)/8.0_dp,h,x2)
CALL RHS(n,to+qh,x2,u3)

call displacement(n,xo,-0.50_dp*u2+u3,h,x3)
CALL RHS(n,to+hh,x3,u4)

call displacement(n,xo,(3.0_dp*u1+9.0_dp*u4)/16.0_dp,h,x4)
CALL RHS(n,to+th,x4,u5)

call displacement(n,xo,(-3.0_dp*u1+2.0_dp*u2+12.0_dp*u3-12.0_dp*u4+8.0_dp*u5)/7.0_dp,h,x5)
CALL RHS(n,to+h,x5,u6)

uf(:) = (7.0_dp*u1(:) + 32.0_dp*u3(:) + 12.0_dp*u4(:) + 32.0_dp*u5(:) + 7.0_dp*u6(:))/90.0_dp

! ... Diffusion terms
! ...
if (noise_mu.gt.0.0_dp) then
  if (Gaussian_noise) then
    noise1(:) = randn(1)
  else
    call random_number(noise1)
    noise1(:) = (noise1(:)-0.5D0)*RNStdev    ! Uniform noise
  endif
  uf(:) = uf(:) + noise_mu*noise1(1)*uf(:)
endif

if (noise_K0.gt.0.0_dp) then
  if (Gaussian_noise) then
    noise2(:) = randn(n)                                  ! Gaussian noise
  else
    call random_number(noise2)                            ! Uniform noise
    noise2(:) = (noise2(:)-0.5D0)*RNStdev
  endif
  uf(:) = uf(:) + noise_K0*noise2(:)
endif

! ... Move the particle from xo to xn:
! ...
call displacement(n,xo,uf,h,xn)

return
end subroutine spherical_rk5
! ...
! =======================================================================================
! ...
subroutine displacement(n,xo,u,dt,xn)

use module_types, only: dp
use module_constants, only: Rearth

implicit none

real(dp), parameter        :: Iearth = 1.0D0/Rearth        ! 1/Earth_Radius

integer, intent(in)                  :: n
real(dp), dimension(n), intent(in)   :: xo                 ! Input in radians
real(dp), dimension(n), intent(in)   :: u
real(dp), intent(in)                 :: dt
real(dp), dimension(n), intent(out)  :: xn                 ! Output in radians

real(dp) dx,dy,rxo,ryo,coslat,ryn,rdx

dx  = dt*u(1)
dy  = dt*u(2)

rxo  = xo(1)
ryo  = xo(2)
coslat = cos(ryo)

ryn = asin(sin(ryo+dy*IEarth)*cos(dx*IEarth))
rdx = atan2(sin(dx*Iearth)*coslat,cos(dx*Iearth)-sin(ryo)*sin(ryn))
xn(1)  = (rxo+rdx)
xn(2)  = ryn

end subroutine displacement


SUBROUTINE formaa(vmfl,rmat,daatd)
!
! This subroutine modifies the dee matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:),rmat(:,:)
 REAL(iwp),INTENT(OUT)::daatd(:,:)
 REAL(iwp)::flowt(1,4),flowa(4,1)
 flowt(1,:)=vmfl
 flowa(:,1)=vmfl
 daatd=MATMUL(MATMUL(MATMUL(rmat,flowa),flowt),rmat)
RETURN
END SUBROUTINE formaa


module gpusd_test1

use fsystem
use genoutput
use storage
use boundary
use triangulation
use cubature
use element
use spatialdiscretisation
use linearsystemscalar
use stdoperators
use matrixio
use statistics

use sd_core

implicit none

contains

subroutine gpusd_1()

  type(t_boundary) :: rbnd
  type(t_triangulation) :: rtria
  type(t_spatialDiscretisation) :: rdiscr
  type(t_vectorScalar) :: ru1, ru2
  type(t_matrixScalar) :: rmatrix
  real(DP), dimension(:), pointer :: p_Du1, p_Du2, p_DA
  integer, dimension(:), pointer :: p_Kld, p_Kcol
  real(DP), dimension(:,:), pointer :: p_Dvtx
  integer, dimension(:,:), pointer :: p_Iverts, p_Iedges
  integer :: NLMAX, info
  real(DP) :: dnu, dalpha, dbeta, dgamma, ddelta
  type(t_timer) :: rtimer

    ! set up the parameters
    NLMAX = 12
    dnu = 1.0_DP

    dalpha = 0.0_DP     ! mass matrix
    dbeta  = 0.0_DP     ! laplace matrix
    dgamma = 1.0_DP     ! convection
    ddelta = 1.0_DP     ! stabilisation

    print *, 'FEAT2 Initialisation'

    ! create the triangulation
    call boundary_read_prm(rbnd, './pre/QUAD.prm')
    call tria_readTriFile2D (rtria, './pre/QUAD.tri', rbnd)
    call tria_quickRefine2LevelOrdering(NLMAX-1, rtria, rbnd)
    call tria_initStandardMeshFromRaw (rtria, rbnd)

    ! Fetch the necessary arrays from the triangulation
    call storage_getbase_double2D(rtria%h_DvertexCoords, p_Dvtx)
    call storage_getbase_int2D(rtria%h_IverticesAtElement, p_Iverts)
    call storage_getbase_int2D(rtria%h_IedgesAtElement, p_Iedges)

    ! create discretisation
    call spdiscr_initDiscr_simple (rdiscr, EL_EM30_NEW, CUB_G3_2D, rtria, rbnd)

    ! create two empty vectors
    call lsyssc_createVecByDiscr(rdiscr, ru1)
    call lsyssc_createVecByDiscr(rdiscr, ru2)

    ! create the matrix structure
    call bilf_createMatrixStructure (rdiscr, LSYSSC_MATRIX9, rmatrix)
    call lsyssc_allocEmptyMatrix(rmatrix, LSYSSC_SETM_UNDEFINED)

    ! Fetch all arrays from the system
    call lsyssc_getbase_double(ru1, p_Du1)
    call lsyssc_getbase_double(ru2, p_Du2)
    call lsyssc_getbase_double(rmatrix, p_DA)
    call lsyssc_getbase_Kld(rmatrix, p_Kld)
    call lsyssc_getbase_Kcol(rmatrix, p_Kcol)

    ! Set u1 and u2 to (1,0)
    call lsyssc_clearVector(ru1, 1.0_DP)
    call lsyssc_clearVector(ru2, 0.0_DP)

    print *, 'FEAT2 Assembly'
    ! Assemble matrix using default SD

    call lsyssc_clearMatrix(rmatrix, 0.0_DP)
    call stat_clearTimer(rtimer)
    call stat_startTimer(rtimer)
!    call sd_asm(p_Du1,p_Du2,rmatrix,ddelta,dnu,dalpha,dbeta,1.0_DP,dgamma,0)
!    call stdop_assembleSimpleMatrix(rmatrix, DER_FUNC, DER_FUNC,bclear=.false.)
!    call stdop_assembleLaplaceMatrix(rmatrix, .false.)
    print *, '-> done!'
    call stat_stopTimer(rtimer)
    print *, 'Time: ', stat_sgetTime_byTimer(rtimer)

    ! Write matrix to text file
!    call matio_writeMatrixHR (rmatrix, 'FEAT2 SD',&
!                              .true., 0, './mat_feat2.txt', '(E20.10)', 1e-5_DP)

    print *, 'Initialising GPU-SD...'
    ! initialise GPU-SD
    call gpusd_init(info)
    if(info .ne. 0) then
      print *, 'Failed to initialise GPU-SD!'
      stop
    end if
    print *, '-> done!'

    ! set scalar parameters
    call gpusd_setparams(dnu, dalpha, dbeta, dgamma, ddelta)

    ! set triangulation arrays
    call gpusd_settria(rtria%NEL, p_Dvtx, p_Iverts, p_Iedges)

    ! set matrix arrays
    call gpusd_setmatrix(rmatrix%NEQ, p_Kld, p_Kcol, p_DA)

    ! set velocity
    call gpusd_setvelo(p_Du1, p_Du2)

    print *, 'GPU-SD Assembly'
    ! try to assemble the matrix
    call lsyssc_clearMatrix(rmatrix, 0.0_DP)
    call stat_clearTimer(rtimer)
    call stat_startTimer(rtimer)
    call gpusd_assemble(info)
    print *, '-> done! INFO: ', info
    call stat_stopTimer(rtimer)
    print *, 'Time: ', stat_sgetTime_byTimer(rtimer)
    call gpusd_statistics()

    ! release GPU-SD
    call gpusd_done()

    ! Write matrix to text file
!    call matio_writeMatrixHR (rmatrix, 'GPU-SD',&
!                              .true., 0, './mat_gpu.txt', '(E20.10)', 1e-5_DP)

    ! Release everything
    call lsyssc_releaseMatrix(rmatrix)
    call lsyssc_releaseVector(ru2)
    call lsyssc_releaseVector(ru1)
    call spdiscr_releaseDiscr(rdiscr)
    call tria_done(rtria)
    call boundary_release(rbnd)

end subroutine

end module


module kernel

  use globals
  implicit none

  type modelpar
    real(dp) :: alpha  = 5e-6
    real(dp) :: relabs = 8.0
    real(dp) :: hscale = 8000
    real(dp) :: beta   = 0.1
    real(dp) :: skybg  = 3e-7
  end type

contains

  elemental real(dp) function th(x,w)
    real(dp), intent(in) :: x
    real(dp), intent(in), optional :: w
    if (present(w)) then
      th = 1 / ( 1 + exp(-4*x/w) )
    else
      th = 1 / ( 1 + exp(-4*x) )
    end if
  end function

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

  elemental subroutine kern(par, A0, R, D, H, Hobs, J1, J2, J3)
    type(modelpar), intent(in) :: par
    real(dp), intent(in) :: A0, R, D, H, Hobs
    real(dp), intent(out) :: J1, J2, J3
    real(dp) :: L, costh, cosg, tau1, tau2, chi

    ! distance from the source to the scattering point
    L = sqrt(H**2 + (1 + H / R) * D**2)

    ! emission and scattering angles
    associate (Q => merge(D**2 / (2 * R * L), 0.0_dp, L .gt. 0))
      costh = H / L + Q
      cosg  = H / L - Q * (1 + H / R)
    end associate

    chi = (par % alpha) * (par % relabs)

    tau1 = chi * L * FF(-H / (par % Hscale))
    tau2 = chi * (par % Hscale) * exp(-Hobs / (par % Hscale)) &
         &     * (1 - exp(-(H - Hobs) / (par % Hscale)))

    J1 = (par % alpha) * exp(-H / (par % Hscale)) &
    &   * (A0 / 2) / (2 * pi * L**2 + A0) * merge(1, 0, cosg > 0)
    J2 = E(cosg) * g(costh)
    J3 = exp(-tau1) * exp(-tau2)

  contains

    elemental real(dp) function ff(x) result(y)
      real(dp), intent(in) :: x
      if ( abs(x) > 1e-2 ) then
        y = (exp(x) - 1) / x
      else
        y = 1 + x * (1 + x * (1 + x * (1 + x / 5) / 4) / 3) / 2
      end if
    end function

    elemental real(dp) function g(costh)
      real(dp), intent(in) :: costh
      g = 3 * (1 + costh**2) / 4
    end function

    elemental real(dp) function E0(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 1.5 * cosg
    end function

    elemental real(dp) function E1(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 6 * cosg * (1 - cosg)
    end function

    elemental real(dp) function E2(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 15 * cosg  * (1 - cosg)**2
    end function

    elemental real(dp) function E3(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 30 * cosg  * (1 - cosg)**3
    end function

    elemental real(dp) function E4(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 52.5_dp * cosg * (1 - cosg)**4
    end function

    elemental real(dp) function E5(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 84 * cosg * (1 - cosg)**5
    end function

    elemental real(dp) function E6(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 126 * cosg * (1 - cosg)**6
    end function

    elemental real(dp) function E7(cosg) result(E)
      real(dp), intent(in) :: cosg
      E = 180 * cosg * (1 - cosg)**7
    end function

    elemental real(dp) function E(cosg)
      real(dp), intent(in) :: cosg
      E = 1.5 * cosg * (1 - par % beta) + 3 * (1 - cosg) * (par % beta)
    end function

  end subroutine

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

  elemental real(dp) function ity2mag(ity) result(mag)
    real(dp), intent(in) :: ity
    mag = 5.5 - 2.5 * log10(ity)
  end function

  elemental real(dp) function mag2ity(mag) result(ity)
    real(dp), intent(in) :: mag
    ity = 10**((5.5 - mag) / 2.5)
  end function

end module


C-----------------------------------------------------------------------
      SUBROUTINE SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPFFTPT     COMPUTE FOURIER TRANSFORM TO GRIDPOINTS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
C
C ABSTRACT: THIS SUBPROGRAM COMPUTES A SLOW FOURIER TRANSFORM
C           FROM FOURIER SPACE TO A SET OF GRIDPOINTS.
C
C PROGRAM HISTORY LOG:
C 1998-12-18  IREDELL
C
C USAGE:    CALL SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G)
C
C   INPUT ARGUMENT LIST:
C     M        - INTEGER FOURIER WAVENUMBER TRUNCATION
C     N        - INTEGER NUMBER OF GRIDPOINTS
C     INCW     - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY
C                (INCW >= M+1)
C     INCG     - INTEGER FIRST DIMENSION OF THE GRIDPOINT ARRAY
C                (INCG >= N)
C     KMAX     - INTEGER NUMBER OF FOURIER FIELDS
C     RLON     - REAL(N) GRID LONGITUDES IN DEGREES
C     W        - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES
C
C   OUTPUT ARGUMENT LIST:
C     G        - REAL(INCG,KMAX) GRIDPOINT VALUES
C
C SUBPROGRAMS CALLED:
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C REMARKS:
C   THIS SUBPROGRAM IS THREAD-SAFE.
C
C$$$
        IMPLICIT NONE
        INTEGER,INTENT(IN):: M,N,INCW,INCG,KMAX
        REAL,INTENT(IN):: RLON(N)
        REAL,INTENT(IN):: W(2*INCW,KMAX)
        REAL,INTENT(OUT):: G(INCG,KMAX)
        INTEGER I,K,L
        REAL RADLON,SLON(M),CLON(M)
        REAL,PARAMETER:: PI=3.14159265358979
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        DO I=1,N
          RADLON=PI/180*RLON(I)
          DO L=1,M
            SLON(L)=SIN(L*RADLON)
            CLON(L)=COS(L*RADLON)
          ENDDO
          DO K=1,KMAX
            G(I,K)=W(1,K)
          ENDDO
          DO L=1,M
            DO K=1,KMAX
              G(I,K)=G(I,K)+2.*(W(2*L+1,K)*CLON(L)-W(2*L+2,K)*SLON(L))
            ENDDO
          ENDDO
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END SUBROUTINE


    Program dggrqf_example

!     DGGRQF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dgemv, dnrm2, dtrmv
      Use lapack_interfaces, Only: dggrqf, dormqr, dormrq, dtrtrs
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: one = 1.0E0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rnorm
      Integer :: i, info, lda, ldb, lwork, m, n, p
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), c(:), d(:), taua(:), &
        taub(:), work(:), x(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: min
!     .. Executable Statements ..
      Write (nout, *) 'DGGRQF Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, p
      lda = m
      ldb = p
      lwork = nb*(p+n)
      Allocate (a(lda,n), b(ldb,n), c(m), d(p), taua(n), taub(n), work(lwork), &
        x(n))

!     Read B, A, C and D from data file
      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:n), i=1, p)
      Read (nin, *) c(1:m)
      Read (nin, *) d(1:p)

!     Compute the generalized RQ factorization of (B,A) as
!     B = (0 T12)*Q,   A = Z*(R11 R12)*Q, where T12, R11
!                            ( 0  R22)
!     are upper triangular
      Call dggrqf(p, m, n, b, ldb, taub, a, lda, taua, work, lwork, info)

!     Set Qx = y. The problem then reduces to:
!                 minimize (Ry - Z^Tc) subject to Ty = d
!     Update c = Z^T*c -> minimize (Ry-c)
      Call dormqr('Left', 'Transpose', m, 1, min(m,n), a, lda, taua, c, m, &
        work, lwork, info)

!     Putting y = (y1), solve T12*w = d for w, storing result in d
!                 (w )
      Call dtrtrs('Upper', 'No transpose', 'Non-unit', p, 1, b(1,n-p+1), ldb, &
        d, p, info)

      If (info>0) Then
        Write (nout, *) 'The upper triangular factor of B is singular, '
        Write (nout, *) 'the least squares solution could not be computed'
        Go To 100
      End If

!     From first n-p rows of (Ry-c) we have: R11*y1 + R12*w = c(1:n-p) = c1
!     Form c1 = c1 - R12*w = R11*y1
      Call dgemv('No transpose', n-p, p, -one, a(1,n-p+1), lda, d, 1, one, c, &
        1)

!     Solve R11*y1 = c1 for y1, storing result in c(1:n-p)
      Call dtrtrs('Upper', 'No transpose', 'Non-unit', n-p, 1, a, lda, c, n-p, &
        info)

      If (info>0) Then
        Write (nout, *) 'The upper triangular factor of A is singular, '
        Write (nout, *) 'the least squares solution could not be computed'
        Go To 100
      End If

!     Copy y into X (first y1, then w)
      x(1:n-p) = c(1:n-p)
      x(n-p+1:n) = d(1:p)

!     Compute x = (Q**T)*y
      Call dormrq('Left', 'Transpose', n, 1, p, b, ldb, taub, x, n, work, &
        lwork, info)

!     The least squares solution is in x, the remainder here is to compute
!     the residual, which equals c2 - R22*w.

!     Upper triangular part of R22 first
      Call dtrmv('Upper', 'No transpose', 'Non-unit', min(m,n)-n+p, &
        a(n-p+1,n-p+1), lda, d, 1)
      Do i = 1, min(m, n) - n + p
        c(n-p+i) = c(n-p+i) - d(i)
      End Do

      If (m<n) Then

!       Additional rectangular part of R22
        Call dgemv('No transpose', m-n+p, n-m, -one, a(n-p+1,m+1), lda, &
          d(m-n+p+1), 1, one, c(n-p+1), 1)
      End If

!     Compute norm of residual sum of squares.
      rnorm = dnrm2(m-(n-p), c(n-p+1), 1)

!     Print least squares solution x
      Write (nout, *) 'Constrained least squares solution'
      Write (nout, 110) x(1:n)

!     Print estimate of the square root of the residual sum of squares
      Write (nout, *)
      Write (nout, *) 'Square root of the residual sum of squares'
      Write (nout, 120) rnorm

100   Continue

110   Format (1X, 7F11.4)
120   Format (3X, 1P, E11.2)
    End Program


| thehouse.f
|
| This example demonstrates how to work with small graphs
| and simple graph algorithms with Reva
|
| Author: Danny Reinhold / Reinhold Software Services
| Reva's license also applies to this file!

: infos
quote %
 This program calculates all solutions for the popular graph drawing problem.
 The house looks like this:
         N3
         /\
        /  \
       /    \
      /      \
     /        \
 N4 X----------X N2
    |\        /|
    | \      / |
    |  \    /  |
    |   \  /   |
    |    \/    |
    |    /\    |
    |   /  \   |
    |  /    \  |
    | /      \ |
    |/        \|
 N0 X----------X N1

%
type
;

: <>  = not ;

8 constant nof-edges
5 constant nof-nodes

nof-edges 1- constant last-edge
nof-nodes 1- constant last-node

: X, -1 1, ;
: _,  0 1, ;

| connection matrix
| =================
| The rows are the nodes of the graph.
| The columns are the edges.
create connections
  X, _, _, _, X, _, _, X,
  X, X, _, _, _, _, X, _,
  _, X, X, _, _, X, _, X,
  _, _, X, X, _, _, _, _,
  _, _, _, X, X, X, X, _,

create edge-data  nof-edges allot

variable nof-solutions
nof-edges 1+  stack: path

: show-path
  nof-solutions @ . ." . solution: "
  nof-edges 0  do  path pop dup ." N" . ." -> "  loop  path pop dup ." N" .
  nof-edges 1+  0  do  path push  loop
  cr
;

: visited  ( edgepos -- flagaddr ) edge-data +  ;
: visited! ( edgepos flag -- )     swap visited c! ;
: visited? ( edgepos -- flag )     visited c@  255  =  ;
: visit    ( edgepos -- )          -1 visited! ;
: unvisit  ( edgepos -- )          0 visited! ;
: connected? ( node edge -- flag )  swap  nof-edges *  connections +  +  c@  255 = ;
: solution? ( -- flag )  -1  nof-edges 0 do  i visited?  and  loop  ;

: other-node ( node edge -- othernode )
  nof-nodes 0  do  2dup  i swap connected?  swap i <>  and  if  2drop i leave  then  loop
;

: search ( node -- )
  dup
  path push

  nof-edges 0 do
    dup i connected?  i visited? not  and
    if  i visit  dup i other-node  search  i unvisit  then
  loop

  solution?  if  1 nof-solutions +!  show-path  then

  path pop
  2drop
;

: house
  infos
  0 nof-solutions !
  nof-edges 0 do  i unvisit  loop

  nof-nodes 0 do  i search  loop

  cr ." Number of solutions: " nof-solutions @ . cr
;

house


      REAL FUNCTION LINT (TABLE,ILTAB,X)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      INTEGER ILTAB
      REAL TABLE(ILTAB), X

**    local variables
      INTEGER I1, ILT, IUP, UNLOG
      REAL SLOPE, TINY
      PARAMETER (TINY=1.E-7)
      LOGICAL ERR, WARN, TOSCR, TOLOG
      SAVE

*     initialize
      ERR  = .FALSE.
      WARN = .FALSE.

*     desired output type for messages
      CALL MESSINQ (TOSCR, TOLOG, UNLOG)

*     check on value of ILTAB
      IF (MOD(ILTAB,2).NE.0 .OR. ILTAB.LE.2) THEN
         IF (TOSCR) WRITE (*,'(A)')
     $    ' Number of elements in LINT table not correct !'
         IF (TOLOG) WRITE (UNLOG,'(A)')
     $    ' Number of elements in LINT table not correct !'
         ERR = .TRUE.

      ELSE
         IUP = 0
         DO 10 I1=3,ILTAB,2
*           check on ascending order of X-values in function
            IF (TABLE(I1).LE.TABLE(I1-2)) THEN
               IF (TOSCR) WRITE (*,'(2A,I4)')
     $          ' X-coordinates in LINT table not in',
     $          ' ascending order at point',I1
               IF (TOLOG) WRITE (UNLOG,'(2A,I4)')
     $          ' X-coordinates in LINT table not in',
     $          ' ascending order at point',I1
               ERR = .TRUE.
            END IF
            IF (IUP.EQ.0 .AND. TABLE(I1).GE.X) IUP = I1
10       CONTINUE
      END IF

      IF (.NOT.ERR .AND. X.LT.TABLE(1)) THEN
         IUP = 3
         IF ((TABLE(1)-X) .GT. ABS(X)*TINY) THEN
            WARN = .TRUE.
            IF (TOSCR) WRITE (*,'(A,G13.5)')
     $       ' WARNING in LINT: X-value below defined region at X=',X
            IF (TOLOG) WRITE (UNLOG,'(A,G13.5)')
     $       ' WARNING in LINT: X-value below defined region at X=',X
         END IF
      ELSE IF (.NOT.ERR .AND. X.GT.TABLE(ILTAB-1)) THEN
         IUP = ILTAB-1
         IF ((X-TABLE(ILTAB-1)) .GT. ABS(X)*TINY) THEN
            WARN = .TRUE.
            IF (TOSCR) WRITE (*,'(A,G13.5)')
     $       ' WARNING in LINT: X-value above defined region at X=',X
            IF (TOLOG) WRITE (UNLOG,'(A,G13.5)')
     $       ' WARNING in LINT: X-value above defined region at X=',X
         END IF
      END IF

      IF (WARN.OR.ERR) THEN
         ILT = MIN (ILTAB/2, 15)
         IF (TOSCR) WRITE (*,'(A,I4,/,A,I2,A)')
     $     ' Number of table elements is',ILTAB,
     $     ' First ',ILT,' pairs are:'
         IF (TOLOG) WRITE (UNLOG,'(A,I4,/,A,I2,A)')
     $     ' Number of table elements is',ILTAB,
     $     ' First ',ILT,' pairs are:'

         IF (ILT.GT.0) THEN
            IF (TOSCR) WRITE (*,'(2G13.5)')
     $       (TABLE(I1),TABLE(I1+1),I1=1,2*ILT,2)
            IF (TOLOG) WRITE (UNLOG,'(2G13.5)')
     $       (TABLE(I1),TABLE(I1+1),I1=1,2*ILT,2)
         END IF
         IF (ERR) CALL FATALERR ('LINT','execution terminated')
      END IF

*     interpolation and extrapolation
      SLOPE = (TABLE(IUP+1)-TABLE(IUP-1))/(TABLE(IUP)-TABLE(IUP-2))
      LINT  = TABLE(IUP-1)+(X-TABLE(IUP-2))*SLOPE

      RETURN
      END


!>
! @license Apache-2.0
!
! Copyright (c) 2020 The Stdlib Authors.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!<

!> Computes the L2-norm of a double-precision floating-point vector.
!
! ## Notes
!
! * Modified version of reference BLAS level1 routine (version 3.8.0). Updated to "free form" Fortran 95.
!
! ## Authors
!
! * Univ. of Tennessee
! * Univ. of California Berkeley
! * Univ. of Colorado Denver
! * NAG Ltd.
!
! ## History
!
! * Original version written on 25-October-1982.
!
! ## License
!
! From <http://netlib.org/blas/faq.html>:
!
! > The reference BLAS is a freely-available software package. It is available from netlib via anonymous ftp and the World Wide Web. Thus, it can be included in commercial software packages (and has been). We only ask that proper credit be given to the authors.
! >
! > Like all software, it is copyrighted. It is not trademarked, but we do ask the following:
! >
! > * If you modify the source for these routines we ask that you change the name of the routine and comment the changes made to the original.
! >
! > * We will gladly answer any questions regarding the software. If a modification is done, however, it is the responsibility of the person who modified the routine to provide support.
!
! @param {integer} N - number of values over which to compute the norm
! @param {Array<double>} dx - array
! @param {integer} stride - stride length
! @returns {double} the L2-norm
!<
double precision function dnrm2( N, dx, stride )
  implicit none
  !..
  ! Scalar arguments:
  integer :: N, stride
  ! ..
  ! Array arguments:
  double precision, intent(in) :: dx(*)
  ! ..
  ! Local scalars:
  double precision :: ax, scale, ssq
  integer :: i
  ! ..
  ! Intrinsic functions:
  intrinsic dabs, dsqrt
  ! ..
  dnrm2 = 0.0d0
  ! ..
  if ( N <= 0 .OR. stride <= 0 ) then
    return
  end if
  !..
  if ( N == 1 ) then
    dnrm2 = dabs( dx( 1 ) )
    return
  end if
  ! ..
  scale = 0.0d0
  ssq = 1.0d0
  do i = 1, 1+((N-1)*stride), stride
    if ( dx( i ) /= 0.0d0 ) then
      ax = dabs( dx( i ) )
      if ( scale < ax ) then
        ssq = 1.0d0 + ( ssq * (scale/ax)**2 )
        scale = ax
      else
        ssq = ssq + (ax/scale)**2
      end if
    end if
  end do
  dnrm2 = scale * dsqrt( ssq )
end function dnrm2


    Program zgbbrd_example

!     ZGBBRD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zgbbrd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: vect = 'N'
!     .. Local Scalars ..
      Integer :: i, info, j, kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), c(:, :), pt(:, :), q(:, :), &
        work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'ZGBBRD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, kl, ku, ncc
      ldab = kl + ku + 1
      ldc = m
      ldpt = n
      ldq = m
      Allocate (ab(ldab,n), c(m,ncc), pt(ldpt,n), q(ldq,m), work(m+n), d(n), &
        e(n-1), rwork(m+n))

!     Read A from data file

      Read (nin, *)((ab(ku+1+i-j,j),j=max(i-kl,1),min(i+ku,n)), i=1, m)

!     Reduce A to upper bidiagonal form

      Call zgbbrd(vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, ldq, pt, ldpt, &
        c, ldc, work, rwork, info)

!     Print bidiagonal form

      Write (nout, *)
      Write (nout, *) 'Diagonal'
      Write (nout, 100) d(1:min(m,n))
      Write (nout, *) 'Superdiagonal'
      Write (nout, 100) e(1:min(m,n)-1)

100   Format (1X, 8F9.4)
    End Program


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcmach(vold,v,nk,ntmat_,shcon,nshcon,physcon,
     &  inomat,mi)
!
      implicit none
!
      integer ntmat_,mi(*),nshcon(*),nk,i,imat,inomat(*)
!
      real*8 v(nk,0:mi(2)),vold(0:mi(2),*),cp,r,temp,
     &  shcon(0:3,ntmat_,*),physcon(*)
!
!     calculate kappa (cp/cv) and store it in v(*,0)
!     calculate the Mach number and store it in v(*,1)
!
      do i=1,nk
        imat=inomat(i)
        if(imat.eq.0) cycle
         temp=vold(0,i)
         call materialdata_cp_sec(imat,ntmat_,temp,shcon,
     &        nshcon,cp,physcon)
         r=shcon(3,1,imat)
         v(i,0)=cp/(cp-r)
         v(i,1)=dsqrt((vold(1,i)**2+vold(2,i)**2+vold(3,i)**2)
     &        /(v(i,0)*r*(temp-physcon(1))))
      enddo
!
      return
      end


!	Standard error for entropy per item under complex sampling.
!	This version is designed for random sampling of psu's within strata.
!	Sampling is with replacement.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!	stratum is observation stratum.
!	psu is observation psu.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.

!	obsweight is  observation weights.
!	prob is array of observed probabilities.
!	totalitems is weighted sum of items presented.
real(kind=8) function sdent_complex(npsu,nstratum,psu,stratum,stratify,usepsu,obsweight,prob,totalitems)
implicit none
interface

!	The following description is for the function's basic purpose.
!	Its use in this subroutine is a bit different.
!	Estimate the information matrix for a complex sample.
!	This version is designed for random sampling of psu's within strata.
!	Sampling is with replacement.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!	psu indicates the psu of an observation.
!	stratum indicates the stratum of an observation.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.
!	grads is the array of observation gradients.
!	obsweight contains observation weights.

    function information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,grads,obsweight)
        implicit none
        integer,intent(in)::nstratum
        integer,intent(in),optional::npsu(:),psu(:),stratum(:)
        logical,intent(in)::stratify,usepsu
        real(kind=8),intent(in)::grads(:,:),obsweight(:)
        real(kind=8)::information_complex(size(grads,1),size(grads,1))
    end function information_complex
end interface

integer,intent(in)::nstratum
integer,intent(in),optional::npsu(:),psu(:),stratum(:)
logical,intent(in)::stratify,usepsu
real(kind=8),intent(in)::obsweight(:),prob(:),totalitems

!	al indicates allocation error.
!   nobs is the number of observations.
!	obs is an observation counter.

integer::al,nobs,obs
!   Variance goes to covobs.
!	Log probabilities.
real(kind=8)::covobs(1,1)
real(kind=8),allocatable::obsmat(:,:)
nobs=size(prob)
allocate(obsmat(1,nobs),stat=al)
if(al/=0) stop "Unable to allocate arrays for asymptotic variances computations for complex sampling."
obsmat=0.0_8
do obs=1,nobs
    if(prob(obs)>0.0_8)obsmat(1,obs)=log(prob(obs))
end do
covobs=information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,&
    obsmat(1:1,:),obsweight)
sdent_complex=sqrt(covobs(1,1))/totalitems
deallocate(obsmat)

return
end function sdent_complex