!!
! basic examples of fibonacci calculation
! takes user input to decide on the max calculation loops
! will also stop, if the fibonacci-number has reached infinity
! to calculate more numbers, adjust the data type.
!!
program fibonacci
    implicit none

    ! declaring variables
    integer :: counter
    integer :: maxloops
    real :: fibo_old
    real :: fibo_new
    real :: fibo_temp

    ! output info
    print *, 'Calculating Fibonacci Numbers ..'

    ! read number of loops
    print *, 'Enter the number of iterations:'
    read(*, *) maxloops

    ! assign starting values
    fibo_old = 0
    fibo_new = 1
    counter = 1

    ! calculation loop
    do
        ! calculate fibonacci number
        fibo_temp = fibo_new + fibo_old
        fibo_old = fibo_new
        fibo_new = fibo_temp
        counter = counter + 1
        maxloops = maxloops - 1

        ! output to screen
        print *, "Loop: ", counter
        print *, "Remaining: ", maxloops
        print *, 'Fibonacci number: ', fibo_new

        ! check if we reached infinity and finish useless calculation
        if(fibo_new > huge(fibo_new)) then
            print *, "reached infinity after iteration: ", counter-1
            exit
        end if

        ! non infinity exit condition, if user requested loops are over
        if(maxloops<2) exit
    end do

end program fibonacci


C-----------------------------------------------------------------------
      SUBROUTINE SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
     &                    IP,IS,JN,JS,KW,KG,JB,JE,JC,
     &                    WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTRANFV   PERFORM A VECTOR SPHERICAL TRANSFORM
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM
C           BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS
C           AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID.
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
C           (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
C           THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING,
C           BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER',
C           I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX.
C           TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY;
C           THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED.
C           IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS
C           MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM.
C           THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT
C           THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED
C           OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  GENERIC FFT USED
C                      OPENMP DIRECTIVES INSERTED
C
C USAGE:    CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
C    &                    IP,IS,JN,JS,KW,KG,JB,JE,JC,
C    &                    WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     IDRT     - INTEGER GRID IDENTIFIER
C                (IDRT=4 FOR GAUSSIAN GRID,
C                 IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
C                 IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
C     IMAX     - INTEGER EVEN NUMBER OF LONGITUDES.
C     JMAX     - INTEGER NUMBER OF LATITUDES.
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     IP       - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN
C     IS       - INTEGER SKIP NUMBER BETWEEN LONGITUDES
C     JN       - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH
C     JS       - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH
C     KW       - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS
C     KG       - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
C     JB       - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM
C     JE       - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM
C     JC       - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
C     WAVED    - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0
C     WAVEZ    - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0
C     GRIDUN   - REAL (*) N.H. GRID U-WINDS (STARTING AT JB) IF IDIR<0
C     GRIDUS   - REAL (*) S.H. GRID U-WINDS (STARTING AT JB) IF IDIR<0
C     GRIDVN   - REAL (*) N.H. GRID V-WINDS (STARTING AT JB) IF IDIR<0
C     GRIDVS   - REAL (*) S.H. GRID V-WINDS (STARTING AT JB) IF IDIR<0
C     IDIR     - INTEGER TRANSFORM FLAG
C                (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE)
C   OUTPUT ARGUMENTS:
C     WAVED    - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0
C                [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)]
C     WAVEZ    - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0
C                [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)]
C     GRIDUN   - REAL (*) N.H. GRID U-WINDS (STARTING AT JB) IF IDIR>0
C     GRIDUS   - REAL (*) S.H. GRID U-WINDS (STARTING AT JB) IF IDIR>0
C     GRIDVN   - REAL (*) N.H. GRID V-WINDS (STARTING AT JB) IF IDIR>0
C     GRIDVS   - REAL (*) S.H. GRID V-WINDS (STARTING AT JB) IF IDIR>0
C
C SUBPROGRAMS CALLED:
C   SPTRANF0     SPTRANF SPECTRAL INITIALIZATION
C   SPTRANF1     SPTRANF SPECTRAL TRANSFORM
C   SPDZ2UV      COMPUTE WINDS FROM DIVERGENCE AND VORTICITY
C   SPUV2DZ      COMPUTE DIVERGENCE AND VORTICITY FROM WINDS
C
C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
C   DIMENSION                    LINEAR              QUADRATIC
C   -----------------------      ---------           -------------
C   IMAX                         2*MAXWV+2           3*MAXWV/2*2+2
C   JMAX (IDRT=4,IROMB=0)        1*MAXWV+1           3*MAXWV/2+1
C   JMAX (IDRT=4,IROMB=1)        2*MAXWV+1           5*MAXWV/2+1
C   JMAX (IDRT=0,IROMB=0)        2*MAXWV+3           3*MAXWV/2*2+3
C   JMAX (IDRT=0,IROMB=1)        4*MAXWV+3           5*MAXWV/2*2+3
C   JMAX (IDRT=256,IROMB=0)      2*MAXWV+1           3*MAXWV/2*2+1
C   JMAX (IDRT=256,IROMB=1)      4*MAXWV+1           5*MAXWV/2*2+1
C   -----------------------      ---------           -------------
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*)
      REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
      REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
      REAL(8) AFFT(50000+4*IMAX)
      REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE)
      REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE)
      REAL PLNTOP(MAXWV+1,JB:JE)
      INTEGER MP(2)
      REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2)
      REAL WTOP(2*(MAXWV+1),2)
      REAL G(IMAX,2,2)
      REAL WINC((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SET PARAMETERS
      MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
      MP=1
      CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE,
     &              EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &              AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM WAVE TO GRID
      IF(IDIR.GT.0) THEN
C$OMP PARALLEL DO PRIVATE(KWS,W,WTOP,G,IJKN,IJKS)
        DO K=1,KMAX
          KWS=(K-1)*KW
          CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
     &                 WAVED(KWS+1),WAVEZ(KWS+1),
     &                 W(1,1),W(1,2),WTOP(1,1),WTOP(1,2))
          DO J=JB,JE
            CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
     &                    EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &                    AFFT,CLAT(J),SLAT(J),WLAT(J),
     &                    PLN(1,J),PLNTOP(1,J),MP,
     &                    W(1,1),WTOP(1,1),G(1,1,1),IDIR)
            CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
     &                    EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &                    AFFT,CLAT(J),SLAT(J),WLAT(J),
     &                    PLN(1,J),PLNTOP(1,J),MP,
     &                    W(1,2),WTOP(1,2),G(1,1,2),IDIR)
            IF(IP.EQ.1.AND.IS.EQ.1) THEN
              DO I=1,IMAX
                IJKN=I+(J-JB)*JN+(K-1)*KG
                IJKS=I+(J-JB)*JS+(K-1)*KG
                GRIDUN(IJKN)=G(I,1,1)
                GRIDUS(IJKS)=G(I,2,1)
                GRIDVN(IJKN)=G(I,1,2)
                GRIDVS(IJKS)=G(I,2,2)
              ENDDO
            ELSE
              DO I=1,IMAX
                IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
                IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
                GRIDUN(IJKN)=G(I,1,1)
                GRIDUS(IJKS)=G(I,2,1)
                GRIDVN(IJKN)=G(I,1,2)
                GRIDVS(IJKS)=G(I,2,2)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSFORM GRID TO WAVE
      ELSE
C$OMP PARALLEL DO PRIVATE(KWS,W,WTOP,G,IJKN,IJKS,WINC)
        DO K=1,KMAX
          KWS=(K-1)*KW
          W=0
          WTOP=0
          DO J=JB,JE
            IF(WLAT(J).GT.0.) THEN
              IF(IP.EQ.1.AND.IS.EQ.1) THEN
                DO I=1,IMAX
                  IJKN=I+(J-JB)*JN+(K-1)*KG
                  IJKS=I+(J-JB)*JS+(K-1)*KG
                  G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2
                  G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2
                  G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2
                  G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2
                ENDDO
              ELSE
                DO I=1,IMAX
                  IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1
                  IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1
                  G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2
                  G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2
                  G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2
                  G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2
                ENDDO
              ENDIF
              CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
     &                      EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &                      AFFT,CLAT(J),SLAT(J),WLAT(J),
     &                      PLN(1,J),PLNTOP(1,J),MP,
     &                      W(1,1),WTOP(1,1),G(1,1,1),IDIR)
              CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J,
     &                      EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP,
     &                      AFFT,CLAT(J),SLAT(J),WLAT(J),
     &                      PLN(1,J),PLNTOP(1,J),MP,
     &                      W(1,2),WTOP(1,2),G(1,1,2),IDIR)
            ENDIF
          ENDDO
          CALL SPUV2DZ(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
     &                 W(1,1),W(1,2),WTOP(1,1),WTOP(1,2),
     &                 WINC(1,1),WINC(1,2))
          WAVED(KWS+1:KWS+2*MX)=WAVED(KWS+1:KWS+2*MX)+WINC(1:2*MX,1)
          WAVEZ(KWS+1:KWS+2*MX)=WAVEZ(KWS+1:KWS+2*MX)+WINC(1:2*MX,2)
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


submodule (BandSpectrum_mod) EnergyFluence_smod

    implicit none

    real(RK)                        :: mv_alphaPlusOne
    real(RK)                        :: mv_alphaPlusTwoOverEpk

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Integrate the Band differential spectrum over the input energy range in units of the input energy.
    !>
    !> \param[in]   lowerLim        :   The lower limit energy (in units of [keV]) of the integration.
    !> \param[in]   upperLim        :   The upper limit energy (in units of [keV]) of the integration.
    !> \param[in]   epk             :   The spectral peak energy in units of [keV].
    !> \param[in]   alpha           :   The lower spectral exponent of the Band model.
    !> \param[in]   beta            :   The upper spectral exponent of the Band model.
    !> \param[in]   tolerance       :   The relative accuracy tolerance of the integration.
    !> \param[out]  energyFluence   :   The fluence in units of the input energy (keV) within the input energy range.
    !> \param[out]  Err             :   An object of class [Err_type](@ref err_mod::err_type) containing error-handling information.
    module subroutine getEnergyFluence(lowerLim,upperLim,epk,alpha,beta,tolerance,energyFluence,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: getEnergyFluence
#endif

        use Constants_mod, only: IK, RK, HUGE_RK
        use QuadPackSPR_mod, only: qag
        use Err_mod, only: Err_type
        implicit none
        real(RK), intent(in)            :: lowerLim, upperLim, epk, alpha, beta, tolerance
        real(RK), intent(out)           :: energyFluence
        type(Err_type), intent(out)     :: Err
        character(*), parameter         :: PROCEDURE_NAME = "@getEnergyFluence()"
        real(RK)                        :: ebrk, alphaPlusTwo
        real(RK)                        :: thisUpperLim, betaPlusTwo
        real(RK)                        :: alphaMinusBeta, coef
        real(RK)                        :: abserr
        integer(IK)                     :: neval
        integer(IK)                     :: ierr

        Err%occurred = .false.

        if (lowerLim>=upperLim) then
            energyFluence = 0._RK
            return
        end if

        ! check if the photon indices are consistent with the mathematical rules
        if (alpha<beta .or. alpha<-2._RK) then
            energyFluence = -HUGE_RK
            Err%occurred = .true.
            Err%msg = MODULE_NAME // PROCEDURE_NAME // ": Error occurred: alpha<beta .or. alpha<-2._RK"
            return
        end if

        ! integrate the spectrum
        alphaPlusTwo = alpha + 2._RK
        alphaMinusBeta = alpha - beta
        ebrk = epk*alphaMinusBeta/alphaPlusTwo

        if (lowerLim>ebrk) then

            ! there is only the high energy component in the energyFluence
            betaPlusTwo = beta + 2._RK
            coef = ebrk**alphaMinusBeta * exp(-alphaMinusBeta);
            energyFluence = coef * ( upperLim**betaPlusTwo - lowerLim**betaPlusTwo ) / betaPlusTwo
            return

!#if defined OS_IS_WSL && defined CODECOV_ENABLED
!! LCOV_EXCL_START
!#endif

        elseif (lowerLim<ebrk) then

            mv_alphaPlusTwoOverEpk = alphaPlusTwo / epk
            thisUpperLim = min(upperLim,ebrk)
            mv_alphaPlusOne = alpha + 1._RK
            ! use brute-force integration
            call qag( f             = getBandCompLowEnergy  &
                    , a             = lowerLim              &
                    , b             = thisUpperLim          &
                    , epsabs        = 0._RK                 &
                    , epsrel        = tolerance             &
                    , key           = 1_IK                  &
                    , result        = energyFluence         &
                    , abserr        = abserr                &
                    , neval         = neval                 &
                    , ier           = ierr                  &
                    )

            if (ierr/=0_IK) then
                energyFluence = -HUGE_RK
                Err%occurred = .true.
                Err%stat = ierr
                Err%msg = MODULE_NAME // PROCEDURE_NAME // ": Error occurred at QuadPack routine. Check the error code to identify the root cause."
                return
            end if

            if (upperLim>ebrk) then ! add the remaining part of the energyFluence from the high-energy component
                betaPlusTwo = beta + 2._RK
                alphaMinusBeta = alpha - beta
                coef = ebrk**alphaMinusBeta * exp(-alphaMinusBeta);
                energyFluence = energyFluence + coef * ( upperLim**betaPlusTwo - ebrk**betaPlusTwo ) / betaPlusTwo
                return
            end if

        end if

    end subroutine getEnergyFluence

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure function getBandCompLowEnergy(energy) result(bandCompLow)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: getBandCompLowEnergy
#endif
        implicit none
        real(RK), intent(in)    :: energy
        real(RK)                :: bandCompLow
        bandCompLow = energy**mv_alphaPlusOne * exp(-mv_alphaPlusTwoOverEpk*energy)
    end function getBandCompLowEnergy

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end submodule EnergyFluence_smod ! LCOV_EXCL_LINE


ccccccccccccccccccccccccccccccccccccccccccc
c Interpolate over the kth element of z by by using its 4 valid neighbors.

      subroutine interp_4(k,vnk,x,y,z,ezk)
      implicit none
c Inputs...
      integer k 		!mark to be filled
      integer vnk(4)		!valid neighbors of k
      real*4 x(202),y(202),z(202)
c Output...
      real*4 ezk		!estimated value of z(k)

c Local variables...
      real*4 a(4,4),b(4)
      integer i,ki,ind

c Model the behavior of z in the local image region as a bilinear
c transfomation using its four neighbors as data points.

      do i=1,4
         ki = vnk(i)
         a(i,1) = 1
         a(i,2) = x(ki)
         a(i,3) = y(ki)
         a(i,4) = x(ki)*y(ki)
         b(i) = z(ki)
      enddo

      call simq(a,b,4,ind)
      if (ind.eq.0) then
         ezk = b(1) + b(2)*x(k) + b(3)*y(k)
     &		+ b(4)*x(k)*y(k)
      else
         call prnt(2,1,k,'***simq err at mark.')
         ezk = -999
      endif

      return
      end


PROGRAM CNPE2_HT
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "CNPE2_HT"
 WRITE(*,*) "Dimension  : 2D"
 WRITE(*,*) "Atmosphere :	Homogeneous"
 WRITE(*,*) "Boundary   : Shift Map"
 WRITE(*,*) "Impedance  : Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Read data
 OPEN(UNIT=10,FILE="CNPE2_IN.dat")
 READ(10,*) L          !Domain range
 READ(10,*) F          !Frequency
 READ(10,*) ZS         !Source height
 READ(10,*) ZR         !Target height
 READ(10,*) ZX         !Impedance real part
 READ(10,*) ZY         !Impedance imaginary part
 READ(10,*) ANGLE      !Terrain maximum angle
 READ(10,*) DC         !Atmosphere profile coefficient
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 C0     = 343.0_DP
 LMBDA0 = C0/F
 K0     = 2.0_DP*PI*F/C0
 DZ     = LMBDA0/10
 DR     = LMBDA0/10
 H      = 200*LMBDA0
 HA     = 50*LMBDA0
 N      = FLOOR(H/DZ)
 M      = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS     = MAX(1,FLOOR(ZS/DZ))
 NA     = FLOOR(HA/DZ)
 A      = IM/(2.0_DP*K0*DZ**2)
 KU     = 1
 KL     = 1
 NDIAG  = KU+KL+1
 WIDE_I = 0
 Z      = CMPLX(ZX,ZY,KIND=DPC)
 R      = (Z-1.0_DP)/(Z+1.0_DP)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Absorbing coefficient
 AS = 4.897_DP*(10**(-9))*(F**3) - &
      7.119_DP*(10**(-6))*(F**2) + &
      3.109_DP*(10**(-3))*F + &
      0.113
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 ALLOCATE(C(N),K(N),DK2(N),ALT(N))
 Z0 = 0.5_DP
 DO NZ = 1,N
  ALT(NZ) = NZ*DZ
  C(NZ)   = C0+DC*ALT(NZ)!LOG(1+ALT(NZ)/Z0)
  K(NZ)   = 2.0_DP*PI*F/C(NZ)
  IF (NZ.GT.(N-NA)) THEN
   K(NZ)  = K(NZ)+AS*IM*(NZ-N+NA)**2/(NA**2)
  END IF
  DK2(NZ) = K(NZ)**2-K0**2
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Terrain Boundary condition
 ALLOCATE(LIN(0:M),X(M),NN(M),TERR(M),TERR1(M),TERR2(M),SLOPX(M))
 LIN(0)  = 0
 THETA   = ANGLE*PI/180.0_DP
 X0      = L/2.0_DP
 S       = L/5.0_DP
 H0      = SQRT(EXP(1.0_DP)/2.0_DP)*S*ATAN(THETA)
 DO MX = 1,M
  GHX      = GHILL(H0,X0,S,MX*DR)
  TERR(MX)  = GHX(1)
  TERR1(MX) = GHX(2)
  TERR2(MX) = GHX(3)
  X(MX)     = MX*DR
  LIN(MX)   = LIN(MX-1)+(1+TERR1(MX))*DR
  SLOPX(MX) = ATAN(TERR1(MX))
  NN(MX)    = TERR(MX)/DZ
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field
 ALLOCATE(PHI(N,M+1),PC(N,M),QC(N,M),P(N,M),Q(N,M))
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B  = 3.0_DP
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
              R*(A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Matrix Initialization (Dense Matrices) - T, D and E
 ALLOCATE(T(N,N),D(N,N),E(N,N),I(N,N))
 TAU1    =  4.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 TAU2    = -1.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 SIGMA1  =  4.0_DP*Z/(3.0_DP*Z-2.0_DP*IM*K0*DZ)
 SIGMA2  = -1.0_DP*Z/(3.0_DP*Z-2.0_DP*IM*K0*DZ)
 T(:,:)  = 0.0_DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) =  1.0_DP
  T(NZ,NZ)   = -2.0_DP
  T(NZ,NZ+1) =  1.0_DP
 END DO
 T(1,1)   = -2.0_DP+SIGMA1
 T(1,2)   =  1.0_DP+SIGMA2
 T(N,N-1) =  1.0_DP+TAU2
 T(N,N)   = -2.0_DP+TAU1
 E        = DDIAG(CMPLX(ALT,0.0_DP,KIND=DPC),N)
 D        = (IM/(2.0_DP*K0))*DDIAG(DK2,N)
 I        = EYE(N)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !System - M1 and M2
 ALLOCATE(M1(N,N),M2(N,N),MB2(NDIAG,N),MB1(NDIAG,N))
 C1 = CMPLX(1.0_DP,0.0_DP,KIND=DPC)
 C2 = CMPLX(0.0_DP,0.0_DP,KIND=DPC)
 SELECT CASE (WIDE_I)
  CASE(0)
   BETA1 = DR/2.0_DP
   BETA2 = -DR/2.0_DP
  CASE(1)
   BETA1 = 1.0_DP/(2.0_DP*IM*K0)+DR/2.0_DP
   BETA2 = 1.0_DP/(2.0_DP*IM*K0)-DR/2.0_DP
  CASE DEFAULT
   STOP "[MAIN] : Enter valid wide-angle case"
 END SELECT
 WRITE(*,*) "Wide-angle order : ", WIDE
 M1  = I+A*BETA1*T+BETA1*D
 M2  = I+A*BETA2*T+BETA2*D
 MB1 = D2B(M1,N,KL,KU)
 MB2 = D2B(M2,N,KL,KU)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 ALLOCATE(MB1T(NDIAG,N),MB2T(KL+NDIAG,N),IPIV(N),TEMP(N,1))
 CALL CPU_TIME(TI)
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !-------------------------------
  !Matrix updating
  !-------------------------------
  MB1T                  = MB1
  MB1T(KU+1,:)          = MB1(KU+1,:)-BETA1*IM*K0*TERR2(MX-1)*ALT
  MB2T(KL+1:KL+NDIAG,:) = MB2
  MB2T(KL+KU+1,:)       = MB2(KU+1,:)-BETA2*IM*K0*TERR2(MX-1)*ALT
  !-------------------------------
  !Right hand side multiplication
  !-------------------------------
  CALL ZGBMV('N',N,N,KL,KU,C1,MB1T,KL+KU+1,PHI(:,MX-1),1,C2,TEMP,1)   !Band matrix form
  WRITE(*,*) ".... Right-hand side multiplied"
  !-------------------------------
  !System solving
  !-------------------------------
  CALL ZGBSV(N,KL,KU,1,MB2T,2*KL+KU+1,IPIV,TEMP,N,INFO)               !Band matrix form
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  !-------------------------------
  !Real pressure
  !-------------------------------
  PHI(1:N,MX)  = TEMP(:,1)
  PC(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)/SQRT((MX-1)*DR)
  P(1:N,MX-1)  = REALPART(PC(1:N,MX-1))
  WRITE(*,*)
 END DO
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !A posteriori phase correction
 DO MX = 1,M-1
  QC(1:N,MX) = (PHI(1:N,MX)+MX*A*(PHI(1:N,MX+1)-2.0_DP*PHI(1:N,MX)+PHI(1:N,MX-1)))/SQRT(MX*DR)
  Q(1:N,MX)  = REALPART(QC(1:N,MX))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 ALLOCATE(LP(N,M),LQ(N,M),LPG(M),LQG(M))
 P0 = ABS(PC(NS,1))                  !Reference pressure (real)
 Q0 = ABS(QC(NS,1))                  !Reference corrected pressure (real)
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 10.0_DP*LOG10(ABS(PC(NZ,MX))**2/(P0**2))
   LQ(NZ,MX) = 10.0_DP*LOG10(ABS(QC(NZ,MX))**2/(Q0**2))
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
    LQ(NZ,MX) = -120
  END IF
  END DO
 END DO
 LP0 = LP(NS,1)
 LQ0 = LQ(NS,1)
 LPG = LP(5,1:M)
 LQG = LQ(5,1:M)
 LPR = LP(NR,M)
 LQR = LQ(NR,M)
 PR  = SQRT(2.0_DP)*P0*10**(LPR/20)
 QR  = SQRT(2.0_DP)*Q0*10**(LPR/20)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 OPEN(UNIT=11,FILE="CNPE2_TL.dat")
 OPEN(UNIT=12,FILE="CNPE2_FIELD.dat")
 !OPEN(UNIT=30,FILE="CNPE2_PC.dat")
 !OPEN(UNIT=50,FILE="CNPE2_Topo.dat")
 DO MX = 1,M
  WRITE(11,100) MX*DR, TERR(MX), LPG(MX)
  DO NZ = 1,N
   WRITE(12,100) MX*DR, NZ*DZ+TERR(MX), LP(NZ,MX)
  END DO
  WRITE(12,*)
 END DO
 100 FORMAT(3(3X,F12.6))
 !101 FORMAT(4(3X,F12.6),3X,F12.6,SP,F12.6,SS,"i")
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 DEALLOCATE(PHI,PC,QC,P,Q,LP,LQ)
 CALL SYSTEM('gnuplot -p plot_xterm.plt')
 CALL SYSTEM('gnuplot -p plot_xterm_contour.plt')
 WRITE(*,*) "================================================"
 WRITE(*,*) "Input file  : ", TOPO
 WRITE(*,*) "================================================"
 WRITE(*,*) "Output file : CNPE2_TL.dat"
 WRITE(*,*) "              CNPE2_FIELD.dat"
 WRITE(*,*) "================================================"
 WRITE(*,*)
 WRITE(*,*) "System size (N x M) :", N, M
 WRITE(*,*) "Step size :", DR
 WRITE(*,*) "Main CPU time (s) :", TF-TI
 WRITE(*,*) "Real pressure at the source - P0 (Pa) :", P0
 WRITE(*,*) "Real pressure at the target - PR (Pa) :", PR
 WRITE(*,*) "SPL/TL at the source - LP0 (dB) :", LP0
 WRITE(*,*) "SPL/TL at the target - LPR (dB) :", LPR
 WRITE(*,*)
 !-----------------------------------------------------------
 !----------------------------------------------------------
END PROGRAM CNPE2_HT


!
!  Copyright (c) 2010-2015 Centre National de la Recherche Scientifique.
!  written by Nathanael Schaeffer (CNRS, ISTerre, Grenoble, France).
!
!  nathanael.schaeffer@ujf-grenoble.fr
!
!  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".
!
!  The fact that you are presently reading this means that you have had
!  knowledge of the CeCILL license and that you accept its terms.
!

!! A Fortran example program that performs backward and forward Spherical Harmonic Transforms using SHTns
      PROGRAM SHT_example

      IMPLICIT NONE
! import useful parameters for shtns initialization
      include 'shtns.f'

      integer*4 lmax, mmax, mres
      integer*4 nlat, nphi
      integer*4 nlm
      integer*4 layout
      integer*4 norm
      real*8 eps_polar
      complex*16, allocatable :: Slm(:), Tlm(:)
      real*8, allocatable :: Sh(:,:), Th(:,:)

      integer i,lm, m

! set size of transform
      lmax = 5
      mmax = 2
      mres = 2
      nphi = 6
      nlat = 8

! compute sizes required for arrays.
      call shtns_calc_nlm(nlm, lmax, mmax, mres)
      print*,'NLM=',nlm

! displays information during initialization
      call shtns_verbose(1)

! enable multi-threaded transform (OpenMP) if supported.
      call shtns_use_threads(0)

! init SHT. SHT_PHI_CONTIGUOUS is defined in 'shtns.f'
      layout = SHT_PHI_CONTIGUOUS
      call shtns_init_sh_gauss(layout, lmax, mmax, mres, nlat, nphi)

! alternatively, you can use the two following calls, giving more control on the initialization process,
! namely you can choose a normalization with 'norm' and control the polar optimization
! with 'eps_polar' : from 0 (no optimization) to 1e-6 (agressive optimization).
!      norm = SHT_ORTHONORMAL + SHT_REAL_NORM
!      call shtns_set_size(lmax, mmax, mres, norm)
!      eps_polar = 1.e-10
!      call shtns_precompute(SHT_GAUSS, layout, eps_polar, nlat, nphi)

! display information:
       call shtns_print_cfg()

! allocate memory for spectral and spatial representation
      allocate ( Slm(1:nlm), Tlm(1:nlm) )
      allocate ( Sh(1:nphi,1:nlat), Th(1:nphi,1:nlat) )
      Slm(:) = 0.0

! get index for given l and m
      call shtns_lmidx(lm, 1, 0)
      Slm(lm) = 1.0
      print*
      print*,Slm(:)

      call shtns_sh_to_spat(Slm, Sh)

! print all spatial data
      print*
      do i=1,nphi
        print*,'phi index=',i
        print*,Sh(i,:)
      enddo

      call shtns_spat_to_sh(Sh, Slm)

      print*
      print*,Slm(:)

! print SH data, grouping by m  (shows how to access SH coefficients)
      print*
      do m=0, mres*mmax, mres
        print*,'m=', m
        call shtns_lmidx(lm,m,m)
        print*,Slm(lm : lm+(lmax-m))
      enddo

! Legendre transform (fixed m, no fft):
      m = 1*mres
      call shtns_lmidx(lm, m, m)
      Slm(lm+1) = 1.0
      call shtns_sh_to_spat_ml(m/mres, Slm(lm), Tlm, lmax)
      print*
      print*,'spectral m=', m
      print*,Slm(lm : lm+lmax-m+1)
      print*,'spatial m=', m
      print*,Tlm(1 : nlat)

      stop
      END


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C
C     8 Feb 98    ...rea...  Initial release. Based upon EIGENVEC, the
C                            standalone 'destretch' program, and the ASTER
C                            Decorrelation Stretch Standard Product algorithm
C    21 Mar 00    ...rea...  Add SAVE parameter, analogous to the SAVE parameter
C                            in EIGEN/EIGENVEC
C    14 Jun 00    ...rea...  Add EXCLUDE parameter to exclude pixels that are
C			     zero in all bands.
C    16 Nov 00    ...rea...  Add QA plane processing.
C
	REAL*8 SUMX(32),SUMXY(1024)
	REAL DATA(200000),EVEC(32,32),EVAL(32),OFFSET(32)
	REAL DSCALE(32),CHAN_MEAN(32),CHAN_SIGMA(32),OMATRIX(32,32)
	REAL BUF(1024)
	INTEGER INUNIT(32),IOUTUNIT(32),NBAND(32),ISUBAREA(200)
	LOGICAL XVPTST,CORR,Q3D,Q3DOUT,QSAVE,QEXCL
	CHARACTER*132 PR
	CHARACTER*60 SAVE
C
	DATA DSCALE/32*1.0/
C								open inputs
	CALL XVPCNT('INP',NI)
	DO I=1,NI
	    CALL XVUNIT(INUNIT(I),'INP',I,ISTATUS,' ')
	    CALL XVOPEN(INUNIT(I),ISTATUS,'OPEN_ACT','SA',
     +			'IO_ACT','SA','U_FORMAT','REAL',' ')
	END DO
	IF (NI .EQ. 1) THEN
	    Q3D = .TRUE.
	    CALL XVBANDS(ISB,NB,NBIN)
	    CALL XVPARM('BANDS',NBAND,NI,IDEF,32)
	    IF (NI .EQ. 0) THEN
		NI = MIN(NB,32)
		DO I=1,NI
		    NBAND(I) = I
		END DO
	    ELSE
		DO I=1,NI
		    IF (NBAND(I).GT.NBIN .OR. NBAND(I).LE.0) THEN
			CALL XVMESSAGE('Invalid BAND parameter',' ')
			CALL ABEND
		    ENDIF
		END DO
	    END IF
	ELSE
	    Q3D = .FALSE.
	END IF
C								QA
	CALL XVPARM('QA',IQA,ICNT,IDEF,0)
	IF (.NOT.Q3D .AND. IQA.NE.0) THEN
	    IQA = NI
	    NI = NI-1
	END IF
C							        get parameters
	CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
C								inc
	CALL XVPARM('INC',INC,ICNT,IDEF,0)
C								area
	CALL XVPARM('AREA',ISUBAREA,N_AREA_PARS,IDEF,0)
	IF (N_AREA_PARS.EQ.0) THEN
	    ISUBAREA(1) = ISL
	    ISUBAREA(2) = ISS
	    ISUBAREA(3) = NL
            ISUBAREA(4) = NS
	    N_AREA_PARS = 4
	END IF
C								covariance
C								exclude, mean
C								sigma, dscale
	CORR = .NOT. XVPTST('COV')
	QEXCL = XVPTST('EXCLUDE')
	CALL XVPARM('MEAN',XMEAN,ICNT,IDEF,0)
	CALL XVPARM('SIGMA',SIGMA,ICNT,IDEF,0)
	CALL XVPARM('DSCALE',DSCALE,ICNT,IDEF,0)
C								save
	CALL XVPCNT('SAVE',NUM)
	IF (NUM .GT. 0) THEN
	    QSAVE = .TRUE.
	    CALL XVPARM('SAVE',SAVE,ICNT,IDEF,0)
	ELSE
	    QSAVE = .FALSE.
	END IF
C								open outputs
	CALL XVPCNT('OUT',NO)
	IF (NO .EQ. 1) THEN
	    CALL XVUNIT(IOUTUNIT(1),'OUT',1,ISTATUS,' ')
	    CALL XVOPEN(IOUTUNIT(1),ISTATUS,'U_NL',NL,'U_NS',NS,
     +			'U_NB',NI,'OPEN_ACT','SA','IO_ACT','SA',
     +			'U_FORMAT','BYTE','O_FORMAT','BYTE',
     +			'U_ORG','BIL','OP','WRITE',' ')
	    Q3DOUT = .TRUE.
	ELSE
	    IF (NI .NE. NO) THEN
		CALL XVMESSAGE(
     +	'Number of input bands does not match the number of outputs',' ')
		CALL ABEND
	    ENDIF
	    DO I=1,NO
		CALL XVUNIT(IOUTUNIT(I),'OUT',I,ISTATUS,' ')
		CALL XVOPEN(IOUTUNIT(I),ISTATUS,'U_NL',NL,'U_NS',NS,
     +			    'U_NB',1,'OPEN_ACT','SA','IO_ACT','SA',
     +			    'U_FORMAT','BYTE','O_FORMAT','BYTE',
     +			    'OP','WRITE',' ')
	    END DO
	    Q3DOUT = .FALSE.
	END IF
C							       gather statistics
	CALL ZIA(SUMX,2*NI)
	CALL ZIA(SUMXY,2*NI*NI)
	NPIX = 0
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(' Area(s) sampled for statistics:',' ')
	DO I=1,N_AREA_PARS,4
	    WRITE (PR,100) ISUBAREA(I),ISUBAREA(I+1),ISUBAREA(I+2),
     +			   ISUBAREA(I+3)
  100	    FORMAT(2X,4I6)
	    CALL XVMESSAGE(PR,' ')
	    IF (QEXCL .OR. IQA.NE.0) THEN
		CALL Z_GATHER_STATS(INUNIT,NI,IQA,QEXCL,Q3D,NBAND,
     +				ISUBAREA(I),ISUBAREA(I+1),ISUBAREA(I+2),
     +				ISUBAREA(I+3),INC,DATA,NPIX,SUMX,SUMXY)
	    ELSE
		CALL GATHER_STATS(INUNIT,NI,Q3D,NBAND,ISUBAREA(I),
     +			     ISUBAREA(I+1),ISUBAREA(I+2),ISUBAREA(I+3),
     +			     INC,DATA,NPIX,SUMX,SUMXY)
	    END IF
	END DO
C								report INC, NPIX
C
	WRITE (PR,200) INC
  200	FORMAT('      INC =',I3)
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(PR,' ')
	WRITE (PR,250) NPIX
  250	FORMAT('      PIXELS USED =',I10)
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(PR,' ')
C					       compute means and cov/corr matrix
	CALL COMPUTE_STATS(NI,NPIX,SUMX,SUMXY,CORR,CHAN_MEAN,
     +			   CHAN_SIGMA,OMATRIX)
C						compute principal component
C						eigenvalues and eigenvectors
	CALL JACOBI(OMATRIX,NI,EVAL,EVEC)
C						sort eigenvalues
	I = 1
	J = 2
	DO WHILE (J .LE. NI)
	    IF (EVAL(J) .GT. EVAL(I)) CALL SWAP(NI,EVEC(1,I),EVEC(1,J),
     +						EVAL(I),EVAL(J))
	    J = J + 1
	    IF (J. GT. NI) THEN
		I = I+1
		J = I+1
	    END IF
	END DO
C						print eigenvalues and vectors
	CALL XVMESSAGE('   Eigen',' ')
	CALL XVMESSAGE('   Value             Eigenvector',' ')
	DO I=1,NI
	    K = 1
	    K2 = MIN(NI,10)
	    WRITE (PR,300) EVAL(I),(EVEC(J,I),J=K,K+K2-1)
  300	    FORMAT(F11.4,10F12.5)
	    CALL XVMESSAGE(PR,' ')
	    K = K + K2
	    DO M=11,NI,10
		K3 = MIN(NI-M+1,10)
		WRITE (PR,400) (EVEC(J,I),J=K,K+K3-1)
  400		FORMAT(11X,10F12.5)
		CALL XVMESSAGE(PR,' ')
		K = K + K3
	    END DO
	END DO
C						Compute and report the final
C						transformation matrix.
C
	CALL COMPUTE_TRANSFORM(NI,EVAL,EVEC,CHAN_MEAN,CHAN_SIGMA,CORR,
     +			     DSCALE,XMEAN,SIGMA,OMATRIX,OFFSET)
	CALL XVMESSAGE(' ',' ')
	DO I=1,NI
	    NJ = MIN(NI,8)
	    WRITE (PR,500) I,OFFSET(I),(OMATRIX(J,I),J,J=1,NJ)
  500	    FORMAT(' Output',I2,' = ',F12.4,8(SP,F9.4,'*in',SS,I1))
	    CALL XVMESSAGE(PR,' ')
	    DO I2=9,NI,8
		NJ = MIN(NI,I2+7)
		WRITE (PR,600) (OMATRIX(J,I),J,J=I2,NJ)
  600		FORMAT(24X,8(SP,F8.4,'*in',SS,I2))
		CALL XVMESSAGE(PR,' ')
	    END DO
	END DO
C						Save the transformation matrix,
C						if requested
	IF (QSAVE) THEN
	    NUM = 0
	    DO I=1,NI
		DO J=1,NI
		    NUM = NUM + 1
		    BUF(NUM) = OMATRIX(J,I)
		END DO
	    END DO
	    CALL XVPOPEN(ISTATUS,IDUMMY1,IDUMMY2,SAVE,'SA',IDUMMY3)
	    CALL XVPOUT(ISTATUS,'MATRIX',BUF,'REAL',NUM)
	    DO I=1,NI
		BUF(I) = 1.0
	    END DO
	    CALL XVPOUT(ISTATUS,'GAIN',BUF,'REAL',NI)
	    CALL XVPOUT(ISTATUS,'OFFSET',OFFSET,'REAL',NI)
	    CALL XVPCLOSE(ISTATUS)
	END IF
C						Perform the transformation and
C						write output
C
	CALL DO_TRANSFORM(INUNIT,IOUTUNIT,NBAND,IQA,ISL,ISS,NL,NS,NI,
     +			  Q3D,Q3DOUT,OMATRIX,OFFSET,DATA)
C
      RETURN
      END
C*******************************************************************************
	SUBROUTINE Z_GATHER_STATS(INUNIT,NI,IQA,QEXCL,Q3D,NBAND,ISL,ISS,
     +				  NL,NS,INC,DATA,NPIX,SUMX,SUMXY)
C
C	This routine is used only if pixels are to be excluded.
C
C	This routine accumulates the sums needed to compute the necessary
C	statistics. In each call, it passes through one area, as defined
C	by the area parameter.
C
	REAL*8 SUMX(NI),SUMXY(NI,NI)
	REAL DATA(NS,NI),XQA(10000)
	INTEGER INUNIT(NI),NBAND(NI)
	LOGICAL QZERO,QEXCL,Q3D
C								initialize QA
	DO I=1,NS
	    XQA(I) = 0.0
	END DO
C
	IEL = ISL + NL - 1
	DO LINE=ISL,IEL,INC
C								read in data
	    IF (Q3D) THEN
		DO IBAND=1,NI
		    CALL XVREAD(INUNIT(1),DATA(1,IBAND),ISTAT,
     +				'BAND',NBAND(IBAND),'LINE',LINE,
     +				'SAMP',ISS,'NSAMPS',NS,' ')
		END DO
		IF (IQA .NE. 0) CALL XVREAD(INUNIT(1),XQA,ISTAT,
     +					    'BAND',IQA,'LINE',LINE,
     +					    'SAMP',ISS,'NSAMPS',NS,' ')
	    ELSE
		DO IBAND=1,NI
		    CALL XVREAD(INUNIT(IBAND),DATA(1,IBAND),ISTAT,
     +		 		'LINE',LINE,'SAMP',ISS,'NSAMPS',NS,' ')
		END DO
		IF (IQA .GT. 0) CALL XVREAD(INUNIT(IQA),XQA,ISTAT,
     +			 		    'LINE',LINE,'SAMP',ISS,
     +					    'NSAMPS',NS,' ')
	    END IF
C								update sums
	    DO ISAMP = 1,NS,INC
		IF (XQA(ISAMP) .LE. 15.0) THEN
		    QZERO = .TRUE.
		    DO IBAND = 1,NI
			DO JBAND = 1,IBAND
			    SUMXY(JBAND,IBAND) = SUMXY(JBAND,IBAND) +
     +				     DATA(ISAMP,JBAND)*DATA(ISAMP,IBAND)
			END DO
			SUMX(IBAND) = SUMX(IBAND) + DATA(ISAMP,IBAND)
			IF (DATA(ISAMP,IBAND) .NE. 0.0) QZERO = .FALSE.
		    END DO
		    IF (.NOT.QZERO .OR. .NOT.QEXCL) NPIX = NPIX + 1
		END IF
	    END DO
	END DO
C
	RETURN
	END
C*******************************************************************************
	SUBROUTINE GATHER_STATS(INUNIT,NI,Q3D,NBAND,ISL,ISS,NL,NS,INC,
     +                          DATA,NPIX,SUMX,SUMXY)
C
C	This routine accumulates the sums needed to compute the necessary
C	statistics. In each call, it passes through one area, as defined
C	by the area parameter.
C
	REAL*8 SUMX(NI),SUMXY(NI,NI)
	REAL DATA(NS,NI)
	INTEGER INUNIT(NI),NBAND(NI)
	LOGICAL Q3D
C
	IEL = ISL + NL - 1
	DO LINE=ISL,IEL,INC
C								read in data
	    IF (Q3D) THEN
		DO IBAND=1,NI
		    CALL XVREAD(INUNIT(1),DATA(1,IBAND),ISTAT,
     +				'BAND',NBAND(IBAND),'LINE',LINE,
     +				'SAMP',ISS,'NSAMPS',NS,' ')
		END DO
	    ELSE
		DO IBAND=1,NI
		    CALL XVREAD(INUNIT(IBAND),DATA(1,IBAND),ISTAT,
     +		 		'LINE',LINE,'SAMP',ISS,'NSAMPS',NS,' ')
		END DO
	    END IF
C								update sums
	    DO ISAMP = 1,NS,INC
		DO IBAND = 1,NI
		    DO JBAND = 1,IBAND
			SUMXY(JBAND,IBAND) = SUMXY(JBAND,IBAND) +
     +				     DATA(ISAMP,JBAND)*DATA(ISAMP,IBAND)
		    END DO
		    SUMX(IBAND) = SUMX(IBAND) + DATA(ISAMP,IBAND)
		END DO
		NPIX = NPIX + 1
	    END DO
	END DO
C
	RETURN
	END
C*******************************************************************************
	SUBROUTINE COMPUTE_STATS(NI,NPIX,SUMX,SUMXY,CORR,CHAN_MEAN,
     +				 CHAN_SIGMA,OMATRIX)
C
	REAL*8 SUMX(NI),SUMXY(NI,NI)
	REAL CHAN_MEAN(NI),CHAN_SIGMA(NI),OMATRIX(32,32)
	LOGICAL CORR
	CHARACTER*132 PRT
C
	NPIX_1 = NPIX-1
C
	DO I=1,NI
C								compute means
	    CHAN_MEAN(I) = SUMX(I)/NPIX
C							     compute covariances
	    DO J=1,I
		OMATRIX(J,I)=(SUMXY(J,I)-CHAN_MEAN(J)*CHAN_MEAN(I)*NPIX)
     +			     / NPIX_1
		OMATRIX(I,J) = OMATRIX(J,I)
	    END DO
C							compute std deviations
	    IF (OMATRIX(I,I) .GT. 0.0) THEN
		CHAN_SIGMA(I) = SQRT(OMATRIX(I,I))
	    ELSE
		CHAN_SIGMA(I) = 0.0
	    END IF
	END DO
C					       report means, sigmas, covariances
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE('   Channel          Mean     Std. Dev.',' ')
	DO I=1,NI
	    WRITE (PRT,100) I,CHAN_MEAN(I),CHAN_SIGMA(I)
  100	    FORMAT(I10,F14.5,F14.5)
	    CALL XVMESSAGE(PRT,' ')
	END DO
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE('Covariance Matrix:',' ')
	DO I=1,NI
	    DO J=1,I,10
		J1 = MIN(I, J+9)
		WRITE (PRT,200) (OMATRIX(K,I),K=J,J1)
  200		FORMAT(X,10F13.4)
		CALL XVMESSAGE(PRT,' ')
	    END DO
	END DO
	CALL XVMESSAGE(' ',' ')
C						if requested, compute and report
C						the correlation matrix
	IF (CORR) THEN
	    DO I=1,NI
		DO J=1,I
		    IF (CHAN_SIGMA(I)*CHAN_SIGMA(J) .NE. 0.0) THEN
			OMATRIX(J,I) = OMATRIX(J,I) /
     +				       (CHAN_SIGMA(I)*CHAN_SIGMA(J))
			OMATRIX(I,J) = OMATRIX(J,I)
		    ELSE
			OMATRIX(J,I) = 0.0
			OMATRIX(I,J) = 0.0
		    END IF
		END DO
	    END DO
	    CALL XVMESSAGE('Correlation Matrix:',' ')
	    DO I=1,NI
		DO J=1,I,10
		    J1 = MIN(I, J+9)
		    WRITE (PRT,200) (OMATRIX(K,I),K=J,J1)
		    CALL XVMESSAGE(PRT,' ')
		END DO
	    END DO
	    CALL XVMESSAGE(' ',' ')
	END IF
C
	RETURN
	END
C****************************************************************************
	SUBROUTINE SWAP(NI,VEC1,VEC2,X1,X2)
C
C	This routine swaps vectors VEC1 and VEC2, and swaps scalars X1 and X2
C
	REAL*4 VEC1(NI),VEC2(NI)
C
	X = X1
	X1 = X2
	X2 = X
C
	DO I=1,NI
	    X = VEC1(I)
	    VEC1(I) = VEC2(I)
	    VEC2(I) = X
	END DO
	RETURN
	END
C*******************************************************************************
	SUBROUTINE COMPUTE_TRANSFORM(NI,EVAL,EVEC,CHAN_MEAN,CHAN_SIGMA,
     +				     CORR,DSCALE,XMEAN,SIGMA,
     +				     OMATRIX,OFFSET)
C
C	This routine computes the overall transformation needed to produce
C	a decorrelation stretched image. The matrix transformation is stored
C	array OMATRIX, and the necessary offsets to keep the results in the
C	0-255 range are stored in the array OFFSET.
C
C	NI	       - (input) integer number of input channels used
C	EVAL(NI)       - (input) real array of eigenvalues
C	EVEC(32,32)    - (input) real matrix of eigenvectors (rotation matrix)
C	CHAN_MEAN(NI)  - (input) real array of the means of the input images
C	CHAN_SIGMA(NI) - (input) real array of the standard deviations of the
C				      input images
C	CORR           - (input) logical flag;
C				      TRUE => correlation matrix was used
C	DSCALE(NI)     - (input) real array of scaling factors to adjust the
C				      weights of each principal component.
C				      Default is for all values = 1.0
C	XMEAN          - (input) real target mean for each output channel.
C       SIGMA          - (input) real target standard deviation for each
C				      output channel.
C	OMATRIX(32,32) - (output)real transformation matrix needed to produce
C				      the output images from the inputs
C	OFFSET(NI)     - (output)real array of offsets applied to pixels after
C				      the transformation matrix, to center
C				      output values in 0-255 range.
C
	REAL EVEC(32,32),OMATRIX(32,32)
	REAL EVAL(NI),CHAN_MEAN(NI),CHAN_SIGMA(NI),DSCALE(NI),OFFSET(NI)
	REAL GAIN(32),GAININ(32)
	LOGICAL CORR
C
	DO I=1,NI
C				GAIN(I) is the vector that will be multiplied
C				with the rotation matrix.
C				If an eigenvalue (EVAL) is 0.0, there is no
C				appropriate value for GAIN. EVAL cannot
C				correctly be less than 0.0
C
	    IF (EVAL(I) .GT. 0.0) THEN
		GAIN(I) = DSCALE(I)*SIGMA/SQRT(EVAL(I))
	    ELSE
		GAIN(I) = 1.0
	    END IF
C				When using the correlation matrix eigenfunctions
C				the input data must first be variance
C				normalized. The GAININ values effectively makes
C				this adjustment.
C
	    IF (CORR .AND. CHAN_SIGMA(I).NE.0.0) THEN
		GAININ(I) = 1.0/CHAN_SIGMA(I)
	    ELSE
		GAININ(I) = 1.0
	    END IF
	END DO
C				This loop generates the output matrix, which is
C				formed by the product of the rotation matrix
C				(EVEC), the vector of variance normalizing
C				values (GAIN), and the back rotation matrix
C				(the transpose of EVEC).
C				X is an accumulator for computing each output
C				     matrix element.
C				Y is used to compute the output location of the
C				     central input point. The OFFSET array is
C				     computed from Y, to force the output to be
C				     centered in the byte data range of 0-255.
	DO I=1,NI
	    Y = 0.0
	    DO J=1,NI
		X = 0.0
		DO K=1,NI
		    X = X + GAIN(K)*EVEC(I,K)*EVEC(J,K)
		END DO
		OMATRIX(J,I) = X * GAININ(J)
		Y = Y + OMATRIX(J,I)*CHAN_MEAN(J)
	    END DO
	    OFFSET(I) = XMEAN - Y
	END DO
C
	RETURN
	END
C*******************************************************************************
	SUBROUTINE DO_TRANSFORM(INUNIT,IOUTUNIT,NBAND,IQA,ISL,ISS,NL,NS,
     +				NI,Q3D,Q3DOUT,OMATRIX,OFFSET,DATA)
C
C	This routine performs the decorrelation stretch transformation
C	and produces the output file(s).
C
C	INUNIT   - input,integer array  Unit numbers of inputs
C	IOUTUNIT - input,integer array  Unit numbers of outputs
C	NBAND    - input,integer array  For 3D input, bands to be used
C	IQA      - input,integer        QA mask flag
C	ISL      - input,integer        Starting line of image
C	ISS      - input,integer        Starting sample of image
C	NL       - input,integer        Number of lines to process
C	NS       - input,integer        Number of samples to process
C	NI       - input,integer        Number of input (and output) bands
C	Q3D      - input,logical        Flag for 3-D input
C	Q3DOUT   - input,logical        Flag for 3-D output
C	OMATRIX  - input,real array     Transformation matrix
C       OFFSET   - input,real array     Offset to be applied after
C				        transformation matrix
C	DATA     - buffer,real array    Storage buffer for input data
C
	REAL OMATRIX(32,32),OFFSET(NI),DATA(NS,NI),XQA(10000)
	INTEGER INUNIT(NI),IOUTUNIT(NI),NBAND(NI)
	LOGICAL Q3D,Q3DOUT
	BYTE OUT(30000)
C								initialize QA
	DO I=1,NS
	    XQA(I) = 0.0
	END DO
C
	IEL = ISL + NL - 1
	DO LINE=ISL,IEL
C								read in data
	    IF (Q3D) THEN
		DO IBAND=1,NI
		    CALL XVREAD(INUNIT(1),DATA(1,IBAND),ISTAT,
     +				'BAND',NBAND(IBAND),'LINE',LINE,
     +				'SAMP',ISS,'NSAMPS',NS,' ')
		END DO
		IF (IQA .GT. 0) CALL XVREAD(INUNIT(1),XQA,ISTAT,
     +					    'BAND',IQA,'LINE',LINE,
     +					    'SAMP',ISS,'NSAMPS',NS,' ')
	    ELSE
		DO IBAND=1,NI
		    CALL XVREAD(INUNIT(IBAND),DATA(1,IBAND),ISTAT,
     +		 		'LINE',LINE,'SAMP',ISS,'NSAMPS',NS,' ')
		END DO
		IF (IQA .GT. 0) CALL XVREAD(INUNIT(IQA),XQA,ISTAT,
     +			 		    'LINE',LINE,'SAMP',ISS,
     +					    'NSAMPS',NS,' ')
	    END IF
C								do transform
	    DO IBAND=1,NI
		DO ISAMP = 1,NS
		    IF (XQA(ISAMP) .NE. 144.0) THEN
			X = 0.0
			DO I = 1,NI
			    X = X + OMATRIX(I,IBAND)*DATA(ISAMP,I)
			END DO
			X = X + OFFSET(IBAND)
C						force the output to be within
C						the byte data range and unsigned
			N = NINT(MIN(MAX(X,0.0),255.0))
			IF (N.GE.128) N=N-256
			OUT(ISAMP) = N
		    ELSE
			OUT(ISAMP) = 0
		    END IF
		END DO
		IF (Q3DOUT) THEN
		    CALL XVWRIT(IOUTUNIT(1),OUT,ISTAT,' ')
		ELSE
		    CALL XVWRIT(IOUTUNIT(IBAND),OUT,ISTAT,' ')
		END IF
	    END DO
	END DO
C
	RETURN
	END
C*******************************************************************************
	SUBROUTINE JACOBI(OMATRIX,NI,EVAL,EVEC)
C
	REAL OMATRIX(32,32),EVAL(32),EVEC(32,32),B(32),Z(32)
	CHARACTER*80 PRT
C								initialize
	SUM = 0.0
	DO ICOL=1,NI
	    DO IROW=1,NI
		IF (IROW .EQ. ICOL) THEN
		    EVEC(ICOL,IROW) = 1.0
		    EVAL(ICOL) = OMATRIX(ICOL,ICOL)
		    B(ICOL) = EVAL(ICOL)
		    Z(ICOL) = 0.0
		ELSE
		    EVEC(ICOL,IROW) = 0.0
		    SUM = SUM + ABS(OMATRIX(ICOL,IROW))/2.0
		END IF
	    END DO
	END DO
	LOOP = 1
C								main loop
	DO WHILE (LOOP.LE.50 .AND. SUM .GT. 0.0)
C
	    IF (LOOP .LT. 4) THEN
		THRESH = 0.2*SUM/NI*NI
	    ELSE
		THRESH = 0.0
	    END IF
C
	    DO IP=1,NI-1
		DO IQ=IP+1,NI
C							if the magnitude of the
C							eigenvalues is as large
C							as THRESH2, there is no
C							benefit to rotation.
C						       (within machine accuracy)
		    THRESH2 = 1.0E10 * ABS(OMATRIX(IP,IQ))
		    IF ((LOOP .GT. 4) .AND.
     +			(ABS(EVAL(IP)) .GE. THRESH2) .AND.
     +			(ABS(EVAL(IQ)) .GE. THRESH2)) THEN
			OMATRIX(IP,IQ) = 0.0
		    ELSE IF (ABS(OMATRIX(IP,IQ)) .GT. THRESH) THEN
			DIF = EVAL(IQ) - EVAL(IP)
			IF (ABS(DIF) .GE. THRESH2) THEN
			    TAN = OMATRIX(IP,IQ) / DIF
			ELSE
			    THETA = 0.5*DIF/OMATRIX(IP,IQ)
			    TAN = 1.0 / (ABS(THETA)+SQRT(1.0+THETA*THETA))
			    IF (THETA .LT. 0.0) TAN = -TAN
			END IF
			COS = 1.0 / SQRT(1.0 + TAN*TAN)
			SIN = TAN*COS
			TAU = SIN / (1.0 + COS)
			H = TAN*OMATRIX(IP,IQ)
			Z(IP) = Z(IP) - H
			Z(IQ) = Z(IQ) + H
			EVAL(IP) = EVAL(IP) - H
			EVAL(IQ) = EVAL(IQ) + H
			OMATRIX(IP,IQ) = 0.0
			DO J=1,IP-1
			    G = OMATRIX(J,IP)
			    H = OMATRIX(J,IQ)
			    OMATRIX(J,IP) = G - SIN*(H+G*TAU)
			    OMATRIX(J,IQ) = H + SIN*(G-H*TAU)
			END DO
			DO J=IP+1,IQ-1
			    G = OMATRIX(IP,J)
			    H = OMATRIX(J,IQ)
			    OMATRIX(IP,J) = G - SIN*(H+G*TAU)
			    OMATRIX(J,IQ) = H + SIN*(G-H*TAU)
			END DO
			DO J=IQ+1,NI
			    G = OMATRIX(IP,J)
			    H = OMATRIX(IQ,J)
			    OMATRIX(IP,J) = G - SIN*(H+G*TAU)
			    OMATRIX(IQ,J) = H + SIN*(G-H*TAU)
			END DO
			DO J=1,NI
			    G = EVEC(J,IP)
			    H = EVEC(J,IQ)
			    EVEC(J,IP) = G - SIN*(H+G*TAU)
			    EVEC(J,IQ) = H + SIN*(G-H*TAU)
			END DO
		    END IF
		END DO
	    END DO
	    SUM = 0.0
	    DO IROW = 1,NI
		B(IROW) = B(IROW) + Z(IROW)
		EVAL(IROW) = B(IROW)
		Z(IROW) = 0.0
		DO ICOL = 1,IROW-1
		    SUM = SUM + ABS(OMATRIX(ICOL,IROW))
		END DO
	    END DO
	    LOOP = LOOP + 1
	END DO
	WRITE (PRT,100) LOOP
  100	FORMAT('Jacobi Routine needed',I3,' iterations')
	CALL XVMESSAGE(PRT,' ')
	RETURN
	END


      SUBROUTINE cholsl(a,n,np,p,b,x)
      INTEGER n,np
      REAL a(np,np),b(n),p(n),x(n)
      INTEGER i,k
      REAL sum
      do 12 i=1,n
        sum=b(i)
        do 11 k=i-1,1,-1
          sum=sum-a(i,k)*x(k)
11      continue
        x(i)=sum/p(i)
12    continue
      do 14 i=n,1,-1
        sum=x(i)
        do 13 k=i+1,n
          sum=sum-a(k,i)*x(k)
13      continue
        x(i)=sum/p(i)
14    continue
      return
      END

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


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine hpsi(ik)
  use global_variables
  implicit none
  integer :: ix,ik

  zhtpsi(1)=-0.5d0*( &
    &+L_coef(0)*ztpsi(1) &
    &+L_coef(1)*(ztpsi(2)+ztpsi(Nx)) &
    &+L_coef(2)*(ztpsi(3)+ztpsi(Nx-1))) &
    &-zI*(Kx(ik)+Acx)*( &
    &+G_coef(1)*(ztpsi(2)-ztpsi(Nx)) &
    &+G_coef(2)*(ztpsi(3)-ztpsi(Nx-1)))
  zhtpsi(2)=-0.5d0*( &
    &+L_coef(0)*ztpsi(2) &
    &+L_coef(1)*(ztpsi(3)+ztpsi(1)) &
    &+L_coef(2)*(ztpsi(4)+ztpsi(Nx))) &
    &-zI*(Kx(ik)+Acx)*( &
    &+G_coef(1)*(ztpsi(3)-ztpsi(1)) &
    &+G_coef(2)*(ztpsi(4)-ztpsi(Nx)))

  do ix=3,Nx-2
    zhtpsi(ix)=-0.5d0*( &
      &+L_coef(0)*ztpsi(ix) &
      &+L_coef(1)*(ztpsi(ix+1)+ztpsi(ix-1)) &
      &+L_coef(2)*(ztpsi(ix+2)+ztpsi(ix-2))) &
      &-zI*(Kx(ik)+Acx)*( &
      &+G_coef(1)*(ztpsi(ix+1)-ztpsi(ix-1)) &
      &+G_coef(2)*(ztpsi(ix+2)-ztpsi(ix-2)))
  end do

  zhtpsi(Nx-1)=-0.5d0*( &
    &+L_coef(0)*ztpsi(Nx-1) &
    &+L_coef(1)*(ztpsi(Nx)+ztpsi(Nx-2)) &
    &+L_coef(2)*(ztpsi(1)+ztpsi(Nx-3))) &
    &-zI*(Kx(ik)+Acx)*( &
    &+G_coef(1)*(ztpsi(Nx)-ztpsi(Nx-2)) &
    &+G_coef(2)*(ztpsi(1)-ztpsi(Nx-3)))
  zhtpsi(Nx)=-0.5d0*( &
    &+L_coef(0)*ztpsi(Nx) &
    &+L_coef(1)*(ztpsi(1)+ztpsi(Nx-1)) &
    &+L_coef(2)*(ztpsi(2)+ztpsi(Nx-2))) &
    &-zI*(Kx(ik)+Acx)*( &
    &+G_coef(1)*(ztpsi(1)-ztpsi(Nx-1)) &
    &+G_coef(2)*(ztpsi(2)-ztpsi(Nx-2)))

  zhtpsi(:)=zhtpsi(:)+(0.5d0*(kx(ik)+Acx)**2+Veff(:))*ztpsi(:)

  return
end subroutine hpsi
!-------10--------20--------30--------40--------50--------60--------70--------80--------90


!-----------------------------------------------------------------------------
!
! Compute sigma^2(R) from the linear matter power spectrum, and
! fit it by Chebyshev polynomials (single precision). EJ
!elise@fnal.gov
!-----------------------------------------------------------------------------
MODULE sigma
  INTEGER :: ndim=30
  DOUBLE PRECISION    :: c(30),cder(30)
  REAL    :: lnR1=-5.684 ! 0.0034Mpc/h, 1.8e4  solar mass
  REAL    :: lnR2=4.     ! 54.9Mpc/h, 7.5e16 solar mass
  DOUBLE PRECISION :: r
contains
  SUBROUTINE compute_sigma2
    DOUBLE PRECISION :: lnsigma2
    EXTERNAL lnsigma2
    CALL chebyshev_coefficients ( DBLE(lnR1), DBLE(lnR2), ndim, lnsigma2, c )
    CALL  dfrnt ( c, ndim, cder,DBLE(lnR1), DBLE(lnR2) ) !Modified Nov 2014 EJ
    return
  END SUBROUTINE compute_sigma2
END MODULE sigma
!--------------------------------------------
DOUBLE PRECISION FUNCTION lnsigma2(lnR)
  USE sigma
  IMPLICIT none
  DOUBLE PRECISION :: lnR
  REAL :: sigma2
  REAL :: wrap_ds2dk
  EXTERNAL wrap_ds2dk
  real abserr
  real, parameter :: epsabs = 0.0E+00
  real, parameter :: epsrel = 0.001E+00
  integer, parameter :: key = 1
  integer n,ier
  integer neval
  r = DBLE(exp(lnR))
  call qag(wrap_ds2dk,REAL(dlog(1d-4)),REAL(dlog(2d1/r)), epsabs, epsrel, key, sigma2, abserr, neval, ier )
  lnsigma2 = DBLE(alog(sigma2))
  return
  END FUNCTION lnsigma2
!--------------------------------------------
!wrapper function as qag only works on REAL functions of one variable. EJ
REAL FUNCTION wrap_ds2dk(lnk)
  USE sigma
  DOUBLE PRECISION :: ds2dk
  REAL :: lnk
  EXTERNAL ds2dk
  wrap_ds2dk = REAL(ds2dk(DBLE(lnk),r))
  return
END FUNCTION wrap_ds2dk
DOUBLE PRECISION FUNCTION ds2dk(lnk,r)
  IMPLICIT none
  DOUBLE PRECISION :: lnk,k,r,x
  DOUBLE PRECISION :: linear_pk,win
  DOUBLE PRECISION :: pi= 3.14159265d0
  k = dexp(lnk)
  x = k*r
  win= (3d0/x)*(sin(x)/x**2d0-cos(x)/x)
  ds2dk = k**3d0*(linear_pk(k)*win**2d0)/(2d0*pi**2d0)
  return
END FUNCTION ds2dk


program main
   implicit none
   use iso_c_binding

   integer(c_long_long) :: min_prime=1000003,max_prime=9999999967
   character(1), dimension(max_prime) :: prime_list
   integer(c_int), dimension(10) :: digits = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
   integer(c_long_long) :: i,

   ! create the prime number list (remember, they're 1 byte chars for memory purposes)
   prime_list = prime_list_gen(min_prime, max_prime)

   ! start near end of list and move down by 2's since we know even numbers aren't prime
   do i = max_prime-2, min_prime, -2
      if (prime_list(i) == 'T') then
         if (check_digits(i)) then
            print i
            exit
         endif
      end if
   end do

   stop

contains
   !> return an array of 1 bit chars that specify true/false
   function prime_list_gen(a, b) result(list)
      integer(c_long_long), intent(in) :: a, b
      character(1), dimension(b) :: list

      ! wheel of 7
      list = 'T'
      list(4:b:2) = 'F'
      list(9:b:3) = 'F'
      list(25:b:5) = 'F'
      list(49:b:7) = 'F'

      ! loop through all from 11 to max primes
      do i=11,b
         if (list(i)=='T') then
            list(i*i:b:2*i) = 'F'
         end if
      end do
   end function prime_list_gen

   !> check to see if all digits are in the number
   logical function check_digits(i) result(is_permutation)
      integer(c_long_long), intent(in) :: i
      integer, allocatable :: test(:)
      integer(c_long_long) :: rem
      integer :: ix, num_digits
      logical :: is_permutation

      num_digits = floor(log10(real(num))+1)
      allocate(test(num_digits))
      rem = i
      ! this actually puts them in *reverse* order, but since we sort it anyway, that's irrelevant
      do ix=1, num_digits
         test(i) = rem - (rem/10)*10
         rem = rem/10
      end do

      ! sort the digits
      call sort(num_digits,test)

      ! check that all numbers are used
      do ix=1,num_digits
         if (test(i) /= digits(i)) then
            is_permutation = .false.
            return
         end if
      end do
      is_permutation = .true.
   end function check_digits

   !> sort the table
   recursive subroutine sort(X)
      integer, intent(inout) :: X(:)
      integer :: iq

      if (size(X)>1) then
         i = partition(X)
         call sort(X(:i-1))
         call sort(X(i:))
      endif
   end subroutine sort

   integer function partition(A) result(marker)
      integer, intent(inout) :: A(:)
      integer :: marker
      integer :: i, j, temp, x

      marker=0

      x = A(1)
      i = 0
      j = size(A)+1

      do
         j = j-1
         do
            if (A(j) <= x) exit
            j = j - 1
         end do
         i = i+1
         do
            if (A(i) >= x) exit
            i = i+1
         end do

         if (i < j) then
            temp = A(i)
            A(i) = A(j)
            A(j) = temp
         else if (i==j) then
            marker = i+1
            return
         else
            marker = i
            return
         endif
      end do
   end function partition
end program


module szfuncs
  use precision1, only : dp
  implicit none

contains

    real(dp) function delta(r)
        use cosmo_params, only : amp,dlr,r0
        implicit none
        real(dp), intent(in) :: r
        real(dp) :: x
        x=0.5_dp*(r-r0)/dlr
        delta=0.5_dp*amp*(1._dp-tanh(x))
    end function delta

    real(dp) function deltaprime(r)
        use cosmo_params, only : amp,dlr,r0
        implicit none
        real(dp), intent(in) :: r
        real(dp) :: x,f
        x=0.5_dp*(r-r0)/dlr
! need more robust solution but for now
        if (x > 250._dp) then
            f=0._dp
        else
            f=1._dp/cosh(x)**2
        end if
        deltaprime=-0.25_dp*amp*f/dlr
    end function deltaprime

    real(dp) function deltapprime(r)
        use cosmo_params, only : amp,dlr,r0
        implicit none
        real(dp), intent(in) :: r
        real(dp) :: x,f
        x=0.5_dp*(r-r0)/dlr
        if (x > 250._dp) then
            f=0._dp
        else
            f=tanh(x)/cosh(x)**2
        end if
        deltapprime=0.25_dp*amp*f/dlr**2
    end function deltapprime

    real(dp) function Mfunc(r)
        use cosmo_params, only : M0
        implicit none
        real(dp), intent(in) :: r
        Mfunc=M0*(1._dp+delta(r))*r**3
    end function Mfunc

    real(dp) function Mprime(r)
        use cosmo_params, only : M0
        implicit none
        real(dp), intent(in) :: r
        real(dp) :: delp1,ddel
        delp1=delta(r)+1._dp
        ddel=deltaprime(r)
        Mprime=M0*(3._dp*delp1+ddel*r)*r**2
    end function Mprime

    real(dp) function Mpprime(r)
        use cosmo_params, only : M0
        real(dp), intent(in) :: r
        real(dp) :: delp1,ddel,dddel,a
        delp1=delta(r)+1._dp
        ddel=deltaprime(r)
        dddel=deltapprime(r)
        a=6._dp*(delp1+ddel*r)
        Mpprime=M0*(a+dddel*r**2)*r
    end function Mpprime

    real(dp) function Omr0(r)
        use cosmo_params, only : FLRW
        implicit none
        real(dp), intent(in) :: r
        Omr0=FLRW%Om*(1._dp+delta(r))
    end function Omr0

    real(dp) function k_approx(r)
        use cosmo_params, only : H0,FLRW
        implicit none
        real(dp), intent(in) :: r
        k_approx=2.455*FLRW%Om*delta(r)*(H0*r)**2
    end function k_approx

    real(dp) function S_sz(r)
        use cosmo_params, only : alpha
        implicit none
        real(dp), intent(in) :: r
        S_sz=r**alpha
    end function S_sz

    real(dp) function Sp_sz(r)
        use cosmo_params, only : alpha
        implicit none
        real(dp), intent(in) :: r
        Sp_sz=alpha*S_sz(r)/r
    end function Sp_sz

    real(dp) function Spp_sz(r)
        use cosmo_params, only : alpha
        implicit none
        real(dp), intent(in) :: r
        Spp_sz=(alpha-1._dp)*Sp_sz(r)/r
    end function Spp_sz

    real(dp) function P_sz(r)
        implicit none
        real(dp), intent(in) :: r
        P_sz=1._dp
    end function P_sz

    real(dp) function Pp_sz(r)
        implicit none
        real(dp), intent(in) :: r
        Pp_sz=0._dp
    end function Pp_sz

    real(dp) function Ppp_sz(r)
        implicit none
        real(dp), intent(in) :: r
        Ppp_sz=0._dp
    end function Ppp_sz

    real(dp) function Q_sz(r)
        implicit none
        real(dp), intent(in) :: r
        Q_sz=0._dp
    end function Q_sz

    real(dp) function Qp_sz(r)
        implicit none
        real(dp), intent(in) :: r
        Qp_sz=0._dp
    end function Qp_sz

    real(dp) function Qpp_sz(r)
        implicit none
        real(dp), intent(in) :: r
        Qpp_sz=0._dp
    end function Qpp_sz

end module szfuncs


      SUBROUTINE UHARD(SYIELD,HARD,EQPLAS,EQPLASRT,TIME,DTIME,TEMP,
     1     DTEMP,NOEL,NPT,LAYER,KSPT,KSTEP,KINC,CMNAME,NSTATV,
     2     STATEV,NUMFIELDV,PREDEF,DPRED,NUMPROPS,PROPS)
C
	  INCLUDE '../aba_param_dp.INC'
C
	  CHARACTER*80 CMNAME
	  DIMENSION HARD(3), STATEV(NSTATV), TIME(1), PREDEF(NUMFIELDV), DPRED(NUMFIELDV), PROPS(*)
	  REAL*8 A1,b1,b2,b3,n1,L1,L2,e,edot,edot0,edotn,T,Tr,Tm,Th,Sp,einv, edinv
	  REAL*8 Ehard,Ehard_e,EDhard,EDhard_e,EDhard_ed,Tsoft,Tsoft_e,Tsoft_T
      A1 = PROPS(1)
      n1 = PROPS(2)
      b1 = PROPS(3)
      b2 = PROPS(4)
      b3 = PROPS(5)
      L1 = PROPS(6)
      L2 = PROPS(7)
      edot0 = PROPS(8)
      Tr = PROPS(9)
      Tm = PROPS(10)

      e = max(EQPLAS, 1e-6)
      einv = 1.0 / max(e, 1.0D-2)
      edot = EQPLASRT
      edotn = max(edot / edot0, 1.0D-3)
      edinv = 1.0 / max(edotn, 1.0D-2)
      T = TEMP
      Th = (T - Tr) / (Tm - Tr)

      Ehard = A1 * e ** n1
      Ehard_e = n1 * A1 * einv ** (1.0D0 - n1)

      EDhard = (1 + (b1 + e * (b2 + e * b3)) * log(edotn))
      EDhard_e = (b2 + 2.0D0 * b3 * e) * log(edotn)
      EDhard_ed = (b1 + e * (b2 + e * b3)) * edinv

      Tsoft = exp((L1 + L2 * e) * Th)
      Tsoft_e = Th * L2 * Tsoft
      Tsoft_T = (L1 + L2 * e) * Tsoft / (Tm - Tr)

      SYIELD = Ehard * EDhard * Tsoft
      HARD(1) = Ehard * EDhard * Tsoft_e + Ehard * EDhard_e * Tsoft + Ehard_e * EDhard * Tsoft
      HARD(2) = Ehard * EDhard_ed * Tsoft
      HARD(3) = Ehard * EDhard * Tsoft_T

      RETURN
      END

      SUBROUTINE VUHARD(
C READ ONLY -
     *     NBLOCK,
     *     JELEM, KINTPT, KLAYER, KSECPT,
     *     LANNEAL, STEPTIME, TOTALTIME, DT, CMNAME,
     *     NSTATEV, NFIELDV, NPROPS,
     *     PROPS, TEMPOLD, TEMPNEW, FIELDOLD, FIELDNEW,
     *     STATEOLD,
     *     EQPS, EQPSRATE,
C WRITE ONLY -
     *     YIELD, DYIELDDTEMP, DYIELDDEQPS,
     *     STATENEW )
C
      INCLUDE '../vaba_param_dp.INC'
C
      DIMENSION PROPS(NPROPS), TEMPOLD(NBLOCK), TEMPNEW(NBLOCK),
     1   FIELDOLD(NBLOCK,NFIELDV), FIELDNEW(NBLOCK,NFIELDV),
     2   STATEOLD(NBLOCK,NSTATEV), EQPS(NBLOCK), EQPSRATE(NBLOCK),
     3   YIELD(NBLOCK), DYIELDDTEMP(NBLOCK), DYIELDDEQPS(NBLOCK,2),
     4   STATENEW(NBLOCK,NSTATEV), JELEM(NBLOCK)
C
      CHARACTER*80 CMNAME
C
	  REAL*8 A1,b1,b2,b3,n1,L1,L2,e,edot,edot0,edotn,T,Tr,Tm,Th,Sp,einv, edinv
	  REAL*8 Ehard,Ehard_e,EDhard,EDhard_e,EDhard_ed,Tsoft,Tsoft_e,Tsoft_T

      DO 100 km = 1,NBLOCK
          A1 = PROPS(1)
          n1 = PROPS(2)
          b1 = PROPS(3)
          b2 = PROPS(4)
          b3 = PROPS(5)
          L1 = PROPS(6)
          L2 = PROPS(7)
          edot0 = PROPS(8)
          Tr = PROPS(9)
          Tm = PROPS(10)

          e = max(EQPS(km), 1e-6)
          einv = 1.0 / max(e, 1.0D-2)
          edot = EQPSRATE(km)
          edotn = max(edot / edot0, 1.0D-3)
          edinv = 1.0 / max(edotn, 1.0D-2)
          T = TEMPOLD(km)
          Th = (T - Tr) / (Tm - Tr)

          Ehard = A1 * e ** n1
          Ehard_e = n1 * A1 * einv ** (1.0D0 - n1)

          EDhard = (1 + (b1 + e * (b2 + e * b3)) * log(edotn))
          EDhard_e = (b2 + 2.0D0 * b3 * e) * log(edotn)
          EDhard_ed = (b1 + e * (b2 + e * b3)) * edinv

          Tsoft = exp((L1 + L2 * e) * Th)
          Tsoft_e = Th * L2 * Tsoft
          Tsoft_T = (L1 + L2 * e) * Tsoft / (Tm - Tr)

          YIELD(km) = Ehard * EDhard * Tsoft
          DYIELDDEQPS(km,1) = Ehard * EDhard * Tsoft_e + Ehard * EDhard_e * Tsoft + Ehard_e * EDhard * Tsoft
          DYIELDDEQPS(km,2) = Ehard * EDhard_ed * Tsoft
          DYIELDDTEMP(km) = Ehard * EDhard * Tsoft_T
  100 CONTINUE
C
      RETURN
      END


      PROGRAM MAIN

C*********************************************************************72
C  Advent of Code 2021
C  --- Day 5: Hydrothermal Venture ---
C
C  data.txt - 500 lines of input, max coordinate is 989
C  example.txt - 10 lines of input, max coordinate is 9

      IMPLICIT NONE

      CHARACTER INF_N*128 ! Input file name
      INTEGER INF_H ! Handle for the input file
      INTEGER COORDS(4, 500), OFLOOR(0:999, 0:999)
      INTEGER I, J, A, N, FROM_X, FROM_Y, TO_X, TO_Y, DIFF_X, DIFF_Y
      INTEGER PART_1, PART_2
      PARAMETER (INF_H = 10)

C  Check if the input file name is available - if not, then exit
      I = IARGC()
      IF (I.LT.1) THEN
          WRITE(*, '(A)') 'ERROR: An input file is required!'
          GOTO 9999
      END IF

C  Read input from data file, stop if end-of-file is reached
      CALL GETARG(1, INF_N)
      OPEN(INF_H, FILE=INF_N, STATUS='OLD')
      I = 0
      N = 0
      DO WHILE (I.EQ.0)
          N = N + 1
          READ(INF_H, *, IOSTAT=I) COORDS(1, N), COORDS(2, N),
     2                             COORDS(3, N), COORDS(4, N)
      END DO
      IF (I.NE.0) THEN ! Decrement the line count if there was an error
          N = N - 1
      END IF
      CLOSE(INF_H)

C  Initialize OFLOOR array
      DO I = 0, 999
          DO J = 0, 999
              OFLOOR(J, I) = 0
          END DO
      END DO

C  Process horizontal & vertical line descriptors
      DO I = 1, N
          FROM_X = COORDS(1, I)
          FROM_Y = COORDS(2, I)
          TO_X = COORDS(3, I)
          TO_Y = COORDS(4, I)
          IF (FROM_X.EQ.TO_X) THEN
              DO J = FROM_Y, TO_Y ! Mark line from top to bottom
                  OFLOOR(FROM_X, J) = OFLOOR(FROM_X, J) + 1
              END DO
              DO J = TO_Y, FROM_Y ! Mark line from bottom to top
                  OFLOOR(FROM_X, J) = OFLOOR(FROM_X, J) + 1
              END DO
          END IF
          IF (FROM_Y.EQ.TO_Y) THEN
              DO J = FROM_X, TO_X ! Mark line from left to right
                  OFLOOR(J, FROM_Y) = OFLOOR(J, FROM_Y) + 1
              END DO
              DO J = TO_X, FROM_X ! Mark line from right to left
                  OFLOOR(J, FROM_Y) = OFLOOR(J, FROM_Y) + 1
              END DO
          END IF
      END DO

C  Part 1 solution
      PART_1 = 0
      DO I = 0, 999
          DO J = 0, 999
              IF (OFLOOR(J, I).GE.2) THEN
                  PART_1 = PART_1 + 1
              END IF
          END DO
      END DO
      WRITE(*, '(A, I8.1)') 'Part 1: ', PART_1

C  Process diagonal (Y = AX + B, where ABS(A) = 1) line descriptors
      DO I = 1, N
          FROM_X = COORDS(1, I)
          FROM_Y = COORDS(2, I)
          TO_X = COORDS(3, I)
          TO_Y = COORDS(4, I)
          DIFF_X = TO_X - FROM_X
          DIFF_Y = TO_Y - FROM_Y
          IF (ABS(DIFF_X).EQ.ABS(DIFF_Y)) THEN ! ABS(A) = 1
              IF (FROM_X.GT.TO_X) THEN ! Flip coords if FROM_X > TO_X
                  CALL ISWAP(FROM_X, TO_X)
                  CALL ISWAP(FROM_Y, TO_Y)
              END IF
              A = SIGN(1, DIFF_X * DIFF_Y)
              DO J = 0, ABS(DIFF_X)
                  OFLOOR(FROM_X+J, FROM_Y+A*J) =
     2                OFLOOR(FROM_X+J, FROM_Y+A*J) + 1
              END DO
          END IF
      END DO

C  Part 2 solution
      PART_2 = 0
      DO I = 0, 999
          DO J = 0, 999
              IF (OFLOOR(J, I).GE.2) THEN
                  PART_2 = PART_2 + 1
              END IF
          END DO
      END DO
      WRITE(*, '(A, I8.1)') 'Part 2: ', PART_2

 9999 STOP
      END

      SUBROUTINE ISWAP(A, B)
          INTEGER A, B
          INTEGER TEMP

          TEMP = A
          A = B
          B = TEMP
          RETURN
      END


! Some utility functions for initialization and analysis

module prob_util_module

  use amrex_fort_module, only : rt => amrex_real

  implicit none

contains

  subroutine analytic(xc, yc, time, temp)

    use prob_params_module, only : center, coord_type
    use probdata_module, only : T1, T2, diff_coeff, t_0, rho0

    implicit none

    real(rt), intent(in) :: xc, yc, time
    real(rt), intent(out) :: temp

    real(rt)         :: dist2

    dist2 = (xc - center(1))**2 + (yc - center(2))**2

    if (coord_type == 0) then
       temp = (T2 - T1)*t_0/(time + t_0) * &
            exp(-0.25_rt*dist2/(diff_coeff*(time + t_0)) ) + T1
    elseif (coord_type == 1) then
       ! this should be the 3-d solution
       temp = (T2 - T1)*(t_0/(time + t_0))**1.5_rt * &
            exp(-0.25_rt*dist2/(diff_coeff*(time + t_0)) ) + T1
    endif

  end subroutine analytic

end module prob_util_module


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c     12/96
c
c     a program for testing all gradient and inverse gradient routines
c
c     (1) first a scalar field is set in st by restricting a poly in x,y,z
c         to the sphere surface
c
c     (2) a scalar analysis is used to compute the coefs a,b of st
c
c     (3) a,b are input to the various gradient routines to compute a vector field
c         (v,w)
c
c     (4) the vector field (v,w) is compared with the gradient of st obtained
c         analytically
c
c     (5) the inverse gradient of (v,w) is computed and compared with (1)
c
      program tgrad
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 33,nnlon= 18, nnt = 4)
      parameter  (mmdb=(nnlon+1)/2, mmdab=(nnlon+2)/2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav= 5*nnlat*nnlat*nnlon)
      parameter (lldwork = 4*nnlat*nnlat)
      double precision dwork(lldwork)
      dimension work(lleng),wsave(llsav)
      dimension br(mmdb,nnlat,nnt),bi(mmdb,nnlat,nnt)
      dimension cr(mmdb,nnlat,nnt),ci(mmdb,nnlat,nnt)
      dimension a(mmdab,nnlat,nnt),b(mmdab,nnlat,nnt)
      dimension sf(nnlat,nnlon,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      lwork = lleng
      lsave = llsav
      mdb = mmdb
      mdab = mmdab
      nt = nnt
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")
      call iout(nt,"  nt")
      isym = 0
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name("gaqd")
      call iout(ier," ier")
      call vecout(thetag,"thtg",nlat)
c
c     test all analysis and synthesis subroutines
c
      do icase=1,4
c
c     icase=1 test gradec,igradec
c     icase=2 test grades,igrades
c     icase=3 test gradgc,igradgc
c     icase=4 test gradgs,igradgs
c
      call name("****")
      call name("****")
      call iout(icase,"icas")
c
c
c     set scalar field as polys in x,y,z and set vector field (v,w) using
c     v = dsfdt, w = 1/sint*dsfdp
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    dxdp = -sint*sinp
	    dydt = cost*sinp
	    dydp = sint*cosp
	    dzdt = -sint
	    dzdp = 0.0
	    if (k.eq.1) then
	       sf(i,j,k) = x*y
	       dsfdt = x*dydt+y*dxdt
	       dsfdp = x*dydp+y*dxdp
	       v(i,j,k) = dsfdt
	       w(i,j,k) = (cosp*dydp+sinp*dxdp)
	    else if (k.eq.2) then
	       sf(i,j,k) = x*z
	       dsfdp = x*dzdp+z*dxdp
	       dsfdt = x*dzdt+z*dxdt
	       v(i,j,k) = dsfdt
	       w(i,j,k) = cosp*dzdp-z*sinp
	    else if (k.eq.3) then
	       sf(i,j,k) = y*z
	       dsfdt = y*dzdt + z*dydt
	       dsfdp = y*dzdp+ z*dydp
	       v(i,j,k) = dsfdt
	       w(i,j,k) = sinp*dzdp + z*cosp
	    else if (k.eq.4) then
	       sf(i,j,k) = x*y*z
	       dsfdt = x*y*dzdt + x*z*dydt + y*z*dxdt
	       dsfdp = x*y*dzdp + x*z*dydp + y*z*dxdp
	       v(i,j,k) = dsfdt
	       w(i,j,k) = cosp*y*dzdp+cosp*z*dydp+sinp*z*dxdp
	    end if
	  end do
	end do
      end do

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(sf(1,1,kk),"  sf",nlat,nlon)
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     end do

      if (icase.eq.1) then

      call name("**ec")
c
c     analyze scalar field st
c
      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaec(nlat,nlon,isym,nt,sf,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(a(1,1,kk),"   a",nlat,nlat)
c     call aout(b(1,1,kk),"   b",nlat,nlat)
c     end do

c
c     compute gradient of st in v,w
c

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhci")
      call iout(ierror,"ierr")

      call gradec(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("grad")
      call iout(ierror,"ierr")

      else if (icase.eq.2) then

      call name("**es")
c
c     analyze scalar field st
c
      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaes(nlat,nlon,isym,nt,sf,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(a(1,1,kk),"   a",nlat,nlat)
c     call aout(b(1,1,kk),"   b",nlat,nlat)
c     end do

c
c     compute gradient of st in v,w
c

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call grades(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("grad")
      call iout(ierror,"ierr")

      else if (icase .eq. 3) then

      call name("**gc")
      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shagc(nlat,nlon,isym,nt,sf,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(a(1,1,kk),"   a",nlat,nlat)
c     call aout(b(1,1,kk),"   b",nlat,nlat)
c     end do

c
c     compute gradient of st in v,w
c

      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhgc")
      call iout(ierror,"ierr")

      call gradgc(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("grad")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then

      call name("**gs")

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shags(nlat,nlon,isym,nt,sf,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(a(1,1,kk),"   a",nlat,nlat)
c     call aout(b(1,1,kk),"   b",nlat,nlat)
c     end do

c
c     compute gradient of st in v,w
c

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhgs")
      call iout(ierror,"ierr")

      call gradgs(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name("grad")
      call iout(ierror,"ierr")
      end if

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     end do

c
c     compute "error" in v,w
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    dxdp = -sint*sinp
	    dydt = cost*sinp
	    dydp = sint*cosp
	    dzdt = -sint
	    dzdp = 0.0
	    if (k.eq.1) then
	       dsfdt = x*dydt+y*dxdt
	       dsfdp = x*dydp+y*dxdp
	       ve = dsfdt
	       we = (cosp*dydp+sinp*dxdp)
	    else if (k.eq.2) then
	       dsfdp = x*dzdp+z*dxdp
	       dsfdt = x*dzdt+z*dxdt
	       ve = dsfdt
	       we = cosp*dzdp-z*sinp
	    else if (k.eq.3) then
	       dsfdt = y*dzdt + z*dydt
	       dsfdp = y*dzdp+ z*dydp
	       ve = dsfdt
	       we = sinp*dzdp + z*cosp
	    else if (k.eq.4) then
	       dsfdt = x*y*dzdt + x*z*dydt + y*z*dxdt
	       dsfdp = x*y*dzdp + x*z*dydp + y*z*dxdp
	       ve = dsfdt
	       we = cosp*y*dzdp+cosp*z*dydp+sinp*z*dxdp
	    end if
	       err2v = err2v + (v(i,j,k)-ve)**2
	       err2w = err2w + (w(i,j,k)-we)**2
	  end do
	end do
      end do
c
c     set and print least squares error in v,w
c
      err2v = sqrt(err2v/(nt*nlat*nlon))
      err2w = sqrt(err2w/(nt*nlat*nlon))
      call vout(err2v,"errv")
      call vout(err2w,"errw")
c
c     now recompute sf by inverting (v,w) using igrad(ec,es,gc,gs)
c
      if (icase.eq.1) then

      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shec")
      call iout(ierror,"ierr")

      call igradec(nlat,nlon,isym,nt,sf,nlat,nlon,br,bi,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("igra")
      call iout(ierror,"ierr")

      else if (icase.eq.2) then
c
c     analyze vector field (v,w)
c
      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaes(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(br(1,1,kk),"  br",nlat,nlat)
c     call aout(bi(1,1,kk),"  bi",nlat,nlat)
c     call aout(cr(1,1,kk),"  cr",nlat,nlat)
c     call aout(ci(1,1,kk),"  ci",nlat,nlat)
c     end do

      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shes")
      call iout(ierror,"ierr")

      call igrades(nlat,nlon,isym,nt,sf,nlat,nlon,br,bi,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("igra")
      call iout(ierror,"ierr")

      else if (icase .eq. 3) then

      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhagc(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shgc")
      call iout(ierror,"ierr")

      call igradgc(nlat,nlon,isym,nt,sf,nlat,nlon,br,bi,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("igra")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhags(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shgs")
      call iout(ierror,"ierr")

      call igradgs(nlat,nlon,isym,nt,sf,nlat,nlon,br,bi,
     +mdb,nlat,wsave,lsave,work,lwork,ierror)
      call name("igra")
      call iout(ierror,"ierr")

      end if

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(sf(1,1,kk),"  sf",nlat,nlon)
c     end do

c
c     compare this sf with original
c
      err2s = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    if (k.eq.1) then
	       se = x*y
	    else if (k.eq.2) then
	       se = x*z
	    else if (k.eq.3) then
	       se = y*z
	    else if (k.eq.4) then
	       se = x*y*z
	    end if
	       err2s = err2s + (sf(i,j,k)-se)**2
	  end do
	end do
      end do
      err2s = sqrt(err2s/(nlat*nlon*nt))
      call vout(err2s,"errs")
c
c     end of icase loop
c
      end do
      end
c
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


C
C ------------------------------------------------------------------
C
      SUBROUTINE DORTQR(NZ, N, NBLOCK, Z, B)
C
      INTEGER NZ, N, NBLOCK
      DOUBLE PRECISION Z(NZ,1), B(NBLOCK,1)
C
C THIS SUBROUTINE COMPUTES THE QR FACTORIZATION OF THE N X NBLOCK
C MATRIX Z.  Q IS FORMED IN PLACE AND RETURNED IN Z.  R IS
C RETURNED IN B.
C
      INTEGER I, J, K, LENGTH, M
      DOUBLE PRECISION SIGMA, TAU, TEMP, DDOT, DNRM2, DSIGN
      EXTERNAL DAXPY, DDOT, DNRM2, DSCAL
C
C THIS SECTION REDUCES Z TO TRIANGULAR FORM.
C
      DO 30 I=1,NBLOCK
C
C THIS FORMS THE ITH REFLECTION.
C
         LENGTH = N - I + 1
         SIGMA = DSIGN(DNRM2(LENGTH,Z(I,I),1),Z(I,I))
         B(I,I) = -SIGMA
         Z(I,I) = Z(I,I) + SIGMA
         TAU = SIGMA*Z(I,I)
         IF (I.EQ.NBLOCK) GO TO 30
         J = I + 1
C
C THIS APPLIES THE ROTATION TO THE REST OF THE COLUMNS.
C
         DO 20 K=J,NBLOCK
            IF (TAU.EQ.0.0D0) GO TO 10
            TEMP = -DDOT(LENGTH,Z(I,I),1,Z(I,K),1)/TAU
            CALL DAXPY(LENGTH, TEMP, Z(I,I), 1, Z(I,K), 1)
   10       B(I,K) = Z(I,K)
            Z(I,K) = 0.0D0
   20    CONTINUE
   30 CONTINUE
C
C THIS ACCUMULATES THE REFLECTIONS IN REVERSE ORDER.
C
      DO 70 M=1,NBLOCK
C
C THIS RECREATES THE ITH = NBLOCK-M+1)TH REFLECTION.
C
         I = NBLOCK + 1 - M
         SIGMA = -B(I,I)
         TAU = Z(I,I)*SIGMA
         IF (TAU.EQ.0.0D0) GO TO 60
         LENGTH = N - NBLOCK + M
         IF (I.EQ.NBLOCK) GO TO 50
         J = I + 1
C
C THIS APPLIES IT TO THE LATER COLUMNS.
C
         DO 40 K=J,NBLOCK
            TEMP = -DDOT(LENGTH,Z(I,I),1,Z(I,K),1)/TAU
            CALL DAXPY(LENGTH, TEMP, Z(I,I), 1, Z(I,K), 1)
   40    CONTINUE
   50    CALL DSCAL(LENGTH, -1.0D0/SIGMA, Z(I,I), 1)
   60    Z(I,I) = 1.0D0 + Z(I,I)
   70 CONTINUE
      RETURN
      END


! Recursive Fortran 95 quicksort routine
! sorts real numbers into ascending numerical order
! Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03
! Based on algorithm from Cormen et al., Introduction to Algorithms,
! 1997 printing

! Made F conformant by Walt Brainerd

module qsort_c_module

implicit none
public :: QsortC
private :: Partition

contains

recursive subroutine QsortC(A)
  real, intent(in out), dimension(:) :: A
  integer :: iq

  if(size(A) > 1) then
     call Partition(A, iq)
     call QsortC(A(:iq-1))
     call QsortC(A(iq:))
  endif
end subroutine QsortC

subroutine Partition(A, marker)
  real, intent(in out), dimension(:) :: A
  integer, intent(out) :: marker
  integer :: i, j
  real :: temp
  real :: x      ! pivot point
  x = A(1)
  i= 0
  j= size(A) + 1

  do
     j = j-1
     do
        if (A(j) <= x) exit
        j = j-1
     end do
     i = i+1
     do
        if (A(i) >= x) exit
        i = i+1
     end do
     if (i < j) then
        ! exchange A(i) and A(j)
        temp = A(i)
        A(i) = A(j)
        A(j) = temp
     elseif (i == j) then
        marker = i+1
        return
     else
        marker = i
        return
     endif
  end do

end subroutine Partition

end module qsort_c_module

program sortdriver
  use qsort_c_module
  implicit none
  integer, parameter :: r = 10
  real, dimension(1:r) :: myarray = &        ! (1:r)
     (/0, 50, 20, 25, 90, 10, 5, 1, 99, 75/)
  print *, "myarray is ", myarray
  call QsortC(myarray)
  print *, "sorted array is ", myarray
end program sortdriver