! =============================================================================
!                       Robert ("Rising bubble") test case
!
!   This module sets up to ten bubbles with a flat-top ("plateau") beyond
!   which the buoyancy follows a Gaussian profile.
! =============================================================================

module robert_3d
    use constants
    use netcdf_writer
    use physics, only : write_physical_quantities, &
                        gravity, theta_0
    implicit none

    private

    double precision, allocatable :: buoyg(:, :, :)

    integer :: buo_id

    type bubble_type
        double precision :: center(3)       ![m] bubble center (x, z)
        double precision :: dtheta_max      ![K] max. pot. temp. perturbation
        double precision :: radius          ![m] plateau radius
        double precision :: width           ![m] standard deviation of Gaussian
    end type bubble_type

    type flow_type
        integer           :: n_bubbles   = 1
        type(bubble_type) :: bubbles(10)
    end type flow_type

    type(flow_type) :: robert_flow

    public :: robert_init, &
              robert_flow

    contains

        subroutine robert_init(ncid, dimids, nx, ny, nz, origin, dx)
            integer,          intent(inout) :: ncid
            integer,          intent(in)    :: dimids(:)
            integer,          intent(in)    :: nx, ny, nz
            double precision, intent(in)    :: origin(3)
            double precision, intent(in)    :: dx(3)
            integer                         :: k
            type(bubble_type)               :: bubble

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='buoyancy',                     &
                                       long_name='buoyancy',                &
                                       std_name='',                         &
                                       unit='m/s^2',                        &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=buo_id)

            call close_definition(ncid)

            if (robert_flow%n_bubbles > size(robert_flow%bubbles)) then
                print *, 'Number of bubbles beyond upper limit.'
                stop
            endif

            allocate(buoyg(0:nz, 0:ny-1, 0:nx-1))

            buoyg = zero

            do k = 1, robert_flow%n_bubbles
                bubble = robert_flow%bubbles(k)

                call robert_gaussian_init(nx, ny, nz, origin, dx, bubble)
            enddo

            call write_netcdf_dataset(ncid, buo_id, buoyg)

            call write_physical_quantities(ncid)

            deallocate(buoyg)

        end subroutine robert_init

        subroutine robert_gaussian_init(nx, ny, nz, origin, dx, bubble)
            integer,           intent(in) :: nx, ny, nz
            double precision,  intent(in) :: origin(3), dx(3)
            type(bubble_type), intent(in) :: bubble
            integer                       :: i, j, k
            double precision              :: xc, yc, zc, r, r_in, dtheta
            double precision              :: dtheta_max, pos(3), s, fs2

            ! in metres
            xc = bubble%center(1)
            yc = bubble%center(2)
            zc = bubble%center(3)
            r_in = bubble%radius
            s = bubble%width
            fs2 = (one / s) ** 2

            ! max. potential temperature perturbation
            dtheta_max = bubble%dtheta_max

            do i = 0, nx-1
                do j = 0, ny-1
                    do k = 0, nz
                        pos = origin + dx * dble((/i, j, k/))

                        r = (pos(1) - xc) ** 2 &
                          + (pos(2) - yc) ** 2 &
                          + (pos(3) - zc) ** 2

                        r = dsqrt(r)

                        ! potential temperature perturbation
                        dtheta = zero

                        if (r <= r_in) then
                            dtheta = dtheta_max
                        else
                            dtheta = dtheta_max * dexp(-(r - r_in) ** 2 * fs2)
                        endif

                        ! MPIC paper:
                        ! liquid-water buoyancy is defined by b = g * (theta − theta_0) / theta_0
                        ! (dtheta = theta - theta_0)
                        buoyg(k, j, i) = buoyg(k, j, i) &
                                       + gravity * dtheta / theta_0
                    enddo
                enddo
            enddo
        end subroutine robert_gaussian_init
end module robert_3d


c
c -------------------------------------------------------------
c
      subroutine stepgrid(q,fm,fp,mitot,mbc,dt,dtnew,dx,
     &                  nvar,xlow,time,mptr,maux,aux)
c
c
c ::::::::::::::::::: STEPGRID ::::::::::::::::::::::::::::::::::::
c take a time step on a single grid. overwrite solution array q.
c A modified version of the clawpack routine step is used.
c
c return fluxes in fm and fp.
c patch has room for ghost cells (mbc of them) around the grid.
c everything is the enlarged size (mitot by mjtot).
c
c mbc       = number of ghost cells  (= lwidth)
c mptr      = grid number  (for debugging)
c xlow      =  left corner of enlarged grid (including ghost cells).
c dt        = incoming time step
c dx        = mesh width for this grid
c dtnew     = return suggested new time step for this grid's soln.
c
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      use amr_module
      implicit double precision (a-h,o-z)
      external rp1

      common /comxyt/ dtcom,dxcom,tcom,icom

      dimension q(nvar,mitot)
      dimension fp(nvar,mitot)
      dimension fm(nvar,mitot)
      dimension aux(maux,mitot)

      logical    debug,  dump
      data       debug/.false./,  dump/.false./

c
c     # set tcom = time.  This is in the common block comxyt that could
c     # be included in the Riemann solver, for example, if t is explicitly
c     # needed there.

      tcom = time

      if (dump) then
         write(outunit,*) "dumping grid ",mptr," at time ",time
         do i = 1, mitot
            write(outunit,545) i,(q(ivar,i),ivar=1,nvar)
c    .                  ,(aux(ivar,i),ivar=1,maux)
 545        format(2i4,5e15.7)
         end do
      endif
c
      meqn   = nvar
      mx = mitot - 2*mbc
      mbig = mx       !# size for 1d scratch array
      xlowmbc = xlow + mbc*dx

c     # method(2:7) and mthlim
c     #    are set in the amr2ez file (read by amr)
c
      method(1) = 0
c
c
      call b4step1(mbc,mx,nvar,q,
     &             xlowmbc,dx,time,dt,maux,aux)
c
c
c     # take one step on the conservation law:
c
      call step1(mbig,nvar,maux,
     &           mbc,mx,
     &              q,aux,dx,dt,cflgrid,
     &              fm,fp,rp1)
c
c
        write(outunit,1001) mptr, node(nestlevel,mptr),cflgrid
 1001   format(' Courant # of grid', i4,
     &        ' on level', i3, ' is  ', e10.3)
c

!$OMP  CRITICAL (cflm)

        cfl_level = dmax1(cfl_level,cflgrid)

!$OMP END CRITICAL (cflm)

c
c       # update q
        dtdx = dt/dx
        do 50 i=mbc+1,mitot-mbc
        do 50 m=1,nvar
         if (mcapa.eq.0) then
c
c            # no capa array.  Standard flux differencing:

           q(m,i) = q(m,i)
     &           - dtdx * (fm(m,i+1) - fp(m,i))
         else
c            # with capa array.
           q(m,i) = q(m,i)
     &          - (dtdx * (fm(m,i+1) - fp(m,i))) / aux(mcapa,i)
         endif

 50      continue
c
c
      if (method(4).eq.1) then
c        # with source term:   use Godunov splitting
         call src1(nvar,mbc,mx,xlowmbc,dx,
     &             q,maux,aux,time,dt)
         endif
c
c
c
c     # output fluxes for debugging purposes:
      if (debug) then
         write(dbugunit,*)" fluxes for grid ",mptr
c        do 830 j = mbc+1, mjtot-1
            do 830 i = mbc+1, mitot-1
               write(dbugunit,831) i,fm(1,i),fp(1,i)
               do 830 m = 2, meqn
                  write(dbugunit,832) fm(m,i),fp(m,i)
  831          format(2i4,4d16.6)
  832          format(8x,4d16.6)
  830    continue
      endif

c
c
c For variable time stepping, use max speed seen on this grid to
c choose the allowable new time step dtnew.  This will later be
c compared to values seen on other grids.
c
       if (cflgrid .gt. 0.d0) then
           dtnew = dt*cfl/cflgrid
         else
c          # velocities are all zero on this grid so there's no
c          # time step restriction coming from this grid.
            dtnew = rinfinity
          endif

c     # give a warning if Courant number too large...
c
      if (cflgrid .gt. cflv1) then
            write(*,810) cflgrid
            write(outunit,810) cflgrid, cflv1
  810       format('*** WARNING *** Courant number  =', d12.4,
     &              '  is larger than input cfl_max = ', d12.4)
            endif
c
      if (dump) then
         write(outunit,*) "dumping grid ",mptr," after stepgrid"
         do i = 1, mitot
            write(outunit,545) i,(q(ivar,i),ivar=1,nvar)
         end do
      endif
      return
      end


program main
  use module_gauss_turan_quadrature
  implicit none

  type(GaussTuranQuadrature) :: gt(maxngt)

  call init_gauss_turan(gt)
  call assemble_gauss_turan
  call uninit_gauss_turan(gt)

end program main


*> \brief \b ZLADIV2 performs complex division in real arithmetic, avoiding unnecessary overflow. Note that this version, created by Jack Poulson, avoids returning a complex value since this frequently causes problems when interfacing different Fortran libraries (e.g., it caused pzlahqr to return many of the eigenvalues shifted left by one due to zladiv returning 1 instead of 0 within zlanv2).
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLADIV2( X, Y, Z )
*
*       .. Scalar Arguments ..
*       COMPLEX*16         X, Y, Z
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZLADIV2 outputs Z = X / Y, where X and Y are complex.
*> The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is COMPLEX*16
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is COMPLEX*16
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*>          Z is COMPLEX*16
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*> \author Jack Poulson
*
*> \date September 2015
*
*> \ingroup complex16OTHERauxiliary
*
*  =====================================================================
      SUBROUTINE ZLADIV2( X, Y, Z )
*
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*  -- Modified by Jack Poulson on September 2015
*
*     .. Scalar Arguments ..
      COMPLEX*16         X, Y, Z
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION   ZI, ZR
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLADIV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, DIMAG
*     ..
*     .. Executable Statements ..
*
      CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
     $             ZI )
      Z = DCMPLX( ZR, ZI )
*
      RETURN
*
*     End of ZLADIV2
*
      END


module data_module

    implicit none
    integer, parameter :: n = 12
    real, dimension(n) :: rainfall
    real, dimension(n) :: sorted

contains
    subroutine readdata
        implicit none
        integer :: i
        character(40) :: filename

        print *, ' What is the filename ?'
        read '(a)', filename
        open(1,file=filename,status='old')
        do i = 1, n
            read(1,*) rainfall(i)
        end do
        close(1)
    end subroutine readdata

    subroutine sortdata
        implicit none
        sorted = rainfall
        call selection

    contains
        subroutine selection
            implicit none
            integer :: i, j, k
            real :: minimum

            do i = 1, n-1
                k = i
                minimum = sorted(k)
                do j = i, n
                    if (sorted(j)<minimum) then
                        k = j
                        minimum = sorted(k)
                    end if
                end do
                sorted(k) = sorted(i)
                sorted(i) = minimum
            end do
        end subroutine selection
    end subroutine sortdata

    subroutine printdata
        implicit none
        integer :: i

        print *, ' original data is '
        do i = 1, n
            print 100, rainfall(i)
        end do
        print *, ' Sorted data is '
        do i = 1, n
            print 100, sorted(i)
        end do

    100 format (1x, f7.1)
    end subroutine printdata
end module

program ch2102
    ! Modules for Globally Sharing Data
    use data_module

    call readdata
    call sortdata
    call printdata
end program


program test_blas
!  use magma
  use omp_lib
  implicit none
  INTEGER,PARAMETER::Ns(3)=(/5000,10000,15000/)
  INTEGER,PARAMETER::M=1000
  COMPLEX,ALLOCATABLE :: A(:,:),B(:,:),z(:,:)
  REAL,ALLOCATABLE    :: R(:,:,:),eig(:)
  COMPLEX,ALLOCATABLE :: WORK(:)
  REAL,ALLOCATABLE    ::rwork(:)
  INTEGER,ALLOCATABLE ::iwork(:),ifail(:)
  INTEGER :: i,j,lwork,lrwork,liwork,ne,info,nn,n

  REAL    :: time1,time2,wtemp(1)

  DO nn=1,size(Ns)
        N=Ns(nn)
  time1=omp_get_wtime()
  ALLOCATE (eig(N),ifail(N))
  Allocate(R(N,N,4),A(N,N),b(N,N),z(N,N))
  CALL random_number(r)
  A=cmplx(R(:,:,1),R(:,:,2))
  call zherk("U","N",N,N,1.0,cmplx(R(:,:,3),R(:,:,4)),N,0.0,B,N)
  DO i=1,N
     DO j=1,i
        A(i,j)=conjg(A(j,i))
        B(i,j)=conjg(B(j,i))
     ENDDO
     A(i,i)=real(A(i,i))
  ENDDO
  time2=omp_get_wtime()
  print *, "Init:",time2-time1

  time1=omp_get_wtime()
  allocate(iwork(5*N),rwork(7*N))
  CALL zhegvx (1, "V", "I", "U", N, A, N, B, N, 0.0, 0.0, 1, M, 1E-8, ne, eig, Z, N, Wtemp, -1, RWORK, IWORK, IFAIL, INFO)
  lwork=wtemp(1)
  print *,"lwork:",lwork
   allocate(work(lwork))
  CALL zhegvx (1, "V", "I", "U", N, A, N, B, N, 0.0, 0.0, 1, M, 1E-8, ne, eig, Z, N, WORK, LWORK, RWORK, IWORK, IFAIL, INFO)
  time2=omp_get_wtime()
  print *, N,"MKL:",time2-time1
  deallocate(work,iwork,rwork,A,B,z,r,eig,ifail)
  enddo

end


!-------Определение координат спутника по бортовым эфемеридам--------
!---------------------исп. переменные:-------------------------------
!-------Бортовые Эфемериды: Toe - эпоха
!-------------------------- WN  - неделя
!-------------------------- ec   - эксцентриситет орбиты
!-------------------------- A0_5 - квадр. корень из большой полуоси
!-------------------------- Omega_0 - долгота восходящего узла
!-------------------------- i_0 - наклон орбиты
!-------------------------- w   - аргумент перигея
!-------------------------- M_0 - средняя аномалия на начало эпохи
!-------------------------- delta_n - отклонение значения среднего движения
!-------------------------- Omega_vel - скорость изменения долготы в. узла
!-------------------------- IDOT - скорость измен. наклона орбиты
!-------------------------- C_uc - амплитуда квадр. поправки арг. широты
!-------------------------- C_us - амплитуда синфазн. поправки арг. широты
!-------------------------- C_rc - амплитуда квадрю поправки радиуса орбиты
!-------------------------- C_rs - амплитуда синфазн. поправки радиуса орбиты
!-------------------------- C_ic - амплитуда квадрю. поправки наклона орбиты
!-------------------------- C_is - амплитуда синфазн. поправки наклона орбиты
!-------Наблюдательные дан: P    - псеводальность до спутника
!-------------------------- t_obs - момент наблюдения
!----Фундаментальные пост.: mu   - геоцентрическая грав. постоянная
!-------------------------- Omega_vel_e - угловая скорость вр. Земли
!-------------------------- c    - скорость света
!-------------------------- a    - большая полуось эллипсоида WGS-84

!-------------Author: Волков Д.В.-------АО мат-меха СПбГУ----------

subroutine coord_sp(Toe,WN,ec,A0_5,Omega_0,i_0,w,M_0,delta_n,Omega_vel,IDOT,C_uc,C_us,C_rc,C_rs,C_ic,C_is,P,t_obs,X,Y,Z)
    implicit none
    !---бортовые эфемериды
	real(8), intent(in) :: Toe, WN, ec, A0_5, Omega_0, i_0, w, M_0, delta_n, Omega_vel, IDOT
	real(8), intent(in) :: C_uc, C_us, C_rc, C_rs, C_ic, C_is
    !---наблюдательные данные
	real(8), intent(in) :: P, t_obs
    !---фундаментальные постоянные
	real(8), parameter :: mu=3.986004418e14, Omega_vel_e=7.2921151467e-5, c=299792458.0, a=6378137.0
    !---вспомогательные переменные
	real(8) :: n_0 !-------среднее движение
	real(8) :: t   !-------время от начала эпохи
	real(8) :: n   !-------исправленное среднее движение
	real(8) :: M   !-------средняя аномалия
	real(8) :: E   !-------эксцентрическая аномалия
	real(8) :: nu  !-------истинная аномалия
	real(8) :: fi  !-------аргумент широты
	real(8) :: delta_u, delta_r, delta_i !--поправки широты, радиуса и наклона
	real(8) :: u, r, i !---испр. широта, радиус и наклон
	real(8) :: X_orb, Y_orb  !----координаты в орбитальной плоскости
	real(8) :: Omega !---испр. долгота восх. узла
	real(8), intent(out) :: X, Y, Z  !---положение в земной системе координат

    n_0 = sqrt(mu/(A0_5)**6)
    write(*,*) "1. n_0 = ", n_0

    t = t_obs - P/c - Toe
    if ( t > 302400 ) then
        t = t - 604800
    else if ( t < -302400 ) then
        t = t + 604800
    endif
    write(*,*) "3. t = ", t

    n = n_0 + delta_n
    write(*,*) "4. n = ", n

    M = M_0 + n*t
    write(*,*) "5. M = ", M

    call E_calc(M, ec, E)
    write(*,*) "6. E = ", E

    call nu_calc(ec, E, nu)
    write(*,*) "7. nu = ", nu

    fi = w + nu
    write(*,*) "8. fi = ", fi

    delta_u = C_us*sin(2*fi) + C_uc*cos(2*fi)
    delta_r = C_rs*sin(2*fi) + C_rc*cos(2*fi)
    delta_i = C_is*sin(2*fi) + C_ic*cos(2*fi)
    write(*,*) "9. delta_u  = ", delta_u
    write(*,*) "9. delta_r  = ", delta_r
    write(*,*) "9. delta_i  = ", delta_i

    u = fi + delta_u
    r = A0_5**2*(1 - ec*cos(E)) + delta_r
    i = i_0 + delta_i + IDOT*t
    write(*,*) "10. u  = ", u
    write(*,*) "10. r  = ", r
    write(*,*) "10. i  = ", i

    X_orb = r*cos(u)
    Y_orb = r*sin(u)
    write(*,*) "11. X_orb  = ", X_orb
    write(*,*) "11. Y_orb  = ", Y_orb

    Omega = Omega_0 + t*(Omega_vel - Omega_vel_e) - Toe*Omega_vel_e
    write(*,*) "12. Omega  = ", Omega

    X = X_orb*cos(Omega) - Y_orb*cos(i)*sin(Omega)
    Y = X_orb*sin(Omega) + Y_orb*cos(i)*cos(Omega)
    Z = Y_orb*sin(i)
    write(*,*) "13. X  = ", X
    write(*,*) "13. Y  = ", Y
    write(*,*) "13. Z  = ", Z

endsubroutine coord_sp

!---процедура решения уравнения Кеплера:

subroutine E_calc(M, ec, E)
    implicit none
	real(8), intent(in) :: M, ec
	real(8), intent(out) :: E
	real(8) :: E_old, E_new, funE

    E_old = 0
    E_new = 1

    do while (abs(funE(M,ec,E_new))>0.0000000000000001)
        E_old = E_new
        E_new = E_old - funE(M,ec,E_old)/(ec*cos(E_old) - 1.d0)
    enddo

    E = E_new
endsubroutine E_calc

function funE(M, ec, E) result(f)
    implicit none
	real(8) :: M, ec, E, f
    f = M - E + ec*sin(E)
endfunction funE

!---процедура нахождения истинной аномалии

subroutine nu_calc(ec, E, nu)
    implicit none
	real(8), intent(in) :: ec, E
	real(8), intent(out) :: nu

    nu = 2*atan(tan(E/2)*sqrt((1+ec)/(1-ec)) )
endsubroutine nu_calc


c
      Subroutine  FOMCAV(IND,NPOINT,A,B,OM,RS,CL,CS)
c
C     11 JAN 78   ...JJL...   INITIAL RELEASE
C     27 JAN 87   ...SP....   REPLACED CALL TO NAG F04AMF WITH CALL TO
C                             MATH77 DHFTI.
C     12 FEB 87   ...SP....   ADDED ERROR CHECKING AFTER DHFTI CALL.
c     15 Jan 93   ...WPL...   Ported for UNIX Conversion
C
C     This routine is a modification of the routine CORCAL as it
C     was in SUPERMAP.   Given a control net of three or more
C     points  on a planetary image, the routine will calculate the
C     planet to camera transformation matrix.
C     This version allows more than three points to be used in the
C     transformation calculation.  If more than 3 image points are
C     specified, then a Linear Least Squares solution to the
C     problem is obtained.  Redundancy in control point specification
C     improves the transformation matrix soln.
C
C     P A R A M E T E R S . .
C
C     IND    = RETURN INDICATOR
C              0 = NORMAL RETURN
C               1 = INITIALIZATION FAILURE
C     A      = RETICLE DESCRIPTIVE ARRAY
C          A(1,J) = LINE VALUE OF JTH RETICLE POINT
C               A(2,J) = SAMP VALUE OF JTH RETICLE POINT
C               A(3,J) = SLANT RANGE TO JTH RETICLE POINT
C               A(4,J) = LATITUDE OF JTH RETICLE POINT
C               A(5,J) = LONGITUDE OF JTH RETICLE POINT
C                  , J=1,2,...,NPOINT-1,NPOINT
C     B      = PLANET AND SPACECRAFT DESCRIPTIVE ARRAY
C               B(1) = CAMERA FOCAL LENGTH (IN PIXELS)
C               B(2) = POLAR FLATTENING (RADIUS AT EQ-RAD.AT POLE)
C               B(3) = DISTANCE PLANET (CENTER ) TO SPACECRAFT
C               B(4) = LATITUDE OF SUBSPACECRAFT POINT
C               B(5) = LONGITUDE OF SUBSPACECRAFT POINT
C               B(6) = EQUATORIAL RADIUS
C     OM - R*8 PLANET TO CAMERA TRANSFORMATION MATRIX
C     RS - PLANET TO CAMERA POSITION VECTOR IN PLANET SYSTEM
C     CL/CS - LINE/SAMPLE OF CAMERA AXIS
C
C
      Implicit  Real*8 (A-H,O-Z)
      Double Precision  OMT(20,3)
c     ,OM(3,3)
      Real*4   A(5,20),B(6), CL,CS
      Real*8   RS(3), OM(3,3)
      Real*8  DETOMT, PLANET(20,3), CAMERA(20,3)
c       , AUX(20,3)
      Double Precision  RNORM(3), H(3), G(3)
      Integer    IPIV(3)
      Equivalence   (OMT, CAMERA)
C
C      MAXN - MAX VALUE OFNPOINT AND NO.OF ROWS IN PLANET/CAMERA ARRAYS
c
c      INTEGER  MAXN
c      Data MAXN/20/
c      LOGICAL*1 MSG1(45)/' ','*','*','*',' ','R','A','W',' ','(','T','R'
c    &,'A','N','S','F','O','R','M','A','T','I','O','N',')',' ','D','E',
c    &'T','E','R','M','I','N','A','N','T',' ','=',' ','X','X','.','X',
c    &'X'
c    &/
      Character*80  MSG1
      Data MSG1/'*** RAW (TRANSFORMATION) DETERMINANT = XX.XX'/

      RAD(PHI,REQ,FLAT) = REQ/DSQRT(REQ*REQ/((REQ-FLAT)**2)+(1.D0-
     *  REQ*REQ/((REQ-FLAT)**2))*(DCOS(PHI*PIIS/180.D0))**2)
      PIIS = 3.141592653589793D0
      PIFAC = 180.D0/PIIS
      EPS = 1.D-14
C
C     Initialize coefficient and right hand matrices
C
      CPS = DCOS(B(4)/PIFAC)
      SPS = DSIN(B(4)/PIFAC)
      CLS = DCOS(B(5)/PIFAC)
      SLS = -DSIN(B(5)/PIFAC)
      RS(1) = B(3)*CPS*CLS
      RS(2) = B(3)*CPS*SLS
      RS(3) = B(3)*SPS
C
C        Generate matrices of control point coordinates given in
C        camera centered planet coordinates (PLANET) and in camera
C        centered camera coordinates (CAMERA)
C
      Do J = 1, NPOINT
        RJ =  RAD(DBLE(A(4,J)),DBLE(B(6)),DBLE(B(2)))
        CPJ = DCOS(A(4,J)/PIFAC)
        SPJ = DSIN(A(4,J)/PIFAC)
        CLJ = DCOS(A(5,J)/PIFAC)
        SLJ = -DSIN(A(5,J)/PIFAC)
C
        PLANET(J,1) = RJ*CPJ*CLJ-RS(1)
        PLANET(J,2) = RJ*CPJ*SLJ-RS(2)
        PLANET(J,3) = RJ*SPJ-RS(3)
        A(3,J) = DSQRT(PLANET(J,1)**2+PLANET(J,2)**2+PLANET(J,3)**2)
C
        DENOM = DSQRT((A(1,J)-DBLE(CL))**2+(A(2,J)-DBLE(CS))**2+
     *    B(1)*DBLE(B(1)))
        FACT = A(3,J)/DENOM
C
        CAMERA(J,1) = (A(2,J)-CS)*FACT
        CAMERA(J,2) = (A(1,J)-CL)*FACT
        CAMERA(J,3) = B(1)*FACT
      END DO
C
C        Solve for transpose (INVERSE) of orientation matrix (OMT)
C        and check for errors
C
C        Find a least squares solution to the following problem
C
C        (PLANET)X(OMT) = (CAMERA)
C
C        where planet is a matrix of npoint row vectors
C        of planetary points in camera centered planet coords.
C        Camera is a matrix of npoint row vectors of the same
C        planetary points given in camera centered camera coords. And
C        OMT is the orthogonal transformation matrix to rotate
C        from planet to camera coordinates.
C

      Call DHFTI( PLANET,20, NPOINT,3, CAMERA, 20,3, 1.D-15,
     .            KRANK, RNORM, H, G, IPIV)
      If (KRANK .LT. 3)  Then   ! CHECK FOR UNDERDETERMINED CASE.
          IND = 1
          Return
      END IF

C
C        We will force the resulting rotation matrix to be
C        orthogonal since orthogonality constraints were not
C        incorporated into Least Squares Solution.
C        Validity of this approach rests on the assumption that the
C        sample points are fairly accurate and the calculated
C        transformation is close to being orthogonal.
C        (another approach would be to utilize lagrangian
C        multipliers to insure orthogonality).
C        The (Least Squares) calculated rotation matrix will be multiplied
C        by the scalar  (1/D**(1/3)) , where D is the
C        transformation determinant.

      DETOMT = OMT(1,1)*(OMT(2,2)*OMT(3,3)-OMT(2,3)*OMT(3,2))
     &-OMT(1,2)*(OMT(2,1)*OMT(3,3)-OMT(2,3)*OMT(3,1))
     &+OMT(1,3)*(OMT(2,1)*OMT(3,2)-OMT(2,2)*OMT(3,1))
      D = DETOMT
c     CALL OUTCON(D,MSG1(45),5,2)
c     CALL QPRINT(MSG1,45)
      Write(MSG1(40:44), '(F5.2)') D
      Call Xvmessage(MSG1, ' ')
      IF (DETOMT.LE.0.01D0 .OR. DETOMT.GE.10.D0) THEN
         IND = 3
         Return
      End IF
      DETOMT = 1.D0/(DETOMT**(1./3.))
c
C         TRANSPOSE RESULT
c
      DO I = 1, 3
         DO J = 1, 3
            OM(I,J) = OMT(J,I)*DETOMT
         END DO
      END DO
C
      IND=0
c
      Return
      End


C=======================================================================
C  PETPEN, Subroutine, N.B. Pickering
C  Calculates FAO-56 Penman-Monteith potential evapotranspiration, exactly
C  grass reference, with place for optional Kc, need this Kc in species.
!-----------------------------------------------------------------------
C  REVISION HISTORY
C  02/19/1992 NBP Written
C  11/04/1993 NBP Renamed routine PET to PETPEN.  Changed XLAI to XHLAI
C               Added XHLAI .LE. 0.0 statement.
C  05/13/1994 NBP Converted all vapor pressures to Pa.  Rearranged.
C  09/16/1994 NBP Added limits to prevent EO and ES (PE) < 0.
C  10/17/1997 CHP Updated for modular format.
C  09/01/1999 GH  Incorporated into CROPGRO
C  05/06/2002 WMB Fixed Stefan-Boltzmann constant
C  01/15/2003 KJB discarded old Penman FAO-24 (it is much too stressful)
C     replaced with Penman FAO-56, exactly grass reference, with explicit
C     LAI 2.88, height 0.12 m, Rs = 100/(0.5*2.88)
C  01/15/2003 KJB:  THREE ISSUES TO ADDRESS:
C  1) USING FIXED ALBEDO, BECAUSE THAT IS HOW REFERENCE IS DEFINED
C  2)  PRESENTLY USING A LOCKED-IN VALUE OF 1.1 TO GIVE KC OF 1.1
C  I WOULD LIKE TO SEE OPTION OF SPECIES INPUT OF KC=1.1 TO 1.3
C  3) WINDHT WAS IN OLD, APPARENTLY 2.0, NO LONGER HERE.  ???
C  02/06/2003 KJB/CHP Added EORATIO as input from plant routines.
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)
!  09/19/2006 SSJ Fixed error in REFHT calc as noted below.
!  08/25/2011 CHP Use measured vapor pressure (VAPR), if available
!-----------------------------------------------------------------------
!  Called from:   PET
!  Calls:         None
C=======================================================================
      SUBROUTINE PETPEN(
     &    CLOUDS, EORATIO, MSALB, SRAD, TAVG, TDEW,       !Input
     &    TMAX, TMIN, VAPR, WINDSP, WINDHT, XHLAI,        !Input
     &    EO)                                             !Output
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CLOUDS, EORATIO, MSALB, SRAD, TAVG, TDEW, TMAX, TMIN,
     &        WINDSP, XHLAI, WINDSP_M
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL ALBEDO, EAIR, ESAT, G, LHVAP, PSYCON, RADB,
     &  RNET, RNETMG, S, TK4,
     &  VHCAIR, VPD, DAIR, RT, ET0, KC, WINDHT, VAPR
      REAL SHAIR, PATM, SBZCON
      REAL k, d, REFHT, Zom, Zoh, ra, rl, rs    !added for PenMon
!      REAL alt_RADB, Tprev
!      INTEGER THREEDAYCOUNT
!      REAL    THREEDAYAVG(3)

!     PARAMETER (WINDHT = 2.0)
C     PARAMETER (SHAIR = 1005.0)
      PARAMETER (SHAIR = 0.001005)  !changed for PenMon to MJ/kg/K
      PARAMETER (PATM = 101300.0)
!      PARAMETER (SBZCON=4.093E-9)  !(MJ/m2/d)
      PARAMETER (SBZCON=4.903E-9)   !(MJ/K4/m2/d) fixed constant 5/6/02
!-----------------------------------------------------------------------
!     FUNCTION SUBROUTINES:
      REAL VPSLOP, VPSAT      !Found in file HMET.for

C-----------------------------------------------------------------------
C     Compute air properties.
      LHVAP = (2501.0-2.373*TAVG) * 1000.0                ! J/kg
C     PSYCON = SHAIR * PATM / (0.622*LHVAP)               ! Pa/K
      PSYCON = SHAIR * PATM / (0.622*LHVAP) * 1000000     ! Pa/K

!     Previous code:
      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0              ! Pa
      EAIR = VPSAT(TDEW)                                  ! Pa

!     If actual vapor pressure is available, use it.
      IF (VAPR > 1.E-6) THEN
        EAIR = VAPR * 1000.
      ENDIF

      VPD = MAX(0.0, ESAT - EAIR)                         ! Pa
      S = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0               ! Pa/K
      RT = 8.314 * (TAVG + 273.0)                         ! N.m/mol
      DAIR = 0.028966*(PATM-0.387*EAIR)/RT                ! kg/m3
C BAD DAIR = 0.1 * 18.0 / RT * ((PATM  -EAIR)/0.622 + EAIR)   ! kg/m3
      VHCAIR = DAIR * SHAIR    !not used                  ! J/m3

C     Convert windspeed to 2 m reference height.
!     Do this conversion in WEATHR and send out 2m windspeed
!     CHP 11/26/01
!      WIND2 = WINDSP * (2.0/WINDHT)**0.2

C       Calculate aerodynamic resistance (ra).
C       ra (d/m) = {ln[zm-d/zom]*ln[zh-d/zoh]}/(k^2*uz)
C       zm = ht.wind measurement (m), zh = ht.humidity measurement (m),
C       zom,zoh=rooughness length of momentum, heat and vapor x-fer (m)
C       k=von Karman's constant 0.41, uz=WINDSP @ z m/d,
C       d = zero plane displacement height (m)

        REFHT = 0.12                 !arbitrary for testing PenMon
        WINDSP_M = WINDSP*(1000.)     !Converts km/d to m/d
        k = 0.41                     !von Karman's constant

!       was 2/3, which (for integers) results in zero!!
!       SSJ 9/19/2006 added the decimals
        !d = (2/3)*REFHT
        d = (2./3.)*REFHT

        Zom = 0.123*REFHT
        Zoh = 0.1*Zom
        ra = (LOG((WINDHT-d)/Zom)*LOG((WINDHT-d)/Zoh))/((k**2)*WINDSP_M)

C       Calculate surface resistance (rs).
C       rs = rl/LAIactive       rs (s m^-1),
C       rl = bulk stomatal resistance of the well-illuminated leaf (s m^-1)

        rl = 100           !value assummed from FAO grass reference
        rs = rl/(0.5*2.88) !0.5*XHLAI assumes half of LA is contributing
C                          !  to heat/vapor transfer
        rs = rs/86400      !converts (s m^-1 to d/m)

C     Calculate net radiation (MJ/m2/d).  By FAO method 1990. EAIR is divided
C       by 1000 to convert Pa to KPa.

c     MJ, 2007-04-11
c     --------------
c     There appears to be no support for soil heat flux (G), apart
c     from the variable already existing; it is just always set to
c     0, for some reason.
c     Here is the (improved) CANEGRO method for calculating G
c     (Allen, R.G. et al 1989,
c     'Operational Estimates of Reference Evapotranspiration',
c     Agronomy Journal Vol. 81, No. 4),
c     http://www.kimberly.uidaho.edu/water/papers/evapotranspiration/
c                   Allen_Operational_Estimates_Reference_ET_1989.pdf
c     :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c         3-day sum of average temperature:
c          IF (THREEDAYCOUNT .LT. 1) THEN
c             Initialise
c              THREEDAYCOUNT = 1
c              THREEDAYAVG   = Tavg
c          ELSE IF (THREEDAYCOUNT .GE. 3) THEN
c              THREEDAYCOUNT = 1
c          ELSE
c              THREEDAYCOUNT = THREEDAYCOUNT + 1
c          ENDIF
c          THREEDAYAVG(THREEDAYCOUNT) = Tavg
c          Tprev = SUM(THREEDAYAVG)/3.
c          G = (Tavg-Tprev) * 0.38
c     --------------
c     MJ, 2007-04-12:
c     :::::::::::::::
c     FAO suggests that G be set to 0.  Oh well.
c     ------------------------------------------

      G = 0.0
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
C  KJB NOTE THAT REFERENCE IS ALWAYS ALBEDO FIXED TO 0.23,  OLD PEN VARIED
C  THE ALBEDO WITH LAI.  WHAT DO WE WANT?  IS THIS PART OF THE REASON THAT
C  KC IS NEEDED WITH THE REFERENCE FORMULATION?
C       ALBEDO = 0.23-(0.23-SALB)*EXP(-0.75*XHLAI)
        ALBEDO = 0.23
      ENDIF

      TK4 = ((TMAX+273.)**4+(TMIN+273.)**4) / 2.0
C
C     BELOW WAS THE OLD PENMAN, DIFFERENT CLOUDS METHOD, EAIR CHG IS GOOD
C     RADB = SBZCON * TK4 * (0.4 - 0.005 * SQRT(EAIR)) *
C    &        (1.1 * (1. - CLOUDS) - 0.1)
C

      RADB = SBZCON * TK4 * (0.34 - 0.14 * SQRT(EAIR/1000)) *
     &        (1.35 * (1. - CLOUDS) - 0.35)

      RNET= (1.0-ALBEDO)*SRAD - RADB

C     Compute EO using Penman-Montieth

      RNETMG = (RNET-G)
C     !MJ/m2/d
        ET0 = ((S*RNETMG + (DAIR*SHAIR*VPD)/ra)/(S+PSYCON*(1+rs/ra)))
C     !Converts MJ/m2/d to mm/d
        ET0 = ET0/ (LHVAP / 1000000.)
        IF (XHLAI .LE. 6.0) THEN
        XHLAI = XHLAI
        ELSE
        XHLAI = 6.0
        ENDIF
C   KJB LATER, NEED TO PUT VARIABLE IN PLACE OF 1.1
!      KC=1.0+(1.1-1.0)*XHLAI/6.0
      KC=1.0+(EORATIO-1.0)*XHLAI/6.0
      EO=ET0*KC
C     EO=ET0
        EO = MAX(EO,0.0)
!###  EO = MAX(EO,0.0)   !gives error in DECRAT_C
      EO = MAX(EO,0.0001)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETPEN

!-----------------------------------------------------------------------
!     PETPEN VARIABLES:
!-----------------------------------------------------------------------
! ALBEDO  Reflectance of soil-crop surface (fraction)
! CLOUDS  Relative cloudiness factor (0-1)
! DAIR
! EAIR    Vapor pressure at dewpoint (Pa)
! EO      Potential evapotranspiration rate (mm/d)
! ESAT    Vapor pressure of air (Pa)
! G       Soil heat flux density term (MJ/m2/d)
! LHVAP   Latent head of water vaporization (J/kg)
! PATM     = 101300.0
! PSYCON  Psychrometric constant (Pa/K)
! RADB    Net outgoing thermal radiation (MJ/m2/d)
! RNET    Net radiation (MJ/m2/d)
! RNETMG  Radiant energy portion of Penman equation (mm/d)
! RT
! S       Rate of change of saturated vapor pressure of air with
!           temperature (Pa/K)
! MSALB   Soil albedo with mulch and soil water effects (fraction)
! SBZCON   Stefan Boltzmann constant = 4.903E-9 (MJ/m2/d)
! SHAIR    = 1005.0
! SRAD    Solar radiation (MJ/m2-d)
! TAVG    Average daily temperature (�C)
! TDEW    Dewpoint temperature (�C)
! TK4     Temperature to 4th power ((oK)**4)
! TMAX    Maximum daily temperature (�C)
! TMIN    Minimum daily temperature (�C)
! Tprev   3-day sum of average temperature:
! VHCAIR
! VPD     Vapor pressure deficit (Pa)
! VPSAT   Saturated vapor pressure of air (Pa)
! VPSLOP  Calculates slope of saturated vapor pressure versus
!           temperature curve (Pa/K)
! WFNFAO  FAO 24 hour wind function
! WIND2   Windspeed at 2m reference height. (km/d)
! WINDSP  Wind speed at 2m (km/d)
! XHLAI   Leaf area index (m2[leaf] / m2[ground])
!-----------------------------------------------------------------------
!     END SUBROUTINE PETPEN
!-----------------------------------------------------------------------

C=======================================================================
C  VPSAT, Real Function, N.B. Pickering, 4/1/90
C  Calculates saturated vapor pressure of air (Tetens, 1930).
!-----------------------------------------------------------------------
!  Called by: CANPET, HMET, VPSLOP, PETPEN
!  Calls:     None
!-----------------------------------------------------------------------
C  Input : T (C)
C  Output: VPSAT (Pa)
C=======================================================================
      REAL FUNCTION VPSAT(T)

      IMPLICIT NONE
      REAL T

      VPSAT = 610.78 * EXP(17.269*T/(T+237.30))

      RETURN
      END FUNCTION VPSAT
C=======================================================================
! VPSAT Variables
!-----------------------------------------------------------------------
! T     Air temperature (oC)
! VPSAT Saturated vapor pressure of air (Pa)
C=======================================================================

C=======================================================================
C  VPSLOP, Real Function, N.B. Pickering, 4/1/90
C  Calculates slope of saturated vapor pressure versus temperature curve
C  using Classius-Clapeyron equation (see Brutsaert, 1982 p. 41)
!-----------------------------------------------------------------------
!  Called by: ETSOLV, PETPEN, TRATIO
!  Calls:     VPSAT
!-----------------------------------------------------------------------
C  Input : T (C)
C  Output: VPSLOP
C=======================================================================
      REAL FUNCTION VPSLOP(T)

      IMPLICIT NONE

      REAL T,VPSAT

C     dEsat/dTempKel = MolWeightH2O * LatHeatH2O * Esat / (Rgas * TempKel^2)
      VPSLOP = 18.0 * (2501.0-2.373*T) * VPSAT(T) / (8.314*(T+273.0)**2)

      RETURN
      END FUNCTION VPSLOP
C=======================================================================
! VPSLOP variables
!-----------------------------------------------------------------------
! T      Air temperature (oC)
! VPSAT  Saturated vapor pressure of air (Pa)
! VPSLOP Slope of saturated vapor pressure versus temperature curve
C=======================================================================


Subroutine cms(i1, i2, px1cm, py1cm, pz1cm, srt)
  Parameter (maxstr=150001)
  Double Precision px1, py1, pz1, px2, py2, pz2, em1, em2, e1, e2, s, etotal, p1beta, transf, dbetax, dbetay, dbetaz, dgamma, scheck
  Common /bb/p(3, maxstr)
  Common /cc/e(maxstr)
  Common /bg/betax, betay, betaz, gamma
  Save
  px1 = dble(p(1,i1))
  py1 = dble(p(2,i1))
  pz1 = dble(p(3,i1))
  px2 = dble(p(1,i2))
  py2 = dble(p(2,i2))
  pz2 = dble(p(3,i2))
  em1 = dble(e(i1))
  em2 = dble(e(i2))
  e1 = dsqrt(em1**2+px1**2+py1**2+pz1**2)
  e2 = dsqrt(em2**2+px2**2+py2**2+pz2**2)
  s = (e1+e2)**2 - (px1+px2)**2 - (py1+py2)**2 - (pz1+pz2)**2
  If (s<=0) s = 0D0
  srt = sngl(dsqrt(s))
  etotal = e1 + e2
  dbetax = (px1+px2)/etotal
  dbetay = (py1+py2)/etotal
  dbetaz = (pz1+pz2)/etotal
  scheck = 1.D0 - dbetax**2 - dbetay**2 - dbetaz**2
  If (scheck<=0D0) Then
     Write (99, *) 'scheck1: ', scheck
     Stop
  End If
  dgamma = 1.D0/dsqrt(scheck)
  p1beta = px1*dbetax + py1*dbetay + pz1*dbetaz
  transf = dgamma*(dgamma*p1beta/(dgamma+1D0)-e1)
  px1cm = sngl(dbetax*transf+px1)
  py1cm = sngl(dbetay*transf+py1)
  pz1cm = sngl(dbetaz*transf+pz1)
  betax = sngl(dbetax)
  betay = sngl(dbetay)
  betaz = sngl(dbetaz)
  gamma = sngl(dgamma)
  Return
End Subroutine cms


	PROGRAM FFTFREQ
C
C	SET FACTOR FOR 4 FREQUENCIES PER OCTAVE
C
C	SAMPLING RATES FOR WIND ARE 21860, 5465,AND 341
C	FOR FUNDAMENTAL FREQUENCIES OF 21.348, 5.337, AND .3336 HZ
C
	FFHI = 21860./1024.
	FFMID = FFHI/4.
	FFLO = FFMID/16.
C
	PRINT*,'FUNDAMENTAL FREQS',FFHI,FFMID,FFLO
C
	FRAT = .5**.25
	FREQHI = 511.
	DO N = 1,28
	  FREQLO = FREQHI*FRAT
	  NF2 = FREQHI
	  NF1 = FREQLO + 1.
	  FREQAV = .5*(FREQHI+FREQLO)
	  FREQAVN = .5*(NF1+NF2)
	  PRINT*,' '
	  PRINT 1001,N,FREQAV,FREQAVN,NF1,NF2,FFHI*FREQAVN,
     1      FFMID*FREQAVN,FFLO*FREQAVN
	  FREQHI = FREQLO
	ENDDO
	DO N = 29,31
	  FREQAV = 32-N
	  PRINT*,' '
	  PRINT 1001,N,FREQAV,FREQAV,32-N,32-N,FFHI*FREQAV,
     1    FFMID*FREQAV,FFLO*FREQAV
	ENDDO
	STOP
 1001	FORMAT(I4,F10.3,F10.3,I8,I8,2X,F11.2,F11.3,F11.4)
	END


c     ============================================
      subroutine setaux(maxmx,maxmy,mbc,mx,my,xlower,ylower,dxc,dyc,
     &                  maux,aux)
c     ============================================
c
c     # set auxiliary arrays for advection on a curvilinear grid
c
c     # on input, (xc(i),yc(j)) gives uniformly spaced computational grid.
c     # on output,
c     #   aux(i,j,1) is edge velocity at "left" boundary of grid point (i,j)
c     #   aux(i,j,2) is edge velocity at "bottom" boundary of grid point (i,j)
c     #   aux(i,j,3) = kappa  is ratio of cell area to dxc*dyc
c
      implicit double precision (a-h,o-z)
      parameter (maxm3 = 1005)
      dimension xc(-3:maxm3), yc(-3:maxm3)
      dimension xp(-3:maxm3,-3:maxm3), yp(-3:maxm3,-3:maxm3)
      dimension zp(-3:maxm3,-3:maxm3)
      dimension theta(-3:maxm3,-3:maxm3), phi(-3:maxm3,-3:maxm3)
      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, 3)
      common /comsphere/ Rsphere

      Rsphere = 1.d0  ! try this

      pi = 4.d0*datan(1.d0)
c     write(6,*) 'in setaux',mx,my,xlower,ylower,dxc,dyc
c
      if (mbc .gt. 4) then
	 write(6,*)'***  increase size of local arrays in setaux ***'
	 stop
	 endif
      if (mx+mbc+1.gt.maxm3 .or. my+mbc+1.gt.maxm3) then
	 write(6,*)'***  increase size of maxm3 in setaux ***'
	 stop
	 endif
c
c     # Set xc and yc so that (xc(i),yc(j)) is the
c     # lower left corner of (i,j) cell in computational space:
c
      do 10 i=1-mbc,mx+mbc+1
         xc(i) = xlower + (i-1.d0) * dxc
   10    continue
c
      do 12 j=1-mbc,my+mbc+1
         yc(j) = ylower + (j-1.d0) * dyc
   12    continue

c     # compute cell corners on sphere and angles phi, theta
c     # related to latitude and longitude
c
      do 15 j=1-mbc,my+mbc+1
         do 15 i=1-mbc,mx+mbc+1

c           # map computational point to (xp,yp,zp) on sphere:
            call mapc2m(xc(i),yc(j),xp(i,j),yp(i,j),zp(i,j))

c           # compute longitude theta from positive x axis:
            r = dsqrt(xp(i,j)**2 + yp(i,j)**2)
            if (r .gt. 1.d-2*dxc) then
                theta(i,j) = dacos(xp(i,j)/r)
              elseif (yp(i,j).gt.0.d0) then
                theta(i,j) = 0.d0
              endif
            if (yp(i,j) .lt. 0.d0) then
                theta(i,j) = -theta(i,j)
                endif

c           # compute phi, angle down from north pole:
            if (zp(i,j) .gt. 0.d0) then
                phi(i,j) = pi/2.d0 - dacos(r/Rsphere)
              else
                phi(i,j) = pi/2.d0 + dacos(r/Rsphere)
              endif
   15	    continue

c
      areamax = 0.d0
      areamin = 1.d3
      velmax = 0.d0
      do 20 j=1-mbc,my+mbc
         do 20 i=1-mbc,mx+mbc
c
c           # compute edge velocities by differencing stream function:
c
	    aux(i,j,1) = (stream(xp(i,j+1),yp(i,j+1),zp(i,j+1))
     &			  - stream(xp(i,j),yp(i,j),zp(i,j))) / dyc
c
	    aux(i,j,2) = -(stream(xp(i+1,j),yp(i+1,j),zp(i+1,j))
     & 			   - stream(xp(i,j),yp(i,j),zp(i,j))) / dxc
            if (dmax1(dabs(aux(i,j,1)), dabs(aux(i,j,2))) .gt. velmax)
     &        then
                velmax = dmax1(dabs(aux(i,j,1)), dabs(aux(i,j,2)))
                ivmax = i
                jvmax = j
              endif

c           # compute area of physical cell from four corners:
c           # find area on the sphere of two spherical triangles obtained
c           # by subdividing rectangle.  See
c           #    http://mathforum.org/library/drmath/view/65316.html

c           # corners are labeled
c           #      1: (i,j)      2: (i+1,j)    3: (i,j+1)    4: (i+1,j+1)

            beta12 = dsin(phi(i,j))*dsin(phi(i+1,j))*
     &                  dcos(theta(i,j) - theta(i+1,j))
     &                + dcos(phi(i,j))*dcos(phi(i+1,j))
            beta23 = dsin(phi(i,j+1))*dsin(phi(i+1,j))*
     &                  dcos(theta(i,j+1) - theta(i+1,j))
     &                 + dcos(phi(i,j+1))*dcos(phi(i+1,j))
            beta13 = dsin(phi(i,j+1))*dsin(phi(i,j))*
     &                  dcos(theta(i,j+1) - theta(i,j))
     &                 + dcos(phi(i,j+1))*dcos(phi(i,j))
            beta24 = dsin(phi(i+1,j+1))*dsin(phi(i+1,j))*
     &                  dcos(theta(i+1,j+1) - theta(i+1,j))
     &                 + dcos(phi(i+1,j+1))*dcos(phi(i+1,j))
            beta34 = dsin(phi(i+1,j+1))*dsin(phi(i,j+1))*
     &                  dcos(theta(i+1,j+1) - theta(i,j+1))
     &                 + dcos(phi(i+1,j+1))*dcos(phi(i,j+1))

c           # great circles distances between corners:
            d12 = Rsphere * dacos(beta12)
            d23 = Rsphere * dacos(beta23)
            d13 = Rsphere * dacos(beta13)
            d24 = Rsphere * dacos(beta24)
            d34 = Rsphere * dacos(beta34)

            s123 = 0.5d0 * (d12 + d23 + d13)
            s234 = 0.5d0 * (d23 + d34 + d24)

c           # spherical excess for each triangle:
            t123 = dtan(s123/2.d0)*dtan((s123-d12)/2.d0)
     &             *dtan((s123-d23)/2.d0)*dtan((s123-d13)/2.d0)
            t123 = dmax1(t123,0.d0)
            E123 = 4.d0*datan(sqrt(t123))

            t234 = dtan(s234/2.d0)*dtan((s234-d23)/2.d0)
     &             *dtan((s234-d34)/2.d0)*dtan((s234-d24)/2.d0)
            t234 = dmax1(t234,0.d0)
            E234 = 4.d0*datan(sqrt(t234))

            area = Rsphere**2 * (E123 + E234)
c
c           # capacity kappa:
	    aux(i,j,3) = area / (dxc*dyc)
            if (i.gt.0 .and. i.le.mx .and. j.gt.0 .and. j.le.my) then
               areamax = dmax1(areamax,area)
               areamin = dmin1(areamin,area)
               endif
c           write(27,*) i,j,area,aux(i,j,3)
            if (aux(i,j,3) .lt. 0.5d0 .or. aux(i,j,3).gt.3.d0) then
               write(27,*) '   '
               write(27,*) i,j,area,aux(i,j,3)
               write(27,*) '   ',mx,my,xlower,ylower,dxc,dyc
               write(27,*) '   ',xc(i),yc(j),theta(i,j),phi(i,j)
               write(27,*) '   ',xp(i,j),yp(i,j),zp(i,j)
               endif

            write(21,210) i,j,xc(i),yc(j),xp(i,j),yp(i,j),zp(i,j),
     &                    theta(i,j),phi(i,j),t123,t234,
     &                    aux(i,j,1),aux(i,j,2),aux(i,j,3)
  210       format(2i3,5e14.5,/,'      ',4e14.5,/,'      ',3e14.5,/)
c
   20       continue
c
c      write(27,*) areamax,areamin
c      write(6,*) 'area ratio = ',areamax/areamin
c      write(6,*) 'max velocity = ',velmax, '  at ', ivmax,jvmax
       return
       end


!==============================================================================!
  real function Tau_Wall_Low_Re(turb, dens, u_tau, u_tan, y_plus)
!------------------------------------------------------------------------------!
!   Calculates tau_wall for low Reynolds approach.                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: TINY
  use Turb_Mod,  only: Turb_Type, kappa, e_log
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type) :: turb
  real            :: dens, u_tau, u_tan, y_plus
!==============================================================================!

  Tau_Wall_Low_Re = dens * kappa * u_tau * u_tan   &
                  / log(e_log * max(y_plus, 1.05))

  end function


subroutine waterstress(method_ws,     &
                        ndws,         &
                        ndews,        &
                        eop,          &
                        trwup,        &
                        rwuep1,       &
                        rwuep2 ,      &
                        t_max_ws_pho, &
                        t_mid_ws_pho, &
                        t_min_ws_pho, &
                        t_max_ws_exp, &
                        t_mid_ws_exp, &
                        t_min_ws_exp, &
                        t_max_ws_til, &
                        t_mid_ws_til, &
                        t_min_ws_til, &
                        t_max_ws_fpf, &
                        t_mid_ws_fpf, &
                        t_min_ws_fpf, &
                        threshews,    &
                        swfacp,       &
                        swface,       &
                        swfact,       &
                        swfacf)

    !----------------------------------------------!
    !--- Soil Water Stress factor for Sugarcane ---!
    !----------------------------------------------!

    Implicit none

    integer method_ws
    integer ndws
    integer ndews
    real    eop
    real    trwup
    real    rwuep1
    real    rwuep2
    real    t_max_ws_pho
    real    t_mid_ws_pho
    real    t_min_ws_pho
    real    t_max_ws_exp
    real    t_mid_ws_exp
    real    t_min_ws_exp
    real    t_max_ws_til
    real    t_mid_ws_til
    real    t_min_ws_til
    real    t_max_ws_fpf
    real    t_mid_ws_fpf
    real    t_min_ws_fpf
    real    threshews

    real    swfacp  ! Photosynthesis Water Stress Factor [0-1]
    real    swface  ! Expansion Water Stress Factor [0-1]
    real    swfact  ! Tillering Water Stress Factor [0-1]
    real    swfacf  ! Fiber partitioning factor Water Stress Factor [0-1]

    real :: max_ws = 0.d0
    real :: min_ws = 1.d0

    real asy_ws     ! Function
    real watdmd     ! Water demand ratio (source/sink)

    save

    !--- Initiate
    swfacp      = 1.d0
    swface      = 1.d0
    swfact      = 1.d0
    swfacf      = 1.d0

    !--- water stress factors in photosynthesis and expansion
        if (eop .le. 0.d0) then
        watdmd = 0.
        swfacp = 1.d0
        swface = 1.d0
        swfact = 1.d0
        swfacf = 1.d0
        else

            !--- Water deficit (supply/demand)
            watdmd = max(trwup/(eop/10.),0.d0)

            if(method_ws .eq. 1)then

                !--- Linear response to water depletion
                if(watdmd .lt. rwuep1) then
                    swfacp = max(0.,min((1./rwuep1) * watdmd,1.))
                endif

                if(watdmd .lt. rwuep2) then
                    swface = max(0.,min((1./rwuep2) * watdmd,1.))
                endif

            else if(method_ws .eq. 2)then

                !--- Asymptote response to water depletion
                swfacp = asy_ws(max_ws, min_ws, t_max_ws_pho, t_mid_ws_pho, t_min_ws_pho, watdmd)
                swface = asy_ws(max_ws, min_ws, t_max_ws_exp, t_mid_ws_exp, t_min_ws_exp, watdmd)
                swfact = asy_ws(max_ws, min_ws, t_max_ws_til, t_mid_ws_til, t_min_ws_til, watdmd)
                swfacf = asy_ws(max_ws, min_ws, t_max_ws_fpf, t_mid_ws_fpf, t_min_ws_fpf, watdmd)

            endif
        endif

        !--- Consecutive days of water stress counter
        if(swfacp .lt. 1.) then
            ndws = ndws + 1
        else
            ndws = 0
        endif

        !--- Consecutive days of extreme water stress counter (threshews is the threshold to account for extreme stress)
        if(watdmd .lt. threshews) then
            ndews = ndews + 1
        else
            ndews = 0
        endif

    return

end subroutine waterstress


      double complex function Afphiqarbmppm(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      double precision s12,s34
      double complex lnrat,A0phiqarbmppm
      integer j1,j2,j3,j4
      s12=s(j1,j2)
      s34=s(j3,j4)
C---arXIv:09060008v1 Eq.(4.12)
c--- the function defined in this routine is in fact (-i*A_4),
c---   i.e. complete LHS
      Afphiqarbmppm=A0phiqarbmppm(j1,j2,j3,j4,za,zb)*
     & (-2d0/3d0*(2d0*epinv+lnrat(musq,-s12)+lnrat(musq,-s34))
     & - 20D0/9D0)

      return
      end


      subroutine runCF_iiiii(i1,i2,i3,i4,i5,m0sq,Gr,Bzero5,N0)
C---  Expression for rearrangement of extension of Eq. 5.69
C---  Calculates Ciiii, requires C00iiiii
C---  Small terms of order Gr(i,j)*Cijklmno
C---  Denominator m0sq
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,i2,i3,i4,i5,m,n,np
      parameter(np=2)
      double precision m0sq,Gr(np,np)
      double complex Bzero5(z5max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(ciiiiiii(z7(n,m,i1,i2,i3,i4,i5))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(czziiiii(z5(i1,i2,i3,i4,i5))+N0,ep-1)

      Cv(ciiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     . (28d0*Cv(czziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)
     . -pole
     . -2d0*Bzero5(z5(i1,i2,i3,i4,i5),ep)
     . +bit)/(2d0*m0sq)

      enddo

      return
      end


! Created by EverLookNeverSee@GitHub on 5/23/20.
! This program finds the largest and the smallest elements of a sequence.

program largest_smalest
    implicit none
    ! declaring variables
    integer :: n, i
    ! declaring temporary biggest and smallest elements
    real :: Big, Small
    real, allocatable, dimension(:) :: a
    1   print *, "Number of elements in the sequence(positive integer):"
    read *, n
    ! checking user input that should be positive integer
    if (n <= 0) then
        goto 1
    end if
    ! creating an array with n blocks
    allocate(a(n))
    ! getting elements of sequence from user
    do i = 1, n
        print *,"a(",i,"):"
        read *, a(i)
    end do
    ! set to first element of sequence
    Big = a(1)
    Small = a(1)
    ! checking elements to find smallest and largest element
    do i = 2, n
        if (Big < a(i)) then
            Big = a(i)
        end if
        if (Small > a(i)) then
            Small = a(i)
        end if
    end do
    ! printing results
    print *,"smallest element:", Small, "Biggest element:", Big
end program largest_smalest


! -*- Mode: Fortran; -*-
!
!  (C) 2016 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
!  Portions of this code were written by Intel Corporation.
!  Copyright (C) 2011-2016 Intel Corporation.  Intel provides this material
!  to Argonne National Laboratory subject to Software Grant and Corporate
!  Contributor License Agreement dated February 8, 2012.

program main
use mpi_f08
implicit none
integer rank, size

type(MPI_Comm) :: comm_cart, comm_new
integer dims(2), coords(2)
logical periods(2), reorder, remain_dims(2)
integer errs

dims(1:2) = 0
periods(1) = .TRUE.
periods(2) = .FALSE.
reorder    = .TRUE.
remain_dims(1) = .TRUE.
remain_dims(2) = .FALSE.
errs = 0

call MTEST_Init()
call MPI_Comm_rank(MPI_COMM_WORLD, rank)
call MPI_Comm_size(MPI_COMM_WORLD, size)
call MPI_Dims_create(size, 2, dims)
call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, periods, reorder, comm_cart)
call MPI_Comm_rank(comm_cart, rank)
call MPI_Cart_coords(comm_cart, rank, 2, coords)

call MPI_Cart_sub(comm_cart, remain_dims, comm_new)
call MPI_Comm_size(comm_new, size)

call MTEST_Finalize(errs)

end program


module hamming

implicit none
contains

  function compute(strand1, strand2, distance)
      character(*) :: strand1, strand2
      integer :: distance, i
      logical :: compute

      distance = 0
      compute = .true.

      if ( len(strand1) .NE. len(strand2) ) then
          compute = .false.
          return
      end if

      do i = 1,len(strand1)
        if (strand1(i:i) .NE. strand2(i:i)) then
          distance = distance + 1
        end if

      end do

  end function compute
end module hamming


C File: arrays-sect-12.f
C Illustrates the use of two-dimensional array sections.

      program main
      implicit none

      integer, dimension (4,6) :: A
      integer, dimension(3) :: C = (/1,3,4/)
      integer :: i, J

      do i = 1, 4
         do j = 1, 6
            A(i,j) = i*i+j*j
         end do
      end do

      do i = 1,4
         write (*,10) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5), A(i,6)
      end do
      write(*,11)

 10   format("BEFORE: ", 6(I5,X))
 11   format('')
 12   format("AFTER:  ", 6(I5,X))

C     A two-dimensional array section.  The elements selected are:
C
C        A(1,1), A(1,3), A(1,4)
C        A(4,1), A(4,3), A(4,4)

      A((/1,4/),C) = -1

      do i = 1,4
         write (*,12) A(i,1), A(i,2), A(i,3), A(i,4), A(i,5), A(i,6)
      end do

      stop
      end program main


!>
!! Module that reads in and provides parameters for the simulation.
!!
MODULE params

IMPLICIT NONE

!> If TRUE, the solution will be written out. Otherwise only timings are generated.
LOGICAL :: do_io

!> If TRUE, Parareal will generate a number of messages during runtime.
LOGICAL ::be_verbose

!> Diffusion coefficient in Burgers equation
DOUBLE PRECISION :: nu

!> Mesh width in x direction
DOUBLE PRECISION :: dx

!> Mesh width in y direction
DOUBLE PRECISION :: dy

!> Mesh width in z direction
DOUBLE PRECISION :: dz

!> Final simulation time
DOUBLE PRECISION :: Tend

!> Number of cells in x direction
INTEGER :: Nx

!> Number of cells in y direction
INTEGER :: Ny

!> Number of cells in z direction
INTEGER :: Nz

!> Time steps *per timeslice* for the fine integrator
INTEGER :: N_fine

!> Time steps *per timeslice* for the coarse integrator
INTEGER :: N_coarse

!> Number of Parareal iterations
INTEGER :: Niter

CHARACTER(len=32) :: param_file

NAMELIST /param/ nu, Nx, Ny, Nz, N_fine, N_coarse, Niter, Tend, do_io, be_verbose

CONTAINS

  !>
  !! Read parameter namelist from input file provided as first command line argument
  SUBROUTINE ReadParameter()

    CALL GET_COMMAND_ARGUMENT(1,param_file)

    ! Read parameters
    OPEN(unit=20, FILE=param_file, ACTION='read', STATUS='old')
    READ(20,NML=param)
    CLOSE(20)

    ! Computational domain is unit cube
    dy = DBLE(1.0)/DBLE(Ny)
    dz = DBLE(1.0)/DBLE(Nz)
    dx = DBLE(1.0)/DBLE(Nx)

  END SUBROUTINE ReadParameter

END MODULE params


SUBROUTINE PZ_CONVOL(yield,zave,spec_pz,lbol_pz,mass_pz)

  !routine to weight SSP(Z) by the MDF: P(Z)=Z**zpow*EXP(-Z/p).
  !The yield is the only input.
  !zpow is set in sps_vars.f90; zpow=1 yields a closed-box
  !requires that all the SSPs are set up in the common block
  !variables spec_ssp_zz, mass_ssp_zz, and lbol_ssp_zz
  !The average metallicity is returned as zave

  USE sps_vars; USE sps_utils, ONLY : linterp
  IMPLICIT NONE

  INTEGER  :: i,t,z
  REAL(SP) :: norm
  REAL(SP), INTENT(out), DIMENSION(nspec,ntfull) :: spec_pz
  REAL(SP), INTENT(out), DIMENSION(ntfull) :: mass_pz, lbol_pz
  REAL(SP), INTENT(out)    :: zave
  REAL(SP), DIMENSION(nz)  ::  pzz1
  REAL(SP), DIMENSION(100) :: pzz2,zz2,zzspec
  REAL(SP), INTENT(in) :: yield

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

  spec_pz = 0.0
  lbol_pz = 0.0
  mass_pz = 0.0
  norm    = 0.0
  zave    = 0.0

  !if using the Padova+BaSeL model, just use the native Z grid
  IF (nz.EQ.22) THEN

     !define P(Z)
     pzz1 = zlegend**zpow2 * EXP(-zlegend/yield)

     !integrate over P(Z)
     DO z=1,nz-1
        spec_pz = spec_pz + (LOG(zlegend(z+1))-LOG(zlegend(z))) * &
             (pzz1(z+1)*spec_ssp_zz(:,:,z+1) + pzz1(z)*spec_ssp_zz(:,:,z))/2.
        lbol_pz = lbol_pz + (LOG(zlegend(z+1))-LOG(zlegend(z))) * &
             (pzz1(z+1)*lbol_ssp_zz(:,z+1) + pzz1(z)*lbol_ssp_zz(:,z))/2.
        mass_pz = mass_pz + (LOG(zlegend(z+1))-LOG(zlegend(z))) * &
             (pzz1(z+1)*mass_ssp_zz(:,z+1) + pzz1(z)*mass_ssp_zz(:,z))/2.
        norm    = norm + (LOG(zlegend(z+1))-LOG(zlegend(z))) * &
          (pzz1(z+1)+pzz1(z))/2.
        zave    = zave + (LOG(zlegend(z+1))-LOG(zlegend(z))) * &
          (pzz1(z+1)*zlegend(z+1)+pzz1(z)*zlegend(z))/2.
     ENDDO

  ELSE

     !set up Z grid
     DO i=1,100
        zz2(i) = 10**(REAL(i)/100.*(-1+4.0)-4)
     ENDDO

     !define P(Z)
     pzz2 = zz2**zpow2 * EXP(-zz2/yield)
     !pzz2 = zz2/ (1/zz2 + 1E4*zz2**zpow)

     DO t=nt,nt
        DO i=1,nspec
           !interpolate
           DO z=1,100
              zzspec(z) = 10**linterp(log10(zlegend),&
                   log10(spec_ssp_zz(i,t,:)),log10(zz2(z)))
           ENDDO
           !integrate
           DO z=1,100-1
              spec_pz(i,t) = spec_pz(i,t) + (LOG(zz2(z+1))-LOG(zz2(z))) * &
                   (pzz2(z+1)*zzspec(z+1) + pzz2(z)*zzspec(z))/2.
           ENDDO
        ENDDO
     ENDDO

     DO z=1,100-1
        norm = norm + (LOG(zz2(z+1))-LOG(zz2(z))) * &
             (pzz2(z+1)+pzz2(z))/2.
        zave = zave + (LOG(zz2(z+1))-LOG(zz2(z))) * &
             (pzz2(z+1)*zz2(z+1)+pzz2(z)*zz2(z))/2.
     ENDDO

  ENDIF

  spec_pz = spec_pz / norm
  lbol_pz = lbol_pz / norm
  mass_pz = mass_pz / norm
  zave    = zave    / norm

END SUBROUTINE PZ_CONVOL


C
C $Id: dpdsym.f,v 1.4 2008-07-27 00:16:58 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE DPDSYM (XPSW,YPSW,CSYM,WOSW,ANGD)
C
        CHARACTER*1 CSYM
C
C This routine is called by DPDRAW to draw a symbol at the point
C (XPSW,YPSW) in the world coordinate system.  The symbol to be
C drawn is the one associated with the character CSYM.  Its width
C is to be WOSW, in the world coordinate system, and it is to be
C written at the angle ANGD, in degrees measured counterclockwise
C from a horizontal vector pointing to the right.
C
C Declare coordinate arrays in which to define the mark.
C
        DIMENSION XCRA(37),YCRA(37)
C
C Define a multiplicative constant to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C Compute the coordinates of the point defining the mark.  The curious
C constants used in some of this code are intended to make each symbol
C have the same area as that of a circle symbol.
C
        IF (CSYM.EQ.'0'.OR.CSYM.EQ.'5') THEN
C
C The mark is a circle.
C
          DO 101 I=1,37
            ANGR=DTOR*(REAL(I-1)*10.)
            XCRA(I)=XPSW+(WOSW/2.)*COS(ANGR)
            YCRA(I)=YPSW+(WOSW/2.)*SIN(ANGR)
  101     CONTINUE
C
          NCRA=37
C
        ELSE IF (CSYM.EQ.'1'.OR.CSYM.EQ.'6') THEN
C
C The mark is a square.
C
          DO 102 I=1,5
            ANGR=DTOR*(ANGD+45.+REAL(I-1)*90.)
            XCRA(I)=XPSW+1.25331*(WOSW/2.)*COS(ANGR)
            YCRA(I)=YPSW+1.25331*(WOSW/2.)*SIN(ANGR)
  102     CONTINUE
C
          NCRA=5
C
        ELSE IF (CSYM.EQ.'2'.OR.CSYM.EQ.'7') THEN
C
C The mark is a triangle.
C
          DO 103 I=1,4
            ANGR=DTOR*(ANGD+90.+REAL(I-1)*120.)
            XCRA(I)=XPSW+1.55512*(WOSW/2.)*COS(ANGR)
            YCRA(I)=YPSW+1.55512*(WOSW/2.)*SIN(ANGR)
  103     CONTINUE
C
          NCRA=4
C
        ELSE IF (CSYM.EQ.'3'.OR.CSYM.EQ.'8') THEN
C
C The mark is a diamond.
C
          DO 104 I=1,5
            ANGR=DTOR*(ANGD+REAL(I-1)*90.)
            XCRA(I)=XPSW+1.25331*(WOSW/2.)*COS(ANGR)
            YCRA(I)=YPSW+1.25331*(WOSW/2.)*SIN(ANGR)
  104     CONTINUE
C
          NCRA=5
C
        ELSE IF (CSYM.EQ.'4'.OR.CSYM.EQ.'9') THEN
C
C The mark is a star.
C
          DO 105 I=1,11
            ANGR=DTOR*(ANGD+18.+REAL(I-1)*36.)
            IF (MOD(I,2).EQ.0) THEN
              RADI=.381966
            ELSE
              RADI=1.
            END IF
            XCRA(I)=XPSW+1.67289*RADI*(WOSW/2.)*COS(ANGR)
            YCRA(I)=YPSW+1.67289*RADI*(WOSW/2.)*SIN(ANGR)
  105     CONTINUE
C
          NCRA=11

        END IF
C
C Fill or outline the mark.
C
        IF (CSYM.GE.'0'.AND.CSYM.LE.'4') THEN
          CALL GFA (NCRA,XCRA,YCRA)
        ELSE IF (CSYM.GE.'5'.AND.CSYM.LE.'9') THEN
          CALL GPL (NCRA,XCRA,YCRA)
        END IF
C
C Done.
C
        RETURN
C
      END