      subroutine tcoorde(trans,cod,beam,
     1                 dx,dy,dz,chi1,chi2,chi3,dir)
      use ffs_flag
      use tmacro
      use mathfun, only: sqrtl
      use temw,only:tmulbs
      implicit none
      integer*4 i
      real*8 dx,dy,dz,chi1,chi2,chi3,cchi1,schi1,
     $     cchi2,schi2,cchi3,schi3,dx0,dy0,dz0,dx1,dy1,dz1,
     $     r11,r12,r13,r21,r22,r23,r31,r32,r33,
     $     pxi,pyi,a,pzi,zi,yi,xi,xf,yf,zf,
     $     pzf,p,z,pxf,pyf,u,v,x,y
      real*8 trans(6,12),cod(6),beam(42)
      logical*4 dir
      real*8 trans1(6,6),trans2(6,6)
      cchi1=cos(chi1)
      schi1=sin(chi1)
      cchi2=cos(chi2)
      schi2=sin(chi2)
      cchi3=cos(chi3)
      schi3=sin(chi3)
      if(dir)then
        dx0=dx
        dy0=dy
        dz0=dz
        dx1=0.d0
        dy1=0.d0
        dz1=0.d0
        r11= cchi1*cchi3+schi1*schi2*schi3
        r12=-cchi2*schi3
        r13= schi1*cchi3-cchi1*schi2*schi3
        r21=-schi1*schi2*cchi3+cchi1*schi3
        r22= cchi2*cchi3
        r23= cchi1*schi2*cchi3+schi1*schi3
        r31=-schi1*cchi2
        r32=-schi2
        r33= cchi1*cchi2
      else
        dx0=0.d0
        dy0=0.d0
        dz0=0.d0
        dx1=dx
        dy1=-dy
        dz1=-dz
        r11= cchi1*cchi3+schi1*schi2*schi3
        r21= cchi2*schi3
        r31=-schi1*cchi3+cchi1*schi2*schi3
        r12= schi1*schi2*cchi3-cchi1*schi3
        r22= cchi2*cchi3
        r32= cchi1*schi2*cchi3+schi1*schi3
        r13= schi1*cchi2
        r23=-schi2
        r33= cchi1*cchi2
      endif
      p=1.d0+cod(6)
      z=cod(5)
      pxi=cod(2)
      pyi=cod(4)
      a=pxi**2+pyi**2
      pzi=p*sqrtl(1.d0-a/p**2)
      zi=pzi/p*z-dz0
      xi=cod(1)-dx0+pxi/p*z
      yi=cod(3)-dy0+pyi/p*z
      call tinitr(trans1)
      trans1(1,2)= z/p
      trans1(1,5)= pxi/p
      trans1(1,6)=-pxi*z/p**2
      trans1(3,4)= z/p
      trans1(3,5)= pyi/p
      trans1(3,6)=-pyi*z/p**2
      trans1(5,2)=-pxi/p/pzi*z
      trans1(5,4)=-pyi/p/pzi*z
      trans1(5,5)=pzi/p
      trans1(5,6)=(pxi**2+pyi**2)/p**2/pzi*z
      trans1(6,2)=-pxi/pzi
      trans1(6,4)=-pyi/pzi
      trans1(6,6)=p/pzi
      xf =r11*xi +r12*yi +r13*zi
      yf =r21*xi +r22*yi +r23*zi
      zf =r31*xi +r32*yi +r33*zi+dz1
      pxf=r11*pxi+r12*pyi+r13*pzi
      pyf=r21*pxi+r22*pyi+r23*pzi
      pzf=r31*pxi+r32*pyi+r33*pzi
      do 110 i=1,6
        x=trans1(1,i)
        y=trans1(3,i)
        u=trans1(2,i)
        v=trans1(4,i)
        trans1(1,i)
     1     =r11*x+r12*y+r13*trans1(5,i)
        trans1(3,i)
     1     =r21*x+r22*y+r23*trans1(5,i)
        trans1(5,i)
     1     =r31*x+r32*y+r33*trans1(5,i)
        trans1(2,i)
     1     =r11*u+r12*v+r13*trans1(6,i)
        trans1(4,i)
     1     =r21*u+r22*v+r23*trans1(6,i)
        trans1(6,i)
     1     =r31*u+r32*v+r33*trans1(6,i)
110   continue
      call tinitr(trans2)
      trans2(1,2)=-zf/pzf
      trans2(1,5)=-pxf/pzf
      trans2(1,6)= pxf/pzf**2*zf
      trans2(3,4)=-zf/pzf
      trans2(3,5)=-pyf/pzf
      trans2(3,6)= pyf/pzf**2*zf
      trans2(5,2)= pxf/p/pzf*zf
      trans2(5,4)= pyf/p/pzf*zf
      trans2(5,5)= p/pzf
      trans2(5,6)=-(pxf**2+pyf**2)/p/pzf**2*zf
      trans2(6,2)=pxf/p
      trans2(6,4)=pyf/p
      trans2(6,6)=pzf/p
      call tmultr(trans1,trans2,6)
      call tmultr(trans,trans1,irad)
      call tmulbs(beam ,trans1,.true.)
      cod(1)=xf-pxf/pzf*zf+dx1
      cod(3)=yf-pyf/pzf*zf+dy1
      cod(5)=p/pzf*zf
      cod(2)=pxf
      cod(4)=pyf
      return
      end


!  RSS_RTM_driver.f90
!

!****************************************************************************
!
!  PROGRAM: RSS_RTM_driver
!
!  PURPOSE:  driver routine for RSS RTM
!
!****************************************************************************

program RSS_RTM_driver
use RSS_RTM
implicit none

    integer(4)                       :: i
    real(4)                          :: freq, tht, sst, sal, wind, surtep, tran,  td, tbdw
    real(4), dimension(2)            :: ewind
    real(4), dimension(2)            :: omega
    real(4), dimension(2,4)          :: eharm
    real(4), parameter               :: teff = 290.0
    character(len=200), parameter    :: control_output='C:\RSS_RTM\control_output.dat'

    open(unit=4,file=control_output,action='write',form='formatted')

    write(4,*) 'Contol Output of RSS RTM module'
    write(4,*)

    freq=37.0
    tht=55.2
    sal=35.0
    sst=20.0
    surtep=sst+273.15
    write(4,*)
    write(4,*) ' [MW 2012] Figure 8'
    write(4,*) ' FREQUENCY = ', freq,' GHz'
    write(4,*) ' EIA = ', tht,' deg'
    do i=0,25
        wind=float(i)
        call find_surface_tb (freq=freq,tht=tht,surtep=surtep,sal=sal,ssws=wind,    ewind=ewind)
        write(4,101) wind,  ewind(1:2)*teff
101     format(1x,f4.1,2x,f10.3,1x,f10.3)
    enddo

    freq=18.7
    sal=35.0
    sst=20.0
    surtep=sst+273.15
    wind=12.1
    write(4,*)
    write(4,*) ' [MW 2012] Figure 5'
    write(4,*) ' FREQUENCY = ', freq,' GHz'
    write(4,*) ' WIND= ', wind,' m/s'
    do i=0,6
        tht=float(i)*10.0
        call find_surface_tb (freq=freq,tht=tht,surtep=surtep,sal=sal,ssws=wind,    ewind=ewind)
        write(4,102) tht,  ewind(1:2)*teff
102     format(1x,f6.1,2x,f10.3,1x,f10.3)
    enddo

    tht=55.2
    sal=35.0
    sst=20.0
    surtep=sst+273.15
    wind=12.1
    write(4,*)
    write(4,*) ' [MW 2012] Figure 9'
    write(4,*) ' EIA = ', tht,' deg'
    write(4,*) ' WIND= ', wind,' m/s'
    do i=1,6

        select case (i)
        case (1)
            freq=6.8
        case (2)
            freq=10.7
        case (3)
            freq=18.7
        case (4)
            freq=23.8
        case (5)
            freq=37.0
        case (6)
            freq=85.5
        end select

        call find_surface_tb (freq=freq,tht=tht,surtep=surtep,sal=sal,ssws=wind,    ewind=ewind)
        write(4,103) freq,  ewind(1:2)*teff
103     format(1x,f6.1,2x,f10.3,1x,f10.3)
    enddo

    freq=18.7
    tht=55.2
    sal=35.0
    wind=7.0
    sst=20.0
    surtep=sst+273.15
    td = 281.0
    write(4,*)
    write(4,*) ' [MW 2012] Figure 10'
    write(4,*) ' FREQUENCY = ', freq,' GHz'
    write(4,*) ' EIA = ', tht,' deg'
    write(4,*) ' WIND ', wind,' m/s'
    do i=0,10
        tran=float(i)*0.1
        if (tran >= 0.9999999) tran=0.9999999
        tbdw = td*(1.0-tran)
        call find_surface_tb (freq=freq,tht=tht,surtep=surtep,sal=sal,ssws=wind,tran=tran,tbdw=tbdw,    omega=omega)
        write(4,104) tran, tbdw,omega(1:2)
104     format(1x,f4.1,1x,f8.3,5x,f8.3,1x,f8.3)
    enddo

    freq=10.7
    tht=50.1
    sal=35.0
    sst=20.0
    surtep=sst+273.15
    write(4,*)
    write(4,*) ' [MW 2012] Figures 12/13'
    write(4,*) ' FREQUENCY = ', freq,' GHz'
    write(4,*) ' EIA = ', tht,' deg'
    do i=0,25
        wind=float(i)
        call find_surface_tb (freq=freq,tht=tht,surtep=surtep,sal=sal,ssws=wind,    eharm=eharm)
        write(4,105) wind,  eharm(1:2,1)*teff, eharm(1:2,2)*teff, eharm(1:2,3)*teff, eharm(1:2,4)*teff
105     format(1x,f4.1,2x,4(2(f6.3,1x),1x))
    enddo

   close(4)

stop ' normal end'
end program RSS_RTM_driver


submodule (Prng_Class) sm_xorshift128plus
!!# xorshift128+
!!This module contains routines to generate random numbers using the xorshift128+ method by Vigna's extensions to
!!Marsaglia, G., 2003. Xorshift RNGs. Journal of Statistical Software 8, 1-6.
!!
!!This module is a modified version of the public domain code written by Shun Sakuraba in 2015-2016.
!!The original code can be found [here](https://bitbucket.org/shun.sakuraba/xorshiftf90).
!!The modified code in coretran is distributed under the coretran license, see the repository for that information.
!!
!!Vigna's xorshift128+ pseudorandom generator.
!!Sebastiano Vigna. 2014. Further scramblings of Marsaglia's xorshift generators. CoRR, abs/1402.6246.
!! xorshift128+ is known as a fast pseudorandom generator with reasonably good resilience to randomness tests.
!! Since its primary imporance is its speed, do not forget to add inlining directives depending your compiler.
!!
!!
!!## Why xorshift128+ ?
!!The seed of the xorshift128+ can be jumped by k cycles, where each cycle jumps ahead by $2^{64}$ random numbers, but quickly.
!!This ability to jump is an important aspect for using random number generators in general but especially in parallel
!!in either OpenMP or MPI paradigms.
!!The time taken to generate a 64 bit integer was 1.06 ns on an IntelR CoreTM i7-4770 CPU @3.40GHz (Haswell) as shown in Vigna (2014).
!!xorshift128+ is the better for less massively parallel applications.
!!
!!If the period of the random number generator is too small for your application, consider using the xorshift1024*
!!generator which has a period of $2^{512}$ numbers. The time to generate a 64 bit integer is slightly slower at 1.36 ns
!!
!!### Important note: This next aspect needs to be tested.
!!@todo: test this
!!Because the Fortran standard does not specify an integer model, int64 overflow has an undefined behaviour.
!!Thus, there might be warnings issued while compiling this program, or worse, it may not work.
!!A workaround uses the int(int(a, kind=16) "op" b, kind=8) trick, which works well with gfortran,
!!but commercial compilers do not accept 128-bit arithmetics (incl. Intel, Cray, and Fujitsu).

implicit none

contains

  !====================================================================!
  module procedure rngInteger_128plus!(this, val)
  !====================================================================!
  !class(prng), intent(inout) :: this
  !integer(i64), intent(out) :: val

  integer(i64) :: s0, s1

  ! swap state variables
  s0 = this%seed(2)
  s1 = this%seed(1)

  this%seed(1) = s0

  ! xorshift
  s1 = ieor(ishft(s1, 23), s1)

  ! scramble
  s1 = ieor(ieor(s1, s0), ieor(ishft(s1, -18), ishft(s0, -5)))
  this%seed(2) = s1

  val = s1 + s0
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure jumpState_128plus!(this)
  !====================================================================!
  !! Jumps the current prng state by $2^{512}$ pulls from the generator without drawing $2^{512}$ numbers.
  !class(Prng), intent(inout) :: this
  integer(i64) :: jump_table(2)
  integer(i64) :: t(0:1)
  integer(i64) :: tmp
  integer :: i, j, b
  data jump_table / -8476663413540573697_i64,& !0x8a5cd789635d2dff
                     1305993406145048470_i64/  !0x121fd2155c472f96

  t(:) = 0

  do i = 1, 2
      do b = 0, 63
        if(btest(jump_table(i), b)) then
            do j = 0, 1
              t(j) = ieor(t(j), this%seed(j))
            end do
        end if
        call rngInteger_128plus(this, tmp)
      end do
  end do
  this%seed(0:1) = t
  end procedure
  !====================================================================!
end submodule


program moist_adiabat
  use scale
  use scale_const, only: &
     PRE00 => CONST_PRE00, &
     Rdry  => CONST_Rdry,  &
     Rvap  => CONST_Rvap,  &
     CPdry => CONST_CPdry
  use scale_atmos_hydrometeor, only: &
     CPvap => CP_VAPOR, &
     CL    => CP_WATER, &
     CI    => CP_ICE
  use scale_io, only: &
     IO_get_available_fid
  use scale_atmos_saturation, only: &
     ATMOS_SATURATION_setup, &
     ATMOS_SATURATION_tdew_liq, &
     ATMOS_SATURATION_pote
  use scale_atmos_adiabat, only: &
     ATMOS_ADIABAT_setup, &
     ATMOS_ADIABAT_cape
  implicit none

  integer :: nx, ny, nz
  real(RP), allocatable :: xaxis(:), yaxis(:)
  real(RP), allocatable :: z(:), zh(:)

  real(RP), allocatable :: TEMP(:), PRES(:)
  real(RP), allocatable :: QV(:), QC(:), QR(:), QI(:), QS(:), QG(:)
  real(RP), allocatable :: POTT(:), DENS(:), QDRY(:)
  real(RP), allocatable :: Rtot(:), CPtot(:)
  real(RP), allocatable :: Tdew(:), POTE(:)
  real(RP), allocatable :: DENS_p(:), TEMP_p(:), BUOY_p(:), QV_p(:)
  real(RP) :: CAPE, CIN, LCL, LFC, LNB

  logical :: converged

  ! conf data
  character(len=H_MID) :: basename_in
  integer :: rankid
  character(len=H_MID) :: filename_out
  real(RP) :: x, y
  integer  :: nstep

  namelist / PARAM_MOIST_ADIABAT / &
       basename_in, &
       rankid, &
       filename_out, &
       x, y, &
       nstep

  integer :: fid
  integer :: k
  integer :: ierr

  call SCALE_init

  call ATMOS_SATURATION_setup
  call ATMOS_ADIABAT_setup

  ! default value
  basename_in  = "history"
  filename_out = "output.dat"
  x = 0.0_RP
  y = 0.0_RP
  nstep = 1

  !--- read namelist
  if ( IO_FID_CONF > 0 ) then
     rewind(IO_FID_CONF)
     read(IO_FID_CONF,nml=PARAM_MOIST_ADIABAT,iostat=ierr)
     if( ierr < 0 ) then !--- missing
        if( IO_L ) write(IO_FID_LOG,*) '*** Not found namelist. Default used.'
     elseif( ierr > 0 ) then !--- fatal error
        write(*,*) 'xxx Not appropriate names in namelist PARAM_MOIST_ADIABAT. Check!'
        call PRC_abort
     endif
  end if
  if( IO_NML ) write(IO_FID_NML,nml=PARAM_MOIST_ADIABAT)

  call read_data

  ! approximate estimation (ignore other tracers)
  allocate( POTT(nz), DENS(nz), QDRY(nz), Rtot(nz), CPtot(nz) )
  do k = 1, nz
     QDRY(k) = 1.0_RP - QV(k) - QC(k) - QR(k) - QI(k) - QS(k) - QG(k)
     Rtot(k)  =  Rdry * QDRY(k) +  Rvap * QV(k)
     CPtot(k) = CPdry * QDRY(k) + CPvap * QV(k) + CL * ( QC(k) + QR(k) ) + CI * ( QI(k) + QS(k) + QG(k) )
     POTT(k) = TEMP(k) * ( PRE00 / PRES(k) )**( Rtot(k) / CPtot(k) )
     DENS(k) = PRES(k) / ( Rtot(k) * TEMP(k) )
  end do

  ! dew point
  allocate( Tdew(nz) )
  call ATMOS_SATURATION_tdew_liq( nz, 1, nz, &
                                  DENS(:), TEMP(:), QV(:), & ! [IN]
                                  Tdew(:), converged       ) ! [OUT]

  ! equivalent potential temperature
  allocate( POTE(nz) )
  call ATMOS_SATURATION_pote( nz, 1, nz, &
                              DENS(:), POTT(:), TEMP(:), QV(:), & ! [IN]
                              POTE(:)                           ) ! [OUT]

  ! lift parcel
  allocate( DENS_p(nz), TEMP_p(nz), BUOY_p(nz), QV_p(nz) )
  call ATMOS_ADIABAT_cape( nz, 1, nz, 1, &
                           DENS(:), TEMP(:), PRES(:),                & ! [IN]
                           QV(:), QC(:), QDRY(:), Rtot(:), CPtot(:), & ! [IN]
                           z(:), zh(:),                              & ! [IN]
                           CAPE, CIN, LCL, LFC, LNB,                 & ! [OUT]
                           DENS_p(:), TEMP_p(:), BUOY_p(:), QV_p(:), & ! [OUT]
                           converged                                 ) ! [OUT]
  if ( .not. converged ) then
     write(*,*) 'xxx calculation was not converged!'
     call PRC_abort
  end if
  !write(*,*) buoy_p
  !write(*,*) zh

  write(fid,'(5(a,f10.2))') 'CAPE=', CAPE, ', CIN=', CIN, ', LCL=', LCL, ', LFC=', LFC, ', LNB=', LNB

  fid = IO_get_available_fid()
  open( unit=fid, file=filename_out )
  write(fid,*)nz
  write(fid,'(2a8,5a10)') "z", "pres", "temp", "tdew", "pott", "pote", "temp_p"
  do k = 1, nz
     write(fid,'(2f8.1,5f10.2)') z(k), pres(k)/100.0_RP, temp(k), tdew(k), pott(k), pote(k), temp_p(k)
  end do
  close(fid)

  !write(*,*)temp_p(nz)*(PRE00/pres(nz))**(Rdry/CPdry)

  call SCALE_finalize

  stop

contains

  subroutine read_data
    use scale_file, only: &
         FILE_open, &
         FILE_get_shape, &
         FILE_read, &
         FILE_close
    integer :: fid
    integer :: dims(3)
    integer :: start(3), count(3)

    integer :: i, j

    ! file open
    call FILE_open( basename_in,  & ! (in)
                    fid,          & ! (out)
                    rankid=rankid ) ! (in)

    ! get dimension size
    call FILE_get_shape( fid, "height", & ! (in)
                         dims(:)        ) ! (out)
    nx = dims(1)
    ny = dims(2)
    nz = dims(3)

    ! get x and y axis
    allocate( xaxis(nx), yaxis(ny) )
    call FILE_read( fid, "x", xaxis(:) )
    call FILE_read( fid, "y", yaxis(:) )

    ! search index
    do i = 1, nx
       if ( x <= xaxis(i) ) exit
    end do
    do j = 1, ny
       if ( y <= yaxis(j) ) exit
    end do
    start(:) = (/i,j,1/)

    ! get z axis
    allocate( z(nz), zh(0:nz) )
    call FILE_read( fid, "height",     z(:),  start=start(:), count=(/1,1,nz/) )
    call FILE_read( fid, "height_xyw", zh(:), start=start(:), count=(/1,1,nz+1/) )

    ! get variables
    allocate( TEMP(nz), PRES(nz), QV(nz), QC(nz), QR(nz), QI(nz), QS(nz), QG(nz) )
    count(:) = (/1,1,nz/)

    call FILE_read( fid, "T",    TEMP(:), start=start(:), count=count(:), step=nstep )
    call FILE_read( fid, "PRES", PRES(:), start=start(:), count=count(:), step=nstep )
    call FILE_read( fid, "QV",   QV  (:), start=start(:), count=count(:), step=nstep )
    call FILE_read( fid, "QC",   QC  (:), start=start(:), count=count(:), step=nstep, allow_missing=.true. )
    call FILE_read( fid, "QR",   QR  (:), start=start(:), count=count(:), step=nstep, allow_missing=.true. )
    call FILE_read( fid, "QI",   QI  (:), start=start(:), count=count(:), step=nstep, allow_missing=.true. )
    call FILE_read( fid, "QS",   QS  (:), start=start(:), count=count(:), step=nstep, allow_missing=.true. )
    call FILE_read( fid, "QG",   QG  (:), start=start(:), count=count(:), step=nstep, allow_missing=.true. )

    ! close
    call FILE_close( fid )

    return
  end subroutine read_data

end program moist_adiabat


      program psndrv3
c
c     Message Passing Layer: BLACS
c
c     Simple program to illustrate the idea of reverse communication
c     in inverse mode for a generalized nonsymmetric eigenvalue problem.
c
c     We implement example three of ex-nonsym.doc in DOCUMENTS directory
c
c\Example-3
c     ... Suppose we want to solve A*x = lambda*B*x in inverse mode,
c         where A is derived from the 1-dimensional convection-diffusion
c         operator on the interval [0,1] with zero boundary condition,
c         and M is the tridiagonal matrix with 4 on the diagonal and 1
c         on the subdiagonals.
c     ... So OP = inv[M]*A  and  B = M.
c     ... Use mode 2 of PSNAUPD.
c
c\BeginLib
c
c\Routines called:
c     psnaupd Parallel ARPACK reverse communication interface routine.
c     psneupd Parallel ARPACK routine that returns Ritz values and (optionally)
c              Ritz vectors.
c     spttrf  LAPACK symmetric positive definite tridiagonal factorization
c             routine.
c     spttrs  LAPACK symmetric positive definite tridiagonal solve routine.
c     slapy2  LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     saxpy   Level 1 BLAS that computes y <- alpha*x+y.
c     psnorm2 Parallel version of Level 1 BLAS that computes the norm of a vector.
c     av      Parallel Matrix vector multiplication routine that computes A*x.
c     mv      Matrix vector multiplication routine that computes M*x.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\Parallel Modifications
c     Kristi Maschhoff
c
c\Revision history:
c     Starting Point: Serial Code FILE: ndrv3.F   SID: 2.2
c
c\SCCS Information:
c FILE: ndrv3.F   SID: 1.2   DATE OF SID: 09/14/98   RELEASE: 1
c
c\Remarks
c     1. None
c
c\EndLib
c--------------------------------------------------------------------------
c
      include 'debug.h'
      include 'stat.h'

c     %-----------------%
c     | BLACS INTERFACE |
c     %-----------------%
c
      integer           comm, iam, nprocs, nloc,
     &                  nprow, npcol, myprow, mypcol
c
      external          BLACS_PINFO, BLACS_SETUP, BLACS_GET,
     &                  BLACS_GRIDINIT, BLACS_GRIDINFO
c
c     %-----------------------------%
c     | Define leading dimensions   |
c     | for all arrays.             |
c     | MAXN:   Maximum dimension   |
c     |         of the A allowed.   |
c     | MAXNEV: Maximum NEV allowed |
c     | MAXNCV: Maximum NCV allowed |
c     %-----------------------------%
c
      integer           maxn, maxnev, maxncv, ldv
      parameter         (maxn=256, maxnev=10, maxncv=25,
     &                   ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer           iparam(11), ipntr(14)
      logical           select(maxncv)
      Real
     &                  ax(maxn), mx(maxn), d(maxncv, 3), resid(maxn),
     &                  v(ldv,maxncv), workd(3*maxn),
     &                  workev(3*maxncv),
     &                  workl(3*maxncv*maxncv+6*maxncv),
     &                  md(maxn), me(maxn-1), temp(maxn), temp_buf(maxn)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character         bmat*1, which*2
      integer           ido, n, nev, ncv, lworkl, info, ierr, j,
     &                  nconv, maxitr, ishfts, mode, blk
      Real
     &                  tol, sigmar, sigmai
      logical           first, rvec
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &                  zero, one
      parameter         (zero = 0.0, one = 1.0)
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
      Real
     &                  psnorm2, slapy2
      external          saxpy, psnorm2, spttrf, spttrs, slapy2
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      call BLACS_PINFO( iam, nprocs )
c
c     If in PVM, create virtual machine if it doesn't exist
c
      if (nprocs .lt. 1) then
         if (iam .eq. 0) then
              write(*,1000)
              read(*, 2000) nprocs
         endif
         call BLACS_SETUP( iam, nprocs )
      endif
c
1000  format('How many processes in machine?')
2000  format(I3)
c
c     Set up processors in 1D Grid
c
      nprow = nprocs
      npcol = 1
c
c     Get default system context, and define grid
c
      call BLACS_GET( 0, 0, comm )
      call BLACS_GRIDINIT( comm, 'Row', nprow, npcol )
      call BLACS_GRIDINFO( comm, nprow, npcol, myprow, mypcol )
c
c     If I'm not in grid, go to end of program
c
      if ( (myprow .ge. nprow) .or. (mypcol .ge. npcol) ) goto 9000
c
      ndigit = -3
      logfil = 6
      mnaupd = 1
c
c     %----------------------------------------------------%
c     | The number N is the dimension of the matrix.  A    |
c     | generalized eigenvalue problem is solved (BMAT =   |
c     | 'G').  NEV is the number of eigenvalues to be      |
c     | approximated.  The user can modify NEV, NCV, WHICH |
c     | to solve problems of different sizes, and to get   |
c     | different parts of the spectrum.  However, The     |
c     | following conditions must be satisfied:            |
c     |                    N <= MAXN,                      |
c     |                  NEV <= MAXNEV,                    |
c     |              NEV + 2 <= NCV <= MAXNCV              |
c     %----------------------------------------------------%
c
      n     = 100
      nev   = 4
      ncv   = 20
c
c     %--------------------------------------%
c     | Set up distribution of data to nodes |
c     %--------------------------------------%
c
      nloc = (n / nprocs )
      blk = nloc
      if ( mod(n, nprocs) .gt. 0 ) then
         if ( myprow .eq. nprow-1 ) nloc = nloc + mod(n, nprocs)
*      if ( mod(n, nprocs) .gt. myprow ) nloc = nloc + 1
      endif
c
      if ( nloc .gt. maxn ) then
         print *, ' ERROR with _NDRV3: NLOC is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV '
         go to 9000
      end if
      bmat  = 'G'
      which = 'LM'
c
c     %-----------------------------------------------------%
c     | The matrix M is chosen to be the symmetric tri-     |
c     | diagonal matrix with 4 on the diagonal and 1 on the |
c     | off diagonals. It is factored by LAPACK subroutine  |
c     | spttrf.                                             |
c     %-----------------------------------------------------%
c
      do 20 j = 1, n-1
         md(j) = 4.0
         me(j) = one
  20  continue
      md(n) = 4.0*one
c
      call spttrf(n, md, me, ierr)
      if ( ierr .ne. 0 ) then
         print*, ' '
         print*, ' ERROR with _pttrf. '
         print*, ' '
         go to 9000
      end if
c
c     %-----------------------------------------------------%
c     | The work array WORKL is used in SNAUPD as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.  The parameter TOL determines    |
c     | the stopping criterion. If TOL<=0, machine          |
c     | precision is used.  The variable IDO is used for    |
c     | reverse communication, and is initially set to 0.   |
c     | Setting INFO=0 indicates that a random vector is    |
c     | generated in SNAUPD to start the Arnoldi iteration. |
c     %-----------------------------------------------------%
c
      lworkl = 3*ncv**2+6*ncv
      tol    = 0.0
      ido    = 0
      info   = 0
c
c     %---------------------------------------------------%
c     | This program uses exact shifts with respect to    |
c     | the current Hessenberg matrix (IPARAM(1) = 1).    |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 2 of SNAUPD is used     |
c     | (IPARAM(7) = 2).  All these options can be        |
c     | changed by the user. For details, see the         |
c     | documentation in SNAUPD.                          |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = 300
      mode   = 2
c
      iparam(1) = ishfts
      iparam(3) = maxitr
      iparam(7) = mode
c
c     %-------------------------------------------%
c     | M A I N   L O O P (Reverse communication) |
c     %-------------------------------------------%
c
 10   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine SNAUPD and take |
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call psnaupd( comm, ido, bmat, nloc, which, nev, tol, resid,
     &                 ncv, v, ldv, iparam, ipntr, workd,
     &                 workl, lworkl, info )
c
         if (ido .eq. -1 .or. ido .eq. 1) then
c
c           %----------------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x      |
c           | The user should supply his/her own     |
c           | matrix vector routine and a linear     |
c           | system solver.  The matrix-vector      |
c           | subroutine should take workd(ipntr(1)) |
c           | as input, and the final result should  |
c           | be returned to workd(ipntr(2)).        |
c           %----------------------------------------%
c
            call av (comm, nloc, n, workd(ipntr(1)), workd(ipntr(2)))
c======== Hack for Linear system ======= ccc
            call sscal(n, zero, temp, 1)
            do 15 j=1,nloc
               temp(myprow*blk + j) = workd(ipntr(2) + j - 1)
   15       continue
            call sgsum2d( comm, 'All', ' ', n, 1, temp, n, -1, -1 )
            call spttrs(n, 1, md, me, temp, n,
     &                  ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' ERROR with _pttrs. '
               print*, ' '
               go to 9000
            end if
            do 16 j=1,nloc
               workd(ipntr(2) + j - 1 ) = temp(myprow*blk + j)
   16       continue
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call SNAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         else if ( ido .eq. 2) then
c
c           %-------------------------------------%
c           |        Perform  y <--- M*x          |
c           | The matrix vector multiplication    |
c           | routine should take workd(ipntr(1)) |
c           | as input and return the result to   |
c           | workd(ipntr(2)).                    |
c           %-------------------------------------%
c
            call mv (comm, nloc, workd(ipntr(1)), workd(ipntr(2)))
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call SNAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         end if
c
c
c     %-----------------------------------------%
c     | Either we have convergence, or there is |
c     | an error.                               |
c     %-----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %---------------------------%
c        | Error message. Check the  |
c        | documentation in PSNAUPD. |
c        %---------------------------%
c
         if ( myprow .eq. 0 ) then
            print *, ' '
            print *, ' Error with _naupd, info = ', info
            print *, ' Check the documentation of _naupd.'
            print *, ' '
         endif
c
      else
c
c        %-------------------------------------------%
c        | No fatal errors occurred.                 |
c        | Post-Process using SNEUPD.                |
c        |                                           |
c        | Computed eigenvalues may be extracted.    |
c        |                                           |
c        | Eigenvectors may also be computed now if  |
c        | desired.  (indicated by rvec = .true.)    |
c        %-------------------------------------------%
c
         rvec = .true.
         call psneupd ( comm, rvec, 'A', select, d, d(1,2), v, ldv,
     &        sigmar, sigmai, workev, bmat, nloc, which, nev, tol,
     &        resid, ncv, v, ldv, iparam, ipntr, workd,
     &        workl, lworkl, ierr )
c
c        %-----------------------------------------------%
c        | The real part of the eigenvalue is returned   |
c        | in the first column of the two dimensional    |
c        | array D, and the IMAGINARY part is returned   |
c        | in the second column of D.  The corresponding |
c        | eigenvectors are returned in the first NEV    |
c        | columns of the two dimensional array V if     |
c        | requested.  Otherwise, an orthogonal basis    |
c        | for the invariant subspace corresponding to   |
c        | the eigenvalues in D is returned in V.        |
c        %-----------------------------------------------%
c
         if ( ierr .ne. 0 ) then
c
c           %------------------------------------%
c           | Error condition:                   |
c           | Check the documentation of SNEUPD. |
c           %------------------------------------%
c
            if ( myprow .eq. 0 ) then
               print *, ' '
               print *, ' Error with _neupd, info = ', ierr
               print *, ' Check the documentation of _neupd'
               print *, ' '
            endif
c
         else
c
            first = .true.
            nconv = iparam(5)
            do 30 j=1, iparam(5)
c
c              %---------------------------%
c              | Compute the residual norm |
c              |                           |
c              |  ||  A*x - lambda*M*x ||  |
c              |                           |
c              | for the NCONV accurately  |
c              | computed eigenvalues and  |
c              | eigenvectors.  (iparam(5) |
c              | indicates how many are    |
c              | accurate to the requested |
c              | tolerance)                |
c              %---------------------------%
c
               if (d(j,2) .eq. zero)  then
c
c                 %--------------------%
c                 | Ritz value is real |
c                 %--------------------%
c
                  call av(comm, nloc, n, v(1,j), ax)
                  call mv(comm, nloc, v(1,j), mx)
                  call saxpy(nloc, -d(j,1), mx, 1, ax, 1)
                  d(j,3) = psnorm2(comm, nloc, ax, 1)
c
               else if (first) then
c
c                 %------------------------%
c                 | Ritz value is complex  |
c                 | Residual of one Ritz   |
c                 | value of the conjugate |
c                 | pair is computed.      |
c                 %------------------------%
c
                  call av(comm, nloc, n, v(1,j), ax)
                  call mv(comm, nloc, v(1,j), mx)
                  call saxpy(nloc, -d(j,1), mx, 1, ax, 1)
                  call mv(comm, nloc, v(1,j+1), mx)
                  call saxpy(nloc, d(j,2), mx, 1, ax, 1)
                  d(j,3) = psnorm2(comm, nloc, ax, 1)**2
                  call av(comm, nloc, n, v(1,j+1), ax)
                  call mv(comm, nloc, v(1,j+1), mx)
                  call saxpy(nloc, -d(j,1), mx, 1, ax, 1)
                  call mv(comm, nloc, v(1,j), mx)
                  call saxpy(nloc, -d(j,2), mx, 1, ax, 1)
                  d(j,3) = slapy2( d(j,3), psnorm2(comm,nloc,ax,1) )
                  d(j+1,3) = d(j,3)
                  first = .false.
               else
                  first = .true.
               end if
c
  30        continue
c
c           %-----------------------------%
c           | Display computed residuals. |
c           %-----------------------------%
c
            call psmout(comm, 6, nconv, 3, d, maxncv, -6,
     &           'Ritz values (Real,Imag) and direct residuals')
c
         end if
c
c        %------------------------------------------%
c        | Print additional convergence information |
c        %------------------------------------------%
c
         if (myprow .eq. 0)then
         if ( info .eq. 1) then
            print *, ' '
            print *, ' Maximum number of iterations reached.'
            print *, ' '
         else if ( info .eq. 3) then
            print *, ' '
            print *, ' No shifts could be applied during implicit
     &                 Arnoldi update, try increasing NCV.'
            print *, ' '
         end if
c
         print *, ' '
         print *, '_NDRV3 '
         print *, '====== '
         print *, ' '
         print *, ' Size of the matrix is ', n
         print *, ' The number of processors is ', nprocs
         print *, ' The number of Ritz values requested is ', nev
         print *, ' The number of Arnoldi vectors generated',
     &            ' (NCV) is ', ncv
         print *, ' What portion of the spectrum: ', which
         print *, ' The number of converged Ritz values is ',
     &              nconv
         print *, ' The number of Implicit Arnoldi update',
     &            ' iterations taken is ', iparam(3)
         print *, ' The number of OP*x is ', iparam(9)
         print *, ' The convergence criterion is ', tol
         print *, ' '
c
         endif
      end if
c
c     %----------------------------%
c     | Done with program psndrv3. |
c     %----------------------------%
c
 9000 continue
c
c     %-------------------------%
c     | Release resources BLACS |
c     %-------------------------%
c
      call BLACS_GRIDEXIT ( comm )
      call BLACS_EXIT(0)
c
      end
c
c==========================================================================
c
c     parallel matrix vector multiplication subroutine
c
c     Compute the matrix vector multiplication y<---A*x
c     where A is a n by n nonsymmetric tridiagonal matrix derived
c     from the central difference discretization of the 1-dimensional
c     convection diffusion operator on the interval [0,1] with
c     zero Dirichlet boundary condition.
c
      subroutine av (comm, nloc, n, v, w)
c
c     .. BLACS Declarations ...
      integer           comm, nprow, npcol, myprow, mypcol
      external          BLACS_GRIDINFO, sgesd2d, sgerv2d
c
      integer           nloc, n, j, next, prev
      Real
     &                  v(nloc), w(nloc), one, two, dd, dl, du,
     &                  s, h, rho, mv_buf
      parameter         ( rho = 10.0, one = 1.0,
     &                    two = 2.0)
c
      call BLACS_GRIDINFO( comm, nprow, npcol, myprow, mypcol )
      h = one / real(n+1)
      s = rho*h / two
      dd = two
      dl = -one - s
      du = -one + s
c
      w(1) =  dd*v(1) + du*v(2)
      do 10 j = 2,nloc-1
         w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1)
 10   continue
      w(nloc) =  dl*v(nloc-1) + dd*v(nloc)
c
      next = myprow + 1
      prev = myprow - 1
      if ( myprow .lt. nprow-1 ) then
         call sgesd2d( comm, 1, 1, v(nloc), 1, next, mypcol)
      endif
      if ( myprow .gt. 0 ) then
         call sgerv2d( comm, 1, 1, mv_buf, 1, prev, mypcol )
         w(1) = w(1) + dl*mv_buf
      endif
c
      if ( myprow .gt. 0 ) then
         call sgesd2d( comm, 1, 1, v(1), 1, prev, mypcol)
      endif
      if ( myprow .lt. nprow-1 ) then
         call sgerv2d( comm, 1, 1, mv_buf, 1, next, mypcol )
         w(nloc) = w(nloc) + du*mv_buf
      endif
c
      return
      end
c------------------------------------------------------------------------
c
c     Compute the matrix vector multiplication y<---M*x
c     where M is a n by n tridiagonal matrix with 4 on the
c     diagonal, 1 on the subdiagonal and the superdiagonal.
c
      subroutine mv (comm, nloc, v, w)
c
c     .. BLACS Declarations ...
      integer           comm, nprow, npcol, myprow, mypcol
      external          BLACS_GRIDINFO, sgesd2d, sgerv2d
c
      integer           nloc, j, next, prev
      Real
     &                  v(nloc), w(nloc), one, four, mv_buf
      parameter         ( one = 1.0, four = 4.0)
c
      call BLACS_GRIDINFO( comm, nprow, npcol, myprow, mypcol )
c
      w(1) =  four*v(1) + one*v(2)
      do 10 j = 2,nloc-1
         w(j) = one*v(j-1) + four*v(j) + one*v(j+1)
 10   continue
      w(nloc) =  one*v(nloc-1) + four*v(nloc)
c
      next = myprow + 1
      prev = myprow - 1
      if ( myprow .lt. nprow-1 ) then
         call sgesd2d( comm, 1, 1, v(nloc), 1, next, mypcol)
      endif
      if ( myprow .gt. 0 ) then
         call sgerv2d( comm, 1, 1, mv_buf, 1, prev, mypcol )
         w(1) = w(1) + mv_buf
      endif
c
      if ( myprow .gt. 0 ) then
         call sgesd2d( comm, 1, 1, v(1), 1, prev, mypcol)
      endif
      if ( myprow .lt. nprow-1 ) then
         call sgerv2d( comm, 1, 1, mv_buf, 1, next, mypcol )
         w(nloc) = w(nloc) + mv_buf
      endif
c
      return
      end
c------------------------------------------------------------
      subroutine mv2 (comm, n, v, w)
      integer           n, j, comm
      Real
     &                  v(n), w(n)
      do 10 j=1,n
         w(j) = v(j)
 10   continue
c
      return
      end


program squarePoly
  implicit none

  real :: x
  real :: y
  != unit kg**2 :: z
  real :: z

  != unit(m) :: a
  real :: a
  != unit(s) :: b
  real :: b

  real :: c

  x = square(a)
  y = square(b)
  z = square(c)

contains

  real function square(x)
    real :: x
    square = x * x
  end function square

end program


      SUBROUTINE ANGTRS (THETA,K,TRANS)
C     &    ENTRY ANGTRD
C
C     ROUTINE TO CALCULATE AND OUTPUT THE INPLANE ROTATION
C     TRANSFORMATION IN 3-D USING THE ANGLE OF ROTATION.
C
C     IF K=1, TRANS OR TRAND WILL BE TRANSPOSED AND THEN RETURNED.
C
C     SINGLE PRECISION -
C
      REAL               TRANS(9)
      DOUBLE PRECISION   TRAND(9), THETAD
C
      DO 10 I = 1,9
   10 TRANS(I) = 0.0
C
      TRANS(1) =  COS(THETA)
      TRANS(2) =  SIN(THETA)
      TRANS(4) = -TRANS(2)
      TRANS(5) =  TRANS(1)
      TRANS(9) =  1.0
C
      IF (K .NE. 1) GO TO 30
      TRANS(2) = -TRANS(2)
      TRANS(4) = -TRANS(4)
      RETURN
C
      ENTRY ANGTRD (THETAD,K,TRAND)
C     =============================
C
C     DOUBLE PRECISION -
C
      DO 20 I = 1,9
   20 TRAND(I) = 0.0D0
C
      TRAND(1) =  DCOS(THETAD)
      TRAND(2) =  DSIN(THETAD)
      TRAND(4) = -TRAND(2)
      TRAND(5) =  TRAND(1)
      TRAND(9) =  1.0D0
C
      IF (K .NE. 1) GO TO 30
      TRAND(2) = -TRAND(2)
      TRAND(4) = -TRAND(4)
   30 RETURN
      END


      subroutine ygam(alf,bet,gam,yg,m,n,nintg)
!----------------------------------------------------------------------
!
!   Version           - July 10, 2000, changed on February 11, 2008 MP,KP.
!
!   Purpose           - calculates Gamma      (alpha,beta,gamma)
!                                       -1,m,n
!
!                                  Gamma      (alpha,beta,gamma)
!                                       -2,m,n
!
!   Arguments         - parameter NINTG (1-2) defines a number of integrals
!                         to be evaluated starting from Gamma
!                                                            -1,m,n
!
!   Remarks:          - see R.A.Sack, C.C.J.Roothaan, and W.Kolos,
!                         J. Math. Phys., v.8 (1967) 1093, for notation
!
!----------------------------------------------------------------------
      implicit          real (16) (a-h,o-z)
      parameter         (lenl=200)
      real (16), parameter ::  one  = 1.0q0
      real (16), parameter ::  half = 0.5q0
      dimension         yg(0:lenl,0:lenl,2)
      dimension         cc(0:lenl,0:lenl),dd(0:lenl,0:lenl),ee(0:2*lenl)
      dimension         ygt(0:lenl,0:lenl,10)
      dimension         gg(0:3*lenl)

      if (bet >= gam) then
         u = (bet-gam)/(alf+gam)
         bt = bet
         gm = gam
         ainv = one/(bet+gam)
         ag = alf+gam
         binv = one/ag
         ab = alf+bet
         ginv = one/ab
         mm = m
         nn = n
         mn = m+n
         ind = 0
      else
         u = (gam-bet)/(alf+bet)
         bt = gam
         gm = bet
         ainv = one/(bet+gam)
         ag = alf+bet
         binv = one/ag
         ab = alf+gam
         ginv = one/ab
         mm = n
         nn = m
         mn = m+n
         ind = 1
      end if
!
!                     dd(i,j) - derivatives of [ln(a+b)-ln(a+g)]/(a-g)
!
      call dplog(u,mn,gg)
      cc(0,0) = gg(0)
      cc(1,0) = gg(1)*binv
      temp = binv
      do i=2,mn
         temp = temp*binv
         cc(i,0) = gg(i)*temp
      end do
      do j=1,nn
         do i=0,mn-j
            cc(i,j) = binv*((i+j-1)*cc(i,j-1)-ab*cc(i+1,j-1))
         end do
      end do
      dd(0,0) = binv*cc(0,0)
      do i=1,mm
         dd(i,0) = binv*cc(i,0)
      end do
      do j=1,nn
         dd(0,j) = binv*(j*dd(0,j-1)+cc(0,j))
         do i=1,mm
            dd(i,j) = binv*(j*dd(i,j-1)+cc(i,j))
         end do
      end do
!
!                       Gamma
!                            -1
!
      yg(0,0,1) = ainv*dd(0,0)
      do i=1,mm
         yg(i,0,1) = ainv*(i*yg(i-1,0,1)+dd(i,0))
      end do
      do j=1,nn
         yg(0,j,1) = ainv*(j*yg(0,j-1,1)+dd(0,j))
         do i=1,mm
            yg(i,j,1) = ainv*(i*yg(i-1,j,1)+j*yg(i,j-1,1)+dd(i,j))
         end do
      end do
!
!                       Gamma
!                            -2
!
      if (nintg < 2) goto 10
      clogbg = log(ab*ag)
      ygt(0,0,1) = ainv*clogbg
      yg(0,0,2) = -alf*yg(0,0,1)-half*(dd(0,0)+ygt(0,0,1))
      dlog = -ginv
      do i=1,mm
         ygt(i,0,1) = ainv*(i*ygt(i-1,0,1)+dlog)
         yg(i,0,2) = -alf*yg(i,0,1)-half*(dd(i,0)+ygt(i,0,1))
         dlog = dlog*i*ginv
      end do
      dlog = -binv
      do j=1,nn
         ygt(0,j,1) = ainv*(j*ygt(0,j-1,1)+dlog)
         yg(0,j,2) = -alf*yg(0,j,1)-half*(dd(0,j)+ygt(0,j,1))
         dlog = dlog*j*binv
         do i=1,mm
            ygt(i,j,1) = ainv*(i*ygt(i-1,j,1)+j*ygt(i,j-1,1))
            yg(i,j,2) = -alf*yg(i,j,1)-half*(dd(i,j)+ygt(i,j,1))
         end do
      end do

!     added 06.01.2008 by MP
!     add derivatives over -b,-c of 1/(b+c)
!
      temp = ainv

!     ee(i) = i!/(b+c)^(i+1)

      ee(0)=ainv
      do i=1,nn+mm
       ee(i)=i*ee(i-1)*ainv
      enddo

      do i=0,mm
       do j=0,nn
        yg(i,j,2) = yg(i,j,2) + ee(i+j)
       enddo
      enddo

!
!                    backward transposition if necessary
!
   10 if (ind == 1) then
         do k=1,nintg
            do i=0,min(m,n)
               do j=0,i-1
                  temp = yg(i,j,k)
                  yg(i,j,k) = yg(j,i,k)
                  yg(j,i,k) = temp
               end do
            end do
            do j=m+1,n
               do i=0,m
                  yg(i,j,k) = yg(j,i,k)
               end do
            end do
            do i=n+1,m
               do j=0,n
                  yg(i,j,k) = yg(j,i,k)
               end do
            end do
         end do
      end if
!
      return
      end


module DRAG_EXPONENTIAL
    ! Description:
    !    Contains the subroutine to compute the perturbation acceleration due to drag. The
    !    atmospheric model is exponential.

    use KINDS, only: dk
    implicit none

    contains

    function DRAG_ACC(y_D,wE,RE,CD,A2M)
    ! Description:
    !    Computes the dimensional drag acceleration from the state vector and parameters. Uses
    !    data from Vallado's Fundamentals of Astrodynamics, 4th Edition; data about atmospheric
    !    density is from the US Standard Atmosphere (1976) and CIRA-72 models.
    !
    ! INPUTS:
    !    y_D = dimensional state vector [km,km/s]
    !    wE  = Earth's rotational velocity [rad/s]
    !    RE  = Earth's equatorial radius [km]
    !    CD  = drag coefficient
    !    A2M = area-to-mass ratio [m^2/kg]
    !
    ! OUTPUTS:
    !    DRAG_ACC = dimensional drag acceleration [km/s^2]
    !
    ! VERSIONS:
    !    10/06/2015: v1.
    !    11/06/2015: v2. Add 0-350 km altitude range.
    !    06/04/2017: v3. Add kinds.
    !    29/09/2017: DEPRECATED.
    !
    ! AUTHOR:
    ! Davide Amato
    ! Space Dynamics Group
    ! E.T.S.I.A.E. - UPM
    ! davideamato@email.arizona.edu
    !
    ! =========================================================================================

    ! VARIABLES
    implicit none
    ! Arguments IN
    real(dk),intent(in)  ::  y_D(1:6),wE,RE,CD,A2M
    ! Function definition
    real(dk)         ::  DRAG_ACC(1:3)

    ! Density data
    real(dk)         ::  rho0,h0,scale_H
    real(dk)         ::  rNorm,h,rho
    ! Relative velocity
    real(dk)         ::  v_atm(1:3),v_rel(1:3),v_relNorm
    real(dk)         ::  D_factor

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

    ! =======================================
    ! 1. DENSITY FROM TABULATED DATA
    ! =======================================

    rNorm = sqrt(dot_product(y_D(1:3),y_D(1:3)))
    h = rNorm - RE

    ! Select base and scale heights and nominal density. Density is in kg/m^3.
    if (h >= 0._dk .and. h < 25._dk) then
        h0      = 0._dk
        scale_H = 7.249_dk
        rho0    = 1.225_dk
    else if (h >= 25._dk .and. h < 30._dk) then               ! 0 KM (SEA LEVEL)
        h0      = 25._dk
        scale_H = 6.349_dk
        rho0    = 3.899E-2_dk
    else if (h >= 30._dk .and. h < 40._dk) then
        h0      = 30._dk
        scale_H = 6.682_dk
        rho0    = 1.774E-2_dk
    else if (h >= 40._dk .and. h < 50._dk) then
        h0      = 40._dk
        scale_H = 7.554_dk
        rho0    = 3.972E-3_dk
    else if (h >= 50._dk .and. h < 60._dk) then
        h0      = 50._dk
        scale_H = 8.382_dk
        rho0    = 1.057E-3_dk
    else if (h >= 60._dk .and. h < 70._dk) then
        h0      = 60._dk
        scale_H = 7.714_dk
        rho0    = 3.206E-4_dk
    else if (h >= 70._dk .and. h < 80._dk) then
        h0      = 70._dk
        scale_H = 6.549_dk
        rho0    = 8.770E-5_dk
    else if (h >= 80._dk .and. h < 90._dk) then
        h0      = 80._dk
        scale_H = 5.799_dk
        rho0    = 1.905E-5_dk
    else if (h >= 90._dk .and. h < 100._dk) then
        h0      = 90._dk
        scale_H = 5.382_dk
        rho0    = 3.396E-6_dk
    else if (h >= 100._dk .and. h < 110._dk) then             ! 100 KM
        h0      = 100._dk
        scale_H = 5.877_dk
        rho0    = 5.297E-7_dk
    else if (h >= 110._dk .and. h < 120._dk) then
        h0      = 110._dk
        scale_H = 7.263_dk
        rho0    = 9.661E-8_dk
    else if (h >= 120._dk .and. h < 130._dk) then
        h0      = 120._dk
        scale_H = 9.473_dk
        rho0    = 2.438E-8_dk
    else if (h >= 130._dk .and. h < 140._dk) then
        h0      = 130._dk
        scale_H = 12.636_dk
        rho0    = 8.484E-9_dk
    else if (h >= 140._dk .and. h < 150._dk) then
        h0      = 140._dk
        scale_H = 16.149_dk
        rho0    = 3.845E-9_dk
    else if (h >= 150._dk .and. h < 180._dk) then
        h0      = 150._dk
        scale_H = 22.523_dk
        rho0    = 2.070E-9_dk
    else if (h >= 180._dk .and. h < 200._dk) then
        h0      = 180._dk
        scale_H = 29.740_dk
        rho0    = 5.464E-10_dk
    else if (h >= 200._dk .and. h < 250._dk) then
        h0      = 200._dk
        scale_H = 37.105_dk
        rho0    = 2.789E-10_dk
    else if (h >= 250._dk .and. h < 300._dk) then
        h0      = 250._dk
        scale_H = 45.546_dk
        rho0    = 7.248E-11_dk
    else if (h >= 300._dk .and. h < 350._dk) then             ! 300 KM
        h0      = 300._dk
        scale_H = 53.628_dk
        rho0    = 2.418E-11_dk
    else if (h >= 350._dk .and. h < 400._dk) then
        h0      = 350._dk
        scale_H = 53.298_dk
        rho0    = 9.518E-12_dk
    else if (h >= 400._dk .and. h < 450._dk) then
        h0      = 400._dk
        scale_H = 58.515_dk
        rho0    = 3.725E-12_dk
    else if (h >= 450._dk .and. h < 500._dk) then
        h0      = 450._dk
        scale_H = 60.828_dk
        rho0    = 1.585E-12_dk
    else if (h >= 500._dk .and. h < 600._dk) then
        h0      = 500._dk
        scale_H = 63.822_dk
        rho0    = 6.967E-13_dk
    else if (h >= 600._dk .and. h < 700._dk) then
        h0      = 600._dk
        scale_H = 71.835_dk
        rho0    = 1.454E-13_dk
    else if (h >= 700._dk .and. h < 800._dk) then
        h0      = 700._dk
        scale_H = 88.667_dk
        rho0    = 3.614E-14_dk
    else if (h >= 800._dk .and. h < 900._dk) then
        h0      = 800._dk
        scale_H = 124.64_dk
        rho0    = 1.170E-14_dk
    else if (h >= 900._dk .and. h < 1000._dk) then
        h0      = 900._dk
        scale_H = 181.05_dk
        rho0    = 5.245E-15_dk
    else if (h > 1000.) then                            ! > 1000 KM
        h0      = 1000._dk
        scale_H = 268._dk
        rho0    = 3.019E-15_dk
    end if

    rho = rho0*exp(-(h-h0)/scale_H)

    ! ===============================================
    ! 2. RELATIVE VELOCITY WITH RESPECT TO ATMOSPHERE
    ! ===============================================

    v_atm = wE*[-y_D(2),y_D(1),0._dk]
    v_rel = y_D(4:6) - v_atm
    v_relNorm = norm2(v_rel)

    ! ===============================================
    ! 3. DRAG ACCELERATION
    ! ===============================================

    ! Acceleration is in km/s^2
    D_factor = -0.5_dk*1000._dk*CD*A2M*rho
    DRAG_ACC = D_factor*v_relNorm*v_rel

    end function DRAG_ACC

    function ATMOS_VALLADO(h)
    ! Description:
    !    Computes the atmospheric density according to the piecewise exponential
    !    model in:
    !    D. Vallado, W. D. McClain, "Fundamentals of Astrodynamics", 4th Edition
    !
    !    Data is originally from the US 1976 Standard Atmosphere and the CIRA-72
    !     model.
    !
    ! ==========================================================================

    ! VARIABLES
    implicit none
    ! Arguments IN
    real(dk),intent(in)  ::  h             ! Altitude [km]
    ! Function definition
    real(dk)         ::  ATMOS_VALLADO     ! Density [kg/m^3]

    ! Density data
    real(dk)         ::  rho0,h0,scale_H

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

    ! Select base and scale heights and nominal density. Density is in kg/m^3.
    if (h >= 0._dk .and. h < 25._dk) then
        h0      = 0._dk
        scale_H = 7.249_dk
        rho0    = 1.225_dk
    else if (h >= 25._dk .and. h < 30._dk) then               ! 0 KM (SEA LEVEL)
        h0      = 25._dk
        scale_H = 6.349_dk
        rho0    = 3.899E-2_dk
    else if (h >= 30._dk .and. h < 40._dk) then
        h0      = 30._dk
        scale_H = 6.682_dk
        rho0    = 1.774E-2_dk
    else if (h >= 40._dk .and. h < 50._dk) then
        h0      = 40._dk
        scale_H = 7.554_dk
        rho0    = 3.972E-3_dk
    else if (h >= 50._dk .and. h < 60._dk) then
        h0      = 50._dk
        scale_H = 8.382_dk
        rho0    = 1.057E-3_dk
    else if (h >= 60._dk .and. h < 70._dk) then
        h0      = 60._dk
        scale_H = 7.714_dk
        rho0    = 3.206E-4_dk
    else if (h >= 70._dk .and. h < 80._dk) then
        h0      = 70._dk
        scale_H = 6.549_dk
        rho0    = 8.770E-5_dk
    else if (h >= 80._dk .and. h < 90._dk) then
        h0      = 80._dk
        scale_H = 5.799_dk
        rho0    = 1.905E-5_dk
    else if (h >= 90._dk .and. h < 100._dk) then
        h0      = 90._dk
        scale_H = 5.382_dk
        rho0    = 3.396E-6_dk
    else if (h >= 100._dk .and. h < 110._dk) then             ! 100 KM
        h0      = 100._dk
        scale_H = 5.877_dk
        rho0    = 5.297E-7_dk
    else if (h >= 110._dk .and. h < 120._dk) then
        h0      = 110._dk
        scale_H = 7.263_dk
        rho0    = 9.661E-8_dk
    else if (h >= 120._dk .and. h < 130._dk) then
        h0      = 120._dk
        scale_H = 9.473_dk
        rho0    = 2.438E-8_dk
    else if (h >= 130._dk .and. h < 140._dk) then
        h0      = 130._dk
        scale_H = 12.636_dk
        rho0    = 8.484E-9_dk
    else if (h >= 140._dk .and. h < 150._dk) then
        h0      = 140._dk
        scale_H = 16.149_dk
        rho0    = 3.845E-9_dk
    else if (h >= 150._dk .and. h < 180._dk) then
        h0      = 150._dk
        scale_H = 22.523_dk
        rho0    = 2.070E-9_dk
    else if (h >= 180._dk .and. h < 200._dk) then
        h0      = 180._dk
        scale_H = 29.740_dk
        rho0    = 5.464E-10_dk
    else if (h >= 200._dk .and. h < 250._dk) then
        h0      = 200._dk
        scale_H = 37.105_dk
        rho0    = 2.789E-10_dk
    else if (h >= 250._dk .and. h < 300._dk) then
        h0      = 250._dk
        scale_H = 45.546_dk
        rho0    = 7.248E-11_dk
    else if (h >= 300._dk .and. h < 350._dk) then             ! 300 KM
        h0      = 300._dk
        scale_H = 53.628_dk
        rho0    = 2.418E-11_dk
    else if (h >= 350._dk .and. h < 400._dk) then
        h0      = 350._dk
        scale_H = 53.298_dk
        rho0    = 9.518E-12_dk
    else if (h >= 400._dk .and. h < 450._dk) then
        h0      = 400._dk
        scale_H = 58.515_dk
        rho0    = 3.725E-12_dk
    else if (h >= 450._dk .and. h < 500._dk) then
        h0      = 450._dk
        scale_H = 60.828_dk
        rho0    = 1.585E-12_dk
    else if (h >= 500._dk .and. h < 600._dk) then
        h0      = 500._dk
        scale_H = 63.822_dk
        rho0    = 6.967E-13_dk
    else if (h >= 600._dk .and. h < 700._dk) then
        h0      = 600._dk
        scale_H = 71.835_dk
        rho0    = 1.454E-13_dk
    else if (h >= 700._dk .and. h < 800._dk) then
        h0      = 700._dk
        scale_H = 88.667_dk
        rho0    = 3.614E-14_dk
    else if (h >= 800._dk .and. h < 900._dk) then
        h0      = 800._dk
        scale_H = 124.64_dk
        rho0    = 1.170E-14_dk
    else if (h >= 900._dk .and. h < 1000._dk) then
        h0      = 900._dk
        scale_H = 181.05_dk
        rho0    = 5.245E-15_dk
    else if (h > 1000.) then                            ! > 1000 KM
        h0      = 1000._dk
        scale_H = 268._dk
        rho0    = 3.019E-15_dk
    end if

    ATMOS_VALLADO = rho0*exp(-(h-h0)/scale_H)

    end function ATMOS_VALLADO

end module DRAG_EXPONENTIAL


! T. Dennnen
! returns the squared amplitude for qQaaaag
      double precision function real_aaaaj(j1,j2,j3,j4,j5,j6,j7,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6,j7
      integer h5,h6
      double complex real_aaajj1(2,2,2,2,2,2), real_aaajj2(2,2,2,2,2,2)
      double complex real_aaaaj_hel(2,2,2,2,2,2)
      integer h1,h2,h3,h4

      call real_aaajj_fill(j1,j2,j3,j4,j5,j6,j7,za,zb,real_aaajj1)
      call real_aaajj_fill(j1,j2,j3,j4,j5,j7,j6,za,zb,real_aaajj2)

      do h5=1,2
      do h6=1,2
      real_aaaaj_hel(:,:,:,:,h5,h6) = real_aaajj1(:,:,:,:,h5,h6)
     & +real_aaajj2(:,:,:,:,h6,h5)
      enddo
      enddo

      real_aaaaj=zip

      do h1=1,2
         do h2=1,2
            do h3=1,2
               do h4=1,2
                  do h5=1,2
                     do h6=1,2
                        real_aaaaj=real_aaaaj
     &                    +cdabs(real_aaaaj_hel(h1,h2,h3,h4,h5,h6))**2
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo

      return
      end


!==========================================================================
elemental function gsw_alpha_on_beta (sa, ct, p)
!==========================================================================
!
!  Calculates alpha divided by beta, where alpha is the thermal expansion
!  coefficient and beta is the saline contraction coefficient of seawater
!  from Absolute Salinity and Conservative Temperature.  This function uses
!  the computationally-efficient expression for specific volume in terms of
!  SA, CT and p (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  alpha_on_beta  =  thermal expansion coefficient with respect to
!                    Conservative Temperature divided by the saline
!                    contraction coefficient at constant Conservative
!                    Temperature                           [ kg g^-1 K^-1 ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_alpha_on_beta

real (r8) :: xs, ys, z, v_ct_part, v_sa_part

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) &
         + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) &
         + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 &
         + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) &
         + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) &
         + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 &
         + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) &
         + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 &
         + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) &
         + z*(a003 + a103*xs + a013*ys + a004*z)))

v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) &
       + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) &
       + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 &
       + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) &
       + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) &
       + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 &
       + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) &
       + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 &
       + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) &
       + z*(b003 +  b103*xs + b013*ys + b004*z)))

gsw_alpha_on_beta = -(v_ct_part*xs)/(20.0_r8*gsw_sfac*v_sa_part)

return
end function

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


*> \brief \b CTGSEN
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CTGSEN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
*                          ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
*                          WORK, LWORK, IWORK, LIWORK, INFO )
*
*       .. Scalar Arguments ..
*       LOGICAL            WANTQ, WANTZ
*       INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
*      $                   M, N
*       REAL               PL, PR
*       ..
*       .. Array Arguments ..
*       LOGICAL            SELECT( * )
*       INTEGER            IWORK( * )
*       REAL               DIF( * )
*       COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
*      $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CTGSEN reorders the generalized Schur decomposition of a complex
*> matrix pair (A, B) (in terms of an unitary equivalence trans-
*> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues
*> appears in the leading diagonal blocks of the pair (A,B). The leading
*> columns of Q and Z form unitary bases of the corresponding left and
*> right eigenspaces (deflating subspaces). (A, B) must be in
*> generalized Schur canonical form, that is, A and B are both upper
*> triangular.
*>
*> CTGSEN also computes the generalized eigenvalues
*>
*>          w(j)= ALPHA(j) / BETA(j)
*>
*> of the reordered matrix pair (A, B).
*>
*> Optionally, the routine computes estimates of reciprocal condition
*> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
*> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
*> between the matrix pairs (A11, B11) and (A22,B22) that correspond to
*> the selected cluster and the eigenvalues outside the cluster, resp.,
*> and norms of "projections" onto left and right eigenspaces w.r.t.
*> the selected cluster in the (1,1)-block.
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] IJOB
*> \verbatim
*>          IJOB is INTEGER
*>          Specifies whether condition numbers are required for the
*>          cluster of eigenvalues (PL and PR) or the deflating subspaces
*>          (Difu and Difl):
*>           =0: Only reorder w.r.t. SELECT. No extras.
*>           =1: Reciprocal of norms of "projections" onto left and right
*>               eigenspaces w.r.t. the selected cluster (PL and PR).
*>           =2: Upper bounds on Difu and Difl. F-norm-based estimate
*>               (DIF(1:2)).
*>           =3: Estimate of Difu and Difl. 1-norm-based estimate
*>               (DIF(1:2)).
*>               About 5 times as expensive as IJOB = 2.
*>           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
*>               version to get it all.
*>           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
*> \endverbatim
*>
*> \param[in] WANTQ
*> \verbatim
*>          WANTQ is LOGICAL
*>          .TRUE. : update the left transformation matrix Q;
*>          .FALSE.: do not update Q.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*>          WANTZ is LOGICAL
*>          .TRUE. : update the right transformation matrix Z;
*>          .FALSE.: do not update Z.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*>          SELECT is LOGICAL array, dimension (N)
*>          SELECT specifies the eigenvalues in the selected cluster. To
*>          select an eigenvalue w(j), SELECT(j) must be set to
*>          .TRUE..
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension(LDA,N)
*>          On entry, the upper triangular matrix A, in generalized
*>          Schur canonical form.
*>          On exit, A is overwritten by the reordered matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension(LDB,N)
*>          On entry, the upper triangular matrix B, in generalized
*>          Schur canonical form.
*>          On exit, B is overwritten by the reordered matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*>          ALPHA is COMPLEX array, dimension (N)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          BETA is COMPLEX array, dimension (N)
*>
*>          The diagonal elements of A and B, respectively,
*>          when the pair (A,B) has been reduced to generalized Schur
*>          form.  ALPHA(i)/BETA(i) i=1,...,N are the generalized
*>          eigenvalues.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*>          Q is COMPLEX array, dimension (LDQ,N)
*>          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
*>          On exit, Q has been postmultiplied by the left unitary
*>          transformation matrix which reorder (A, B); The leading M
*>          columns of Q form orthonormal bases for the specified pair of
*>          left eigenspaces (deflating subspaces).
*>          If WANTQ = .FALSE., Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of the array Q. LDQ >= 1.
*>          If WANTQ = .TRUE., LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*>          Z is COMPLEX array, dimension (LDZ,N)
*>          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
*>          On exit, Z has been postmultiplied by the left unitary
*>          transformation matrix which reorder (A, B); The leading M
*>          columns of Z form orthonormal bases for the specified pair of
*>          left eigenspaces (deflating subspaces).
*>          If WANTZ = .FALSE., Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of the array Z. LDZ >= 1.
*>          If WANTZ = .TRUE., LDZ >= N.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The dimension of the specified pair of left and right
*>          eigenspaces, (deflating subspaces) 0 <= M <= N.
*> \endverbatim
*>
*> \param[out] PL
*> \verbatim
*>          PL is REAL
*> \endverbatim
*>
*> \param[out] PR
*> \verbatim
*>          PR is REAL
*>
*>          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
*>          reciprocal  of the norm of "projections" onto left and right
*>          eigenspace with respect to the selected cluster.
*>          0 < PL, PR <= 1.
*>          If M = 0 or M = N, PL = PR  = 1.
*>          If IJOB = 0, 2 or 3 PL, PR are not referenced.
*> \endverbatim
*>
*> \param[out] DIF
*> \verbatim
*>          DIF is REAL array, dimension (2).
*>          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
*>          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
*>          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
*>          estimates of Difu and Difl, computed using reversed
*>          communication with CLACN2.
*>          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
*>          If IJOB = 0 or 1, DIF is not referenced.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK. LWORK >=  1
*>          If IJOB = 1, 2 or 4, LWORK >=  2*M*(N-M)
*>          If IJOB = 3 or 5, LWORK >=  4*M*(N-M)
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
*>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*>          LIWORK is INTEGER
*>          The dimension of the array IWORK. LIWORK >= 1.
*>          If IJOB = 1, 2 or 4, LIWORK >=  N+2;
*>          If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
*>
*>          If LIWORK = -1, then a workspace query is assumed; the
*>          routine only calculates the optimal size of the IWORK array,
*>          returns this value as the first entry of the IWORK array, and
*>          no error message related to LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>            =0: Successful exit.
*>            <0: If INFO = -i, the i-th argument had an illegal value.
*>            =1: Reordering of (A, B) failed because the transformed
*>                matrix pair (A, B) would be too far from generalized
*>                Schur form; the problem is very ill-conditioned.
*>                (A, B) may have been partially reordered.
*>                If requested, 0 is returned in DIF(*), PL and PR.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  CTGSEN first collects the selected eigenvalues by computing unitary
*>  U and W that move them to the top left corner of (A, B). In other
*>  words, the selected eigenvalues are the eigenvalues of (A11, B11) in
*>
*>              U**H*(A, B)*W = (A11 A12) (B11 B12) n1
*>                              ( 0  A22),( 0  B22) n2
*>                                n1  n2    n1  n2
*>
*>  where N = n1+n2 and U**H means the conjugate transpose of U. The first
*>  n1 columns of U and W span the specified pair of left and right
*>  eigenspaces (deflating subspaces) of (A, B).
*>
*>  If (A, B) has been obtained from the generalized real Schur
*>  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
*>  reordered generalized Schur form of (C, D) is given by
*>
*>           (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
*>
*>  and the first n1 columns of Q*U and Z*W span the corresponding
*>  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
*>
*>  Note that if the selected eigenvalue is sufficiently ill-conditioned,
*>  then its value may differ significantly from its value before
*>  reordering.
*>
*>  The reciprocal condition numbers of the left and right eigenspaces
*>  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
*>  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
*>
*>  The Difu and Difl are defined as:
*>
*>       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
*>  and
*>       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
*>
*>  where sigma-min(Zu) is the smallest singular value of the
*>  (2*n1*n2)-by-(2*n1*n2) matrix
*>
*>       Zu = [ kron(In2, A11)  -kron(A22**H, In1) ]
*>            [ kron(In2, B11)  -kron(B22**H, In1) ].
*>
*>  Here, Inx is the identity matrix of size nx and A22**H is the
*>  conjuguate transpose of A22. kron(X, Y) is the Kronecker product between
*>  the matrices X and Y.
*>
*>  When DIF(2) is small, small changes in (A, B) can cause large changes
*>  in the deflating subspace. An approximate (asymptotic) bound on the
*>  maximum angular error in the computed deflating subspaces is
*>
*>       EPS * norm((A, B)) / DIF(2),
*>
*>  where EPS is the machine precision.
*>
*>  The reciprocal norm of the projectors on the left and right
*>  eigenspaces associated with (A11, B11) may be returned in PL and PR.
*>  They are computed as follows. First we compute L and R so that
*>  P*(A, B)*Q is block diagonal, where
*>
*>       P = ( I -L ) n1           Q = ( I R ) n1
*>           ( 0  I ) n2    and        ( 0 I ) n2
*>             n1 n2                    n1 n2
*>
*>  and (L, R) is the solution to the generalized Sylvester equation
*>
*>       A11*R - L*A22 = -A12
*>       B11*R - L*B22 = -B12
*>
*>  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
*>  An approximate (asymptotic) bound on the average absolute error of
*>  the selected eigenvalues is
*>
*>       EPS * norm((A, B)) / PL.
*>
*>  There are also global error bounds which valid for perturbations up
*>  to a certain restriction:  A lower bound (x) on the smallest
*>  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
*>  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
*>  (i.e. (A + E, B + F), is
*>
*>   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
*>
*>  An approximate bound on x can be computed from DIF(1:2), PL and PR.
*>
*>  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
*>  (L', R') and unperturbed (L, R) left and right deflating subspaces
*>  associated with the selected cluster in the (1,1)-blocks can be
*>  bounded as
*>
*>   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
*>   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
*>
*>  See LAPACK User's Guide section 4.11 or the following references
*>  for more information.
*>
*>  Note that if the default method for computing the Frobenius-norm-
*>  based estimate DIF is not wanted (see CLATDF), then the parameter
*>  IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF
*>  (IJOB = 2 will be used)). See CTGSYL for more details.
*> \endverbatim
*
*> \par Contributors:
*  ==================
*>
*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*>     Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
*  ================
*>
*>  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
*>      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
*>      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
*>      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*> \n
*>  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
*>      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
*>      Estimation: Theory, Algorithms and Software, Report
*>      UMINF - 94.04, Department of Computing Science, Umea University,
*>      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
*>      To appear in Numerical Algorithms, 1996.
*> \n
*>  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
*>      for Solving the Generalized Sylvester Equation and Estimating the
*>      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
*>      Department of Computing Science, Umea University, S-901 87 Umea,
*>      Sweden, December 1993, Revised April 1994, Also as LAPACK working
*>      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
*>      1996.
*>
*  =====================================================================
      SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
     $                   ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
     $                   WORK, LWORK, IWORK, LIWORK, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      LOGICAL            WANTQ, WANTZ
      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
     $                   M, N
      REAL               PL, PR
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      REAL               DIF( * )
      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
     $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            IDIFJB
      PARAMETER          ( IDIFJB = 3 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP
      INTEGER            I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2,
     $                   N1, N2
      REAL               DSCALE, DSUM, RDSCAL, SAFMIN
      COMPLEX            TEMP1, TEMP2
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
*     ..
*     .. External Subroutines ..
      REAL               SLAMCH
      EXTERNAL           CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC, CTGSYL,
     $                   SLAMCH, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, CMPLX, CONJG, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
      IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -15
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTGSEN', -INFO )
         RETURN
      END IF
*
      IERR = 0
*
      WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
      WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
      WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
      WANTD = WANTD1 .OR. WANTD2
*
*     Set M to the dimension of the specified pair of deflating
*     subspaces.
*
      M = 0
      IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN
      DO 10 K = 1, N
         ALPHA( K ) = A( K, K )
         BETA( K ) = B( K, K )
         IF( K.LT.N ) THEN
            IF( SELECT( K ) )
     $         M = M + 1
         ELSE
            IF( SELECT( N ) )
     $         M = M + 1
         END IF
   10 CONTINUE
      END IF
*
      IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
         LWMIN = MAX( 1, 2*M*(N-M) )
         LIWMIN = MAX( 1, N+2 )
      ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
         LWMIN = MAX( 1, 4*M*(N-M) )
         LIWMIN = MAX( 1, 2*M*(N-M), N+2 )
      ELSE
         LWMIN = 1
         LIWMIN = 1
      END IF
*
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
*
      IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -21
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -23
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTGSEN', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( M.EQ.N .OR. M.EQ.0 ) THEN
         IF( WANTP ) THEN
            PL = ONE
            PR = ONE
         END IF
         IF( WANTD ) THEN
            DSCALE = ZERO
            DSUM = ONE
            DO 20 I = 1, N
               CALL CLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
               CALL CLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
   20       CONTINUE
            DIF( 1 ) = DSCALE*SQRT( DSUM )
            DIF( 2 ) = DIF( 1 )
         END IF
         GO TO 70
      END IF
*
*     Get machine constant
*
      SAFMIN = SLAMCH( 'S' )
*
*     Collect the selected blocks at the top-left corner of (A, B).
*
      KS = 0
      DO 30 K = 1, N
         SWAP = SELECT( K )
         IF( SWAP ) THEN
            KS = KS + 1
*
*           Swap the K-th block to position KS. Compute unitary Q
*           and Z that will swap adjacent diagonal blocks in (A, B).
*
            IF( K.NE.KS )
     $         CALL CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
     $                      LDZ, K, KS, IERR )
*
            IF( IERR.GT.0 ) THEN
*
*              Swap is rejected: exit.
*
               INFO = 1
               IF( WANTP ) THEN
                  PL = ZERO
                  PR = ZERO
               END IF
               IF( WANTD ) THEN
                  DIF( 1 ) = ZERO
                  DIF( 2 ) = ZERO
               END IF
               GO TO 70
            END IF
         END IF
   30 CONTINUE
      IF( WANTP ) THEN
*
*        Solve generalized Sylvester equation for R and L:
*                   A11 * R - L * A22 = A12
*                   B11 * R - L * B22 = B12
*
         N1 = M
         N2 = N - M
         I = N1 + 1
         CALL CLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
         CALL CLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
     $                N1 )
         IJB = 0
         CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
     $                N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
     $                DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
     $                LWORK-2*N1*N2, IWORK, IERR )
*
*        Estimate the reciprocal of norms of "projections" onto
*        left and right eigenspaces
*
         RDSCAL = ZERO
         DSUM = ONE
         CALL CLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
         PL = RDSCAL*SQRT( DSUM )
         IF( PL.EQ.ZERO ) THEN
            PL = ONE
         ELSE
            PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
         END IF
         RDSCAL = ZERO
         DSUM = ONE
         CALL CLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
         PR = RDSCAL*SQRT( DSUM )
         IF( PR.EQ.ZERO ) THEN
            PR = ONE
         ELSE
            PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
         END IF
      END IF
      IF( WANTD ) THEN
*
*        Compute estimates Difu and Difl.
*
         IF( WANTD1 ) THEN
            N1 = M
            N2 = N - M
            I = N1 + 1
            IJB = IDIFJB
*
*           Frobenius norm-based Difu estimate.
*
            CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
     $                   N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
     $                   N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
     $                   LWORK-2*N1*N2, IWORK, IERR )
*
*           Frobenius norm-based Difl estimate.
*
            CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
     $                   N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
     $                   N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ),
     $                   LWORK-2*N1*N2, IWORK, IERR )
         ELSE
*
*           Compute 1-norm-based estimates of Difu and Difl using
*           reversed communication with CLACN2. In each step a
*           generalized Sylvester equation or a transposed variant
*           is solved.
*
            KASE = 0
            N1 = M
            N2 = N - M
            I = N1 + 1
            IJB = 0
            MN2 = 2*N1*N2
*
*           1-norm-based estimate of Difu.
*
   40       CONTINUE
            CALL CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE,
     $                   ISAVE )
            IF( KASE.NE.0 ) THEN
               IF( KASE.EQ.1 ) THEN
*
*                 Solve generalized Sylvester equation
*
                  CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
     $                         WORK, N1, B, LDB, B( I, I ), LDB,
     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
     $                         IERR )
               ELSE
*
*                 Solve the transposed variant.
*
                  CALL CTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA,
     $                         WORK, N1, B, LDB, B( I, I ), LDB,
     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
     $                         IERR )
               END IF
               GO TO 40
            END IF
            DIF( 1 ) = DSCALE / DIF( 1 )
*
*           1-norm-based estimate of Difl.
*
   50       CONTINUE
            CALL CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE,
     $                   ISAVE )
            IF( KASE.NE.0 ) THEN
               IF( KASE.EQ.1 ) THEN
*
*                 Solve generalized Sylvester equation
*
                  CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
     $                         WORK, N2, B( I, I ), LDB, B, LDB,
     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
     $                         IERR )
               ELSE
*
*                 Solve the transposed variant.
*
                  CALL CTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA,
     $                         WORK, N2, B, LDB, B( I, I ), LDB,
     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
     $                         IERR )
               END IF
               GO TO 50
            END IF
            DIF( 2 ) = DSCALE / DIF( 2 )
         END IF
      END IF
*
*     If B(K,K) is complex, make it real and positive (normalization
*     of the generalized Schur form) and Store the generalized
*     eigenvalues of reordered pair (A, B)
*
      DO 60 K = 1, N
         DSCALE = ABS( B( K, K ) )
         IF( DSCALE.GT.SAFMIN ) THEN
            TEMP1 = CONJG( B( K, K ) / DSCALE )
            TEMP2 = B( K, K ) / DSCALE
            B( K, K ) = DSCALE
            CALL CSCAL( N-K, TEMP1, B( K, K+1 ), LDB )
            CALL CSCAL( N-K+1, TEMP1, A( K, K ), LDA )
            IF( WANTQ )
     $         CALL CSCAL( N, TEMP2, Q( 1, K ), 1 )
         ELSE
            B( K, K ) = CMPLX( ZERO, ZERO )
         END IF
*
         ALPHA( K ) = A( K, K )
         BETA( K ) = B( K, K )
*
   60 CONTINUE
*
   70 CONTINUE
*
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
*
      RETURN
*
*     End of CTGSEN
*
      END


      PROGRAM TRIPLE_NESTED
      IMPLICIT NONE

      INTEGER MONTH, DATE, DAY

      MONTH = 1

      DO WHILE (MONTH <= 12)
        DATE = 1
        DO WHILE (DATE <= 7)
          DAY = 1
          DO WHILE (DAY <= DATE)
            IF (DAY == 1) THEN
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", SUNDAY"
            ELSE IF (DAY == 2) THEN
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", MONDAY"
            ELSE IF (DAY == 3) THEN
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", TUESDAY"
            ELSE IF (DAY == 4) THEN
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", WEDNESDAY"
            ELSE IF (DAY == 5) THEN
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", THURSDAY"
            ELSE IF (DAY == 6) THEN
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", FRIDAY"
            ELSE
              PRINt *, "MONTH: ", MONTH, " DAY: ", DAY, ", SATURDAY"
            END IF
            DAY = DAY + 1
          END DO
          DATE = DATE +1
        END DO
        MONTH = MONTH + 1
      END DO
      END PROGRAM TRIPLE_NESTED


      subroutine knots ( break, l, kpm, t, n )
c  from  * a practical guide to splines *  by c. de boor
c  to be called in  c o l l o c .
c  constructs from the given breakpoint sequence  b r e a k  the knot
c  sequence  t	so that
c  spline(k+m,t) = pp(k+m,break) with  m-1  continuous derivatives .
c  this means that
c  t(1),...,t(n+kpm)  =  break(1) kpm times, then break(2),...,
c	 break(l) each	k  times, then, finally, break(l+1) kpm times.
c
c******  i n p u t  ******
c  break(1),...,break(l+1)  breakpoint sequence
c  l  number of intervals or pieces
c  kpm	 = k + m, order of the pp function or spline
c
c******  o u t p u t  ******
c  t(1),...,t(n+kpm)  the knot sequence.
c  n	 = l*k + m  =  dimension of  spline(k+m,t).
c
      integer l,kpm,n,	 iside,j,jj,jjj,k,ll,m
      real break(1),t(1),   xside
      common /side/ m,iside,xside(10)
      k = kpm - m
      n = l*k + m
      jj = n + kpm
      jjj = l + 1
      do 11 ll=1,kpm
	 t(jj) = break(jjj)
   11	 jj = jj - 1
      do 12 j=1,l
      jjj = jjj - 1
	 do 12 ll=1,k
	    t(jj) = break(jjj)
   12	    jj = jj - 1
      do 13 ll=1,kpm
   13	 t(ll) = break(1)
					return
      end


!INTEGER N, niters
!REAL check
!N = 128
!niters = 128*3
!CALL echo_f90(N, niters, check)
!PRINT *, check
!END

SUBROUTINE echo_f90(N, niters, check)
  INTEGER, INTENT( IN ) :: N, niters
  REAL, INTENT( OUT ) :: check

  REAL, DIMENSION (N,N) :: P1, P2, P3, c
  INTEGER iter

  CALL echo_f90_setupInitialConditions(c, P1, P2, P3, N)
  CALL checkArray_f90(P2, N)
  CALL checkArray_f90(c, N)

  DO iter=1, niters
    P3(2:N-1,2:N-1) = (2-4*c(2:N-1,2:N-1)) * P2(2:N-1,2:N-1) &
        + c(2:N-1,2:N-1)*(P2(1:N-2,2:N-1) + P2(3:N,2:N-1)    &
        + P2(2:N-1,1:N-2) + P2(2:N-1,3:N)) - P1(2:N-1,2:N-1)
    P1 = P2
    P2 = P3
  END DO

  check = P1(N/2,7*N/8)

  RETURN
END

SUBROUTINE echo_f90_setupInitialConditions(c, P1, P2, P3, N)
  INTEGER, INTENT( IN ) :: N
  REAL, DIMENSION (N,N) :: P1(N,N), P2(N,N), P3(N,N), c(N,N)

  INTEGER blockLeft, blockRight, blockTop, blockBottom
  INTEGER channelLeft, channelRight, channel1Height, channel2Height
  REAL cr, cc
  INTEGER i, j
  REAL s2

  ! Set the velocity field
  c = 0.2

  ! Solid block with which the pulse collides
  blockLeft = 1
  blockRight = 2 * N / 5.0
  blockTop = N / 3.0
  blockBottom = 2 * N / 3.0
  c(blockTop:blockBottom, blockLeft:blockRight) = 0.5

  ! Channel directing the pulse leftwards
  channelLeft = 4 * N / 5.0
  channelRight = N
  channel1Height = 3 * N / 8.0
  channel2Height = 5 * N / 8.0

  c(channel1Height,channelLeft:channelRight) = 0.0;
  c(channel2Height,channelLeft:channelRight) = 0.0;

  ! Initial pressure distribution: a gaussian pulse inside the channel
  cr = N / 2.0
  cc = 7.0 * N / 8.0
  s2 = 64.0 * 9.0 / ((N / 2.0) ** 2)

  DO j=1,N
    DO i=1,N
      P2(i,j) = exp(-((i-cr)**2 + (j-cc)**2) * s2)
    END DO
  END DO

  P1 = 0.0
  P3 = 0.0
END

      SUBROUTINE checkArray_f90(A, N)
      INTEGER N
      REAL, DIMENSION(N,N) :: A

      INTEGER i,j
      REAL check
      check = 0.0
      DO j=1,N
        DO i=1,N
          check = check + (i*n+j)*A(i,j)
        END DO
      END DO

      PRINT *, 'Array check: ', check
      RETURN
      END


MODULE physvars
!
! physical parameters
!
      REAL,    PARAMETER :: BE    = 13.6056923      ! [eV] binding energy H
      REAL,    PARAMETER :: BEKEV = BE*1.E-3        ! [keV]
      REAL,    PARAMETER :: CC    = 2.9979E10       ! [cm/s] speed of light
      REAL,    PARAMETER :: CC2   = CC*CC           ! [cm^2/s^2] CC squared
      REAL,    PARAMETER :: CC3   = CC*CC*CC        ! [cm^2/s^2] CC squared

      REAL,    PARAMETER :: AMUKEV= 0.931494012E6   ! [keV] 1 AMU
      REAL,    PARAMETER :: AMUG  =1.660538783E-24  ! [g] AMU
      REAL,    PARAMETER :: MEKEV = 510.998902      ! [keV] electron mass
      REAL,    PARAMETER :: MPKEV = 0.938271998E6   ! [keV] proton mass
      REAL,    PARAMETER :: MDKEV =2.0141018*AMUKEV ! [keV] deuterium mas
      REAL,    PARAMETER :: MTKEV =3.0160492*AMUKEV ! [keV] triton masss
      REAL,    PARAMETER :: MPG   =1.0072765*AMUG   ! [g] deuterium mass
      REAL,    PARAMETER :: MDG   =2.0141018*AMUG   ! [g] deuterium mass
      REAL,    PARAMETER :: MTG   =3.0160492*AMUG   ! [g] triton mass

      REAL,    PARAMETER :: HBARC = 197.33E-10      ! [keV-cm ] hbar*c 197.5863737 eV nm ??
      REAL,    PARAMETER :: HBAR  = 6.5821E-19      ! [keV-s] hbar
      REAL,    PARAMETER :: HBARC2= HBARC*HBARC     ! [keV^2-cm^2]
      REAL,    PARAMETER :: A0CM  = 5.29E-9         ! [cm] Bohr radius
      REAL,    PARAMETER :: ALPHA = 1./137.035999679! 1/137.036
!
!     k_b = DEBYE*SQRT(zb*zb*nb*betab)           ! [1/cm]
      REAL,    PARAMETER :: DEBYE =4.2539E-5     ! Debye wave number
      REAL,    PARAMETER :: DEBYE2=DEBYE*DEBYE
!
!     om_b=(1.32155E+3)*SQRT(zb*zb*nb*AMUKEV/mb) ! [1/s]
      REAL,    PARAMETER :: OMEGI =1.32155E+3    ! plasma frequency
      REAL,    PARAMETER :: OMEGI2=OMEGI*OMEGI
!
!     ge=(6.1260E-15)*SQRT(ne)*betae**1.5        ! dimensionless
      REAL,    PARAMETER :: GECOEFF=6.1260E-15   ! plasma coupling

!     LOGICAL, PARAMETER :: SMALL_E_NLO=.TRUE.   ! T= LO + NLO
    LOGICAL, PARAMETER :: SMALL_E_NLO=.FALSE.    ! F= LO only

!
! conversion factors
!
!      REAL,    PARAMETER :: KTOEV =8.61772E-5    ! K -> eV : [eV/K]
!      REAL,    PARAMETER :: CMTOA0=1.8867925E8   ! cm -> a0: [a0/cm]
!      REAL,    PARAMETER :: A0TOCM=1/CMTOA0      ! a0 -> cm: [cm/a0]
!      REAL,    PARAMETER :: CONVFACT=1.E-7/A0CM  ! keV/a0 -> keV/micron
!      REAL,    PARAMETER :: CONVFACT=CMTOA0*1.E-7! keV/a0 -> keV/micron
END MODULE physvars


      subroutine compute_rrtheta(ctfm,ctfmp,n_A,n_B,n_Lamx,n_phi,octfmp,
     &x,Nx,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_B(Nx)
      real*8 n_Lamx(Nx)
      real*8 n_phi(Nx)
      real*8 octfmp(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = n_Lamx(i) * n_B(i) / ctfm(i) + (n_B(i) / n_A(i) - 0.1D1) / ct
     #fm(i) ** 2 + ((0.2500000000000000D0 * (-0.1D1 * n_B(i - 1) + n_B(i
     # + 1)) * n_Lamx(i) + 0.2500000000000000D0 * (-0.1D1 * n_B(i - 1) +
     # n_B(i + 1)) / n_A(i) * octfmp(i) - 0.1D1 / n_A(i) * (n_phi(i - 1)
     # - 0.1D1 * n_phi(i + 1)) * octfmp(i) * n_B(i)) / ctfmp(i) + (-0.50
     #00000000000000D0 / n_B(i) * (-0.1D1 * n_B(i - 1) + n_B(i + 1)) + 0
     #.3D1 / n_A(i) * n_B(i) * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1))) /
     #ctfmp(i) / ctfm(i)) / hx + (-0.2500000000000000D0 / n_A(i) ** 2 *
     #(-0.1D1 * n_A(i - 1) + n_A(i + 1)) * n_B(i) * (n_phi(i - 1) - 0.1D
     #1 * n_phi(i + 1)) + 0.1250000000000000D0 / n_B(i) / n_A(i) * (-0.1
     #D1 * n_B(i - 1) + n_B(i + 1)) ** 2 + 0.7500000000000000D0 / n_A(i)
     # * (-0.1D1 * n_B(i - 1) + n_B(i + 1)) * (n_phi(i - 1) - 0.1D1 * n_
     #phi(i + 1)) - 0.1D1 / n_A(i) * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1
     #)) ** 2 * n_B(i) + 0.2D1 / n_A(i) * (-0.1D1 * n_phi(i - 1) + 0.2D1
     # * n_phi(i) - 0.1D1 * n_phi(i + 1)) * n_B(i) + 0.5000000000000000D
     #0 / n_A(i) * (-0.1D1 * n_B(i - 1) + 0.2D1 * n_B(i) - 0.1D1 * n_B(i
     # + 1))) / ctfmp(i) ** 2 / hx ** 2
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END