! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! Test that nested array constructors are optimized.
program main
  implicit none
  integer, parameter :: dp=selected_real_kind(15)
  real(kind=dp), dimension(2,2) :: a
  real(kind=dp) thirteen

  data a /2._dp,3._dp,5._dp,7._dp/
  thirteen = 13._dp
  if (abs (product([[11._dp, thirteen], a]) - 30030._dp) > 1e-8) call abort
end program main
! { dg-final { scan-tree-dump-times "while" 2 "original" } }


module mod1
implicit none
save
integer, parameter :: precision=15, range=307
integer, parameter :: dp = selected_real_kind(precision, range)
real(dp), parameter :: pi=3.1415926539
real(dp), parameter :: RU=8314d0
real(dp), parameter :: zero=0._dp, one=1._dp

real(dp):: cp,cv,g,rgas,mw,vol=one,dia,cf,id,od,length,rref,rhos,psipa,pref
real(dp):: db=zero,dt,tmax,Tflame
real(dp):: thrust=zero, area, r, n, surf,mdotgen,mdotout,edotgen,edotout,energy
real(dp):: mdotos=zero, edotos, texit, dsigng,pamb,p,t
real(dp):: mcham,echam,time=zero
integer nsteps,i
real(dp), allocatable :: output(:,:)

end module

subroutine burnrate
  use mod1
  implicit none
  r=rref*(p/pref)**n ! calculate burn rate
  db=db+r*dt  ! calculate incremental burn distance
end subroutine

subroutine calcsurf
  ! cylinder burning from id outward and from both ends along the length
  use mod1
  implicit none

  surf=pi*(id+2.0d0*db)*(length-2.0d0*db)+0.5d0*pi*(od**2.0d0-(id+2.0*db)**2.0d0)

  if(id+2d0*db.gt.od.or.db.gt.length/2d0) THEN
     surf=0d0  ! we hit the wall and burned out
     r=0  ! turn off burn rate so burn distance stops increasing
   endif

vol=vol+r*surf*dt ! increment the interior volume of the chamber a little
end subroutine

subroutine calmdotgen
  use mod1
  implicit none
  mdotgen=rhos*r*surf
  edotgen=mdotgen*cp*Tflame
end subroutine

subroutine massflow
   USE mod1
   implicit none
   REAL (8)::mdtx,engyx
   REAL (8)::tx,gx,rx,px,cpx,pcrit,facx,term1,term2,pratio,cstar,ax,hx
   REAL (8):: p1,p2

   mdotos=0.
   edotos=0.  ! initially set them to zero prior to running this loop

     p1=p
     p2=pamb
     ax=area
     IF(p1.GT.p2) THEN
        dsigng=1
        tx=t
        gx=g
        rx=rgas
        px=p
        cpx=cp
        hx=cp*t
        pratio=p1/p2
     else
        dsigng=-1
        tx=300d0
        gx=g
        rx=rgas
        px=pamb
        cpx=cp
        hx=cp*300d0
        pratio=p2/p1
    end if

    pcrit=(2./(gx+1.))**(gx/(gx-1.))
    IF((1./pratio).LT.pcrit) then
        ! choked flow
        cstar=sqrt((1./gx)*((gx+1.)/2.)**((gx+1.)/(gx-1.))*rx*tx)
        mdtx=px*ax/cstar
    else
        ! unchoked flow
      facx=pratio**((gx-1.)/gx)
      term1=SQRT(gx*rx*tx/facx)
      term2=SQRT((facx-1.)/(gx-1.))
      mdtx=SQRT(2.)*px/pratio/rx/tx*facx*term1*term2*ax
    end if
    engyx=mdtx*hx  ! reformulate based on enthalpy of the chamber
    mdotos=mdtx*dsigng ! exiting mass flow (could be negative "dsigng")
    edotos=engyx*dsigng ! exiting enthalpy
end subroutine

subroutine addmass
    use mod1
    implicit none
    mcham=mcham+(mdotgen-mdotos)*dt
    echam=echam+(edotgen-edotos)*dt
end subroutine

subroutine calct
    use mod1
    implicit none
    t=echam/mcham/cv
end subroutine

subroutine calcp
    use mod1
    implicit none
    p=mcham*rgas*t/vol
end subroutine

subroutine calcthrust
    use mod1
    implicit none
    thrust=(p-pamb)*area*cf ! correction to thrust (actual vs vacuum thrust)
end subroutine

!!  Main program

function legacy_rocket(input_file)
  !! this is a basic program of a single stage
  !! rocket motor flowing out of a nozzle, assuming
  !! a thrust coefficient and ignoring the complexities of
  !! what happens to thrust at low pressures, i.e. shock in the nozzle

use assertions_interface, only : assert, max_errmsg_len
use results_interface, only : results_t
use mod1
implicit none

character(len=*), intent(in) :: input_file
type(results_t) legacy_rocket

character(len=max_errmsg_len) error_message
integer io_status, file_unit
integer, parameter :: success = 0

real(dp) dt_, t_max_
real(dp) c_p_, MW_
real(dp) temperature_, pressure_
real(dp) T_flame_, r_ref_, n_
real(dp) id_, od_, length_, rho_solid_
real(dp) dia_, C_f_

namelist/numerics_list/ dt_, t_max_
namelist/gas_list/ c_p_, MW_
namelist/state_list/  temperature_, pressure_
namelist/combustion_list/ T_flame_, r_ref_, n_
namelist/grain_list/ id_, od_, length_, rho_solid_
namelist/nozzle_list/ dia_, C_f_

open(newunit=file_unit, file=input_file, status="old", iostat=io_status, iomsg=error_message)
call assert(io_status == success, "legacy_rocket: io_status == success", error_message)

read(file_unit, nml=numerics_list)
dt   = dt_
tmax = t_max_

read(file_unit, nml=gas_list)
cp = c_p_
mw = MW_

read(file_unit, nml=state_list)
t = temperature_
p = pressure_

read(file_unit, nml=combustion_list)
Tflame = T_flame_
rref   = r_ref_
n      = n_

read(file_unit, nml=grain_list)
id     = id_
od     = od_
length = length_
rhos   = rho_solid_

read(file_unit, nml=nozzle_list)
dia = dia_
cf  = C_f_

close(file_unit)

!  propellent grain is a cylinder burning radially outward and axially inward.
! outer diameter is inhibited because this is a cast propellent: it was poured
! into the tube/chamber and only the inner diameter burns when ignited.

  ! propellant burn rate information
  psipa=6894.76d0 ! pascals per psi (constant)
  pref=3000d0*psipa ! reference pressure (constant)

  nsteps=nint(tmax/dt) ! number of time steps

! preallocate an output file for simulation infomration
  allocate(output(0:nsteps,6))

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11

!! now begin calculating and initializing
! gas variables
  rgas=ru/mw
  cv=cp-rgas
  g=cp/cv

  area=pi/4d0*dia**2.0d0 ! nozzle area

  pamb=101325d0 ! atmospheric pressure

!  calculate initial mass and energy in the chamber
  mcham=p*vol/rgas/t  ! use ideal gas law to determine mass in chamber
  echam=mcham*cv*t ! initial internal energy in chamber

  output(0,:)=[time,p,t,mdotos,thrust,vol]

  do i=1,nsteps
   call burnrate
   call calcsurf
   call calmdotgen  ! [mdot,engy,dsign]= massflow(p1,pamb,t1,tamb,cp,cp,rgas,rgas,g,g,area)
   call massflow
   call addmass
   call calct
   call calcp
   call calcthrust
   time=time+dt
   output(i,:)=[time,p,t,mdotos,thrust,vol]

  enddo

  block
    character(len=*), parameter :: header(*) = [ character(len=len("temperatureLegacy)")) :: &
      "timeLegacy", "pressureLegacy", "temperatureLegacy", "mdotosLegacy", "thrustLegacy", "volumeLegacy"]
    legacy_rocket = results_t(header, output)
  end block

end function legacy_rocket


C$Procedure RECPGR ( Rectangular to planetographic )

      SUBROUTINE RECPGR ( BODY, RECTAN, RE, F, LON, LAT, ALT )

C$ Abstract
C
C     Convert rectangular coordinates to planetographic coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     KERNEL
C     NAIF_IDS
C     PCK
C
C$ Keywords
C
C     CONVERSION
C     COORDINATES
C     GEOMETRY
C     MATH
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'zzctr.inc'

      CHARACTER*(*)         BODY
      DOUBLE PRECISION      RECTAN ( 3 )
      DOUBLE PRECISION      RE
      DOUBLE PRECISION      F
      DOUBLE PRECISION      LON
      DOUBLE PRECISION      LAT
      DOUBLE PRECISION      ALT

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     BODY       I   Body with which coordinate system is associated.
C     RECTAN     I   Rectangular coordinates of a point.
C     RE         I   Equatorial radius of the reference spheroid.
C     F          I   Flattening coefficient.
C     LON        O   Planetographic longitude of the point (radians).
C     LAT        O   Planetographic latitude of the point (radians).
C     ALT        O   Altitude of the point above reference spheroid.
C
C$ Detailed_Input
C
C     BODY       Name of the body with which the planetographic
C                coordinate system is associated.
C
C                BODY is used by this routine to look up from the
C                kernel pool the prime meridian rate coefficient giving
C                the body's spin sense.  See the Files and Particulars
C                header sections below for details.
C
C
C     RECTAN     The rectangular coordinates of a point.  Units
C                are arbitrary, except that the input RE must be
C                expressed in the same units.
C
C
C     RE         Equatorial radius of a reference spheroid.  This
C                spheroid is a volume of revolution:  its horizontal
C                cross sections are circular.  The shape of the
C                spheroid is defined by an equatorial radius RE and a
C                polar radius RP.  Units of RE must match those of
C                RECTAN.
C
C
C     F          Flattening coefficient =
C
C                   (RE-RP) / RE
C
C                where RP is the polar radius of the spheroid, and the
C                units of RP match those of RE.
C
C$ Detailed_Output
C
C     LON        Planetographic longitude of the input point.  This is
C                the angle between the prime meridian and the meridian
C                containing RECTAN.  For bodies having prograde (aka
C                direct) rotation, the direction of increasing
C                longitude is positive west:  from the +X axis of the
C                rectangular coordinate system toward the -Y axis.
C                For bodies having retrograde rotation, the direction
C                of increasing longitude is positive east:  from the +X
C                axis toward the +Y axis.
C
C                The earth, moon, and sun are exceptions:
C                planetographic longitude is measured positive east for
C                these bodies.
C
C                The default interpretation of longitude by this
C                and the other planetographic coordinate conversion
C                routines can be overridden; see the discussion in
C                Particulars below for details.
C
C                LON is output in radians.  The nominal range of LON is
C                given by:
C
C                   0  <  LON  <  2*pi
C                      -
C
C                However, round-off error could cause LON to equal 2*pi.
C
C
C     LAT        Planetographic latitude of the input point.  For a
C                point P on the reference spheroid, this is the angle
C                between the XY plane and the outward normal vector at
C                P. For a point P not on the reference spheroid, the
C                planetographic latitude is that of the closest point
C                to P on the spheroid.
C
C                LAT is output in radians. The range of LAT is given
C                by:
C
C                   -pi/2  <  LAT  <  pi/2
C                          -       -
C
C
C     ALT        Altitude of point above the reference spheroid.
C
C                The units associated with ALT are those associated
C                with the input RECTAN and RE.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the body name BODY cannot be mapped to a NAIF ID code,
C        and if BODY is not a string representation of an integer,
C        the error SPICE(IDCODENOTFOUND) will be signaled.
C
C     2) If the kernel variable
C
C           BODY<ID code>_PGR_POSITIVE_LON
C
C        is present in the kernel pool but has a value other than one
C        of
C
C            'EAST'
C            'WEST'
C
C        the error SPICE(INVALIDOPTION) will be signaled.  Case
C        and blanks are ignored when these values are interpreted.
C
C     3) If polynomial coefficients for the prime meridian of BODY
C        are not available in the kernel pool, and if the kernel
C        variable BODY<ID code>_PGR_POSITIVE_LON is not present in
C        the kernel pool, the error SPICE(MISSINGDATA) will be signaled.
C
C     4) If the equatorial radius is non-positive, the error
C        SPICE(VALUEOUTOFRANGE) is signaled.
C
C     5) If the flattening coefficient is greater than or equal to one,
C        the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C     6) For points inside the reference ellipsoid, the nearest point
C        on the ellipsoid to RECTAN may not be unique, so latitude may
C        not be well-defined.
C
C$ Files
C
C     This routine expects a kernel variable giving BODY's prime
C     meridian angle as a function of time to be available in the
C     kernel pool.  Normally this item is provided by loading a PCK
C     file.  The required kernel variable is named
C
C        BODY<body ID>_PM
C
C     where <body ID> represents a string containing the NAIF integer
C     ID code for BODY.  For example, if BODY is 'JUPITER', then
C     the name of the kernel variable containing the prime meridian
C     angle coefficients is
C
C        BODY599_PM
C
C     The optional kernel variable
C
C        BODY<body ID>_PGR_POSITIVE_LON
C
C     also is normally defined via loading a text kernel. When this
C     variable is present in the kernel pool, the prime meridian
C     coefficients for BODY are not required by this routine. See the
C     Particulars section below for details.
C
C$ Particulars
C
C     Given the body-fixed rectangular coordinates of a point, this
C     routine returns the planetographic coordinates of the point. The
C     body-fixed rectangular frame is that having the X-axis pass
C     through the 0 degree latitude 0 degree longitude direction, the
C     Z-axis pass through the 90 degree latitude direction, and the
C     Y-axis equal to the cross product of the unit Z-axis and X-axis
C     vectors.
C
C     The planetographic definition of latitude is identical to the
C     planetodetic (also called "geodetic" in SPICE documentation)
C     definition. In the planetographic coordinate system, latitude is
C     defined using a reference spheroid.  The spheroid is
C     characterized by an equatorial radius and a polar radius. For a
C     point P on the spheroid, latitude is defined as the angle between
C     the X-Y plane and the outward surface normal at P.  For a point P
C     off the spheroid, latitude is defined as the latitude of the
C     nearest point to P on the spheroid.  Note if P is an interior
C     point, for example, if P is at the center of the spheroid, there
C     may not be a unique nearest point to P.
C
C     In the planetographic coordinate system, longitude is defined
C     using the spin sense of the body.  Longitude is positive to the
C     west if the spin is prograde and positive to the east if the spin
C     is retrograde.  The spin sense is given by the sign of the first
C     degree term of the time-dependent polynomial for the body's prime
C     meridian Euler angle "W":  the spin is retrograde if this term is
C     negative and prograde otherwise.  For the sun, planets, most
C     natural satellites, and selected asteroids, the polynomial
C     expression for W may be found in a SPICE PCK kernel.
C
C     The earth, moon, and sun are exceptions: planetographic longitude
C     is measured positive east for these bodies.
C
C     If you wish to override the default sense of positive longitude
C     for a particular body, you can do so by defining the kernel
C     variable
C
C        BODY<body ID>_PGR_POSITIVE_LON
C
C     where <body ID> represents the NAIF ID code of the body. This
C     variable may be assigned either of the values
C
C        'WEST'
C        'EAST'
C
C     For example, you can have this routine treat the longitude
C     of the earth as increasing to the west using the kernel
C     variable assignment
C
C        BODY399_PGR_POSITIVE_LON = 'WEST'
C
C     Normally such assignments are made by placing them in a text
C     kernel and loading that kernel via FURNSH.
C
C     The definition of this kernel variable controls the behavior of
C     the SPICELIB planetographic routines
C
C        PGRREC
C        RECPGR
C        DPGRDR
C        DRDPGR
C
C     It does not affect the other SPICELIB coordinate conversion
C     routines.
C
C$ Examples
C
C
C     Numerical results shown for this example may differ between
C     platforms as the results depend on the SPICE kernels used as
C     input and the machine specific arithmetic implementation.
C
C
C     1) Find the planetographic coordinates of the point having Mars
C        rectangular coordinates:
C
C           X (km) =      0.0
C           Y (km) =  -2620.678914818178
C           Z (km) =   2592.408908856967
C
C        (These input values have been chosen to create "simple" output
C        values.)
C
C
C                 PROGRAM EX1
C                 IMPLICIT NONE
C           C
C           C     SPICELIB functions
C           C
C                 DOUBLE PRECISION      RPD
C           C
C           C     Local variables
C           C
C                 DOUBLE PRECISION      ALT
C                 DOUBLE PRECISION      F
C                 DOUBLE PRECISION      LAT
C                 DOUBLE PRECISION      LON
C                 DOUBLE PRECISION      RADII  ( 3 )
C                 DOUBLE PRECISION      RE
C                 DOUBLE PRECISION      RECTAN ( 3 )
C                 DOUBLE PRECISION      RP
C
C                 INTEGER               N
C           C
C           C     Load a PCK file containing a triaxial
C           C     ellipsoidal shape model and orientation
C           C     data for Mars.
C           C
C                 CALL FURNSH ( 'pck00008.tpc' )
C
C           C
C           C     Look up the radii for Mars.  Although we
C           C     omit it here, we could first call BADKPV
C           C     to make sure the variable BODY499_RADII
C           C     has three elements and numeric data type.
C           C     If the variable is not present in the kernel
C           C     pool, BODVRD will signal an error.
C           C
C                 CALL BODVRD ( 'MARS', 'RADII', 3, N, RADII )
C
C           C
C           C     Compute flattening coefficient.
C           C
C                 RE  =  RADII(1)
C                 RP  =  RADII(3)
C                 F   =  ( RE - RP ) / RE
C
C           C
C           C     Do the conversion.
C           C
C                 RECTAN(1) =      0.D0
C                 RECTAN(2) =  -2620.678914818178D0
C                 RECTAN(3) =   2592.408908856967D0
C
C                 CALL RECPGR ( 'MARS', RECTAN, RE, F, LON, LAT, ALT )
C
C                 WRITE (*,*) ' '
C                 WRITE (*,*) 'Rectangular coordinates:'
C                 WRITE (*,*) ' '
C                 WRITE (*,*) '  X (km)                 = ', RECTAN(1)
C                 WRITE (*,*) '  Y (km)                 = ', RECTAN(2)
C                 WRITE (*,*) '  Z (km)                 = ', RECTAN(3)
C                 WRITE (*,*) ' '
C                 WRITE (*,*) 'Ellipsoid shape parameters: '
C                 WRITE (*,*) ' '
C                 WRITE (*,*) '  Equatorial radius (km) = ', RE
C                 WRITE (*,*) '  Polar radius      (km) = ', RP
C                 WRITE (*,*) '  Flattening coefficient = ', F
C                 WRITE (*,*) ' '
C                 WRITE (*,*) 'Planetographic coordinates:'
C                 WRITE (*,*) ' '
C                 WRITE (*,*) '  Longitude (deg)        = ', LON / RPD()
C                 WRITE (*,*) '  Latitude  (deg)        = ', LAT / RPD()
C                 WRITE (*,*) '  Altitude  (km)         = ', ALT
C                 WRITE (*,*) ' '
C
C                 END
C
C
C        Output from this program should be similar to the following
C        (rounding and formatting will differ across platforms):
C
C           Rectangular coordinates:
C
C             X (km)                 =   0.
C             Y (km)                 =  -2620.67891
C             Z (km)                 =   2592.40891
C
C           Ellipsoid shape parameters:
C
C             Equatorial radius (km) =   3396.19
C             Polar radius      (km) =   3376.2
C             Flattening coefficient =   0.00588600756
C
C           Planetographic coordinates:
C
C             Longitude (deg)        =   90.
C             Latitude  (deg)        =   45.
C             Altitude  (km)         =   300.
C
C
C
C     2) Below is a table showing a variety of rectangular coordinates
C        and the corresponding Mars planetographic coordinates.  The
C        values are computed using the reference spheroid having radii
C
C           Equatorial radius:    3397
C           Polar radius:         3375
C
C        Note:  the values shown above may not be current or suitable
C               for your application.
C
C
C        Corresponding rectangular and planetographic coordinates are
C        listed to three decimal places.
C
C    RECTAN(1)    RECTAN(2)   RECTAN(3)    LON        LAT         ALT
C    ------------------------------------------------------------------
C     3397.000      0.000      0.000       0.000      0.000       0.000
C    -3397.000      0.000      0.000     180.000      0.000       0.000
C    -3407.000      0.000      0.000     180.000      0.000      10.000
C    -3387.000      0.000      0.000     180.000      0.000     -10.000
C        0.000  -3397.000      0.000      90.000      0.000       0.000
C        0.000   3397.000      0.000     270.000      0.000       0.000
C        0.000      0.000   3375.000       0.000     90.000       0.000
C        0.000      0.000  -3375.000       0.000    -90.000       0.000
C        0.000      0.000      0.000       0.000     90.000   -3375.000
C
C
C
C     3)  Below we show the analogous relationships for the earth,
C         using the reference ellipsoid radii
C
C            Equatorial radius:    6378.140
C            Polar radius:         6356.750
C
C         Note the change in longitudes for points on the +/- Y axis
C         for the earth vs the Mars values.
C
C
C    RECTAN(1)    RECTAN(2)   RECTAN(3)    LON        LAT         ALT
C    ----------------------------------  -------------------------------
C     6378.140      0.000      0.000       0.000      0.000       0.000
C    -6378.140      0.000      0.000     180.000      0.000       0.000
C    -6388.140      0.000      0.000     180.000      0.000      10.000
C    -6368.140      0.000      0.000     180.000      0.000     -10.000
C        0.000  -6378.140      0.000     270.000      0.000       0.000
C        0.000   6378.140      0.000      90.000      0.000       0.000
C        0.000      0.000   6356.750       0.000     90.000       0.000
C        0.000      0.000  -6356.750       0.000    -90.000       0.000
C        0.000      0.000      0.000       0.000     90.000   -6356.750
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C     B.V. Semenov    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 21-SEP-2013 (BVS)
C
C        Updated to save the input body name and ZZBODTRN state
C        counter and to do name-ID conversion only if the counter
C        has changed.
C
C        Updated to call LJUCRS instead of CMPRSS/UCASE.
C
C-    SPICELIB Version 1.0.1, 23-JAN-2008 (EDW)
C
C        Corrected typo in LAT range description, from:
C
C                   -pi/2  <  LAT  <  pi
C                          -       -
C
C        to:
C
C                   -pi/2  <  LAT  <  pi/2
C                          -       -
C
C-    SPICELIB Version 1.0.0, 26-DEC-2004 (CHA) (NJB) (HAN) (BVS) (WLT)
C
C-&

C$ Index_Entries
C
C     convert rectangular to planetographic coordinates
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      BRCKTD
      DOUBLE PRECISION      TWOPI

      INTEGER               PLNSNS

      LOGICAL               RETURN

C
C     Local parameters
C
      CHARACTER*(*)         PMTMP
      PARAMETER           ( PMTMP  = 'BODY#_PM' )

      CHARACTER*(*)         OVRTMP
      PARAMETER           ( OVRTMP = 'BODY#_PGR_POSITIVE_LON' )

      INTEGER               EARTH
      PARAMETER           ( EARTH  = 399 )

      INTEGER               KVNMLN
      PARAMETER           ( KVNMLN = 32  )

      INTEGER               LNSIZE
      PARAMETER           ( LNSIZE = 80  )

      INTEGER               MOON
      PARAMETER           ( MOON   = 301 )

      INTEGER               SENSLN
      PARAMETER           ( SENSLN = 4 )

      INTEGER               SUN
      PARAMETER           ( SUN    = 10  )

C
C     Saved body name length.
C
      INTEGER               MAXL
      PARAMETER           ( MAXL  = 36 )

C
C     Local variables
C
      CHARACTER*(LNSIZE)    KVALUE
      CHARACTER*(KVNMLN)    PMKVAR
      CHARACTER*(SENSLN)    PGRLON

      INTEGER               BODYID
      INTEGER               N
      INTEGER               SENSE

      LOGICAL               FOUND

C
C     Saved name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(MAXL)      SVBODY
      INTEGER               SVBDID
      LOGICAL               SVFND1

      LOGICAL               FIRST

C
C     Saved name/ID items.
C
      SAVE                  SVCTR1
      SAVE                  SVBODY
      SAVE                  SVBDID
      SAVE                  SVFND1

      SAVE                  FIRST

C
C     Initial values.
C
      DATA                  FIRST   / .TRUE. /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'RECPGR' )

C
C     Initialization.
C
      IF ( FIRST ) THEN

C
C        Initialize counter.
C
         CALL ZZCTRUIN( SVCTR1 )

         FIRST = .FALSE.

      END IF

C
C     Convert the body name to an ID code.
C
      CALL ZZBODS2C ( SVCTR1, SVBODY, SVBDID, SVFND1,
     .                BODY, BODYID, FOUND    )

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The value of the input argument BODY is #, '
     .   //            'this is not a recognized name of an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit. '           )
         CALL ERRCH  ( '#', BODY                                  )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'RECPGR'                                   )
         RETURN

      END IF

C
C     The equatorial radius must be positive. If not, signal an error
C     and check out.
C
      IF ( RE .LE. 0.0D0 ) THEN

         CALL SETMSG ( 'Equatorial radius was #.' )
         CALL ERRDP  ( '#', RE                    )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'   )
         CALL CHKOUT ( 'RECPGR'                   )
         RETURN

      END IF

C
C     If the flattening coefficient is greater than 1, the polar radius
C     is negative. If F is equal to 1, the polar radius is zero. Either
C     case is a problem, so signal an error and check out.
C
      IF ( F .GE. 1.D0 ) THEN

         CALL SETMSG ( 'Flattening coefficient was #.'  )
         CALL ERRDP  ( '#', F                           )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'         )
         CALL CHKOUT ( 'RECPGR'                         )
         RETURN

      END IF

C
C     Look up the longitude sense override variable from the
C     kernel pool.
C
      CALL REPMI  ( OVRTMP, '#',     BODYID, PMKVAR )
      CALL GCPOOL ( PMKVAR, 1, 1, N, KVALUE, FOUND  )

      IF ( FOUND ) THEN
C
C        Make sure we recognize the value of PGRLON.
C
         CALL LJUCRS ( 0, KVALUE, PGRLON )

         IF ( PGRLON .EQ. 'EAST' ) THEN

            SENSE =  1

         ELSE IF ( PGRLON .EQ. 'WEST' ) THEN

            SENSE = -1

         ELSE

            CALL SETMSG ( 'Kernel variable # may have the values ' //
     .                    'EAST or WEST.  Actual value was #.'    )
            CALL ERRCH  ( '#', PMKVAR                             )
            CALL ERRCH  ( '#', KVALUE                             )
            CALL SIGERR ( 'SPICE(INVALIDOPTION)'                  )
            CALL CHKOUT ( 'RECPGR'                                )
            RETURN

         END IF

      ELSE
C
C        Look up the spin sense of the body's prime meridian.
C
         SENSE = PLNSNS ( BODYID )

C
C        If the required prime meridian rate was not available,
C        PLNSNS returns the code 0.  Here we consider this situation
C        to be an error.
C
         IF ( SENSE .EQ. 0 ) THEN

            CALL REPMI  ( PMTMP, '#', BODYID, PMKVAR )

            CALL SETMSG ( 'Prime meridian rate coefficient defined ' //
     .                    'by kernel variable # is required but '    //
     .                    'not available for body #. '               )
            CALL ERRCH  ( '#', PMKVAR                                )
            CALL ERRCH  ( '#', BODY                                  )
            CALL SIGERR ( 'SPICE(MISSINGDATA)'                       )
            CALL CHKOUT ( 'RECPGR'                                   )
            RETURN

         END IF

C
C        Handle the special cases:  earth, moon, and sun.
C
         IF (      ( BODYID .EQ. EARTH )
     .        .OR. ( BODYID .EQ. MOON  )
     .        .OR. ( BODYID .EQ. SUN   )  ) THEN

            SENSE = 1

         END IF

      END IF

C
C     At this point, SENSE is set to +/- 1.
C
C     Convert the input coordinates first to geodetic coordinates.
C
      CALL RECGEO ( RECTAN, RE, F, LON, LAT, ALT )

C     Adjust the longitude according to the sense of the body's
C     spin, or according to the override value if one is provided.
C
      LON = SENSE * LON

C
C     Convert the longitude from the range (-pi, pi] to [0, 2*pi),
C     the latter being the range of planetographic longitude.
C
      IF ( LON .LT. 0.D0 ) THEN

         LON = LON + TWOPI()

      END IF

C
C     Make sure round-off error doesn't take LON out of range.
C
      LON = BRCKTD (  LON,   0.D0,  TWOPI()  )

      CALL CHKOUT ( 'RECPGR' )
      RETURN
      END


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine sim1dm                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.0
!  Written by Gordon A. Fenton, Dalhousie University, Mar 12, 2007
!  Latest Update: Mar 12, 2007
!
!  PURPOSE  simulates random processes for MSIM1M
!
!  DESCRIPTION
!  This routine simulates m random processes, which are
!  possibly intercorrelated. Individual fields are generated as standard
!  Gaussian random fields using the 1-D Local Average Subdivision (LAS)
!  algorithm. These fields are then combined to produce correlated standard
!  Gaussian fields using the Covariance Matrix Decomposition approach.
!  Finally the individual fields are transformed so that they have the
!  desired marginal distributions. These transformations are as follows;
!
!	P(x) = mean + sd*G(x)		       if normally distributed
!
!	P(x) = exp{ log-mean + log-sd*G(x) }   if lognormally distributed
!
!	P(x) = a + 0.5*(b-a)*[ 1 + tanh((m + s*G(x))/2*pi) ]
!						if bounded
!
!  where P(x) is the desired 1-D random process,
!  G(x) is one of the standard correlated Gaussian fields, and (mean,sd)
!  and (a,b,m,s) are parameters of the distributions.
!
!  If the process is deterministic, the entire process is simply set to its
!  mean.
!
!  ARGUMENTS
!
!   iterm	unit number to which error and warning messages are sent.
!		(input)
!
!	m	integer containing the number of random processes produced
!		in each realization. (input)
!
!      xl	real value containing the physical length of the process.
!		(input)
!
!     nxe	integer containing the number of cells that each process
!		is subdivided into. (input)
!
!     thx	real value containing the desired scale of fluctuation of
!		the processes. (input)
!
!  varfnc	character string of length 6 containing the name of the
!		1-D covariance function to use in the simulation. Possible
!		values of varfnc are;
!
!			dlace1	- damped oscillatory noise process
!			dlafr1	- fractional Gaussian noise process
!			dlavx1	- Markov process
!			dlsmp1	- simple polynomial decaying covariance
!			dlspx1	- Gaussian covariance function
!		(input)
!
!   kseed	integer containing the seed used to initialize the pseudo-
!		random number generator. (input)
!
!   lxfld	logical flag which is true if more than one of the processes
!		are cross-correlated. That is, if all processes are
!		independent, then lxfld is false. (input)
!
!	a	real array of size at least 7 x m which contains
!		the parameters of each of the i = 1, 2, ..., m processes.
!		Notably,
!		   a(1,i) = mean,
!		   a(2,i) = standard deviation,
!		   a(3,i) = distribution type;
!			  = 0.0 if process is deterministic (at mean value)
!			  = 1.0 if process is normally distributed
!			  = 2.0 if process is lognormally distributed (logn)
!			  = 3.0 if process is bounded
!		   a(4,i) = lower bound (bounded), or mean of log-process(logn)
!		   a(5,i) = upper bound (bounded), or sd of log-process (logn)
!		   a(6,i) = m parameter (if bounded)
!		   a(7,i) = s parameter (if bounded)
!		If process i (i = 1, 2, ..., m) is bounded, then a(1,i) and
!		a(2,i) are ignored and the parameters a(4,i) through a(7,i)
!		completely describe the distribution. (input)
!
!	R	real array of size at least m x m which contains
!		the correlation matrix between the m
!		random processes. For example R(i,j) will be the
!		correlation coefficient, assumed to act at all points
!		in the field, acting between process i and process j.
!		(input)
!
!       G	real array of size at least (3*nxe/2) x m which, on output,
!		will contain the m process realizations, each of length nxe.
!		The extra nxe/2, in each of the m columns in the array, is
!		used as workspace. (output)
!
!     MXM	integer containing the maximum allowable number of random
!		processes. (input)
!
!     MXP	integer containing the maximum allowable number of cells
!		in each process. (input)
!
! lsquare	logical flag which is true if the cells in each process are
!		actually two-dimensional squares. What this does is to
!		provide for local averaging over the square (assuming a
!		separable variance function) rather than just along the
!		1-D process. (input)
!
!   debug	logical flag which is true if debug info is to be written
!		to unit iterm. (input)
!
!  REVISION HISTORY:
!-------------------------------------------------------------------------
      subroutine sim1dm(iterm,m,xl,nxe,thx,varfnc,kseed,lxfld,            &
                       a,R,G,MXM,MXQ,lsquare,debug)
      real xl, thx, a(7,*), R(MXM,*), G(MXQ,*)
      integer m, nxe, kseed, MXM, MXQ
      logical lxfld, lsquare, debug
      character*(*) varfnc
      real*4 rerr
      real*8 dvar, dpb, dthx, dthy, dthz, ddx
      real*8 dlace1, dlafr1, dlavx1, dlsmp1, dlspx1
      real*8 dmin1, dble
      save ienter
      external dlace1, dlafr1, dlavx1, dlsmp1, dlspx1
      common/dparam/ dvar, dpb, dthx, dthy, dthz
      data zero/0.0/, half/0.5/, one/1.0/, onept5/1.5/, twopt5/2.5/, d4/4.0/
      data tolr/0.001/
      data twopi/6.2831853071795864769/
      data ienter/0/

   1  format(a,a)

!-------------------------------------- initialize -------------------------
!					compute required field size (once)
      if( debug ) then
         write(iterm,1)'sim1dm: just entered...'
         call flush(iterm)
      endif
      ienter = ienter + 1
      if( ienter .eq. 1 ) then
         if( lxfld ) then
            if( debug ) then
               write(iterm,1)'sim1dm: Decomposing R...'
               call flush(iterm)
            endif
            call chol2(R,MXM,m,rerr)		! decompose correlation matrix
            if( rerr .gt. tolr ) then
              call print1(istat,                                     &
		   'Warning: relative error on Cholesky decomposition of R is %f%n'&
		   ,rerr)
            endif
            if( debug ) then
               write(iterm,1)'sim1dm: R decomposed...'
               call flush(iterm)
            endif
         endif

         if( thx .gt. zero ) then
            ddx = dble(xl)/dble(nxe)
!						set covariance fnc parameters
            dthx = thx
            if( lsquare ) then
               dvar = -1.d0
               if(     varfnc .eq. 'dlace1' ) then
                  dpb = dlace1(ddx)
               elseif( varfnc .eq. 'dlafr1' ) then
                  dpb = dlafr1(ddx)
               elseif( varfnc .eq. 'dlavx1' ) then
                  dpb = dlavx1(ddx)
               elseif( varfnc .eq. 'dlsmp1' ) then
                  dpb = dlsmp1(ddx)
               elseif( varfnc .eq. 'dlspx1' ) then
                  dpb = dlspx1(ddx)
               endif
               dvar = dpb
            else
               dvar = 1.d0
            endif

            if( varfnc .eq. 'dlafr1' ) dpb = ddx

!						initialize LAS1G
            if( debug ) then
               write(iterm,1)'sim1dm: Initializing LAS1G...'
               call flush(iterm)
            endif
            if( varfnc .eq. 'dlace1' ) then
               call las1g(G,nxe,xl,dlace1,3,kseed,-1,iterm)
            elseif( varfnc .eq. 'dlafr1' ) then
               call las1g(G,nxe,xl,dlafr1,3,kseed,-1,iterm)
            elseif( varfnc .eq. 'dlavx1' ) then
               call las1g(G,nxe,xl,dlavx1,3,kseed,-1,iterm)
            elseif( varfnc .eq. 'dlsmp1' ) then
               call las1g(G,nxe,xl,dlsmp1,3,kseed,-1,iterm)
            elseif( varfnc .eq. 'dlspx1' ) then
               call las1g(G,nxe,xl,dlspx1,3,kseed,-1,iterm)
            else
               write(iterm,1)                                             &
                 '*** Error: unknown variance function name: ', varfnc
               stop
            endif
            if( debug ) then
               write(iterm,1)'sim1dm: LAS1G initialized...'
               call flush(iterm)
            endif
         endif
      endif
!					now produce m standard normal fields
      do 30 j = 1, m
         if( a(3,j) .lt. half ) then	! deterministic process
            do 10 i = 1, nxe
               G(i,j) = zero
  10        continue
         elseif( thx .eq. zero ) then	! white noise process
            do 20 i = 1, nxe
               G(i,j) = gausv(one)
  20        continue
         else
            if( debug ) then
               call print1(iterm,'sim1dm: Generating field #%i%n',rerr)
               call flush(iterm)
            endif
            if( varfnc .eq. 'dlace1' ) then
               call las1g(G(1,j),nxe,xl,dlace1,3,kseed,0,iterm)
            elseif( varfnc .eq. 'dlafr1' ) then
               call las1g(G(1,j),nxe,xl,dlace1,3,kseed,0,iterm)
            elseif( varfnc .eq. 'dlavx1' ) then
               call las1g(G(1,j),nxe,xl,dlavx1,3,kseed,0,iterm)
            elseif( varfnc .eq. 'dlsmp1' ) then
               call las1g(G(1,j),nxe,xl,dlsmp1,3,kseed,0,iterm)
            elseif( varfnc .eq. 'dlspx1' ) then
               call las1g(G(1,j),nxe,xl,dlspx1,3,kseed,0,iterm)
            endif
            if( debug ) then
               call print1(iterm,'sim1dm: Field #%i generated.%n',rerr)
               call flush(iterm)
            endif
         endif
  30  continue
!					combine for correlated fields...
      if( debug ) then
         write(iterm,1)'sim1dm: Correlating fields...'
         call flush(iterm)
      endif
      if( lxfld ) then
         do 60 i = 1, nxe
            do 50 j = m, 2, -1
               G(i,j) = R(j,j)*G(i,j)
               do 40 k = 1, j-1
                  G(i,j) = G(i,j) + R(k,j)*G(i,k)
  40           continue
  50        continue
  60     continue
      endif
      if( debug ) then
         write(iterm,1)'sim1dm: Fields correlated...'
         call flush(iterm)
      endif
!					convert to final processes
      do 110 j = 1, m
         if( debug ) then
            call print1(iterm,'sim1dm: Converting field #%i.%n',rerr)
            call flush(iterm)
         endif
         if( a(3,j) .lt. half ) then			! deterministic
            do 70 i = 1, nxe
               G(i,j) = a(1,j)
  70        continue
         elseif( a(3,j) .lt. onept5 ) then			! normal
            do 80 i = 1, nxe
               G(i,j) = a(1,j) + a(2,j)*G(i,j)
  80        continue
         elseif( a(3,j) .lt. twopt5 ) then			! lognormal
            do 90 i = 1, nxe
               G(i,j) = exp( a(4,j) + a(5,j)*G(i,j) )
  90        continue
         else						! bounded
            do 100 i = 1, nxe
			 G(i,j) = a(4,j) + half*(a(5,j)-a(4,j))                     &
                  *( one + tanh((a(6,j)+a(7,j)*G(i,j))/twopi) )
 100        continue
         endif
         if( debug ) then
            call print1(iterm,'sim1dm: Field #%i converted.%n',rerr)
            call flush(iterm)
         endif
 110  continue

      if( debug ) then
         write(iterm,1)'sim1dm: all done, just leaving...'
         call flush(iterm)
      endif

      return
      end


use MathClass
use IOClass
implicit none

type(IO_) :: f

real(real64) :: t,dt,sigma

dt = 0.010d0
sigma = 1.0d0

call f%open("Ricker.txt","w")
do i_i = 1,5000
    t   = dble(i_i-1)*dt
    call f%write(t, RickerFunction(t=t,sigma=sigma,center=10.0d0) )
enddo
call f%close()
call f%plot(option="with lines")

end


	PROGRAM WORLD
C *** LAST REVISED ON 14-AUG-1987 16:14:57.40
C *** SOURCE FILE: [DL.GRAPHICS.LONGLIB]WORLD.FOR
C
C	AND EXAMPLE OF USING THE MAPLIB ROUTINES.
C	THIS PROGRAM WILL PLOT A 3-D MAP OF THE WORLD WITH
C	BINNING GRID INFORMATION ON IT.
C
	DIMENSION V(3)
C
C	DEFINE DEGREE TO RADIAN CONVERSION
C
	DEGRAD(X)=X*3.141592654/180.0
C
	R=6378.1778		! RADIUS OF THE EARTH IN KM
	FLAT=3.3528132E-3	! FLATNESS OF EARTH
	F3=0.00002		! 3D SCALE FACTOR
	F=5.0			! PLOTTING SCALE FACTOR
	X=100.			! VIEW POINT LOCATION
	Y=100.
	Z=100.
	DS=600.			! PERSPECTIVE FACTOR
	RES=20.			! LAT/LONG GRID RESOLUTION
C
	NPTS=180./RES
	FPTS=NPTS
C
C	OPEN LONGLIB PACKAGE WITH PROMPT FOR SCREEN DEVICE
C
	CALL FRAME(3,0,5.,5.,F)
C
C	INITIALIZE 3D ROUTINES
C
	CALL INIT3D(X,Y,Z,0.,0.,0.,0.,DS,F3)
C
C	PLOT A 2D LABEL (DOESN'T USE 3D ROUTINES)
C
	CALL SYMBOL(-.5,-.5,.03,'WORLD',0.,5,-1)
C
C	PLOT EARTH LAT/LONG GRID IN 3D
C
	CALL NEWPEN(3)
	DO 310 ILAT=2,NPTS
		ALAT=DEGRAD((ILAT-1)*180./FPTS)
		ID=3
		DO 310 ILONG=1,2*NPTS+1
			ALONG=DEGRAD((ILONG-1)*180./FPTS)
			RAD=R*(1.-FLAT*SIN(ALAT))
			CALL SPRECT1(V,ALONG,ALAT,RAD)
			CALL PLOT3D(V(1),V(2),V(3),ID)
			ID=2
310	CONTINUE
	CALL NEWPEN(5)
	DO 320 ILONG=1,NPTS*2+1
		ALONG=DEGRAD((ILONG-1)*180./FPTS)
		ID=3
		DO 320 ILAT=1,NPTS+1
			ALAT=DEGRAD((ILAT-1)*180./FPTS)
			RAD=R*(1.-FLAT*SIN(ALAT))
			CALL SPRECT1(V,ALONG,ALAT,RAD)
			CALL PLOT3D(V(1),V(2),V(3),ID)
			ID=2
320	CONTINUE
	CALL PLOT(0.,0.,3)
C
C	ADD LAND MAP
C
	CALL NEWPEN(0)
	CALL EARTH3D(R,FLAT)
	CALL PLOTND
	CALL CTERM(2)
	STOP
	END


C$Procedure EDNMPT ( Ellipsoid normal vector to surface point )

      SUBROUTINE EDNMPT ( A, B, C, NORMAL, POINT )

C$ Abstract
C
C     Return the unique point on an ellipsoid's surface where the
C     outward normal direction is a given vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     ELLIPSOID
C     GEOMETRY
C     NORMAL
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      NORMAL ( 3 )
      DOUBLE PRECISION      POINT  ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     A          I   Length of the ellipsoid semi-axis along the x-axis.
C     B          I   Length of the ellipsoid semi-axis along the y-axis.
C     C          I   Length of the ellipsoid semi-axis along the z-axis.
C     NORMAL     I   Outward normal direction.
C     POINT      O   Point where outward normal is parallel to NORMAL.
C
C$ Detailed_Input
C
C     A          is the length of the semi-axis of the ellipsoid
C                that is parallel to the x-axis of the body-fixed
C                coordinate system.
C
C     B          is the length of the semi-axis of the ellipsoid
C                that is parallel to the y-axis of the body-fixed
C                coordinate system.
C
C     C          is the length of the semi-axis of the ellipsoid
C                that is parallel to the z-axis of the body-fixed
C                coordinate system.
C
C     NORMAL     is a non-zero vector. The unique point on the
C                ellipsoid at which NORMAL is an outward normal vector
C                is sought.
C
C$ Detailed_Output
C
C     POINT      is the unique point on the ellipsoid at which NORMAL
C                is an outward normal vector.
C
C                POINT is a 3-vector giving the bodyfixed coordinates
C                of a point on the ellipsoid. In bodyfixed coordinates,
C                the semi-axes of the ellipsoid are aligned with the x,
C                y, and z-axes of the coordinate system.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If any of the semi-axis lengths is non-positive, the error
C         SPICE(BADAXISLENGTH) will be signaled.
C
C     2)  If any of the semi-axis lengths underflows to zero when
C         divided by the largest semi-axis length, the error
C         SPICE(AXISUNDERFLOW) will be signaled.
C
C     3)  If NORMAL is the zero vector, the error SPICE(ZEROVECTOR)
C         will be signaled.
C
C     4)  If the input pass the above checks but lead to a
C         divide-by-zero error or to an computing an invalid argument
C         of a fractional exponential expression, the error
C         SPICE(DEGENERATECASE) will be signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine can be used to determine the distance between an
C     ellipsoid and a non-intersecting plane. This distance computation
C     supports computation of terminator points on an ellipsoid.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1) Choose a triaxial ellipsoid with three unequal semi-axis
C        lengths. Pick several vectors; find the points on the
C        ellipsoid where the respective outward normals are parallel to
C        those vectors.
C
C        Check the results: at each point, a computed outward normal
C        vector should have very small angular separation from the
C        input vector. Also, the point should be on the surface of the
C        ellipsoid. The ellipsoid can be thought of as a level surface
C        of the function
C
C                             2        2         2
C           f(x, y, z) = (x/a)  + (y/b)  +  (z/c)
C
C        where a, b, c are the semi-axis lengths of the ellipsoid.
C        Specifically, the ellipsoid is the set
C
C           { (x, y, z) : f(x, y, z)  =  1 }
C
C        We can evaluate f at a point to determine whether that point
C        is close to the ellipsoid's surface.
C
C
C        Example code begins here.
C
C
C              PROGRAM EX1
C              IMPLICIT NONE
C        C
C        C     SPICELIB functions
C        C
C              DOUBLE PRECISION      VSEP
C        C
C        C     Local parameters
C        C
C              CHARACTER*(*)         FMT1
C              PARAMETER           ( FMT1 = '(A,3F15.9)' )
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      A
C              DOUBLE PRECISION      B
C              DOUBLE PRECISION      C
C              DOUBLE PRECISION      NORMAL ( 3 )
C              DOUBLE PRECISION      POINT  ( 3 )
C              DOUBLE PRECISION      XNORML ( 3 )
C        C
C        C     Initialize the ellipsoid semi-axes.
C        C
C              A = 10.D0
C              B =  5.D0
C              C =  2.D0
C        C
C        C     Pick several vectors; find the points
C        C     on the ellipsoid where the respective
C        C     outward normals are parallel to those
C        C     vectors; check the results.
C        C
C              CALL VPACK  ( 0.D0, 0.D0, 3.D0, XNORML )
C              CALL EDNMPT ( A,    B,    C,    XNORML, POINT  )
C              CALL SURFNM ( A,    B,    C,    POINT,  NORMAL )
C
C              WRITE (*,*   ) ' '
C              WRITE (*,FMT1) 'Semi-axis lengths:   ', A, B, C
C              WRITE (*,FMT1) 'Input vector:        ', XNORML
C              WRITE (*,FMT1) 'Point:               ', POINT
C              WRITE (*,FMT1) 'Outward normal:      ', NORMAL
C              WRITE (*,FMT1) 'Angular error (rad): ', VSEP(NORMAL,
C             .                                          XNORML )
C              WRITE (*,FMT1) 'Off-surface error:   ',
C             .                 (POINT(1)/A)**2 + (POINT(2)/B)**2
C             .               + (POINT(3)/C)**2 - 1
C              WRITE (*,*) ' '
C
C
C              CALL VPACK  ( 15.D0, -7.D0, 3.D0, XNORML )
C              CALL EDNMPT ( A,      B,    C,    XNORML, POINT  )
C              CALL SURFNM ( A,      B,    C,    POINT,  NORMAL )
C
C              WRITE (*,FMT1) 'Semi-axis lengths:   ', A, B, C
C              WRITE (*,FMT1) 'Input vector:        ', XNORML
C              WRITE (*,FMT1) 'Point:               ', POINT
C              WRITE (*,FMT1) 'Outward normal:      ', NORMAL
C              WRITE (*,FMT1) 'Angular error (rad): ', VSEP(NORMAL,
C             .                                             XNORML )
C              WRITE (*,FMT1) 'Off-surface error:   ',
C             .                 (POINT(1)/A)**2 + (POINT(2)/B)**2
C             .               + (POINT(3)/C)**2 - 1
C              WRITE (*,*) ' '
C
C              CALL VPACK  ( 15.D0, -7.D0, 3.D0, XNORML )
C              CALL EDNMPT ( A,      B,    C,    XNORML, POINT  )
C              CALL SURFNM ( A,      B,    C,    POINT,  NORMAL )
C
C              WRITE (*,FMT1) 'Semi-axis lengths:   ', A, B, C
C              WRITE (*,FMT1) 'Input vector:        ', XNORML
C              WRITE (*,FMT1) 'Point:               ', POINT
C              WRITE (*,FMT1) 'Outward normal:      ', NORMAL
C              WRITE (*,FMT1) 'Angular error (rad): ', VSEP(NORMAL,
C             .                                             XNORML )
C              WRITE (*,FMT1) 'Off-surface error:   ',
C             .                 (POINT(1)/A)**2 + (POINT(2)/B)**2
C             .               + (POINT(3)/C)**2 - 1
C              WRITE (*,*) ' '
C
C              CALL VPACK  ( A/2, B/2,  C/2, XNORML )
C              CALL EDNMPT ( A,   B,    C,   XNORML, POINT  )
C              CALL SURFNM ( A,   B,    C,   POINT,  NORMAL )
C
C              WRITE (*,FMT1) 'Semi-axis lengths:   ', A, B, C
C              WRITE (*,FMT1) 'Input vector:        ', XNORML
C              WRITE (*,FMT1) 'Point:               ', POINT
C              WRITE (*,FMT1) 'Outward normal:      ', NORMAL
C              WRITE (*,FMT1) 'Angular error (rad): ', VSEP(NORMAL,
C             .                                             XNORML )
C              WRITE (*,FMT1) 'Off-surface error:   ',
C             .                 (POINT(1)/A)**2 + (POINT(2)/B)**2
C             .               + (POINT(3)/C)**2 - 1
C              WRITE (*,*) ' '
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran 64-bit
C     platform, the output was:
C
C
C     Semi-axis lengths:      10.000000000    5.000000000    2.000000000
C     Input vector:            0.000000000    0.000000000    3.000000000
C     Point:                   0.000000000    0.000000000    2.000000000
C     Outward normal:          0.000000000    0.000000000    1.000000000
C     Angular error (rad):     0.000000000
C     Off-surface error:       0.000000000
C
C     Semi-axis lengths:      10.000000000    5.000000000    2.000000000
C     Input vector:           15.000000000   -7.000000000    3.000000000
C     Point:                   9.731032027   -1.135287070    0.077848256
C     Outward normal:          0.891657447   -0.416106809    0.178331489
C     Angular error (rad):     0.000000000
C     Off-surface error:       0.000000000
C
C     Semi-axis lengths:      10.000000000    5.000000000    2.000000000
C     Input vector:           15.000000000   -7.000000000    3.000000000
C     Point:                   9.731032027   -1.135287070    0.077848256
C     Outward normal:          0.891657447   -0.416106809    0.178331489
C     Angular error (rad):     0.000000000
C     Off-surface error:       0.000000000
C
C     Semi-axis lengths:      10.000000000    5.000000000    2.000000000
C     Input vector:            5.000000000    2.500000000    1.000000000
C     Point:                   9.694128639    1.211766080    0.077553029
C     Outward normal:          0.880450906    0.440225453    0.176090181
C     Angular error (rad):     0.000000000
C     Off-surface error:       0.000000000
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 17-MAY-2016 (NJB) (WLT)
C
C-&

C$ Index_Entries
C
C     point on an ellipsoid having given surface normal
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      TOUCHD

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local variables
C
      DOUBLE PRECISION      ARG
      DOUBLE PRECISION      LAMBDA
      DOUBLE PRECISION      NA2
      DOUBLE PRECISION      NB2
      DOUBLE PRECISION      NC2
      DOUBLE PRECISION      SA
      DOUBLE PRECISION      SB
      DOUBLE PRECISION      SC
      DOUBLE PRECISION      SCALE

C
C     Use discovery check-in. We will test RETURN though, since
C     we could have invalid inputs to our arithmetic computations
C     if a SPICE error condition exists upon entry.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Perform some preliminary checks.
C
C     We need a non-degenerate ellipsoid to start with.
C
      IF (      ( A .LE. 0.D0 )
     .     .OR. ( B .LE. 0.D0 )
     .     .OR. ( C .LE. 0.D0 )  ) THEN

         CALL CHKIN  ( 'EDNMPT'                               )
         CALL SETMSG ( 'All ellipsoid semi-axis lengths must '
     .   //            'be strictly positive. Lengths were: '
     .   //            'A = #; B = #; C = #'                  )
         CALL ERRDP  ( '#',  A                                )
         CALL ERRDP  ( '#',  B                                )
         CALL ERRDP  ( '#',  C                                )
         CALL SIGERR ( 'SPICE(BADAXISLENGTH)'                 )
         CALL CHKOUT ( 'EDNMPT'                               )
         RETURN

      END IF

C
C     We'll work with scaled copies of the input semi-axis
C     lengths.
C
      SCALE = MAX ( A, B, C )

      SA    = TOUCHD( A / SCALE )
      SB    = TOUCHD( B / SCALE )
      SC    = TOUCHD( C / SCALE )
C
C     If any of the scaled-semi axes underflowed to zero,
C     we can't continue.
C
      IF (      ( SA .LE. 0.D0 )
     .     .OR. ( SB .LE. 0.D0 )
     .     .OR. ( SC .LE. 0.D0 )  ) THEN

         CALL CHKIN  ( 'EDNMPT'                                   )
         CALL SETMSG ( 'Scaled semi-axis lengths must be '
     .   //            'strictly positive. Scaled lengths were: '
     .   //            'SA = #; SB = #; SC = #'                   )
         CALL ERRDP  ( '#',  SA                                   )
         CALL ERRDP  ( '#',  SB                                   )
         CALL ERRDP  ( '#',  SC                                   )
         CALL SIGERR ( 'SPICE(AXISUNDERFLOW)'                     )
         CALL CHKOUT ( 'EDNMPT'                                   )
         RETURN

      END IF

C
C     The normal vector can't be the zero vector.
C
      IF ( VZERO(NORMAL) ) THEN

         CALL CHKIN  ( 'EDNMPT'                                       )
         CALL SETMSG ( 'The input normal vector was the zero vector. '
     .   //            'There is no solution.'                        )
         CALL SIGERR ( 'SPICE(ZEROVECTOR)'                            )
         CALL CHKOUT ( 'EDNMPT'                                       )
         RETURN

      END IF

C
C     In general, given an ellipsoid E with axes a, b, c,
C     and given a normal vector
C
C        n = ( n1, n2, n3 )
C
C     this problem is equivalent to finding a point (x,y,z)
C     on E such that
C
C             2     2     2
C        ( x/a,  y/b,  z/c ) = lambda * n
C
C     which implies
C                                           2     2     2
C        ( x, y, z )         = lambda ( n1*a, n2*b, n3*c )
C
C
C     Then since the vector on the left side is on the surface
C     of E, we must have
C
C              2       2   2        2   2       2   2
C        lambda  ( ( n1 * a  ) + (n2 * b ) + (n3 + c ) ) = 1
C
C
C     Requiring lambda to be positive, we have
C
C                               2   2        2   2       2   2
C        lambda = 1 / sqrt( ( n1 * a  ) + (n2 * b ) + (n3 + c ) )
C
C
      NA2 = NORMAL(1) * SA * SA
      NB2 = NORMAL(2) * SB * SB
      NC2 = NORMAL(3) * SC * SC

      ARG = TOUCHD(   ( NA2 * NORMAL(1) ) + ( NB2 * NORMAL(2) )
     .              + ( NC2 * NORMAL(3) )                        )

      IF ( ARG .LE. 0.D0 ) THEN

         CALL CHKIN  ( 'EDNMPT'                                   )
         CALL SETMSG ( 'Scale factor LAMBDA must be positive, '
     .   //            'but reciprocal of square of LAMBDA is #.' )
         CALL ERRDP  ( '#', ARG                                   )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                    )
         CALL CHKOUT ( 'EDNMPT'                                   )
         RETURN

      END IF

C
C     Compute LAMBDA as above, and scale it too. This will place
C     POINT on the original ellipsoid.
C
      LAMBDA   = ( ARG ** (-0.5D0) ) * SCALE

      POINT(1) = LAMBDA * NA2
      POINT(2) = LAMBDA * NB2
      POINT(3) = LAMBDA * NC2

      END


      DOUBLE PRECISION FUNCTION DT_TDIFF(Ecm,Tmin,Xm1i,K1,Xm2i,K2,Irej)

C***********************************************************************
C t-selection for single/double diffractive interactions.              *
C          ECM      cm. energy                                         *
C          TMIN     minimum momentum transfer to produce diff. masses  *
C          XM1/XM2  diffractively produced masses                      *
C                   (for single diffraction XM2 is obsolete)           *
C          K1/K2= 0 not excited                                        *
C               = 1 low-mass excitation                                *
C               = 2 high-mass excitation                               *
C This version dated 11.02.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION ALPHAP , BTP0 , DT_RNDM , Ecm , slope , t ,
     &                 Tmin , xdi , xm1 , Xm1i , xm2 , Xm2i , y , ZERO
      INTEGER Irej , K1 , K2 , ncloop
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0)

      PARAMETER (BTP0=3.7D0,ALPHAP=0.24D0)

      Irej = 0
      ncloop = 0
      DT_TDIFF = ZERO

      IF ( K1.GT.0 ) THEN
         xm1 = Xm1i
         xm2 = Xm2i
      ELSE
         xm1 = Xm2i
      END IF
      xdi = (xm1/Ecm)**2
      IF ( (K1.EQ.0) .OR. (K2.EQ.0) ) THEN
C slope for single diffraction
         slope = BTP0 - 2.0D0*ALPHAP*LOG(xdi)
      ELSE
C slope for double diffraction
         slope = -2.0D0*ALPHAP*LOG(xdi*xm2**2)
      END IF

 100  ncloop = ncloop + 1
      IF ( MOD(ncloop,1000).EQ.0 ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,99010) Ecm , Tmin , Xm1i , Xm2i ,
     &        K1 , K2
99010    FORMAT (1X,'DT_TDIFF:   t-selection rejected!',/,1X,'ECM  = ',
     &           E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',E12.3,' XM2I = ',
     &           E12.3,' K1 = ',I2,' K2 = ',I2)
         Irej = 1
      ELSE
         y = DT_RNDM(xdi)
         t = -LOG(1.0D0-y)/slope
         IF ( ABS(t).LE.ABS(Tmin) ) GOTO 100
         DT_TDIFF = -ABS(t)
      END IF

      END FUNCTION


! { dg-do run }
! Test program inspired by bug report from Walt Brainerd.
! http://gcc.gnu.org/ml/fortran/2005-04/msg00132.html
program tiny1
  real(4) x4
  real(8) x8
  if (minexponent(x4) /= exponent(tiny(x4))) call abort
  if (minexponent(x8) /= exponent(tiny(x8))) call abort
end program tiny1


#include "scalar.fpp"

program main

  ! import petsc modules

  use petscsys
  use petscvec
  use petscmat
  use petscpc
  use petscksp

  implicit none

  type(integer)     :: dim
  type(integer)     :: n = 100
  type(integer)     :: i, j, ii, jj
  type(integer)     :: istart, iend
  type(integer)     :: iters
  type(integer)     :: ierr, rank, size
  type(integer)     :: irow, icol

  type(logical)     :: flag
  type(real)        :: norm

  type(vec)         :: x, b, ax
  type(mat)         :: A
  type(ksp)         :: cksp
  type(pc)          :: cpc

  type(PetscViewer) :: viewer
  type(scalar)      :: tmp

  print *, "Initializing petsc"

  call PetscInitialize(PETSC_NULL_CHARACTER, ierr)

  ! Create matrix
  call MatCreate(PETSC_COMM_WORLD, A, ierr)
  call MatSetSizes(A, PETSC_DECIDE, PETSC_DECIDE, n, n, ierr)
  !call MatSetFromOptions(A, ierr)
  call MatSetUp(A, ierr)

  ! Get the ownership range of the matrix on each processor
  call MatGetOwnershipRange(A, istart, iend, ierr)

  ! print *, "ownership of rank", rank, " between ", istart, iend

  ! set entries into the matrix

  ! Create a central difference operator matrix
  rows: do irow = istart, iend - 1
     cols: do icol = istart, iend - 1
        if (irow .eq. icol) then
           tmp = 2.0_WP  ! d
        else if (irow .eq. icol - 1) then
           tmp = -1.0_WP ! -r
        else if (icol .eq. icol + 1) then
           tmp = -1.0_WP ! -r
        end if
        call MatSetValue(A, irow, icol, tmp, INSERT_VALUES, ierr)
     end do cols
  end do rows

  ! assemble matrix ( once the matrix is assembled, the matrix can
  ! not be changed )

  call MatAssemblyBegin(A, MAT_FINAL_ASSEMBLY, ierr)
  call MatAssemblyEnd(A, MAT_FINAL_ASSEMBLY, ierr)

  ! Optionally write and read matrix in binary file (debugging)
  ! call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'mat.bin', FILE_MODE_WRITE, viewer, ierr)
  ! call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'mat.bin', FILE_MODE_READ, viewer, ierr)
  ! call MatView(A, viewer, ierr)
  ! call PetscViewerDestroy(viewer,ierr)

  ! create vectors Create parallel vectors.  - Here, the parallel
!  partitioning of the vector is determined by PETSc at runtime.  We
!  could also specify the local dimensions if desired -- or use the
!  more general routine VecCreate().  - When solving a linear system,
!  the vectors and matrices MUST be partitioned accordingly.  PETSc
!  automatically generates appropriately partitioned matrices and
!  vectors when MatCreate() and VecCreate() are used with the same
!  communicator.  - Note: We form 1 vector from scratch and then
!  duplicate as needed.

  call VecCreateMPI(PETSC_COMM_WORLD, PETSC_DECIDE, n, ax, ierr)
  call VecSetFromOptions(ax, ierr)
  call VecDuplicate(ax, b, ierr)
  call VecDuplicate(b, x, ierr)

!!$
!!$  ! rhs vector
!!$  call VecCreate(PETSC_COMM_WORLD, b, ierr)
!!$  call VecSetSizes(b, PETSC_DECIDE, n, ierr)
!!$  call VecSetFromOptions(b, ierr)
!!$
!!$  ! solution vector
!!$  call VecCreate(PETSC_COMM_WORLD, x, ierr)
!!$  call VecSetSizes(x, PETSC_DECIDE, n, ierr)
!!$  call VecSetFromOptions(x, ierr)
!!$
!!$  ! temporary vector to store Ax
!!$  call VecCreate(PETSC_COMM_WORLD, ax, ierr)
!!$  call VecSetSizes(ax, PETSC_DECIDE, n, ierr)
!!$  call VecSetFromOptions(ax, ierr)

!  call VecSet(b, 1.0_WP, ierr)
!  call MatMult(A, x, b)

  !-------------------------------------------------------------------!
  ! Create the linear solver
  !-------------------------------------------------------------------!
 !  Set exact solution; then compute right-hand-side vector.
!  By default we use an exact solution of a vector with all
!  elements of 1.0;  Alternatively, using the runtime option
!  -random_sol forms a solution vector with random components.

!      call PetscOptionsHasName(PETSC_NULL_CHARACTER,                    &
!     &             "-random_exact_sol",flg,ierr)
!      if (flg) then
 !        call PetscRandomCreate(PETSC_COMM_WORLD,rctx,ierr)
 !        call PetscRandomSetFromOptions(rctx,ierr)
 !        call VecSetRandom(u,rctx,ierr)
 !        call PetscRandomDestroy(rctx,ierr)
 !     else
  call VecSet(ax, 1.0_WP, ierr)
  !     endif
  call MatMult(A, ax, b, ierr)

!  View the exact solution vector if desired

!      call PetscOptionsHasName(PETSC_NULL_CHARACTER,                    &
!     &             "-view_exact_sol",flg,ierr)
 !     if (flg) then
!  call VecView(ax, PETSC_VIEWER_STDOUT_WORLD, ierr)

  !    endif

  call KSPCreate(PETSC_COMM_WORLD, cksp, ierr)

  ! currently the matrix itself serves as the preconditioner
  !  call KSPSetOperators(cksp, A, A, ierr)
  call KSPSetOperators(cksp, A, A, DIFFERENT_NONZERO_PATTERN, ierr)

  ! The matrix and preconditioner are the same
!  call PetscOptionsHasName(PETSC_NULL_CHARACTER,'-my_ksp_monitor',  &
!       &                    flg,ierr)
!  if (flg) then
!  call KSPMonitorSet(sksp, MyKSPMonitor, PETSC_NULL_OBJECT,          &
!       &                     PETSC_NULL_FUNCTION, ierr)
  !  endif

 !-------------------------------------------------------------------!
 ! Solve the linear system
 !-------------------------------------------------------------------!

  call KSPSolve(cksp, b, x, ierr)

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!                     Check solution and clean up
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  !  Check the error
  call VecAXPY(x, -1.0_WP, b, ierr)
  call VecNorm(x, NORM_2, norm, ierr)
  call KSPGetIterationNumber(cksp, iters, ierr)

  if (norm .gt. 1.e-12) then
     print *, norm, iters
  else
     print *, norm, iters
  endif

  call VecView(ax, PETSC_VIEWER_STDOUT_WORLD, ierr)
  call VecView(b, PETSC_VIEWER_STDOUT_WORLD, ierr)

!!$ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!!$ !                     Check solution and clean up
!!$ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!!$
!!$ !  Check the error
!!$ call VecAXPY(x,-1.0_WP,u,ierr)
!!$ call VecNorm(x,NORM_2,norm,ierr)
!!$ call KSPGetIterationNumber(cksp,its,ierr)
!!$ if (rank .eq. 0) then
!!$    if (norm .gt. 1.e-12) then
!!$       write(6,100) norm,its
!!$    else
!!$       write(6,110) its
!!$    endif
!!$ endif
!!$100 format('Norm of error ',e11.4,' iterations ',i5)
!!$110 format('Norm of error < 1.e-12,iterations ',i5)

 !  Free work space.  All PETSc objects should be destroyed when they
 !  are no longer needed.

  print *, "Destroy KSP"
! call KSPDestroy(cksp, ierr)

 print *, "Destroy vectors"
! call VecDestroy(ax, ierr)
 print *, "Destroy vectors"
! call VecDestroy(x, ierr)
 print *, "Destroy vectors"
! call VecDestroy(b, ierr)

! call MatDestroy(A, ierr)

 print *, "Finalizing petsc done"
 call PetscFinalize(ierr)
 print *, "Execution complete"
end program main


program test_io_bin
    use forlab_io, only: disp, savebin, loadbin, savetxt, loadtxt
    use forlab_stats, only: rng, randn
    real(8), allocatable :: x(:)
    real(8), allocatable :: y(:)
    call rng()
    allocate(X(5))
    X = randn(mean=0.0_8, std=1.0_8, ndim=5)
    call disp(x,'call randn(X):')
    call savebin('DP.bin', x)
    call savetxt('DP.txt', x)
    call loadtxt('DP.txt', y)
    call disp(y,'read from DP.txt')
    call loadbin('DP.bin', y)
    call disp(y,'read from DP.bin')
end program test_io_bin


      SUBROUTINE JDAY(M,D,Y,DOY)
      IMPLICIT NONE

C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C  Routine to Calculate Day-of-Year from the given Month, Day, and Year
C  information
C
C  Fortran Usage:    Call  JDAY(M, D, Y, DOY)
C
C  Parameters:-
C
C       M:  Month           Input,   Integer*4
C       D:  Day of Month    Input,   Integer*4
C       Y:  Year            Input,   Integer*4
C     DOY:  Day of Year     Output,  Integer*4
C
C   History
C
C   07-28-92....WPL....Initial Release under MSTP (Ported for UNIX conversion)
C
C   07-08-1998 .TXH.   Modified date checking statements to use
C                      'date_check' subroutine calls for correct
C                      calculation of leap year.
C
C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

       INTEGER*4  M,D,Y,DOY

       INTEGER*4  LEAP,STATUS  ! flags to indicate leap year and status.

       Integer*4  BDOY(12)     ! Beginning Day of Year for the 12 months

C    Define beginnign day for each month (Regular, NON-Leap Year)

        BDOY(1) =   1   ! Beginning of January   is Day    1 of Year
        BDOY(2) =  32   !              Februrary          32
        BDOY(3) =  60   !              March              60
        BDOY(4) =  91   !              April              91
        BDOY(5) = 121   !              May               121
        BDOY(6) = 152   !              June              152
        BDOY(7) = 182   !              July              182
        BDOY(8) = 213   !              August            213
        BDOY(9) = 244   !              September         244
        BDOY(10)= 274   !              October           274
        BDOY(11)= 305   !              November          305
        BDOY(12)= 335   !              December          335

        LEAP = 0    ! initialize leap year flag
        STATUS = 0  ! initialize status flag

C Check some default inputs (original implementation)
C
C        If (M .LT. 1 .or.  M .GT. 12)  then
C          Call Xvmessage(' Input value of MONTH out of bound', ' ')
C          Call Abend
C        Endif
C        If (D .LT. 1  .or. D. GT. 31)  then
C          Call Xvmessage(' Input value of DAY out of bound', ' ')
C          Call Abend
C        Endif

C Check some default inputs (new implementation)
C Using the 'date_check' subroutines
        CALL CHK_DAY (Y,M,D,STATUS)
        IF (STATUS .EQ. 0) THEN
           CALL XVMESSAGE ('Invalid date input.',' ')
           CALL ABEND
        END IF

C    Calculate DOY  for NON-Leap year !
        DOY = BDOY(M) + D - 1

C Determine if the year is a leap year using 'date_check' subroutine
        CALL CHK_LEAP (Y, LEAP)

C Add 1 day for LEAP Year if Month passes Februrary
        IF ((LEAP .EQ. 1) .AND. (M .GT. 2)) THEN
            DOY = DOY + 1
        ENDIF

        RETURN
        END


MODULE constants

INTEGER, PARAMETER              :: idp = KIND(1.D0)
REAL(KIND = idp), PARAMETER     :: pi = 4.0_idp*ATAN(1.0_idp)
REAL(KIND = idp), PARAMETER     :: twopi = 2.0_idp*pi
REAL(KIND = idp), PARAMETER     :: eps = EPSILON(1.0_idp)

END MODULE  constants


! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original -Wrealloc-lhs" }
! PR 66094: Check functionality for MATMUL(A, TRANSPSE(B))
module x
contains
  subroutine mm1(a,b,c)
    real, dimension(:,:), intent(in) :: a, b
    real, dimension(:,:), intent(out) :: c
    c = -42.
    c = matmul(a, transpose(b))
  end subroutine mm1
end module x

program main
  use x
  implicit none
  integer, parameter :: n = 3, m=4, cnt=2
  real, dimension(n,cnt) :: a
  real, dimension(m,cnt) :: b
  real, dimension(n,m) :: c, cres
  real, dimension(:,:), allocatable :: calloc

  data a / 2., -3., 5., -7., 11., -13./
  data b /17., -23., 29., -31., 37., -39., 41., -47./
  data cres / -225., 356., -396., 227., -360., 392., &
       -229., 364., -388., 267., -424., 456./

  c = matmul(a,transpose(b))
  if (sum(c-cres)>1e-4) call abort
  call mm1 (a, b, c)
  if (sum(c-cres)>1e-4) call abort

  ! Unallocated
  calloc = matmul(a,transpose(b)) ! { dg-warning "Code for reallocating the allocatable array" }
  if (any(shape(c) /= shape(calloc))) call abort
  if (sum(calloc-cres)>1e-4) call abort
  deallocate(calloc)

  ! Allocated to wrong shape
  allocate (calloc(10,10))
  calloc = matmul(a,transpose(b)) ! { dg-warning "Code for reallocating the allocatable array" }
  if (any(shape(c) /= shape(calloc))) call abort
  if (sum(calloc-cres)>1e-4) call abort
  deallocate(calloc)

end program main
! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "original" } }


subroutine apply_pde_operator(t, q, output)

! For the PDE q_t = g(q), calculates g(q).
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: PDE solution at time t.
!   output: g(q), calculated here.

    !# use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(out) :: output

    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc) :: q_laplacian, x_flux, y_flux
    integer :: ix, iy
    double precision :: q_face

    call get_laplacian(q(:,:,1), q_laplacian)

    !$omp parallel do private(ix, q_face)
    do iy = 1, my
        do ix = 1, mx+1
            q_face = (q(ix-1, iy, 1) + q(ix, iy, 1)) / 2.d0
            x_flux(ix, iy) = q_face * (q_laplacian(ix, iy) - q_laplacian(ix-1, iy)) / dx
        end do
    end do

    !$omp parallel do private(ix, q_face)
    do iy = 1, my+1
        do ix = 1, mx
            q_face = (q(ix, iy-1, 1) + q(ix, iy, 1)) / 2.d0
            y_flux(ix, iy) = q_face * (q_laplacian(ix, iy) - q_laplacian(ix, iy-1)) / dy
        end do
    end do

    !$omp parallel do private(ix)
    do iy = 1, my
        do ix = 1, mx
            output(ix, iy, 1) = - (x_flux(ix+1, iy) - x_flux(ix, iy)) / dx  &
                - (y_flux(ix, iy+1) - y_flux(ix, iy)) / dy
        end do
    end do

end subroutine apply_pde_operator


c     program DRXBLAS
c>> 1996-05-28 DRXBLAS Krogh Added external statement.
c>> 1992-03-13 CLL
c   DRXBLAS..  Demo driver for DSDOT and SDSDOT
c     ------------------------------------------------------------------
      external DSDOT, SDSDOT
      double precision DSDOT
      real    SDSDOT

      double precision D1
      real    S1, X(4), Y(4)
      integer N
      data X  /  4.0, -7.0, 3.0, -9.0 /
      data Y  /  -2.0, -8.0, 5.0, 6.0 /
c     ------------------------------------------------------------------
      print'(a)',
     * ' DRXBLAS..  Demo driver for DSDOT and SDSDOT',
     * ' These subprograms accept SP data but use DP arithmetic.'
      N = 4
      S1 = SDSDOT(N, -9.0e0, X, 1, Y, 1)
      D1 = -9.0d0 + DSDOT(N, X, 1, Y, 1)
      print'(/a)',' Using SDSDOT and DSDOT.  Expect S1 = D1 = 0.0'
      print'(a,f8.2,a,f8.2)',' Computed: S1 =',S1,', D1 =',D1
      end


*> \brief \b SLARND
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL             FUNCTION SLARND( IDIST, ISEED )
*
*       .. Scalar Arguments ..
*       INTEGER            IDIST
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLARND returns a random real number from a uniform or normal
*> distribution.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] IDIST
*> \verbatim
*>          IDIST is INTEGER
*>          Specifies the distribution of the random numbers:
*>          = 1:  uniform (0,1)
*>          = 2:  uniform (-1,1)
*>          = 3:  normal (0,1)
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry, the seed of the random number generator; the array
*>          elements must be between 0 and 4095, and ISEED(4) must be
*>          odd.
*>          On exit, the seed is updated.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup real_matgen
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  This routine calls the auxiliary routine SLARAN to generate a random
*>  real number from a uniform (0,1) distribution. The Box-Muller method
*>  is used to transform numbers from a uniform to a normal distribution.
*> \endverbatim
*>
*  =====================================================================
      REAL             FUNCTION SLARND( IDIST, ISEED )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            IDIST
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO
      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0 )
      REAL               TWOPI
      PARAMETER          ( TWOPI = 6.2831853071795864769252867663E+0 )
*     ..
*     .. Local Scalars ..
      REAL               T1, T2
*     ..
*     .. External Functions ..
      REAL               SLARAN
      EXTERNAL           SLARAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          COS, LOG, SQRT
*     ..
*     .. Executable Statements ..
*
*     Generate a real random number from a uniform (0,1) distribution
*
      T1 = SLARAN( ISEED )
*
      IF( IDIST.EQ.1 ) THEN
*
*        uniform (0,1)
*
         SLARND = T1
      ELSE IF( IDIST.EQ.2 ) THEN
*
*        uniform (-1,1)
*
         SLARND = TWO*T1 - ONE
      ELSE IF( IDIST.EQ.3 ) THEN
*
*        normal (0,1)
*
         T2 = SLARAN( ISEED )
         SLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
      END IF
      RETURN
*
*     End of SLARND
*
      END


subroutine coordinates(xp, yp, dx, dy, imax, jmax)
use parameters
use kind_parameters
implicit none

integer, intent(in):: imax, jmax
real(kind=dp), intent(inout) :: xp(-1:imax+2), yp(-1:jmax+2)
real(kind=dp), intent(in) :: dx(imax), dy(jmax)
integer:: ip, jp

! locate the u position in x direction

!xu(1) = 0.0d0
!
!do iu = 2,iumax
!
!    xu(iu)=xu(iu-1) + delxu(iu-1)
!
!end do
!
!! locate the u position in y direction
!
!yu(1) = 0.0d0
!
!do ju = 2,jumax
!
!    yu(ju) = yu(ju-1) + delyu(ju-1)
!
!end do
!
!! locate the v position in x direction
!
!xv(1) = 0.0d0
!
!do iv = 2,ivmax
!
!  xv(iv) = xv(iv-1) + delxv(iv-1)
!
!end do
!
!! locate the v position in y direction
!
!do jv = 2,jvmax
!
!  yv(jv) = yv(jv-1) + delyv(jv-1)
!
!end do

! locate the p position in x direction

xp(1) = 0.0d0
xp(0) = xp(1) - 0.5*(dx(1) + dx(2))
xp(-1) = xp(0) - 0.5*(dx(2) + dx(3))

do ip = 2,imax

    xp(ip) = xp(ip-1) + 0.5*(dx(ip-1) + dx(ip))

end do

xp(imax+1) = xp(imax) + 0.5*(dx(imax-1) + dx(imax))
xp(imax+2) = xp(imax+1) + 0.5*(dx(imax-1) + dx(imax-2))

! locate the p position in y direction

yp(1) = 0.0d0
yp(0) = yp(1) - 0.5*(dy(1) + dy(2))
yp(-1) = yp(0) - 0.5*(dy(2) + dy(3))

do jp = 2,jmax

    yp(jp) = yp(jp-1) + 0.5*(dy(jp-1) + dy(jp))

end do

yp(imax+1) = yp(imax) + 0.5*(dy(jmax-1) + dy(jmax))
yp(imax+2) = yp(imax+1) + 0.5*(dy(jmax-1) + dy(jmax-2))

end subroutine


      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END


      SUBROUTINE DBLFFT(Z,N,ISIGN)
      COMPLEX Z(1),TEMP,W,V,B1
      NH=N/2
      NN=NH
      CALL FOUR(Z,NN,ISIGN)
      NQ=N/4
      NQ1=NQ+1
      B1=AIMAG(Z(1))
      Z(1)=REAL(Z(1))
      DO 112 I=2,NQ
      TEMP=0.5*(Z(I)+CONJG(Z(NH+2-I)))
      Z(NH+2-I)=(0.,-0.5)*(Z(I)-CONJG(Z(NH+2-I)))
  112 Z(I)=TEMP
      TWOPI=6.28318
      THETA=TWOPI/FLOAT(N)
      W=CMPLX(COS(THETA),(ISIGN)*(SIN(THETA)))
C
      TEMP=Z(1)+B1
      B1=Z(1)-B1
      Z(1)=TEMP
      DO 113 I=2,NQ
      V=(Z(NH+2-I))*(W**(I-1))
      Z(NH+2-I)=Z(I)-V
  113 Z(I)=Z(I)+V
      RETURN
      END


module make_grav_module

  use amrex_constants_module, only: ZERO, HALF, ONE, M_PI
  use probin_module, only : g0
  use base_state_geometry_module, only: nr_fine, dr, nr, max_radial_level, finest_radial_level

  implicit none

  private

  public :: make_grav_cell, make_grav_edge, grav_zone

contains

  pure function grav_zone(y) result (g)

    double precision, intent(in) :: y
    double precision :: g
    double precision :: fg

    if (y < 1.0625d0 * 4.d8) then
        fg = HALF * (ONE + sin(16.d0 * M_PI * (y/4.d8 - 1.03125d0)))
    else if (y > 2.9375d0 * 4.d8) then
        fg = HALF * (ONE - sin(16.d0 * M_PI * (y/4.d8 - 2.96875d0)))
    else
        fg = ONE
    endif

    g = fg * g0 / ((y / 4.d8)**1.25d0)

  end function grav_zone

  subroutine make_grav_cell(grav_cell,rho0,r_cc_loc,r_edge_loc) &
       bind(C, name="make_grav_cell")
    ! compute the base state gravitational acceleration at the cell
    ! centers.  The base state uses 0-based indexing, so grav_cell
    ! does too.

    double precision, intent(  out) ::  grav_cell(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) ::       rho0(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) ::   r_cc_loc(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: r_edge_loc(0:max_radial_level,0:nr_fine  )

    ! Local variables
    integer :: r, n

    call bl_proffortfuncstart("Maestro::make_grav_cell")

    do n = 0, finest_radial_level
        do r = 0, nr(n)-1
           grav_cell(n,r) = grav_zone(r_cc_loc(n,r))
        enddo
     enddo

    call bl_proffortfuncstop("Maestro::make_grav_cell")

  end subroutine make_grav_cell

  subroutine make_grav_edge(grav_edge,rho0,r_edge_loc) &
       bind(C, name="make_grav_edge")
    ! compute the base state gravity at the cell edges
    ! grav_edge(0) is the gravitational acceleration at the left edge of zone 0).
    ! The base state uses 0-based indexing, so grav_edge does too.

    double precision, intent(  out) ::  grav_edge(0:max_radial_level,0:nr_fine  )
    double precision, intent(in   ) ::       rho0(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: r_edge_loc(0:max_radial_level,0:nr_fine  )

    ! Local variables
    integer                      :: r, n

    call bl_proffortfuncstart("Maestro::make_grav_edge")

    do n = 0, finest_radial_level
        do r = 0, nr(n)-1
           grav_edge(n,r) = grav_zone(r_edge_loc(n,r))
        enddo
     enddo

    call bl_proffortfuncstop("Maestro::make_grav_edge")

  end subroutine make_grav_edge

end module make_grav_module