      SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
     $           PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
     $           R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      LOGICAL            WANTNC
      INTEGER   B1, BN, N, NEGCNT, R
      DOUBLE PRECISION   GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
     $                   RQCORR, ZTZ
*     ..
*     .. Array Arguments ..
      INTEGER            ISUPPZ( * )
      DOUBLE PRECISION   D( * ), L( * ), LD( * ), LLD( * ),
     $                  WORK( * )
      COMPLEX*16       Z( * )
*     ..
*
*  Purpose
*  =======
*
*  ZLAR1V computes the (scaled) r-th column of the inverse of
*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
*  L D L^T - sigma I. When sigma is close to an eigenvalue, the
*  computed vector is an accurate eigenvector. Usually, r corresponds
*  to the index where the eigenvector is largest in magnitude.
*  The following steps accomplish this computation :
*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
*  (c) Computation of the diagonal elements of the inverse of
*      L D L^T - sigma I by combining the above transforms, and choosing
*      r as the index where the diagonal of the inverse is (one of the)
*      largest in magnitude.
*  (d) Computation of the (scaled) r-th column of the inverse using the
*      twisted factorization obtained by combining the top part of the
*      the stationary and the bottom part of the progressive transform.
*
*  Arguments
*  =========
*
*  N        (input) INTEGER
*           The order of the matrix L D L^T.
*
*  B1       (input) INTEGER
*           First index of the submatrix of L D L^T.
*
*  BN       (input) INTEGER
*           Last index of the submatrix of L D L^T.
*
*  LAMBDA    (input) DOUBLE PRECISION
*           The shift. In order to compute an accurate eigenvector,
*           LAMBDA should be a good approximation to an eigenvalue
*           of L D L^T.
*
*  L        (input) DOUBLE PRECISION array, dimension (N-1)
*           The (n-1) subdiagonal elements of the unit bidiagonal matrix
*           L, in elements 1 to N-1.
*
*  D        (input) DOUBLE PRECISION array, dimension (N)
*           The n diagonal elements of the diagonal matrix D.
*
*  LD       (input) DOUBLE PRECISION array, dimension (N-1)
*           The n-1 elements L(i)*D(i).
*
*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)
*           The n-1 elements L(i)*L(i)*D(i).
*
*  PIVMIN   (input) DOUBLE PRECISION
*           The minimum pivot in the Sturm sequence.
*
*  GAPTOL   (input) DOUBLE PRECISION
*           Tolerance that indicates when eigenvector entries are negligible
*           w.r.t. their contribution to the residual.
*
*  Z        (input/output) COMPLEX*16       array, dimension (N)
*           On input, all entries of Z must be set to 0.
*           On output, Z contains the (scaled) r-th column of the
*           inverse. The scaling is such that Z(R) equals 1.
*
*  WANTNC   (input) LOGICAL
*           Specifies whether NEGCNT has to be computed.
*
*  NEGCNT   (output) INTEGER
*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.
*
*  ZTZ      (output) DOUBLE PRECISION
*           The square of the 2-norm of Z.
*
*  MINGMA   (output) DOUBLE PRECISION
*           The reciprocal of the largest (in magnitude) diagonal
*           element of the inverse of L D L^T - sigma I.
*
*  R        (input/output) INTEGER
*           The twist index for the twisted factorization used to
*           compute Z.
*           On input, 0 <= R <= N. If R is input as 0, R is set to
*           the index where (L D L^T - sigma I)^{-1} is largest
*           in magnitude. If 1 <= R <= N, R is unchanged.
*           On output, R contains the twist index used to compute Z.
*           Ideally, R designates the position of the maximum entry in the
*           eigenvector.
*
*  ISUPPZ   (output) INTEGER array, dimension (2)
*           The support of the vector in Z, i.e., the vector Z is
*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
*  NRMINV   (output) DOUBLE PRECISION
*           NRMINV = 1/SQRT( ZTZ )
*
*  RESID    (output) DOUBLE PRECISION
*           The residual of the FP vector.
*           RESID = ABS( MINGMA )/SQRT( ZTZ )
*
*  RQCORR   (output) DOUBLE PRECISION
*           The Rayleigh Quotient correction to LAMBDA.
*           RQCORR = MINGMA*TMP
*
*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Beresford Parlett, University of California, Berkeley, USA
*     Jim Demmel, University of California, Berkeley, USA
*     Inderjit Dhillon, University of Texas, Austin, USA
*     Osni Marques, LBNL/NERSC, USA
*     Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )

*     ..
*     .. Local Scalars ..
      LOGICAL            SAWNAN1, SAWNAN2
      INTEGER            I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
     $                   R2
      DOUBLE PRECISION   DMINUS, DPLUS, EPS, S, TMP
*     ..
*     .. External Functions ..
      LOGICAL DISNAN
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DISNAN, DLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE
*     ..
*     .. Executable Statements ..
*
      EPS = DLAMCH( 'Precision' )

      IF( R.EQ.0 ) THEN
         R1 = B1
         R2 = BN
      ELSE
         R1 = R
         R2 = R
      END IF

*     Storage for LPLUS
      INDLPL = 0
*     Storage for UMINUS
      INDUMN = N
      INDS = 2*N + 1
      INDP = 3*N + 1

      IF( B1.EQ.1 ) THEN
         WORK( INDS ) = ZERO
      ELSE
         WORK( INDS+B1-1 ) = LLD( B1-1 )
      END IF

*
*     Compute the stationary transform (using the differential form)
*     until the index R2.
*
      SAWNAN1 = .FALSE.
      NEG1 = 0
      S = WORK( INDS+B1-1 ) - LAMBDA
      DO 50 I = B1, R1 - 1
         DPLUS = D( I ) + S
         WORK( INDLPL+I ) = LD( I ) / DPLUS
         IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
         S = WORK( INDS+I ) - LAMBDA
 50   CONTINUE
      SAWNAN1 = DISNAN( S )
      IF( SAWNAN1 ) GOTO 60
      DO 51 I = R1, R2 - 1
         DPLUS = D( I ) + S
         WORK( INDLPL+I ) = LD( I ) / DPLUS
         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
         S = WORK( INDS+I ) - LAMBDA
 51   CONTINUE
      SAWNAN1 = DISNAN( S )
*
 60   CONTINUE
      IF( SAWNAN1 ) THEN
*        Runs a slower version of the above loop if a NaN is detected
         NEG1 = 0
         S = WORK( INDS+B1-1 ) - LAMBDA
         DO 70 I = B1, R1 - 1
            DPLUS = D( I ) + S
            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
            WORK( INDLPL+I ) = LD( I ) / DPLUS
            IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
            IF( WORK( INDLPL+I ).EQ.ZERO )
     $                      WORK( INDS+I ) = LLD( I )
            S = WORK( INDS+I ) - LAMBDA
 70      CONTINUE
         DO 71 I = R1, R2 - 1
            DPLUS = D( I ) + S
            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
            WORK( INDLPL+I ) = LD( I ) / DPLUS
            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
            IF( WORK( INDLPL+I ).EQ.ZERO )
     $                      WORK( INDS+I ) = LLD( I )
            S = WORK( INDS+I ) - LAMBDA
 71      CONTINUE
      END IF
*
*     Compute the progressive transform (using the differential form)
*     until the index R1
*
      SAWNAN2 = .FALSE.
      NEG2 = 0
      WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
      DO 80 I = BN - 1, R1, -1
         DMINUS = LLD( I ) + WORK( INDP+I )
         TMP = D( I ) / DMINUS
         IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
         WORK( INDUMN+I ) = L( I )*TMP
         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
 80   CONTINUE
      TMP = WORK( INDP+R1-1 )
      SAWNAN2 = DISNAN( TMP )

      IF( SAWNAN2 ) THEN
*        Runs a slower version of the above loop if a NaN is detected
         NEG2 = 0
         DO 100 I = BN-1, R1, -1
            DMINUS = LLD( I ) + WORK( INDP+I )
            IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
            TMP = D( I ) / DMINUS
            IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
            WORK( INDUMN+I ) = L( I )*TMP
            WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
            IF( TMP.EQ.ZERO )
     $          WORK( INDP+I-1 ) = D( I ) - LAMBDA
 100     CONTINUE
      END IF
*
*     Find the index (from R1 to R2) of the largest (in magnitude)
*     diagonal element of the inverse
*
      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
      IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
      IF( WANTNC ) THEN
         NEGCNT = NEG1 + NEG2
      ELSE
         NEGCNT = -1
      ENDIF
      IF( ABS(MINGMA).EQ.ZERO )
     $   MINGMA = EPS*WORK( INDS+R1-1 )
      R = R1
      DO 110 I = R1, R2 - 1
         TMP = WORK( INDS+I ) + WORK( INDP+I )
         IF( TMP.EQ.ZERO )
     $      TMP = EPS*WORK( INDS+I )
         IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
            MINGMA = TMP
            R = I + 1
         END IF
 110  CONTINUE
*
*     Compute the FP vector: solve N^T v = e_r
*
      ISUPPZ( 1 ) = B1
      ISUPPZ( 2 ) = BN
      Z( R ) = CONE
      ZTZ = ONE
*
*     Compute the FP vector upwards from R
*
      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
         DO 210 I = R-1, B1, -1
            Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
     $           THEN
               Z( I ) = ZERO
               ISUPPZ( 1 ) = I + 1
               GOTO 220
            ENDIF
            ZTZ = ZTZ + DBLE( Z( I )*Z( I ) )
 210     CONTINUE
 220     CONTINUE
      ELSE
*        Run slower loop if NaN occurred.
         DO 230 I = R - 1, B1, -1
            IF( Z( I+1 ).EQ.ZERO ) THEN
               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
            ELSE
               Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
            END IF
            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
     $           THEN
               Z( I ) = ZERO
               ISUPPZ( 1 ) = I + 1
               GO TO 240
            END IF
            ZTZ = ZTZ + DBLE( Z( I )*Z( I ) )
 230     CONTINUE
 240     CONTINUE
      ENDIF

*     Compute the FP vector downwards from R in blocks of size BLKSIZ
      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
         DO 250 I = R, BN-1
            Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
     $         THEN
               Z( I+1 ) = ZERO
               ISUPPZ( 2 ) = I
               GO TO 260
            END IF
            ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) )
 250     CONTINUE
 260     CONTINUE
      ELSE
*        Run slower loop if NaN occurred.
         DO 270 I = R, BN - 1
            IF( Z( I ).EQ.ZERO ) THEN
               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
            ELSE
               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
            END IF
            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
     $           THEN
               Z( I+1 ) = ZERO
               ISUPPZ( 2 ) = I
               GO TO 280
            END IF
            ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) )
 270     CONTINUE
 280     CONTINUE
      END IF
*
*     Compute quantities for convergence test
*
      TMP = ONE / ZTZ
      NRMINV = SQRT( TMP )
      RESID = ABS( MINGMA )*NRMINV
      RQCORR = MINGMA*TMP
*
*
      RETURN
*
*     End of ZLAR1V
*
      END


MODULE Netradiationmod
    IMPLICIT NONE
CONTAINS
    SUBROUTINE model_netradiation(minTair, &
        maxTair, &
        albedoCoefficient, &
        stefanBoltzman, &
        elevation, &
        solarRadiation, &
        vaporPressure, &
        extraSolarRadiation, &
        netRadiation, &
        netOutGoingLongWaveRadiation)
        REAL, INTENT(IN) :: minTair
        REAL, INTENT(IN) :: maxTair
        REAL, INTENT(IN) :: albedoCoefficient
        REAL, INTENT(IN) :: stefanBoltzman
        REAL, INTENT(IN) :: elevation
        REAL, INTENT(IN) :: solarRadiation
        REAL, INTENT(IN) :: vaporPressure
        REAL, INTENT(IN) :: extraSolarRadiation
        REAL, INTENT(OUT) :: netRadiation
        REAL, INTENT(OUT) :: netOutGoingLongWaveRadiation
        REAL:: Nsr
        REAL:: clearSkySolarRadiation
        REAL:: averageT
        REAL:: surfaceEmissivity
        REAL:: cloudCoverFactor
        REAL:: Nolr
        !- Description:
    !            - Model Name: NetRadiation Model
    !            - Author: Pierre Martre
    !            - Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            - Institution: INRA Montpellier
    !            - Abstract: It is calculated at the surface of the canopy and is givenby the difference between incoming and outgoing radiation of both short
    !                     and long wavelength radiation
        !- inputs:
    !            - name: minTair
    !                          - description : minimum air temperature
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : -30
    !                          - max : 45
    !                          - default : 0.7
    !                          - unit : °C
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
    !            - name: maxTair
    !                          - description : maximum air Temperature
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : -30
    !                          - max : 45
    !                          - default : 7.2
    !                          - unit : °C
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
    !            - name: albedoCoefficient
    !                          - description : albedo Coefficient
    !                          - parametercategory : constant
    !                          - datatype : DOUBLE
    !                          - default : 0.23
    !                          - min : 0
    !                          - max : 1
    !                          - unit :
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : parameter
    !            - name: stefanBoltzman
    !                          - description : stefan Boltzman constant
    !                          - parametercategory : constant
    !                          - datatype : DOUBLE
    !                          - default : 4.903E-09
    !                          - min : 0
    !                          - max : 1
    !                          - unit :
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : parameter
    !            - name: elevation
    !                          - description : elevation
    !                          - parametercategory : constant
    !                          - datatype : DOUBLE
    !                          - default : 0
    !                          - min : -500
    !                          - max : 10000
    !                          - unit : m
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : parameter
    !            - name: solarRadiation
    !                          - description : solar Radiation
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - default : 3
    !                          - min : 0
    !                          - max : 1000
    !                          - unit : MJ m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
    !            - name: vaporPressure
    !                          - description : vapor Pressure
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - default : 6.1
    !                          - min : 0
    !                          - max : 1000
    !                          - unit : hPa
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
    !            - name: extraSolarRadiation
    !                          - description : extra Solar Radiation
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - default : 11.7
    !                          - min : 0
    !                          - max : 1000
    !                          - unit : MJ m2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          - inputtype : variable
        !- outputs:
    !            - name: netRadiation
    !                          - description :  net radiation
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 5000
    !                          - unit : MJ m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !            - name: netOutGoingLongWaveRadiation
    !                          - description : net OutGoing Long Wave Radiation
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 5000
    !                          - unit : g m-2 d-1
    !                          - uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        Nsr = (1.0 - albedoCoefficient) * solarRadiation
        clearSkySolarRadiation = (0.75 + (2 *  (10.0 ** (-5)) * elevation)) *  &
                extraSolarRadiation
        averageT = ( ((maxTair + 273.16) ** 4) +  ((minTair + 273.16) ** 4))  &
                / 2.0
        surfaceEmissivity = 0.34 - (0.14 * SQRT(vaporPressure / 10.0))
        cloudCoverFactor = 1.35 * (solarRadiation / clearSkySolarRadiation) -  &
                0.35
        Nolr = stefanBoltzman * averageT * surfaceEmissivity *  &
                cloudCoverFactor
        netRadiation = Nsr - Nolr
        netOutGoingLongWaveRadiation = Nolr
    END SUBROUTINE model_netradiation

END MODULE


      SUBROUTINE sinft(y,n)
      INTEGER n
      REAL y(n)
CU    USES realft
      INTEGER j
      REAL sum,y1,y2
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      theta=3.141592653589793d0/dble(n)
      wr=1.0d0
      wi=0.0d0
      wpr=-2.0d0*sin(0.5d0*theta)**2
      wpi=sin(theta)
      y(1)=0.0
      do 11 j=1,n/2
        wtemp=wr
        wr=wr*wpr-wi*wpi+wr
        wi=wi*wpr+wtemp*wpi+wi
        y1=wi*(y(j+1)+y(n-j+1))
        y2=0.5*(y(j+1)-y(n-j+1))
        y(j+1)=y1+y2
        y(n-j+1)=y1-y2
11    continue
      call realft(y,n,+1)
      sum=0.0
      y(1)=0.5*y(1)
      y(2)=0.0
      do 12 j=1,n-1,2
        sum=sum+y(j)
        y(j)=y(j+1)
        y(j+1)=sum
12    continue
      return
      END

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


!----------------------------------------------------------------
! (c) Copyright, 2011 by the Regents of the University of California.
! Version: 1.0
! Author: Ji Qiang, LBNL
!---------------
! convert from the Trace3d twiss parameter to the IMPACT input distribution parameters.
! Here, the TRACE3d units are, alpha, beta (m/rad), emittance (mm-mrad, rms, unnormalized)
!                              alpha_z,beta_z (deg/keV), emittance (deg-keV,rms)
!
      program Tr2Impact
      implicit none
!-----File Tr2Impact.f90:  Generates IMPACT input distribution from
!     "beam.dat" Trace3D twiss parameter file

      double precision alpha, beta, eps  ! C-S parameters from beam.dat.
      double precision sig1, sig2, rho   ! IMPACT parameters for sim.dat.
      double precision mass,kine,bgamma,bbeta,pi,clight,rad2deg,xl,freq
      integer i

      open(2,file='sim.dat',status='unknown')
      open(3,file='beam.dat',status='old')

      pi=4.d0*atan(1.d0)
      clight = 2.99792458e8
      rad2deg = 180.0/pi
      read(3,*)freq,mass,kine
      bgamma = 1 + kine/mass
      bbeta = sqrt(1.0-1.0/bgamma/bgamma)
      xl=clight/(2.d0*pi*freq)     ! Length scale
      do i=1,3
        read(3,*) alpha, beta, eps
        !-----Change units
        if (i.ne.3) then
           eps=1.0d-6*eps  ! unnormalized emittance
           sig1=sqrt(beta*eps/(1.d0+alpha**2))
           !gammabeta is needed because <x'^2>=emittance*gamma instead of <(px/mc)^2>
           sig2=sqrt(eps/beta)*bgamma*bbeta
           !sig2=sqrt(eps/beta) !correct for x' or px/p0 as independent variable
           rho=alpha/sqrt(1.d0+alpha**2)
           write(2,'(3e15.7,4f7.3)') sig1/xl, sig2, rho, 1.0, 1.0, 0.0, 0.0
        else
           beta=1000.d0*beta
           eps=1.0d-3*eps
           sig1=sqrt(beta*eps/(1.d0+alpha**2))/rad2deg
           sig2=sqrt(eps/beta)/mass*1.0e6
           !sig2=sqrt(eps/beta)/mass  !//old wrong one
           rho=-alpha/sqrt(1.d0+alpha**2)
           write(2,'(3e15.7,4f7.3)') sig1, sig2, rho, 1.0, 1.0, 0.0, 0.0
        endif
      enddo

      close(2)
      close(3)

      end program Tr2Impact
!-------------------------------------


! Licensed under a 3-clause BSD style license - see LICENSE

module misc_functions_fortran
! This module provides the Fortran code for the handling of various miscellaneous functions,
! not tied to one specific sub-section of the codebase.
implicit none
integer, parameter :: dp = kind(0.0d0)  ! double precision
real(dp), parameter :: pi = 4.0_dp*atan(1.0_dp)

contains

subroutine haversine_wrapper(lon1, lon2, lat1, lat2, hav_dist)
    ! Wrapper for the haversine formula in shared_library.f90.
    integer, parameter :: dp = kind(0.0d0)  ! double precision
    ! On sky longitudes and latitudes of the two sources for which we wish to find a separation.
    real(dp), intent(in) :: lon1, lon2, lat1, lat2
    ! On-sky, Haversine separation of the two sources in question.
    real(dp), intent(out) :: hav_dist

    call haversine(lon1, lon2, lat1, lat2, hav_dist)

end subroutine haversine_wrapper

subroutine find_nearest_point(source_lon, source_lat, point_lon, point_lat, point_ind)
    ! Find the nearest on-sky distance between a series of coordinates and another list of positions.
    integer, parameter :: dp = kind(0.0d0)  ! double precision
    ! 1-D arrays of longitudes and latitudes (or equivalent) to search the nearest point of.
    real(dp), intent(in) :: source_lon(:), source_lat(:)
    ! 1-D arrays of lon & lat (consistent with source_lon & source_lat) points that positons are
    ! sampled from.
    real(dp), intent(in) :: point_lon(:), point_lat(:)
    ! 1-D array of indices, for each source position, of the closest position.
    integer, intent(out) :: point_ind(size(source_lon))
    ! Loop counters
    integer :: i, j
    ! Great-circle distance
    real(dp) :: hav_dist, min_hav_dist

    !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i, min_hav_dist, hav_dist) SHARED(source_lon, source_lat, point_lon, &
    !$OMP& point_lat, point_ind)
    do i = 1, size(source_lon)
        min_hav_dist = 9999.9_dp
        do j = 1, size(point_lon)
            call haversine(source_lon(i), point_lon(j), source_lat(i), point_lat(j), hav_dist)
            if (hav_dist < min_hav_dist) then
                point_ind(i) = j - 1  ! pre-convert one-index fortran to zero-index python indices
                min_hav_dist = hav_dist
            end if
        end do
    end do
    !$OMP END PARALLEL DO

end subroutine find_nearest_point

subroutine calc_j0(r, r0, j0s)
    ! Wrapper for jy01a_j0, to calculate the Bessel Function of First Kind of
    ! Zeroth Order for arrays of rs and rhos.
    integer, parameter :: dp = kind(0.0d0)  ! double precision
    ! Input r/rho arrays.
    real(dp), intent(in) :: r(:), r0(:)
    ! Output J0(x) values, where x = 2 pi r rho.
    real(dp), intent(out) :: j0s(size(r), size(r0))
    ! Loop counter integers.
    integer :: i, j
    ! Temporary holding variable, where z = 2 pi r rho.
    real(dp) :: z

!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i, j, z) SHARED(r, r0, j0s) COLLAPSE(2)
    do i = 1, size(r0)
        do j = 1, size(r)
            z = r(j)*r0(i)*2.0_dp*pi
            call jy01a_j0(z, j0s(j, i))
        end do
    end do
!$OMP END PARALLEL DO

end subroutine calc_j0

end module misc_functions_fortran


MODULE Nelder_Mead

IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60)
PRIVATE
PUBLIC :: minim

CONTAINS

SUBROUTINE minim(p, step, nop, func, maxfn, iprint, stopcr, nloop, iquad,  &
                 simp, var, functn, ifault)

!     A PROGRAM FOR FUNCTION MINIMIZATION USING THE SIMPLEX METHOD.

!     FOR DETAILS, SEE NELDER & MEAD, THE COMPUTER JOURNAL, JANUARY 1965

!     PROGRAMMED BY D.E.SHAW,
!     CSIRO, DIVISION OF MATHEMATICS & STATISTICS
!     P.O. BOX 218, LINDFIELD, N.S.W. 2070

!     WITH AMENDMENTS BY R.W.M.WEDDERBURN
!     ROTHAMSTED EXPERIMENTAL STATION
!     HARPENDEN, HERTFORDSHIRE, ENGLAND

!     Further amended by Alan Miller
!     CSIRO Division of Mathematical & Information Sciences
!     Private Bag 10, CLAYTON, VIC. 3169

!     Fortran 90 conversion by Alan Miller, June 1995
!     Alan.Miller @ vic.cmis.csiro.au
!     Latest revision - 5 December 1999

!     ARGUMENTS:-
!     P()     = INPUT, STARTING VALUES OF PARAMETERS
!               OUTPUT, FINAL VALUES OF PARAMETERS
!     STEP()  = INPUT, INITIAL STEP SIZES
!     NOP     = INPUT, NO. OF PARAMETERS, INCL. ANY TO BE HELD FIXED
!     FUNC    = OUTPUT, THE FUNCTION VALUE CORRESPONDING TO THE FINAL
!                 PARAMETER VALUES.
!     maxfn     = INPUT, THE MAXIMUM NO. OF FUNCTION EVALUATIONS ALLOWED.
!               Say, 20 times the number of parameters, NOP.
!     IPRINT  = INPUT, PRINT CONTROL PARAMETER
!                 < 0 NO PRINTING
!                 = 0 PRINTING OF PARAMETER VALUES AND THE FUNCTION
!                     VALUE AFTER INITIAL EVIDENCE OF CONVERGENCE.
!                 > 0 AS FOR IPRINT = 0 PLUS PROGRESS REPORTS AFTER EVERY
!                     IPRINT EVALUATIONS, PLUS PRINTING FOR THE INITIAL SIMPLEX.
!     STOPCR  = INPUT, STOPPING CRITERION.
!               The criterion is applied to the standard deviation of
!               the values of FUNC at the points of the simplex.
!     NLOOP   = INPUT, THE STOPPING RULE IS APPLIED AFTER EVERY NLOOP
!               FUNCTION EVALUATIONS.   Normally NLOOP should be slightly
!               greater than NOP, say NLOOP = 2*NOP.
!     IQUAD   = INPUT, = 1 IF FITTING OF A QUADRATIC SURFACE IS REQUIRED
!                      = 0 IF NOT
!               N.B. The fitting of a quadratic surface is strongly
!               recommended, provided that the fitted function is
!               continuous in the vicinity of the minimum.   It is often
!               a good indicator of whether a premature termination of
!               the search has occurred.
!     SIMP    = INPUT, CRITERION FOR EXPANDING THE SIMPLEX TO OVERCOME
!               ROUNDING ERRORS BEFORE FITTING THE QUADRATIC SURFACE.
!               The simplex is expanded so that the function values at
!               the points of the simplex exceed those at the supposed
!               minimum by at least an amount SIMP.
!     VAR()   = OUTPUT, CONTAINS THE DIAGONAL ELEMENTS OF THE INVERSE OF
!               THE INFORMATION MATRIX.
!     FUNCTN  = INPUT, NAME OF THE USER'S SUBROUTINE - ARGUMENTS (P,FUNC)
!               WHICH RETURNS THE FUNCTION VALUE FOR A GIVEN SET OF
!               PARAMETER VALUES IN ARRAY P.
!****     FUNCTN MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
!     IFAULT  = OUTPUT, = 0 FOR SUCCESSFUL TERMINATION
!                 = 1 IF MAXIMUM NO. OF FUNCTION EVALUATIONS EXCEEDED
!                 = 2 IF INFORMATION MATRIX IS NOT +VE SEMI-DEFINITE
!                 = 3 IF NOP < 1
!                 = 4 IF NLOOP < 1

!     N.B. P, STEP AND VAR (IF IQUAD = 1) MUST HAVE DIMENSION AT LEAST NOP
!          IN THE CALLING PROGRAM.

!*****************************************************************************

INTEGER, INTENT(IN)        :: nop, maxfn, iprint, nloop, iquad
INTEGER, INTENT(OUT)       :: ifault
REAL (dp), INTENT(IN)      :: stopcr, simp
REAL (dp), INTENT(IN OUT)  :: p(:), step(:)
REAL (dp), INTENT(OUT)     :: var(:), func

INTERFACE
  SUBROUTINE functn(p, func)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: p(:)
    REAL (dp), INTENT(OUT) :: func
  END SUBROUTINE functn
END INTERFACE

!     Local variables

REAL (dp)   :: g(nop+1,nop), h(nop+1), pbar(nop), pstar(nop), pstst(nop), &
               aval(nop), pmin(nop), temp(nop), bmat(nop*(nop+1)/2),  &
               vc(nop*(nop+1)/2), ymin, rmax, hstst, a0, hmin, test, hmean, &
               hstd, hstar, hmax, savemn

REAL (dp), PARAMETER :: zero = 0._dp, half = 0.5_dp, one = 1._dp, two = 2._dp
INTEGER     :: i, i1, i2, iflag, ii, ij, imax, imin, irank, irow, j, j1, jj, &
               k, l, loop, nap, neval, nmore, np1, nullty

!     A = REFLECTION COEFFICIENT, B = CONTRACTION COEFFICIENT, AND
!     C = EXPANSION COEFFICIENT.

REAL (dp), PARAMETER :: a = 1._dp, b = 0.5_dp, c = 2._dp

!     SET LOUT = LOGICAL UNIT NO. FOR OUTPUT

INTEGER, PARAMETER :: lout = 6

!     IF PROGRESS REPORTS HAVE BEEN REQUESTED, PRINT HEADING

IF (iprint > 0) WRITE (lout,5000) iprint

!     CHECK INPUT ARGUMENTS

ifault = 0
IF (nop <= 0) ifault = 3
IF (nloop <= 0) ifault = 4
IF (ifault /= 0) RETURN

!     SET NAP = NO. OF PARAMETERS TO BE VARIED, I.E. WITH STEP /= 0

nap = COUNT(step /= zero)
neval = 0
loop = 0
iflag = 0

!     IF NAP = 0 EVALUATE FUNCTION AT THE STARTING POINT AND RETURN

IF (nap <= 0) THEN
  CALL functn(p,func)
  RETURN
END IF

!     SET UP THE INITIAL SIMPLEX

20 g(1,:) = p
irow = 2
DO i = 1, nop
  IF (step(i) /= zero) THEN
    g(irow,:) = p
    g(irow,i) = p(i) + step(i)
    irow = irow + 1
  END IF
END DO

np1 = nap + 1
DO i = 1, np1
  p = g(i,:)
  CALL functn(p,h(i))
  neval = neval + 1
  IF (iprint > 0) THEN
    WRITE (lout,5100) neval, h(i), p
  END IF
END DO

!     START OF MAIN CYCLE.

!     FIND MAX. & MIN. VALUES FOR CURRENT SIMPLEX (HMAX & HMIN).

Main_loop: DO
  loop = loop + 1
  imax = 1
  imin = 1
  hmax = h(1)
  hmin = h(1)
  DO i = 2, np1
    IF (h(i) > hmax) THEN
      imax = i
      hmax = h(i)
    ELSE
      IF (h(i) < hmin) THEN
        imin = i
        hmin = h(i)
      END IF
    END IF
  END DO

!     FIND THE CENTROID OF THE VERTICES OTHER THAN P(IMAX)

  pbar = zero
  DO i = 1, np1
    IF (i /= imax) THEN
      pbar = pbar + g(i,:)
    END IF
  END DO
  pbar = pbar / nap

!     REFLECT MAXIMUM THROUGH PBAR TO PSTAR,
!     HSTAR = FUNCTION VALUE AT PSTAR.

  pstar = a * (pbar - g(imax,:)) + pbar
  CALL functn(pstar,hstar)
  neval = neval + 1
  IF (iprint > 0) THEN
    IF (MOD(neval,iprint) == 0) WRITE (lout,5100) neval, hstar, pstar
  END IF

!     IF HSTAR < HMIN, REFLECT PBAR THROUGH PSTAR,
!     HSTST = FUNCTION VALUE AT PSTST.

  IF (hstar < hmin) THEN
    pstst = c * (pstar - pbar) + pbar
    CALL functn(pstst,hstst)
    neval = neval + 1
    IF (iprint > 0) THEN
      IF (MOD(neval,iprint) == 0) WRITE (lout,5100) neval, hstst, pstst
    END IF

!     IF HSTST < HMIN REPLACE CURRENT MAXIMUM POINT BY PSTST AND
!     HMAX BY HSTST, THEN TEST FOR CONVERGENCE.

    IF (hstst >= hmin) THEN   ! REPLACE MAXIMUM POINT BY PSTAR & H(IMAX) BY HSTAR.
      g(imax,:) = pstar
      h(imax) = hstar
    ELSE
      g(imax,:) = pstst
      h(imax) = hstst
    END IF
    GO TO 250
  END IF

!     HSTAR IS NOT < HMIN.
!     TEST WHETHER IT IS < FUNCTION VALUE AT SOME POINT OTHER THAN
!     P(IMAX).   IF IT IS REPLACE P(IMAX) BY PSTAR & HMAX BY HSTAR.

  DO i = 1, np1
    IF (i /= imax) THEN
      IF (hstar < h(i)) THEN  ! REPLACE MAXIMUM POINT BY PSTAR & H(IMAX) BY HSTAR.
        g(imax,:) = pstar
        h(imax) = hstar
        GO TO 250
      END IF
    END IF
  END DO

!     HSTAR > ALL FUNCTION VALUES EXCEPT POSSIBLY HMAX.
!     IF HSTAR <= HMAX, REPLACE P(IMAX) BY PSTAR & HMAX BY HSTAR.

  IF (hstar <= hmax) THEN
    g(imax,:) = pstar
    hmax = hstar
    h(imax) = hstar
  END IF

!     CONTRACTED STEP TO THE POINT PSTST,
!     HSTST = FUNCTION VALUE AT PSTST.

  pstst = b * g(imax,:) + (one-b) * pbar
  CALL functn(pstst,hstst)
  neval = neval + 1
  IF (iprint > 0) THEN
    IF (MOD(neval,iprint) == 0) WRITE (lout,5100) neval, hstst, pstst
  END IF

!     IF HSTST < HMAX REPLACE P(IMAX) BY PSTST & HMAX BY HSTST.

  IF (hstst <= hmax) THEN
    g(imax,:) = pstst
    h(imax) = hstst
    GO TO 250
  END IF

!     HSTST > HMAX.
!     SHRINK THE SIMPLEX BY REPLACING EACH POINT, OTHER THAN THE CURRENT
!     MINIMUM, BY A POINT MID-WAY BETWEEN ITS CURRENT POSITION AND THE
!     MINIMUM.

  DO i = 1, np1
    IF (i /= imin) THEN
      DO j = 1, nop
        IF (step(j) /= zero) g(i,j) = (g(i,j) + g(imin,j)) * half
        p(j) = g(i,j)
      END DO
      CALL functn(p,h(i))
      neval = neval + 1
      IF (iprint > 0) THEN
        IF (MOD(neval,iprint) == 0) WRITE (lout,5100) neval, h(i), p
      END IF
    END IF
  END DO

!     IF LOOP = NLOOP TEST FOR CONVERGENCE, OTHERWISE REPEAT MAIN CYCLE.

  250 IF (loop < nloop) CYCLE Main_loop

!     CALCULATE MEAN & STANDARD DEVIATION OF FUNCTION VALUES FOR THE
!     CURRENT SIMPLEX.

  hmean = SUM( h(1:np1) ) / np1
  hstd = SUM( (h(1:np1) - hmean) ** 2 )
  hstd = SQRT(hstd / np1)

!     IF THE RMS > STOPCR, SET IFLAG & LOOP TO ZERO AND GO TO THE
!     START OF THE MAIN CYCLE AGAIN.

  IF (hstd > stopcr .AND. neval <= maxfn) THEN
    iflag = 0
    loop = 0
    CYCLE Main_loop
  END IF

!     FIND THE CENTROID OF THE CURRENT SIMPLEX AND THE FUNCTION VALUE THERE.

  DO i = 1, nop
    IF (step(i) /= zero) THEN
      p(i) = SUM( g(1:np1,i) ) / np1
    END IF
  END DO
  CALL functn(p,func)
  neval = neval + 1
  IF (iprint > 0) THEN
    IF (MOD(neval,iprint) == 0) WRITE (lout,5100) neval, func, p
  END IF

!     TEST WHETHER THE NO. OF FUNCTION VALUES ALLOWED, maxfn, HAS BEEN
!     OVERRUN; IF SO, EXIT WITH IFAULT = 1.

  IF (neval > maxfn) THEN
    ifault = 1
    IF (iprint < 0) RETURN
    WRITE (lout,5200) maxfn
    WRITE (lout,5300) hstd
    WRITE (lout,5400) p
    WRITE (lout,5500) func
    RETURN
  END IF

!     CONVERGENCE CRITERION SATISFIED.
!     IF IFLAG = 0, SET IFLAG & SAVE HMEAN.
!     IF IFLAG = 1 & CHANGE IN HMEAN <= STOPCR THEN SEARCH IS COMPLETE.

  IF (iprint >= 0) THEN
    WRITE (lout,5600)
    WRITE (lout,5400) p
    WRITE (lout,5500) func
  END IF

  IF (iflag == 0 .OR. ABS(savemn-hmean) >= stopcr) THEN
    iflag = 1
    savemn = hmean
    loop = 0
  ELSE
    EXIT Main_loop
  END IF

END DO Main_loop

IF (iprint >= 0) THEN
  WRITE (lout,5700) neval
  WRITE (lout,5800) p
  WRITE (lout,5900) func
END IF
IF (iquad <= 0) RETURN

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

!     QUADRATIC SURFACE FITTING

IF (iprint >= 0) WRITE (lout,6000)

!     EXPAND THE FINAL SIMPLEX, IF NECESSARY, TO OVERCOME ROUNDING
!     ERRORS.

hmin = func
nmore = 0
DO i = 1, np1
  DO
    test = ABS(h(i)-func)
    IF (test < simp) THEN
      DO j = 1, nop
        IF (step(j) /= zero) g(i,j) = (g(i,j)-p(j)) + g(i,j)
        pstst(j) = g(i,j)
      END DO
      CALL functn(pstst,h(i))
      nmore = nmore + 1
      neval = neval + 1
      IF (h(i) >= hmin) CYCLE
      hmin = h(i)
      IF (iprint >= 0) WRITE (lout,5100) neval, hmin, pstst
    ELSE
      EXIT
    END IF
  END DO
END DO

!     FUNCTION VALUES ARE CALCULATED AT AN ADDITIONAL NAP POINTS.

DO i = 1, nap
  i1 = i + 1
  pstar = (g(1,:) + g(i1,:)) * half
  CALL functn(pstar,aval(i))
  nmore = nmore + 1
  neval = neval + 1
END DO

!     THE MATRIX OF ESTIMATED SECOND DERIVATIVES IS CALCULATED AND ITS
!     LOWER TRIANGLE STORED IN BMAT.

a0 = h(1)
DO i = 1, nap
  i1 = i - 1
  i2 = i + 1
  DO j = 1, i1
    j1 = j + 1
    pstst = (g(i2,:) + g(j1,:)) * half
    CALL functn(pstst,hstst)
    nmore = nmore + 1
    neval = neval + 1
    l = i * (i-1) / 2 + j
    bmat(l) = two * (hstst + a0 - aval(i) - aval(j))
  END DO
END DO

l = 0
DO i = 1, nap
  i1 = i + 1
  l = l + i
  bmat(l) = two * (h(i1) + a0 - two*aval(i))
END DO

!     THE VECTOR OF ESTIMATED FIRST DERIVATIVES IS CALCULATED AND
!     STORED IN AVAL.

DO i = 1, nap
  i1 = i + 1
  aval(i) = two * aval(i) - (h(i1) + 3._dp*a0) * half
END DO

!     THE MATRIX Q OF NELDER & MEAD IS CALCULATED AND STORED IN G.

pmin = g(1,:)
DO i = 1, nap
  i1 = i + 1
  g(i1,:) = g(i1,:) - g(1,:)
END DO

DO i = 1, nap
  i1 = i + 1
  g(i,:) = g(i1,:)
END DO

!     INVERT BMAT

CALL syminv(bmat, nap, bmat, temp, nullty, ifault, rmax)
IF (ifault == 0) THEN
  irank = nap - nullty
ELSE                                 ! BMAT not +ve definite
                                     ! Resume search for the minimum
  IF (iprint >= 0) WRITE (lout,6100)
  ifault = 2
  IF (neval > maxfn) RETURN
  WRITE (lout,6200)
  step = half * step
  GO TO 20
END IF

!     BMAT*A/2 IS CALCULATED AND STORED IN H.

DO i = 1, nap
  h(i) = zero
  DO j = 1, nap
    IF (j <= i) THEN
      l = i * (i-1) / 2 + j
    ELSE
      l = j * (j-1) / 2 + i
    END IF
    h(i) = h(i) + bmat(l) * aval(j)
  END DO
END DO

!     FIND THE POSITION, PMIN, & VALUE, YMIN, OF THE MINIMUM OF THE
!     QUADRATIC.

ymin = DOT_PRODUCT( h(1:nap), aval(1:nap) )
ymin = a0 - ymin
DO i = 1, nop
  pstst(i) = DOT_PRODUCT( h(1:nap), g(1:nap,i) )
END DO
pmin = pmin - pstst
IF (iprint >= 0) THEN
  WRITE (lout,6300) ymin, pmin
  WRITE (lout,6400)
END IF

!     Q*BMAT*Q'/2 IS CALCULATED & ITS LOWER TRIANGLE STORED IN VC

DO i = 1, nop
  DO j = 1, nap
    h(j) = zero
    DO k = 1, nap
      IF (k <= j) THEN
        l = j * (j-1) / 2 + k
      ELSE
        l = k * (k-1) / 2 + j
      END IF
      h(j) = h(j) + bmat(l) * g(k,i) * half
    END DO
  END DO

  DO j = i, nop
    l = j * (j-1) / 2 + i
    vc(l) = DOT_PRODUCT( h(1:nap), g(1:nap,j) )
  END DO
END DO

!     THE DIAGONAL ELEMENTS OF VC ARE COPIED INTO VAR.

j = 0
DO i = 1, nop
  j = j + i
  var(i) = vc(j)
END DO
IF (iprint < 0) RETURN
WRITE (lout,6500) irank
CALL print_tri_matrix(vc, nop, lout)

WRITE (lout,6600)
CALL syminv(vc, nap, bmat, temp, nullty, ifault, rmax)

!     BMAT NOW CONTAINS THE INFORMATION MATRIX

WRITE (lout,6700)
CALL print_tri_matrix(bmat, nop, lout)

ii = 0
ij = 0
DO i = 1, nop
  ii = ii + i
  IF (vc(ii) > zero) THEN
    vc(ii) = one / SQRT(vc(ii))
  ELSE
    vc(ii) = zero
  END IF
  jj = 0
  DO j = 1, i - 1
    jj = jj + j
    ij = ij + 1
    vc(ij) = vc(ij) * vc(ii) * vc(jj)
  END DO
  ij = ij + 1
END DO

WRITE (lout,6800)
ii = 0
DO i = 1, nop
  ii = ii + i
  IF (vc(ii) /= zero) vc(ii) = one
END DO
CALL print_tri_matrix(vc, nop, lout)

!     Exit, on successful termination.

WRITE (lout,6900) nmore
RETURN

5000 FORMAT (' Progress Report every',i4,' function evaluations'/  &
             ' EVAL.   FUNC.VALUE.          PARAMETER VALUES')
5100 FORMAT (/' ', i4, '  ', g12.5, '  ', 5G11.4, 3(/t22, 5G11.4))
5200 FORMAT (' No. of function evaluations > ',i5)
5300 FORMAT (' RMS of function values of last simplex =', g14.6)
5400 FORMAT (' Centroid of last simplex =',4(/' ', 6G13.5))
5500 FORMAT (' Function value at centroid =', g14.6)
5600 FORMAT (/' EVIDENCE OF CONVERGENCE')
5700 FORMAT (/' Minimum found after',i5,' function evaluations')
5800 FORMAT (' Minimum at',4(/' ', 6G13.6))
5900 FORMAT (' Function value at minimum =', g14.6)
6000 FORMAT (/' Fitting quadratic surface about supposed minimum'/)
6100 FORMAT (/' MATRIX OF ESTIMATED SECOND DERIVATIVES NOT +VE DEFN.'/ &
             ' MINIMUM PROBABLY NOT FOUND'/)
6200 FORMAT (/t11, 'Search restarting'/)
6300 FORMAT (' Minimum of quadratic surface =',g14.6,' at',4(/' ', 6G13.5))
6400 FORMAT (' IF THIS DIFFERS BY MUCH FROM THE MINIMUM ESTIMATED ',      &
             'FROM THE MINIMIZATION,'/' THE MINIMUM MAY BE FALSE &/OR THE ',  &
             'INFORMATION MATRIX MAY BE INACCURATE'/)
6500 FORMAT (' Rank of information matrix =',i3/ &
             ' Inverse of information matrix:-')
6600 FORMAT (/' If the function minimized was -LOG(LIKELIHOOD),'/         &
             ' this is the covariance matrix of the parameters.'/         &
             ' If the function was a sum of squares of residuals,'/       &
             ' this matrix must be multiplied by twice the estimated ',   &
             'residual variance'/' to obtain the covariance matrix.'/)
6700 FORMAT (' INFORMATION MATRIX:-'/)
6800 FORMAT (/' CORRELATION MATRIX:-')
6900 FORMAT (/' A further',i4,' function evaluations have been used'/)

END SUBROUTINE minim

SUBROUTINE syminv(a, n, c, w, nullty, ifault, rmax)

!     ALGORITHM AS7, APPLIED STATISTICS, VOL.17, 1968.

!     ARGUMENTS:-
!     A()    = INPUT, THE SYMMETRIC MATRIX TO BE INVERTED, STORED IN
!                LOWER TRIANGULAR FORM
!     N      = INPUT, ORDER OF THE MATRIX
!     C()    = OUTPUT, THE INVERSE OF A (A GENERALIZED INVERSE IF C IS
!                SINGULAR), ALSO STORED IN LOWER TRIANGULAR FORM.
!                C AND A MAY OCCUPY THE SAME LOCATIONS.
!     W()    = WORKSPACE, DIMENSION AT LEAST N.
!     NULLTY = OUTPUT, THE RANK DEFICIENCY OF A.
!     IFAULT = OUTPUT, ERROR INDICATOR
!                 = 1 IF N < 1
!                 = 2 IF A IS NOT +VE SEMI-DEFINITE
!                 = 0 OTHERWISE
!     RMAX   = OUTPUT, APPROXIMATE BOUND ON THE ACCURACY OF THE DIAGONAL
!                ELEMENTS OF C.  E.G. IF RMAX = 1.E-04 THEN THE DIAGONAL
!                ELEMENTS OF C WILL BE ACCURATE TO ABOUT 4 DEC. DIGITS.

!     LATEST REVISION - 1 April 1985

!***************************************************************************

REAL (dp), INTENT(IN OUT) :: a(:), c(:), w(:)
INTEGER, INTENT(IN)       :: n
INTEGER, INTENT(OUT)      :: nullty, ifault
REAL (dp), INTENT(OUT)    :: rmax

REAL (dp), PARAMETER :: zero = 0._dp, one = 1._dp
INTEGER              :: i, icol, irow, j, jcol, k, l, mdiag, ndiag, nn, nrow
REAL (dp)            :: x

nrow = n
ifault = 1
IF (nrow > 0) THEN
  ifault = 0

!     CHOLESKY FACTORIZATION OF A, RESULT IN C

  CALL chola(a, nrow, c, nullty, ifault, rmax, w)
  IF (ifault == 0) THEN

!     INVERT C & FORM THE PRODUCT (CINV)'*CINV, WHERE CINV IS THE INVERSE
!     OF C, ROW BY ROW STARTING WITH THE LAST ROW.
!     IROW = THE ROW NUMBER, NDIAG = LOCATION OF LAST ELEMENT IN THE ROW.

    nn = nrow * (nrow+1) / 2
    irow = nrow
    ndiag = nn
    10 IF (c(ndiag) /= zero) THEN
      l = ndiag
      DO i = irow, nrow
        w(i) = c(l)
        l = l + i
      END DO
      icol = nrow
      jcol = nn
      mdiag = nn

      30 l = jcol
      x = zero
      IF (icol == irow) x = one / w(irow)
      k = nrow
      40 IF (k /= irow) THEN
        x = x - w(k) * c(l)
        k = k - 1
        l = l - 1
        IF (l > mdiag) l = l - k + 1
        GO TO 40
      END IF

      c(l) = x / w(irow)
      IF (icol == irow) GO TO 60
      mdiag = mdiag - icol
      icol = icol - 1
      jcol = jcol - 1
      GO TO 30
    END IF ! (c(ndiag) /= zero)

    l = ndiag
    DO j = irow, nrow
      c(l) = zero
      l = l + j
    END DO

    60 ndiag = ndiag - irow
    irow = irow - 1
    IF (irow /= 0) GO TO 10
  END IF
END IF
RETURN

END SUBROUTINE syminv

SUBROUTINE chola(a, n, u, nullty, ifault, rmax, r)

!     ALGORITHM AS6, APPLIED STATISTICS, VOL.17, 1968, WITH
!     MODIFICATIONS BY A.J.MILLER

!     ARGUMENTS:-
!     A()    = INPUT, A +VE DEFINITE MATRIX STORED IN LOWER-TRIANGULAR
!                FORM.
!     N      = INPUT, THE ORDER OF A
!     U()    = OUTPUT, A LOWER TRIANGULAR MATRIX SUCH THAT U*U' = A.
!                A & U MAY OCCUPY THE SAME LOCATIONS.
!     NULLTY = OUTPUT, THE RANK DEFICIENCY OF A.
!     IFAULT = OUTPUT, ERROR INDICATOR
!                 = 1 IF N < 1
!                 = 2 IF A IS NOT +VE SEMI-DEFINITE
!                 = 0 OTHERWISE
!     RMAX   = OUTPUT, AN ESTIMATE OF THE RELATIVE ACCURACY OF THE
!                DIAGONAL ELEMENTS OF U.
!     R()    = OUTPUT, ARRAY CONTAINING BOUNDS ON THE RELATIVE ACCURACY
!                OF EACH DIAGONAL ELEMENT OF U.

!     LATEST REVISION - 1 April 1985

!***************************************************************************

REAL (dp), INTENT(IN)   :: a(:)
INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: u(:)
INTEGER, INTENT(OUT)    :: nullty, ifault
REAL (dp), INTENT(OUT)  :: rmax, r(:)

!     ETA SHOULD BE SET EQUAL TO THE SMALLEST +VE VALUE SUCH THAT
!     1._dp + ETA IS CALCULATED AS BEING GREATER THAN 1._dp IN THE ACCURACY
!     BEING USED.

REAL (dp), PARAMETER :: eta = EPSILON(1.0_dp), zero = 0._dp
INTEGER              :: i, icol, irow, j, k, l, m
REAL (dp)            :: rsq, w

ifault = 1
IF (n > 0) THEN
  ifault = 2
  nullty = 0
  rmax = eta
  r(1) = eta
  j = 1
  k = 0

!     FACTORIZE COLUMN BY COLUMN, ICOL = COLUMN NO.

  DO  icol = 1, n
    l = 0

!     IROW = ROW NUMBER WITHIN COLUMN ICOL

    DO  irow = 1, icol
      k = k + 1
      w = a(k)
      IF (irow == icol) rsq = (w*eta) ** 2
      m = j
      DO  i = 1, irow
        l = l + 1
        IF (i == irow) EXIT
        w = w - u(l) * u(m)
        IF (irow == icol) rsq = rsq + (u(l)**2*r(i)) ** 2
        m = m + 1
      END DO

      IF (irow == icol) EXIT
      IF (u(l) /= zero) THEN
        u(k) = w / u(l)
      ELSE
        u(k) = zero
        IF (ABS(w) > ABS(rmax*a(k))) GO TO 60
      END IF
    END DO

!     END OF ROW, ESTIMATE RELATIVE ACCURACY OF DIAGONAL ELEMENT.

    rsq = SQRT(rsq)
    IF (ABS(w) > 5.*rsq) THEN
      IF (w < zero) RETURN
      u(k) = SQRT(w)
      r(i) = rsq / w
      IF (r(i) > rmax) rmax = r(i)
    ELSE
      u(k) = zero
      nullty = nullty + 1
    END IF

    j = j + icol
  END DO
  ifault = zero
END IF
60 RETURN

END SUBROUTINE chola

SUBROUTINE print_tri_matrix(a, n, lout)

INTEGER, INTENT(IN)    :: n, lout
REAL (dp), INTENT(IN)  :: a(:)

!     Local variables
INTEGER  :: i, ii, i1, i2, l

l = 1
DO l = 1, n, 6
  ii = l * (l-1) / 2
  DO i = l, n
    i1 = ii + l
    ii = ii + i
    i2 = MIN(ii,i1+5)
    WRITE (lout,'(1X,6G13.5)') a(i1:i2)
  END DO
END DO
RETURN

END SUBROUTINE print_tri_matrix

END MODULE Nelder_Mead


	SUBROUTINE LSFIT(Y,X,WT,N,A,B,RMS)
C
C	FIT Y = A*X + B
C
	DIMENSION Y(128),X(128),WT(128)
C
C
	SYY=0.
	SXY=0.
	SXX=0.
	SX=0.
	SY=0.
	SC=0.
	DO 1 J = 1,N
	   SYY=SYY+WT(J)*Y(J)**2
	   SXY=SXY+WT(J)*X(J)*Y(J)
	   SXX=SXX+WT(J)*X(J)**2
	   SX=SX+WT(J)*X(J)
	   SY=SY+WT(J)*Y(J)
	   SC=SC+WT(J)
 1	CONTINUE
	A=0.
	B=0.
	DEN=SXX*SC-SX*SX
	IF(DEN.EQ.0.) TYPE 101
	IF(DEN.EQ.0.) RETURN
	A=(SXY*SC-SY*SX)/DEN
	B=(SXX*SY-SX*SXY)/DEN
	SUMSQ=SYY+SXX*A**2+SC*B**2-2.*SXY*A-2.*SY*B+2.*SX*A*B
	SM=SUMSQ/SC
	RMS=SQRT(AMAX1(SM,0.))
	RETURN
C
C
 101	FORMAT(' VANISHING DETERMINANT IN LSFIT')
	END


c=======================================================================
c
c     Random Generators (for Linux/Unix platform)
c
c-----------------------------------------------------------------------
c
c        Fonctions List
c
c        rn      : generate Normal(0,1)
c        rns     : generate Normal(mean,std)
c        rus     : generate Uniform(mean,half interval)
c
c     author: Yann Vernaz
c
c=======================================================================
c
c     function rn
c
c     Standard Normal distribution generator N(0,1)
c     Transformation method
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION rn()
c-----------------------------------------------------------------------
c     OUTPUT
c       rn : generated normal deviate N(0,1)                      double
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     local variables
      DOUBLE PRECISION x1, x2, PI2, EPS
      PARAMETER ( PI2 = 6.283185307d0, EPS=1.d-15  )
      INTEGER init_seed_linux, s
c
c     external function
      EXTERNAL init_seed_linux
c
c     intrinsic functions
      INTRINSIC SQRT, LOG, COS
c
c     seeding function for UNIX FORTRAN random number generators
c     (cf. rne/random/init_seed_linux.f)
      s = init_seed_linux()
c
      x1 = rand(s)
      DO WHILE (x1 .LT. EPS)
         x1 = rand()
      ENDDO
      x2 = rand()
      rn = SQRT(-2.0*LOG(x1))*COS(PI2*x2)
      RETURN
      END
c
c=======================================================================
c
c     function rns
c
c     Standard Normal distribution generator N(mean,std)
c     with mean and standard deviation
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION rns ( mean, std )
c-----------------------------------------------------------------------
c
c     INPUT
c       mean : mean                                                double
c       std  : standard deviation                                  double
c
c     OUTPUT
c       rns  : generated normal deviate N(mean,std)                double
c
c     CALL
c       rn   : generate normal deviate N(0,1)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      DOUBLE PRECISION mean, std
c
c     external functions
      DOUBLE PRECISION rn, snorm
      EXTERNAL rn, snorm
c
      rns = rn()*std + mean
c
      RETURN
      END
c
c=======================================================================
c
c     function rus
c
c     Uniform distribution generator with mean and half interval
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION rus ( mean, hint )
c-----------------------------------------------------------------------
c
c     INPUT
c            mean   : mean of the normal distribution             double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT
c            rus    : scalar from an uniform distribution         double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      DOUBLE PRECISION mean, hint
c
c     local variables
      DOUBLE PRECISION x
      INTEGER init_seed_linux, s
c
c     external function
      EXTERNAL init_seed_linux
c
c     seeding function for UNIX FORTRAN random number generators
c     (cf. rne/random/init_seed_linux.f)
      s = init_seed_linux()
c
c     generate Uniform variate integer in the range [0,RAND_MAX]
      x = rand(s)
c
c     Uniform variate with mean
      rus = (x-0.5)*2.0*hint + mean
c
      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! FEAST Driver Example - CSR Storage
!!!!!!! solving Ax=eBx with A and B real non-symmetric (non-Hermitian)
!!!!!!! James Kestyn, Eric Polizzi 2015
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program driver

  implicit none
!!!!!!!!!!!!!!!!! Feast declaration variable
  integer,dimension(64) :: feastparam
  integer :: loop
!!!!!!!!!!!!!!!!! Matrix declaration variable
  character(len=100) :: name
  integer :: n,nnz
  double precision,dimension(:),allocatable :: sa,sb
  integer,dimension(:),allocatable :: isa,jsa

!!!!!!!!!!!!!!!!! Others
  integer :: t1,t2,tim
  integer :: i,k
  integer :: M0,M,info
  complex(kind=(kind(1.0d0))) :: Emid
  double precision :: r,epsout
  complex(kind=(kind(1.0d0))),dimension(:),allocatable :: E ! eigenvectors
  complex(kind=(kind(1.0d0))),dimension(:,:),allocatable :: X ! eigenvectors
  double precision,dimension(:),allocatable :: res ! eigenvalue+residual

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!! read input file in csr format!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  name='../../system3'

!!!!!!!!!! form CSR arrays isa,jsa,sa
  open(10,file=trim(name),status='old')
  read(10,*) n,nnz
  allocate(isa(1:N+1))
  isa=0
  isa(1)=1
  allocate(jsa(1:nnz))
  allocate(sa(1:nnz))
  allocate(sb(1:nnz))
  do k=1,nnz
     read(10,*) i,jsa(k),sa(k),sb(k)
     isa(i+1)=isa(i+1)+1
  end do
  close(10)
  do i=2,n+1
     isa(i)=isa(i)+isa(i-1)
  enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!! INFORMATION ABOUT MATRIX !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  print *,'sparse matrix -system3- size',n
  print *,'nnz',nnz

  call system_clock(t1,tim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!! FEAST in sparse format !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!! search interval [Emin,Emax] including M eigenpairs
  Emid=(0.59d0,0.0d0)
  r=0.4100d0
  M0=40 !! M0>=M

!!!!!!!!!!!!! ALLOCATE VARIABLE
  allocate(e(1:M0))     ! Eigenvalue
  allocate(X(1:n,1:2*M0)) ! Eigenvectors
  allocate(res(1:2*M0))   ! Residual (if needed)

!!!!!!!!!!!!!  FEAST
  call feastinit(feastparam)
  feastparam(1)=1
  call dfeast_gcsrgv(N,sa,isa,jsa,sb,isa,jsa,feastparam,epsout,loop,Emid,r,M0,E,X,M,res,info)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!! POST-PROCESSING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call system_clock(t2,tim)
  print *,'FEAST OUTPUT INFO',info
  if (info==0) then
     print *,'*************************************************'
     print *,'************** REPORT ***************************'
     print *,'*************************************************'
     print *,'SIMULATION TIME',(t2-t1)*1.0d0/tim
     print *,'# Search interval [Emin,Emax]',Emid,r
     print *,'# mode found/subspace',M,M0
     print *,'# iterations',loop
     print *,'TRACE',sum(E(1:M))
     print *,'Relative error on the Trace',epsout
     print *,'Eigenvalues/Residuals'
     do i=1,M
        print *,i,E(i),max(res(i),res(M0+i))
     enddo
  endif

end program driver


      PROGRAM MAIN
      INTEGER YEAR,I
      DOUBLE PRECISION T,L,LP,F,D,OM,X,DX,Y,DY,PM(2)
      DOUBLE PRECISION DUT1,DLOD,IANGLE(11),ANGLE(11),DAY
      DOUBLE PRECISION DLAT,DLON,AZ,EL,GRN,GRE,DMJD,PRES,TEMP
      DOUBLE PRECISION UNDU,FCUL_ZHD,FCUL_ZWD,FCUL_ZTD

*     ------------------------------------------------------------------------
*     FUNDARG
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function FUNDARG'
      WRITE (*,*) 'Abs. differences in radians'
      T = 0.07995893223819302D0
      CALL FUNDARG ( T, L, LP, F, D, OM )
      WRITE (*,10) '|dl|  = ',DABS (2.291187512612069099D0-L)
      WRITE (*,10) '|dlp| = ',DABS (6.212931111003726414D0-LP)
      WRITE (*,10) '|df|  = ',DABS (3.658025792050572989D0-F)
      WRITE (*,10) '|dd|  = ',DABS (4.554139562402433228D0-D)
      WRITE (*,10) '|dom| = ',DABS (-0.5167379217231804489D0-OM)
 10   FORMAT (A,F20.18)

*     ------------------------------------------------------------------------
*     FCNNUT
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function FCNNUT'
      WRITE (*,*) 'Abs. differences in microarcseconds:'
      T = 54790D0
      CALL FCNNUT ( T,X,Y,DX,DY )
      WRITE (*,11) '|dx|  = ',DABS (-176.8012290066270680D0-X)
      WRITE (*,11) '|dy|  = ',DABS (-93.51855308903756736D0-Y)
      WRITE (*,11) '|ddx| = ',DABS (3.745573770491803067D0-DX)
      WRITE (*,11) '|ddy| = ',DABS (3.745573770491803067D0-DY)
 11   FORMAT (A,F20.18)

*     ------------------------------------------------------------------------
*     PMSDNUT2
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function PMSDNUT2'
      WRITE (*,*) 'Abs. differences in microarcseconds:'
      T = 54335D0
      CALL PMSDNUT2 (T, PM)
      WRITE (*,12) '|pm(1)|  = ',DABS (24.83144238273364834D0-PM(1))
      WRITE (*,12) '|pm(2)|  = ',DABS (-14.09240692041837661D0-PM(2))
 12   FORMAT (A,F20.18)

*     ------------------------------------------------------------------------
*     UTLIBR
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function UTLIBR (test A)'
      WRITE (*,*) 'Abs. differences in mus and mus/day:'
      T = 44239.1D0
      CALL UTLIBR (T,DUT1,DLOD)
*      WRITE (*,*) '->test A.'
      WRITE (*,13) '|ddut1|  = ',DABS (2.441143834386761746D0-DUT1)
      WRITE (*,13) '|ddlod|  = ',DABS (-14.78971247349449492D0-DLOD)
      WRITE (*,*) 'Function UTLIBR (test B)'
      WRITE (*,*) 'Abs. differences in mus and mus/day:'
      T = 55227.4D0
      CALL UTLIBR (T,DUT1,DLOD)
*      WRITE (*,*) '->test B.'
      WRITE (*,13) '|ddut1|  = ',DABS (-2.655705844335680244D0-DUT1)
      WRITE (*,13) '|ddlod|  = ',DABS (27.39445826599846967D0-DLOD)
 13   FORMAT (A,F20.18)

*     ------------------------------------------------------------------------
*     ARG2
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function ARG2'
      WRITE (*,*) 'Abs. differences in radians:'
      ANGLE(1)  = 2.849663065753787805D0
      ANGLE(2)  = 6.28318080000000023D0
      ANGLE(3)  = 4.926040134021299366D0
      ANGLE(4)  = 1.608450491115348768D0
      ANGLE(5)  = 2.375021572352622456D0
      ANGLE(6)  = 0.4746414933980958040D0
      ANGLE(7)  = 3.908159227647345801D0
      ANGLE(8)  = 2.551018561669245344D0
      ANGLE(9)  = 5.041990012540757959D0
      ANGLE(10) = 4.206816878908014701D0
      ANGLE(11) = 1.608463638294885811D0
      YEAR = 2008
      DAY = 311.5D0
      CALL ARG2 (YEAR,DAY,IANGLE)
      DO I=1,11
        WRITE (*,14) '|dangle(',I,')|  = ', DABS (ANGLE(I)-IANGLE(I))
      ENDDO
 14   FORMAT (A,I0.2,A,F20.18)

*     ------------------------------------------------------------------------
*     RGZONT2
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function RG_ZONT2'
      WRITE (*,*) 'Abs. differences in (see results):'
      T = .07995893223819302D0;
      CALL RG_ZONT2 (T, X, DX, Y);
      WRITE (*,15) '|ddut|    = ',DABS(7.983287678576557467D-002
     .  -X),' seconds'
      WRITE (*,15) '|ddlod|   = ',DABS(5.035331113978199288D-005
     .  -DX),' seconds/day'
      WRITE (*,15) '|ddomega| = ',DABS(-4.249711616463017D-014
     .  -Y),' radians/second'
 15   FORMAT (A,F20.18,A)

*     ------------------------------------------------------------------------
*     ORTHO_EOP
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function ORTHO_EOP'
      WRITE (*,*) 'Abs. differences in microarcseconds:'
      T = 47100D0
      CALL ORTHO_EOP (T,ANGLE);
      WRITE (*,16) '|deop(1)|   = ',DABS(-162.8386373279636530D0
     . -ANGLE(1))
      WRITE (*,16) '|deop(2)|   = ',DABS(117.7907525842668974D0
     . -ANGLE(2))
      WRITE (*,16) '|deop(3)|   = ',DABS(-23.39092370609808214D0
     . -ANGLE(3))
 16   FORMAT (A,F20.18)

*     ------------------------------------------------------------------------
*     APG
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function APG'
      WRITE (*,*) 'Abs. differences in (see results):'
      DLAT = 0.6274877539940092D0
      DLON = 2.454994088489240D0
      AZ   = 0.2617993877991494D0
      EL   = 0.8726646259971648D0
      CALL APG (DLAT,DLON,AZ,EL,D,GRN,GRE)
      WRITE (*,17) '|dd|        = ',DABS(-0.9677190006296187757D-4
     . -D)
      WRITE (*,17) '|dgre|      = ',DABS(-0.1042668498001996791D0
     . -GRN)
      WRITE (*,17) '|dgrn|      = ',DABS(0.4662515377110782594D-1
     . -GRE)
 17   FORMAT (A,F20.18)

*     ------------------------------------------------------------------------
*     GPT
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function GPT'
      WRITE (*,*) 'Abs. differences in (see results):'
      CALL GPT (55055D0,0.6708665767D0,-1.393397187D0,812.546D0,
     . PRES,TEMP,UNDU)
      WRITE (*,18) '|dpres|     = ',DABS(918.0710638757363995D0
     . -PRES),' hPa'
      WRITE (*,18) '|dtemp|     = ',DABS(19.31914181012882992D0
     . -TEMP),' Celsius'
      WRITE (*,18) '|dundu|     = ',DABS(-42.19185643717770517D0
     . -UNDU),' meters'
 18   FORMAT (A,F20.18,A)

*     ------------------------------------------------------------------------
*     FCUL_ZD_HPA
*     ------------------------------------------------------------------------
      WRITE (*,*) 'Function FCUL_ZD_HPA'
      WRITE (*,*) 'Abs. differences in meters:'
      CALL FCULZD_HPA
     . (30.67166667D0,2010.344D0,798.4188D0,14.322D0,0.532D0,
     . FCUL_ZTD, FCUL_ZHD, FCUL_ZWD)
      WRITE (*,19) '|dfcul_ztd|= ',DABS(1.935225924846803114D0-FCUL_ZTD)
      WRITE (*,19) '|dfcul_zhd|= ',DABS(1.932992176591644462D0-FCUL_ZHD)
      WRITE (*,19) '|dfcul_zwd|= ',DABS(0.2233748255158703871D-02-
     . FCUL_ZWD)
 19   FORMAT (A,F20.18,A)

      END PROGRAM MAIN