C NCLFORTSTART
      subroutine cfftfdriver (nmx,xr,xi,acoef,bcoef,work,nw)
      implicit none
c                                      ! INPUT
      integer  nmx,nw
      double precision xr(nmx),xi(nmx),work(nw)
c                                      ! OUTPUT
      double precision acoef(nmx), bcoef(nmx)
c NCLEND
c
c NCL:  coef = cfftf( xr, xi, opt)     ! coef(2,...)
c                                      ! LOCAL
      integer  n
c     double precision work(4*nmx+25)
      double complex   carr(nmx)

      call cffti(nmx,work)
c                                      ! create complex input
      do n=1,nmx
         carr(n) = cmplx( xr(n), xi(n) )
      end do

      call cfftf(nmx, carr, work)

      do n=1,nmx
         acoef(n) = dble ( carr(n) )
         bcoef(n) = dimag( carr(n) )
      end do

      return
      end

C NCLFORTSTART
      subroutine cfftbdriver (nmx,xr,xi,acoef,bcoef,work,nw)
      implicit none
c                                      ! INPUT
      integer  nmx,nw
      double precision acoef(nmx), bcoef(nmx), work(nw)
c                                      ! OUTPUT
      double precision xr(nmx), xi(nmx)
c NCLEND
c
c NCL:  coef = cfftb( acoef, bcoef, opt )
c                                      ! LOCAL
      integer  n
c      double precision work(4*nmx+25)
      double complex   carr(nmx)

      call cffti(nmx,work)
c                                      ! create complex input
      do n=1,nmx
         carr(n) = cmplx( acoef(n), bcoef(n))
      end do

      call cfftb(nmx, carr, work)
c                                      ! reconstruct ... normalize
      do n=1,nmx
         xr(n) = dble ( carr(n) ) / nmx
         xi(n) = dimag( carr(n) ) / nmx
      end do

      return
      end

C NCLFORTSTART
      subroutine frqcfft (npts,frq)
      implicit none
c
c SPECIAL to generate frequencies for frq attribute: cfftf
c .   Need to allow for a back transform so no order change
c                                                  ! input
      integer npts
c                                                  ! output
      double precision frq(npts)
C NCLEND
c                                                  ! local
      integer n
      double precision df
c                                      frequency interval
      df  =  1.0d0/npts
c                                      generate frequencies
      do n=1,npts
         frq(n) = (n-1)*df
         if (frq(n).gt.0.5d0) frq(n) = frq(n) - 1.0d0
      end do

      return
      end

C NCLFORTSTART
      subroutine cfftffrqreorder (npts,frqi,cfai,cfbi,frqo,cfao,cfbo)
      implicit none
c
c SPECIAL to reorder frequencies to range from -0.5 to +0.5
c .   Generally, for graphics reasons only.
c                                                  ! input
      integer npts
      double precision frqi(npts), cfai(npts), cfbi(npts)
c                                                  ! output
      double precision frqo(npts), cfao(npts), cfbo(npts)
C NCLEND
c
c NCL: cf_reorder = cfftf_frq_reorder( cf )
c                                                  ! local
      integer n, n2

      n2  = npts/2
c                             for clarity use two differnt sections
      if (mod(npts,2).eq.0) then
c                                                  ! even
          do n=1,n2
             frqo(n) = frqi(n+n2)
             cfao(n) = cfai(n+n2)
             cfbo(n) = cfbi(n+n2)
          end do

          if (frqo(1).gt.0.0d0) frqo(1) = -frqo(1)

          do n=1,n2
             frqo(n2+n) = frqi(n)
             cfao(n2+n) = cfai(n)
             cfbo(n2+n) = cfbi(n)
          end do
      else
c                                                  ! odd
          do n=1,n2
             frqo(n)    = frqi(n+n2+1)
             cfao(n)    = cfai(n+n2+1)
             cfbo(n)    = cfbi(n+n2+1)
          end do

          do n=1,n2+1
             frqo(n2+n) = frqi(n)
             cfao(n2+n) = cfai(n)
             cfbo(n2+n) = cfbi(n)
          end do
      end if

      return
      end


module pde

! This module contains all information that appears inside the PDEs.
! It specifies how many equations shall be solved, the numerical data,
! the routines to compute the fluxes from the solution, routines for
! computing primitive variables from the conserved solution U, etc.
!
! ---------- SHALLOW WATER EQUATIONS ----------

  use global_module

  implicit none

  integer, parameter      :: Neq = 3    ! Number of equations
  real(kind=8), parameter :: g   = 9.81 ! [N/kg] Earth's gravity

  ! Initial conditions
  real(kind=8), parameter :: h0   = 1.0     ! [m]
  real(kind=8), parameter :: ux0  = 0.0     ! [m/s]
  real(kind=8), parameter :: uy0  = 0.0     ! [m/s]

  ! Name of primitive variables, used ONLY for exporting the solution to VTK file
  ! NOTE: To initialize it here, all entries need to have the same length!!!
  !       I'm using two letters for simplicity.
  character(len=20), dimension(Neq) :: prim_names = (/'hh','Ux','Uy'/)

  contains

  ! ============================================================

  subroutine initialize_solution(U)

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    ! Initialize internal cells (i = "1,2" and "Nx-1, Nx" are ghost cells. Same thing for j)
    U(1, 3:Nx-2, 3:Ny-2) = h0     ! Density
    U(2, 3:Nx-2, 3:Ny-2) = h0*ux0 ! Momentum along x
    U(3, 3:Nx-2, 3:Ny-2) = h0*uy0 ! Momentum along y

    U(1, floor((Nx)/3.0):floor(real(Nx)/2.0), floor((Ny)/3.0):floor(real(Ny)/2.0)) = 2.0*h0
    U(2, floor((Nx)/3.0):floor(real(Nx)/2.0), floor((Ny)/3.0):floor(real(Ny)/2.0)) = 2.0*h0*ux0
    U(3, floor((Nx)/3.0):floor(real(Nx)/2.0), floor((Ny)/3.0):floor(real(Ny)/2.0)) = 2.0*h0*uy0

  end subroutine

  ! ============================================================

  subroutine assign_BCs(U)

  ! This subroutine assigns boundary values to the ghost cells.
  ! In this form, we impose periodic BCs, by copying into the ghost cells the values inside the
  ! domain cells at the other side of the domain.

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer :: i, j

    ! Periodic BCs
    U(:, 1:2, :)     = U(:, Nx-3:Nx-2, :) ! Left BC
    U(:, Nx-1:Nx, :) = U(:, 3:4, :)       ! Right BC
    U(:, :, 1:2)     = U(:, :, Ny-3:Ny-2) ! Bottom BC
    U(:, :, Ny-1:Ny) = U(:, :, 3:4)       ! Top BC

  end subroutine

  ! ============================================================

  subroutine compute_primitive_from_conserved(U, prim)

    ! Computes vector of primitive variables "prim" from the conserved variables "U"

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: prim

    ! Working variables
    real(kind=8) :: h, ux, uy

    ! Extract primitive variables
    h  = U(1)
    ux = U(2)/(h + 1.0d-25) ! Use a small tolerance, since h may be zero
    uy = U(3)/(h + 1.0d-25) ! Use a small tolerance, since h may be zero

    ! Compose array of primitive variables
    prim(1) = h
    prim(2) = ux
    prim(3) = uy

  end subroutine

  ! ============================================================

  subroutine compute_conserved_from_primitive(prim, U)

    ! Computes vector of conserved variables "U" from the primitive variables "prim"

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: prim
    real(kind=8), dimension(Neq), intent(out) :: U

    ! Working variables

    U(1) = prim(1)
    U(2) = prim(1)*prim(2)
    U(3) = prim(1)*prim(3)

  end subroutine

  ! ============================================================

  subroutine compute_flux_ws_x(U, Fx, ws_max, ws_min)

    ! Computes the convective flux along x,
    ! and also the maximum and minimum wave speeds (required by some numerical flux schemes)

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fx
    real(kind=8), intent(out) :: ws_max, ws_min

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: h, ux, uy

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    h  = prim(1)
    ux = prim(2)
    uy = prim(3)

    ! Assemble fluxes Fx
    Fx(1) = h*ux
    Fx(2) = h*ux*ux + 0.5*g*h**2
    Fx(3) = h*ux*uy

    ! Maximum and minimum wave speeds (eigenvalues of the Euler system)
    ws_max = ux + sqrt(g*h)
    ws_min = ux - sqrt(g*h)

  end subroutine

  ! ============================================================

  subroutine compute_flux_ws_y(U, Fy, ws_max, ws_min)

    ! Computes the convective flux along y,
    ! and also the maximum and minimum wave speeds (required by some numerical flux schemes)

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fy
    real(kind=8), intent(out) :: ws_max, ws_min

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: h, ux, uy

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    h  = prim(1)
    ux = prim(2)
    uy = prim(3)

    ! Assemble fluxes Fx
    Fy(1) = h*uy
    Fy(2) = h*ux*uy
    Fy(3) = h*uy*uy + 0.5*g*h*h

    ! Maximum and minimum wave speeds (eigenvalues of the Euler system)
    ws_max = uy + sqrt(g*h)
    ws_min = uy - sqrt(g*h)

  end subroutine

end module


! Routine for n-dimensional optimization through
! quasi-Newton methods: DFP or BFGS.
! Igor Lopes, February 2015
SUBROUTINE QUASINEWTON(NDIM)
    IMPLICIT NONE
    ! Parameters
    REAL(8) CONVTOL /1.0D-6/
    REAL(8) R0 /0.0D0/
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    REAL(8) R5 /5.0D0/
    ! Arguments
    INTEGER :: NDIM
    ! Locals
    REAL(8)         :: GOLD, FO, TOL, EVALFUNC, AMIN, FMIN, ANOR, &
                            BNOR, BETA, THETA, SIGMA, TAU, RELDIF
    REAL(8),DIMENSION(NDIM)      :: XO, XN, GRAD, GRADO, SDIR, XMAX, XMIN
    REAL(8),DIMENSION(NDIM,1)    :: DX, DGRAD, AVEC
    REAL(8),DIMENSION(1,NDIM)    :: DXT, AVECT
    REAL(8),DIMENSION(NDIM,NDIM) :: HMAT, DMAT, AMAT
    REAL(8),DIMENSION(2)         :: ALPHO
    REAL(8),DIMENSION(4)         :: ALPH, FN
    INTEGER         :: I, ITER, MITER, NITER
    CHARACTER       :: STRING*256
    ! Initialize
    GOLD=(R1+DSQRT(R5))/R2
    STRING='quasi_newton.res'
    CALL RESULTFILE(STRING)
    HMAT=R0
    DO I=1,NDIM
        HMAT(I,I)=R1
    ENDDO
    ! Formats
5   FORMAT('-------------------------------------------------------------------------')
10  FORMAT('ITER.',6X,<NDIM>('X_'I3,10X),'F',14X,'alpha')
15  FORMAT(I3,4X,<NDIM>(G12.6,3X),G12.6,3X,G12.6)
    ! Begin algorithm
20  WRITE(*,*)'Define THETA value:'
    WRITE(*,*)'0 - DFP (minimum)'
    WRITE(*,*)'1 - BFGS (maximum)'
    READ(*,*)THETA
    IF(THETA.LT.R0.OR.THETA.GT.R1)THEN
        WRITE(*,*)'THETA out of range.'
        GOTO 20
    ENDIF
    WRITE(*,*)'Define limits for each variable:'
    WRITE(11,*)'Variables limits:'
    WRITE(11,*)'i     Xmin     Xmax'
    DO I=1,NDIM
        WRITE(*,*)'Xmin_',I,' Xmax_',I
        READ(*,*)XMIN(I),XMAX(I)
        WRITE(11,*)I,XMIN(I),XMAX(I)
    ENDDO
    WRITE(*,*)'Give an initial guess for design variables X'
    READ(*,*)(XO(I),I=1,NDIM)
    WRITE(*,*)'Define maximum number of iterations'
    READ(*,*)MITER
    WRITE(*,*)'Define tolerance for step search'
    READ(*,*)TOL
    WRITE(11,*)'THETA=',THETA
    WRITE(11,*)'Maximum number of iterations=',MITER
    WRITE(11,*)'Tolerance for step search=',TOL
    NITER=INT(LOG(TOL)/LOG(GOLD-R1))+R1
    !
    FO=EVALFUNC(XO,NDIM)
    WRITE(11,5)
    WRITE(*,5)
    WRITE(11,10)(I,I=1,NDIM)
    WRITE(*,10)(I,I=1,NDIM)
    WRITE(11,5)
    WRITE(*,5)
    WRITE(11,15)0,XO,FO
    WRITE(*,15)0,XO,FO
    !
    CALL GRADIENT(GRAD,XO,NDIM)
    DO ITER=1,MITER
        CALL MATPRD(HMAT,GRAD,SDIR,NDIM,NDIM,1)
        SDIR=-SDIR
        CALL FINDBOUNDS(XO,FO,ALPHO(1),ALPHO(2),XMAX,XMIN,SDIR,NDIM)
        CALL GOLDENSECTIONNDIM(XO,ALPHO,ALPH,FN,NITER,SDIR,NDIM)
        ! Determine minimum
        AMIN=ALPH(1)
        FMIN=FN(1)
        DO I=2,4
            IF(FN(I).LT.FMIN)THEN
                FMIN=FN(I)
                AMIN=ALPH(I)
            ENDIF
        ENDDO
        XN=XO+AMIN*SDIR
        WRITE(11,15)ITER,(XN(I),I=1,NDIM),FMIN,AMIN
        WRITE(*,15)ITER,(XN(I),I=1,NDIM),FMIN,AMIN
        ! Check convergence
        RELDIF=DABS(FMIN-FO)
        IF(DABS(FO).GT.CONVTOL)RELDIF=RELDIF/DABS(FO)
        IF(RELDIF.LT.CONVTOL)THEN
            !FINISH PROCESS
            GOTO 99
        ENDIF
        ! Update HMAT
        GRADO=GRAD
        CALL GRADIENT(GRAD,XN,NDIM)
        DO I=1,NDIM
            DX(I,1)=XN(I)-XO(I)
            DGRAD(I,1)=GRAD(I)-GRADO(I)
        ENDDO
        SIGMA=DOT_PRODUCT(DX(:,1),DGRAD(:,1))
        CALL TRANSPOSE(DX,DXT,NDIM,1)
        CALL MATPRD(HMAT,DGRAD,AVEC,NDIM,NDIM,1)
        TAU=DOT_PRODUCT(DGRAD(:,1),AVEC(:,1))
        CALL MATPRD(DX,DXT,AMAT,NDIM,1,NDIM)
        DMAT=AMAT*(SIGMA+TAU*THETA)/(SIGMA*SIGMA)
        CALL TRANSPOSE(AVEC,AVECT,NDIM,1)
        CALL MATPRD(AVEC,AVECT,AMAT,NDIM,1,NDIM)
        DMAT=DMAT+AMAT*(THETA-R1)/TAU
        CALL MATPRD(AVEC,DXT,AMAT,NDIM,1,NDIM)
        DMAT=DMAT-AMAT*THETA/SIGMA
        CALL MATPRD(DX,AVECT,AMAT,NDIM,1,NDIM)
        DMAT=DMAT-AMAT*THETA/SIGMA
        HMAT=HMAT+DMAT
        XO=XN
        FO=FMIN
    ENDDO
99  WRITE(11,5)
    WRITE(*,5)
    CLOSE(UNIT=11)
END SUBROUTINE


module dimensions
    implicit none
    integer, parameter :: width = 1000
    integer, parameter :: height = 1000
end module dimensions

program main
    use dimensions
    implicit none

    double precision, parameter :: temp_tolerance = 0.01
    double precision            :: worst_dt = 100.0
    integer                     :: i, j
    integer                     :: iteration = 1
    real                        :: begin_time, end_time, elapsed

    double precision            :: temperature(0:height+1, 0:width+1)
    double precision            :: temperature_previous(0:height+1, 0:width+1)

    ! Start measuring time
    call cpu_time(begin_time)

    ! initialize temperature profile
    call initialize(temperature_previous)

    do while (worst_dt > temp_tolerance)
        ! finite difference
        do j = 1, width
            do i = 1, height
                temperature(i,j) = 0.25 * (temperature_previous(i+1,j) &
                                        + temperature_previous(i-1,j)  &
                                        + temperature_previous(i,j+1)  &
                                        + temperature_previous(i,j-1));
            enddo
        enddo

        ! calculate max difference between temperature and temperature_previous
        worst_dt = 0.0
        do j = 1, width
            do i = 1, height
                worst_dt = max(abs(temperature(i,j) - &
                                temperature_previous(i,j)), &
                                worst_dt);
            enddo
        enddo

        ! update temperature_previous
        do j = 1, width
            do i = 1, height
                temperature_previous(i,j) = temperature(i,j)
            enddo
        enddo

        ! track progress
        if (mod(iteration, 100) == 0) then
            call track_progress(iteration, temperature)
        endif

        iteration = iteration + 1
    enddo

    ! Stop measuring time and calculate the elapsed time
    call cpu_time(end_time)
    elapsed = end_time - begin_time

    write(*, '("Total time was ", f9.6, " seconds.")') elapsed
    write(*, '("Max error at iteration ", i0, " was ", f9.6)') iteration-1, worst_dt

end program main

subroutine initialize(temperature_previous)
    use dimensions
    implicit none

    double precision :: temperature_previous(0:height+1, 0:width+1)
    integer          :: i,j

    ! initialize temperature_previous to 0.0
    do j = 0, width+1
        do i = 0, height+1
            temperature_previous(i,j) = 0.0
        enddo
    enddo

    ! setting the left and right boundary conditions
    do i = 0, height+1
        temperature_previous(i,0) = 0.0
        temperature_previous(i,width+1) = (100.0/height)*i
    enddo

    ! setting the top and bottom boundary condition
    do j = 0, width+1
        temperature_previous(0,j) = 0.0
        temperature_previous(height+1,j) = (100.0/width)*j
    enddo
end subroutine initialize

subroutine track_progress(iteration, temperature)
    use dimensions
    implicit none

    integer          :: iteration
    double precision :: temperature(0:height+1, 0:width+1)
    integer          :: i

    write(*, '("---------- Iteration number: ", i0, " ----------")') iteration
    do i = height-5, height
        write(*, '("["i0,","i0,"]:",f6.2," ")', advance='no') &
                     i, i, temperature(i,i)
    enddo
    write(*,*)
end subroutine track_progress


    MODULE cdf_neg_binomial_mod
! ----------------------------------------------------------------------

!                           cdf_neg_binomial_mod
!                           *=*=*=*=*=*=*=*=*=*=

!  -  SUBROUTINE CDF_NEG_BINOMIAL(WHICH, CUM, CCUM, F, S, PR, CPR,
!                                 STATUS, BCHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_NEG_BINOMIAL(F, S, N, PR, CPR, STATUS,
!                                             CHECK_INPUT)
!  -  REAL (dpkind)FUNCTION CCUM_NEG_BINOMIAL(F, S, N, PR, CPR, STATUS,
!                                             CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_NEG_BINOMIAL(CUM, CCUM, N, PR, CPR,
!                                             STATUS, CHECK_INPUT)

!                             The Distribution
!                             ================

!   The density of the negative binomial distribution provides the
!   probability of precisely F failures before the S'th success in
!   independent binomial trials, each with probability of success PR.
!   The density is:

!                          (  F+S-1  )  S       F
!                          (   S-1   )PR  (1-PR)

!   The cumulative distribution function is the probability of F or fewer
!   failures before the F'th success.The negative binomial is extended to
!   non-integer values of F via the relation between the cumulative
!   distribution function of the negative binomial and the incomplete beta
!   function.
!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    four arguments is to be calculated.
!  Input Range: [ 1:4 ]
!     - 1 CUM and CCUM
!     - 2 F
!     - 3 S
!     - 4 PR and CPR
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the negative-binomial
!    distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL : CCUM. One minus the CDF of the binomial
!    distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: F. The number of failures before the S'th success.
!  Range: [ 0: ]
!  - REAL (dpkind) :: S. The number of successes to occur.
!  Input Range: [ 0: ]
!  - REAL (dpkind) :: PR. The probability of success in each independent
!    trial.
!  Range: [ 0:1 ]
!  - REAL (dpkind) :: CPR. One minus the probability of success in each
!    independent trial; the probability of failure in each trial.
!  Range: [ 0:1 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!        0 problem successfully solved
!       -1 WHICH outside input range
!       -2 CUM outside range
!       -3 CCUM outside range
!       -4 F outside range
!       -5 S outside range
!       -6 PR outside range
!       -7 CPR outside range
!        3 CUM + CCUM is not nearly one
!        4 PR + CPR is not nearly one
!       10 cdf_beta (in local_cum_neg_binomial) has no answer.
!      -50 Answer (if any) is BELOW the LOWER search bound
!       50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!        .TRUE. input argument values are not checked for validity.

!  NOTE: CUM and CCUM and also PR and CPR must add to (nearly) one.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_neg_binomial, cdf_neg_binomial, cum_neg_binomial, &
        inv_neg_binomial
! ..
    CONTAINS

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

      FUNCTION ccum_neg_binomial(f,s,pr,cpr,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_neg_binomial
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL, INTENT (IN) :: cpr, pr
        REAL (dpkind), INTENT (IN) :: f, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_neg_binomial(which=1,cum=ccum_neg_binomial,f=f,s=s, &
          pr=pr,cpr=cpr,status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_neg_binomial

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

      SUBROUTINE cdf_neg_binomial(which,cum,ccum,f,s,pr,cpr,status, &
          check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cpr, cum, pr
        REAL (dpkind) :: f, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cpr, local_cum, local_pr, &
          try_ccum, try_cpr, try_cum, try_pr
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum, vary_pr
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

! Check that at least one of cum, ccum is present in the calling list

        CALL check_complements(cum,ccum,the_negative_binomial%name,'cum', &
          'ccum',local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        CALL check_complements(pr,cpr,the_negative_binomial%name,'pr', &
          'cpr',local_pr,local_cpr,set_values=(which/=4),bad_status=4, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

!==========
! Check that probabilities add to one
!==========

        IF (which/=4) THEN
          IF ( .NOT. add_to_one(local_pr,local_cpr,the_binomial%name,'pr' &
            ,'cpr',4,status)) RETURN
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = f
        params(4) = s
        params(5) = local_pr
        params(6) = local_cpr

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_negative_binomial,which,params, &
            status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF
        END IF

!++++++++++++++++++++++++++++++++++++++++++++++++++
! Compute the Answers
!++++++++++++++++++++++++++++++++++++++++++++++++++

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)

        CASE (1)
! Calculate cum and ccum (cdf)

          CALL local_cum_neg_binomial(f,s,local_pr,local_cpr,local_cum, &
            local_ccum,status)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)
! Calculate f

          f = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_negative_binomial,3,local)

          DO
            CALL rc_step_zf(zf_status,f,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_neg_binomial(f,s,local_pr,local_cpr,try_cum, &
              try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        CASE (3)
! Calculate s

          s = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_negative_binomial,4,local)

          DO
            CALL rc_step_zf(zf_status,s,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_neg_binomial(f,s,local_pr,local_cpr,try_cum, &
              try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        CASE (4)

! Solve for probability

!!! A difficult case -- we will try to match the lesser of cum and ccum
!!! If the answer <= 1/2 we will vary pr else we will vary cpr

          zf_status = 0

! Decide whether to vary pr or cpr

          CALL local_cum_neg_binomial(f,s,half,half,try_cum,try_ccum, &
            status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF

! Opposite than for BINOMIAL distribution!!!

          vary_pr = (try_cum>local_cum)

          IF (match_cum .AND. vary_pr) THEN

! We are trying to match cum varying pr

            CALL cdf_set_zero_finder(the_dummy_binomial,1,local)

            DO
              CALL rc_interval_zf(zf_status,try_pr,fx,local)

              IF (zf_status/=1) EXIT

              try_cpr = one - try_pr

              CALL local_cum_neg_binomial(f,s,try_pr,try_cpr,try_cum, &
                try_ccum,status)

              IF (has_status) THEN
                IF (status/=0) THEN
                  RETURN
                END IF
              END IF

              fx = local_cum - try_cum
            END DO

          ELSE IF (match_cum .AND. .NOT. vary_pr) THEN
! Try to match cum varying cpr

            CALL cdf_set_zero_finder(the_dummy_binomial,2,local)

            DO

              CALL rc_interval_zf(zf_status,try_cpr,fx,local)

              IF (zf_status/=1) EXIT

              try_pr = one - try_cpr

              CALL local_cum_neg_binomial(f,s,try_pr,try_cpr,try_cum, &
                try_ccum,status)

              IF (has_status) THEN
                IF (status/=0) THEN
                  RETURN
                END IF
              END IF

              fx = local_cum - try_cum
            END DO

          ELSE IF ( .NOT. match_cum .AND. vary_pr) THEN
! Try to match ccum varying pr

            CALL cdf_set_zero_finder(the_dummy_binomial,1,local)

            DO
              CALL rc_interval_zf(zf_status,try_pr,fx,local)

              IF (zf_status/=1) EXIT

              try_cpr = one - try_pr

              CALL local_cum_neg_binomial(f,s,try_pr,try_cpr,try_cum, &
                try_ccum,status)

              IF (has_status) THEN
                IF (status/=0) THEN
                  RETURN
                END IF
              END IF

              fx = local_ccum - try_ccum

            END DO

          ELSE

! Try to match ccum varying cpr

            CALL cdf_set_zero_finder(the_dummy_binomial,2,local)

            DO
              CALL rc_interval_zf(zf_status,try_cpr,fx,local)

              IF (zf_status/=1) THEN
                IF (PRESENT(pr)) pr = try_pr
                IF (PRESENT(cpr)) cpr = try_cpr

                EXIT
              END IF

              try_pr = one - try_cpr

              CALL local_cum_neg_binomial(f,s,try_pr,try_cpr,try_cum, &
                try_ccum,status)

              IF (has_status) THEN
                IF (status/=0) THEN
                  RETURN
                END IF
              END IF

              fx = local_ccum - try_ccum
            END DO

          END IF

        END SELECT

        IF (has_status) THEN
! Set the status of the zero finder
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_neg_binomial

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

      FUNCTION cum_neg_binomial(f,s,pr,cpr,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_neg_binomial
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL, INTENT (IN) :: cpr, pr
        REAL (dpkind), INTENT (IN) :: f, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_neg_binomial(which=1,cum=cum_neg_binomial,f=f,s=s,pr=pr, &
          cpr=cpr,status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_neg_binomial

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

      FUNCTION inv_neg_binomial(cum,ccum,s,pr,cpr,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_neg_binomial
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL, INTENT (IN) :: ccum, cpr, cum, pr
        REAL (dpkind), INTENT (IN) :: s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_neg_binomial(which=2,cum=cum,ccum=ccum, &
          f=inv_neg_binomial,s=s,pr=pr,cpr=cpr,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION inv_neg_binomial

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

      SUBROUTINE local_cum_neg_binomial(f,s,pr,cpr,cum,ccum,status)

!                              METHOD

!     Formula  26.5.26    of   Abramowitz  and    Stegun,  Handbook   of
!     Mathematical   Functions (1966) is   used  to reduce the  negative
!     binomial distribution to the cumulative beta distribution.
! .. Use Statements ..
        USE cdf_beta_mod
! ..
! .. Scalar Arguments ..
! .. Local Scalars
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: cpr, f, pr, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Scalars ..
        INTEGER :: beta_status
! ..
        CALL cdf_beta(1,cum,ccum,x=pr,cx=cpr,a=s,b=f+one, &
          check_input=.FALSE.,status=beta_status)

        IF (beta_status/=0) THEN
! cdf_beta has NO answer.

          IF (PRESENT(status)) THEN
            status = 10
          ELSE
            WRITE (*,*) &
              'Error in local_cum_neg_binomial call to cdf_beta'
            WRITE (*,*) 'Status: ', beta_status

            STOP 'Error in local_cum_neg_binomial call to cdf_beta'
          END IF
        END IF

        RETURN

      END SUBROUTINE local_cum_neg_binomial

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

    END MODULE cdf_neg_binomial_mod


PROGRAM F015

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: INPUT_GRID_DIMENSION = 20;

    REAL (KIND=8)      :: ROUTES_N = 1;

    INTEGER :: I

    DO I = 1, INPUT_GRID_DIMENSION
        ROUTES_N = ROUTES_N * REAL(I + INPUT_GRID_DIMENSION, 8) / REAL(I, 8);
    END DO

    PRINT ('(I0)'), CEILING(ROUTES_N, 8)

END PROGRAM F015


       ! Exponential Map of Tensor Arguments
       ! --------------------------------------------------------
       ! Algorithmic Sources
       ! Miehe(2002): Homogenization of inelastic solid materials
       !    at (nite strains based on incremental minimization
       !    principles. Application
       !    to the texture analysis of polycrystals

       ! --------------------------------------------------------
       ! Author: A. Dutzler, Graz University of Technology
       ! Date:   2018-04-06

       function dexp_2(T)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: Eye,N_i,N_j,N_r
        type(Tensor4) :: dexp_2
        real(kind=8)  :: tol,I1,I2,I3,g_i
        integer :: i,j,r

        tol = 1.0d-8
        i = 2

        Eye = identity2(Eye)
        dexp_2 = Eye.cdya.Eye

        I1 = T**Eye
        I2 = 0.5*(I1**2-T**T)
        I3 = det(T)

        N_i = Eye
        do while (norm(N_i)/fact(i) .gt. tol)
         g_i = 1./fact(i)
         if (i >= 3) then
           ! Cayley-Hamilton recursive formula
           N_i = I1 * T**(i-1) - I2 * T**(i-2) + I3 * T**(i-3)
         else
           N_i = T**i
         end if

         do r=0,i-1
          j = i-1-r

          if (j >= 3) then
           ! Cayley-Hamilton recursive formula
           N_j = I1 * T**(j-1) - I2 * T**(j-2) + I3 * T**(j-3)
          else
           N_j = T**j
          end if

          if (r >= 3) then
           ! Cayley-Hamilton recursive formula
           N_r = I1 * T**(r-1) - I2 * T**(r-2) + I3 * T**(r-3)
          else
           N_r = T**r
          end if

          dexp_2 = dexp_2 + g_i * (N_j.cdya.N_r)

         end do

         i = i+1
        end do

       end function dexp_2

       function dexp_2s(T)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: Eye,N_i,N_j,N_r
        type(Tensor4s) :: dexp_2s
        real(kind=8)  :: tol,I1,I2,I3,g_i
        integer :: i,j,r

        tol = 1.0d-8
        i = 2

        Eye = identity2(Eye)
        dexp_2s = Eye.cdya.Eye

        I1 = T**Eye
        I2 = 0.5*(I1**2-T**T)
        I3 = det(T)

        N_i = Eye
        do while (norm(N_i)/fact(i) .gt. tol)
         g_i = 1./fact(i)
         if (i >= 3) then
           ! Cayley-Hamilton recursive formula
           N_i = I1 * T**(i-1) - I2 * T**(i-2) + I3 * T**(i-3)
         else
           N_i = T**i
         end if

         do r=0,i-1
          j = i-1-r

          if (j >= 3) then
           ! Cayley-Hamilton recursive formula
           N_j = I1 * T**(j-1) - I2 * T**(j-2) + I3 * T**(j-3)
          else
           N_j = T**j
          end if

          if (r >= 3) then
           ! Cayley-Hamilton recursive formula
           N_r = I1 * T**(r-1) - I2 * T**(r-2) + I3 * T**(r-3)
          else
           N_r = T**r
          end if

          dexp_2s = dexp_2s + g_i * (N_j.cdya.N_r)

         end do

         i = i+1
        end do

       end function dexp_2s


      subroutine clawpack46_qinit(maxmx,maxmy, meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)
       implicit none

       integer meqn, mbc, mx, my, maux, maxmx, maxmy
       double precision xlower, ylower, dx, dy, xi, yj
       double precision q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
       double precision aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)
       double precision a(3,3), f, x, y

       integer i, j, mq, l, k

       f(x,y)=dsin(8d0*datan(1d0)*x)*dsin(8d0*datan(1d0)*y)

       a(1,1)=1d0
       a(1,2)=4d0
       a(1,3)=1d0
       a(2,1)=4d0
       a(2,2)=16d0
       a(2,3)=4d0
       a(3,1)=1d0
       a(3,2)=4d0
       a(3,3)=1d0

      do 20 j=1-mbc,my+mbc
         do 10 i=1-mbc,mx+mbc
            q(i,j,1)=0d0
   10       continue
   20    continue

      do mq=1, meqn
         do j=1-mbc,my+mbc
            yj = ylower + (j-1d0)*dy
            do i=1-mbc,mx+mbc
               xi = xlower + (i-1d0)*dx
               do k=0,2
                  do l=0,2
                     q(i,j,mq)=q(i,j,mq)+(1d0/36d0)*a(k+1,l+1)
     &                     * f(dx*k/2d0+xi,dy*l/2d0+yj)
                  enddo
               enddo
            enddo
         enddo
       enddo

       return
       end


!
! lab1_3_a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
! MA 02110-1301, USA.
!
PROGRAM lab1_3_a
IMPLICIT NONE

INTEGER :: i, j, k, n
REAL(KIND=8) :: h, x0, xf, xi, integ, I_exact, er
OPEN(UNIT=10, FILE='salida_ej3_a.dat', STATUS='UNKNOWN', ACTION='WRITE')

x0 = 0.d0
xf = 1.d0

WRITE(*,*) "EJERCICIO 3 a LABORATORIO 1"
WRITE(10, *) "# I  n  k  err   I_exact"

I_exact = f(1.d0) - 1.d0

do k = 2, 16, 1
    n = 2**k
    h = (xf - x0)/n

    xi = x0
    integ = f(xi) / 2.d0
    do i=1, n-1, 1                          ! INTEGRO DADO N
        xi = x0 + (h * i)
        integ = integ + f(xi)
    end do

    integ = integ + f(xf) / 2.d0
    integ = integ * h

    er = ABS(integ - I_exact)
    WRITE(10, *) integ, n, k, er, I_exact

end do

CONTAINS

FUNCTION f(x)
REAL (KIND=8) :: f
REAL (KIND=8), INTENT(IN) :: x

    f = DEXP(x)

END FUNCTION f

END PROGRAM


! Program to test array arguments which depend on other array arguments
program arrayarg2
   integer, dimension(5) :: a, b

   a = (/1, 2, 3, 4, 5/)
   b = (/2, 3, 4, 5, 6/)

   call test (a, b)

   if (any (b .ne. (/4, 7, 10, 13, 16/))) call abort
contains
subroutine test (x1, x2)
   implicit none
   integer, dimension(1:), intent(in) :: x1
   integer, dimension(1:), intent(inout) :: x2
   integer, dimension(1:size(x1)) :: x3

   x3 = x1 * 2
   x2 = x2 + x3
end subroutine test
end program


! (C) Copyright 2019 UCAR
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.

module femps_const_mod

use femps_kinds_mod

implicit none
private

! Pi
real(kind=kind_real), parameter, public :: piby4 = atan(1.0_kind_real)
real(kind=kind_real), parameter, public :: pi = 4.0_kind_real*piby4
real(kind=kind_real), parameter, public :: piby2 = 0.5_kind_real*pi

! Earth's radius
real(kind=kind_real), parameter, public :: rearth = 6371220.0_kind_real

! Radians to degrees
real(kind=kind_real), parameter, public :: rad2deg = 57.2957779186820_kind_real
real(kind=kind_real), parameter, public :: deg2rad = 0.01745329300562541_kind_real

end module femps_const_mod


      SUBROUTINE SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT,
     $                   LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q,
     $                   LDQ, X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS,
     $                   IWORK, DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X either the continuous-time algebraic Riccati
C     equation
C                                          -1
C        Q + op(A)'*X + X*op(A) - X*op(B)*R  op(B)'*X = 0,           (1)
C
C     or the discrete-time algebraic Riccati equation
C                                                                -1
C        X = op(A)'*X*op(A) - op(A)'*X*op(B)*(R + op(B)'*X*op(B))  *
C                             op(B)'*X*op(A) + Q,                    (2)
C
C     where op(M) = M or M' (M**T), A, op(B), Q, and R are N-by-N,
C     N-by-M, N-by-N, and M-by-M matrices respectively, with Q symmetric
C     and R symmetric nonsingular; X is an N-by-N symmetric matrix.
C                           -1
C     The matrix G = op(B)*R  *op(B)' must be provided on input, instead
C     of B and R, that is, the continuous-time equation
C
C        Q + op(A)'*X + X*op(A) - X*G*X = 0,                         (3)
C
C     or the discrete-time equation
C                                -1
C        Q + op(A)'*X*(I_n + G*X)  *op(A) - X = 0,                   (4)
C
C     are solved, where G is an N-by-N symmetric matrix. SLICOT Library
C     routine SB02MT should be used to compute G, given B and R. SB02MT
C     also enables to solve Riccati equations corresponding to optimal
C     problems with coupling terms.
C
C     The routine also returns the computed values of the closed-loop
C     spectrum of the optimal system, i.e., the stable eigenvalues
C     lambda(1),...,lambda(N) of the corresponding Hamiltonian or
C     symplectic matrix associated to the optimal problem. It is assumed
C     that the matrices A, G, and Q are such that the associated
C     Hamiltonian or symplectic matrix has N stable eigenvalues, i.e.,
C     with negative real parts, in the continuous-time case, and with
C     moduli less than one, in the discrete-time case.
C
C     Optionally, estimates of the conditioning and error bound on the
C     solution of the Riccati equation (3) or (4) are returned.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'X':  Compute the solution only;
C             = 'C':  Compute the reciprocal condition number only;
C             = 'E':  Compute the error bound only;
C             = 'A':  Compute all: the solution, reciprocal condition
C                     number, and the error bound.
C
C     DICO    CHARACTER*1
C             Specifies the type of Riccati equation to be solved or
C             analyzed, as follows:
C             = 'C':  Equation (3), continuous-time case;
C             = 'D':  Equation (4), discrete-time case.
C
C     HINV    CHARACTER*1
C             If DICO = 'D' and JOB = 'X' or JOB = 'A', specifies which
C             symplectic matrix is to be constructed, as follows:
C             = 'D':  The matrix H in (6) (see METHOD) is constructed;
C             = 'I':  The inverse of the matrix H in (6) is constructed.
C             HINV is not used if DICO = 'C', or JOB = 'C' or 'E'.
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices G and Q is
C             stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     SCAL    CHARACTER*1
C             If JOB = 'X' or JOB = 'A', specifies whether or not a
C             scaling strategy should be used, as follows:
C             = 'G':  General scaling should be used;
C             = 'N':  No scaling should be used.
C             SCAL is not used if JOB = 'C' or 'E'.
C
C     SORT    CHARACTER*1
C             If JOB = 'X' or JOB = 'A', specifies which eigenvalues
C             should be obtained in the top of the Schur form, as
C             follows:
C             = 'S':  Stable   eigenvalues come first;
C             = 'U':  Unstable eigenvalues come first.
C             SORT is not used if JOB = 'C' or 'E'.
C
C     FACT    CHARACTER*1
C             If JOB <> 'X', specifies whether or not a real Schur
C             factorization of the closed-loop system matrix Ac is
C             supplied on entry, as follows:
C             = 'F':  On entry, T and V contain the factors from a real
C                     Schur factorization of the matrix Ac;
C             = 'N':  A Schur factorization of Ac will be computed
C                     and the factors will be stored in T and V.
C             For a continuous-time system, the matrix Ac is given by
C                Ac = A - G*X, if TRANA = 'N', or
C                Ac = A - X*G, if TRANA = 'T' or 'C',
C             and for a discrete-time system, the matrix Ac is given by
C                Ac = inv(I_n + G*X)*A, if TRANA = 'N', or
C                Ac = A*inv(I_n + X*G), if TRANA = 'T' or 'C'.
C             FACT is not used if JOB = 'X'.
C
C     LYAPUN  CHARACTER*1
C             If JOB <> 'X', specifies whether or not the original or
C             "reduced" Lyapunov equations should be solved for
C             estimating reciprocal condition number and/or the error
C             bound, as follows:
C             = 'O':  Solve the original Lyapunov equations, updating
C                     the right-hand sides and solutions with the
C                     matrix V, e.g., X <-- V'*X*V;
C             = 'R':  Solve reduced Lyapunov equations only, without
C                     updating the right-hand sides and solutions.
C                     This means that a real Schur form T of Ac appears
C                     in the equations, instead of Ac.
C             LYAPUN is not used if JOB = 'X'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, Q, G, and X.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If JOB = 'X' or JOB = 'A' or FACT = 'N' or LYAPUN = 'O',
C             the leading N-by-N part of this array must contain the
C             coefficient matrix A of the equation.
C             If JOB = 'C' or 'E' and FACT = 'F' and LYAPUN = 'R', A is
C             not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,N), if JOB  = 'X' or JOB = 'A' or
C                                 FACT = 'N' or LYAPUN = 'O'.
C             LDA >= 1,        otherwise.
C
C     T       (input or output) DOUBLE PRECISION array, dimension
C             (LDT,N)
C             If JOB <> 'X' and FACT = 'F', then T is an input argument
C             and on entry, the leading N-by-N upper Hessenberg part of
C             this array must contain the upper quasi-triangular matrix
C             T in Schur canonical form from a Schur factorization of Ac
C             (see argument FACT).
C             If JOB <> 'X' and FACT = 'N', then T is an output argument
C             and on exit, if INFO = 0 or INFO = 7, the leading N-by-N
C             upper Hessenberg part of this array contains the upper
C             quasi-triangular matrix T in Schur canonical form from a
C             Schur factorization of Ac (see argument FACT).
C             If JOB = 'X', the array T is not referenced.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= 1,        if JOB =  'X';
C             LDT >= MAX(1,N), if JOB <> 'X'.
C
C     V       (input or output) DOUBLE PRECISION array, dimension
C             (LDV,N)
C             If JOB <> 'X' and FACT = 'F', then V is an input argument
C             and on entry, the leading N-by-N part of this array must
C             contain the orthogonal matrix V from a real Schur
C             factorization of Ac (see argument FACT).
C             If JOB <> 'X' and FACT = 'N', then V is an output argument
C             and on exit, if INFO = 0 or INFO = 7, the leading N-by-N
C             part of this array contains the orthogonal N-by-N matrix
C             from a real Schur factorization of Ac (see argument FACT).
C             If JOB = 'X', the array V is not referenced.
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= 1,        if JOB =  'X';
C             LDV >= MAX(1,N), if JOB <> 'X'.
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, the leading N-by-N upper triangular part (if
C             UPLO = 'U') or lower triangular part (if UPLO = 'L') of
C             this array must contain the upper triangular part or lower
C             triangular part, respectively, of the symmetric matrix G.
C             On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and
C             LYAPUN = 'R', the leading N-by-N part of this array
C             contains the symmetric matrix G fully stored.
C             If JOB <> 'X' and LYAPUN = 'R', this array is modified
C             internally, but restored on exit.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, the leading N-by-N upper triangular part (if
C             UPLO = 'U') or lower triangular part (if UPLO = 'L') of
C             this array must contain the upper triangular part or lower
C             triangular part, respectively, of the symmetric matrix Q.
C             On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and
C             LYAPUN = 'R', the leading N-by-N part of this array
C             contains the symmetric matrix Q fully stored.
C             If JOB <> 'X' and LYAPUN = 'R', this array is modified
C             internally, but restored on exit.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     X       (input or output) DOUBLE PRECISION array, dimension
C             (LDX,N)
C             If JOB = 'C' or JOB = 'E', then X is an input argument
C             and on entry, the leading N-by-N part of this array must
C             contain the symmetric solution matrix of the algebraic
C             Riccati equation. If LYAPUN = 'R', this array is modified
C             internally, but restored on exit; however, it could differ
C             from the input matrix at the round-off error level.
C             If JOB = 'X' or JOB = 'A', then X is an output argument
C             and on exit, if INFO = 0 or INFO >= 6, the leading N-by-N
C             part of this array contains the symmetric solution matrix
C             X of the algebraic Riccati equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     SEP     (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, the
C             estimated quantity
C                sep(op(Ac),-op(Ac)'), if DICO = 'C', or
C                sepd(op(Ac),op(Ac)'), if DICO = 'D'. (See METHOD.)
C             If JOB = 'C' or JOB = 'A' and X = 0, or JOB = 'E', SEP is
C             not referenced.
C             If JOB = 'X', and INFO = 0, INFO = 5 or INFO = 7,
C             SEP contains the scaling factor used, which should
C             multiply the (2,1) submatrix of U to recover X from the
C             first N columns of U (see METHOD). If SCAL = 'N', SEP is
C             set to 1.
C
C     RCOND   (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, an
C             estimate of the reciprocal condition number of the
C             algebraic Riccati equation.
C             If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
C             If JOB = 'X', or JOB = 'E', RCOND is not referenced.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = 7, an
C             estimated forward error bound for the solution X. If XTRUE
C             is the true solution, FERR bounds the magnitude of the
C             largest entry in (X - XTRUE) divided by the magnitude of
C             the largest entry in X.
C             If N = 0 or X = 0, FERR is set to 0.
C             If JOB = 'X', or JOB = 'C', FERR is not referenced.
C
C     WR      (output) DOUBLE PRECISION array, dimension (2*N)
C     WI      (output) DOUBLE PRECISION array, dimension (2*N)
C             If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5,
C             these arrays contain the real and imaginary parts,
C             respectively, of the eigenvalues of the 2N-by-2N matrix S,
C             ordered as specified by SORT (except for the case
C             HINV = 'D', when the order is opposite to that specified
C             by SORT). The leading N elements of these arrays contain
C             the closed-loop spectrum of the system matrix Ac (see
C             argument FACT). Specifically,
C                lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N.
C             If JOB = 'C' or JOB = 'E', these arrays are not
C             referenced.
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
C             If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, the
C             leading 2N-by-2N part of this array contains the ordered
C             real Schur form S of the (scaled, if SCAL = 'G')
C             Hamiltonian or symplectic matrix H. That is,
C
C                    ( S    S   )
C                    (  11   12 )
C                S = (          ),
C                    ( 0    S   )
C                    (       22 )
C
C             where S  , S   and S   are N-by-N matrices.
C                    11   12      22
C             If JOB = 'C' or JOB = 'E', this array is not referenced.
C
C     LDS     INTEGER
C             The leading dimension of the array S.
C             LDS >= MAX(1,2*N), if JOB = 'X' or JOB = 'A';
C             LDS >= 1,          if JOB = 'C' or JOB = 'E'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= 2*N,          if JOB = 'X';
C             LIWORK >= N*N,          if JOB = 'C' or JOB = 'E';
C             LIWORK >= MAX(2*N,N*N), if JOB = 'A'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, or INFO = 7, DWORK(1) returns the
C             optimal value of LDWORK. If INFO = 0, or INFO >= 5, and
C             JOB = 'X', or JOB = 'A', then DWORK(2) returns an estimate
C             RCONDU of the reciprocal of the condition number (in the
C             1-norm) of the N-th order system of algebraic equations
C             from which the solution matrix X is obtained, and DWORK(3)
C             returns the reciprocal pivot growth factor for the LU
C             factorization of the coefficient matrix of that system
C             (see SLICOT Library routine MB02PD); if DWORK(3) is much
C             less than 1, then the computed X and RCONDU could be
C             unreliable.
C             If DICO = 'D', and JOB = 'X', or JOB = 'A', then DWORK(4)
C             returns the reciprocal condition number RCONDA of the
C             given matrix A, and DWORK(5) returns the reciprocal pivot
C             growth factor for A or for its leading columns, if A is
C             singular (see SLICOT Library routine MB02PD); if DWORK(5)
C             is much less than 1, then the computed S and RCONDA could
C             be unreliable.
C             On exit, if INFO = 0, or INFO >= 4, and JOB = 'X', the
C             elements DWORK(6:5+4*N*N) contain the 2*N-by-2*N
C             transformation matrix  U  which reduced the Hamiltonian or
C             symplectic matrix  H  to the ordered real Schur form  S.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 5+MAX(1,4*N*N+8*N), if JOB = 'X' or JOB = 'A';
C             This may also be used for JOB = 'C' or JOB = 'E', but
C             exact bounds are as follows:
C             LDWORK >= 5 + MAX(1,LWS,LWE) + LWN, where
C             LWS = 0,       if FACT = 'F' or  LYAPUN = 'R';
C                 = 5*N,     if FACT = 'N' and LYAPUN = 'O' and
C                                              DICO = 'C' and JOB = 'C';
C                 = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and
C                                              DICO = 'C' and JOB = 'E';
C                 = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and
C                                              DICO = 'D';
C             LWE = 2*N*N,                if DICO = 'C' and JOB = 'C';
C                 = 4*N*N,                if DICO = 'C' and JOB = 'E';
C                 = MAX(3,2*N*N) + N*N,   if DICO = 'D' and JOB = 'C';
C                 = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and JOB = 'E';
C             LWN = 0,   if LYAPUN = 'O' or   JOB = 'C';
C                 = 2*N, if LYAPUN = 'R' and DICO = 'C' and JOB = 'E';
C                 = 3*N, if LYAPUN = 'R' and DICO = 'D' and JOB = 'E'.
C             For optimum performance LDWORK should sometimes be larger.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C             LBWORK >= 2*N,          if JOB = 'X' or JOB = 'A';
C             LBWORK >= 1,            if JOB = 'C' or JOB = 'E', and
C                                     FACT = 'N' and LYAPUN = 'R';
C             LBWORK >= 0,            otherwise.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if matrix A is (numerically) singular in discrete-
C                   time case;
C             = 2:  if the Hamiltonian or symplectic matrix H cannot be
C                   reduced to real Schur form;
C             = 3:  if the real Schur form of the Hamiltonian or
C                   symplectic matrix H cannot be appropriately ordered;
C             = 4:  if the Hamiltonian or symplectic matrix H has less
C                   than N stable eigenvalues;
C             = 5:  if the N-th order system of linear algebraic
C                   equations, from which the solution matrix X would
C                   be obtained, is singular to working precision;
C             = 6:  if the QR algorithm failed to complete the reduction
C                   of the matrix Ac to Schur canonical form, T;
C             = 7:  if T and -T' have some almost equal eigenvalues, if
C                   DICO = 'C', or T has almost reciprocal eigenvalues,
C                   if DICO = 'D'; perturbed values were used to solve
C                   Lyapunov equations, but the matrix T, if given (for
C                   FACT = 'F'), is unchanged. (This is a warning
C                   indicator.)
C
C     METHOD
C
C     The method used is the Schur vector approach proposed by Laub [1],
C     but with an optional scaling, which enhances the numerical
C     stability [6]. It is assumed that [A,B] is a stabilizable pair
C     (where for (3) or (4), B is any matrix such that B*B' = G with
C     rank(B) = rank(G)), and [E,A] is a detectable pair, where E is any
C     matrix such that E*E' = Q with rank(E) = rank(Q). Under these
C     assumptions, any of the algebraic Riccati equations (1)-(4) is
C     known to have a unique non-negative definite solution. See [2].
C     Now consider the 2N-by-2N Hamiltonian or symplectic matrix
C
C                 ( op(A)   -G    )
C            H =  (               ),                                 (5)
C                 (  -Q   -op(A)' ),
C
C     for continuous-time equation, and
C                         -1              -1
C                 (  op(A)           op(A)  *G       )
C            H =  (        -1                   -1   ),              (6)
C                 ( Q*op(A)     op(A)' + Q*op(A)  *G )
C
C     for discrete-time equation, respectively, where
C                       -1
C            G = op(B)*R  *op(B)'.
C     The assumptions guarantee that H in (5) has no pure imaginary
C     eigenvalues, and H in (6) has no eigenvalues on the unit circle.
C     If Y is an N-by-N matrix then there exists an orthogonal matrix U
C     such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U
C     can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks
C     (corresponding to the complex conjugate eigenvalues and real
C     eigenvalues respectively) appear in any desired order. This is the
C     ordered real Schur form. Thus, we can find an orthogonal
C     similarity transformation U which puts (5) or (6) in ordered real
C     Schur form
C
C            U'*H*U = S = (S(1,1)  S(1,2))
C                         (  0     S(2,2))
C
C     where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1)
C     have negative real parts in case of (5), or moduli greater than
C     one in case of (6). If U is conformably partitioned into four
C     N-by-N blocks
C
C               U = (U(1,1)  U(1,2))
C                   (U(2,1)  U(2,2))
C
C     with respect to the assumptions we then have
C     (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1),
C         (2), (3), or (4) with X = X' and non-negative definite;
C     (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if
C         DICO = 'D') are equal to the eigenvalues of optimal system
C         (the 'closed-loop' spectrum).
C
C     [A,B] is stabilizable if there exists a matrix F such that (A-BF)
C     is stable. [E,A] is detectable if [A',E'] is stabilizable.
C
C     The condition number of a Riccati equation is estimated as
C
C     cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
C                 norm(Pi)*norm(G) ) / norm(X),
C
C     where Omega, Theta and Pi are linear operators defined by
C
C     Omega(W) = op(Ac)'*W + W*op(Ac),
C     Theta(W) = inv(Omega(op(W)'*X + X*op(W))),
C        Pi(W) = inv(Omega(X*W*X)),
C
C     in the continuous-time case, and
C
C     Omega(W) = op(Ac)'*W*op(Ac) - W,
C     Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))),
C        Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))),
C
C     in the discrete-time case, and Ac has been defined (see argument
C     FACT). Details are given in the comments of SLICOT Library
C     routines SB02QD and SB02SD.
C
C     The routine estimates the quantities
C
C     sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)),
C     sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)),
C
C     norm(Theta) and norm(Pi) using 1-norm condition estimator.
C
C     The forward error bound is estimated using a practical error bound
C     similar to the one proposed in [5].
C
C     REFERENCES
C
C     [1] Laub, A.J.
C         A Schur Method for Solving Algebraic Riccati equations.
C         IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979.
C
C     [2] Wonham, W.M.
C         On a matrix Riccati equation of stochastic control.
C         SIAM J. Contr., 6, pp. 681-697, 1968.
C
C     [3] Sima, V.
C         Algorithms for Linear-Quadratic Optimization.
C         Pure and Applied Mathematics: A Series of Monographs and
C         Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996.
C
C     [4] Ghavimi, A.R. and Laub, A.J.
C         Backward error, sensitivity, and refinement of computed
C         solutions of algebraic Riccati equations.
C         Numerical Linear Algebra with Applications, vol. 2, pp. 29-49,
C         1995.
C
C     [5] Higham, N.J.
C         Perturbation theory and backward error for AX-XB=C.
C         BIT, vol. 33, pp. 124-136, 1993.
C
C     [6] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
C         DGRSVX and DMSRIC: Fortran 77 subroutines for solving
C         continuous-time matrix algebraic Riccati equations with
C         condition and accuracy estimates.
C         Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
C         Chemnitz, May 1998.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations. The solution accuracy
C     can be controlled by the output parameter FERR.
C
C     FURTHER COMMENTS
C
C     To obtain a stabilizing solution of the algebraic Riccati
C     equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set
C     SORT = 'S', if HINV = 'I'.
C
C     The routine can also compute the anti-stabilizing solutions of
C     the algebraic Riccati equations, by specifying
C         SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or
C         SORT = 'S' if DICO = 'D' and HINV = 'D'.
C
C     Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I'
C     and SORT = 'U', for stabilizing and anti-stabilizing solutions,
C     respectively, will be faster then the other combinations [3].
C
C     The option LYAPUN = 'R' may produce slightly worse or better
C     estimates, and it is faster than the option 'O'.
C
C     This routine is a functionally extended and more accurate
C     version of the SLICOT Library routine SB02MD. Transposed problems
C     can be dealt with as well. Iterative refinement is used whenever
C     useful to solve linear algebraic systems. Condition numbers and
C     error bounds on the solutions are optionally provided.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001,
C     Dec. 2002, Oct. 2004.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE
      PARAMETER         ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT,
     $                  TRANA, UPLO
      INTEGER           INFO, LDA, LDG, LDQ, LDS, LDT, LDV, LDWORK, LDX,
     $                  N
      DOUBLE PRECISION  FERR, RCOND, SEP
C     .. Array Arguments ..
      LOGICAL           BWORK(*)
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*),
     $                  S(LDS,*), T(LDT,*), V(LDV,*), WI(*), WR(*),
     $                  X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           COLEQU, DISCR, JBXA, JOBA, JOBC, JOBE, JOBX,
     $                  LHINV, LSCAL, LSCL, LSORT, LUPLO, NOFACT,
     $                  NOTRNA, ROWEQU, UPDATE
      CHARACTER         EQUED, JOBS, LOFACT, LOUP, TRANAT
      INTEGER           I, IERR, IU, IW, IWB, IWC, IWF, IWI, IWR, LDW,
     $                  LWE, LWN, LWS, N2, NN, NP1, NROT
      DOUBLE PRECISION  GNORM, QNORM, PIVOTA, PIVOTU, RCONDA, RCONDU,
     $                  WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME, SB02MR, SB02MS, SB02MV, SB02MW
      DOUBLE PRECISION  DLAMCH, DLANGE, DLANSY
      EXTERNAL          DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS,
     $                  SB02MV, SB02MW
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEES, DGESV, DLACPY, DLASCL,
     $                  DLASET, DSCAL, DSWAP, DSYMM, MA02AD, MA02ED,
     $                  MB01RU, MB01SD, MB02PD, SB02QD, SB02RU, SB02SD,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C     .. Executable Statements ..
C
C     Decode the input parameters.
C
      N2  = N + N
      NN  = N*N
      NP1 = N + 1
      INFO = 0
      JOBA   = LSAME( JOB,    'A' )
      JOBC   = LSAME( JOB,    'C' )
      JOBE   = LSAME( JOB,    'E' )
      JOBX   = LSAME( JOB,    'X' )
      NOFACT = LSAME( FACT,   'N' )
      NOTRNA = LSAME( TRANA,  'N' )
      DISCR  = LSAME( DICO,   'D' )
      LUPLO  = LSAME( UPLO,   'U' )
      LSCAL  = LSAME( SCAL,   'G' )
      LSORT  = LSAME( SORT,   'S' )
      UPDATE = LSAME( LYAPUN, 'O' )
      JBXA   = JOBX .OR. JOBA
      LHINV  = .FALSE.
      IF ( DISCR .AND. JBXA )
     $   LHINV = LSAME( HINV, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.( JBXA .OR. JOBC .OR. JOBE ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF( DISCR .AND. JBXA ) THEN
         IF( .NOT.( LHINV .OR. LSAME( HINV, 'I' ) ) )
     $      INFO = -3
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR.
     $                          LSAME( TRANA, 'C' ) ) ) THEN
            INFO = -4
         ELSE IF( .NOT.( LUPLO .OR. LSAME( UPLO, 'L' ) ) )
     $      THEN
            INFO = -5
         ELSE IF( JBXA ) THEN
            IF( .NOT.( LSCAL .OR. LSAME( SCAL, 'N' ) ) ) THEN
               INFO = -6
            ELSE IF( .NOT.( LSORT .OR. LSAME( SORT, 'U' ) ) ) THEN
               INFO = -7
            END IF
         END IF
         IF( INFO.EQ.0 .AND. .NOT.JOBX ) THEN
            IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN
               INFO = -8
            ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN
               INFO = -9
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( N.LT.0 ) THEN
               INFO = -10
            ELSE IF( LDA.LT.1 .OR. ( ( JBXA .OR. NOFACT .OR. UPDATE )
     $         .AND. LDA.LT.N ) ) THEN
               INFO = -12
            ELSE IF( LDT.LT.1 .OR. ( .NOT. JOBX .AND. LDT.LT.N ) ) THEN
               INFO = -14
            ELSE IF( LDV.LT.1 .OR. ( .NOT. JOBX .AND. LDV.LT.N ) ) THEN
               INFO = -16
            ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
               INFO = -18
            ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
               INFO = -20
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -22
            ELSE IF( LDS.LT.1 .OR. ( JBXA .AND. LDS.LT.N2 ) ) THEN
               INFO = -29
            ELSE
               IF( JBXA ) THEN
                  IF( LDWORK.LT.5 + MAX( 1, 4*NN + 8*N ) )
     $               INFO = -32
               ELSE
                  IF( NOFACT .AND. UPDATE ) THEN
                     IF( .NOT.DISCR .AND. JOBC ) THEN
                        LWS = 5*N
                     ELSE
                        LWS = 5*N + NN
                     END IF
                  ELSE
                     LWS = 0
                  END IF
                  IF( DISCR ) THEN
                     IF( JOBC ) THEN
                        LWE = MAX( 3, 2*NN) + NN
                     ELSE
                        LWE = MAX( 3, 2*NN) + 2*NN
                     END IF
                  ELSE
                     IF( JOBC ) THEN
                        LWE = 2*NN
                     ELSE
                        LWE = 4*NN
                     END IF
                  END IF
                  IF( UPDATE .OR. JOBC ) THEN
                     LWN = 0
                  ELSE
                     IF( DISCR ) THEN
                        LWN = 3*N
                     ELSE
                        LWN = 2*N
                     END IF
                  END IF
                  IF( LDWORK.LT.5 + MAX( 1, LWS, LWE ) + LWN )
     $               INFO = -32
               END IF
            END IF
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02RD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF( JOBX )
     $      SEP = ONE
         IF( JOBC .OR. JOBA )
     $      RCOND = ONE
         IF( JOBE .OR. JOBA )
     $      FERR  = ZERO
         DWORK(1) = ONE
         DWORK(2) = ONE
         DWORK(3) = ONE
         IF ( DISCR ) THEN
            DWORK(4) = ONE
            DWORK(5) = ONE
         END IF
         RETURN
      END IF
C
      IF ( JBXA ) THEN
C
C        Compute the solution matrix X.
C
C        Initialise the Hamiltonian or symplectic matrix associated with
C        the problem.
C        Workspace:  need   0    if DICO = 'C';
C                           6*N, if DICO = 'D'.
C
         CALL SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q,
     $                LDQ, S, LDS, IWORK, DWORK, LDWORK, IERR )
C
         IF ( IERR.NE.0 ) THEN
            INFO = 1
            IF ( DISCR ) THEN
               DWORK(4) = DWORK(1)
               DWORK(5) = DWORK(2)
            END IF
            RETURN
         END IF
C
         IF ( DISCR ) THEN
            WRKOPT = 6*N
            RCONDA = DWORK(1)
            PIVOTA = DWORK(2)
         ELSE
            WRKOPT = 0
         END IF
C
         IF ( LSCAL ) THEN
C
C           Scale the Hamiltonian or symplectic matrix S, using the
C           square roots of the norms of the matrices Q and G.
C
            QNORM = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) )
            GNORM = SQRT( DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) )
C
            LSCL = QNORM.GT.GNORM .AND. GNORM.GT.ZERO
            IF( LSCL ) THEN
               CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1),
     $                      LDS, IERR )
               CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1),
     $                      LDS, IERR )
            END IF
         ELSE
            LSCL = .FALSE.
         END IF
C
C        Find the ordered Schur factorization of S,  S = U*H*U'.
C        Workspace:  need   5 + 4*N*N + 6*N;
C                    prefer larger.
C
         IU  = 6
         IW  = IU + 4*NN
         LDW = LDWORK - IW + 1
         IF ( .NOT.DISCR ) THEN
            IF ( LSORT ) THEN
               CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS,
     $                     NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW,
     $                     BWORK, IERR )
            ELSE
               CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS,
     $                     NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW,
     $                     BWORK, IERR )
            END IF
         ELSE
            IF ( LSORT ) THEN
               CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS,
     $                     NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW,
     $                     BWORK, IERR )
            ELSE
               CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS,
     $                     NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW,
     $                     BWORK, IERR )
            END IF
            IF ( LHINV ) THEN
               CALL DSWAP( N, WR, 1, WR(NP1), 1 )
               CALL DSWAP( N, WI, 1, WI(NP1), 1 )
            END IF
         END IF
         IF ( IERR.GT.N2 ) THEN
            INFO = 3
         ELSE IF ( IERR.GT.0 ) THEN
            INFO = 2
         ELSE IF ( NROT.NE.N ) THEN
            INFO = 4
         END IF
         IF ( INFO.NE.0 ) THEN
            IF ( DISCR ) THEN
               DWORK(4) = RCONDA
               DWORK(5) = PIVOTA
            END IF
            RETURN
         END IF
C
         WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) )
C
C        Compute the solution of X*U(1,1) = U(2,1) using
C        LU factorization and iterative refinement. The (2,1) block of S
C        is used as a workspace for factoring U(1,1).
C        Workspace:  need   5 + 4*N*N + 8*N.
C
C        First transpose U(2,1) in-situ.
C
         DO 20 I = 1, N - 1
            CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2,
     $                  DWORK(IU+N+(I-1)*(N2+1)+1), 1 )
   20    CONTINUE
C
         IWR = IW
         IWC = IWR + N
         IWF = IWC + N
         IWB = IWF + N
         IW  = IWB + N
C
         CALL MB02PD( 'Equilibrate', 'Transpose', N, N, DWORK(IU), N2,
     $                S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR),
     $                DWORK(IWC), DWORK(IU+N), N2, X, LDX, RCONDU,
     $                DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW),
     $                IERR )
         IF( JOBX ) THEN
C
C           Restore U(2,1) back in-situ.
C
            DO 40 I = 1, N - 1
               CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2,
     $                     DWORK(IU+N+(I-1)*(N2+1)+1), 1 )
   40       CONTINUE
C
            IF( .NOT.LSAME( EQUED, 'N' ) ) THEN
C
C              Undo the equilibration of U(1,1) and U(2,1).
C
               ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
               COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
C
               IF( ROWEQU ) THEN
C
                  DO 60 I = 1, N
                     DWORK(IWR+I-1) = ONE / DWORK(IWR+I-1)
   60             CONTINUE
C
                  CALL MB01SD( 'Row scaling', N, N, DWORK(IU), N2,
     $                         DWORK(IWR), DWORK(IWC) )
               END IF
C
               IF( COLEQU ) THEN
C
                  DO 80 I = 1, N
                     DWORK(IWC+I-1) = ONE / DWORK(IWC+I-1)
   80             CONTINUE
C
                  CALL MB01SD( 'Column scaling', N, N, DWORK(IU), N2,
     $                         DWORK(IWR), DWORK(IWC) )
                  CALL MB01SD( 'Column scaling', N, N, DWORK(IU+N), N2,
     $                         DWORK(IWR), DWORK(IWC) )
               END IF
            END IF
C
C           Set S(2,1) to zero.
C
            CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS )
         END IF
C
         PIVOTU = DWORK(IW)
C
         IF ( IERR.GT.0 ) THEN
C
C           Singular matrix. Set INFO and DWORK for error return.
C
            INFO = 5
            GO TO 160
         END IF
C
C        Make sure the solution matrix X is symmetric.
C
         DO 100 I = 1, N - 1
            CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 )
            CALL DSCAL( N-I, HALF, X(I+1,I), 1 )
            CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX )
  100    CONTINUE
C
         IF( LSCAL ) THEN
C
C           Undo scaling for the solution matrix.
C
            IF( LSCL )
     $         CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, X, LDX,
     $                      IERR )
         END IF
      END IF
C
      IF ( .NOT.JOBX ) THEN
         IF ( .NOT.JOBA )
     $      WRKOPT = 0
C
C        Estimate the conditioning and compute an error bound on the
C        solution of the algebraic Riccati equation.
C
         IW = 6
         LOFACT = FACT
         IF ( NOFACT .AND. .NOT.UPDATE ) THEN
C
C           Compute Ac and its Schur factorization.
C
            IF ( DISCR ) THEN
               CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IW), N )
               CALL DSYMM(  'Left', UPLO, N, N, ONE, G, LDG, X, LDX,
     $                      ONE, DWORK(IW), N )
               IF ( NOTRNA ) THEN
C
C                 Compute Ac = inv(I_n + G*X)*A.
C
                  CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
                  CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR )
               ELSE
C
C                 Compute Ac = A*inv(I_n + X*G).
C
                  CALL MA02AD( 'Full', N, N, A, LDA, T, LDT )
                  CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR )
                  DO 120 I = 2, N
                     CALL DSWAP( I-1, T(1,I), 1, T(I,1), LDT )
  120             CONTINUE
               END IF
C
            ELSE
C
               CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
               IF ( NOTRNA ) THEN
C
C                 Compute Ac = A - G*X.
C
                  CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX,
     $                        ONE, T, LDT )
               ELSE
C
C                 Compute Ac = A - X*G.
C
                  CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX,
     $                        ONE, T, LDT )
               END IF
            END IF
C
C           Compute the Schur factorization of Ac, Ac = V*T*V'.
C           Workspace:  need   5 + 5*N.
C                       prefer larger.
C
            IWR = IW
            IWI = IWR + N
            IW  = IWI + N
            LDW = LDWORK - IW + 1
C
            CALL DGEES( 'Vectors', 'Not ordered', SB02MS, N, T, LDT,
     $                  NROT, DWORK(IWR), DWORK(IWI), V, LDV, DWORK(IW),
     $                  LDW, BWORK, IERR )
C
            IF( IERR.NE.0 ) THEN
               INFO = 6
               GO TO 160
            END IF
C
            WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) )
            LOFACT = 'F'
            IW = 6
         END IF
C
         IF ( .NOT.UPDATE ) THEN
C
C           Update G, Q, and X using the orthogonal matrix V.
C
            TRANAT = 'T'
C
C           Save the diagonal elements of G and Q.
C
            CALL DCOPY( N, G, LDG+1, DWORK(IW), 1 )
            CALL DCOPY( N, Q, LDQ+1, DWORK(IW+N), 1 )
            IW = IW + N2
C
            IF ( JOBA )
     $         CALL DLACPY( 'Full', N, N, X, LDX, S(NP1,1), LDS )
            CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, V, LDV,
     $                   X, LDX, DWORK(IW), NN, IERR )
            CALL DSCAL( N, HALF, X, LDX+1 )
            CALL MA02ED( UPLO, N, X, LDX )
            IF( .NOT.DISCR ) THEN
               CALL MA02ED( UPLO, N, G, LDG )
               CALL MA02ED( UPLO, N, Q, LDQ )
            END IF
            CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, V, LDV,
     $                   G, LDG, DWORK(IW), NN, IERR )
            CALL DSCAL( N, HALF, G, LDG+1 )
            CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, V, LDV,
     $                   Q, LDQ, DWORK(IW), NN, IERR )
            CALL DSCAL( N, HALF, Q, LDQ+1 )
         END IF
C
C        Estimate the conditioning and/or the error bound.
C        Workspace: 5 + MAX(1,LWS,LWE) + LWN, where
C
C           LWS = 0,       if FACT = 'F' or  LYAPUN = 'R';
C               = 5*N,     if FACT = 'N' and LYAPUN = 'O' and DICO = 'C'
C                                                         and JOB = 'C';
C               = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C'
C                                          and (JOB = 'E' or JOB = 'A');
C               = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and
C                                                         DICO = 'D';
C           LWE = 2*N*N,                if DICO = 'C' and  JOB = 'C';
C               = 4*N*N,                if DICO = 'C' and (JOB = 'E' or
C                                                          JOB = 'A');
C               = MAX(3,2*N*N) + N*N,   if DICO = 'D' and  JOB = 'C';
C               = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and (JOB = 'E' or
C                                                          JOB = 'A');
C           LWN = 0,   if LYAPUN = 'O' or   JOB = 'C';
C               = 2*N, if LYAPUN = 'R' and DICO = 'C' and (JOB = 'E' or
C                                                          JOB = 'A');
C               = 3*N, if LYAPUN = 'R' and DICO = 'D' and (JOB = 'E' or
C                                                          JOB = 'A').
C
         LDW = LDWORK - IW + 1
         IF ( JOBA ) THEN
            JOBS = 'B'
         ELSE
            JOBS = JOB
         END IF
C
         IF ( DISCR ) THEN
            CALL SB02SD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA,
     $                   T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP,
     $                   RCOND, FERR, IWORK, DWORK(IW), LDW, IERR )
         ELSE
            CALL SB02QD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA,
     $                   T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP,
     $                   RCOND, FERR, IWORK, DWORK(IW), LDW, IERR )
         END IF
C
         WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) )
         IF( IERR.EQ.NP1 ) THEN
            INFO = 7
         ELSE IF( IERR.GT.0 ) THEN
            INFO = 6
            GO TO 160
         END IF
C
         IF ( .NOT.UPDATE ) THEN
C
C           Restore X, G, and Q and set S(2,1) to zero, if needed.
C
            IF ( JOBA ) THEN
               CALL DLACPY( 'Full', N, N, S(NP1,1), LDS, X, LDX )
               CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS )
            ELSE
               CALL MB01RU( UPLO, TRANA, N, N, ZERO, ONE, X, LDX, V,
     $                      LDV, X, LDX, DWORK(IW), NN, IERR )
               CALL DSCAL( N, HALF, X, LDX+1 )
               CALL MA02ED( UPLO, N, X, LDX )
            END IF
            IF ( LUPLO ) THEN
               LOUP = 'L'
            ELSE
               LOUP = 'U'
            END IF
C
            IW = 6
            CALL DCOPY( N, DWORK(IW), 1, G, LDG+1 )
            CALL MA02ED( LOUP, N, G, LDG )
            CALL DCOPY( N, DWORK(IW+N), 1, Q, LDQ+1 )
            CALL MA02ED( LOUP, N, Q, LDQ )
         END IF
C
      END IF
C
C     Set the optimal workspace and other details.
C
      DWORK(1) = WRKOPT
  160 CONTINUE
      IF( JBXA ) THEN
         DWORK(2) = RCONDU
         DWORK(3) = PIVOTU
         IF ( DISCR ) THEN
            DWORK(4) = RCONDA
            DWORK(5) = PIVOTA
         END IF
         IF( JOBX ) THEN
            IF ( LSCL ) THEN
               SEP = QNORM / GNORM
            ELSE
               SEP = ONE
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of SB02RD ***
      END


      subroutine log_normal(mu,sig,c)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function generates a random number from a lognormal distribution curve
!!    for estimating constituent concentration in the effluent of urban bmps
!!    given mean and standard deviation values.
!!    Jaehak Jeong, 2017

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    mu          |mg/l          |mean value
!!    sig         |mg/l          |standard deviation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    c           |mg/l          |value generated for distribution
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real*8,intent(in) :: mu,sig
      real*8,intent(out):: c
      real*8 :: temp(2),r,theta
      real*8,PARAMETER :: PI=3.141592653589793238462
      CALL RANDOM_NUMBER(temp)
      r = (-2.0d0*log(temp(1)))**0.5
      theta = 2.0d0*PI*temp(2)
      c = mu+sig*r*sin(theta)
      c = exp(c)
      end


	subroutine bjdaz2 (zlat0,alon0,zlat,alon,delt,az1,az2,lattype)
c----------------------------------------------------------------------
c  calculate geocentric distance, azimuth, and back azimuth from a
c  reference point to another point on the earth's surface.
c
c	bruce julian	 29 dec 1976
c	modified by d gubbins 23 july 1977
c	further modified by s roecker 1981
C	 This version allows inputs of lat or colat
c
c  input arguments:
c	if lattype = 1 then
c	zlat0 = geocentric latitude of reference point.
c	zlat = geocentric latitude of point
c	if lattype = 0 then
c	zlat0 = geocentric colatitude of reference point.
c	zlat = geocentric colatitude of point
c
c	alon0 = longitude of reference point.
c	alon = longitude of point
c
c  output arguments:
c	delt = epicentral distance
c	az1 =  azimuth of the point from the reference point.
c	az2 =  azimuth of the reference point from the point.
c
c  ***  note  ***
c	   all angles are in radians.
c	   north latitude and east longitude are positive.
c	   azimuth is measured clockwise from north.
c	   if one point is at north or south pole, azimuth from that
c		 point will be the limit of the azimuth as the pole is
c		 approached along the meridian whose longitude is given.
c----------------------------------------------------------------------
	implicit double precision (a-h,o-z)
	real*4 zlat0,alon0,zlat,alon,delt,az1,az2
	data pii/3.141592653/
	twopi = pii*2.d0
	if (lattype.eq.1) then
	  alat0=pii*0.5d0-dble(zlat0)
	  alat=pii*0.5d0-dble(zlat)
	else
	  alat0 = dble(zlat0)
	  alat = dble(zlat)
	end if
	st0 = dsin(alat0)
	ct0 = dcos(alat0)
	ct1 = dcos(alat)
	s0c1 = st0*ct1
	st1 = dsin(alat)
	s1c0 = st1*ct0
	dlon = dble(alon) - dble(alon0)
	sdlon = dsin(dlon)
	cdlon = dcos(dlon)
	cdelt = st0*st1*cdlon + ct0*ct1
	b = s0c1 - s1c0*cdlon
	a = st1*sdlon
	sdelt = dsqrt(b*b+a*a)
	ddelt = datan2(sdelt, cdelt)
	aze = 0.d0
	if (sdelt.ne.0.d0) aze = datan2(a,b)
c------calculate back azimuth
	a = -sdlon*st0
	b = s1c0 - s0c1*cdlon
	azs =pii
	if (sdelt.ne.0.d0) azs = datan2(a,b)
c------make  0 < azimuth < twopi
	if(aze .lt. 0.d0) aze = aze + twopi
	if(azs .lt. 0.d0) azs = azs + twopi
	delt = ddelt
	az1 = aze
	az2 = azs
	return
	end


	FUNCTION PR_PRES  ( tmpc, thta )
C************************************************************************
C* PR_PRES      							*
C*									*
C* This function computes PRES from TMPC and THTA.  Poisson's equation	*
C* is used:								*
C*									*
C*     PRES = 1000. * ( PR_TMCK (TMPC) / THTA ) ** (1 / RKAPPA)		*
C*									*
C* REAL PR_PRES  ( TMPC, THTA )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL     	Temperature in Celsius		*
C*	THTA		REAL     	Potential temperature in Kelvin	*
C*									*
C* Output parameters:							*
C*	PR_PRES		REAL		Station pressure in millibars	*
C**									*
C* Log:									*
C* M. Goodman/RDS	8/84	Cleaned code				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC       7/88	Documentation; bounds on tmpc, thta	*
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ( ERMISS (tmpc) ) .or. ( ERMISS (thta) )
     *        .or. ( tmpc .le. -TMCK ) .or. ( thta .le. 0.) )  THEN
	    PR_PRES = RMISSD
	  ELSE
	    tmpk = PR_TMCK (tmpc)
	    PR_PRES = 1000. * (tmpk / thta) ** (1 / RKAPPA)
	END IF
C*
	RETURN
	END