      program plotforce

      real rplot(0:200),zplot(0:200),vc(0:200),
     :     vd(0:200),vh(0:200),vb(0:200),fz(0:200)
      character*60 toplbl,filename
      integer*4 ibuf1(15)
      character ans

      open(20,file='scales',status='old',err=5)
      read(20,*) rscale
      write(*,*) 'Will normalize model so that vcirc(rsun)=200.'
      write(*,*) 'and will write this to "scales"'
      close(20)
      goto 6

 5    write(*,*) 'No files "scales" found.'
      write(*,*) 'Will use default length scale [4kpc] instead.'
      write(*,*) 'Will normalize forces so that vcirc(8kpc)=200.'
      rscale=4.

 6    continue

      write(*,*) 'Will plot rotation curve and Kz.'
      write(*,*) 'For rotation curve: radius bin [kpc], no. bins?'
      read(*,*) drplot,nrplot
      write(*,*) 'For Kz:  z-bin [kpc], no. bins?'
      read(*,*) dzplot,nzplot

c inititially store the radial forces in the velocity arrays

      filename='h.dat'
      call readharmfile(filename,ibuf1)

      write(*,*) 'Calculating halo rotation curve...'
      do ir=0,nrplot
         rp=ir*drplot/rscale
         rplot(ir)=rp*rscale
         call force(rp,0.,vh(ir),fz(0),p)
!	 print*,rp,vh(ir),fz(0),p
      enddo

      filename='b.dat'
      call readharmfile(filename,ibuf1)
      write(*,*) 'Calculating bulge rotation curve...'
      do ir=0,nrplot
         rp=rplot(ir)/rscale
         call force(rp,0.,vb(ir),fz,p)
      enddo

      filename='dbh.dat'
      call readharmfile(filename,ibuf1)
c      call readdiskdf(filename,ibuf1)
c (this also reads in the dbh.dat file)
      write(*,*) 'Calculating total rotation curve...'
      do ir=0,nrplot
         rp=rplot(ir)/rscale
         call force(rp,0.,vc(ir),fz,p)
      enddo

      rsun=8.
      call force(rsun/rscale,0.,fr,fz,p)
      vcsun=sqrt(max(0.,-rsun/rscale*fr))
      vscale=200./vcsun
      emscale=rscale*vscale**2/4.3e-6

      write(*,*) 'Scales for mass, distance, speed:'
      write(*,*) emscale,' Msun, ',rscale,' kpc, ',vscale,' km/s.'
      densscale=emscale/rscale**3
      dfscale=densscale/vscale**3
      open(16,file='scales',status='unknown')
      write(16,*) rscale,'    radius scale [kpc]'
      write(16,*) vscale,'    speed scale [km/s]'
      write(16,*) emscale,'    mass scale [Msun]'
      close(16)
      vsun=vcsun*vscale
      write(*,*) 'Circular speed at R=',rsun,' kpc: ',vsun,' km/s.'

c now turn forces into circular speeds.
      vmax=-1e31
      write(*,*) 'Calculating disk rotation curve...'
      do ir=0,nrplot
         vd(ir)=vc(ir)-vh(ir)-vb(ir)
         rp=rplot(ir)/rscale
         vb(ir)=sqrt(max(0.,-rp*vb(ir)))*vscale
         vh(ir)=sqrt(max(0.,-rp*vh(ir)))*vscale
         vd(ir)=sqrt(max(0.,-rp*vd(ir)))*vscale
         vc(ir)=sqrt(max(0.,-rp*vc(ir)))*vscale
         vmax=max(vc(ir),vmax)
      enddo

      fmax=-1e31
      do iz=0,nzplot
         zp=iz*dzplot
         zplot(iz)=zp
         call force(rsun/rscale,zp/rscale,fr,fz(iz),p)
         fz(iz)=-fz(iz)*vscale**2/rscale/1000.
         fmax=max(fmax,fz(iz))
      enddo

 1    call pgbeg(0,'?',1,2)
      write(*,*)
      call pgsch(2.0)
      call pgenv(0.,rplot(nrplot),0.,vmax*1.15,0,0)
      call pgline(nrplot+1,rplot(0),vb(0))
      call pgline(nrplot+1,rplot(0),vd(0))
      call pgline(nrplot+1,rplot(0),vh(0))
      call pgline(nrplot+1,rplot(0),vc(0))
      call pgpt(1,8.,200.,12)
      call pglabel('R [kpc]','Vcirc [km/s]','ROTATION CURVES')

      call pgenv(0.,zplot(nzplot),0.,fmax*1.15,0,0)
      call pgline(nzplot+1,zplot(0),fz(0))
      write(toplbl,'(''z-FORCE AT R='',f6.3,'' kpc'')') rsun
      call pglabel('z [kpc]','Kz [(km/s)**2 /pc]',toplbl)
      call pgpt(1,1.1,1.9,12)
      call modstamp
      call pgend

      write(*,*) 'Same plot, different device?'
      read(*,'(a)') ans
      if (ans.ne.'n' .and. ans.ne.'N') goto 1
      end


!***********************************************************************
!
! Author:  Jens Debernard
! Date:    20080606
! Purpose: Extract defined(?) values from a field into undef points.
!          Undef points are replaced by the weighted mean of the defined
!          neighbour points.
!
!***********************************************************************

! Arguments

! Local variabels

! Initialisation and start

subroutine creep_fill(finn,mask,ilo,ihi,jlo,jhi,maxit)
  use fill_mod
  implicit none

  integer, intent(in) :: ilo,jlo,ihi,jhi,maxit
  real, intent(in),    dimension(ilo:ihi,jlo:jhi) :: mask
  real, intent(inout), dimension(ilo:ihi,jlo:jhi) :: finn

!jd  real, intent(in),    dimension(:,:) :: mask
!jd  real, intent(inout), dimension(:,:) :: f

  real, dimension(ilo-1:ihi+1,jlo-1:jhi+1) :: f

  integer :: itr, pt, i,j, k,l
  real :: sumw, wginv

  f = 0.0
  f(ilo:ihi,jlo:jhi) = finn

  call fill_init(ilo,ihi,jlo,jhi,mask)

  do itr = 1,maxit
     npo = npn

     nm1 = n
     n = 3-nm1

     do pt=1,npo
        i = iind(pt,nm1); j=jind(pt,nm1);
        sumw=0
        do k=-1,1
           do l=-1,1
              mwg(l,k) = rmask(i+l,j+k)*wg(l,k)
              sumw = sumw + mwg(l,k)
           end do
        end do
!        write(*,*) i,j, sumw

        imask(pt) = 0
        fval(pt) = 0.0
        if (sumw > 0.1) then
           sumw = 1.0/sumw
           imask(pt) = 1
           do k=-1,1
              do l=-1,1
                 wginv = mwg(l,k)*sumw
                 fval(pt) = fval(pt) + wginv*f(i+l,j+k)
!                 write(*,*) pt, wginv, sumw, fval(pt)
              end do
           end do
        end if
     end do

     npn=0
     do pt=1,npo
        i = iind(pt,nm1); j=jind(pt,nm1);
        if ( imask(pt) /= 0 ) then
           f(i,j) = fval(pt)
           rmask(i,j) = 1.0
        else
           npn = npn + 1
           rmask(i,j) = 0.0
           iind(npn,n) = i
           jind(npn,n) = j
        end if
     end do

!     call printf(rmask,ilo,ihi,jlo,jhi,'rmask')
!     call printf(f,ilo,ihi,jlo,jhi,'f-creep')

!jd     write(*,*) itr, npn
     if (npn == 0) exit
  end do

  finn = f(ilo:ihi,jlo:jhi)

  write(*,*) 'Itr, maxit = ', itr, maxit

end subroutine creep_fill


       SUBROUTINE CELLMAP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! sets up the 2D linkcell map
!!!! K.Travis 24/02/12  Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      USE header_file
      IMPLICIT NONE

      INTEGER   :: IX,IY,ICELL,IMAP

      DO IY = 1,NCELLY
        DO IX = 1,NCELLX

          IMAP = (ICELL(IX, IY,NCELLX,NCELLY) - 1)*4

          MAP(IMAP + 1) = ICELL(IX + 1, IY    , NCELLX, NCELLY)
          MAP(IMAP + 2) = ICELL(IX + 1, IY + 1, NCELLX, NCELLY)
          MAP(IMAP + 3) = ICELL(IX    , IY + 1, NCELLX, NCELLY)
          MAP(IMAP + 4) = ICELL(IX - 1, IY + 1, NCELLX, NCELLY)

        END DO
      END DO

      END SUBROUTINE

      INTEGER FUNCTION ICELL(IXX,IYY,NX,NY)
      IMPLICIT NONE
! declare input variables
      INTEGER,  INTENT(IN) :: IXX
      INTEGER,  INTENT(IN) :: IYY
      INTEGER,  INTENT(IN) :: NX
      INTEGER,  INTENT(IN) :: NY

! evaluate cell index

      ICELL = 1 + MOD(IXX - 1 + NX,NX) + MOD(IYY - 1 + NY, NY)*NX

      END FUNCTION


*     MC01PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX
      PARAMETER        ( KMAX = 10 )
*     .. Local Scalars ..
      INTEGER          I, INFO, K
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(KMAX+1), IMZ(KMAX), P(KMAX+1), REZ(KMAX)
*     .. External Subroutines ..
      EXTERNAL         MC01PD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K
      IF ( K.LT.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) K
      ELSE
         READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K )
*        Compute the coefficients of P(x) from the given zeros.
         CALL MC01PD( K, REZ, IMZ, P, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99996 ) ( I, P(I+1), I = 0,K )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC01PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01PD = ',I2)
99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe',
     $       'r of x     coefficient ')
99996 FORMAT (2X,I5,9X,F9.4)
99995 FORMAT (' K is out of range.',/' K = ',I5)
      END


c     Subroutine to output extremes of latlon
c     AJ_Kettle, 13Sep2019
c     27Mar2020: used for USAF update

      SUBROUTINE check_running_latlon(
     +   f_min_lon,f_max_lon,f_min_lat,f_max_lat,
     +   l_cnt_rgh,l_cnt_triplet,s_vec_latitude,s_vec_longitude)

      IMPLICIT NONE
c************************************************************************
      REAL                :: f_min_lon,f_max_lon,f_min_lat,f_max_lat
      INTEGER             :: l_cnt_rgh
      INTEGER             :: l_cnt_triplet
      CHARACTER(LEN=9)    :: s_vec_latitude(l_cnt_rgh)
      CHARACTER(LEN=9)    :: s_vec_longitude(l_cnt_rgh)
c*****
c     Variables used withi subroutine

      INTEGER             :: i,j,k,ii,jj,kk

      REAL                :: f_lat,f_lon
c************************************************************************
c      print*,'just entered check_running_latlon'

      print*,'l_cnt_rgh,l_cnt_triplet=',l_cnt_rgh,l_cnt_triplet

      print*,'lat list=',(s_vec_latitude(i),i=1,l_cnt_triplet)
      print*,'lon list=',(s_vec_longitude(i),i=1,l_cnt_triplet)

      DO i=1,l_cnt_triplet
       READ(s_vec_latitude(i),'(f10.5)') f_lat
       READ(s_vec_longitude(i),'(f10.5)') f_lon
c       print*,'i=',i,f_lat,f_lon

       f_min_lon=MIN(f_min_lon,f_lon)
       f_max_lon=MAX(f_max_lon,f_lon)
       f_min_lat=MIN(f_min_lat,f_lat)
       f_max_lat=MAX(f_max_lat,f_lat)
      ENDDO

      print*,'f_min_lon...=',f_min_lon,f_max_lon,f_min_lat,f_max_lat

c      print*,'just leaving check_running_latlon'

      RETURN
      END


program mag2geo

use, intrinsic :: iso_fortran_env, only: real64
use apex, only : apex_setup,gm2gc

implicit none (type, external)

integer :: i, u, N
character(256) :: buf, nmlfn
real :: yeardec, r
real, allocatable, dimension(:) :: glat, glon, gmlat, gmlon
real(real64) :: tic, toc

namelist / input_shape / N
namelist / output / glat, glon
namelist / input / gmlat, gmlon

call get_command_argument(1, buf, status=i)
if(i/=0) error stop 'missing decimal year e.g. 2020.35'
read(buf, '(f8.4)', iostat=i) yeardec
if(i/=0) error stop 'command line should be like "./geo2mag yeardec in.nml out.nml"'

call get_command_argument(2, nmlfn, status=i)
if(i/=0) error stop 'specify input namelist file'

! -------------------------
!! read first, in case there is an IO issue, we don't want to waste time
!! initializing Apex if it will fail anyway
open(newunit=u, file=nmlfn, action='readwrite', status='old')
read(u, nml=input_shape)

allocate(glat(N), glon(N), gmlat(N), gmlon(N))

read(u, nml=input)

call cpu_time(tic)
call apex_setup(yeardec,altmax=1000.)
call cpu_time(toc)
print '(F5.1,A)', toc-tic, ' seconds to setup Apex'

call cpu_time(tic)
do i = 1,size(gmlat)
  call gm2gc(gmlat(i), gmlon(i), glat(i), glon(i))
end do
call cpu_time(toc)
print '(ES12.3,A,I8,A)', toc-tic, ' seconds to convert ', N, ' points.'

write(u, nml=output)
close(u)

end program


C++------------------------------------------------------------------------
C ARITHM_COLUMNS
C General program to perform arithmethic operations on X,Y lists
C with/without error bars,
C
C Reads galaxy profiles, ascii X,Y lists, Midas, FITS spectra, etc
C (by calling READFILE).
C
C JLP
C Version of 24-03-2010
C--------------------------------------------------------------------------
        PROGRAM ARITHM_COLUMNS
        IMPLICIT NONE
        INTEGER*4 IDIM
        PARAMETER (IDIM=20000)
C
	REAL*4 XX(IDIM),Y1(IDIM),Y2(IDIM),ZZ(IDIM)
        REAL*4 ERRORX(IDIM),ERRORY(IDIM),ERRORZ(IDIM)
        REAL*4 AA,BB,CC
        INTEGER*4 NPT1,NPT2,NPTS,I,IOPT
        CHARACTER IN_FILE*40,IN_COMMENTS*80,ANS*1
	LOGICAL ERROR_BARS,CHECK_INPUT

10	FORMAT(A)
        NPTS=0

	PRINT 88
88	FORMAT(5X,' Program ARITHM_COLUMNS',/,
     1    'Version of 24-11-2004',/)
C
	PRINT 89
89	FORMAT(' Do you want me to type the values of the input',
     1	' files ? (N)')
	READ(5,10) ANS
	CHECK_INPUT=.FALSE.
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')CHECK_INPUT=.TRUE.

C Image format (in case of option 8 in READFILE):
        CALL JLP_BEGIN
        CALL JLP_INQUIFMT
C
	ERROR_BARS=.FALSE.
12	WRITE(6,130)
130     FORMAT(' Menu :',/,
     1	' 1. Input of a vector (X,Y1) or (X,Y1,Y2)',/,
     1	' 2. Input of a vector (X,Y,ERRROR_Y) with error bars',/,
     1	5X,' Enter the option you want: ')
	READ(5,*) IOPT

C------------------------------------------------------------------
C Without error bars
	IF(IOPT.EQ.1)THEN
	CALL RREADFILE(XX,Y1,NPT1,XX,Y2,NPT2,IDIM,
     1                 IN_FILE,IN_COMMENTS,0)
	IF((NPT2.NE.0).AND.(NPT1.NE.NPT2))THEN
          WRITE(6,*)' Fatal error: not the same X list'
          STOP
	ENDIF
	IF(CHECK_INPUT)THEN
          IF(NPT2.NE.0)THEN
	    DO I=1,NPT1
	      PRINT *,I,XX(I),Y1(I),Y2(I)
	    END DO
          ELSE
	    DO I=1,NPT1
	      PRINT *,I,XX(I),Y1(I)
	    END DO
          ENDIF
	ENDIF

	ERROR_BARS=.FALSE.
        NPTS=NPT1

C------------------------------------------------------------------
C Input with error bars
	ELSEIF(IOPT.EQ.2)THEN

	ERROR_BARS=.TRUE.

C Reading XX, Y1, Error_X, Error_Y
	CALL RREADFILE_ERRORS(XX,Y1,ERRORX,ERRORY,NPT1,IDIM,
     1                 IN_FILE,IN_COMMENTS,2)

	 IF(CHECK_INPUT)THEN
	   DO I=1,NPT1
	     PRINT 508,I,XX(I),Y1(I),ERRORX(I),ERRORY(I)
	   END DO
	 ENDIF
508	FORMAT(' I=',I4,'X,Y,ERROR X,ERROR Y:',4(F12.3,1X))

	ERROR_BARS=.TRUE.
        NPT2=0
        NPTS=NPT1
	ENDIF
C------------------------------------------------------------------
        IF(NPTS.EQ.0)THEN
          WRITE(6,*) 'No curves: Exit'
          STOP
        ENDIF

C------------------------------------------------------------------
        IF(NPT2.NE.0)THEN
	WRITE(6,131)
131     FORMAT(' Menu :',/,
     1  ' 1. X1 := X1 + A and Y1 := Y1 + B and  Y2 := Y2 + C',/,
     1  '                         (sortie: X1, Y1, Y2)',/,
     1	' 2. Z = A * (Y2/Y1) + B  (sortie: X1,Z)',/,
     1	' 3. Z = A * (Y1/Y2) + B  (sortie: X1,Z)',/,
     1	5X,' Enter the option you want: ')
	READ(5,*) IOPT

C------------------------------------------------------------------
	IF(IOPT.EQ.1)THEN
          WRITE(6,*)' Enter A, B, C:'
          READ(5,*) AA,BB,CC
          CALL ARITH_XY1Y2(XX,Y1,Y2,NPTS,AA,BB,CC)
	ELSE IF(IOPT.EQ.2)THEN
          WRITE(6,*)' Enter A, B:'
          READ(5,*) AA,BB
          CALL ARITH1(Y2,Y1,ZZ,NPTS,AA,BB)
        ELSEIF(IOPT.EQ.3)THEN
          WRITE(6,*)' Enter A, B:'
          READ(5,*) AA,BB
          CALL ARITH1(Y1,Y2,ZZ,NPTS,AA,BB)
        ENDIF

        ELSE
 	  WRITE(6,132)
132       FORMAT(' Menu :',/,
     1	' 2. Z = A * Y1 + B  (sortie: X1, Z)',/,
     1	5X,' Enter the option you want: ')
	  READ(5,*) IOPT
C------------------------------------------------------------------
	IF(IOPT.EQ.2)THEN
          WRITE(6,*)' Enter A, B: '
          READ(5,*) AA,BB
          CALL ARITH2(Y1,ZZ,ERRORY,ERRORZ,ERROR_BARS,NPTS,
     1                AA,BB)
        ENDIF

        ENDIF
C------------------------------------------------------------------
        IF(IOPT.EQ.1)THEN
          CALL OUTPUT_CURVE_XYY(XX,Y1,Y2,NPTS)
        ELSEIF(IOPT.EQ.2.OR.IOPT.EQ.3) THEN
          CALL OUTPUT_CURVE(XX,ZZ,ERRORX,ERRORZ,ERROR_BARS,NPTS)
        ENDIF
C------------------------------------------------------------------
        CALL JLP_END
        STOP
	END
C********************************************************************
C Subroutine performing arithmetic operations on the curves
C********************************************************************
        SUBROUTINE ARITH_XY1Y2(XX,Y1,Y2,NPTS,AA,BB,CC)
        IMPLICIT NONE
	REAL*4 XX(*),Y1(*),Y2(*)
        REAL*4 AA,BB,CC
        INTEGER*4 I,NPTS

        DO I=1,NPTS
           XX(I)=XX(I)+AA
           Y1(I)=Y1(I)+BB
           Y2(I)=Y2(I)+CC
        END DO

        RETURN
        END
C********************************************************************
C Subroutine performing arithmetic operations on the curves
C without error_bars
C********************************************************************
	SUBROUTINE ARITH1(Y1,Y2,ZZ,NPTS,AA,BB)
        IMPLICIT NONE
	REAL*4 Y1(*),Y2(*),ZZ(*)
        REAL*4 AA,BB
        INTEGER*4 I,NPTS

	DO I=1,NPTS
          IF(Y2(I).NE.0)THEN
	    ZZ(I)=AA*Y1(I)/Y2(I)+BB
          ELSE
            ZZ(I)=1.e+9
          ENDIF
	END DO

	RETURN
	END
C********************************************************************
C Subroutine performing arithmetic operations on the curves
C with error_bars
C********************************************************************
	SUBROUTINE ARITH2(Y1,ZZ,ERRORY,ERRORZ,ERROR_BARS,
     1                    NPTS,AA,BB)
        IMPLICIT NONE
	REAL*4 Y1(*),ZZ(*),ERRORY(*),ERRORZ(*)
        REAL*4 AA,BB
        INTEGER*4 I,NPTS
	LOGICAL ERROR_BARS

C
	DO I=1,NPTS
	  ZZ(I)=AA*Y1(I)+BB
	END DO

C Errors:
        IF(ERROR_BARS)THEN
	  DO I=1,NPTS
	    ERRORZ(I)=AA*ERRORY(I)
	  END DO
        ENDIF

	RETURN
	END

C********************************************************************
C Subroutine to output a curve from XPLOT,YPLOT
C********************************************************************
	SUBROUTINE OUTPUT_CURVE(XX,ZZ,ERRORX,ERRORZ,ERROR_BARS,NPTS)
        IMPLICIT NONE
	REAL*4 XX(*),ZZ(*),ERRORX(*),ERRORZ(*)
        INTEGER I,NPTS
	CHARACTER NAME*60
	LOGICAL ERROR_BARS

10	FORMAT(A)

807	PRINT *,' NAME OF THE OUTPUT FILE ?'
	READ(5,10) NAME
	OPEN(1,FILE=NAME,STATUS='UNKNOWN',ACCESS='SEQUENTIAL')
         IF(ERROR_BARS)THEN
	   DO I=1,NPTS
	     WRITE(1,*)XX(I),ZZ(I),ERRORX(I),ERRORZ(I)
	   END DO
         ELSE
	   DO I=1,NPTS
	     WRITE(1,*)XX(I),ZZ(I)
	   END DO
         ENDIF
	CLOSE(1)

	RETURN
	END

C********************************************************************
C Subroutine to output a curve from XPLOT,YPLOT
C********************************************************************
        SUBROUTINE OUTPUT_CURVE_XYY(XX,Y1,Y2,NPTS)
        IMPLICIT NONE
	REAL*4 XX(*),Y1(*),Y2(*)
        INTEGER I,NPTS
        CHARACTER NAME*60

10      FORMAT(A)

897     PRINT *,' NAME OF THE OUTPUT FILE ?'
        READ(5,10) NAME
        OPEN(1,FILE=NAME,STATUS='UNKNOWN',ACCESS='SEQUENTIAL')
           DO I=1,NPTS
               WRITE(1,*)XX(I),Y1(I),Y2(I)
           END DO
        CLOSE(1)

        RETURN
        END


*> \brief \b CPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CPBTF2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, KD, LDAB, N
*       ..
*       .. Array Arguments ..
*       COMPLEX            AB( LDAB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CPBTF2 computes the Cholesky factorization of a complex Hermitian
*> positive definite band matrix A.
*>
*> The factorization has the form
*>    A = U**H * U ,  if UPLO = 'U', or
*>    A = L  * L**H,  if UPLO = 'L',
*> where U is an upper triangular matrix, U**H is the conjugate transpose
*> of U, and L is lower triangular.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the upper or lower triangular part of the
*>          Hermitian matrix A is stored:
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KD
*> \verbatim
*>          KD is INTEGER
*>          The number of super-diagonals of the matrix A if UPLO = 'U',
*>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*>          AB is COMPLEX array, dimension (LDAB,N)
*>          On entry, the upper or lower triangle of the Hermitian band
*>          matrix A, stored in the first KD+1 rows of the array.  The
*>          j-th column of A is stored in the j-th column of the array AB
*>          as follows:
*>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*>
*>          On exit, if INFO = 0, the triangular factor U or L from the
*>          Cholesky factorization A = U**H *U or A = L*L**H of the band
*>          matrix A, in the same storage format as A.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= KD+1.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -k, the k-th argument had an illegal value
*>          > 0: if INFO = k, the leading minor of order k is not
*>               positive definite, and the factorization could not be
*>               completed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The band storage scheme is illustrated by the following example, when
*>  N = 6, KD = 2, and UPLO = 'U':
*>
*>  On entry:                       On exit:
*>
*>      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
*>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*>
*>  Similarly, if UPLO = 'L' the format of A is as follows:
*>
*>  On entry:                       On exit:
*>
*>     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
*>     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
*>     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
*>
*>  Array elements marked * are not used by the routine.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
*     ..
*     .. Array Arguments ..
      COMPLEX            AB( LDAB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, KLD, KN
      REAL               AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CHER, CLACGV, CSSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CPBTF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      KLD = MAX( 1, LDAB-1 )
*
      IF( UPPER ) THEN
*
*        Compute the Cholesky factorization A = U**H * U.
*
         DO 10 J = 1, N
*
*           Compute U(J,J) and test for non-positive-definiteness.
*
            AJJ = REAL( AB( KD+1, J ) )
            IF( AJJ.LE.ZERO ) THEN
               AB( KD+1, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
*
*           Compute elements J+1:J+KN of row J and update the
*           trailing submatrix within the band.
*
            KN = MIN( KD, N-J )
            IF( KN.GT.0 ) THEN
               CALL CSSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
               CALL CLACGV( KN, AB( KD, J+1 ), KLD )
               CALL CHER( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
     $                    AB( KD+1, J+1 ), KLD )
               CALL CLACGV( KN, AB( KD, J+1 ), KLD )
            END IF
   10    CONTINUE
      ELSE
*
*        Compute the Cholesky factorization A = L*L**H.
*
         DO 20 J = 1, N
*
*           Compute L(J,J) and test for non-positive-definiteness.
*
            AJJ = REAL( AB( 1, J ) )
            IF( AJJ.LE.ZERO ) THEN
               AB( 1, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
*
*           Compute elements J+1:J+KN of column J and update the
*           trailing submatrix within the band.
*
            KN = MIN( KD, N-J )
            IF( KN.GT.0 ) THEN
               CALL CSSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
               CALL CHER( 'Lower', KN, -ONE, AB( 2, J ), 1,
     $                    AB( 1, J+1 ), KLD )
            END IF
   20    CONTINUE
      END IF
      RETURN
*
   30 CONTINUE
      INFO = J
      RETURN
*
*     End of CPBTF2
*
      END


subroutine SubScanEdges(az, search_length, scan_edges,vars, level, len_az)
  implicit none

  integer, intent(in) :: len_az
  real(8), intent(in) :: az(len_az)
  integer, intent(in) :: search_length
  real(8), intent(in) :: level
  integer, intent(out) :: scan_edges(len_az)
  real(8), intent(out) :: vars(len_az)

  integer :: i

  real(8) :: buffer_values(search_length)
  real(8) :: mean, rms, var, r_search_length

  r_search_length = REAL(search_length)

  ! scan_edges is 1 wherever variance of az is < level,
  !  e.g. azimuth is no moving, therefore end of a scan
  scan_edges(1) = 1
  scan_edges(len_az) = 1
  do i=1, len_az

     ! Fill up the buffer initially
     IF (i < search_length+1) THEN
        buffer_values(i) = az(i)

     ELSE
        ! THEN measure the variance of each step
        buffer_values(MOD(i, search_length)+1) = az(i)
        mean = SUM(buffer_values)/r_search_length
        rms  = SUM(buffer_values*buffer_values)/r_search_length
        var  = SQRT(rms - mean*mean)
        vars(i) =  var

        IF (var < level) THEN
           scan_edges(i) = 1
        END IF
     END IF
  END DO
end subroutine SubScanEdges

subroutine FindMidPoints(data, edges, len_data)
  implicit none

  integer, intent(in) :: len_data
  integer, intent(in) :: data(len_data)
  integer, intent(out) :: edges(len_data)

  integer :: buffer_values(len_data)

  integer :: i, iedge, buffer_count, lastedge, distance
  iedge = 1
  buffer_count = 1

  distance = 2000
  lastedge = 0 - distance

  DO i=1, len_data

     ! Start filling the buffer
     IF (data(i) .EQ. 1) THEN
        buffer_values(buffer_count) = i
        buffer_count = buffer_count + 1
     ELSE ! when you move into data
        IF (buffer_count > 1) THEN ! need to clear the buffer
           if (buffer_values(1) .GT. (lastedge + distance)) THEN
              edges(iedge) = buffer_values(1) !SUM(buffer_values(1:buffer_count))/(buffer_count-1)
              lastedge = edges(iedge)
           end if
           !lastedge = buffer_values(1)
           iedge = iedge + 1
           buffer_count = 1

        END IF
     END IF
  END DO
end subroutine FindMidPoints


C     Structured version of four3.f
C
C     The loop here is never entered... since J is initialized to 1

      SUBROUTINE FOUR4(N)

      J = 1
      NN = 2*N
      M=NN/2
      DO WHILE ((M.GE.2).AND.(J.GT.M))
         J=J-M
         M=M/2
      ENDDO

      PRINT *, N, NN, M, J

      END


! $Id: num_rec.f90,v 1.1 2008-07-24 17:31:45 dschanen Exp $
!   From _Numerical Recipes in Fortran 90_
!   (C) 1988-1996 Numerical Recipes Software
MODULE nrtype

INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
INTEGER, PARAMETER :: SP  = KIND(1.0)
INTEGER, PARAMETER :: DP  = KIND(1.0D0)
INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
INTEGER, PARAMETER :: LGT = KIND(.true.)

REAL(SP), PARAMETER :: PI      = 3.141592653589793238462643383279502884197_sp
REAL(SP), PARAMETER :: PIO2    = 1.57079632679489661923132169163975144209858_sp
REAL(SP), PARAMETER :: TWOPI   = 6.283185307179586476925286766559005768394_sp
REAL(SP), PARAMETER :: SQRT2   = 1.41421356237309504880168872420969807856967_sp
REAL(SP), PARAMETER :: EULER   = 0.5772156649015328606065120900824024310422_sp
REAL(DP), PARAMETER :: PI_D    = 3.141592653589793238462643383279502884197_dp
REAL(DP), PARAMETER :: PIO2_D  = 1.57079632679489661923132169163975144209858_dp
REAL(DP), PARAMETER :: TWOPI_D = 6.283185307179586476925286766559005768394_dp

TYPE sprs2_sp
  INTEGER(I4B)                        :: n, len
  REAL(SP), DIMENSION(:), POINTER     :: val
  INTEGER(I4B), DIMENSION(:), POINTER :: irow
  INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_sp

TYPE sprs2_dp
  INTEGER(I4B)                        :: n, len
  REAL(DP), DIMENSION(:), POINTER     :: val
  INTEGER(I4B), DIMENSION(:), POINTER :: irow
  INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_dp

END MODULE nrtype


Program Compass
  implicit none

  integer :: i, ind
  real :: heading

  do i = 0, 32
    heading = i * 11.25
    if (mod(i, 3) == 1) then
      heading = heading + 5.62
    else if (mod(i, 3) == 2) then
            heading = heading - 5.62
    end if
    ind = mod(i, 32) + 1
    write(*, "(i2, a20, f8.2)") ind, compasspoint(heading), heading
  end do

contains

function compasspoint(h)
  character(18) :: compasspoint
  character(18) :: points(32) = (/ "North             ", "North by east     ", "North-northeast   ", &
             "Northeast by north", "Northeast         ", "Northeast by east ", "East-northeast    ", &
             "East by north     ", "East              ", "East by south     ", "East-southeast    ", &
             "Southeast by east ", "Southeast         ", "Southeast by south", "South-southeast   ", &
             "South by east     ", "South             ", "South by west     ", "South-southwest   ", &
             "Southwest by south", "Southwest         ", "Southwest by west ", "West-southwest    ", &
             "West by south     ", "West              ", "West by north     ", "West-northwest    ", &
             "Northwest by west ", "Northwest         ", "Northwest by north", "North-northwest   ", &
             "North by west     "  /)
  real, intent(in) :: h
  real :: x

  x = h / 11.25 + 1.5
  if (x >= 33.0) x = x - 32.0
  compasspoint = points(int(x))
end function compasspoint
end program Compass


      SUBROUTINE slDVXV (VA, VB, VC)
*+
*     - - - - -
*      D V X V
*     - - - - -
*
*  Vector product of two 3-vectors  (double precision)
*
*  Given:
*      VA      dp(3)     first vector
*      VB      dp(3)     second vector
*
*  Returned:
*      VC      dp(3)     vector result
*
*  P.T.Wallace   Starlink   March 1986
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION VA(3),VB(3),VC(3)

      DOUBLE PRECISION VW(3)
      INTEGER I

*  Form the vector product VA cross VB
      VW(1)=VA(2)*VB(3)-VA(3)*VB(2)
      VW(2)=VA(3)*VB(1)-VA(1)*VB(3)
      VW(3)=VA(1)*VB(2)-VA(2)*VB(1)

*  Return the result
      DO I=1,3
         VC(I)=VW(I)
      END DO

      END


program main

  use boxlib
  use parallel
  use multifab_module
  use bl_IO_module
  use layout_module
  use init_data_module
  use write_plotfile_module
  use advance_module
  use bl_prof_module

  implicit none
  !
  ! We only support 3-D.
  !
  integer, parameter :: DM = 3
  !
  ! We need four grow cells.
  !
  integer, parameter :: NG  = 4
  !
  ! We have five components (no species).
  !
  integer, parameter :: NC  = 5

  integer            :: nsteps, plot_int, n_cell, max_grid_size
  integer            :: un, farg, narg
  logical            :: need_inputs_file, found_inputs_file
  character(len=128) :: inputs_file_name
  integer            :: i, lo(DM), hi(DM), istep
  double precision   :: prob_lo(DM), prob_hi(DM), cfl, eta, alam
  double precision   :: dx(DM), dt, time, start_time, end_time
  logical            :: is_periodic(DM)
  type(box)          :: bx
  type(boxarray)     :: ba
  type(layout)       :: la
  type(multifab)     :: U

  type(bl_prof_timer), save :: bpt, bpt_init_data, bpt_sleep

  !
  ! What's settable via an inputs file.
  !
  namelist /probin/ nsteps, plot_int, n_cell, max_grid_size, cfl, eta, alam

  call boxlib_initialize()
  call bl_prof_initialize(on = .true.)

  call build(bpt, "bpt_main")

  start_time = parallel_wtime()

  call build(bpt_sleep, "bpt_sleep")
  call Sleep(5)
  call destroy(bpt_sleep)

  !
  ! Namelist default values -- overwritable via inputs file.
  !
  nsteps        = 100
  plot_int      = 10
  n_cell        = 32
  max_grid_size = 32
  cfl           = 0.5d0
  eta           = 1.8d-4 ! Diffusion coefficient.
  alam          = 1.5d2  ! Diffusion coefficient.
  !
  ! Read inputs file and overwrite any default values.
  !
  narg = command_argument_count()
  need_inputs_file = .true.
  farg = 1
  if ( need_inputs_file .AND. narg >= 1 ) then
     call get_command_argument(farg, value = inputs_file_name)
     inquire(file = inputs_file_name, exist = found_inputs_file )
     if ( found_inputs_file ) then
        farg = farg + 1
        un = unit_new()
        open(unit=un, file = inputs_file_name, status = 'old', action = 'read')
        read(unit=un, nml = probin)
        close(unit=un)
        need_inputs_file = .false.
     end if
  end if

  if ( parallel_IOProcessor() ) then
     write(6,probin)
  end if
  !
  ! Physical problem is a box on (-1,-1) to (1,1), periodic on all sides.
  !
  prob_lo     = -0.1d0
  prob_hi     =  0.1d0
  is_periodic = .true.
  !
  ! Create a box from (0,0) to (n_cell-1,n_cell-1).
  !
  lo = 0
  hi = n_cell-1
  bx = make_box(lo,hi)

  do i = 1,DM
     dx(i) = (prob_hi(i)-prob_lo(i)) / n_cell
  end do

  call boxarray_build_bx(ba,bx)

  call boxarray_maxsize(ba,max_grid_size)

  call layout_build_ba(la,ba,boxarray_bbox(ba),pmask=is_periodic)

  call destroy(ba)

  call multifab_build(U,la,NC,NG)

  call build(bpt_init_data, "bpt_init_data")
  call init_data(U,dx,prob_lo,prob_hi)
  call destroy(bpt_init_data)

  istep = 0
  time  = 0.d0

  if (plot_int > 0) then
     call write_plotfile(U,istep,dx,time,prob_lo,prob_hi)
  end if

  do istep=1,nsteps

     if (parallel_IOProcessor()) then
        print*,'Advancing time step',istep,'time = ',time
     end if

     call advance(U,dt,dx,cfl,eta,alam)

     time = time + dt

     if (plot_int > 0) then
        if (mod(istep,plot_int) .eq. 0 .or. istep .eq. nsteps) then
           call write_plotfile(U,istep,dx,time,prob_lo,prob_hi)
        end if
     end if

  end do

  call destroy(U)
  call destroy(la)

  end_time = parallel_wtime()

  if ( parallel_IOProcessor() ) then
     print*,"Run time (s) =",end_time-start_time
  end if

  call destroy(bpt)
  call bl_prof_glean("bl_prof_report")
  call bl_prof_finalize()

  call boxlib_finalize()

end program main


MODULE Potentialtranspirationmod
    IMPLICIT NONE
CONTAINS
    SUBROUTINE model_potentialtranspiration(evapoTranspiration, &
        tau, &
        potentialTranspiration)
        REAL, INTENT(IN) :: evapoTranspiration
        REAL, INTENT(IN) :: tau
        REAL, INTENT(OUT) :: potentialTranspiration
        !- Description:
    !            - Model Name: PotentialTranspiration Model
    !            - Author: Pierre Martre
    !            - Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            - Institution: INRA/LEPSE Montpellier
    !            - Abstract: SiriusQuality2 uses availability of water from the soil reservoir as a method to restrict
    !                    transpiration as soil moisture is depleted
        !- inputs:
    !            - name: evapoTranspiration
    !                          - description : evapoTranspiration
    !                          - variablecategory : rate
    !                          - datatype : DOUBLE
    !                          - default : 830.958
    !                          - min : 0
    !                          - max : 10000
    !                          - unit : mm
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
    !            - name: tau
    !                          - description : plant cover factor
    !                          - parametercategory : species
    !                          - datatype : DOUBLE
    !                          - default : 0.9983
    !                          - min : 0
    !                          - max : 1
    !                          - unit :
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : parameter
        !- outputs:
    !            - name: potentialTranspiration
    !                          - description : potential Transpiration
    !                          - variablecategory : rate
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - unit : g m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        potentialTranspiration = evapoTranspiration * (1.0 - tau)
    END SUBROUTINE model_potentialtranspiration

END MODULE


SUBROUTINE inner(g,its,nsm)

!-------------------------------------------------------------
!
!  Directs the inner iterations
!   Calls for the mesh sweep in 'sweep'
!   Evaulates convergence
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g, nsm
INTEGER :: i, it
INTEGER, INTENT(OUT) :: its
REAL*8 :: df, dfmx
REAL*8, DIMENSION(nx*sord) :: e

! Initialize the previous flux iterate
e = 0.0
! Start the iterations
DO it = 1, itmx
   ! Call for the mesh sweep
   CALL sweep(g,e)

   ! Compare new and old flux iterates for user chosen range of moments, iall
   dfmx = -1.0
   DO i = 1, nsm, sord     ! Set stride so only check 0 moment convergence
      ! Compute the difference depending on 'e' value
      IF (ABS(e(i)) >= tolr) THEN
         df = ABS((f(i,g) - e(i))/e(i))
      ELSE
         df = ABS(f(i,g) - e(i))
      END IF
      ! Find the largest value
      IF (df > dfmx) THEN
         dfmx = df
      END IF
   END DO

   ! Print whether or not convergence was reached
   IF (dfmx > err .AND. it < itmx) THEN
      ! Set previous iterate of flux equal to current iterate
      e = f(:,g)
   ELSE IF (dfmx < err) THEN
      cnvf(g) = 1
      its = it
      EXIT
   ELSE IF (it == itmx) THEN
      cnvf(g) = 0
      its = it
      EXIT
   END IF

! End the iterations
END DO

! 111 FORMAT(2X,'Gr',I3,' It ',I5,' Pos ',3I4,' DfMx ',ES11.3,' Flx ',ES11.3, '  Time(s) ', F9.3)

RETURN
END SUBROUTINE inner


      SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
      DOUBLE PRECISION   ANORM, RCOND
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), RWORK( * )
      COMPLEX*16         E( * )
*     ..
*
*  Purpose
*  =======
*
*  ZPTCON computes the reciprocal of the condition number (in the
*  1-norm) of a complex Hermitian positive definite tridiagonal matrix
*  using the factorization A = L*D*L**H or A = U**H*D*U computed by
*  ZPTTRF.
*
*  Norm(inv(A)) is computed by a direct method, and the reciprocal of
*  the condition number is computed as
*                   RCOND = 1 / (ANORM * norm(inv(A))).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  D       (input) DOUBLE PRECISION array, dimension (N)
*          The n diagonal elements of the diagonal matrix D from the
*          factorization of A, as computed by ZPTTRF.
*
*  E       (input) COMPLEX*16 array, dimension (N-1)
*          The (n-1) off-diagonal elements of the unit bidiagonal factor
*          U or L from the factorization of A, as computed by ZPTTRF.
*
*  ANORM   (input) DOUBLE PRECISION
*          The 1-norm of the original matrix A.
*
*  RCOND   (output) DOUBLE PRECISION
*          The reciprocal of the condition number of the matrix A,
*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
*          1-norm of inv(A) computed in this routine.
*
*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The method used is described in Nicholas J. Higham, "Efficient
*  Algorithms for Computing the Condition Number of a Tridiagonal
*  Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IX
      DOUBLE PRECISION   AINVNM
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPTCON', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
*
*     Check that D(1:N) is positive.
*
      DO 10 I = 1, N
         IF( D( I ).LE.ZERO )
     $      RETURN
   10 CONTINUE
*
*     Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
*
*        m(i,j) =  abs(A(i,j)), i = j,
*        m(i,j) = -abs(A(i,j)), i .ne. j,
*
*     and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
*
*     Solve M(L) * x = e.
*
      RWORK( 1 ) = ONE
      DO 20 I = 2, N
         RWORK( I ) = ONE + RWORK( I-1 )*ABS( E( I-1 ) )
   20 CONTINUE
*
*     Solve D * M(L)' * x = b.
*
      RWORK( N ) = RWORK( N ) / D( N )
      DO 30 I = N - 1, 1, -1
         RWORK( I ) = RWORK( I ) / D( I ) + RWORK( I+1 )*ABS( E( I ) )
   30 CONTINUE
*
*     Compute AINVNM = max(x(i)), 1<=i<=n.
*
      IX = IDAMAX( N, RWORK, 1 )
      AINVNM = ABS( RWORK( IX ) )
*
*     Compute the reciprocal condition number.
*
      IF( AINVNM.NE.ZERO )
     $   RCOND = ( ONE / AINVNM ) / ANORM
*
      RETURN
*
*     End of ZPTCON
*
      END


!*==zhptrd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZHPTRD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZHPTRD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   D( * ), E( * )
!       COMPLEX*16         AP( * ), TAU( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
!> real symmetric tridiagonal form T by a unitary similarity
!> transformation: Q**H * A * Q = T.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] AP
!> \verbatim
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          On entry, the upper or lower triangle of the Hermitian matrix
!>          A, packed columnwise in a linear array.  The j-th column of A
!>          is stored in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the unitary
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the unitary matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> \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 December 2016
!
!> \ingroup complex16OTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n-1) . . . H(2) H(1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
!>  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(n-1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!>  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZHPTRD(Uplo,N,Ap,D,E,Tau,Info)
      IMPLICIT NONE
!*--ZHPTRD155
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION D(*) , E(*)
      COMPLEX*16 Ap(*) , Tau(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 ONE , ZERO , HALF
      PARAMETER (ONE=(1.0D+0,0.0D+0),ZERO=(0.0D+0,0.0D+0),              &
     &           HALF=(0.5D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      LOGICAL upper
      INTEGER i , i1 , i1i1 , ii
      COMPLEX*16 alpha , taui
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , ZAXPY , ZHPMV , ZHPR2 , ZLARFG
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      COMPLEX*16 ZDOTC
      EXTERNAL LSAME , ZDOTC
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZHPTRD',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N<=0 ) RETURN
!
      IF ( upper ) THEN
!
!        Reduce the upper triangle of A.
!        I1 is the index in AP of A(1,I+1).
!
         i1 = N*(N-1)/2 + 1
         Ap(i1+N-1) = DBLE(Ap(i1+N-1))
         DO i = N - 1 , 1 , -1
!
!           Generate elementary reflector H(i) = I - tau * v * v**H
!           to annihilate A(1:i-1,i+1)
!
            alpha = Ap(i1+i-1)
            CALL ZLARFG(i,alpha,Ap(i1),1,taui)
            E(i) = alpha
!
            IF ( taui/=ZERO ) THEN
!
!              Apply H(i) from both sides to A(1:i,1:i)
!
               Ap(i1+i-1) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(1:i)
!
               CALL ZHPMV(Uplo,i,taui,Ap,Ap(i1),1,ZERO,Tau,1)
!
!              Compute  w := y - 1/2 * tau * (y**H *v) * v
!
               alpha = -HALF*taui*ZDOTC(i,Tau,1,Ap(i1),1)
               CALL ZAXPY(i,alpha,Ap(i1),1,Tau,1)
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w**H - w * v**H
!
               CALL ZHPR2(Uplo,i,-ONE,Ap(i1),1,Tau,1,Ap)
!
            ENDIF
            Ap(i1+i-1) = E(i)
            D(i+1) = Ap(i1+i)
            Tau(i) = taui
            i1 = i1 - i
         ENDDO
         D(1) = Ap(1)
      ELSE
!
!        Reduce the lower triangle of A. II is the index in AP of
!        A(i,i) and I1I1 is the index of A(i+1,i+1).
!
         ii = 1
         Ap(1) = DBLE(Ap(1))
         DO i = 1 , N - 1
            i1i1 = ii + N - i + 1
!
!           Generate elementary reflector H(i) = I - tau * v * v**H
!           to annihilate A(i+2:n,i)
!
            alpha = Ap(ii+1)
            CALL ZLARFG(N-i,alpha,Ap(ii+2),1,taui)
            E(i) = alpha
!
            IF ( taui/=ZERO ) THEN
!
!              Apply H(i) from both sides to A(i+1:n,i+1:n)
!
               Ap(ii+1) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(i:n-1)
!
               CALL ZHPMV(Uplo,N-i,taui,Ap(i1i1),Ap(ii+1),1,ZERO,Tau(i),&
     &                    1)
!
!              Compute  w := y - 1/2 * tau * (y**H *v) * v
!
               alpha = -HALF*taui*ZDOTC(N-i,Tau(i),1,Ap(ii+1),1)
               CALL ZAXPY(N-i,alpha,Ap(ii+1),1,Tau(i),1)
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w**H - w * v**H
!
               CALL ZHPR2(Uplo,N-i,-ONE,Ap(ii+1),1,Tau(i),1,Ap(i1i1))
!
            ENDIF
            Ap(ii+1) = E(i)
            D(i) = Ap(ii)
            Tau(i) = taui
            ii = i1i1
         ENDDO
         D(N) = Ap(ii)
      ENDIF
!
!
!     End of ZHPTRD
!
      END SUBROUTINE ZHPTRD


c
c
c ===================================================================
      subroutine trlimit(maxmx,meqn,mwaves,mbc,mx,aux,
     &                   wave,s,mthlim)
c ===================================================================
c
c     # Transmission-based limiter for acoustics equations
c     #    See Fogarty and LeVeque paper for a description.
c
c     # Use in place of limiter.f
c
c     # Assumes
c     #    aux(i,1) = sound speed c in i'th cell
c     #    aux(i,2) = impedance Z in i'th cell
c     #    wave(i,*,1) is the left-going wave
c     #      = alf_i^1 [Z_{i-1} ; 1]
c     #    wave(i,*,2) is the right-going wave
c     #      = alf_i^2 [Z_i ; 1]
c     #
c
c     --------------------------------------------------------------------
c
      implicit double precision (a-h,o-z)
      dimension  aux(1-mbc:maxmx+mbc, *)
      dimension    s(1-mbc:maxmx+mbc, mwaves)
      dimension wave(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension mthlim(mwaves)
c
c
c     # transmission-based limiter:
c     # use the fact that second component of wave is strength alpha since
c     # second component of eigenvector is 1.
c
       do 100 i=0,mx+1
c          # 1-wave at this cell and neighbor:
	   alf1i = wave(i,2,1)
	   if (alf1i .ne. 0.d0) then
	      alf1ip = wave(i+1,2,1)
c             # transmitted part of neighboring 1-wave:
	      alf1ipt = (2.d0*aux(i,1)/(aux(i-1,1)+aux(i,1))) * alf1ip
	      wlimitr = philim(alf1i, alf1ipt, mthlim(1))
	      do m=1,meqn
	         wave(i,m,1) = wlimitr * wave(i,m,1)
	         enddo
	      endif

c          # 2-wave at this cell and neighbor:
	   alf2i = wave(i,2,2)
	   if (alf2i .ne. 0.d0) then
	      alf2im = wave(i-1,2,2)
c             # transmitted part of neighboring 2-wave:
  	      alf2imt = (2.d0*aux(i-1,1)/(aux(i-1,1)+aux(i,1))) * alf2im
  	      wlimitr = philim(alf2i, alf2imt, mthlim(2))
	      do m=1,meqn
	         wave(i,m,2) = wlimitr * wave(i,m,2)
	         enddo
	      endif
  100      continue
c
      return
      end