!----------------------Function----------------------------------------!
!
      FUNCTION FNTBLX( FY,N1,N2,INDX )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Linearly interpolate from a table of values.
!
!     INDX = 0 : Table truncation beyond table limits.
!     INDX = 1 : Table extrapolation beyond table limits.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, PNL, March, 1993.
!     Last Modified by MD White, Battelle, PNL, April 14, 1994.
!     $Id: fntblx.F 1080 2017-03-14 16:22:02Z d3c002 $
!

!----------------------Fortran 90 Modules------------------------------!
!
      USE GLB_PAR
      USE TABL
      USE SOLTN
!

!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!

!
!----------------------Common Blocks-----------------------------------!
!

!
!----------------------Executable Lines--------------------------------!
!
      ISUB_LOG = ISUB_LOG+1
      SUB_LOG(ISUB_LOG) = '/FNTBLX'
      IF( INDEX(SVN_ID(61)(1:1),'$').EQ.0 ) SVN_ID(61) =
     & '$Id: fntblx.F 1080 2017-03-14 16:22:02Z d3c002 $'
!
!---  Ascending table order  ---
!
      IF( TBLY(N2) .GT. TBLY(N1) ) THEN
        IF( FY .LE. TBLY(N1) ) THEN
          IF( INDX.EQ.0 ) THEN
            FNTBLX = TBLX(N1)
          ELSE
            FNTBLX = (FY-TBLY(N1))*(TBLX(N1+1)-TBLX(N1))/
     &        (TBLY(N1+1)-TBLY(N1)) + TBLX(N1)
          ENDIF
        ELSEIF( FY .GE. TBLY(N2) ) THEN
          IF( INDX.EQ.0 ) THEN
            FNTBLX = TBLX(N2)
          ELSE
            FNTBLX = (FY-TBLY(N2))*(TBLX(N2)-TBLX(N2-1))/
     &        (TBLY(N2)-TBLY(N2-1)) + TBLX(N2)
          ENDIF
        ELSE
          DO 100 N = N1+1,N2
            IF( FY .LE. TBLY(N) ) THEN
              FNTBLX = (FY-TBLY(N-1))*(TBLX(N)-TBLX(N-1))/
     &          (TBLY(N)-TBLY(N-1)) + TBLX(N-1)
              GOTO 110
            ENDIF
  100     CONTINUE
  110   CONTINUE
        ENDIF
!
!---  Descending table order  ---
!
      ELSEIF( TBLY(N2) .LT. TBLY(N1) ) THEN
        IF( FY .LE. TBLY(N2) ) THEN
          IF( INDX.EQ.0 ) THEN
            FNTBLX = TBLX(N2)
          ELSE
            FNTBLX = (FY-TBLY(N2))*(TBLX(N2-1)-TBLX(N2))/
     &        (TBLY(N2-1)-TBLY(N2)) + TBLX(N2)
          ENDIF
        ELSEIF( FY .GE. TBLY(N1) ) THEN
          IF( INDX.EQ.0 ) THEN
            FNTBLX = TBLX(N1)
          ELSE
            FNTBLX = (FY-TBLY(N1))*(TBLX(N1)-TBLX(N1+1))/
     &        (TBLY(N1)-TBLY(N1+1)) + TBLX(N1)
          ENDIF
        ELSE
          DO 200 N = N1+1,N2
            IF( FY .GE. TBLY(N) ) THEN
              FNTBLX = (FY-TBLY(N))*(TBLX(N-1)-TBLX(N))/
     &          (TBLY(N-1)-TBLY(N)) + TBLX(N)
              GOTO 210
            ENDIF
  200     CONTINUE
  210   CONTINUE
        ENDIF
      ELSE
        INDX = 3
        CHMSG = 'Invalid Table'
        CALL WRMSGS( INDX )
      ENDIF
      ISUB_LOG = ISUB_LOG-1
!
!---  End of FNTBLX group
!
      RETURN
      END


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!               Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine compute_normal_vector( angle, n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z )

  implicit none

  include 'constants.h'

  double precision :: angle
  double precision :: n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z

  double precision  :: theta1, theta2, theta3
  double precision  :: costheta1, costheta2, costheta3

  if ( abs(n2_z - n1_z) < TINYVAL ) then
     costheta1 = 0
  else
     costheta1 = (n2_z - n1_z) / sqrt((n2_x - n1_x)**2 + (n2_z - n1_z)**2)
  endif
  if ( abs(n3_z - n2_z) < TINYVAL ) then
     costheta2 = 0
  else
     costheta2 = (n3_z - n2_z) / sqrt((n3_x - n2_x)**2 + (n3_z - n2_z)**2)
  endif
  if ( abs(n4_z - n3_z) < TINYVAL ) then
     costheta3 = 0
  else
    costheta3 = (n4_z - n3_z) / sqrt((n4_x - n3_x)**2 + (n4_z - n3_z)**2)
  endif

  theta1 = - sign(1.d0,n2_x - n1_x) * acos(costheta1)
  theta2 = - sign(1.d0,n3_x - n2_x) * acos(costheta2)
  theta3 = - sign(1.d0,n4_x - n3_x) * acos(costheta3)

  ! a sum is needed here because in the case of a source force vector
  ! users can give an angle with respect to the normal to the topography surface,
  ! in which case we must compute the normal to the topography
  ! and add it the existing rotation angle
  angle = angle + (theta1 + theta2 + theta3) / 3.d0 + PI/2.d0

  end subroutine compute_normal_vector

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

  subroutine tri_quad(n, n1, nnodes)

  implicit none

  integer  :: n1, nnodes
  integer, dimension(4)  :: n

  n(2) = n1

  if ( n1 == 1 ) then
     n(1) = nnodes
  else
     n(1) = n1-1
  endif

  if ( n1 == nnodes ) then
     n(3) = 1
  else
     n(3) = n1+1
  endif

  if ( n(3) == nnodes ) then
     n(4) = 1
  else
     n(4) = n(3)+1
  endif

  end subroutine tri_quad


submodule(nozzle_t_interface) nozzle_implementation
  !! Define the nozzle_t user-defined structure constructrors and type-bound procedures
  implicit none
contains

  module procedure new_nozzle_t
    use constants, only : pi
    new_nozzle_t%area_ = pi/4d0*dia**2 ! nozzle area
    new_nozzle_t%C_f_ = C_f
  end procedure

  module procedure calcthrust
    use constants, only : p_amb
    calcthrust = (p-p_amb)*this%area_*this%C_f_ ! correction to thrust (actual vs vacuum thrust)
  end procedure

  module procedure area
    area = this%area_
  end procedure

end submodule nozzle_implementation


program phaml_master
use phaml
implicit none
type(phaml_solution_type) :: soln
real(my_real) :: intgrl, invnorm
call phaml_create(soln,nproc=4)
call phaml_solve_pde(soln,print_grid_when=FINAL,print_grid_who=MASTER, &
                     max_vert=500)
intgrl = phaml_integrate(soln,1)
write(6,100) "integral of solution",intgrl
intgrl = phaml_integrate(soln,2)
write(6,100) "integral of x*solution",intgrl
intgrl = phaml_integrate(soln,1,p=2)
write(6,100) "integral of solution squared",intgrl
invnorm = sqrt(1/intgrl)
call phaml_scale(soln,invnorm)
intgrl = phaml_integrate(soln,1,p=2)
write(6,100) "integral of normalized solution squared",intgrl
call phaml_destroy(soln)
100 format(A,SS,1P,E19.12E2)
end program phaml_master


!
!     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 resultsmech_us3(co,kon,ipkon,lakon,ne,v,
     &  stx,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,
     &  ielmat,ielorien,norien,orab,ntmat_,t0,t1,ithermal,prestr,
     &  iprestr,eme,iperturb,fn,iout,qa,vold,nmethod,
     &  veold,dtime,time,ttime,plicon,nplicon,plkcon,nplkcon,
     &  xstateini,xstiff,xstate,npmat_,matname,mi,ielas,icmd,
     &  ncmat_,nstate_,stiini,vini,ener,eei,enerini,istep,iinc,
     &  reltime,calcul_fn,calcul_qa,calcul_cauchy,nener,
     &  ikin,nal,ne0,thicke,emeini,i,ielprop,prop,t0g,t1g)
!
!     calculates nal,qa,fn,xstiff,ener,eme,eei,stx for user element 1
!
!     This is a beam type element. Reference:
!     Yunhua Luo, An Efficient 3D Timoshenko Beam Element with
!     Consistent Shape Functions, Adv. Theor. Appl. Mech., Vol. 1,
!     2008, no. 3, 95-106
!
!
!     special case for which the beam axis goes through the
!     center of gravity of the cross section and the 1-direction
!     corresponds with a principal axis
!
!     note that the strain components are Lagrange strain components,
!     the stress components are Piola-Kirchhoff components of the
!     second kind. For linear geometric calculations the strains
!     reduce to the infinitesimal strains
!
!
!     INPUT:
!
!     co(1..3,i)         coordinates of node i
!     kon(*)             contains the topology of all elements. The
!                        topology of element i starts at kon(ipkon(i)+1)
!                        and continues until all nodes are covered. The
!                        number of nodes depends on the element label
!     ipkon(i)           points to the location in field kon preceding
!                        the topology of element i
!     lakon(i)           label of element i (character*8)
!     ne                 highest element number in the mesh
!     v(0..mi(2),i)      value of the variables in node i at the end
!                        of the present iteration
!     elcon              elastic constants (cf. List of variables and
!                        their meaning in the User's Manual)
!     nelcon             integers describing the elastic constant fields
!                        (cf. User's Manual)
!     rhcon              density constants (cf. User's Manual)
!     nrhcon             integers describing the density constant fields
!                        (cf. User's Manual)
!     alcon              thermal expansion constants (cf. User's Manual)
!     nalcon             integers describing the thermal expansion
!                        constants (cf. User's Manual)
!     alzero             thermal expansion reference values (cf. User's Manual)
!     ielmat(i)          material for element i
!     ielorien(i)        orientation for element i
!     norien             number of orientations
!     orab(7,*)          description of all local coordinate systems.
!                        (cf. List of variables and their meaning in the
!                        User's manual)
!     ntmat_             maximum number of material temperature points
!     t0(i)              temperature in node i at start of calculation
!     t1(i)              temperature in node i at the end of the current
!                        increment
!     ithermal(1..2)     cf. List of variables and
!                        their meaning in the User's Manual
!     prestr(i,j,k)      residual stress component i in integration point j
!                        of element k
!     iprestr            if 0: no residual stresses
!                        else: residual stresses
!     iperturb(*)        describes the kind of nonlinearity of the
!                        calculation, cf. User's Manual
!     iout               if -2: v is assumed to be known and is used to
!                               calculate strains, stresses..., no result output
!                               corresponds to iout=-1 with in addition the
!                               calculation of the internal energy density
!                        if -1: v is assumed to be known and is used to
!                               calculate strains, stresses..., no result
!                               output; is used to take changes in SPC's and
!                               MPC's at the start of a new increment or
!                               iteration into account
!                        if 0: v is calculated from the system solution
!                              and strains, stresses.. are calculated,
!                              no result output
!                        if 1: v is calculated from the system solution and
!                              strains, stresses.. are calculated, requested
!                              results output
!                        if 2: v is assumed to be known and is used to
!                              calculate strains, stresses..., requested
!                              results output
!     vold(0..mi(2),i)   value of the variables in node i at the end
!                        of the previous iteration
!     nmethod            procedure:
!                        1: static analysis
!                        2: frequency analysis
!                        3: buckling analysis
!                        4: (linear or nonlinear) dynamic analysis
!                        5: steady state dynamics analysis
!                        6: Coriolis frequency calculation
!                        7: flutter frequency calculation
!                        8:  magnetostatics
!                        9:  magnetodynamics
!                        10: electromagnetic eigenvalue problems
!                        11: superelement creation or Green function
!                            calculation
!                        12: sensitivity analysis
!     veold(j,i)         time rate of variable j in node i at the end
!                        of the previous iteration
!     dtime              length of present time increment
!     time               step time at the end of the present increment
!     ttime              total time at the start of the present increment
!     plicon,nplicon     fields describing isotropic hardening of
!                        a plastic material or spring constants of
!                        a nonlinear spring (cf. User's Manual)
!     plkcon,nplkcon     fields describing kinematic hardening of
!                        a plastic material or gap conductance
!                        constants (cf. User's Manual)
!     xstateini(i,j,k)   state variable component i in integration point j
!                        of element k at the start of the present increment
!     xstate(i,j,k)      state variable component i in integration point j
!                        of element k at the end of the present increment
!     npmat_             maximum number of plastic constants
!     matname(i)         name of material i
!     mi(1)              max # of integration points per element (max
!                        over all elements)
!     mi(2)              max degree of freedom per node (max over all
!                        nodes) in fields like v(0:mi(2))...
!     mi(3)              max number of layers in the structure
!     ielas              0: no elastic iteration: irreversible effects
!                        are allowed
!                        1: elastic iteration, i.e. no irreversible
!                           deformation allowed
!     icmd               not equal to 3: calculate stress and stiffness
!                        3: calculate only stress
!     ncmat_             max number of elastic constants
!     nstate_            max number of state variables in any integration
!                        point
!     stiini(i,j,k)      stress component i in integration point j
!                        of element k at the start of the present
!                        increment (= end of last increment)
!     vini(0..mi(2),i)   value of the variables in node i at the start
!                        of the present increment
!     enerini(j,k)       internal energy density at integration point j
!                        of element k at the start of the present increment
!     istep              current step number
!     iinc               current increment number within the actual step
!     reltime            relative step time (between 0 and 1)
!     calcul_fn          if 0: no nodal forces have to be calculated
!                        else: nodal forces are required on output
!     calcul_qa          if 0: no mean forces have to be calculated
!                        else: mean forces are required on output
!     calcul_cauchy      if 0: no Cauchy stresses are required
!                        else: Cauchy stresses are required on output: have
!                              to be calculated from the PK2 stresses
!     nener              if 0: internal energy calculation is not required
!                        else: internal energy is required on output
!     ikin               if 0: kinetic energy calculation is not requred
!                        else: kinetic energy is required on output
!     ne0                largest element number without contact elements (are
!                        stored after all other elements)
!     thicke(j,i)        layer thickness for layer j in element i
!     emeini(i,j,k)      mechanical strain component i in integration point j
!                        of element k at the start of the present increment
!     i                  actual element at stake
!     ielprop(i)         points to the location in field prop preceding
!                        the properties of element i
!     prop(*)            contains the properties and some beam
!                        elements (cf. User's Manual)
!
!
!     OUTPUT:
!
!     stx(i,j,k)         stress component i in integration point j
!                        of element k at the end of the present
!                        iteration
!     eme(i,j,k)         mechanical strain component i in integration point j
!                        of element k at the end of the present iteration
!     fn(j,i)            nodal force component j in node i
!     qa(1..4)           qa(1): average force
!                        qa(2): average flux
!                        ... cf. User's Manual
!     xstiff(i,j,k)      stiffness (i=1...21) and conductivity
!                        (i=22..27) constants in integration point j
!                        of element k
!     ener(j,k)          internal energy density at integration point j
!                        of element k at the end of the present increment
!     eei(i,j,k)         total strain component i in integration point j
!                        of element k at the end of the present iteration
!     nal                number of nodal force contributions
!
      implicit none
      !
      character*8 lakon(*)
      character*80 amat,matname(*)
      !
      integer kon(*),konl(26),mi(*),
     &  nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(mi(3),*),
     &  ielorien(mi(3),*),ntmat_,ipkon(*),ne0,nelem,
     &  istep,iinc,ne,mattyp,ithermal(*),iprestr,i,j,k,m1,m2,jj,
     &  i1,kk,nener,indexe,nope,norien,iperturb(*),iout,
     &  nal,icmd,ihyper,nmethod,kode,imat,iorien,ielas,
     &  istiff,ncmat_,nstate_,ikin,ielprop(*),
     &  nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_,calcul_fn,
     &  calcul_cauchy,calcul_qa,index,node,jjj,j1,j2
     !
      real*8 co(3,*),v(0:mi(2),*),stiini(6,mi(1),*),
     &  stx(6,mi(1),*),xl(3,26),vl(0:mi(2),26),stre(6),prop(*),
     &  elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*),
     &  alcon(0:6,ntmat_,*),vini(0:mi(2),*),q1,
     &  alzero(*),orab(7,*),elas(21),rho,fn(0:mi(2),*),
     &  q(0:mi(2),26),t0(*),t1(*),prestr(6,mi(1),*),eme(6,mi(1),*),
     &  vold(0:mi(2),*),eloc(9),elconloc(21),eth(6),coords(3),
     &  ener(mi(1),*),emec(6),eei(6,mi(1),*),enerini(mi(1),*),
     &  veold(0:mi(2),*),e,un,um,tt,dl,qa(*),t0l,t1l,dtime,time,ttime,
     &  plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*),
     &  xstiff(27,mi(1),*),xstate(nstate_,mi(1),*),plconloc(802),
     &  xstateini(nstate_,mi(1),*),tm(3,3),a,reltime,kap,
     &  thicke(mi(3),*),emeini(6,mi(1),*),aly,alz,bey,bez,xi(2),
     &  vlp(6,2),aa,Bs(2,18),Bb(3,18),Bm(3,18),tau(2),Smf(3),
     &  h,xg(3,3),x(3,3),ushell(18),fintg(18),ueg(18),pgauss(3),
     &  Ds(2,2),Qs(2,2),Qin(3,3),Dm(3,3),Db(3,3),temp_grad0,
     &  Kp(18,18),Km(18,18),tmg(18,18),Kshell(18,18),
     &  alp(3),temp_grad,thick_gp(2),ftherm(18),beta(6),
     &  d3,Ae,tmt(3,3),Ys(2),Emf(3),gpthick(3,2),
     &  Ethm(3),Ethf(3),Em(3),Ef(3),alph6(6),t0g(2,*),t1g(2,*),
     &  Dsi(2,2),Dmi(3,3),Dbi(3,3),di,dett,dettt
      !
      nope = 3
      !
      Bs(:,:) = 0.d0
      Bb(:,:) = 0.d0
      Bm(:,:) = 0.d0
      beta(:) = 0.d0
      !
      gpthick(1,1) = +1.d0
      gpthick(2,1) =  0.d0
      gpthick(3,1) = -1.d0
      gpthick(1,2) = 2.d0/6.d0
      gpthick(2,2) = 8.d0/6.d0
      gpthick(3,2) = 2.d0/6.d0
      !

      !
      di = 1.d0/3.d0
      !
      indexe=ipkon(i)
      !
      ! properties of the shell section
      !
      index = ielprop(i)
      h = prop(index+1)
      dett  = h/2.d0
      dettt = h**3/8.d0
      !
      ! material and orientation
      !
      imat   = ielmat(1,i)
      amat   = matname(imat)
      !
       if(norien.gt.0) then
          iorien = max(0,ielorien(1,i))
       else
          iorien = 0
       endif
       !
       if(nelcon(1,imat).lt.0) then
          ihyper = 1
       else
          ihyper = 0
       endif
      !
      kode = nelcon(1,imat)
      !
      if(kode.eq.2) then
         mattyp=1
      else
         mattyp=0
      endif
      !
      !     computation of the coordinates and displacements of the local nodes
      !
      ! vl: u,v,w,rx,ry,rz
      do k = 1,nope
        konl(k) = kon(indexe+k)
        do j = 1,3
          xg(k,j)   = co(j,konl(k))  ! global coordinates element nodes
	      vl(j,k)   = v(j,konl(k))   ! uvw
          vl(j+3,k) = v(j+3,konl(k)) ! rxyz
        enddo
      enddo
!
!     gp temp gradient based nodal gradients
      if(ithermal(1).ne.0) then
        temp_grad  = (t1g(1,konl(1))+t1g(1,konl(2))+t1g(1,konl(3)))*di
        temp_grad0 = (t0g(1,konl(1))+t0g(1,konl(2))+t0g(1,konl(3)))*di
      endif
      !
      ! e0-frame base tm (3x3) -> tmg (18x18)
      call us3_csys(xg,tm,tmg)  ! | call us3_csys_cr(xg,tm,tmg)
      call us3_xu(x,ushell,ueg,xg,tm,vl(1:6,1:3))  ! coords,displ in e0-frame & global displ
      !
      !  stress and strains
      !
      call us3_Bs(x,Bs) ! constant
      call us3_Bb(x(:,1),x(:,2),Bb) ! constant
      !
      Dm(:,:) = 0.d0
      Db(:,:) = 0.d0
      Ds(:,:) = 0.d0
      !
      do jjj = 1,3  ! ----  start loop gauß points ----
        !
        ! natural coordinates z-dirc. -1,0,1
        !
        if(jjj.eq.1) then
          aa = -0.5d0*h
        elseif(jjj.eq.2) then
          aa = 0.d0
        else
          aa = 0.5d0*h
        endif
        !
        if(ithermal(1).ne.0) then
          t0l = (t0(konl(1))+t0(konl(2))+t0(konl(3)))/3.d0
     &         +temp_grad0*aa
          t1l = (t1(konl(1))+t1(konl(2))+t1(konl(3)))/3.d0
     &         +temp_grad*aa
        endif
        !
        istiff = 0
        call us3_materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,
     &           nalcon,imat,amat,iorien,pgauss,orab,ntmat_,
     &           elas,rho,i,ithermal,alzero,mattyp,t0l,t1l,ihyper,
     &           istiff,elconloc,eth,kode,plicon,nplicon,
     &           plkcon,nplkcon,npmat_,plconloc,mi(1),dtime,jjj,
     &           xstiff,ncmat_)
        !
        if(mattyp.eq.1) then
          e   = elas(1)
          un  = elas(2)
          rho = rhcon(1,1,imat)
          alp(1) = eth(1) !alcon(1,1,imat)
          alp(2) = eth(1) !alcon(1,1,imat)
          alp(3) = 0.d0
        elseif(mattyp.eq.2) then
          write(*,*) '*ERROR in e_c3d_US3: no orthotropic material'
          write(*,*) '       calculation for this type of element'
          call exit(201)
        else
          write(*,*) '*ERROR in e_c3d_US3: no anisotropic material'
          write(*,*) '       calculation for this type of element'
          call exit(201)
        endif
        !
        call us3_linel_Qi(e,un,Qin,Qs)
        Dm = Dm + Qin*gpthick(jjj,2)*dett
        Db = Db + Qin*((gpthick(jjj,1))**2)*gpthick(jjj,2)*dettt
        Ds = Ds + Qs*gpthick(jjj,2)*dett
        !
        !  save elastic constants in xstff -> e_c3d_us3
        !
        ! material data; for linear elastic materials
        ! this includes the calculation of the stiffness
        ! matrix
        kode = 2
        call linel(kode,mattyp,beta,eme,stre,elas,elconloc,
     &  iorien,orab,pgauss)
        do m1=1,21
          xstiff(m1,jjj,i) = elas(m1) ! elas for each gp saved in xstiff
        enddo
        !
        call bm_ANDES(x,Bm,Qin,h,di,di)
        !
        ! Total strains
        !
        Ys  = matmul(Bs,ushell)
        Em  = matmul(Bm,ushell)
        Ef  = aa*(matmul(Bb,ushell))
        Emf = Em + Ef
        !
        ! -> eei total strains out
        !
        if((iout.gt.0).or.(iout.eq.-2).or.(kode.le.-100)) then
          eei(1,jjj,i)  = Emf(1)
          eei(2,jjj,i) = Emf(2)
          eei(3,jjj,i) = 0.d0
          eei(4,jjj,i) = Emf(3)
          eei(5,jjj,i) = Ys(2)
          eei(6,jjj,i) = Ys(1)
        endif
        !
        if(ithermal(1).ne.0) then
          t0l = (t0(konl(1))+t0(konl(2))+t0(konl(3)))/3.d0+temp_grad0*aa
          t1l = (t1(konl(1))+t1(konl(2))+t1(konl(3)))/3.d0+temp_grad*aa
          !
          Ethm = alp*(t1l-t0l)  ! mem
          Ethf = alp*(temp_grad-temp_grad0)*aa  ! bend.
          Emf = Emf-(Ethf+Ethm)
        endif
        !
        ! mechanical strains
        !
        eme(1,jjj,i) = Emf(1)
        eme(2,jjj,i) = Emf(2)
        eme(3,jjj,i) = 0.d0
        eme(4,jjj,i) = Emf(3)
        eme(5,jjj,i) = Ys(2)
        eme(6,jjj,i) = Ys(1)
        !
        Smf = matmul(Qin,Emf)
        tau = matmul(Qs,Ys)
        !
        stx(1,jjj,i) = Smf(1)   ! sxx
        stx(2,jjj,i) = Smf(2)   ! syy
        stx(3,jjj,i) = 0.d0     ! szz
        stx(4,jjj,i) = Smf(3)   ! txy
        stx(5,jjj,i) = tau(1)   ! tyz
        stx(6,jjj,i) = tau(2)   ! txz
        !
        stre(1) = Smf(1)   ! sxx
        stre(2) = Smf(2)   ! syy
        stre(3) = 0.d0     ! szz
        stre(4) = Smf(3)   ! txy
        stre(5) = tau(1)   ! tyz
        stre(6) = tau(2)   ! txz
        !
      enddo  ! ----  end loop gauß points ----
      !
      ! Thermal loads
      !
      if(ithermal(1).ne.0) then
        !
        call us3_ae(x,Ae) ! element area
        ftherm(:) = 0.d0
        !
        do k = 1,3
          !
          t0l = ((t0(1)+t0(2)+t0(3))/3.d0)!+temp_grad0*0.5*h*gpthick(k,1)
          t1l = ((t1(1)+t1(2)+t1(3))/3.d0)!+temp_grad*0.5*h*gpthick(k,1)
          !
          istiff=1
          call us3_materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,
     &     nalcon,imat,amat,iorien,coords,orab,ntmat_,elas,rho,
     &     i,ithermal,alzero,mattyp,t0l,t1l,
     &     ihyper,istiff,elconloc,eth,kode,plicon,
     &     nplicon,plkcon,nplkcon,npmat_,
     &     plconloc,mi(1),dtime,k,
     &     xstiff,alcon)
          e     = elas(1)
          un    = elas(2)
          rho   = rhcon(1,1,imat)
          alp(1) = eth(1)!alcon(1,1,imat)
          alp(2) = eth(2)!alcon(1,1,imat)
          alp(3) = 0.d0
          !
          call us3_linel_Qi(e,un,Qin,Qs)
          !
          ftherm=ftherm-matmul(matmul(transpose(Bm),Qin),alp)
     &     *(t1l-t0l)*Ae*gpthick(k,2)*dett
          ftherm=ftherm-matmul(matmul(transpose(Bb),Qin) ,alp)*
     &    (temp_grad-temp_grad0)*Ae*(gpthick(k,1)**2)*dettt*gpthick(k,2)
        enddo
!         t0l = ((t0(1)-t0(2)-t0(3))/3.d0)!+temp_grad0*0.5*h*g_p(k,1)
!         t1l = ((t1(1)+t1(2)+t1(3))/3.d0)!+temp_grad*0.5*h*g_p(k,1)
!         ftherm=ftherm-matmul(matmul(transpose(Bm),Dm),alp)
!      &     *(t1l-t0l)*Ae
!         ftherm=ftherm-matmul(matmul(transpose(Bb),Db)
!      &     ,alp)*(temp_grad-temp_grad0)*Ae*h
        do k = 1,nope
          konl(k) = kon(indexe+k)
          do j = 1,3
            fn(j,konl(k))   = fn(j,konl(k))  +ftherm(j+(k-1)*6)    ! f_th
            fn(j+3,konl(k)) = fn(j+3,konl(k))+ftherm(j+3+(k-1)*6)  ! r_th
          enddo
        enddo
      endif
      !
      ! Internal forces based on displacments
      !
      if(calcul_fn.eq.1)then
        !
        !   stiffness matirx (6 dofs 3 nodes -> 18x18)
        !
        call us3_Kp(x,Db,Ds,Kp) ! plate part (CS-DSG) - in e0-frame
        call us3_Km(x,Km,Dm/h,h) ! membrane part (ANDES) - in e0-frame
        !
        Kshell = matmul(matmul(transpose(tmg),(Km+Kp)),tmg)
        fintg  = matmul(Kshell,ueg)
        do k = 1,nope
          konl(k) = kon(indexe+k)
          do j = 1,3
            fn(j,konl(k))   = fn(j,konl(k))  +fintg(j+(k-1)*6)    ! fi
            fn(j+3,konl(k)) = fn(j+3,konl(k))+fintg(j+3+(k-1)*6)  ! ri
          enddo
        enddo
      endif
      !
      !
      !     q contains the contributions to the nodal force in the nodes
      !     belonging to the element at stake from other elements (elements
      !     already treated). These contributions have to be
      !     subtracted to get the contributions attributable to the element
      !     at stake only
      !
      if(calcul_qa.eq.1) then
        do m1=1,nope
          do m2=1,3
            qa(1)=qa(1)+dabs(fn(m2,konl(m1))-q(m2,m1))
          enddo
        enddo
        nal=nal+3*nope
      endif
      !
      return
      end


!  compile using "gfortran -xf95-cpp-input"
!    to invoke the preprocessor

PROGRAM iceline_emombm

use emombm
IMPLICIT NONE

!  Declarations
	INTEGER, PARAMETER :: maxSizeS0array = 5000
	INTEGER i, ice, ess
	REAL*8, DIMENSION(J) :: Quold, Qlold, Tsold, Qunew, Qlnew, Tsnew
	REAL*8 ::  Taveold, Tavenew
	!REAL*8, PARAMETER :: S0max = 1450., S0min = 1150., deltaS0 = 1.
	!INTEGER, PARAMETER :: sizeS0array = NINT((S0max-S0min)/deltaS0*2) + 1
	REAL*8, DIMENSION(maxSizeS0array) :: S0array
	INTEGER :: sizeS0array, ios
	CHARACTER(LEN=100) :: S0file,outputfile,iceoutfile
	REAL*8 value, joe
	REAL*8 :: maxS0,minS0,deltaS0
	LOGICAL done

	namelist /icelineparam/ S0file,outputfile,iceoutfile,maxS0,minS0,deltaS0

	open(unit=8,file='paramfile')
	read(unit=8,nml=icelineparam)
	close(unit=8)

	call emombm_setup()

	!  read in the array of solar constants
	S0array = -1. !pad the array with extra -1 values... we declare a larger array than we need so that we can run with different S0 files without recompiling.
	!open(unit=9,file=S0file)
	!ios = 0
	!ess = 0
	!DO WHILE(ios==0)
	!	read(unit=9,fmt=103,iostat=ios) value
	!	if (ios==0) then
	!		ess = ess+1
	!		S0array(ess) = value
	!	end if
	!END DO
	!close(unit=9)
	!sizeS0array = ess
	done = .FALSE.
	S0array(1) = maxS0
	ess = 2
	DO WHILE(.NOT. done)
		joe = S0array(ess-1) - deltaS0
		IF ( joe .GE. minS0 ) THEN
			S0array(ess) = joe
		ELSE
			S0array(ess) = S0array(ess-1)+deltaS0
			done = .TRUE.
		END IF
		ess = ess+1
	END DO
	done = .FALSE.
	DO WHILE(.NOT. done)
		joe = S0array(ess-1)+deltaS0
		IF (joe .LE. maxS0 ) THEN
			S0array(ess) = joe
		ELSE
			sizeS0array = ess-1
			done = .true.
		END IF
		ess = ess+1
	END DO

	print *, ' '
	print *, 'Running an iceline experiment with sizeS0array = '
	print *, sizeS0array
	print *, ' '

	!  initial condition
	Quold = dble(2.0)*f0/sqrt(2.)*sin(phiq)
	Qlold = Quold
	Taveold = 11.
	Tsold = 40.-40.*2./pi*phiq

	! open output files
	open(unit=9, file=S0file)
	open(unit=10, file=outputfile)
	open(unit=11, file=iceoutfile)

	DO ess=1,sizeS0array
		S0 = S0array(ess)
		S = S0/4*(1. + s2/2*(3*sin(phiq)**2 -1) )
		print *, S0
time:	DO i=1,numsteps
			call timestep_emombm(Quold,Qlold,Taveold,Tsold,Qunew,Qlnew,Tavenew,Tsnew,ice)
			Quold  = Qunew
			Qlold = Qlnew
			Taveold = Tavenew
			Tsold = Tsnew
		END DO time
		PRINT *, ice
		write(unit=9,fmt=100) S0
		write(unit=10, fmt=99) Qunew,Qlnew
		write(unit=10,fmt=100) Tavenew
		write(unit=10,fmt=100) Tsnew
		write(unit=11,fmt=102) ice
	END DO

	close(unit=9)
	close(unit=10)
	close(unit=11)

	print *, 'Done. Go home.'

	99 format(E20.10)
	101 format(F14.2)
	100 format(F14.8)
	102 format(I10)
	103 format(E20.7)

END PROGRAM iceline_emombm


      SUBROUTINE GAUSS (A,N,N2)
C
      COMPLEX A(20,1)
C
      DO 100 I=1,N
      K=I+1
      DO 10 J=K,N2
   10 A(I,J)=A(I,J)/A(I,I)
      DO 30 M=1,N
      IF(M.EQ.I) GO TO 30
      DO 20 L=K,N2
   20 A(M,L)=A(M,L)-A(M,I)*A(I,L)
   30 CONTINUE
  100 CONTINUE
      RETURN
      END


c
c---------------------------------------------------------------------
c
      subroutine makebx(ix0,iy0,ixadj,iyadj,ivert,x1,y1,x2,y2,ddx,ddy,
     &                  box,areabx,ix1,iy1,ix2,iy2)
      implicit double precision (a-h,o-z)
      dimension box(10,2)
c
c     # create box, a list of vertices corresponding to a box starting at
c     # (x1,y1), (x2,y2) and going out (ddx,ddy).
c     # On input,
c     #    (ix0,iy0) is index of current cell,
c     #               with (x1,y1),(x2,y2) being one side of this cell
c     #    (ixadj,iyadj) is the adjacent cell across this side
c     #    ivert = 1 if this is a vertical side
c     #            0 if this is a horizontal side
c     # On output,
c     #    box is the box
c     #    areabx is the area of the box
c     #    (ix1,iy1) is the cell that the box first intersects, going
c     #             away from the initial side
c     #    (ix2,iy2) is the other cell this box intersects, if any.
c
      ihoriz = 1-ivert
      if (ddx*(y2-y1)-ddy*(x2-x1) .gt. 0.d0) then
	  is = 1
	  ix1 = ix0
	  iy1 = iy0
	else
	  is = -1
	  ix1 = ixadj
	  iy1 = iyadj
	endif
c
      ix2 = ix1 + ihoriz*isig(ddx)
      iy2 = iy1 + ivert*isig(ddy)
c     ix2 = ix1 + dsign(dfloat(ihoriz),(ddx))
c     iy2 = iy1 + dsign(dfloat(ivert),(ddy))
      areabx = ivert*dabs((y2-y1)*ddx) + ihoriz*dabs((x2-x1)*ddy)
c
      box(1,1) = x1
      box(1,2) = y1
      box(3-is,1) = x2
      box(3-is,2) = y2
      box(3,1) = x2 + ddx
      box(3,2) = y2 + ddy
      box(3+is,1) = x1 + ddx
      box(3+is,2) = y1 + ddy
      box(5,1) = x1
      box(5,2) = y1
      box(6,1) = -11
c
      return
      end


!*==dgelqf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DGELQF
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGELQF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LWORK, M, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGELQF computes an LQ factorization of a real M-by-N matrix A:
!>
!>    A = ( L 0 ) *  Q
!>
!> where:
!>
!>    Q is a N-by-N orthogonal matrix;
!>    L is a lower-triangular M-by-M matrix;
!>    0 is a M-by-(N-M) zero matrix, if M < N.
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          with the array TAU, represent the orthogonal matrix Q as a
!>          product of elementary reflectors (see Further Details).
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,M).
!>          For optimum performance LWORK >= M*NB, where NB is the
!>          optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2019
!
!> \ingroup doubleGEcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!>  and tau in TAU(i).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DGELQF(M,N,A,Lda,Tau,Work,Lwork,Info)
      IMPLICIT NONE
!*--DGELQF147
!
!  -- LAPACK computational routine (version 3.9.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2019
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Lwork , M , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Tau(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER i , ib , iinfo , iws , k , ldwork , lwkopt , nb , nbmin , &
     &        nx
!     ..
!     .. External Subroutines ..
      EXTERNAL DGELQ2 , DLARFB , DLARFT , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      EXTERNAL ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      nb = ILAENV(1,'DGELQF',' ',M,N,-1,-1)
      lwkopt = M*nb
      Work(1) = lwkopt
      lquery = (Lwork==-1)
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ELSEIF ( Lwork<MAX(1,M) .AND. .NOT.lquery ) THEN
         Info = -7
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGELQF',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      k = MIN(M,N)
      IF ( k==0 ) THEN
         Work(1) = 1
         RETURN
      ENDIF
!
      nbmin = 2
      nx = 0
      iws = M
      IF ( nb>1 .AND. nb<k ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         nx = MAX(0,ILAENV(3,'DGELQF',' ',M,N,-1,-1))
         IF ( nx<k ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            ldwork = M
            iws = ldwork*nb
            IF ( Lwork<iws ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               nb = Lwork/ldwork
               nbmin = MAX(2,ILAENV(2,'DGELQF',' ',M,N,-1,-1))
            ENDIF
         ENDIF
      ENDIF
!
      IF ( nb>=nbmin .AND. nb<k .AND. nx<k ) THEN
!
!        Use blocked code initially
!
         DO i = 1 , k - nx , nb
            ib = MIN(k-i+1,nb)
!
!           Compute the LQ factorization of the current block
!           A(i:i+ib-1,i:n)
!
            CALL DGELQ2(ib,N-i+1,A(i,i),Lda,Tau(i),Work,iinfo)
            IF ( i+ib<=M ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i) H(i+1) . . . H(i+ib-1)
!
               CALL DLARFT('Forward','Rowwise',N-i+1,ib,A(i,i),Lda,     &
     &                     Tau(i),Work,ldwork)
!
!              Apply H to A(i+ib:m,i:n) from the right
!
               CALL DLARFB('Right','No transpose','Forward','Rowwise',  &
     &                     M-i-ib+1,N-i+1,ib,A(i,i),Lda,Work,ldwork,    &
     &                     A(i+ib,i),Lda,Work(ib+1),ldwork)
            ENDIF
         ENDDO
      ELSE
         i = 1
      ENDIF
!
!     Use unblocked code to factor the last or only block.
!
      IF ( i<=k ) CALL DGELQ2(M-i+1,N-i+1,A(i,i),Lda,Tau(i),Work,iinfo)
!
      Work(1) = iws
!
!     End of DGELQF
!
      END SUBROUTINE DGELQF


program MarsCrustalThickness
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will compute the relief along the crust-mantle interface that
!	is needed to explain the martian gravity field. This crustal thickness model
!	is "anchored" by chosing a minimum crustal thickness.
!
!	Note that in this program, that the maximum spherical harmonic degree that is used
!	when calculating the relief raised to the nth power is the input spherical harmonic
!	degree. This is not entirely correct, as the relief raised to the nth power generates
!	a spherical harmonic field up to lmax*n. However, as it is also not correct to assume
!	that the topo and gravity field are bandlimited with a maximum spherical harmonic degree
!	of lmax, this approximation is probably ok.
!
!	Written by Mark Wieczorek 2003
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	use SHTOOLS
	use PLANETSCONSTANTS

	implicit none
	integer, parameter :: max1 = 110
	real*8 :: 	r0, mass, rho_u, rho_l, pi, topo_c(2, max1+1, max1+1), &
			moho_c(2,max1+1, max1+1), bc(2,max1+1, max1+1), gm, &
			ba(2,max1+1, max1+1), pot(2,max1+1, max1+1), d, thick_min, &
			delta, delta_max, thick_delta, param(8), grav, cilm(2,max1+1, max1+1), &
			tmin, r_grav, interval, rref, misfit(2,max1+1, max1+1), timein, timeout
	real*8, allocatable ::	topogrid(:,:), mohogrid(:,:), mohogrid_old(:,:)
	integer ::	l, m, lmax, i, nmax, nlat, nlong, gridtype, astat, n_out, &
			iter, j, r1, lmaxp, lmaxt, filter_type, filter_degree, degmax
	character*80 ::	grav_file, moho_out, thick_grid_out, topo_file, misfit_file

	pot = 0.0d0
	topo_c = 0.0d0

	print*,  "rho_crust (kg/m3) > "
	read(*,*) rho_u
	print*, "rho_mantle (kg/m3) > "
	read(*,*) rho_l

	pi = acos(-1.0d0)
	delta_max = 5.0d0
	grav = Grav_constant

	gridtype = 3
	nmax = 6	! nmax of Wieczorek and Phillips (1998)

	print*, "Input filter type (1) Minimum amplitude, (2) minimum curvature, (0) no filter "
	read(*,*) filter_type
	if (filter_type /= 0 ) then
		print*, "Degree at which the filter is 1/2 "
		read(*,*) filter_degree
	endif

	grav_file = "../ExampleDataFiles/jgm85h02.sh"
	topo_file = "../ExampleDataFiles/Mars2000.shape"

	print*, "Remove degree 1 topo coefficients from Bouguer Correction? (0:no, 1:yes) > "
	read(*,*) r1

	print*, "maximum degree to compute Moho relief to >"
	read(*,*) degmax

	lmax = 2 * degmax ! this partially takes into account aliasing problems. Technically, it should be nmax*degmax
	if (degmax > max1) then
		print*, "Reset PARAMETER MAXDEG to ", degmax, "and recompile."
		stop
	endif

	nlat = 2*lmax+2
	nlong = 2*nlat

	print*, "Minimum assumed crustal thickness (km) > "
	read(*,*) thick_min
	thick_min = thick_min*1.d3

	print*, "Moho spherical harmonic coeficient output filename > "
	read(*,*) moho_out
	print*, "Grid spacing for output crustal thickness map (degrees) > "
	read(*,*) interval
	print*, "gridded crustal thickness output filename >"
	read(*,*) thick_grid_out
	print*, "Gravity misfit spherical harmonic filename >"
	read(*,*) misfit_file

	call cpu_time(timein)

	allocate(topogrid(nlat, nlong), stat = astat)
	if (astat /= 0) then
		print*, "Problem allocating array TOPOGRID."
		stop
	endif

	allocate(mohogrid(nlat, nlong), stat = astat)
	if (astat /= 0) then
		print*, "Problem allocating array TOPOGRID."
		stop
	endif

	allocate(mohogrid_old(nlat, nlong), stat = astat)
	if (astat /= 0) then
		print*, "Problem allocating array TOPOGRID."
		stop
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Read topo and grav files
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Reading data from ", grav_file
	call SHRead(grav_file, pot, lmaxp, header=param(1:2))

	gm = param(2)
	r_grav = param(1)
	mass = gm/grav

	print*, "Mass (kg) = ", mass
	print*, "Lmax of gravitational potential file = ", lmaxp

	print*, "Reading data from ", topo_file
	call SHRead(topo_file, topo_c, lmaxt, header=param(1:8))
	print*, "Lmax of topography file = ", lmaxt

	r0 = topo_c(1,1,1)
	print*, "r0 (km) = ", r0/1.d3

	! Downward continue gravity coefficients from 3397 to MPR

	do l = 2, lmaxp
		pot(1:2,l+1,1:l+1) = pot(1:2,l+1,1:l+1) * (r_grav/r0)**l
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Create Bouger anomaly up to degree nmax
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	print*, "Creating Bouger anomaly"

	call MakeGridDH(topogrid, n_out, topo_c, lmax, norm = 1, sampling = 2, csphase = 1, lmax_calc = degmax)

	print*, "Maximum Topo (km) = ", maxval(topogrid(1:nlat, 1:nlong))/1.d3
	print*, "Minimum Topo (km) = ", minval(topogrid(1:nlat, 1:nlong))/1.d3

	call CilmPlus(bc, topogrid, degmax, nmax, mass, rref, rho_u, gridtype, n = nlat)

	ba = pot - bc	! This is the bouguer anomaly

	if (r1==1) ba(1:2,2,1:2) = 0.0d0

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute crustal thickness by iterating at each
	!	reference moho depth. Gravity anomalies are calculated
	!	using n*lmax coefficients, but only the first lmax are
	!	used in the crustal thickness calculations.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	thick_delta = 1.d9

	d = r0 - 44.0d3		! initial reference moho depth

	do while (abs(thick_delta) > delta_max)

		write(*,*)
		print*, "Reference depth (km) = ", (r0-d)/1.d3

		moho_c = 0.0d0
		moho_c(1,1,1) = d

		do l=1, degmax
			moho_c(1:2,l+1,1:l+1) =  ba(1:2,l+1,1:l+1) *mass * (2.0d0*l+1.0d0) * ((r0/d)**l) &
				/(4.0d0*pi*(rho_l-rho_u)*d**2)
		enddo

		call MakeGridDH(mohogrid_old, n_out, moho_c, lmax, norm = 1, sampling = 2, csphase = 1, lmax_calc = degmax)

		print*, "Maximum Crustal thickness (km) = ", maxval(topogrid(1:nlat, 1:nlong)-mohogrid_old(1:nlat, 1:nlong))/1.d3
		print*, "Minimum Crustal thickness (km) = ", minval(topogrid(1:nlat, 1:nlong)-mohogrid_old(1:nlat, 1:nlong))/1.d3

		iter = 0
		delta = 1.d9

		do while(delta > delta_max)

			iter = iter +1
			print*, "Iteration ", iter

			call Hilm(moho_c, ba, mohogrid_old, lmax, nmax, mass, r0, rho_l-rho_u, gridtype, &
				filter_type=filter_type, filter_deg=filter_degree, lmax_calc = degmax)

			call MakeGridDH(mohogrid, n_out, moho_c, lmax,  norm = 1, sampling = 2, csphase = 1, lmax_calc = degmax)

			delta = maxval(abs(mohogrid(1:nlat, 1:nlong)-mohogrid_old(1:nlat, 1:nlong)))

			print*, "Delta (km) = ", delta/1.d3
			print*, "Maximum Crustal thickness (km) = ", maxval(topogrid(1:nlat, 1:nlong)-mohogrid(1:nlat, 1:nlong))/1.d3
			print*, "Minimum Crustal thickness (km) = ", minval(topogrid(1:nlat, 1:nlong)-mohogrid(1:nlat, 1:nlong))/1.d3

			tmin = minval(topogrid(1:nlat, 1:nlong)-mohogrid(1:nlat, 1:nlong))
			mohogrid_old = mohogrid

		enddo

		call CilmPlus(cilm, mohogrid, degmax, nmax, mass, rref, rho_l-rho_u, gridtype, n=nlat)

		d = d + 1.0*(tmin-thick_min)
		thick_delta  = tmin  - thick_min

	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Determine misfit between observed and calculated gravity, and write
	!	data to external files. Note that here, only coefficients up to lmax
	!	are considered.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! upward continue moho coefficients
	do l=0, degmax
		cilm(1:2,l+1,1:l+1) = cilm(1:2,l+1,1:l+1) * (d/r0)**l
	enddo

	misfit = pot - (bc + cilm) 	! this is the misfit
	misfit(1,1,1) = 0.0d0		! ignore degree-0 misfit

	do l=0, degmax
		cilm(1:2,l+1,1:l+1) = misfit(1:2,l+1,1:l+1)*(l+1.0d0)*gm*(1.0d5)/r0**2
	enddo

	call MakeGridDH(mohogrid_old, n_out, cilm, lmax, norm = 1, sampling = 2, csphase = 1, lmax_calc = degmax)

	print*, "Maximum misfit (mgals) = ", maxval(mohogrid_old(1:nlat, 1:nlong))
	print*, "Minimum misfit (mgals) = ", minval(mohogrid_old(1:nlat, 1:nlong))

	print*, "Mean Crustal Thickness (km) =", (r0-moho_c(1,1,1))/1.d3

	print*, "Writing output data"

	open(12,file=moho_out)

	do l=0,degmax
		do m=0,l
			write(12,*) l, m, moho_c(1,l+1,m+1), moho_c(2,l+1,m+1)
		enddo
	enddo

	close(12)

	call MakeGrid2d(topogrid, topo_c - moho_c, degmax, interval, nlat, nlong)

	open(12, file=thick_grid_out)
	write(12,*) nlat, nlong
	do i=1, nlat
		do j=1,nlong
			write(12,*) topogrid(i,j)/1.d3
		enddo
	enddo

	close(12)

	open(12, file=misfit_file)
	do l=0,degmax
		do m=0,l
			write(12,*) l, m, misfit(1,l+1,m+1), misfit(2,l+1,m+1)
		enddo
	enddo

	close(12)

	deallocate(topogrid)
	deallocate(mohogrid)
	deallocate(mohogrid_old)

	call cpu_time(timeout)
	print*, "time (sec) = ", timeout-timein

end program MarsCrustalThickness


module math_utilities
!*Brief Description:* This module contains solvers required for lung problems
!
!*LICENSE:*
!
!
!
!*Full Description:*
!
!
  use arrays, only: dp
  use diagnostics, only: enter_exit

  implicit none
  private
  public ax_cr,diagonal_pointer_cr,ilu_cr,lus_cr,mult_givens,rearrange_cr
  public sort_integer_list
  public sort_real_list

contains
!
!###########################################################################
!
!*ax_cr:* Computes A*x for a matrix stored in sparse compressed row form
  subroutine ax_cr ( n, ia, ja, a, x, w )
    implicit none

    integer ( kind = 4 ) n !the order of the system
    integer ( kind = 4 ) ia(*) !ia(n+1) row indices
    integer ( kind = 4 ) ja(*) !ja(nz_num) column indices
    real ( kind = 8 ) a(*) !a(nz_num) Matrix values
    real ( kind = 8 ) x(*) !x(n) Vector to be multiplied by A
    real ( kind = 8 ) w(*) !w(n) Value of A*x

    integer ( kind = 4 ) i
    integer ( kind = 4 ) k1
    integer ( kind = 4 ) k2

    w(1:n) = 0.0D+00

    do i = 1, n
       k1 = ia(i)
       k2 = ia(i+1) - 1
       w(i) = w(i) + dot_product ( a(k1:k2), x(ja(k1:k2)) )
    end do

    return
  end subroutine ax_cr
!
!##############################################################################
!
! *ILU_CR:* computes the incomplete LU factorization of a matrix. For a matrix
! stored in compressed row format.
    !    Input, integer ( kind = 4 ) UA(N), the index of the diagonal element
    !    of each row.
    !    Output, real ( kind = 8 ) L(NZ_NUM), the ILU factorization of A.
  subroutine ilu_cr ( n, nz_num, ia, ja, a, ua, l )
    integer ( kind = 4 ) n
    integer ( kind = 4 ) nz_num
    integer ( kind = 4 ) ia(*) !ia(n+1)
    integer ( kind = 4 ) ja(*) !ja(nz_num)
    real ( kind = 8 ) a(*) !a(nz_num)
    integer ( kind = 4 ) ua(*) !ua(n)
    real ( kind = 8 ) l(*) !l(nz_num)

    integer ( kind = 4 ) i
    integer ( kind = 4 ) iw(n)
    integer ( kind = 4 ) j
    integer ( kind = 4 ) jj
    integer ( kind = 4 ) jrow
    integer ( kind = 4 ) jw
    integer ( kind = 4 ) k
    real ( kind = 8 ) tl

    !  Copy A.
    l(1:nz_num) = a(1:nz_num)

    do i = 1, n ! for each row, up to max number of rows
       !  IW points to the nonzero entries in row I.
       iw(1:n) = -1
       do k = ia(i), ia(i+1) - 1 !for each
          iw(ja(k)) = k
       end do
       do j = ia(i), ia(i+1) - 1
          jrow = ja(j)
          if ( i <= jrow ) then
             exit
          end if
          tl = l(j) * l(ua(jrow))
          l(j) = tl
          do jj = ua(jrow) + 1, ia(jrow+1) - 1
             jw = iw(ja(jj))
             if ( jw /= -1 ) then
                l(jw) = l(jw) - tl * l(jj)
             end if
          end do
       end do
       ua(i) = j
       if ( jrow /= i ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'ILU_CR - Fatal error!'
          write ( *, '(a)' ) '  JROW ~= I'
          write ( *, '(a,i8)' ) '  JROW = ', jrow
          write ( *, '(a,i8)' ) '  I    = ', i
          stop
       end if
       if ( l(j) == 0.0D+00 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'ILU_CR - Fatal error!'
          write ( *, '(a,i8)' ) '  Zero pivot on step I = ', i
          write ( *, '(a,i8,a)' ) '  L(', j, ') = 0.0'
          stop
       end if
       l(j) = 1.0D+00 / l(j)
    end do

    l(ua(1:n)) = 1.0D+00 / l(ua(1:n))

    return
  end subroutine ilu_cr
!
!##############################################################################
!
!*DIAGONAL_POINTER_CR:* finds diagonal entries in a sparse compressed row matrix.
    !    The array UA can be used to locate the diagonal elements of the matrix.
    !    It is assumed that every row of the matrix includes a diagonal element,
    !    and that the elements of each row have been ascending sorted.
subroutine diagonal_pointer_cr ( n, ia, ja, ua )
    integer ( kind = 4 ) n
    integer ( kind = 4 ) ia(*) !ia(n+1)
    integer ( kind = 4 ) ja(*) !ja(nz_num)
    integer ( kind = 4 ) ua(*) !ua(n)

    integer ( kind = 4 ) i
    integer ( kind = 4 ) k

    ua(1:n) = -1

    do i = 1, n
       do k = ia(i), ia(i+1) - 1
          if ( ja(k) == i ) then
             ua(i) = k
          end if
       end do
    end do
    return
  end subroutine diagonal_pointer_cr

  !*****************************************************************************80

  subroutine lus_cr ( n, ia, ja, l, ua, r, z )
!!! LUS_CR applies the incomplete LU preconditioner.
    !    The linear system M * Z = R is solved for Z.  M is the incomplete
    !    LU preconditioner matrix, and R is a vector supplied by the user.
    !    So essentially, we're solving L * U * Z = R.
    !    Input, integer ( kind = 4 ) UA(N), the index of the diagonal element
    !    of each row.
    !    Input, real ( kind = 8 ) R(N), the right hand side.
    !    Output, real ( kind = 8 ) Z(N), the solution of the system M * Z = R.
    implicit none

    integer ( kind = 4 ) n
    integer ( kind = 4 ) ia(*) !ia(n+1)
    integer ( kind = 4 ) ja(*) !ja(nz_num)
    real ( kind = 8 ) l(*) !l(nz_num)
    integer ( kind = 4 ) ua(*) !ua(n)
    real ( kind = 8 ) r(*) !r(n)

    integer ( kind = 4 ) i
    integer ( kind = 4 ) j
    real ( kind = 8 ) w(n)
    real ( kind = 8 ) z(n)

    !  Copy R in.
    w(1:n) = r(1:n)

    !  Solve L * w = w where L is unit lower triangular.
    do i = 2, n
       do j = ia(i), ua(i) - 1
          w(i) = w(i) - l(j) * w(ja(j))
       end do
    end do

    !  Solve U * w = w, where U is upper triangular.
    do i = n, 1, -1
       do j = ua(i) + 1, ia(i+1) - 1
          w(i) = w(i) - l(j) * w(ja(j))
       end do
       w(i) = w(i) / l(ua(i))
    end do

    !  Copy Z out.
    z(1:n) = w(1:n)

    return
  end subroutine lus_cr

  !*****************************************************************************80
  subroutine mult_givens ( c, s, k, g )
!!! MULT_GIVENS applies a Givens rotation to two successive entries of a vector.
    !    In order to make it easier to compare this code with the Original C,
    !    the vector indexing is 0-based.
    !    Input, real ( kind = 8 ) C, S, the cosine and sine of a Givens
    !    rotation.
    !
    !    Input, integer ( kind = 4 ) K, indicates the location of the first
    !    vector entry.
    !
    !    Input/output, real ( kind = 8 ) G(1:K+1), the vector to be modified.
    !    On output, the Givens rotation has been applied to entries G(K) and G(K+1).

    implicit none

    real ( kind = 8 ) c
    real ( kind = 8 ) s
    integer ( kind = 4 ) k
    real ( kind = 8 ) g(*) !g(1:k+1)

    real ( kind = 8 ) g1
    real ( kind = 8 ) g2

    g1 = c * g(k) - s * g(k+1)
    g2 = s * g(k) + c * g(k+1)

    g(k)   = g1
    g(k+1) = g2

    return
  end subroutine mult_givens

  !*****************************************************************************80
  subroutine rearrange_cr ( n, ia, ja, a )
!!! REARRANGE_CR sorts a sparse compressed row matrix.
    !    This routine guarantees that the entries in the CR matrix
    !    are properly sorted.
    !
    !    After the sorting, the entries of the matrix are rearranged in such
    !    a way that the entries of each column are listed in ascending order
    !    of their column values.
    !    Input, integer ( kind = 4 ) N, the order of the system.
    !
    !    Input, integer ( kind = 4 ) NZ_NUM, the number of nonzeros.
    !
    !    Input, integer ( kind = 4 ) IA(N+1), the compressed row indices.
    !
    !    Input/output, integer ( kind = 4 ) JA(NZ_NUM), the column indices.
    !    On output, these may have been rearranged by the sorting.
    !
    !    Input/output, real ( kind = 8 ) A(NZ_NUM), the matrix values.  On output,
    !    the matrix values may have been moved somewhat because of the sorting.
    !
    implicit none

    integer ( kind = 4 ) n
    integer ( kind = 4 ) ia(*) !ia(n+1)
    integer ( kind = 4 ) ja(*) !ja(nz_num)
    real ( kind = 8 ) a(*) !a(nz_num)

    integer ( kind = 4 ) i
    integer ( kind = 4 ) i4temp
    integer ( kind = 4 ) k
    integer ( kind = 4 ) l
    real ( kind = 8 ) r8temp

    do i = 1, n

       do k = ia(i), ia(i+1) - 2
          do l = k + 1, ia(i+1) - 1

             if ( ja(l) < ja(k) ) then
                i4temp = ja(l)
                ja(l)  = ja(k)
                ja(k)  = i4temp

                r8temp = a(l)
                a(l)   = a(k)
                a(k)   = r8temp
             end if

          end do
       end do

    end do

    return
  end subroutine rearrange_cr

!######################################################################

  !
  !*sort_integer_list:* sorts a list of integer values into a non-decreasing order.
  ! sorts N integer IDATA values into a non-decreasing sequence using IHEAPSORT
  ! (N>50) or ISHELLSORT (N>50) and then  removes all duplicates from the list. On
  ! exit N contains the number of unique elements in the list.
  !
  subroutine sort_integer_list(N,IDATA)
    !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_SORT_INTEGER_LIST" :: SORT_INTEGER_LIST
    integer :: IDATA(:),N

    !Local Variables
    integer :: count1,index,itemp,nolist
    logical :: continue

    character(len=60) :: sub_name

    sub_name = 'sort_integer_list'
    call enter_exit(sub_name,1)

    !order the array non-decreasing
    do nolist=2,N
       count1=0
       continue=.true.
       do while(continue)
          if(IDATA(nolist-count1).lt.IDATA(nolist-count1-1))then
             itemp=IDATA(nolist-1)
             IDATA(nolist-1)=IDATA(nolist)
             IDATA(nolist)=itemp
             count1=count1+1
             if(nolist-count1-1.eq.0) continue=.false.
          else
             continue=.false.
          endif
       enddo !while
    enddo !N

    !eliminate duplicate entries
    index=0
    do nolist=2,N
       if(IDATA(nolist).eq.IDATA(nolist-1)) then
          index=index+1
       else
          IDATA(nolist-index)=IDATA(nolist)
       endif
    enddo !nolist

    N=N-index

    call enter_exit(sub_name,2)

  end subroutine sort_integer_list

!!!#########################################################################
  !*sort_real_list:* sorts a list of real values into a non-decreasing order
  ! using a bubble sort algorithm.

  subroutine sort_real_list(n,RDATA,INDEX)
    !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_SORT_REAL_LIST" :: SORT_REAL_LIST

    integer :: INDEX(*),n
    real(dp) :: RDATA(*)

    !Local Variables
    integer :: FLAG,i,ITEMP,j,k
    real(dp) :: TEMP

    character(len=60) :: sub_name

    sub_name = 'sort_real_list'
    call enter_exit(sub_name,1)

    if(N.LE.1) then
    else
       FLAG=n
       do i=1,n
          k=FLAG-1
          FLAG=0
          do j=1,k
             if(RDATA(j).gt.RDATA(j+1)) then
                TEMP=RDATA(j)
                RDATA(j)=RDATA(j+1)
                RDATA(j+1)=TEMP
                ITEMP=INDEX(j)
                INDEX(j)=INDEX(j+1)
                INDEX(j+1)=ITEMP
                FLAG=j
             endif
          enddo
          if(FLAG.eq.0) then
             write(*,*) 'warning in rsort'
          endif
       enddo
    endif

    call enter_exit(sub_name,2)

  end subroutine sort_real_list

end module math_utilities


	SUBROUTINE GDTXEV ( rlvlsi, nlvlsi, icord, rlvlso, nlvlso,
     +			    iret )
C************************************************************************
C* GDTXEV								*
C*									*
C* This subroutine gets evenly spaced levels for interpolation		*
C*									*
C* GDTXEV ( RLVLSI, NLVLSI, ICORD, RLVLSO, NLVLSO, IRET )		*
C*									*
C* Input parameters:							*
C*	RLVLSI (NLVLSI)	REAL		input levels			*
C*	NLVLSI		INTEGER		# of input levels		*
C*	ICORD		INTEGER		coordinate type:		*
C*					  1 = linear			*
C*					  2 = log			*
C*					  3 = **RKAPPA			*
C*									*
C* Output parameters:							*
C*	RLVLSO (NLVLSO)	REAL		output levels			*
C*	NLVLSO		INTEGER		# of output levels		*
C*	IRET		INTEGER		return code			*
C*					  0 = normal return		*
C*					 -4 = invalid vert coord	*
C**									*
C* Log:									*
C* K. F. Brill/GSC       7/89  						*
C* K. Brill/GSC          8/89           Interpolate to exact levels	*
C* K. Brill/GSC          1/90           Set lower/upper lvls for int	*
C* K. Brill/NMC		 1/91		Check for equality between 	*
C*        				input and output levels		*
C* T.W.Barker		 9/91		Created from gdtxgd		*
C* K. Brill/NMC		11/92		Fix calls to ER_WMSG		*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
        REAL 		rlvlsi(*),rlvlso(*)
C------------------------------------------------------------------------
	iret = 0
C*
C*
	rkinv = 1. / RKAPPA
C
C*	  Compute the vertical increment for the output grid using the
C*        minimum vertical differential distance in the transformed
C*        coordinate.
C
	difmin = 1.e32
	DO k = 1, nlvlsi
	    IF ( icord .eq. 1 ) THEN
		qk = rlvlsi ( k )
	    ELSE IF ( icord .eq. 2 ) THEN
		IF ( rlvlsi ( k ) .gt. 0.0 ) THEN
		    qk = ALOG ( rlvlsi ( k ) )
		ELSE
		    iret = -7
		    CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		    RETURN
		END IF
	    ELSE IF ( icord .eq. 3 ) THEN
		IF ( rlvlsi ( k ) .gt. 0.0 ) THEN
		    qk = rlvlsi ( k ) ** RKAPPA
		ELSE
		    iret = -7
		    CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		    RETURN
		END IF
	    ELSE
		iret = -7
		CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		RETURN
	    END IF
	    IF ( k .gt. 1 ) THEN
		dif = ABS ( qk - qkm1 )
		IF ( dif .lt. difmin ) difmin = dif
	    END IF
	    qkm1 = qk
	END DO
C
C*      Compute the bounds in output coordinate system.
C
	ybot = rlvlsi(1)
	ytop = rlvlsi(nlvlsi)
        IF ( icord .eq. 1 ) THEN
	    q1 = ybot
	    q2 = ytop
        ELSE IF ( icord .eq. 2 ) THEN
	    IF ( ybot .gt. 0.0 .and. ytop .gt. 0.0 ) THEN
		q1 = ALOG ( ybot )
		q2 = ALOG ( ytop )
	    ELSE
		iret = -7
		CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		RETURN
	    END IF
	ELSE IF ( icord .eq. 3 ) THEN
	    IF ( ybot .gt. 0.0 .and. ytop .gt. 0.0 ) THEN
		q1 = ybot ** RKAPPA
		q2 = ytop ** RKAPPA
	    ELSE
		iret = -7
		CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		RETURN
	    END IF
        ELSE
	    iret = -7
	    CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
	    RETURN
	END IF

C*      Determine the number of levels to which to interpolate.
C
	rnolv = ABS ( q1 - q2 ) / difmin
	nvout = INT ( rnolv + .5 ) + 1
	IF ( nvout .gt. LLMXLV ) nvout = LLMXLV
C*
 	nvm1 = nvout - 1
	dz = ( q2 - q1 ) / FLOAT ( nvm1 )
C
C*	  Create array of output levels.
C
	z = q1
	DO k = 2, nvm1
	   z = z + dz
	   IF ( icord .eq. 1 ) rlvlso ( k ) = z
           IF ( icord .eq. 2 ) rlvlso ( k ) = EXP ( z )
           IF ( icord .eq. 3 ) rlvlso ( k ) = z ** rkinv
	END DO
C
C*	Set lower and upper most levels for the interpolation.
C
	rlvlso ( 1 ) = rlvlsi ( 1 )
	rlvlso ( nvout ) = rlvlsi ( nlvlsi )
	nlvlso = nvout
C
C*
	RETURN
	END


!*==ctrevc3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CTREVC3
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CTREVC3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
!                           LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
!
!       .. Scalar Arguments ..
!       CHARACTER          HOWMNY, SIDE
!       INTEGER            INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
!       ..
!       .. Array Arguments ..
!       LOGICAL            SELECT( * )
!       REAL               RWORK( * )
!       COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CTREVC3 computes some or all of the right and/or left eigenvectors of
!> a complex upper triangular matrix T.
!> Matrices of this type are produced by the Schur factorization of
!> a complex general matrix:  A = Q*T*Q**H, as computed by CHSEQR.
!>
!> The right eigenvector x and the left eigenvector y of T corresponding
!> to an eigenvalue w are defined by:
!>
!>              T*x = w*x,     (y**H)*T = w*(y**H)
!>
!> where y**H denotes the conjugate transpose of the vector y.
!> The eigenvalues are not input to this routine, but are read directly
!> from the diagonal of T.
!>
!> This routine returns the matrices X and/or Y of right and left
!> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!> input matrix. If Q is the unitary factor that reduces a matrix A to
!> Schur form T, then Q*X and Q*Y are the matrices of right and left
!> eigenvectors of A.
!>
!> This uses a Level 3 BLAS version of the back transformation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] SIDE
!> \verbatim
!>          SIDE is CHARACTER*1
!>          = 'R':  compute right eigenvectors only;
!>          = 'L':  compute left eigenvectors only;
!>          = 'B':  compute both right and left eigenvectors.
!> \endverbatim
!>
!> \param[in] HOWMNY
!> \verbatim
!>          HOWMNY is CHARACTER*1
!>          = 'A':  compute all right and/or left eigenvectors;
!>          = 'B':  compute all right and/or left eigenvectors,
!>                  backtransformed using the matrices supplied in
!>                  VR and/or VL;
!>          = 'S':  compute selected right and/or left eigenvectors,
!>                  as indicated by the logical array SELECT.
!> \endverbatim
!>
!> \param[in] SELECT
!> \verbatim
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!>          computed.
!>          The eigenvector corresponding to the j-th eigenvalue is
!>          computed if SELECT(j) = .TRUE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!> \endverbatim
!>
!> \param[in,out] T
!> \verbatim
!>          T is COMPLEX array, dimension (LDT,N)
!>          The upper triangular matrix T.  T is modified, but restored
!>          on exit.
!> \endverbatim
!>
!> \param[in] LDT
!> \verbatim
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] VL
!> \verbatim
!>          VL is COMPLEX array, dimension (LDVL,MM)
!>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by CHSEQR).
!>          On exit, if SIDE = 'L' or 'B', VL contains:
!>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*Y;
!>          if HOWMNY = 'S', the left eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VL, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'R'.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.
!>          LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N.
!> \endverbatim
!>
!> \param[in,out] VR
!> \verbatim
!>          VR is COMPLEX array, dimension (LDVR,MM)
!>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by CHSEQR).
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*X;
!>          if HOWMNY = 'S', the right eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VR, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'L'.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.
!>          LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N.
!> \endverbatim
!>
!> \param[in] MM
!> \verbatim
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!> \endverbatim
!>
!> \param[out] M
!> \verbatim
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR actually
!>          used to store the eigenvectors.
!>          If HOWMNY = 'A' or 'B', M is set to N.
!>          Each selected eigenvector occupies one column.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of array WORK. LWORK >= max(1,2*N).
!>          For optimum performance, LWORK >= N + 2*N*NB, where NB is
!>          the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (LRWORK)
!> \endverbatim
!>
!> \param[in] LRWORK
!> \verbatim
!>          LRWORK is INTEGER
!>          The dimension of array RWORK. LRWORK >= max(1,N).
!>
!>          If LRWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the RWORK array, returns
!>          this value as the first entry of the RWORK array, and no error
!>          message related to LRWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!  @generated from ztrevc3.f, fortran z -> c, Tue Apr 19 01:47:44 2016
!
!> \ingroup complexOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The algorithm used in this program is basically backward (forward)
!>  substitution, with scaling to make the the code robust against
!>  possible overflow.
!>
!>  Each eigenvector is normalized so that the element of largest
!>  magnitude has magnitude 1; here the magnitude of a complex number
!>  (x,y) is taken to be |x| + |y|.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CTREVC3(Side,Howmny,Select,N,T,Ldt,Vl,Ldvl,Vr,Ldvr,Mm, &
     &                   M,Work,Lwork,Rwork,Lrwork,Info)
      IMPLICIT NONE
!*--CTREVC3250
!
!  -- LAPACK computational routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      CHARACTER Howmny , Side
      INTEGER Info , Ldt , Ldvl , Ldvr , Lwork , Lrwork , M , Mm , N
!     ..
!     .. Array Arguments ..
      LOGICAL Select(*)
      REAL Rwork(*)
      COMPLEX T(Ldt,*) , Vl(Ldvl,*) , Vr(Ldvr,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
      COMPLEX CZERO , CONE
      PARAMETER (CZERO=(0.0E+0,0.0E+0),CONE=(1.0E+0,0.0E+0))
      INTEGER NBMIN , NBMAX
      PARAMETER (NBMIN=8,NBMAX=128)
!     ..
!     .. Local Scalars ..
      LOGICAL allv , bothv , leftv , lquery , over , rightv , somev
      INTEGER i , ii , is , j , k , ki , iv , maxwrk , nb
      REAL ovfl , remax , scale , smin , smlnum , ulp , unfl
      COMPLEX cdum
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV , ICAMAX
      REAL SLAMCH , SCASUM
      EXTERNAL LSAME , ILAENV , ICAMAX , SLAMCH , SCASUM
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , CCOPY , CLASET , CSSCAL , CGEMM , CGEMV ,       &
     &         CLATRS , CLACPY , SLABAD
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , REAL , CMPLX , CONJG , AIMAG , MAX
!     ..
!     .. Statement Functions ..
      REAL CABS1
!     ..
!     .. Statement Function definitions ..
      CABS1(cdum) = ABS(REAL(cdum)) + ABS(AIMAG(cdum))
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      bothv = LSAME(Side,'B')
      rightv = LSAME(Side,'R') .OR. bothv
      leftv = LSAME(Side,'L') .OR. bothv
!
      allv = LSAME(Howmny,'A')
      over = LSAME(Howmny,'B')
      somev = LSAME(Howmny,'S')
!
!     Set M to the number of columns required to store the selected
!     eigenvectors.
!
      IF ( somev ) THEN
         M = 0
         DO j = 1 , N
            IF ( Select(j) ) M = M + 1
         ENDDO
      ELSE
         M = N
      ENDIF
!
      Info = 0
      nb = ILAENV(1,'CTREVC',Side//Howmny,N,-1,-1,-1)
      maxwrk = N + 2*N*nb
      Work(1) = maxwrk
      Rwork(1) = N
      lquery = (Lwork==-1 .OR. Lrwork==-1)
      IF ( .NOT.rightv .AND. .NOT.leftv ) THEN
         Info = -1
      ELSEIF ( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( Ldt<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldvl<1 .OR. (leftv .AND. Ldvl<N) ) THEN
         Info = -8
      ELSEIF ( Ldvr<1 .OR. (rightv .AND. Ldvr<N) ) THEN
         Info = -10
      ELSEIF ( Mm<M ) THEN
         Info = -11
      ELSEIF ( Lwork<MAX(1,2*N) .AND. .NOT.lquery ) THEN
         Info = -14
      ELSEIF ( Lrwork<MAX(1,N) .AND. .NOT.lquery ) THEN
         Info = -16
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CTREVC3',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF ( N==0 ) RETURN
!
!     Use blocked version of back-transformation if sufficient workspace.
!     Zero-out the workspace to avoid potential NaN propagation.
!
      IF ( over .AND. Lwork>=N+2*N*NBMIN ) THEN
         nb = (Lwork-N)/(2*N)
         nb = MIN(nb,NBMAX)
         CALL CLASET('F',N,1+2*nb,CZERO,CZERO,Work,N)
      ELSE
         nb = 1
      ENDIF
!
!     Set the constants to control overflow.
!
      unfl = SLAMCH('Safe minimum')
      ovfl = ONE/unfl
      CALL SLABAD(unfl,ovfl)
      ulp = SLAMCH('Precision')
      smlnum = unfl*(N/ulp)
!
!     Store the diagonal elements of T in working array WORK.
!
      DO i = 1 , N
         Work(i) = T(i,i)
      ENDDO
!
!     Compute 1-norm of each column of strictly upper triangular
!     part of T to control overflow in triangular solver.
!
      Rwork(1) = ZERO
      DO j = 2 , N
         Rwork(j) = SCASUM(j-1,T(1,j),1)
      ENDDO
!
      IF ( rightv ) THEN
!
!        ============================================================
!        Compute right eigenvectors.
!
!        IV is index of column in current block.
!        Non-blocked version always uses IV=NB=1;
!        blocked     version starts with IV=NB, goes down to 1.
!        (Note the "0-th" column is used to store the original diagonal.)
         iv = nb
         is = M
         DO ki = N , 1 , -1
            IF ( somev ) THEN
               IF ( .NOT.Select(ki) ) CYCLE
            ENDIF
            smin = MAX(ulp*(CABS1(T(ki,ki))),smlnum)
!
!           --------------------------------------------------------
!           Complex right eigenvector
!
            Work(ki+iv*N) = CONE
!
!           Form right-hand side.
!
            DO k = 1 , ki - 1
               Work(k+iv*N) = -T(k,ki)
            ENDDO
!
!           Solve upper triangular system:
!           [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK.
!
            DO k = 1 , ki - 1
               T(k,k) = T(k,k) - T(ki,ki)
               IF ( CABS1(T(k,k))<smin ) T(k,k) = smin
            ENDDO
!
            IF ( ki>1 ) THEN
               CALL CLATRS('Upper','No transpose','Non-unit','Y',ki-1,T,&
     &                     Ldt,Work(1+iv*N),scale,Rwork,Info)
               Work(ki+iv*N) = scale
            ENDIF
!
!           Copy the vector x or Q*x to VR and normalize.
!
            IF ( .NOT.over ) THEN
!              ------------------------------
!              no back-transform: copy x to VR and normalize.
               CALL CCOPY(ki,Work(1+iv*N),1,Vr(1,is),1)
!
               ii = ICAMAX(ki,Vr(1,is),1)
               remax = ONE/CABS1(Vr(ii,is))
               CALL CSSCAL(ki,remax,Vr(1,is),1)
!
               DO k = ki + 1 , N
                  Vr(k,is) = CZERO
               ENDDO
!
            ELSEIF ( nb==1 ) THEN
!              ------------------------------
!              version 1: back-transform each vector with GEMV, Q*x.
               IF ( ki>1 ) CALL CGEMV('N',N,ki-1,CONE,Vr,Ldvr,          &
     &                                Work(1+iv*N),1,CMPLX(scale),      &
     &                                Vr(1,ki),1)
!
               ii = ICAMAX(N,Vr(1,ki),1)
               remax = ONE/CABS1(Vr(ii,ki))
               CALL CSSCAL(N,remax,Vr(1,ki),1)
!
            ELSE
!              ------------------------------
!              version 2: back-transform block of vectors with GEMM
!              zero out below vector
               DO k = ki + 1 , N
                  Work(k+iv*N) = CZERO
               ENDDO
!
!              Columns IV:NB of work are valid vectors.
!              When the number of vectors stored reaches NB,
!              or if this was last vector, do the GEMM
               IF ( (iv==1) .OR. (ki==1) ) THEN
                  CALL CGEMM('N','N',N,nb-iv+1,ki+nb-iv,CONE,Vr,Ldvr,   &
     &                       Work(1+(iv)*N),N,CZERO,Work(1+(nb+iv)*N),N)
!                 normalize vectors
                  DO k = iv , nb
                     ii = ICAMAX(N,Work(1+(nb+k)*N),1)
                     remax = ONE/CABS1(Work(ii+(nb+k)*N))
                     CALL CSSCAL(N,remax,Work(1+(nb+k)*N),1)
                  ENDDO
                  CALL CLACPY('F',N,nb-iv+1,Work(1+(nb+iv)*N),N,Vr(1,ki)&
     &                        ,Ldvr)
                  iv = nb
               ELSE
                  iv = iv - 1
               ENDIF
            ENDIF
!
!           Restore the original diagonal elements of T.
!
            DO k = 1 , ki - 1
               T(k,k) = Work(k)
            ENDDO
!
            is = is - 1
         ENDDO
      ENDIF
!
      IF ( leftv ) THEN
!
!        ============================================================
!        Compute left eigenvectors.
!
!        IV is index of column in current block.
!        Non-blocked version always uses IV=1;
!        blocked     version starts with IV=1, goes up to NB.
!        (Note the "0-th" column is used to store the original diagonal.)
         iv = 1
         is = 1
         DO ki = 1 , N
!
            IF ( somev ) THEN
               IF ( .NOT.Select(ki) ) CYCLE
            ENDIF
            smin = MAX(ulp*(CABS1(T(ki,ki))),smlnum)
!
!           --------------------------------------------------------
!           Complex left eigenvector
!
            Work(ki+iv*N) = CONE
!
!           Form right-hand side.
!
            DO k = ki + 1 , N
               Work(k+iv*N) = -CONJG(T(ki,k))
            ENDDO
!
!           Solve conjugate-transposed triangular system:
!           [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK.
!
            DO k = ki + 1 , N
               T(k,k) = T(k,k) - T(ki,ki)
               IF ( CABS1(T(k,k))<smin ) T(k,k) = smin
            ENDDO
!
            IF ( ki<N ) THEN
               CALL CLATRS('Upper','Conjugate transpose','Non-unit','Y',&
     &                     N-ki,T(ki+1,ki+1),Ldt,Work(ki+1+iv*N),scale, &
     &                     Rwork,Info)
               Work(ki+iv*N) = scale
            ENDIF
!
!           Copy the vector x or Q*x to VL and normalize.
!
            IF ( .NOT.over ) THEN
!              ------------------------------
!              no back-transform: copy x to VL and normalize.
               CALL CCOPY(N-ki+1,Work(ki+iv*N),1,Vl(ki,is),1)
!
               ii = ICAMAX(N-ki+1,Vl(ki,is),1) + ki - 1
               remax = ONE/CABS1(Vl(ii,is))
               CALL CSSCAL(N-ki+1,remax,Vl(ki,is),1)
!
               DO k = 1 , ki - 1
                  Vl(k,is) = CZERO
               ENDDO
!
            ELSEIF ( nb==1 ) THEN
!              ------------------------------
!              version 1: back-transform each vector with GEMV, Q*x.
               IF ( ki<N ) CALL CGEMV('N',N,N-ki,CONE,Vl(1,ki+1),Ldvl,  &
     &                                Work(ki+1+iv*N),1,CMPLX(scale),   &
     &                                Vl(1,ki),1)
!
               ii = ICAMAX(N,Vl(1,ki),1)
               remax = ONE/CABS1(Vl(ii,ki))
               CALL CSSCAL(N,remax,Vl(1,ki),1)
!
            ELSE
!              ------------------------------
!              version 2: back-transform block of vectors with GEMM
!              zero out above vector
!              could go from KI-NV+1 to KI-1
               DO k = 1 , ki - 1
                  Work(k+iv*N) = CZERO
               ENDDO
!
!              Columns 1:IV of work are valid vectors.
!              When the number of vectors stored reaches NB,
!              or if this was last vector, do the GEMM
               IF ( (iv==nb) .OR. (ki==N) ) THEN
                  CALL CGEMM('N','N',N,iv,N-ki+iv,CONE,Vl(1,ki-iv+1),   &
     &                       Ldvl,Work(ki-iv+1+(1)*N),N,CZERO,          &
     &                       Work(1+(nb+1)*N),N)
!                 normalize vectors
                  DO k = 1 , iv
                     ii = ICAMAX(N,Work(1+(nb+k)*N),1)
                     remax = ONE/CABS1(Work(ii+(nb+k)*N))
                     CALL CSSCAL(N,remax,Work(1+(nb+k)*N),1)
                  ENDDO
                  CALL CLACPY('F',N,iv,Work(1+(nb+1)*N),N,Vl(1,ki-iv+1),&
     &                        Ldvl)
                  iv = 1
               ELSE
                  iv = iv + 1
               ENDIF
            ENDIF
!
!           Restore the original diagonal elements of T.
!
            DO k = ki + 1 , N
               T(k,k) = Work(k)
            ENDDO
!
            is = is + 1
         ENDDO
      ENDIF
!
!
!     End of CTREVC3
!
      END SUBROUTINE CTREVC3


      program DRDEI
c>> 1996-05-28 DRDEI    Krogh Added external statement.
c>> 1994-10-19 DRDEI    Krogh  Changes to use M77CON
c>> 1992-03-16 DRDEI    CLL
c>> 1990-11-29 CLL
c>> 1987-12-09 DRDEI    Lawson  Initial Code.
c     ------------------------------------------------------------------
c--D replaces "?": DR?EI, ?EI, ?E1
c     ------------------------------------------------------------------
      integer J
      external DEI, DE1
      double precision X(14), Y, Z, DEI, DE1
c     ------------------------------------------------------------------
      data X / -80.D0, -20.D0, -5.D0, -1.D0, -.4D0, -.3D0, -.001D0,
     *         .001D0, .3D0, .4D0, 1.D0, 5.D0, 20.D0, 80.D0 /
c
      print '(1x,3X,A1,13X,A6,14X,A6/)','X','DEI(X)','DE1(X)'
c
      do 10 J = 1, 14
        Y = DEI(X(J))
        Z = DE1(X(J))
        print '(1x,F7.3,5X,2(G15.8,5X))',X(J),Y,Z
   10 continue
      end


subroutine dmatvecprod(prod, arg1, arg2, size)
    implicit none
    integer size, i
    real(kind=8) prod(size), arg1(size), arg2(size)

    do i = 1, size
        prod(i) = arg1(i) * arg2(i)
    end do
    return
end
subroutine dotprod(arg1, arg2, size, dot)
    implicit none
    integer size, i
    real(kind=8) dot, arg1(size), arg2(size), ddot
    !      dot=ddot(size,arg1,1,arg2,1)
    dot = 0.d0
    do i = 1, size
        dot = dot + arg1(i) * arg2(i)
    end do
    return
end
subroutine cdotprod(arg1, arg2, size, dot)
    implicit none
    integer size, i
    complex(kind=8) dot, arg1(size), arg2(size), zdotu
    !      dot=zdotu(size,arg1,1,arg2,1)
    dot = (0.d0, 0.d0)
    do i = 1, size
        dot = dot + dconjg(arg1(i)) * arg2(i)
    end do
    return
end


*----------------------------------------------------------------------*
!>  takes a sorts the lists of values in increasing value order
!!
!!  xlist is actually nopt lists of elements of the me_lists. Each sorted in ascending order.
!!  idxlist contains the corresponding indices of the elements on the lists.
!!
!!  this subroutine merges the lists into xlist_all and idxlist_all where xlist_all is the values in ascending order
!!  idxlist_all are the indices of the elements where every element is indexed by a pair ( index of list (iopt),index on list )
!!   if choice is unequal zero only values of the respective operator are considered.
*----------------------------------------------------------------------*
      subroutine merge_min_lists(xlist_all,idxlist_all,ntrials_all,
     &     xlist,idxlist,nopt,maxtrials,ntrials,choice)

      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     nopt, maxtrials, ntrials(nopt), idxlist(maxtrials,nopt),
     &     choice
      real(8), intent(in) ::
     &     xlist(maxtrials,nopt)

      integer, intent(out) ::
     &     idxlist_all(2,maxtrials), ntrials_all
      real(8), intent(out) ::
     &     xlist_all(maxtrials)

      integer ::
     &     itry, idx(nopt), iopt, jopt
      real(8) ::
     &     xlow

      if (choice.eq.0) then

        idx(1:nopt) = 0

        ntrials_all = min(maxtrials,sum(ntrials(1:nopt)))

        do itry = 1, ntrials_all

          ! look for next-lowest element in all lists
          xlow = huge(xlow)
          jopt = -1
          do iopt = 1, nopt
            if (idx(iopt).lt.ntrials(iopt)) then
              if (xlist(idx(iopt)+1,iopt).lt.xlow) then
                xlow = xlist(idx(iopt)+1,iopt)
                jopt = iopt
              end if
            end if
          end do

          if (jopt.le.0)
     &         call quit(1,'merge_min_lists','something''s wrong !')

          ! increment this index
          idx(jopt) = idx(jopt)+1

          ! store information on new list
          xlist_all(itry) = xlist(idx(jopt),jopt)
          idxlist_all(1:2,itry) = (/jopt,idxlist(idx(jopt),jopt)/)

        end do
       elseif (choice.le.nopt) then
         ntrials_all = min(maxtrials,ntrials(choice))

         do itry = 1, ntrials_all

           xlist_all(itry) = xlist(itry,choice)
           idxlist_all(1:2,itry) = (/choice,idxlist(itry,choice)/)

         enddo
       else
         call quit(1,'merge_min_lists','wrong choice')
       endif

      if (ntest.ge.100) then
        write(lulog,*) 'new array:'
        do itry = 1, ntrials_all
          write(lulog,'(1x,f14.8,2x,i3,i10)')
     &         xlist_all(itry), idxlist_all(1:2,itry)
        end do
        write(lulog,*) 'end of array'

      end if

      end