      subroutine MATL01(eps,trace,td,d,ud,hn,h1,nh,sig,dd,isw)

c      * * F E A P * * A Finite Element Analysis Program

c     Michael Scott
c     CE 233

c-----[--.----+----.----+----.-----------------------------------------]
c     Purpose: Linear Elastic Material Model

c     Input:
c          eps(*)  -  Current strains at point
c          trace   -  Trace of strain at point
c          td      -  Temperature change
c          d(*)    -  Program material parameters (ndd)
c          ud(*)   -  User material parameters (nud)
c          hn(nh)  -  History terms at point: t_n
c          h1(nh)  -  History terms at point: t_n+1
c          nh      -  Number of history terms
c          isw     -  Solution option from element

c     Output: (N.B. Arrays are set to zero before call)
c          sig(6)  -  Stresses at point.
c          dd(6,6) -  Current material tangent moduli
c-----[--.----+----.----+----.-----------------------------------------]

      implicit none

      integer  nh, isw
      real*8   trace, td
      real*8   eps(6),d(*),ud(*),hn(nh),h1(nh),sig(6),dd(6,6)

      real*8   E,nu
      real*8   mu,mu2,lam
      integer  i,j

c     // Read in material parameters
      E = ud(1)
      nu = ud(2)

      mu2 = E/(1.d0+nu)
      mu  = 0.5d0*mu2
      lam = mu2*nu/(1.d0-2.d0*nu)

      sig(1) = mu2*eps(1) + lam*trace
      sig(2) = mu2*eps(2) + lam*trace
      sig(3) = mu2*eps(3) + lam*trace
      sig(4) =  mu*eps(4)
      sig(5) =  mu*eps(5)
      sig(6) =  mu*eps(6)

      do i = 1,3
         dd(i  ,i  ) = mu2
         dd(i+3,i+3) = mu
         do j = 1,3
            dd(i,j) = dd(i,j) + lam
         end do
      end do

      end


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculates the fluid/ice partition function
!>    @param[in] tlocal = temperature
!>    @param[in] tliq = phase boundary temperature
!>    @param[in] wmushy =  scaling factor for "mushy" region = Tsolidus-tliqidus
!>    @param[in] ismpl local sample index
!>    @param[out] theta = value of partition function  (0<Theta<1)
!>    @param[out] dtheta = value of derivative of partition function with respect to temperature
!#>   returns the fluid/ice partition function theta and its derivative dtheta
!>    @details
!>calculates the fluid/ice partition function used for the \n
!>apparent heat capacity approach to phase change.\n
      SUBROUTINE ftheta(tlocal,tliq,wmushy,theta,dtheta,ismpl)
        use arrays
                use ice
        IMPLICIT NONE
        INTEGER ismpl
        DOUBLE PRECISION tlocal, theta, dtheta, val, tliq, wmushy

        theta = 1.D0
        dtheta = 0.D0

        IF (tlocal<tliq) THEN
          val = (tlocal-tliq)/wmushy
!         Theta=exp((-(T-Tf)/w)^2)
          theta = exp(-val*val)
!         dTheta=-2*(T-Tf)/w^2*Theta;
          dtheta = -2.D0*val*theta/wmushy
!       IF (theta.lt.liqmin) THEN
!         theta  =  liqmin
!         dtheta =  0.
!       END IF

        END IF
        RETURN
      END

!>    @brief calculates the fluid/ice partition function used for the
!>    @param[in] tlocal = temperature
!>    @param[in] tliq = phase boundary temperature
!>    @param[in] wmushy = scaling factor for "mushy" region = tsolidus-tliqidus
!>    @param[in] ismpl local sample index
!>    @param[out] theta = value of partition function (0<Theta<1)
!>    @param[out] dtheta = value of derivative of partition function with respect to temperature
!>    @details
!>calculates the fluid/ice partition function used for the \n
!>apparent heat capacity approach to phase change (galushkin)\n
      SUBROUTINE ftheta_gal(tlocal,tliq,wmushy,theta,dtheta,ismpl)
        use arrays
                use ice
        IMPLICIT NONE
        INTEGER ismpl
        DOUBLE PRECISION solid, tlocal, tref, tlimit, km, theta, &
          dtheta, a0, a1, a2, a3, a4, a5, a6, a7, a8, tliq, wmushy
        DOUBLE PRECISION t, t1, t2, t3, t4, t5, t6, t7, t8
        PARAMETER (a0=1.0D0,a1=0.60152823763179D0, &
          a2=0.23218232347212D0,a3=0.04669792788297D0, &
          a4=0.00535597924776D0,a5=0.00036415588418D0, &
          a6=0.00001450956751D0,a7=0.00000031279149D0, &
          a8=0.00000000281502D0)

        theta = 1.D0
        dtheta = 0.0

        IF (tlocal<tliq) THEN
          t1 = tlocal
          t2 = t1*t1
          t3 = t2*t1
          t4 = t3*t1
          t5 = t4*t1
          t6 = t5*t1
          t7 = t6*t1
          t8 = t7*t1
          theta = a0 + a1*t1 + a2*t2 + a3*t3 + a4*t4 + a5*t5 + a6*t6 + &
            a7*t7 + a8*t8
          dtheta = a1 + 2.D0*a2*t1 + 3.D0*a3*t2 + 4.D0*a4*t3 + &
            5.D0*a5*t4 + 6.D0*a6*t5 + 7.D0*a7*t6 + 8.D0*a8*t7
        END IF
        RETURN
      END

!>    @brief calculates the fluid/ice partition function used for the
!>    @param[in] tlocal = temperature
!>    @param[in] tliq = phase boundary temperature
!>    @param[in] wpara = scaling factor for "mushy" region = tsolidus-tliqidus
!>    @param[in] ismpl local sample index
!>    @param[out] theta = value of partition function (0<Theta<1)
!>    @param[out] dtheta = value of derivative of partition function with respect to temperature
!>    @details
!>calculates the fluid/ice partition function used for the \n
!>apparent heat capacity approach to phase change (nikolsky2009)\n
      SUBROUTINE ftheta_nik(tlocal,tliq,wpara,theta,dtheta,ismpl)
        use arrays
                use ice
        IMPLICIT NONE
        INTEGER ismpl
        DOUBLE PRECISION solid,tlocal,tref,tlimit,km,theta,dtheta
        DOUBLE PRECISION tliq,wpara

        theta    =   1.d0
        dtheta   =   0.0d0

        IF (tlocal<tliq .and. wpara>=0.5d0 .and. wpara<=0.8d0) THEN
          theta = (abs(tliq)**wpara)*(abs(tlocal)**(-wpara))

!AW
          dtheta= (abs(tliq)**wpara)* &
            (-wpara)*abs(tlocal)**(-wpara-1.d0)
!AW oben stehende Zwischenloesung muss mit unten stehendem Original korrigiert werden <- SIGN ist aber falsch!!!
          WRITE(*,*) 'error: "ftheta_nik" needs to be modified!!!'
          STOP
!AW-original          dtheta= (abs(tliq)**wpara)* &
!AW-original            (-wpara)*abs(tlocal)**(-wpara-1.d0)*sign(tlocal)

        END IF
        RETURN
      END


#include "Config.fpp"

module mod_cheb_particles_aggregate

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_cheb_particles_aggregate'
 !
 !          Purpose:
 !                      This module models 'Chebyshev Particles' aggregated ensemble
 !
 !          History:
 !                        Date: 04-08-2018
 !                        Time: 11:51 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                      Bernard Gingold
 !
 !
 !          References:
 !
 !                           'Scattering of Radiation by Moderately Non-Spherical Particles'
 !                            By A. Mugnai and W.J. Wiscombe (1986)
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85
    ! Tab:5 col - Type and etc.. definitions
    ! Tab:10,11 col - Type , function and subroutine code blocks.
    implicit none
    use module_kinds,    only : I32P, R64P
    use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT, &
                                stdout=>OUTPUT_UNIT

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P),  parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_MAJOR = 1_I32P

    ! Minor version
    integer(I32P),  parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_MINOR = 0_I32P

    ! Micro version
    integer(I32P),  parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_MICRO = 0_I32P

    ! Module full version
    integer(I32P),  parameter, public :: MOD_CHEB_PARTICLES_AGGREAGTE_FULLVER = 1000_I32P*MOD_CHEB_PARTICLES_AGGREGATE_MAJOR + &
                                                                                100_I32P*MOD_CHEB_PARTICLES_AGGREGATE_MINOR  + &
                                                                                10_I32P*MOD_CHEB_PARTICLES_AGGREGATE_MICRO
    ! Module creation date
    character(*),   parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_CREATE_DATE = "04-08-2018 11:41 +00200 (SAT 04 AUG 2018 GMT+2) "

    ! Module build date (  should be set after successful compilation)
    character(*),   parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_AUTHOR = "Programmer: Bernard Gingold, contact: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_CHEB_PARTICLES_AGGREGATE_DESCRIPT = "Model of aggregated chebyshev particles (hydrometeors)."

    ! Constants

    real(R64P),    parameter, private :: Deg90toRad = 1.5708_R64P

    !============================================
    !  type: Chebyshev_paggregate_t
    !============================================
    type, public :: Chebyshev_paggregate_t

          private

           ! Number of particles  in aggregated emsemble
          integer(I32P)              :: m_np

          ! Particles aggregate ID number
          integer(I32P)              :: m_ID

          ! Time evolution steps
          integer(I32P)              :: m_nt

          ! Maximal number of parametric equation points
          integer(I32P)              :: m_maxx, m_maxy, m_maxz

          ! Total volume of particles per ensemble
          real(R64P)                 :: m_tpv

          ! Total particles surface area per ensemble
          real(R64P)                 :: m_tpsa

          ! Total particles mass per ensemble
          real(R64P)                 :: m_tpm

           ! Hydrometeor type
          character(len=32)          :: m_htype

           ! Ensemble shape  only 2 types supported for now: -- ( spheroid, chebyshev-particle)
           character(len=64)         :: m_esh

          ! Chebyshev particles shape in aggregated assembly ( (r = r0[1+eTn(cos(theta))])
          ! [r,np], where r = parametric shape (cross-section), np =  n-th particle
          real(R64P), allocatable, dimension(:,:), public :: m_pcs
!DIR$     ATTRIBUTES ALIGN : 64 :: m_pcs

          ! Chebyshev particles radii in aggregate ensemble
          real(R64P), allocatable, dimension(:),   public :: m_pradii
!DIR$     ATTRIBUTES ALIGN : 64 :: m_pradii

          ! Trajectory of Chebyshev particles ensemble, radial distance component (spherical coordinate system)
          ! [r,np]
          real(R64P), allocatable, dimension(:,:), public :: m_prdist
!DIR$     ATTRIBUTES ALIGN : 64 :: m_prdist

           ! Trajectory of Chebyshev particles ensemble, theta angle component (spherical coordinate system)
           ! [theta,np]
          real(R64P), allocatable, dimension(:,:), public :: m_ptheta
!DIR$     ATTRIBUTES ALIGN : 64 :: m_ptheta

          ! Trajectory of Chebyshev particles ensemble, phi angle component (spherical coordinate system)
          ! [phi,np]
          real(R64P), allocatable, dimension(:,:), public :: m_pphi
!DIR$     ATTRIBUTES ALIGN : 64 :: m_pphi

          ! Chebyshev particles aggregate shape approximated by 3D parametric equations.
          ! Components form location of the particle in the ensemble.
          ! [3,np], where first dimension represents coordinate components
          ! second dimension represent number of particles.
          real(R64P), allocatable, dimension(:,:), public :: m_pes
!DIR$     ATTRIBUTES ALIGN : 64 :: m_pes

          ! Chebyshev particles ensemble( per each particle) parametric equation in x - dimension (non-dimensional)
          ! [paramx,np]
          real(R64P), allocatable, dimension(:,:), public :: m_ppx
!DIR$     ATTRIBUTES ALIGN : 64 :: m_ppx

          ! Chebyshev particles ensemble (per each particle)  parametric equation in y  - dimension (non-dimensional)
          real(R64P), allocatable, dimension(:,:), public :: m_ppy
!DIR$     ATTRIBUTES ALIGN : 64 :: m_ppy

         ! Chebyshev particles ensemble (per each particle)  parametric equation in z  - dimension (non-dimensional)
          real(R64P), allocatable, dimension(:,:), public :: m_ppz
!DIR$    ATTRIBUTES ALIGN : 64 :: m_ppz

          ! Chebyshev particles ensemble fall speed
          ![nt]
          real(R64P), allocatable, dimension(:),   public :: m_pfv
!DIR$     ATTRIBUTES ALIGN : 64 :: m_pvf

          contains

          !========================================================
          !         Class getters
          !========================================================

          procedure, pass(this), public :: get_np

          procedure, pass(this), public :: get_ID

          procedure, pass(this), public :: get_nt

          procedure, pass(this), public :: get_maxx

          procedure, pass(this), public :: get_maxy

          procedure, pass(this), public :: get_maxz

          procedure, pass(this), public :: get_htype

          procedure, pass(this), public :: get_esh

          procedure, pass(this), public :: get_tpv

          procedure, pass(this), public :: get_tpsa

          procedure, pass(this), public :: get_tpm

          !==============================================56
          ! write/read subroutines
          !==============================================56

          procedure, public :: read_state

          procedure, public :: write_state

          !===============================================
          !  Class helper procedures
          !===============================================
          procedure, public :: dbg_info

          !===============================================
          !   Generic operators
          !===============================================
          procedure, public :: copy_assign

          generic :: assignment (=) => copy_assign

          !================================================
          !  Computational procedures
          !================================================

          procedure, public :: compute_cross_section

          procedure, public :: compute_ensemble_shape

          procedure, public :: compute_x_param

          procedure, public :: compute_y_param

          procedure, public :: compute_z_param

          procedure, public :: compute_ensemble_vol

          procedure, public :: compute_ensemble_surf

          procedure, public :: compute_vfall

    end type Chebyshev_paggregate_t

    interface Chebyshev_paggregate_t
        procedure :: constructor
    end interface Chebyshev_paggregate_t

    contains

    !================================================================
    !  @function:  constructor
    !             Memory allocation and
    !             default initialization of array and scalar
    !             member variables.
    !=================================================================
    pure type(Chebyshev_paggregate_t)  function constructor(np,ID,nt,htype,esh,maxx,maxy,maxz,  &
                                                         msval,verbose,logging,filename,append    )
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_PINF
          integer(I32P),        intent(in) :: np
          integer(I32P),        intent(in) :: ID
          integer(I32P),        intent(in) :: nt
          character(len=32),    intent(in) :: htype
          character(len=64),    intent(in) :: esh
          integer(I32P),        intent(in) :: maxx
          integer(I32P),        intent(in) :: maxy
          integer(I32P),        intent(in) :: maxz
          integer(I32P),        intent(in) :: msval   ! max values per particle's shape
          logical(I32P),        intent(in) :: verbose
          logical(I32P),        intent(in) :: logging
          character(len=*),     intent(in) :: filename
          logical(I32P),        intent(in) :: append
          ! Locals
          integer(I32P)      :: aerr
          character(len=256) :: emsg
          ! Exec code ......
          constructor%m_np    = np
          constructor%m_ID    = ID
          constructor%m_nt    = nt
          constructor%m_maxx  = maxx
          constructor%m_maxy  = maxy
          constructor%m_maxz  = maxz
          constructor%m_tpv   = LAM_PINF
          constructor%m_tpsa  = LAM_PINF
          constructor%m_tpm   = LAM_PINF
          constructor%m_htype = htype
          constructor%m_esh   = esh

          associate(mnp=>constructor%m_np,  &
                    mnt=>constructor%m_nt,  &
                    mmx=>constructor%m_mmx, &
                    mmy=>constructor%m_mmy, &
                    mmz=>constructor%m_mmz   )

              allocate(  constructor%m_pcs(msval,mnp),  &
                         constructor%m_pradii(mnp),     &
                         constructor%m_rdist(mnt,mnp),  &
                         constructor%m_ptheta(mnt,mnp), &
                         constructor%m_pphi(mnt,mnp),   &
                         constructor%m_pes(3,mnp),      &
                         constructor%m_ppx(mmx,mnp),    &
                         constructor%m_ppy(mmy,mnp),    &
                         constructor%m_ppz(mmz,mnp),    &
                         constructor%m_pfv(mnt),        &
                         STAT=aerr,                     &
                         ERRMSG=emsg             )

         end associate
         if(aerr /= 0_I32P) then
             call handle_fatal_memory_error(  logging,verbose,append,filename,   &
                                   "logger:303 -- Module: [mod_cheb_particles_aggregate], subroutine: [Chebyshev_paggregate_t%constructor]" ,  &
                                   "------ !!! FATAL-ERROR !!! ------ Memory Allocation Failure !!", &
                                    emsg,__LINE__)
         end if
         constructor%m_pcs    = LAM_PINF
         constructor%m_pradii = LAM_PINF
         constructor%m_rdist  = LAM_PINF
         constructor%m_ptheta = LAM_PINF
         constructor%m_pphi   = LAM_PINF
         constructor%m_pes    = LAM_PINF
         constructor%m_ppx    = LAM_PINF
         constructor%m_ppy    = LAM_PINF
         constructor%m_ppz    = LAM_PINF
         constructor%m_pfv    = LAM_PINF
    end function constructor

    !==========================================
    !       Class getters
    !==========================================

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_np
!DIR$ ENDIF
    pure function get_np(this) result(np)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          integer(I32P) :: np
          ! Exec code ....
          np = this%m_np
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_ID
!DIR$ ENDIF
    pure function get_ID(this) result(ID)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          integer(I32P) :: ID
          ! Exec code ....
          ID = this%m_ID
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_nt
!DIR$ ENDIF
    pure function get_nt(this)  result(nt)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          integer(I32P) :: nt
          ! Exec code ....
          nt = this%m_nt
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_maxx
!DIR$ ENDIF
    pure function get_maxx(this) result(maxx)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          integer(I32P) :: maxx
          ! Exec code ...
          maxx = this%m_maxx
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_maxy
!DIR$ ENDIF
    pure function get_maxy(this) result(maxy)
          class(Chebyshev_paggregate_t), intent(in) :: this
          ! Locals
          integer(I32P) :: maxy
          ! Exec code ...
          maxy = this%m_maxy
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_maxz
!DIR$ ENDIF
    pure function get_maxz(this) result(maxz)
          class(Chebyshev_paggregate_t), intent(in) :: this
          ! Locals
          integer(I32P) :: maxz
          ! Exec code ...
          maxz = this%m_maxz
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_htype
!DIR$ ENDIF
    pure function get_htype(this) result(htype)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          character(len=32) :: htype
          ! Exec code ....
          htype = this%m_htype
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_esh
!DIR$ ENDIF
    pure function get_esh(this)  result(esh)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          character(len=64) :: esh
          ! Exec code ...
          esh = this%m_esh
    end function

 !DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_tpv
!DIR$ ENDIF
    pure function get_tpv(this) result(tpv)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          ! Locals
          real(R64P) :: tpv
          ! Exec code ...
          tpv = this%m_tpv
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_tpsa
!DIR$ ENDIF
    pure function get_tpsa(this) result(tpsa)
          class(Chebyshev_paggregate_t), intent(in) :: this
          ! Locals
          real(R64P) ::  tpsa
          ! Exec code ....
          tpsa = this%m_tpsa
    end function

!DIR$ IF (USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_tpm
!DIR$ ENDIF
    pure function get_tpm(this) result(tpm)
          class(Chebyshev_paggregate_t), intent(in) :: this
          ! Locals
          real(R64P) :: tpm
          ! Exec code ...
          tpm = this%m_tpm
    end function

     !==================================================
    !       Read write procedures
    !==================================================
    subroutine read_state(this,form,unit,ioerr)

          class(Chebyshev_paggregate_t),   intent(in)    :: this
          character(len=*),                intent(in)    :: form
          integer(I32P),                   intent(in)    :: unit
          integer(I32P),                   intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(Chebyshev_paggregate_t),   intent(in)    :: this
          character(len=*),                intent(in)    :: form
          integer(I32P),                   intent(in)    :: unit
          integer(I32P),                   intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine write_state

    subroutine dbg_info(this,show_arrays)
          class(Chebyshev_paggregate_t),  intent(in) :: this
          logical(I32P),                  intent(in) :: show_arrays
          ! Exec code ....
          print*, "=================================================================="
          print*, "         Dumping: -- Chebyshev_paggregate_t -- object state        "
          print*, "=================================================================="
          print*, "         Chebyshev_paggregate_t: -- Memory layout                  "
          write(stdout,10) LOC(this)
10        format('addressof(this):                   -- ',Z15)
          write(stdout,20) LOC(this%m_np)
20        format('addressof(this%m_np):              -- ',Z15)
          write(stdout,30) LOC(this%m_ID)
30        format('addressof(this%m_ID):              -- ',Z15)
          write(stdout,40) LOC(this%m_nt)
40        format('addressof(this%m_nt):              -- ',Z15)
          write(stdout,50) LOC(this%m_maxx)
50        format('addressof(this%m_maxx):            -- ',Z15)
          write(stdout,60) LOC(this%m_maxy)
60        format('addressof(this%m_maxy):            -- ',Z15)
          write(stdout,70) LOC(this%m_maxz)
70        format('addressof(this%m_maxz):            -- ',Z15)
          write(stdout,80) LOC(this%m_htype)
80        format('addressof(this%m_htype):           -- ',Z15)
          write(stdout,90) LOC(this%m_esh)
90        format('addressof(this%m_esh):             -- ',Z15)
          write(stdout,100) LOC(this%m_tpv)
100       format('addressof(this%m_tpv):             -- ',Z15)
          write(stdout,110) LOC(this%m_tpsa)
110       format('addressof(this%m_tpsa):            -- ',Z15)
          write(stdout,120) LOC(this%m_tpm)
120       format('addressof(this%m_tpm):             -- ',Z15)
          write(stdout,130) LOC(this%m_pcs)
130       format('addressof(this%m_pcs):             -- ',Z15)
          write(stdout,140) LOC(this%m_pradii)
140       format('addressof(this%m_pradii):          -- ',Z15)
          write(stdout,150) LOC(this%m_rdist)
150       format('addressof(this%m_rdist):           -- ',Z15)
          write(stdout,160) LOC(this%m_ptheta)
160       format('addressof(this%m_ptheta):          -- ',Z15)
          write(stdout,170) LOC(this%m_pphi)
170       format('addressof(this%m_pphi):            -- ',Z15)
          write(stdout,180) LOC(this%m_pes)
180       format('addressof(this%m_pes):             -- ',Z15)
          write(stdout,190) LOC(this%m_ppx)
190       format('addressof(this%m_ppx):             -- ',Z15)
          write(stdout,200) LOC(this%m_ppy)
200       format('addressof(this%m_ppy):             -- ',Z15)
          write(stdout,210) LOC(this%m_ppz)
210       format('addressof(this%m_ppz):             -- ',Z15)
          write(stdout,220) LOC(this%m_pfv)
220       format('addressof(this%m_pfv):             -- ',Z15)
          print*, "==========================================================="
          print*, "        Dumping scalar and array member values             "
          print*, "==========================================================="
          print*, "  m_np:    ",  this%m_np,    &
                  "  m_ID:    ",  this%m_ID,    &
                  "  m_nt:    ",  this%m_nt,    &
                  "  m_maxx:  ",  this%m_maxx,  &
                  "  m_maxy:  ",  this%m_maxy,  &
                  "  m_maxz:  ",  this%m_maxz,  &
                  "  m_tpv:   ",  this%m_tpv,   &
                  "  m_tpsa:  ",  this%m_tpsa,  &
                  "  m_tpm:   ",  this%m_tpm,   &
                  "  m_htype: ",  this%m_htype, &
                  "  m_esh:   ",  this%m_esh
          if( show_arrays == .true. )  then
                   print*, "  Caller decided to print array members content.            "
                   print*, "============================================================"
                   print*, " m_pcs:     ", this%m_pcs
                   print*, " m_pradii:  ", this%m_pradii
                   print*, " m_rdist:   ", this%m_rdist
                   print*, " m_ptheta:  ", this%m_ptheta
                   print*, " m_pphi:    ", this%m_pphi
                   print*, " m_pes:     ", this%m_pes
                   print*, " m_ppx:     ", this%m_ppx
                   print*, " m_ppy:     ", this%m_ppy
                   print*, " m_ppz:     ", this%m_ppz
                   print*, " m_pfv:     ", this%m_pfv
          else
                     print*, " Caller decided to skip over array content printing."
          end if
          print*, "==============================================================="
          print*, "     End of: -- Chebyshev_paggregate_t object state dump        "
          print*, "==============================================================="
    end subroutine

    subroutine copy_assign(this,other)
          class(Chebyshev_paggregate_t),    intent(inout) :: this
          class(Chebyshev_paggregate_t),    intent(in)    :: other
          ! Exec code ...
          this%m_np     = other%m_np
          this%m_ID     = other%m_ID
          this%m_nt     = other%m_nt
          this%m_maxx   = other%m_maxx
          this%m_maxy   = other%m_maxy
          this%m_maxz   = other%m_maxz
          this%m_tpv    = other%m_tpv
          this%m_tpsa   = other%m_tpsa
          this%m_tpm    = other%m_tpm
          this%m_htype  = other%m_htype
          this%m_esh    = other%m_esh
          this%m_pcs    = other%m_pcs
          this%m_pradii = other%m_pradii
          this%m_rdist  = other%m_rdist
          this%m_ptheta = other%m_ptheta
          this%m_pphi   = other%m_pphi
          this%m_pes    = other%m_pes
          this%m_ppx    = other%m_ppx
          this%m_ppy    = other%m_ppy
          this%m_ppz    = other%m_ppz
          this%m_pfv    = other%m_pfv
    end subroutine

    !===================================================================
    !                   Computational procedures
    !  These procedures  type bound, but in order to facilitate potential
    !  OpenMP parallelization (to be done later) derived type is not
    !  passed explicitly as an argument.
    !  Only Chebyshev Particles of type T2 and T4 should be used, at
    !  least in accordance to Wycombe paper.
    !===================================================================

    !===============================================================================
    ! Compute particles shape as a cross-section
    ! This code relies on compuation of radial distance as function of un-perturbed
    ! sphere radius, deformity coefficient and T(n) curve.
    !===============================================================================
    subroutine compute_cross_section(pcs,np,nrval,sphrad,chebn,cdeform,inith,incth,ierr,  &
                                     verbose,ierr,fp_flags                  )
 !DIR$  IF( USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$   ENDIF
          use mod_print_error,  only : print_non_fatal_error
          use mod_constants,    only : LAM_dtcoeff
          real(R64P),    dimension(nrval,np),       intent(out)   :: pcs
          integer(I32P),                            intent(in)    :: np
          integer(I32P),                            intent(in)    :: nrval
          real(R64P),    dimension(np),             intent(in)    :: sphrad
          real(R64P),    dimension(np),             intent(in)    :: chebn
          real(R64P),    dimension(np),             intent(in)    :: cdeform
          real(R64P),                               intent(in)    :: inith
          real(R64P),                               intent(in)    :: incth
          integer(I32P),                            intent(inout) :: ierr
          logical(I32P),                            intent(in)    :: verbose
          logical(I32P), dimension(5),              intent(inout) :: fp_flags
          ! Locals
          integer(I32P)     :: j,i
          real(R64P)        :: theta,term,r
          character(len=40) :: sdate,stime
!DIR$     IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)    :: status_value
!DIR$     ENDIF
          ! Exec code .....
          ! Input arguments checking
          if(ierr < 0_I32P) ierr = 0_I32P
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          if( inith < 0._R64P  ) then
                  if(verbose == .true.)  then
                       call print_non_fatal_error( "=================== Non-Fatal Error =====================",  &
                          " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_cross_section]: -- Invalid Argument!!", &
                             sdate,stime,__LINE__     )
                  end if
                  ierr = -1_I32P
                  return
          end if
          do i = 1_I32P, size(LAM_dtcoeff)
              if(incth /= LAM_dtcoeff(i)) then
                  if(verbose == .true.) then
                         call print_non_fatal_error( "============================ Non-Fatal Error ==========================", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_cross_section]: -- Invalid: 'incth' or 'incphi' value.", &
                             sdate,stime,__LINE__  )
                  end if
                  ierr = -2_I32P
                  return
              end if
          end do
          do i = 1_I32P,    mxp
             if((chebn(i)       < 0.0_R64P ) .OR.  &
                (abs(cdeform(i) > 1.0_R64P)    ) then
                    if(verbose == .true. ) then
                           call print_non_fatal_error( "========================== Non-Fatal Error =========================", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_cross_section]: -- Invalid: T(n) order ,or deform coeff.", &
                             sdate,stime,__LINE__)
                    end if
                    ierr = -3_I32P
                    return
             end if
          end do
          term = 0.0_R64P
          theta = 0.0_R64P
          r     = 0.0_R64P
          ! Computational loop
          ! IEEE exception cheking if enabled is perfromed per each interation
          ! of 'j' (outer) loop.
          do j = 1_I32P,   np
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                 call ieee_get_status(status_value)
                 call ieee_set_halting_mode(ieee_all,.false.)
                 call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
                 do i = 1_I32P, nrval
                     theta = theta + incth
                     term = 1.0_R64P + cdeform(j) * cos(chebn(j) * theta)
                     pcs(i,j) = sphrad(j) * term
                 end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                call ieee_get_flag(ieee_all,fp_flags)
                if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_cross_section: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags, "at iteration: ", j
                        print "====================================================================================================="
                end if
                call ieee_set_status(status_value)
!DIR$ ENDIF
          end do
          ierr = 0_I32P
    end subroutine

    !=================================================================71
    !     Computation of ensemble shape.
    !     As for now only 3 shapes are supported:
    !     1) Cylindrical
    !     2) Pure spherical
    !     3) Chebyshev particle like
    !=================================================================71
    subroutine compute_ensemble_shape( pes,np,inz,incz,shape_name, &
                                       r,inphi,inth,incphi,incth,sphrad,chebn,cdeform,verbose,ierr,fp_flags)
!DIR$  IF( USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$   ENDIF
          use mod_print_error,  only : print_non_fatal_error
          real(R64P),   dimension(3,np),    intent(out)           :: pes
          integer(I32P),                    intent(in)            :: np
          real(R64P),                       intent(in), optional  :: inz
          real(R64P),                       intent(in), optional  :: incz
          character(len=64),                intent(in)            :: shape_name
          real(R64P),                       intent(in), optional  :: r
          real(R64P),                       intent(in), optional  :: inphi
          real(R64P),                       intent(in), optional  :: inth
          real(R64P),                       intent(in), optional  :: incphi
          real(R64P),                       intent(in), optional  :: incth
          real(R64P),                       intent(in), optional  :: sphrad
          real(R64P),                       intent(in), optional  :: chebn
          real(R64P),                       intent(in), optional  :: cdeform
          logical(I32P),                    intent(in)            :: verbose
          integer(I32P),                    intent(inout)         :: ierr
          logical(I32P),dimension(5),       intent(inout)         :: fp_flags

          ! Locals
          integer(I32P)     :: i
          real(R64P)        :: term1,phi,theta,x,y,z,u
          character(len=40) :: sdate,stime
!DIR$     IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)    :: status_value
!DIR$     ENDIF
          ! Exec code .....
          ! Input arguments checking
          if(ierr = 0_I32P) ierr = 0_I32P
          if(any(fp_flags)) then
              fp_flags = .false.
          end if

          ! Begin computation
          select case (trim(shape_name))
          case("Cylindrical")
              if(  present(inz)  .AND.  &
                   present(incz) .AND.  &
                   present(r)    .AND.  &
                   present(inth) .AND.  &
                   present(incth)       ) then

                    ! Parametric equation
                    ! Begin computation

                    z = inz
                    theta = inth
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                    call ieee_get_status(status_value)
                    call ieee_set_halting_mode(ieee_all,.false.)
                    call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
                    do i = 1_I32P,    np
                        theta = theta + incth
                        z = z + incz
                        pes(1,i) = r * cos(theta)
                        pes(2,i) = r * sin(theta)
                        pes(3,i) = z
                    end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                    call ieee_get_flag(ieee_all,fp_flags)
                    if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_ensemble_shape: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
                    end if
                   call ieee_set_status(status_value)
!DIR$ ENDIF
              else
                   if(verbose == .true.) then
                          call print_non_fatal_error( "========================== Non-Fatal Error =========================", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_ensemble_shape]: -- Optional argument(s) non present", &
                               sdate,stime,__LINE__)
                   end if
                   ierr = -1_I32P
                   return
              end if
          case("Spheroidal")
              if(present(r)      .AND. &
                 present(inth)   .AND. &
                 present(incth)  .AND. &
                 present(inphi)  .AND. &
                 present(incphi)        )  then
                    ! Parametric equation
                    ! Begin computation
                    theta = inth
                    phi   = inphi
 !DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                    call ieee_get_status(status_value)
                    call ieee_set_halting_mode(ieee_all,.false.)
                    call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
                    do i = 1_I32P,  np
                        theta = theta + incth
                        phi   = phi   + incphi
                        u = r * cos(phi)
                        pes(1,i) = sqrt(r**2 - u**2) * cos(theta)
                        pes(2,i) = sqrt(r**2 - u**2) * sin(theta)
                        pes(3,i) = u
                    end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                    call ieee_get_flag(ieee_all,fp_flags)
                    if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_ensemble_shape: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
                    end if
                    call ieee_set_status(status_value)
!DIR$ ENDIF
              else
                  if(verbose == .true.) then
                      call print_non_fatal_error( "========================== Non-Fatal Error =========================", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_ensemble_shape]: -- Optional argument(s) non present", &
                               sdate,stime,__LINE__)
                  end if
                  ierr = -1_I32P
                  return
              end if
          case("ChebyshevParticle")
               if(present(inth)   .AND.  &
                  present(incth)  .AND.  &
                  present(inphi)  .AND.  &
                  present(incphi) .AND.  &
                  present(sphrad) .AND.  &
                  present(chebn)  .AND.  &
                  present(cdeform)              ) then
                    ! Parametric equation
                    ! Begin computation
                     theta = inth
                     phi   = inphi
                     x = 0.0_R64P
                     y = 0.0_R64P
                     z = 0.0_R64P
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                    call ieee_get_status(status_value)
                    call ieee_set_halting_mode(ieee_all,.false.)
                    call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
                    do i = 1_I32P,   np
                        theta = theta + incth
                        phi   = phi   + incphi
                        term1 = sphrad * (1.0_R64P + cdeform * cos(chebn * theta)
                        x = term1 * sin(theta) * cos(phi)
                        pes(1,i) = x
                        y = term1 * sin(theta) * sin(phi)
                        pes(2,i) = y
                        z = term1 * cos(theta)
                        pes(3,i) = z
                    end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                    call ieee_get_flag(ieee_all,fp_flags)
                    if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_ensemble_shape: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
                    end if
                    call ieee_set_status(status_value)
!DIR$ ENDIF
              else
                  if(verbose == .true.) then
                        call print_non_fatal_error( "========================== Non-Fatal Error =========================", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_ensemble_shape]: -- Optional argument(s) non present", &
                               sdate,stime,__LINE__)
                  end if
                  ierr = -1_I32P
                  return
              end if
          case default
                if(verbose == .true.) then
                     call print_non_fatal_error( "========================== Non-Fatal Error =========================", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_ensemble_shape]: -- Invalid switch argument", &
                               sdate,stime,__LINE__)
                end if
                ierr = -2_I32P
                return
          end select
          ierr = 0_I32P
    end subroutine

    !=================================================================71
    !
    !     Chebyshev Particles parametric equation in parameter 'x'
    !     x = r0[1+- eTn(cos(theta))]sin(theta) cos(phi)
    !
    !=================================================================71
    subroutine compute_x_param(ppx,maxx,np,sphrad,chebn,cdeform,inith,incth,  &
                               iniphi,incphi,verbose,ierr,fp_flags        )
!DIR$   IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$   ENDIF
          use mod_print_error, only : print_non_fatal_error
          use mod_constants,   only : LAM_dtcoeff
          real(R64P),       dimension(maxx,np),     intent(out)    :: ppx
          integer(I32P),                            intent(in)    :: maxx
          integer(I32P),                            intent(in)    :: np
          real(R64P),       dimension(np),          intent(in)    :: sphrad
          real(R64P),       dimension(np),          intent(in)    :: chebn
          real(R64P),       dimension(np),          intent(in)    :: cdeform
          real(R64P),                               intent(in)    :: inith
          real(R64P),                               intent(in)    :: incth
          real(R64P),                               intent(in)    :: iniphi
          real(R64P),                               intent(in)    :: incphi
          logical(I32P),                            intent(in)    :: verbose
          integer(I32P),                            intent(inout) :: ierr
          logical(I32P),  dimension(5),             intent(inout) :: fp_flags
          ! Locals
          integer(I32P)     :: j,i
          real(R64P)        :: term,theta,phi,x
          character(len=40) :: sdate,stime
!DIR$     IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)    :: status_value
!DIR$     ENDIF
          ! Exec code ....
          ! Sanity check
          if(ierr = 0_I32P) ierr = 0_I32P
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          if( iniphi < 0.0_R64P .OR. iniphi > 4.0*Deg90toRad ) then
              if(verbose == .true. ) then
                  call print_non_fatal_error(  " =================== Non-Fatal Error ===================== " , &
                         " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_x_param]: -- Invalid Argument!! " , &
                                 sdate,stime,__LINE__  )
              end if
              ierr = -1_I32P
              return
          end if
          do j = 1_I32P,  size(LAM_dtcoeff)
              if(incphi  /= LAM_dtcoeff(i)) then
                  if(verbose == .true. ) then
                      call print_non_fatal_error(  " =================== Non-Fatal Error ===================== ", &
                             " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_x_param]: -- Invalid incth or incphi value!!", &
                                sdate,stime, __LINE__ )
                  end if
                  ierr = -2_I32P
                  return
              end if
          end do
          term  = 0.0_R64P
          theta = inith
          phi   = iniphi
          x     = 0.0_R64P
          ! Begin computational loop
          do j = 1_I32P,     np
               ! Check ieee fp-exception register status per each iteration of 'j' loop
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_status(status_value)
              call ieee_set_halting_mode(ieee_all,.false.)
              call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
              do i  = 1_I32P,  maxx
                  theta = theta + incth
                  phi   = phi   + incphi
                  term = sphrad(j) * (1.0_R64P + cdeform(j) * cos(chebn(j) * theta)
                  x    = term * sin(theta) * cos(phi)
                  ppx(i,j) = x
              end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                call ieee_get_flag(ieee_all,fp_flags)
                if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_x_param: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags, "at iteration: ", j
                        print "====================================================================================================="
                end if
                call ieee_set_status(status_value)
!DIR$ ENDIF
          end do
          ierr = 0_I32P
    end subroutine

    !==========================================================================80
    !     Chebyshev Particles parametric equation in parameter 'y'
    !     x = r0[1+- eTn(cos(theta))]sin(theta) sin(phi)
    !==========================================================================80
    subroutine compute_y_param(ppy,maxy,np,sphrad,chebn,cdeform,inith,incth,   &
                                iniphi,incphi,verbose,ierr,fp_flags         )
!DIR$   IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$   ENDIF
          use mod_print_error, only : print_non_fatal_error
          use mod_constants,   only : LAM_dtcoeff
          real(R64P),       dimension(maxy,np),     intent(out) :: ppy
          integer(I32P),                            intent(in)  :: maxy
          integer(I32P),                            intent(in)  :: np
          real(R64P),       dimension(np),          intent(in)    :: sphrad
          real(R64P),       dimension(np),          intent(in)    :: chebn
          real(R64P),       dimension(np),          intent(in)    :: cdeform
          real(R64P),                               intent(in)    :: inith
          real(R64P),                               intent(in)    :: incth
          real(R64P),                               intent(in)    :: iniphi
          real(R64P),                               intent(in)    :: incphi
          logical(I32P),                            intent(in)    :: verbose
          integer(I32P),                            intent(inout) :: ierr
          logical(I32P),  dimension(5),             intent(inout) :: fp_flags
          ! Locals
          integer(I32P)     :: j,i
          real(R64P)        :: term,theta,phi,y
          character(len=40) :: sdate,stime
!DIR$     IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)    :: status_value
!DIR$     ENDIF
          ! Exec code ....
          ! Sanity check
            ! Exec code .....
          ! Sanity checks
          if(ierr < 0_I32P) ierr = 0_I32P
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          if( iniphi < 0.0_R64P .OR. iniphi > 4.0_R64P*Deg90toRad  ) then
              if(verbose == .true. ) then
                  call print_non_fatal_error(   " =================== Non-Fatal Error ===================== " , &
                                " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_y_param]: -- Invalid Argument!! " , &
                                 sdate,stime,__LINE__  )
              end if
              ierr = -1_I32P
              return
          end if
          do i = 1_I32P, size(LAM_dtcoeff)
              if( incphi /= LAM_dtcoeff(i)) then
                  if(verbose == .true.) then
                       call print_non_fatal_error(  " =================== Non-Fatal Error ===================== ", &
                                " Module name: -- [mod_cheb_particles_aggregate],  subroutine name: [compute_y_param]: -- Invalid incth or incphi value!!", &
                                sdate,stime, __LINE__ )
                  end if
                  ierr = -2_I32P
                  return
              end if
          end do
          term  = 0.0_R64P
          theta = inith
          phi   = iniphi
          y     = 0.0_R64P
          ! Begin a computation loop
          do j = 1_I32P,  np
             ! Check ieee fp-exception register status per each iteration of 'j' loop
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_status(status_value)
              call ieee_set_halting_mode(ieee_all,.false.)
              call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
              do i = 1_I32P, maxy
                  theta = theta + incth
                  phi   = phi   + incphi
                  term = sphrad(j) * 1.0_R64P + cdeform(j) * cos(chebn(j) * theta)
                  y = term * sin(theta) * sin(phi)
                  ppy(i,j) = y
              end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                call ieee_get_flag(ieee_all,fp_flags)
                if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_y_param: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags, "at iteration: ", j
                        print "====================================================================================================="
                end if
                call ieee_set_status(status_value)
!DIR$ ENDIF
          end do
          ierr = 0_I32P
    end subroutine

    !==========================================================================80
    !     Chebyshev Particles parametric equation in parameter 'z'
    !     x = r0[1+- eTn(cos(theta))]sin(theta)
    !==========================================================================80
    subroutine compute_z_param(ppz,maxz,np,sphrad,chebn,cdeform,inith,incth,verbose,ierr,fp_flags)
!DIR$  IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$  ENDIF
          use mod_print_error, only : print_non_fatal_error
          use mod_constants,   only : LAM_dtcoeff
          real(R64P),       dimension(maxz,np),     intent(out)   :: ppz
          integer(I32P),                            intent(in)    :: maxz
          integer(I32P),                            intent(in)    :: np
          real(R64P),       dimension(np),          intent(in)    :: sphrad
          real(R64P),       dimension(np),          intent(in)    :: chebn
          real(R64P),       dimension(np),          intent(in)    :: cdeform
          real(R64P),                               intent(in)    :: inith
          real(R64P),                               intent(in)    :: incth
          logical(I32P),                            intent(in)    :: verbose
          integer(I32P),                            intent(inout) :: ierr
          logical(I32P),    dimension(5),           intent(inout) :: fp_flags
          ! Locals
          integer(I32P) :: j,i
          real(R64P)    :: term,theta,z
          character(len=40) :: sdate,stime
!DIR$    IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)    :: status_value
!DIR$    ENDIF
          ! Exec code ....
          ! Sanity check
          if(ierr < 0_I32P) ierr = 0_I32P
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          term = 0.0_R64P
          theta = 0.0_R64P
          z = 0.0_R64P
          ! Begin computational loop
          do j = 1_I32P,   np
               ! Check ieee fp-exception register status per each iteration of 'j' loop
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_status(status_value)
              call ieee_set_halting_mode(ieee_all,.false.)
              call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
              do i = 1_I32P,   maxz
                  theta = theta + incth

                        term = sphrad(j) * (1.0_R64P + cdeform(j) + cos(chebn(j) * theta))
                        z = term * cos(theta)
                        ppz(i,j) = z

              end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
                call ieee_get_flag(ieee_all,fp_flags)
                if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_z_param: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags, "at iteration: ", j
                        print "====================================================================================================="
                end if
                call ieee_set_status(status_value)
!DIR$ ENDIF
          end do
          ierr = 0_I32P

    end subroutine

    !==========================================================================80
    !           Computing Chebyshev ensemble particles volume.
    !           No argument verification is performed on array arguments like:
    !           sphrad,chebn and cdeform (these argument are verified by compute
    !                                     cross_section subroutine)
    !==========================================================================80
    subroutine  compute_ensemble_vol(tpv,np,sphrad,chebn,cdeform,fp_flags)
!DIR$  IF( USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$  ENDIF
          use mod_constants,  only : LAM_PI
          real(R64P),                     intent(out)   ::  tpv
          integer(I32P),                  intent(in)    ::  np
          real(R64P),     dimension(np),  intent(in)    ::  sphrad
          real(R64P),     dimension(np),  intent(in)    ::  chebn
          real(R64P),     dimension(np),  intent(in)    ::  cdeform
          logical(I32P),  dimension(5),   intent(inout) ::  fp_flags
          ! Locals
          integer(I32P) :: i
          real(R64P)    :: term1,term1a,term2,term3,term4
!DIR$     IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type) :: status_value
!DIR$     ENDIF
          ! Exec code ....
          ! Sanity checks
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          term1 = 0.0_R64P
          term1a = 0.0_R64P
          term2 = 0.0_R64P
          term3 = 0.0_R64P
          term4 = 0.0_R64P
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
          do i = 1_I32P,   np
                        term1 =   0.3333333333333333333333333_R64P*4.0_R64P*LAM_PI*sphrad(i)**3
                        term1a =  1.0_R64P + 1.5_R64P * cdeform(i)**2 * &
                                  (4.0_R64P*chebn(i)**2-2.0_R64P/4.0_R64P*chebn(i)**2-1.0_R64P)
                        if(iand(int(chebn(i),kind=4),1_I32P) == 0_I32P) then
                                term2 = 3.0_R64P * cdeform(i) * (1.0_R64P + cdeform(i)**2*0.25_R64P) / &
                                        (chebn(i)**2-1.0_R64P)
                                term3 = 0.25_R64P*cdeform(i)**3 / &
                                        (9.0_R64P*chebn(i)**2-1.0_R64P)
                                term4 = term1 * (term1a - term2 - term3)
                                tpv = tpv + term4
                        else
                                term2 = term1 * term1a
                                tpv = tpv + term2
                        end if
          end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print "             compute_ensemble_vol: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
          end if
          call ieee_set_status(status_value)
!DIR$ ENDIF
    end subroutine

    !==========================================================================80
    !            Computes Chebyshev particles surface area (total per ensemble)
    !            No argument verification is performed on array arguments like:
    !            sphrad,chebn and cdeform (these argument are verified by compute
    !                                     cross_section subroutine)
    !==========================================================================80
    subroutine compute_ensemble_surf(tps,np,sphrad,chebn,cdeform,fp_flags)
!DIR$  IF( USE_IEEE_EXCEPTION_HANDLING .EQ. 1
          use, intrinsic :: ieee_exceptions
!DIR$  ENDIF
          use mod_constants, only : LAM_PI
          real(R64P),                      intent(out)   :: tps
          integer(I32P),                   intent(in)    :: np
          real(R64P),       dimension(np), intent(in)    :: sphrad
          real(R64P),       dimension(np), intent(in)    :: chebn
          real(R64P),       dimension(np), intent(in)    :: cdeform
          logical(I32P),    dimension(5),  intent(inout) :: fp_flags
          ! Locals
          integer(I32P) :: i
          real(R64P)    :: term1,term2,term3,term4,term5,term5a,tmp
!DIR$     IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)  :: status_value
!DIR$     ENDIF
          ! Exec code ...
          ! Sanity check
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          term1  = 0.0_R64P
          term2  = 0.0_R64P
          term3  = 0.0_R64P
          term4  = 0.0_R64P
          term5  = 0.0_R64P
          term5a = 0.0_R64P
          tmp    = 0.0_R64P
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
          do i = 1_I32P,    np
              term1 = 4.0_R64P * LAM_PI * sphrad(i)**2

              if(iand(int(chebn(i),kind=4),1_I32P) == 0_I32P) then
                    term2 = 1.0_R64P - 2.0_R64P * cdeform(i)/(chebn(i)**2-1.0_R64P)
                    term3 = cdeform(i)**2*(chebn(i)**4+2.0_R64P*chebn(i)**2-1.0_R64P) / &
                            (4.0_R64P*chebn(i)**2-1.0_R64P)
                    term4 =  3.0_R64P*cdeform(k)**4*chebn(i)**8 / &
                             (64.0_R64P*chebn(i)**4-12.0_R64P*chebn(i)**2+1.0_R64P)
                    term5 =  -6.0_R64P*cdeform(k)**5*chebn(i)**8
                    term5a =             1.0_R64P /        &
                             ((chebn(i)**2-1.0_R64P)*(9.0_R64P*chebn(i)**2-1.0_R64P)*(25.0_R64P*chebn(i)**2-1.0_R64P))
                    tmp = term1 * (term2 + term3 - term4 - term5 * term5a)
                    tps = tps + tmp
              else
                    term2 = 1.0_R64P + cdeform(k)**2*(chebn(i)**4+2.0_R64P*chebn(i)**2-1.0_R64P) / &
                                    (4.0_R64P*chebn(i)**2-1.0_R64P)
                    term3 = 3.0_R64P*cdeform(k)**4*chebn(i)**4*0.015625_R64P
                    term4 = 1.0_R64P + 20.0_R64P*chebn(i)**2-1.0_R64P / &
                                    ((16.0_R64P*chebn(i)**2-1.0_R64P)*(4.0_R64P*chebn(i)**2-1.0_R64P))
                    tmp = term1 * (term2 - term3 * term4)
                    tps = tps + tmp
              end if

          end do
 !DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print "            compute_ensemble_surf: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
          end if
          call ieee_set_status(status_value)
!DIR$ ENDIF

    end subroutine

    !============================================================================
    !      Vertical falling speed computation based on
    !     "Fall Velocities of Hydrometeors in the Atmosphere:
    !      Refinements to Continous Analytical Power Law    "
    !      by Vitaliy I. Khvorostyanov and Judith A. Curry
    !
    !      Adding as an option turbulence correction coefficients.
    !============================================================================
    subroutine compute_vfall(pfv,nt,aRe,bRe,vb,kvisc,nx,ny,nz,A,rho_b,rho_f,mD, &
                             Re,bRet,aRet,fp_flags                          )
 !DIR$  IF(USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$  ENDIF
          real(R64P),       dimension(nt),       intent(out)    :: pfv
          integer(I32P),                         intent(in)     :: nt
          real(R64P),       dimension(nt),       intent(in)     :: aRe
          real(R64P),       dimension(nt),       intent(in)     :: bRe
          real(R64P),                            intent(in)     :: vb
          real(R64P),       dimension(nx,ny,nz), intent(in)     :: kvisc
          integer(I32P),                         intent(in)     :: nx
          integer(I32P),                         intent(in)     :: ny
          integer(I32P),                         intent(in)     :: nz
          real(R64P),                            intent(in)     :: A
          real(R64P),                            intent(in)     :: rho_b
          real(R64P),      dimension(nx,ny,nz),  intent(in)     :: rho_f
          real(R64P),                            intent(in)     :: mD
          real(R64P),                            intent(in)     :: Re
          real(R64P),      dimension(nt),        intent(in)     :: bRet  ! Turbulence correction term
          real(R64P),      dimension(nt),        intent(in)     :: aRet  ! Turbulence correction term
          logical(I32P),   dimension(5),         intent(inout)  :: fp_flags
          ! Locals
          integer(I32P) :: i,ix,iy,iz
          real(R64P)    :: term1,term2,term2a,term3
!DIR$  IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type) ::
!DIR$  ENDIF
          ! Exec code ....
          ! Sanity checking
          if(any(fp_flags)) then
              fp_flags = .false.
          end if
          term1  = 0.0_R64P
          term2  = 0.0_R64P
          term2a = 0.0_R64P
          term3  = 0.0_R64P
          if((abs(Re) - 999.0_R64P) <= EPSILON(0.0_R64P) ) then
             ! Obtain ieee floating-point register state
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_status(status_value)
              call ieee_set_halting_mode(ieee_all,.false.)
              call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
              do i = 1_I32P,  nt

                  do iz = 1_I32P,  nz
                      do iy = 1_I32P,  ny
                          do ix = 1_I32P,  nx
                              term1 = aRet(i) * kvisc(ix,iy,iz)**1.0_R64P-2.0_R64P*aRet(i)
                              term2 = 2.0_R64P*vb*9.81_R64P / A
                              if( rho_b > rho_f(ix,iy,iz) ) then
                                    term2a = abs(rho_b / rho_f(ix,iy,iz) )
                              else
                                    term2a = abs(rho_b / rho_f(ix,iy,iz) - 1.0_R64P )
                              end if
                              term3 = mD**2.0_R64P*bRet(i) - 1.0_R64P
                              pfv(i) = term1 * (term2 * term2a)**bRet(i) * term3
                          end do
                      end do
                  end do

              end do
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_flag(ieee_all,fp_flags)
              if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_vfall: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
              end if
              call ieee_set_status(status_value)
!DIR$ ENDIF
          else
                   ! Obtain ieee floating-point register state
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_status(status_value)
              call ieee_set_halting_mode(ieee_all,.false.)
              call ieee_set_flag(ieee_all,fp_flags)
!DIR$ ENDIF
              do i = 1_I32P,  nt

                  do iz = 1_I32P,  nz
                      do iy = 1_I32P,  ny
                          do ix = 1_I32P,  nx
                              term1 = aRe(i) * kvisc(ix,iy,iz)**1.0_R64P-2.0_R64P*aRe(i)
                              term2 = 2.0_R64P*vb*9.81_R64P / A
                              if( rho_b > rho_f(ix,iy,iz) ) then
                                    term2a = abs(rho_b / rho_f(ix,iy,iz) )
                              else
                                    term2a = abs(rho_b / rho_f(ix,iy,iz) - 1.0_R64P )
                              end if
                              term3 = mD**2.0_R64P*bRe(i) - 1.0_R64P
                              pfv(i) = term1 * (term2 * term2a)**bRe(i) * term3
                          end do
                      end do
                  end do

              end do

!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
              call ieee_get_flag(ieee_all,fp_flags)
              if(ANY(fp_flags)) then

                        print "====================================================================================================="
                        print " compute_vfall: FLOATING-POINT EXCEPTION(S) OCCURRED -- ", fp_flags
                        print "====================================================================================================="
              end if
              call ieee_set_status(status_value)
!DIR$ ENDIF
          end if

    end subroutine

end module mod_cheb_particles_aggregate


      real(kind=qp) zip,zero,half,one,two,three,four,eight
      parameter(zip=0._qp,zero=0._qp,half=0.5_qp,one=1._qp,two=2._qp)
      parameter(three=3._qp,four=4._qp,eight=8._qp)
      real(kind=qp) pi,pisq,pisqo6,pi3,pi6
      parameter(pi=3.14159265358979323846264338327948_qp,
     & pisq=pi*pi,pisqo6=pisq/6._qp,pi3=pisq/three,pi6=pisqo6)

      complex(kind=qp) im,impi,czip,chalf,cone,ctwo,c2ipi
      parameter(im=cmplx(zip,one,kind=qp),impi=cmplx(zip,pi,kind=qp),
     & czip=cmplx(zip,zip,kind=qp),chalf=cmplx(half,zip,kind=qp),
     & cone=cmplx(one,zip,kind=qp),ctwo=cmplx(two,zip,kind=qp),
     & c2ipi=two*impi)

      complex(kind=qp) nan
      parameter (nan = (1.e123_qp, 1.e123_qp))


! En esta subroutina calculamos las propiedades de autodifusion,
! el desplazamiento cuadratico medio
! y el coeficiente de difusion dependiente del tiempo

Subroutine WDT
  Use cte

  Implicit None

  Integer :: i, j, k,  L, ntmax
  Real    :: dif, wtx, wty, wtz, wt, time

  Open  (55, File = "wdt_D.txt")
  Open  (56, File = "wdt_W.txt")

  tim = Real(NFREC2) * Dt

  !Comenzamos el ciclo para dar la cadencia en el barrimiento temporal

  Do i = 1, KI - 1

     ntmax = KI - i

     wtx = 0
     wty = 0
     wtz = 0
     wt  = 0

     ! Iniciamos el barrimiento de particulas

     Do L = 1, Nc

        ! Ciclo para calcular el avance temporal
        Do j = 1, ntmax

           wtx = wtx + (CXR(L, i + j) - CXR(L, j))**2
           wty = wty + (CYR(L, i + j) - CYR(L, j))**2
           wtz = wtz + (CZR(L, i + j) - CZR(L, j))**2

        End Do

     End Do

     time = tim * Real(i)
     wt   = (wtx + wty + wtz)/(Real(ntmax)* Real(Nc)* 6)
     dif  = wt/time

     Write (55, *) time, dif
     Write (56, *) time, wt

  End Do

  Close (55)

  Close (56)

End Subroutine WDT


      SUBROUTINE DELPII (PHI, K2, ALPHA2, P, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>1996-05-02 DELPII Krogh  Fixed "max" for C conversion.
C>>1994-10-20 DELPII Krogh  Changes to use M77CON
C>>1991-10-10 DELPII WV Snyder JPL Original code.
C ----------------------------------------------------------------------
C        COMPUTES REAL ELLIPTIC INTEGRAL OF THE THIRD KIND
C ----------------------------------------------------------------------
      DOUBLE PRECISION PHI, K2, ALPHA2, P
      INTEGER IERR
C        IERR = 0..3, AS FOR DRJVAL AND DRFVAL
C        IERR = 4 IF ABS(PHI) > PI/2.
C
C--D replaces "?": ?ELPII, ?ERM1, ?RFVAL, ?RJVAL
C --------------------
      DOUBLE PRECISION A, B, C, PIHALF, R, RF, S, S2
      PARAMETER (PIHALF = 1.5707 96326 79489 66192 31322D0)
C ----------------------------------------------------------------------
      IF (ABS(PHI) .GT. PIHALF) THEN
         IERR = 4
         CALL DERM1 ('DELPII',4,0,'ABS(PHI) > PI/2','PHI',PHI,'.')
         RETURN
      end if
C
      S = SIN(PHI)
      C = COS(PHI)
      A = C*C
      S2 = S*S
      B = 1.0 - K2*S2
      S2 = ALPHA2*S2
      R = 1.0 - S2
      C = MAX(A,MAX(B,R))
      A = C*A
      B = C*B
      R = C*R
C
      CALL DRJVAL (A, B, C, R, P, IERR)
      IF (IERR .EQ. 0) then
         CALL DRFVAL (A, B, C, RF, IERR)
         P = SQRT(C) * S * ((S2 * C * P) / 3.0 + RF)
      end if
      RETURN
C
      END


      subroutine gp_global_coord(i, j, x, y, z)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Returns the global (x,y,z) coordinates of the j-th gausspoint in the
! i-the element
!
! Author : Sai Rapaka
!

      use comfem
      use comai, only: ns
      use combi, only: cord

      implicit none
      integer           :: i, j
      real*8            :: x, y, z

      integer           :: node, k

      x = 0.0d0
      y = 0.0d0
      z = 0.0d0

      do k=1,ns
        node = elnode(i, k)
        x = x + cord(node, 1)*Psi(i, j, k)
        y = y + cord(node, 2)*Psi(i, j, k)
        z = z + cord(node, 3)*Psi(i, j, k)
      enddo

      end subroutine gp_global_coord


program vin
  integer:: K
  real ::a(4) = (/ 2, (K,K=1,3,1) /)
  print *, (/ 2, (K,K=1,3,2) /)  + (/ (K,K=3,5,2), 6 /)
  do K=1,4
    print *,a(K)
  end do

end program vin


        subroutine idd_qmatmat(iftranspose,m,n,a,krank,l,b,work)
c
c       applies to a bunch of vectors collected together as a matrix
c       the Q matrix (or its transpose) which the routine iddp_qrpiv or
c       iddr_qrpiv has stored in a triangle of the matrix it produces
c       (stored, incidentally, as data for applying a bunch
c       of Householder reflections).
c       Use the routine qmatvec to apply the Q matrix
c       (or its transpose)
c       to a single vector, if you'd rather not provide a work array.
c
c       input:
c       iftranspose -- set to 0 for applying Q;
c                      set to 1 for applying the transpose of Q
c       m -- first dimension of both a and b
c       n -- second dimension of a
c       a -- data describing the qr decomposition of a matrix,
c            as produced by iddp_qrpiv or iddr_qrpiv
c       krank -- numerical rank
c       l -- second dimension of b
c       b -- matrix to which Q (or its transpose) is to be applied
c
c       output:
c       b -- matrix to which Q (or its transpose) has been applied
c
c       work:
c       work -- must be at least krank real*8 elements long
c
        implicit none
        save
        integer l,m,n,krank,j,k,ifrescal,mm,iftranspose
        real*8 a(m,n),b(m,l),work(krank)
c
c
        if(iftranspose .eq. 0) then
c
c
c         Handle the first iteration, j = 1,
c         calculating all scals (ifrescal = 1).
c
          ifrescal = 1
c
          j = 1
c
          do k = krank,1,-1
            if(k .lt. m) then
              mm = m-k+1
              call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                          work(k),b(k,j))
            endif
          enddo ! k
c
c
          if(l .gt. 1) then
c
c           Handle the other iterations, j > 1,
c           using the scals just computed (ifrescal = 0).
c
            ifrescal = 0
c
            do j = 2,l
c
              do k = krank,1,-1
                if(k .lt. m) then
                  mm = m-k+1
                  call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                              work(k),b(k,j))
                endif
              enddo ! k
c
            enddo ! j
c
          endif ! j .gt. 1
c
c
        endif ! iftranspose .eq. 0
c
c
        if(iftranspose .eq. 1) then
c
c
c         Handle the first iteration, j = 1,
c         calculating all scals (ifrescal = 1).
c
          ifrescal = 1
c
          j = 1
c
          do k = 1,krank
            if(k .lt. m) then
              mm = m-k+1
              call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                          work(k),b(k,j))
            endif
          enddo ! k
c
c
          if(l .gt. 1) then
c
c           Handle the other iterations, j > 1,
c           using the scals just computed (ifrescal = 0).
c
            ifrescal = 0
c
            do j = 2,l
c
              do k = 1,krank
                if(k .lt. m) then
                  mm = m-k+1
                  call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal,
     1                              work(k),b(k,j))
                endif
              enddo ! k
c
            enddo ! j
c
          endif ! j .gt. 1
c
c
        endif ! iftranspose .eq. 1
c
c
        return
        end
c
c
c
c


module bootstrap

! JLR 25/8/2015
!
! Bootstrap confidence interval for Gaussian Kernel Correlation

use correlation

implicit none

contains

real function cpdf(x)
implicit none
real, intent(in) :: x

! cumulative probability density function
!
! Abramowitz and Stegun 26.2.17

real*8 :: z

if (x.ge.0) then
  z=1d0-0.5d0/(1d0+0.196854*x+0.115194*x**2+0.000344*x**3+0.019527*x**4)**4
else
  z=0.5d0/(1d0-0.196854*x+0.115194*x**2-0.000344*x**3+0.019527*x**4)**4
endif

cpdf=z

end function

real function icpdf(x)
implicit none
real, intent(in) :: x

! inverse cumulative probability density function
!
! Algorithm AS 241 Wichura 1988

real*8 :: q,r,zp
real*8, parameter :: a0=3.3871327179d0, a1=50.434271938d0, a2=159.29113202d0
real*8, parameter :: a3=59.109374720d0, b1=17.895169469d0, b2=78.757757664d0
real*8, parameter :: b3=67.187563600d0, c0=1.4234372777d0, c1=2.7568153900d0
real*8, parameter :: c2=1.3067284816d0, c3=0.17023821103d0, d1=0.73700164250d0
real*8, parameter :: d2=0.12021132975d0, e0=6.6579051150d0, e1=3.0812263860d0
real*8, parameter :: e2=0.42868294337d0, e3=0.017337203997d0
real*8, parameter :: f1=0.24197894225d0, f2=0.012258202635d0

q=x-0.5d0

if (abs(q).le.0.425d0) then
  r=0.425d0**2-q**2
  zp=q*(((a3*r+a2)*r+a1)*r+a0)/(((b3*r+b2)*r+b1)*r+1d0)
else
  if ((x.eq.0d0).or.(x.eq.1d0)) then
    r=27d0
  else
    r=sqrt(-log(min(x,1d0-x)))
    r=min(r,27d0)
  endif
  if (r.le.5.0d0) then
    r=r-1.6d0
    zp=(((c3*r+c2)*r+c1)*r+c0)/((d2*r+d1)*r+1d0)
  else
    r=r-5.0d0
    zp=(((e3*r+e2)*r+e1)*r+e0)/((f2*r+f1)*r+1d0)
  endif
  if (q.lt.0) zp=-zp
endif

icpdf=zp

end function

subroutine add_one_sort(x)

implicit none

! add an element to a sorted list)

real, intent(inout) :: x(:)
real :: temp
integer :: i,j,n

n=size(x,1)

do i=1,n-1
  if (x(n)<x(i)) then
    temp=x(n)
    do j=n-1,i,-1
      x(j+1)=x(j)
    enddo
    x(i)=temp
    exit
  endif
enddo

end subroutine

subroutine joint_sort(a,ia,n)

implicit none

! sort a (union of two sorted lists, joined at n) perform sam operation on ia

real, intent(inout) :: a(:)
integer, intent(inout) :: ia(:)
integer, intent(in) :: n

integer :: i,j,k,m
real :: tmp(size(a,1))
integer :: itmp(size(a,1))

tmp(:)=a(:)
itmp(:)=ia(:)

i=1
j=n+1
k=1
m=size(a,1)

a(:)=-999
ia(:)=-999

do
  if (tmp(i).le.tmp(j)) then
    a(k)=tmp(i)
    ia(k)=itmp(i)
    i=i+1
  else
    a(k)=tmp(j)
    ia(k)=itmp(j)
    j=j+1
  endif
  k=k+1
  if (i>n) then
    a(k:m)=tmp(j:m)
    ia(k:m)=itmp(j:m)
    exit
  endif
  if (j>m) then
    a(k:m)=tmp(i:n)
    ia(k:m)=itmp(i:n)
    exit
  endif
!  if ((i.eq.n).and.(j.eq.m)) exit
enddo

end subroutine

function bootstrap_ci(x,y,tx,ty)
real ::  bootstrap_ci(1:2)

real, intent(in) :: x(:),y(:),tx(:),ty(:)
integer :: n,m,nm,i,j,k,iter,n_low,ierr,ci1,ci2,outer
real :: taux,tauy,txmean,tymean,rnd,p,logp,tmean,dt
real :: orig,pd,z0,a,astar,asum,a_num,a_den,b0,b1
real, allocatable :: temp(:),tstar(:)
real, allocatable :: nx(:),ny(:),ntx(:),nty(:)
real, allocatable :: bse(:)
integer, allocatable :: tmp_indx(:),indx(:,:),seq(:)
integer, parameter :: max_iter=2000
real :: med_min(25),med_max(25)
logical :: init(2)

n=size(x,1)
m=size(y,1)

allocate (temp(m+n),tstar(n+m),tmp_indx(n+m),indx(n+m,2),seq(n+m+1))
allocate (nx(n+m),ny(n+m),ntx(n+m),nty(n+m),bse(max_iter))

orig=correlate_gaussian(x,y,tx,ty)

! estimate persistence times

txmean=(tx(n)-tx(1))/(n-1)
tymean=(ty(m)-ty(1))/(m-1)
tmean=max(txmean,tymean)

do i=1,n/16
  temp(1:n)=tx(1:n)+i*txmean
  taux=correlate_gaussian(x,x,tx,temp(1:n))
  if (abs(taux)<0.368) exit
enddo
taux=i*txmean

do i=1,m/16
  temp(1:m)=ty(1:m)+i*tymean
  tauy=correlate_gaussian(y,y,temp(1:m),ty)
  if (abs(tauy)<0.368) exit
enddo
tauy=i*tymean

p=1.0-tmean/(4*max(taux,tauy))
logp=log(p)

! build integrated time-list
temp(1:n)=tx(1:n)
temp(n+1:n+m)=ty(1:m)
! index elements for series x  are positive integers, and negative for y
do i=1,n
  tmp_indx(i)=i
enddo
do i=1,m
  tmp_indx(n+i)=-i
enddo
call joint_sort(temp,tmp_indx,n)
j=1
indx(:,:)=0 ! set no data value
do i=1,n+m
  tstar(j)=temp(i)
  if (tmp_indx(i)>0) then
    indx(j,1)=tmp_indx(i)
  else
    indx(j,2)=tmp_indx(i)
  endif
  if (i.lt.n+m) then
    if (temp(i).ne.temp(i+1)) j=j+1
  endif
enddo
nm=j

! do the bootstraps
do outer=1,25 ! outer iteration
 n_low=0
 iter=1
 do ! inner iteration
  j=1
  init(:)=.false.
  ! random starting point
  call random_number(rnd)
  i=floor((nm-1)*rnd)+1
  if (indx(i,1).ne.0) then
    seq(j)=indx(i,1)
    j=j+1
    init(1)=.true.
  endif
  if (indx(i,2).ne.0) then
    seq(j)=indx(i,2)
    j=j+1
    init(2)=.true.
  endif
  ! loop for rest of points
  do
    call random_number(rnd)
    if (i.gt.1) then
      dt=tstar(i)-tstar(i-1)
    else
      dt=tstar(2)-tstar(1)
    endif
    if (rnd.gt.exp(dt/tmean*logp)) then ! start a new block
      if (.not.(init(1).and.init(2))) then ! if haven't already sampled from both series, restart iteration
        j=1
        init(:)=.false.
      endif
      call random_number(rnd)
      i=floor((nm-1)*rnd)+1
      if (indx(i,1).ne.0) then
        seq(j)=indx(i,1)
        j=j+1
      endif
      if (indx(i,2).ne.0) then
        seq(j)=indx(i,2)
        j=j+1
      endif
    else ! continue with existing block
      i=i+1
      if (i.gt.nm) i=1
      if (indx(i,1).ne.0) then
        seq(j)=indx(i,1)
        j=j+1
        init(1)=.true.
      endif
      if (indx(i,2).ne.0) then
        seq(j)=indx(i,2)
        j=j+1
        init(2)=.true.
      endif
    endif
    if (j.gt.n+m) exit ! have enough data
  enddo
  ! built up two series and correspondind time bases
  ! find start times for each series
  init(:)=.false.
  j=1
  k=1
  do i=1,n+m
    if (seq(i)>0) then
      if (init(1)) then ! already have time base
        nx(j)=x(seq(i))
        if (seq(i).gt.1) then
          dt=tx(seq(i))-tx(seq(i)-1)
        else
          dt=tx(2)-tx(1)
        endif
        ntx(j)=ntx(j-1)+dt
      else
        nx(j)=x(seq(i))
        init(1)=.true.
        if (init(2)) then
          if (ty(-seq(i-1)).gt.tx(seq(i))) then
            if (seq(i).gt.1) then
              dt=tx(seq(i))-tx(seq(i)-1)
            else
              dt=tx(2)-tx(1)
            endif
            ntx(j)=nty(k-1)+dt
          else
            ntx(j)=nty(k-1)+tx(seq(i))-ty(-seq(i-1))
          endif
        else
          ntx(j)=tx(seq(i))
        endif
      endif
      j=j+1
    else
      if (init(2)) then ! already have time base
        ny(k)=y(-seq(i))
        if (-seq(i).gt.1) then
          dt=ty(-seq(i))-ty(-seq(i)-1)
        else
          dt=ty(2)-ty(1)
        endif
        nty(k)=nty(k-1)+dt
      else
        ny(k)=y(-seq(i))
        init(2)=.true.
        if (init(1)) then
          if (tx(seq(i-1)).gt.ty(-seq(i))) then
            if (-seq(i).gt.1) then
              dt=ty(-seq(i))-ty(-seq(i)-1)
            else
              dt=ty(2)-ty(1)
            endif
            nty(k)=ntx(j-1)+dt
          else
            nty(k)=ntx(j-1)+ty(-seq(i))-tx(seq(i-1))
          endif
        else
          nty(k)=ty(-seq(i))
        endif
      endif
      k=k+1
    endif
  enddo
  j=j-1
  k=k-1
  bse(iter)=correlate_gaussian(nx(1:j),ny(1:k),ntx(1:j),nty(1:k))
  if (bse(iter)<orig) n_low=n_low+1
  if (iter>1) call add_one_sort(bse(1:iter))
  iter=iter+1
  if (iter.gt.max_iter) exit
 enddo

!calcalate bias parameter
 z0=icpdf(real(n_low)/max_iter)

!calculate accelation parameter
 asum=0.0
 do i=1,max_iter
   asum=asum+bse(i)
 enddo
 astar=0.0
 do i=1,max_iter
   astar=astar+(asum-bse(i))/(max_iter-1)
 enddo
 astar=astar/max_iter
 a_num=0.0
 a_den=0.0
 do i=1,max_iter
   a_num=a_num+(astar-(asum-bse(i))/(max_iter-1))**3
   a_den=a_den+(astar-(asum-bse(i))/(max_iter-1))**2
 enddo
 a=a_num/(6.0*exp(1.5*log(a_den)))

! calculate interval points
 b0=z0+(z0-1.960)/(1-a*(z0-1.960))
 b1=z0+(z0+1.960)/(1-a*(z0+1.960))

 ci1=min(max(floor(iter*cpdf(b0)),1),max_iter)
 ci2=max(min(ceiling(iter*cpdf(b1)),max_iter),1)

 med_min(outer)=bse(ci1)
 med_max(outer)=bse(ci2)

 if (outer>1) then
   call add_one_sort(med_min(1:outer))
   call add_one_sort(med_max(1:outer))
 endif

! print *,bse(ci1),bse(ci2)

enddo

bootstrap_ci(1)=med_min(13)
bootstrap_ci(2)=med_max(13)

deallocate (temp,tstar,indx,tmp_indx,seq)
deallocate (nx,ny,ntx,nty,bse)

end function

end module


       function pow_2(T,i)
        implicit none

        type(Tensor2), intent(in) :: T
        integer, intent(in) :: i

        type(Tensor2) :: pow_2
        integer :: j

        if (i > 0) then
         pow_2 = T
         do j=1,i-1
          pow_2 = pow_2*T
         end do
        else if (i == 0) then
         pow_2 = identity2(T)
        else
         pow_2 = inv(T)
        end if

       end function pow_2

       function pow_2s(T,i)
        implicit none

        type(Tensor2s), intent(in) :: T
        integer, intent(in) :: i

        type(Tensor2s) :: pow_2s
        integer :: j

        if (i > 0) then
         pow_2s = T
         do j=1,i-1
          pow_2s = pow_2s*T
         end do
        else if (i == 0) then
         pow_2s = identity2(T)
        else
         pow_2s = inv(T)
        end if

       end function pow_2s


*> \brief \b SLA_LIN_BERR computes a component-wise relative backward error.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLA_LIN_BERR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLA_LIN_BERR( N, NZ, NRHS, RES, AYB, BERR )
*
*       .. Scalar Arguments ..
*       INTEGER            N, NZ, NRHS
*       ..
*       .. Array Arguments ..
*       REAL               AYB( N, NRHS ), BERR( NRHS )
*       REAL               RES( N, NRHS )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    SLA_LIN_BERR computes componentwise relative backward error from
*>    the formula
*>        max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
*>    where abs(Z) is the componentwise absolute value of the matrix
*>    or vector Z.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>     The number of linear equations, i.e., the order of the
*>     matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NZ
*> \verbatim
*>          NZ is INTEGER
*>     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to
*>     guard against spuriously zero residuals. Default value is N.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>     The number of right hand sides, i.e., the number of columns
*>     of the matrices AYB, RES, and BERR.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] RES
*> \verbatim
*>          RES is REAL array, dimension (N,NRHS)
*>     The residual matrix, i.e., the matrix R in the relative backward
*>     error formula above.
*> \endverbatim
*>
*> \param[in] AYB
*> \verbatim
*>          AYB is REAL array, dimension (N, NRHS)
*>     The denominator in the relative backward error formula above, i.e.,
*>     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B
*>     are from iterative refinement (see sla_gerfsx_extended.f).
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*>          BERR is REAL array, dimension (NRHS)
*>     The componentwise relative backward error from the formula above.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realOTHERcomputational
*
*  =====================================================================
      SUBROUTINE SLA_LIN_BERR( N, NZ, NRHS, RES, AYB, BERR )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N, NZ, NRHS
*     ..
*     .. Array Arguments ..
      REAL               AYB( N, NRHS ), BERR( NRHS )
      REAL               RES( N, NRHS )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               TMP
      INTEGER            I, J
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. External Functions ..
      EXTERNAL           SLAMCH
      REAL               SLAMCH
      REAL               SAFE1
*     ..
*     .. Executable Statements ..
*
*     Adding SAFE1 to the numerator guards against spuriously zero
*     residuals.  A similar safeguard is in the SLA_yyAMV routine used
*     to compute AYB.
*
      SAFE1 = SLAMCH( 'Safe minimum' )
      SAFE1 = (NZ+1)*SAFE1

      DO J = 1, NRHS
         BERR(J) = 0.0
         DO I = 1, N
            IF (AYB(I,J) .NE. 0.0) THEN
               TMP = (SAFE1+ABS(RES(I,J)))/AYB(I,J)
               BERR(J) = MAX( BERR(J), TMP )
            END IF
*
*     If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know
*     the true residual also must be exactly 0.0.
*
         END DO
      END DO
*
*     End of SLA_LIN_BERR
*
      END


        subroutine idzp_rid(lproj,eps,m,n,matveca,p1,p2,p3,p4,
     1                      krank,list,proj,ier)
c
c       computes the ID of a, i.e., lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon dimensioned epsilon(m,n-krank)
c       such that the greatest singular value of epsilon
c       <= the greatest singular value of a * eps.
c
c       input:
c       lproj -- maximum usable length (in complex*16 elements)
c                of the array proj
c       eps -- precision to which the ID is to be computed
c       m -- first dimension of a
c       n -- second dimension of a
c       matveca -- routine which applies the adjoint
c                  of the matrix to be ID'd to an arbitrary vector;
c                  this routine must have a calling sequence
c                  of the form
c
c                  matveca(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the adjoint
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the adjoint of the matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matveca
c       p2 -- parameter to be passed to routine matveca
c       p3 -- parameter to be passed to routine matveca
c       p4 -- parameter to be passed to routine matveca
c
c       output:
c       krank -- numerical rank
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               the present routine uses proj as a work array, too, so
c               proj must be at least m+1 + 2*n*(krank+1) complex*16
c               elements long, where krank is the rank output
c               by the present routine
c       ier -- 0 when the routine terminates successfully;
c              -1000 when lproj is too small
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least m+1 + 2*n*(krank+1) complex*16
c               elements long, where krank is the rank output
c               by the present routine.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,list(n),krank,lw,iwork,lwork,ira,kranki,lproj,
     1          lra,ier,k
        real*8 eps
        complex*16 p1,p2,p3,p4,proj(*)
        external matveca
c
c
        ier = 0
c
c
c       Allocate memory in proj.
c
        lw = 0
c
        iwork = lw+1
        lwork = m+2*n+1
        lw = lw+lwork
c
        ira = lw+1
c
c
c       Find the rank of a.
c
        lra = lproj-lwork
        call idz_findrank(lra,eps,m,n,matveca,p1,p2,p3,p4,
     1                    kranki,proj(ira),ier,proj(iwork))
        if(ier .ne. 0) return
c
c
        if(lproj .lt. lwork+2*kranki*n) then
          ier = -1000
          return
        endif
c
c
c       Take the adjoint of ra.
c
        call idz_adjointer(n,kranki,proj(ira),proj(ira+kranki*n))
c
c
c       Move the adjoint thus obtained to the beginning of proj.
c
        do k = 1,kranki*n
          proj(k) = proj(ira+kranki*n+k-1)
        enddo ! k
c
c
c       ID the adjoint.
c
        call idzp_id(eps,kranki,n,proj,krank,list,proj(1+kranki*n))
c
c
        return
        end
c
c
c
c


program ring

  ! Accumulate the sum of the ranks by sending a message around a
  ! ring.

  ! We use a synchronous non-blocking send mpi_issend() and a non-
  ! blocking recieve mpi_irecv(), along with two wait statements.

  use mpi
  implicit none

  integer :: ifail
  integer :: rank, size
  integer :: my_prev, my_next
  integer :: sum

  ! Message information

  integer :: sendbuf, recvbuf
  integer :: req1, req2
  integer, parameter :: my_tag = 9999
  integer, dimension(MPI_STATUS_SIZE) :: status

  ! loop counter
  integer :: n

  call mpi_init(ifail)

  call mpi_comm_rank(MPI_COMM_WORLD, rank, ifail)
  call mpi_comm_size(MPI_COMM_WORLD, size, ifail)

  ! Work out neighbouring ranks

  my_prev = rank - 1
  if (my_prev < 0) my_prev = my_prev + size
  my_next = mod(rank + 1, size)

  ! Initialise the sum and the message for all ranks
  sum = 0
  sendbuf = rank

  do n = 1, size

     call mpi_irecv(recvbuf, 1, MPI_INTEGER, my_prev, my_tag, MPI_COMM_WORLD, &
                    req1, ifail)
     call mpi_issend(sendbuf, 1, MPI_INTEGER, my_next, my_tag, MPI_COMM_WORLD, &
                     req2, ifail)

     ! When the receive has completed, we can use the contents of recvbuf
     call mpi_wait(req1, status, ifail)
     sum = sum + recvbuf

     ! When the send has completed, we can safely re-use the send buffer
     call mpi_wait(req2, status, ifail)
     sendbuf = recvbuf

  end do

  ! Display the result on all ranks, along with the correct answer

  write (unit = *, fmt = '(a,i3,a,i4,a,i4)') &
       "Rank ", rank, " has sum of ranks ", sum, " Answer ", (size - 1)*size/2

  call mpi_finalize(ifail)

end program ring


function huc1(bwtdmx,bwtdmn,bctmax,bctmin)
!
implicit none
!
! Dummy arguments
!
real :: bctmax,bctmin,bwtdmn,bwtdmx
real :: huc1
!
! Local variables
!
real :: heatunit
!
!     author : amare retta
!     + + + purpose + + +
!     calculate single day heat units for given temperatures

!     + + + keywords + + +
!     heat units, daylength

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     bctmax - maximum crop growth temperature. debe assumed this definition
!     bctmin - minimum crop growth temperature
!     bctopt - optimum crop growth temperature. not currently used.
!     bwtdmn - daily minimum air temperature
!     bwtdmx - daily maximum air temperature
!     huc1 - returns the value of the function. debe assumed this definition

!     + + + local variable definitions + + +
!     heatunit - a function. this variable holds the value returned by
!                the heatunit function. debe assumed this definition

!     + + + output formats + + +
!2000 format('+',109x,2(f8.2,1x))

!     + + + function declarations + + +

!     + + + end of specifications + + +

huc1 = heatunit(bwtdmx,bwtdmn,bctmin) - heatunit(bwtdmx,bwtdmn,bctmax)
if (huc1<0.) huc1 = 0.
!
end function huc1