subroutine taylor(kmax      ,kmxdt     ,kmxt      ,np        ,nfreqs    , &
                & luniwe    ,wsp10     ,siglim    ,wvlbed    ,wvlsur    , &
                & frcbed    ,frcsur    ,ustbx     ,ustby     ,ustwix    , &
                & ustwiy    ,sig       ,thick     ,zeta      ,dps       , &
                & dudz      ,dvdz      ,rich      ,bruvai    ,rtur0     , &
                & vicww     ,u0        ,v0        ,tkepro    ,tkedis    , &
                & fuiwe     ,fviwe     ,d2u0      ,d2v0      ,atg       , &
                & btg       ,ctg       ,utg       ,vtg       ,d2u       , &
                & d2v       ,bv2       ,qz        ,r1tg      ,tke       , &
                & eps       ,dijdij    ,edvis     ,zlw       ,tlw       , &
                & ttkiw     ,tiwtk     ,futg      ,fvtg      ,freqlo    , &
                & frequp    ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: taylor.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/taylor/taylor.f90 $
!!--description-----------------------------------------------------------------
!
!    Function:-Turbulence production,
!             -turbulence dissipation,
!             -turbulence diffusion and
!             -momentum exchange (not yet installed)
!              due to Internal Waves (IW's) generated
!
!             -internally by turbulence or
!             -externally by surface perturbations or
!             -externally by bed topography.
!
!              These processes are estimated by solving real-
!              valued eigenmodes of the Taylor-Goldstein second-
!              order differential equation for internal waves in
!              an arbitrary shear flow.
!
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
   !
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    real(fp)               , pointer :: alfaz
    real(fp)               , pointer :: xmu0
    real(fp)               , pointer :: viscof
    integer                , pointer :: nrange
    logical                , pointer :: iwedia
    real(fp)               , pointer :: ag
    real(fp)               , pointer :: vonkar
!
! Global variables
!
    integer                                      :: kmax   !  Description and declaration in esm_alloc_int.f90
    integer                                      :: kmxdt  !  Description and declaration in dimens.igs
    integer                                      :: kmxt   !  Description and declaration in dimens.igs
    integer                                      :: luniwe !!  Unit number for diagnostic reports of this subprogram as well as called subroutines
    integer                                      :: nfreqs !  Description and declaration in dimens.igs
    integer                                      :: np     !!  Dimension for IWE frequency arrays MAX (1,NFREQS)
    real(prec)                                   :: dps    !  Description and declaration in esm_alloc_real.f90
    real(fp)                                     :: frcbed !  Description and declaration in iwepar.igs
    real(fp)                                     :: frcsur !  Description and declaration in iwepar.igs
    real(fp)                                     :: siglim !  Description and declaration in iwepar.igs
    real(fp)                                     :: ustbx  !!  X/u-component of bed-shear stress velocity (zeta point)
    real(fp)                                     :: ustby  !!  Y/v-component of bed-shear stress velocity (zeta point)
    real(fp)                                     :: ustwix !!  X/u-component of wind-shear stress velocity
    real(fp)                                     :: ustwiy !!  Y/v-component of wind-shear stress velocity
    real(fp)                                     :: wsp10  !!  Windspeed at 10 m
    real(fp)                        , intent(in) :: wvlbed !  Description and declaration in iwepar.igs
    real(fp)                        , intent(in) :: wvlsur !  Description and declaration in iwepar.igs
    real(fp)                                     :: zeta   !!  Water surface elevation
    real(fp) , dimension(0:kmax)                 :: bruvai !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(0:kmax)                 :: d2u0
    real(fp) , dimension(0:kmax)                 :: d2v0
    real(fp) , dimension(0:kmax)                 :: dudz   !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(0:kmax)                 :: dvdz   !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(0:kmax)                 :: rich   !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(0:kmax)                 :: vicww  !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(0:kmax, 2)              :: rtur0  !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(0:kmxdt)                :: atg
    real(fp) , dimension(0:kmxdt)                :: btg
    real(fp) , dimension(0:kmxdt)                :: bv2
    real(fp) , dimension(0:kmxdt)                :: ctg
    real(fp) , dimension(0:kmxdt)                :: d2u
    real(fp) , dimension(0:kmxdt)                :: d2v
    real(fp) , dimension(0:kmxdt)                :: dijdij
    real(fp) , dimension(0:kmxdt)                :: edvis
    real(fp) , dimension(0:kmxdt)                :: eps    !  Description and declaration in numeco.igs
    real(fp) , dimension(0:kmxdt)                :: futg
    real(fp) , dimension(0:kmxdt)                :: fvtg
    real(fp) , dimension(0:kmxdt)                :: qz
    real(fp) , dimension(0:kmxdt)                :: r1tg
    real(fp) , dimension(0:kmxdt)                :: tiwtk
    real(fp) , dimension(0:kmxdt)                :: tke
    real(fp) , dimension(0:kmxdt)                :: tlw
    real(fp) , dimension(0:kmxdt)                :: ttkiw
    real(fp) , dimension(0:kmxdt)                :: utg
    real(fp) , dimension(0:kmxdt)                :: vtg
    real(fp) , dimension(0:kmxdt)                :: zlw
    real(fp) , dimension(kmax)                   :: fuiwe  !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: fviwe  !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: sig    !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: thick  !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: tkedis !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: tkepro !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: u0     !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(kmax)                   :: v0     !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(np, 2)                  :: freqlo
    real(fp) , dimension(np, 2)                  :: frequp
!
!
! Local variables
!
    integer                        :: k
    integer                        :: kbed                 ! K-value on TG grid: upper level stratified layer
    integer                        :: kcrit                ! K-value on TG grid of the critical level associated with a given IW own mode (R1TG)
    integer                        :: ktg
    integer                        :: ktgcd                ! KTG-value of upper most critical level
    integer                        :: ktgcu                ! KTG-value of lowest critical level
    integer                        :: ktop                 ! K-value on TG grid: lower level stratified layer
    integer                        :: n
    integer                        :: ncrit
    integer                        :: nd
    integer                        :: ndir                 ! If NDIR=1 then horizontal Direction of IW propagation is in wavenumber direction, and in opposite direction for NDIR=2
    integer                        :: nr
    integer                        :: nrd
    integer                        :: nru
    integer                        :: nu
    integer  , dimension(2, 2)     :: kcri                 ! K-value on TG grid of most upper and lower critical levels of turbulence- generated IW's
    integer  , dimension(2, 2)     :: ncri                 ! Number of critical layers found per minimal or maximal K-value as well as sign of frequency of turbulence- generated IW's
    logical                        :: barcli               ! presence of subgrid barcolcinic modes
    logical                        :: frfind               ! If .true. then find root of TG equation as function of angular frequency, else find root as function of angle of horizontal wave number vector
    logical                        :: singul               ! Indicator of singular solution of TG equation
    logical                        :: tgfind               ! Indicator for instructing subroutine TG to yield the eigen mode for given input
    logical                        :: top                  ! Indicator for instructing subroutine TG to yield the eigen mode by sweeping from surface to bed, or vice versa
    logical                        :: useref               ! Switch instructing INTPOL using reference velocity
    logical  , dimension(2, 2)     :: sing                 ! Indicator of singular solutions of TG equation
    real(fp)                       :: angle                ! Angle [degrees] between horizontal IW wavenumber vector and x-u-axis
    real(fp)                       :: az
    real(fp)                       :: azmax                ! Maximal rms IW vertical displacement amplitude
    real(fp)                       :: bvav                 ! Mean bouyancy frequency
    real(fp)                       :: bvmx                 ! Maximal buoyancy frequency
    real(fp)                       :: bz                   ! Bandwidth of IW vertical wavenumber components
    real(fp)                       :: crit                 ! Minimal value found after convergence of root-finding procedure ZBRENT
    real(fp)                       :: cs2
    real(fp)                       :: delf                 ! Increment in non-dimensional angular frequency
    real(fp)                       :: epsiwe               ! Depth integral of IWE dissipation rate
    real(fp)                       :: factor
    real(fp)                       :: frlo                 ! Left bracket of frequency interval with largest root of TG equation
    real(fp)                       :: frup                 ! Right bracket of frequency interval with largest root of TG equation
    real(fp)                       :: h0                   ! Water depth
    real(fp)                       :: hstrat               ! Thickness of stratified layer
    real(fp)                       :: omeg                 ! Angular frequency of IW with respect to ground (root of TG equation)
    real(fp)                       :: pi2
    real(fp)                       :: ratiod               ! Ratio between depth-averaged kin. energy in internal wave and kin. energy of vertical motions, based on lowest critical layer
    real(fp)                       :: ratiou               ! Ratio between depth-averaged kin. energy in internal wave and kin. energy of vertical motions, based on upper critical layer
    real(fp)                       :: ratiow               ! Mean ratio between depth-averaged kin energy in internal wave and kin. energy of vertical motions
    real(fp)                       :: riav                 ! Mean value of all RICH with RICH > RICRIT
    real(fp)                       :: rilz                 ! Vertical interval with RICH > RICRIT
    real(fp)                       :: scale                ! Length scale for scaling
    real(fp)                       :: term
    real(fp)                       :: umag
    real(fp)                       :: umean                ! Depth-average of u-velocity component
    real(fp)                       :: ustmx
    real(fp)                       :: vmean                ! Depth-average of v-velocity component
    real(fp)                       :: wvltke               ! First estimate of typical wave length of the turbulence that excites IW's
    real(fp)                       :: xk                   ! Magnitude of horizntal wave number vector, in [m^-1]
    real(fp)                       :: xkh                  ! Non-dimensional XK
    real(fp)                       :: zlo                  ! Ozmidov length scale, depth-averaged over stratified layer
    real(fp)                       :: zzlu
    character(132)                 :: stage                ! Text string to define in which part of the calibration we are
!
!
!! executable statements -------------------------------------------------------
!
    !
    ag       => gdp%gdphysco%ag
    vonkar   => gdp%gdphysco%vonkar
    alfaz    => gdp%gdiwearr%alfaz
    xmu0     => gdp%gdiwearr%xmu0
    viscof   => gdp%gdiwearr%viscof
    nrange   => gdp%gdiwearr%nrange
    iwedia   => gdp%gdiwearr%iwedia
    !
    pi2 = 8.*atan(1.)
    !
    ! Initialise IWE-TKE exchange rates:
    !
    do k = 1, kmxt
       ttkiw(k) = 0.0
       tiwtk(k) = 0.0
    enddo
    do k = 1, kmax
       tkepro(k) = 0.0
       tkedis(k) = 0.0
    enddo
    !
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! IWE generation by turbulence implying internal       +
    ! re-distribution of TKE.                              +
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    !
    h0     = zeta + real(dps,fp)
    zzlu   = vonkar*h0/8
    wvltke = pi2*zzlu
    xk     = pi2/wvltke
    useref = .true.
    !
    call intpol(kmax      ,kmxdt     ,kmxt      ,h0        ,zeta      , &
              & dps       ,siglim    ,barcli    ,riav      ,rilz      , &
              & xk        ,u0        ,dudz      ,d2u0      ,ustbx     , &
              & ustwix    ,v0        ,dvdz      ,d2v0      ,ustby     , &
              & ustwiy    ,sig       ,thick     ,rich      ,bruvai    , &
              & rtur0     ,vicww     ,scale     ,bvav      ,bvmx      , &
              & xkh       ,kbed      ,ktop      ,umean     ,vmean     , &
              & utg       ,vtg       ,d2u       ,d2v       ,bv2       , &
              & tke       ,eps       ,edvis     ,zlw       ,tlw       , &
              & zlo       ,useref    ,gdp       )
    !
    hstrat = max(1, kbed - ktop)*h0/kmxt
    !
    ! Diagnostics
    !
    if (iwedia) then
       write (luniwe, *)
       write (luniwe, '(a)') '++++++++++++++++++++++++++++++++++'
       write (luniwe, '(a)') ' TAYLOR                          :'
       write (luniwe, '(a,1x,g9.2)') ' Mean Ri in layer             [-]:', riav
       write (luniwe, '(a,1x,g9.2)') ' Interval with Ri>0.25        [m]:', rilz
    endif
    !
    if (.not.barcli) then
       if (iwedia) write (luniwe, '(a)')                                        &
                     & ' TAYLOR                          : IWE model not applied'
       goto 9999
    else
       if (iwedia) then
          write (luniwe, '(a,1x,g9.2)') ' Upper level stratified layer [m]:',   &
                                      & h0*(1. - ktop/real(kmxt,sp))
          write (luniwe, '(a,1x,g9.2)') ' Lower level stratified layer [m]:',   &
                                      & h0*(1. - kbed/real(kmxt,sp))
          write (luniwe, '(a,1x,g9.2)') ' Thickness strat. layer       [m]:',   &
                                      & hstrat
          write (luniwe, '(a,1x,g9.2)') ' Mean Ozmidov length scale    [m]:',   &
                                      & zlo
          write (luniwe, '(a,1x,g9.2)') ' Minimal IW period            [s]:',   &
                                      & pi2/(bvav*bvmx)
       endif
       !
       ! IW vertical displacement amplitude and IWE-dissipation rate:
       !
       bz = hstrat/(xmu0*zlo)
       if (bz>1.01) then
          term   = 0.5*(1. - 1./(bz*bz))/log(bz)
          azmax  = hstrat*alfaz*sqrt(term)/pi2
          cs2    = 5.6
          factor = viscof*cs2*(bvav**2)*log(bz)*h0/kmxt
          !
          epsiwe = 0.0
          do ktg = 1, kmxt - 1
             if (ktop<=ktg .and. ktg<=kbed) then
                epsiwe = epsiwe + bv2(ktg)
             endif
          enddo
          epsiwe = epsiwe*factor
          !
          !
          if (iwedia) then
             write (luniwe, '(a,1x,g9.2)') &
                 & ' Maximal rms IWE Z-ampl.      [m]:', azmax
             write (luniwe, '(a,1x,g9.2)') &
                 & ' Bandwidth vertical wave numbers :', bz
             write (luniwe, '(a,1x,g9.2)') &
                 & ' Integral of IWE diss.  [m^3/s^3]:', epsiwe
          endif
       elseif (iwedia) then
          write (luniwe, '(a,1x,g9.2)') ' Bandwidth vertical wave numbers :', bz
          write (luniwe, '(2a       )')                                            &
                                & ' Therefore no bandwidth of vertical IWE modes', &
                                & ' inside stratified layer'
       else
       endif
    endif
    !
    ! Detect upper and lower critical layers:
    !
    call disper(kmxdt     ,kmxt      ,np        ,nfreqs    ,angle     , &
              & bvmx      ,freqlo    ,frequp    ,kcri      ,ncri      , &
              & sing      ,umean     ,vmean     ,atg       ,btg       , &
              & bv2       ,ctg       ,d2u       ,d2v       ,h0        , &
              & kbed      ,ktop      ,qz        ,r1tg      ,scale     , &
              & utg       ,vtg       ,xkh       ,gdp       )
    !
    !
    ! Find most upper and lowest levels with critical layers
    ! defined by:
    ! - KTGCU is KTG-level of highest critical layer
    !   (nearest to water surface)
    ! - KTGCD is KTG-level of lowest  critical layer
    !   (nearest to the bed)
    !
    ktgcu = kmxt
    ktgcd = 0
    ncrit = 0
    !
    nrd = 0
    nru = 0
    !
    do nr = 1, 2
       do ndir = 1, 2
          if (sing(nr, ndir)) then
             ncrit = ncrit + 1
             if (ktgcu>kcri(nr, ndir)) then
                ktgcu = kcri(nr, ndir)
                nru = nr
                nu = ncri(nr, ndir)
             endif
             if (ktgcd<kcri(nr, ndir)) then
                ktgcd = kcri(nr, ndir)
                nrd = nr
                nd = ncri(nr, ndir)
             endif
          endif
       enddo
    enddo
    !
    ! Upper most critical layer (ktgcu):
    !
    if (nru>0) then
       n      = nu
       nr     = nru
       top    = .true.
       frfind = .true.
       !
       stage  = ' Upper most critical layer, first step'
       !
       call zbrent(kmxdt     ,kmxt      ,omeg      ,angle     ,frfind    , &
                 & tgfind    ,stage     ,freqlo(n, nr)        ,frequp(n, nr)        ,atg       , &
                 & btg       ,bv2       ,ctg       ,crit      ,d2u       , &
                 & d2v       ,h0        ,kbed      ,ktop      ,qz        , &
                 & r1tg      ,scale     ,top       ,utg       ,vtg       , &
                 & xkh       ,luniwe    ,gdp       )
       !
       ! Force normalisation:
       !
       tgfind = .true.
       call tg(kmxdt     ,kmxt      ,angle     ,atg       ,btg       , &
             & bv2       ,ctg       ,crit      ,d2u       ,d2v       , &
             & h0        ,kbed      ,ktop      ,omeg      ,qz        , &
             & r1tg      ,scale     ,tgfind    ,top       ,utg       , &
             & vtg       ,xkh       ,gdp       )
       !
       !
       call seliwe(angle     ,kbed      ,ktop      ,kmxt      ,omeg      , &
                 & r1tg      ,utg       ,vtg       ,xkh       ,singul    , &
                 & top       ,kcrit     ,gdp       )
       !
       !
       if (singul .and. .not.top) then
          !
          stage = ' Upper most critical layer, second step'
          !
          call zbrent(kmxdt     ,kmxt      ,omeg      ,angle     ,frfind    , &
                    & tgfind    ,stage     ,freqlo(n, nr)        ,frequp(n, nr)        ,atg       , &
                    & btg       ,bv2       ,ctg       ,crit      ,d2u       , &
                    & d2v       ,h0        ,kbed      ,ktop      ,qz        , &
                    & r1tg      ,scale     ,top       ,utg       ,vtg       , &
                    & xkh       ,luniwe    ,gdp       )
          !
          ! Force normalisation:
          !
          tgfind = .true.
          call tg(kmxdt     ,kmxt      ,angle     ,atg       ,btg       , &
                & bv2       ,ctg       ,crit      ,d2u       ,d2v       , &
                & h0        ,kbed      ,ktop      ,omeg      ,qz        , &
                & r1tg      ,scale     ,tgfind    ,top       ,utg       , &
                & vtg       ,xkh       ,gdp       )
          !
          !
          call seliwe(angle     ,kbed      ,ktop      ,kmxt      ,omeg      , &
                    & r1tg      ,utg       ,vtg       ,xkh       ,singul    , &
                    & top       ,kcrit     ,gdp       )
       !
       !
       endif
       !
       ! Optional, correction on position upper most critical layer:
       !
       if (singul) ktgcu = min(ktgcu, kcrit)
       !
       call totiwe(kmxdt     ,kmxt      ,ratiou    ,singul    ,top       , &
                 & r1tg      ,h0        ,scale     ,kcrit     ,xkh       )
    endif
    !
    ! Lowest critical layer (ktgcd):
    !
    if (nrd>0) then
       n      = nd
       nr     = nrd
       top    = .true.
       frfind = .true.
       !
       stage  = ' Lowest critical layer, first step'
       !
       call zbrent(kmxdt     ,kmxt      ,omeg      ,angle     ,frfind    , &
                 & tgfind    ,stage     ,freqlo(n, nr)        ,frequp(n, nr)        ,atg       , &
                 & btg       ,bv2       ,ctg       ,crit      ,d2u       , &
                 & d2v       ,h0        ,kbed      ,ktop      ,qz        , &
                 & r1tg      ,scale     ,top       ,utg       ,vtg       , &
                 & xkh       ,luniwe    ,gdp       )
       !
       ! Force normalisation:
       !
       tgfind = .true.
       call tg(kmxdt     ,kmxt      ,angle     ,atg       ,btg       , &
             & bv2       ,ctg       ,crit      ,d2u       ,d2v       , &
             & h0        ,kbed      ,ktop      ,omeg      ,qz        , &
             & r1tg      ,scale     ,tgfind    ,top       ,utg       , &
             & vtg       ,xkh       ,gdp       )
       !
       !
       call seliwe(angle     ,kbed      ,ktop      ,kmxt      ,omeg      , &
                 & r1tg      ,utg       ,vtg       ,xkh       ,singul    , &
                 & top       ,kcrit     ,gdp       )
       !
       !
       if (singul .and. .not.top) then
          !
          stage = ' Lowest critical layer, second step'
          !
          call zbrent(kmxdt     ,kmxt      ,omeg      ,angle     ,frfind    , &
                    & tgfind    ,stage     ,freqlo(n, nr)        ,frequp(n, nr)        ,atg       , &
                    & btg       ,bv2       ,ctg       ,crit      ,d2u       , &
                    & d2v       ,h0        ,kbed      ,ktop      ,qz        , &
                    & r1tg      ,scale     ,top       ,utg       ,vtg       , &
                    & xkh       ,luniwe    ,gdp       )
          !
          ! Force normalisation:
          !
          tgfind = .true.
          call tg(kmxdt     ,kmxt      ,angle     ,atg       ,btg       , &
                & bv2       ,ctg       ,crit      ,d2u       ,d2v       , &
                & h0        ,kbed      ,ktop      ,omeg      ,qz        , &
                & r1tg      ,scale     ,tgfind    ,top       ,utg       , &
                & vtg       ,xkh       ,gdp       )
          !
          !
          call seliwe(angle     ,kbed      ,ktop      ,kmxt      ,omeg      , &
                    & r1tg      ,utg       ,vtg       ,xkh       ,singul    , &
                    & top       ,kcrit     ,gdp       )
       !
       !
       endif
       !
       ! Optional correction on position lowest critical layer:
       !
       if (singul) ktgcd = max(ktgcd, kcrit)
       !
       call totiwe(kmxdt     ,kmxt      ,ratiod    ,singul    ,top       , &
                 & r1tg      ,h0        ,scale     ,kcrit     ,xkh       )
    endif
    !
    ! In case of turbulence-generated critical layers:
    !
    if (ncrit>=2) then
       ktgcu  = max(1, ktgcu)
       ktgcd  = min(kmxt - 1, ktgcd)
       !ratiow = SQRT (ratiod*ratiou)
       ratiow = 2.0
       call turiwe(kmxdt     ,kmxt      ,h0        ,scale     ,bvav      , &
                 & xkh       ,utg       ,vtg       ,ratiow    ,kbed      , &
                 & ktop      ,ktgcd     ,ktgcu     ,tke       ,zlw       , &
                 & tlw       ,ttkiw     ,tiwtk     ,luniwe    ,gdp       )
    !
    !
    ! Without turbulence-generated critical layers:
    !
    else
       ktgcu  = ktop
       ktgcd  = kbed
       ratiow = 2.0
       call turiwe(kmxdt     ,kmxt      ,h0        ,scale     ,bvav      , &
                 & xkh       ,utg       ,vtg       ,ratiow    ,kbed      , &
                 & ktop      ,ktgcd     ,ktgcu     ,tke       ,zlw       , &
                 & tlw       ,ttkiw     ,tiwtk     ,luniwe    ,gdp       )
       !
       if (iwedia) write (luniwe, '(a)') ' No turb.-gen. crit. layers      '
    endif
    !
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! IWE generation by bed topograhy; using               +
    ! zero reference velocity                              +
    ! minimal velocity for notable wave generation set at  +
    ! 1 [cm/s]/15, see below:                              +
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    !
    umag  = ustbx*ustbx + ustby*ustby
    umag  = sqrt(umag)
    ustmx = 0.01/15.
    if (frcbed<1E-10 .or. umag<ustmx) goto 300
    !
    xk     = pi2/wvlbed
    useref = .false.
    !
    call intpol(kmax      ,kmxdt     ,kmxt      ,h0        ,zeta      , &
              & dps       ,siglim    ,barcli    ,riav      ,rilz      , &
              & xk        ,u0        ,dudz      ,d2u0      ,ustbx     , &
              & ustwix    ,v0        ,dvdz      ,d2v0      ,ustby     , &
              & ustwiy    ,sig       ,thick     ,rich      ,bruvai    , &
              & rtur0     ,vicww     ,scale     ,bvav      ,bvmx      , &
              & xkh       ,kbed      ,ktop      ,umean     ,vmean     , &
              & utg       ,vtg       ,d2u       ,d2v       ,bv2       , &
              & tke       ,eps       ,edvis     ,zlw       ,tlw       , &
              & zlo       ,useref    ,gdp       )
    !
    !
    ! Bracketing of angle intervals with lee waves i.e. with OMEG=0,
    ! the relevant angle intervals are stored in FREQLO(N,1) and FREQUP(N,1).
    !
    call brkbed(kmxdt     ,kmxt      ,np        ,nfreqs    ,atg       , &
              & btg       ,bv2       ,ctg       ,d2u       ,d2v       , &
              & h0        ,kbed      ,ktop      ,qz        ,r1tg      , &
              & scale     ,tgfind    ,utg       ,vtg       ,xkh       , &
              & freqlo    ,frequp    ,luniwe    ,gdp       )
    !
    !
    if (.not.tgfind) goto 300
    !
    ! Start from last bracketed angle interval (phase speed most
    ! oppposite to currebt speed) and search for solution which is either:
    ! - non-singular or, if singular,
    ! - has critical layer from bed upwards.
    !
    nr = 1
    n = 0
    !
  310 continue
    n      = n + 1
    top    = .false.
    frfind = .false.
    !
    stage  = ' Lee wave'
    !
    call zbrent(kmxdt     ,kmxt      ,omeg      ,angle     ,frfind    , &
              & tgfind    ,stage     ,freqlo(n, nr)        ,frequp(n, nr)        ,atg       , &
              & btg       ,bv2       ,ctg       ,crit      ,d2u       , &
              & d2v       ,h0        ,kbed      ,ktop      ,qz        , &
              & r1tg      ,scale     ,top       ,utg       ,vtg       , &
              & xkh       ,luniwe    ,gdp       )
    !
    ! Force normalisation:
    !
    tgfind = .true.
    call tg(kmxdt     ,kmxt      ,angle     ,atg       ,btg       , &
          & bv2       ,ctg       ,crit      ,d2u       ,d2v       , &
          & h0        ,kbed      ,ktop      ,omeg      ,qz        , &
          & r1tg      ,scale     ,tgfind    ,top       ,utg       , &
          & vtg       ,xkh       ,gdp       )
    !
    !
    call seliwe(angle     ,kbed      ,ktop      ,kmxt      ,omeg      , &
              & r1tg      ,utg       ,vtg       ,xkh       ,singul    , &
              & top       ,kcrit     ,gdp       )
    !
    !
    if (top .and. n<nrange) goto 310
    if (top) then
       write (luniwe, '(a)') 'TAYLOR : no bed-generated IW?'
    else
       !
       call bediwe(kmax      ,kmxdt     ,kmxt      ,h0        ,scale     , &
                 & bvav      ,xkh       ,angle     ,singul    ,kbed      , &
                 & ktop      ,kcrit     ,thick     ,ustbx     ,ustby     , &
                 & d2u       ,d2v       ,dudz      ,dvdz      ,utg       , &
                 & vtg       ,frcbed    ,edvis     ,qz        ,r1tg      , &
                 & dijdij    ,ttkiw     ,tiwtk     ,az        ,atg       , &
                 & btg       ,luniwe    ,gdp       )
    !
    !
    endif
    !
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! IWE generation by surface perturbations.             +
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    !
  300 continue
    umag = ustwix*ustwix + ustwiy*ustwiy
    umag = sqrt(umag)
    if (frcsur<1E-10 .or. umag<1.E-6) goto 400
    !
    xk = pi2/wvlsur
    useref = .true.
    !
    call intpol(kmax      ,kmxdt     ,kmxt      ,h0        ,zeta      , &
              & dps       ,siglim    ,barcli    ,riav      ,rilz      , &
              & xk        ,u0        ,dudz      ,d2u0      ,ustbx     , &
              & ustwix    ,v0        ,dvdz      ,d2v0      ,ustby     , &
              & ustwiy    ,sig       ,thick     ,rich      ,bruvai    , &
              & rtur0     ,vicww     ,scale     ,bvav      ,bvmx      , &
              & xkh       ,kbed      ,ktop      ,umean     ,vmean     , &
              & utg       ,vtg       ,d2u       ,d2v       ,bv2       , &
              & tke       ,eps       ,edvis     ,zlw       ,tlw       , &
              & zlo       ,useref    ,gdp       )
    !
    !
    ! Loop until IW is found which is either non-singular or
    ! singular with critical layer extending down from water surface:
    !
    frup = bvmx
    delf = bvmx/nfreqs
  410 continue
    call brksur(kmxdt     ,kmxt      ,nfreqs    ,angle     ,atg       , &
              & btg       ,bv2       ,ctg       ,d2u       ,d2v       , &
              & h0        ,kbed      ,ktop      ,qz        ,r1tg      , &
              & scale     ,tgfind    ,utg       ,vtg       ,xkh       , &
              & ustwix    ,ustwiy    ,frlo      ,frup      ,bvmx      , &
              & luniwe    ,gdp       )
    !
    !
    top = .true.
    frfind = .true.
    !
    stage = ' Wind-generated internal waves'
    !
    call zbrent(kmxdt     ,kmxt      ,omeg      ,angle     ,frfind    , &
              & tgfind    ,stage     ,frlo      ,frup      ,atg       , &
              & btg       ,bv2       ,ctg       ,crit      ,d2u       , &
              & d2v       ,h0        ,kbed      ,ktop      ,qz        , &
              & r1tg      ,scale     ,top       ,utg       ,vtg       , &
              & xkh       ,luniwe    ,gdp       )
    !
    ! Force normalisation:
    !
    tgfind = .true.
    call tg(kmxdt     ,kmxt      ,angle     ,atg       ,btg       , &
          & bv2       ,ctg       ,crit      ,d2u       ,d2v       , &
          & h0        ,kbed      ,ktop      ,omeg      ,qz        , &
          & r1tg      ,scale     ,tgfind    ,top       ,utg       , &
          & vtg       ,xkh       ,gdp       )
    !
    !
    call seliwe(angle     ,kbed      ,ktop      ,kmxt      ,omeg      , &
              & r1tg      ,utg       ,vtg       ,xkh       ,singul    , &
              & top       ,kcrit     ,gdp       )
    !
    !
    if (frlo>delf .and. .not.top) then
       frup = frlo
       goto 410
    elseif (.not.top) then
       write (luniwe, '(a)') 'TAYLOR : no wind-generated IW ?'
    else
       !
       call suriwe(kmax      ,kmxdt     ,kmxt      ,h0        ,scale     , &
                 & bvav      ,xkh       ,angle     ,omeg      ,singul    , &
                 & kbed      ,ktop      ,kcrit     ,wsp10     ,ustwix    , &
                 & ustwiy    ,utg       ,vtg       ,frcsur    ,edvis     , &
                 & qz        ,r1tg      ,dijdij    ,ttkiw     ,tiwtk     , &
                 & az        ,atg       ,btg       ,luniwe    ,gdp       )
    !
    !
    endif
    !
    !
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! The collected transfer rates are redistributed along +
    ! the DPM grid and used in TRATUR for the k-e model:   +
    !                                                      +
    ! Currently, the momentum fluxes/forces FUTG-FUIWE     +
    ! and FVTG-FVIWE are not yet installed.                +
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++
    !
  400 continue
    call distri(ttkiw     ,tiwtk     ,tkepro    ,tkedis    ,futg      , &
              & fvtg      ,fuiwe     ,fviwe     ,h0        ,thick     , &
              & bv2       ,ktop      ,kbed      ,kmax      ,kmxdt     , &
              & kmxt      ,luniwe    ,gdp       )
              !
              !
 9999 continue
end subroutine taylor


!*******************************************************************
!> author: Akira Kageyama
!  license: MIT
!  date: 2020.01.22
!
!  断面データの作成とディスクへの出力
!
!  書き出されたデータはslice_grapherディレクトリにあるプログラムで
!  可視化される。
!
!  @note
!    ここで書き出す断面データは単精度浮動小数点数である。可視化には
!    単精度で十分である。
!
!  @note
!    サブルーチンmake_single_precision_fieldでは
!    fieldモジュールで定義されたcurlを計算するルーチンを呼び出している。
!    ここで.curl.などの演算子を使うと記述が簡潔になるが、
!    現在はこれをコメントアウトしている。Fortranコンパイラが
!    自己定義演算子を問題なく使えるのであれば
!    .curl.などを使うようにコメントを外せばよい。
!    詳しくはfieldモジュールを見よ。

module slicedata_m
  use ut_m      ! ユーティリティ。constantsモジュールは間接的にuseされる
  use field_m   ! 流体場
  use params_m  ! パラメータ
  use debug_m   ! デバッグ関係
  use solver_m  ! ナビエ・ストークス方程式ソルバ
  implicit none ! 暗黙の型宣言無効化。必須
  private ! このモジュール内の変数・ルーチン等はデフォルトで非公開
  public :: slicedata__initialize,  &
            slicedata__write

  ! 2次元単精度実数配列
  real(SR), dimension(:,:), allocatable :: Slice_vx  ! 速度のx成分
  real(SR), dimension(:,:), allocatable :: Slice_vy  ! 速度のy成分
  real(SR), dimension(:,:), allocatable :: Slice_vz  ! 速度のz成分
  real(SR), dimension(:,:), allocatable :: Slice_ps  ! 圧力
  real(SR), dimension(:,:), allocatable :: Slice_en  ! エンストロフィ
                             ! Enstrophy とは渦度の二乗
                             ! 渦度は速度のcurl

  logical, save :: Initialize_done = .false.    ! モジュール初期化済か否か
  integer(SI), parameter :: FILE_SLICEDATA = 20 ! 断面データ出力ファイル番号

contains

  subroutine make_single_precision_field(vel,ps)
    !! シミュレーションで計算した速度場と圧力場
    !! のx-z平面での断面データを求める。
    !! その際、倍精度実数から単精度実数に型変換する。
    !!
    !! ここではx-z平面で書き出しているが、
    !! x-y平面での断面データなど、同様にとることが可能である。
    !!
    !! サブルーチンmake_single_precision_fieldでは
    !! x-z面に平行な断面をとっている。その際、
    !! その断面位置は
    !!     j = slice_j = NY / 2
    !! としている。NYが偶数の時、
    !! この断面は厳密に言えばy=0にはなっていない。
    !! なぜならgridモジュールできめたy方向の格子点の
    !! 定義によればy=0の面はj=NY/2とj=NY/2+1の2つの面
    !! の中間にあるからである。正確にy=0面上での可視化
    !! をしたいのであればこの2つの面上でのデータ
    !! の平均値をディスクに書き出すべきである。
    !!
    !! [バグ]
    !!   NYが奇数のときにちょうどy=0面に対応するのは
    !!     j = slice_j = NY / 2 + 1
    !!   である。偶数のときにもこれでよい。
    type(field__vector3d_t),       intent(in) :: vel !! 速度場（3D）
    real(DR), dimension(NX,NY,NZ), intent(in) :: ps  !! 圧力場（3D）

    integer(SI) :: slice_j = NY / 2    ! 断面をとるy座標の格子点位置

    type(field__vector3d_t)       :: vor       ! vorticity、渦度
    real(DR), dimension(NX,NY,NZ) :: enstrophy ! 渦度の2乗

!>        vor = .curl.vel
!>  enstrophy = vor.dot.vor
          vor = operator_curl(vel)
    enstrophy = operator_dot_product(vor,vor)

    Slice_vx = real(    vel%x(:,slice_j,:),SR)
    Slice_vy = real(    vel%y(:,slice_j,:),SR)
    Slice_vz = real(    vel%z(:,slice_j,:),SR)
    Slice_ps = real(       ps(:,slice_j,:),SR)
    Slice_en = real(enstrophy(:,slice_j,:),SR)

    call debug__print('called slicedata/make_single_precision_field.')
      ! デバッグモードがonの時には毎回メッセージを標準出力に
      ! 書き出す。コードが完成し、product runの段階に入ったら
      ! デバッグモードをoffにすれば、書き出しは抑制される。
      ! この行をコメントアウトする必要はない。
  end subroutine make_single_precision_field

!
! Private  これより上が非公開の関数・ルーチン
!===================================================
! Public   これより下が公開する関数・ルーチン
!

  subroutine slicedata__initialize
    !! このモジュールの初期化
    !!
    !! 流体の場（fluid）の配列は決め打ち（つまりallocatableにしない）で
    !! 最初から3次元配列を確保している一方、ここではSlice_??配列を
    !! アロケータブルにしているのは、このslicedataモジュールは
    !! シミュレーションには必須ではないためである。
    !! 場合によってはこのslicedataモジュールを使わずに
    !! シュミレーションすることも考えられる。
    !! 例えば断面ではなく三次元の可視化をする時など。
    !! そのような場合は、このslicedataモジュールは実際には
    !! 呼びたさないであろう。そのような時に備えて以下のように
    !! allocatableにしておけばメモリーを無駄遣いしない。
    allocate(Slice_vx(NX,NZ),   &
             Slice_vy(NX,NZ),   &
             Slice_vz(NX,NZ),   &
             Slice_ps(NX,NZ),   &
             Slice_en(NX,NZ))

    call debug__print('Slice data allocated.')
      ! デバッグモードがonの時には毎回メッセージを標準出力に
      ! 書き出す。コードが完成し、product runの段階に入ったら
      ! デバッグモードをoffにすれば、書き出しは抑制される。
      ! この行をコメントアウトする必要はない。

    open(FILE_SLICEDATA,                                &
         file=trim(params__get_string('Slicedata_tag')),  &
         form='unformatted')
      ! 断面データを書き出すファイルをオープン

    Initialize_done = .true.  ! 初期化終了のフラグをonにする

    call debug__print('called slicedata__initlilize')
  end subroutine slicedata__initialize

  subroutine slicedata__write(nloop,time,fluid)
    !! 断面データのディスクへの書き出し
    integer(DI),          intent(in) :: nloop !! 現在のループカウンタ
    real(DR),             intent(in) :: time  !! 現在の時刻
    type(field__fluid_t), intent(in) :: fluid !! 現在の流体データ

    type(field__vector3d_t) :: vel
      ! 流れ速度ベクトル場。いまはナビエ・ストークス方程式の
      ! 基本変数を質量フラックスにしているのでこの流れ速度
      ! ベクトル場は基本変数ではなく、基本変数から計算される
      ! 二次的な量である。

    if ( params__get_integer('Slicedata_nskip') <= 0 ) return
                                      ! 何らかの理由で断面データの
                                      ! 出力をしないときには
                                      ! parameter中のSlicedata_nskip
                                      ! の値を負にする。

    if ( mod(nloop,params__get_integer('Slicedata_nskip')) /= 0 ) return
                                      ! parameter中のSlicedata_nskip
                                      ! の値が例えば10の時には
                                      ! 10ステップおきに断面データを計算し、
                                      ! ディスクに書き出す。

    call ut__assert(Initialize_done,"<slicedata__write> Forgot init?")
                                      ! モジュールの初期化終了確認

    call solver__get_subfield(fluid,vel)
                                      ! 流体の基本変数から速度場を求める

    call make_single_precision_field(vel,fluid%pressure)
                                      ! 断面データを作成

    write(FILE_SLICEDATA) nloop, real(time,SR),  &
                          Slice_vx, Slice_vy, Slice_vz,  &
                          Slice_ps, Slice_en
                                      ! ディスクへの書き出し
                                      ! 時刻も単精度に変換している

    call ut__message('#slice data saved at ', nloop, time)
                                      ! ここはデバッグモードがoffでも
                                      ! 書き出すようにしている。
                                      ! 断面データはそれほど頻繁に
                                      ! 書き出さない（この行まで到達しない）
                                      ! のでこの出力がたくさんあって
                                      ! 邪魔になることはあまりないと
                                      ! 予想できるためである。
    call debug__print('called slicedata__write.')
  end subroutine slicedata__write

end module slicedata_m


C$Procedure  MAXAD  ( Maximum element of array, DP )

      SUBROUTINE MAXAD ( ARRAY, NDIM, MAXVAL, LOC )

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

      DOUBLE PRECISION      ARRAY ( * )
      INTEGER               NDIM
      DOUBLE PRECISION      MAXVAL
      INTEGER               LOC

C$ Brief_I/O
C
C      VARIABLE  I/O           DESCRIPTION
C      --------  ---  -------------------------------------------------
C      ARRAY      I   Array.
C      NDIM       I   Number of elements in ARRAY.
C      MAXVAL     O   Maximum value in ARRAY.
C      LOC        O   Location of MAXVAL in ARRAY.
C
C$ Detailed_Input
C
C      ARRAY       is an arbitrary array.
C
C      NDIM        is the number of elements in ARRAY.
C
C$ Detailed_Output
C
C      MAXVAL      is the value in array that is greater than or equal
C                  to all other values in the array. If the array
C                  contains more than one element with this value,
C                  the first one is returned.
C
C                  Elements in character arrays are compared according
C                  to the ASCII collating sequence.
C
C      LOC         is the location of the maximum element. That is,
C                  MAXVAL contains element ARRAY(LOC).
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the array is empty (NDIM is less than one), LOC is zero, and
C        MAXVAL is not changed.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C      None.
C
C$ Examples
C
C      Let array A contain the following elements.
C
C         A(1) = 16.D0
C         A(2) =  4.D0
C         A(3) = 32.D0
C         A(4) = 64.D0
C         A(5) =  2.D0
C         A(6) =  8.D0
C
C      Then following the call
C
C         CALL MAXAD ( A, 6, MAXVAL, LOC )
C
C      the values of MAXVAL and LOC are 64.D0 and 4 respectively.
C
C$ Restrictions
C
C      None
C
C$ Author_and_Institution
C
C      I.M. Underwood  (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU)
C
C-&

C$ Index_Entries
C
C     maximum element of d.p. array
C
C-&

C$ Revisions
C
C-     Beta Version 1.0.1, 2-FEB-1989 (IMU)
C
C         Missing header sections completed.
C
C-&

C
C     Local variables
C
      INTEGER I

      IF (NDIM .LE. 0) THEN
         LOC = 0
         RETURN
      END IF

      MAXVAL = ARRAY(1)
      LOC = 1

      DO I = 2, NDIM
         IF (ARRAY(I) .GT. MAXVAL) THEN
            MAXVAL = ARRAY(I)
            LOC = I
         END IF
      END DO

      RETURN
      END


! The goal of this test case is to check that all basic reduction operators
! are well printed by the pips prettyprinter. All the loops in the programm
! should be parallelized with an omp reduction pragma.

      program parallel
      REAL x, y
      INTEGER j, k
      LOGICAL m, o
      do i = 1, n
         s = s + 1
      end do
      do i = 1, n
         s = s - 1
      end do
      do i = 1, n
         s = s * 2
      end do
      do i = 1, n
         m = m.AND.o
      end do
      do i = 1, n
         m = m.OR.o
      end do
      do i = 1, n
         m = m.EQV.o
      end do
      do i = 1, n
         m = m.NEQV.o
      end do
      do i = 1, n
         y = MAX(y,x)
      end do
      do i = 1, n
         y = MIN(y,x)
      end do
!     do i = 1, n
!     k = IAND(k,j)
!     end do
!     do i = 1, n
!     k = IOR(k,j)
!     end do
!     do i = 1, n
!     k = IEOR(k,j)
!     end do
      end


      SUBROUTINE AGCAP(I1,I2,I3,I4,I5,I6,I7,I8)
!     AGCAP PERFORMS AGC (AUTOMATIC GAIN CONTROL) USING THE VFC OF THE FPS AP.
!  AGC SCALES THE DATA SUCH THAT EACH OUTPUT WINDOW HAS THE SAME AVERAGE
!  ABSOLUTE AVERAGE.
!
!  ARGUMENTS:
!    I1 - IN     - THE AP ADDRESS OF THE INPUT ARRAY.
!    I2 - NADD   - THE NUMBER OF SAMPLES TO SKIP FROM IN BECAUSE THEY ARE DEAD.
!    I3 - WINLEN - THE NUMBER OF SAMPLES IN EACH WINDOW.
!    I4 - OUT    - THE AP ADDRESS OF THE OUTPUT ARRAY.
!    I5 - NOUT   - THE NUMBER OF VALUES TO OUTPUT (ALSO THE LENGTH OF THE INPUT).
!    I6 - PARAMS - THE AP ADDRESS OF 3 VARIABLES THAT MUST BE SET IN TH AP BY
!                  THE CALLING PROGRAM.
!                +0 - 1./WINLEN
!                +1 - A SMALL NUMBER TO PREVENT DIVIDE BY ZEROES
!                +2 - THE OUTPUT WINDOW LEVEL (AVERAGE ABSOLUTE VALUE)
!    I7 - SCR1   - THE AP ADDRESS OF A SCRATCH ARRAY NOUT LONG.
!    I8 - SCR2   - THE AP ADDRESS OF A SECOND SCRATCH ARRAY NOUT LONG.
!
!  WRITTEN AND COPYRIGHTED BY:
!  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, 2 JANUARY 1980
!  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
!  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
!
      IMPLICIT INTEGER*2(B-Z)
      IN=I1
      NADD=I2
      WINLEN=I3
      OUT=I4
      NOUT=I5
      PARAMS=I6
      SCR1=I7
      SCR2=I8
      WINL2=WINLEN/2
      N=NOUT-NADD
      N=N-WINLEN                                                        ! THE NUMBER OF WINDOWS IN THE TRACE
      ISTART=IN+NADD                                                    ! THE FIRST LIVE VALUE IN THE TRACE
      I=0
10    CALL SVEMG(ISTART,1,SCR1,WINLEN)                                  ! CALCULATE THE SUM OF THE MAGNITUDES
      I=I+1
      ISTART=ISTART+1
      SCR1=SCR1+1                                                       ! PUT THE NEXT RESULT IN THE NEXT AP LOCATION
      IF(I.LT.N) GO TO 10
      SCR1=I7                                                           ! THE BEGINNING OF THE SCRATCH ARRAY
      CALL VSMUL(SCR1,1,PARAMS,SCR1,1,N)                                ! DIVIDE THE BY N TO MAKE IT THE AVE
      IADD=PARAMS+1
      OLEVEL=PARAMS+2
      CALL VFILL(OLEVEL,SCR2,1,N)                                       ! MAKE A VECTOR OF THE OUTPUT LEVELS
      CALL VSADD(SCR1,1,IADD,SCR1,1,N)                                  ! MAKE SURE WE DON'T DIVIDE BY ZERO
      CALL VDIV(SCR1,1,SCR2,1,SCR1,1,N)                                 ! DIVIDE THE OLEVEL BY THE AVERAGE
      M=NADD+WINL2
      CALL VFILL(SCR1,SCR2,1,M)
      NEXT=SCR2+M
      CALL VMOV(SCR1,1,NEXT,1,N)                                        ! MOVE THE MULTIPLIERS
      LAST=SCR1+N
      LAST=LAST-1
      NEXT=NEXT+N
      CALL VFILL(LAST,NEXT,1,WINL2)                                     ! FILL THE LAST HALF OF THE LAST WINDOW
      CALL VMUL(SCR2,1,IN,1,OUT,1,NOUT)
      RETURN
      END


      PROGRAM WRITEVOXEL

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*  COLUMNS: FROM LEFT TO RIGHT
*  ROWS: FROM BACK TO FRONT
*  SLICES: FROM TOP TO BOTTOM
* Voxel Mesh Parameters
* - bin size [cm] along X => DX
* - bin size [cm] along Y => DY
* - bin size [cm] along Z => DZ
      PARAMETER ( DX = 0.1D-01 )
      PARAMETER ( DY = 0.1D-01 )
      PARAMETER ( DZ = 0.1D-01 )
* Voxel Mesh Parameters
* - number of bin along X => NX
* - number of bin along Y => NY
* - number of bin along Z => NZ
      PARAMETER ( NX = 10 )
      PARAMETER ( NY = 10 )
      PARAMETER ( NZ = 10 )

      DIMENSION MYARRAY(NX,NY,NZ)
      INTEGER*2 MYARRAY
      DIMENSION VXL(NX,NY,NZ)
      INTEGER*2 VXL
      CHARACTER TITLE*80
      DIMENSION IREG(1000), KREG(1000)
      INTEGER*2 IREG, KREG
*
      CALL CMSPPR
      DO IC = 1, 1000
         KREG(IC) = 0
      END DO
      OPEN(UNIT=30,FILE='ascii_file.dat',STATUS='OLD')
      READ(30,*) MYARRAY
      NO=0
      MO=0
      DO IZ=1,NZ
         DO IY=1,NY
            DO IX=1,NX
               IF (MYARRAY(IX,IY,IZ) .GT. 0) THEN
                  IO = MYARRAY(IX,IY,IZ)
                  VXL(IX,IY,IZ) = IO
                  MO = MAX (MO,IO)
                  DO IR=1,NO
                     IF (IREG(IR) .EQ. IO) GO TO 1000
                  END DO
                  NO=NO+1
                  IREG(NO)=IO
                  KREG(IO)=NO
                  WRITE(*,'(A,2I10)')'organ_index, voxel_number', IO, NO
 1000             CONTINUE
               END IF
            END DO
         END DO
      END DO
*     NO = number of different organs
*     MO = max. organ number before compacting
      WRITE(*,*) ' NO,MO',NO,MO
      OPEN(UNIT=31,FILE='target.vxl',STATUS='UNKNOWN',
     c     FORM='UNFORMATTED')
      TITLE = 'Dummy Voxel'
      WRITE(31) TITLE
      WRITE(31) NX,NY,NZ,NO,MO
      WRITE(31) DX,DY,DZ
      WRITE(31) VXL
      WRITE(31) (KREG(IC),IC=1,MO)
      STOP
      END


C Copyright (C) 2009 Sandia Corporation.  Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of Sandia Corporation nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: mxmult.f,v 1.3 1993/07/16 22:50:49 gdsjaar Exp $
C $Log: mxmult.f,v $
C Revision 1.3  1993/07/16 22:50:49  gdsjaar
C Unrolled loops for faster execution
C
c Revision 1.2  1993/07/16  19:14:19  gdsjaar
c Restructured to optimize faster
c
c Revision 1.1  1993/07/16  16:47:35  gdsjaar
c Changed plt to library rather than single source file.
c
C=======================================================================
      SUBROUTINE MXMULT(N,MAT1,MAT2,MATR)
      REAL MAT1(N,*),MAT2(N,*),MATR(N,*)

      IF (N .EQ. 4) THEN
          MATR(1,1) = MAT1(1,1)*MAT2(1,1) + MAT1(1,2)*MAT2(2,1) +
     *                MAT1(1,3)*MAT2(3,1) + MAT1(1,4)*MAT2(4,1)
          MATR(1,2) = MAT1(1,1)*MAT2(1,2) + MAT1(1,2)*MAT2(2,2) +
     *                MAT1(1,3)*MAT2(3,2) + MAT1(1,4)*MAT2(4,2)
          MATR(1,3) = MAT1(1,1)*MAT2(1,3) + MAT1(1,2)*MAT2(2,3) +
     *                MAT1(1,3)*MAT2(3,3) + MAT1(1,4)*MAT2(4,3)
          MATR(1,4) = MAT1(1,1)*MAT2(1,4) + MAT1(1,2)*MAT2(2,4) +
     *                MAT1(1,3)*MAT2(3,4) + MAT1(1,4)*MAT2(4,4)

          MATR(2,1) = MAT1(2,1)*MAT2(1,1) + MAT1(2,2)*MAT2(2,1) +
     *                MAT1(2,3)*MAT2(3,1) + MAT1(2,4)*MAT2(4,1)
          MATR(2,2) = MAT1(2,1)*MAT2(1,2) + MAT1(2,2)*MAT2(2,2) +
     *                MAT1(2,3)*MAT2(3,2) + MAT1(2,4)*MAT2(4,2)
          MATR(2,3) = MAT1(2,1)*MAT2(1,3) + MAT1(2,2)*MAT2(2,3) +
     *                MAT1(2,3)*MAT2(3,3) + MAT1(2,4)*MAT2(4,3)
          MATR(2,4) = MAT1(2,1)*MAT2(1,4) + MAT1(2,2)*MAT2(2,4) +
     *                MAT1(2,3)*MAT2(3,4) + MAT1(2,4)*MAT2(4,4)

          MATR(3,1) = MAT1(3,1)*MAT2(1,1) + MAT1(3,2)*MAT2(2,1) +
     *                MAT1(3,3)*MAT2(3,1) + MAT1(3,4)*MAT2(4,1)
          MATR(3,2) = MAT1(3,1)*MAT2(1,2) + MAT1(3,2)*MAT2(2,2) +
     *                MAT1(3,3)*MAT2(3,2) + MAT1(3,4)*MAT2(4,2)
          MATR(3,3) = MAT1(3,1)*MAT2(1,3) + MAT1(3,2)*MAT2(2,3) +
     *                MAT1(3,3)*MAT2(3,3) + MAT1(3,4)*MAT2(4,3)
          MATR(3,4) = MAT1(3,1)*MAT2(1,4) + MAT1(3,2)*MAT2(2,4) +
     *                MAT1(3,3)*MAT2(3,4) + MAT1(3,4)*MAT2(4,4)

          MATR(4,1) = MAT1(4,1)*MAT2(1,1) + MAT1(4,2)*MAT2(2,1) +
     *                MAT1(4,3)*MAT2(3,1) + MAT1(4,4)*MAT2(4,1)
          MATR(4,2) = MAT1(4,1)*MAT2(1,2) + MAT1(4,2)*MAT2(2,2) +
     *                MAT1(4,3)*MAT2(3,2) + MAT1(4,4)*MAT2(4,2)
          MATR(4,3) = MAT1(4,1)*MAT2(1,3) + MAT1(4,2)*MAT2(2,3) +
     *                MAT1(4,3)*MAT2(3,3) + MAT1(4,4)*MAT2(4,3)
          MATR(4,4) = MAT1(4,1)*MAT2(1,4) + MAT1(4,2)*MAT2(2,4) +
     *                MAT1(4,3)*MAT2(3,4) + MAT1(4,4)*MAT2(4,4)

      ELSE

        DO 230 K = 1,N
          DO 200 J = 1,N
            MATR(K,J) = 0.0
 200      CONTINUE
          DO 220 I = 1,N
            DO 210 J = 1,N
              MATR(K,J) = MATR(K,J) + MAT1(K,I)*MAT2(I,J)
 210        CONTINUE
 220      CONTINUE
 230    CONTINUE
      END IF
      RETURN
      END


c=======================================================================
c
c     subroutine CHTMCM
c
c     Computes the mean of each column of a vectorized matrix
c     with a poor historic (some unknown - "unborn" in fact - values
c     at the beginning of historic only)
c
c-----------------------------------------------------------------------
      SUBROUTINE chtmcm ( nlmat, ncmat, mat, hole, ages, vect, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            nlmat  : number of rows (= number of dates)
c                     of the matrix mat                          integer
c            ncmat  : number of columns of the matrix mat
c                     (= number of assets)                       integer
c            mat    : matrix as vector (nlmat*ncmat)              double
c            hole   : stands for unknown value                    double
c            ages   : vector (ncmat) of "ages of the assets
c                     (=nb of known values in the historic)      integer
c
c     OUTPUT
c            vect   : mean of each column, vector(ncmat)          double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER nlmat, ncmat, info, ages(*)
      DOUBLE PRECISION hole, mat(nlmat,*), vect(*)
c
c     local variables
      INTEGER j, k, ind1st
      DOUBLE PRECISION sum, eps
      PARAMETER( eps = 1.E-5 )
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
      DO j = 1,ncmat
         IF (ages(j) .LT. 1) THEN
            info = -2
            RETURN
         ENDIF
         ind1st = nlmat-ages(j) + 1
c
c        sum
         sum = 0.
         DO k = ind1st,nlmat
            IF (      (mat(k,j) .GE. hole - eps)
     &          .and. (mat(k,j) .LE. hole + eps)) THEN
c
c              hole value
               info = -4005
               RETURN
            ENDIF
            sum = sum + mat(k,j)
         ENDDO
         vect(j) = sum / (ages(j))
      ENDDO
c
      RETURN
      END


     program demo_elips
     use M_calcomp, only : plots, plot, newpen, factor, nframe, elips
     implicit none
     character(len=:),allocatable :: lines(:)
     integer                  :: i
     real                     :: x, y
     real                     :: a
     real                     :: major_axis_length, minor_axis_length
     real                     :: start_angle, finish_angle
     integer                  :: ipen
     integer,parameter        :: END=999, MOVE=3, DRAW=2
     lines=[character(len=80) :: &
     '#---------------------------------------------------------------------#-',&
     '#  move over in the x direction the same amount you change axis length  ',&
     '#---------#---------#---------#---------#---------#---------#---------#-',&
     '|6.5      !8.0      !0.5      !0.7      ! 0.0     ! 0.0     ! 360.0   !3',&
     '|6.6      !8.0      !0.6      !0.6      ! 0.0     ! 0.0     ! 360.0   !3',&
     '|6.7      !8.0      !0.7      !0.5      ! 0.0     ! 0.0     ! 360.0   !3',&
     '|6.8      !8.0      !0.8      !0.4      ! 0.0     ! 0.0     ! 360.0   !3',&
     '|6.9      !8.0      !0.9      !0.3      ! 0.0     ! 0.0     ! 360.0   !3',&
     '|7.0      !8.0      !1.0      !0.2      ! 0.0     ! 0.0     ! 360.0   !3',&
     '#---------#---------#---------#---------#---------#---------#---------#-',&
     '#  different end angles of different signs                              ',&
     '#---------#---------#---------#---------#---------#---------#---------#-',&
     '|5.0      !8.0      !1.0      !0.2      ! 0.0     ! 0.0     !  45.0   !3',&
     '|3.0      !8.0      !1.0      !0.2      ! 0.0     ! 0.0     ! -60.0   !3',&
     '#---------#---------#---------#---------#---------#---------#---------#-',&
     '# circles                                                               ',&
     '#---------#---------#---------#---------#---------#---------#---------#-',&
     '#---------#---------#---------#---------#---------#---------#---------#-',&
     '#  end of values to call ELIPS(3f) with                                 ',&
     '#---------------------------------------------------------------------#-']
        call plots(0.0,10.0,0.0,10.0)
        do i=1,size(lines)
           write(*,'(a)')lines(i)
           if( lines(i).eq.' ' .or. index(lines(i),'#').ne.0 )cycle
           read(lines(i),9012) x,y, &
                           & major_axis_length,minor_axis_length, &
                           & a, &
                           & start_angle,finish_angle, &
                           & ipen
           9012 format(7(1X,F9.3),1X,I1)
           call elips(x,y, &
                           & major_axis_length,minor_axis_length, &
                           & a, &
                           & start_angle,finish_angle, &
                           & ipen)
        enddo
        call nframe()
        call plot(0.0,0.0,END)
     end program demo_elips


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_UPDT_FIELD_VARS_AVERAGE

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_FIELD_VARS_AVERAGE

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_UPDT_FIELD_VARS_AVERAGE

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:,:  ) :: UNIT_FORCES , UNIT_MOTION
    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:,:  ) :: UNIT_ENERGY

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:,:  ) :: QUV

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_UPDT_FIELD_VARS_AVERAGE

    USE MR_MOD_OPERATOR_UV
    USE MR_MOD_OPERATOR_SS

    USE MR_MOD_AVERAGE

    USE MR_MOD_CALC_UNIT_FORCES_N_MOTION
    USE MR_MOD_CALC_UNIT_ENERGY

    IMPLICIT NONE

  ! UPDATE AVERAGE_H
    CALL MR_AVERAGE_SS_BY_AREA( NI , NJ , H , AVERAGE_PLAN_H , AVERAGE_XSEC_H )

    ALLOCATE( UNIT_FORCES(1:NI1(NI,FDRD_KIND),1:NJ,1:2) , UNIT_MOTION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) )
    CALL MR_CALC_UNIT_FORCES_N_MOTION( NI , NJ , NK , UNIT_FORCES , UNIT_MOTION )
  ! UPDATE AVERAGE_UNIT_FORCES AND AVERAGE_UNIT_MOTION
    CALL MR_AVERAGE_UV_BY_AREA( NI , NJ , UNIT_FORCES , AVERAGE_PLAN_UNIT_FORCES , AVERAGE_XSEC_UNIT_FORCES  )
    CALL MR_AVERAGE_UV_BY_AREA( NI , NJ , UNIT_MOTION , AVERAGE_PLAN_UNIT_MOTION , AVERAGE_XSEC_UNIT_MOTION )
    DEALLOCATE( UNIT_FORCES , UNIT_MOTION )

    ALLOCATE( UNIT_ENERGY(1:NI1(NI,FDRD_KIND),1:NJ,1:2) )
    CALL MR_CALC_UNIT_ENERGY( NI , NJ , NK , UNIT_ENERGY )
  ! UPDATE AVERAGE_UNIT_ENERGY
    CALL MR_AVERAGE_SS_BY_AREA( NI , NJ , UNIT_ENERGY(:,:,1) , AVERAGE_PLAN_UNIT_ENERGY ,   &
    & AVERAGE_XSEC_UNIT_ENERGY )
  ! UPDATE AVERAGE_UNIT_CIRC_INTENSITY
    CALL MR_AVERAGE_SS_BY_LINE( NI , NJ , UNIT_ENERGY(:,:,1) , AVERAGE_PLAN_UNIT_CIRC_INTENSITY(1) ,   &
    & AVERAGE_XSEC_UNIT_CIRC_INTENSITY(:,1) )
    CALL MR_AVERAGE_SS_BY_LINE( NI , NJ , UNIT_ENERGY(:,:,2) , AVERAGE_PLAN_UNIT_CIRC_INTENSITY(2) ,   &
    & AVERAGE_XSEC_UNIT_CIRC_INTENSITY(:,2) )
    DEALLOCATE( UNIT_ENERGY )

  ! UPDATE AVERAGE_TBFUV
    CALL MR_AVERAGE_UV_BY_AREA( NI , NJ , TBFUV , AVERAGE_PLAN_TBFUV , AVERAGE_XSEC_TBFUV )
    CALL MR_AVERAGE_SS_BY_AREA( NI , NJ ,   &
    & ( .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBFUV ) ) ) , AVERAGE_PLAN_TBFUV_MOD , AVERAGE_XSEC_TBFUV_MOD )

  ! UPDATE AVERAGE_TBUV
    CALL MR_AVERAGE_UV_BY_AREA( NI , NJ , TBUV , AVERAGE_PLAN_TBUV , AVERAGE_XSEC_TBUV )
    CALL MR_AVERAGE_SS_BY_AREA( NI , NJ ,   &
    & ( .MRSSQRT. ( .MRUVSQR. ( JUV .MRUVTFM. TBUV ) ) ) , AVERAGE_PLAN_TBUV_MOD , AVERAGE_XSEC_TBUV_MOD )

    ALLOCATE( QUV(1:NI1(NI,FDRD_KIND),1:NJ,1:2) )
    QUV = UVA .MRUVMTP. H
  ! UPDATE AVERAGE_QUV
    CALL MR_AVERAGE_UV_BY_LINE( NI , NJ , QUV , AVERAGE_PLAN_QUV , AVERAGE_XSEC_QUV )
    DEALLOCATE( QUV )

  END SUBROUTINE MR_UPDT_FIELD_VARS_AVERAGE

  END MODULE MR_MOD_UPDT_FIELD_VARS_AVERAGE


program ch0502
    ! Type Conversion and Assignment
    implicit none

    real :: a, b, c
    integer :: i

    a = 1.5
    b = 2.
    c = a/b
    i = a/b
    print *, a, b
    print *, c
    print *, i
end program


      subroutine dvmul(n,dx,incx,dy,incy)
c!but
c
c     etant donne un vecteur dx et un vecteur dy,
c      cette subroutine fait:
c                    dy = dy * dx
c     quand les deux increments sont egaux a un, cette
c     subroutine emploie des boucles "epanouis". dans le cas ou
c     les increments sont negatifs, cette subroutine prend
c     les composantes en ordre inverse.
c
c!liste d'appel
c
c     subroutine dvmul(n,dx,incx,dy,incy)
c
c     dy, dx: vecteurs double precision.
c
c     incx, incy: increments entre deux composantes succesives
c     des vecteurs.
c
c!auteur
c
c     serge steer inria
c!
c     Copyright INRIA
      double precision dx(*),dy(*)
      integer i,incx,incy,ix,iy,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) * dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c code for both increments equal to 1
c
   20 continue
      do 30 i = 1,n
        dy(i) = dy(i) * dx(i)
   30 continue
c
      end


! Call to "size" intrinsic is inlined
program size_intrin
  integer :: array(10) = 0
  integer , parameter :: n = 3
  integer :: result(n) , expect(n)
  expect(1) = 10
  expect(2) = 10
  expect(3) = 0
  result(1) = size(array(1:10:1),1)
  result(2) = size(array(10:1:-1),1)
  result(3) = size(array(1:10:-1),1)
  call checkf(result,expect,n)
end program size_intrin


MODULE c_arrays

  IMPLICIT NONE

CONTAINS

  FUNCTION array_in(n,x) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in) :: x(n)
    INTEGER :: y
    y = SUM(x)
  END FUNCTION array_in

  ! Test assumed size array
  FUNCTION array_in_2(x) RESULT(y)
    INTEGER, INTENT(in) :: x(*)
    INTEGER :: y
    y = SUM(x(1:4))
  END FUNCTION array_in_2

  SUBROUTINE array_out(nx,ny,x,y)
    INTEGER, INTENT(in) :: nx,ny
    INTEGER, INTENT(out) :: x(nx)
    INTEGER, DIMENSION(ny), INTENT(out) :: y
    x = 20
    y = 30
  END SUBROUTINE  array_out

  FUNCTION inner_prod(n,a,b) RESULT(y)
    INTEGER, INTENT(in) :: n, a(n), b(n)
    INTEGER :: y
    y = DOT_PRODUCT(a,b)
  END FUNCTION inner_prod

END MODULE c_arrays


c=======================================================================
c
c     Workspace for JMS
c
c=======================================================================
c
c     subroutine GWJMS
c
c     get the size of workspace needed by JMS
c
c=======================================================================
c     INPUT :
c            n : dimension of the matrix                         integer
c
c     OUTPUT :
c            sdwork : size of double precision workspace         integer
c-----------------------------------------------------------------------
      subroutine gwjms ( n, sdwork )
      implicit none
      integer n, sdwork
      sdwork = n*n
      return
      end


           program demo_maxloc
           implicit none
           integer      :: ii
           integer,save :: i(-3:3)=[(abs(abs(ii)-50),ii=-3,3)]
           integer,save :: ints(3,5)= reshape([&
              1,  2,  3,  4,  5, &
             10, 20, 30, 40, 50, &
             11, 22, 33, 44, 55  &
           ],shape(ints),order=[2,1])
           write(*,*) maxloc(ints)
           write(*,*) maxloc(ints,dim=1)
           write(*,*) maxloc(ints,dim=2)
           ! when array bounds do not start with one remember MAXLOC(3f) returns the
           ! offset relative to the lower bound-1 of the location of the maximum
           ! value, not the subscript of the maximum value. When the lower bound of
           ! the array is one, these values are the same. In other words, MAXLOC(3f)
           ! returns the subscript of the value assuming the first subscript of the
           ! array is one no matter what the lower bound of the subscript actually
           ! is.
           write(*,'(g0,1x,g0)') (ii,i(ii),ii=lbound(i,dim=1),ubound(i,dim=1))
           write(*,*)maxloc(i)

           end program demo_maxloc


program i
  integer::a=3+4
end program i