MODULE common
!=======================================================================
!
! [PURPOSE:] General constants and procedures
!
! [ATTENTION:] This module calls 'SFMT.f90'
!
! [HISTORY:]
!   07/20/2004 Takemasa MIYOSHI  created
!   01/23/2009 Takemasa MIYOSHI  modified for SFMT
!
!=======================================================================
  IMPLICIT NONE
  PUBLIC
  INTEGER,SAVE :: nbv=02
!-----------------------------------------------------------------------
! Variable size definitions
!-----------------------------------------------------------------------
  INTEGER,PARAMETER :: r_size=kind(0.0d0)
  INTEGER,PARAMETER :: r_dble=kind(0.0d0)
  INTEGER,PARAMETER :: r_sngl=kind(0.0e0)
!-----------------------------------------------------------------------
! Constants
!-----------------------------------------------------------------------
  REAL(r_size),PARAMETER :: pi=3.1415926535d0
  REAL(r_size),PARAMETER :: gg=9.81d0
  REAL(r_size),PARAMETER :: rd=287.05d0       ! gas constant air (J/kg/K)      GYL
  REAL(r_size),PARAMETER :: rv=461.50d0       ! gas constant H2O (J/kg/K)      GYL
  REAL(r_size),PARAMETER :: cp=1005.7d0       ! spec heat air [p] (J/kg/K)
  REAL(r_size),PARAMETER :: hvap=2.5d6        ! heat of vaporization (J/kg)
  REAL(r_size),PARAMETER :: fvirt=rv/rd-1.0d0 ! parameter for T/Tv conversion  GYL
  REAL(r_size),PARAMETER :: re=6371.3d3
  REAL(r_size),PARAMETER :: r_omega=7.292d-5
  REAL(r_size),PARAMETER :: t0c=273.15d0
  REAL(r_size),PARAMETER :: undef=-9.99d33

CONTAINS
!-----------------------------------------------------------------------
! Mean
!-----------------------------------------------------------------------
SUBROUTINE com_mean(ndim,var,amean)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: amean

  INTEGER :: i

  amean = 0.0d0
  DO i=1,ndim
    amean = amean + var(i)
  END DO
  amean = amean / REAL(ndim,r_size)

  RETURN
END SUBROUTINE com_mean
!-----------------------------------------------------------------------
! Standard deviation
!-----------------------------------------------------------------------
SUBROUTINE com_stdev(ndim,var,aout)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: aout

  REAL(r_size) :: amean
  REAL(r_size) :: dev(ndim)

  CALL com_mean(ndim,var,amean)

  dev(:) = var(:) - amean

  aout = SQRT( SUM(dev*dev) / REAL(ndim-1,r_size) )

  RETURN
END SUBROUTINE com_stdev
!-----------------------------------------------------------------------
! Covariance
!-----------------------------------------------------------------------
SUBROUTINE com_covar(ndim,var1,var2,cov)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var1(ndim)
  REAL(r_size),INTENT(IN) :: var2(ndim)
  REAL(r_size),INTENT(OUT) :: cov

  REAL(r_size) :: amean1,amean2
  REAL(r_size) :: dev1(ndim),dev2(ndim)

  CALL com_mean(ndim,var1,amean1)
  CALL com_mean(ndim,var2,amean2)

  dev1(:) = var1(:) - amean1
  dev2(:) = var2(:) - amean2

  cov = SUM( dev1*dev2 ) / REAL(ndim-1,r_size)

  RETURN
END SUBROUTINE com_covar
!-----------------------------------------------------------------------
! Correlation
!-----------------------------------------------------------------------
SUBROUTINE com_correl(ndim,var1,var2,cor)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var1(ndim)
  REAL(r_size),INTENT(IN) :: var2(ndim)
  REAL(r_size),INTENT(OUT) :: cor

  REAL(r_size) :: cov,stdev1,stdev2

  CALL com_stdev(ndim,var1,stdev1)
  CALL com_stdev(ndim,var2,stdev2)
  CALL com_covar(ndim,var1,var2,cov)

  cor = cov/stdev1/stdev2

  RETURN
END SUBROUTINE com_correl
!-----------------------------------------------------------------------
! Anomaly Correlation
!-----------------------------------------------------------------------
SUBROUTINE com_anomcorrel(ndim,var1,var2,varmean,cor)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var1(ndim)
  REAL(r_size),INTENT(IN) :: var2(ndim)
  REAL(r_size),INTENT(IN) :: varmean(ndim)
  REAL(r_size),INTENT(OUT) :: cor

  REAL(r_size) :: dev1(ndim),dev2(ndim)

  dev1 = var1 - varmean
  dev2 = var2 - varmean

  cor = SUM( dev1*dev2 ) / SQRT( SUM(dev1*dev1) * SUM(dev2*dev2) )

  RETURN
END SUBROUTINE com_anomcorrel
!-----------------------------------------------------------------------
! L2 Norm
!-----------------------------------------------------------------------
SUBROUTINE com_l2norm(ndim,var,anorm)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: anorm

  anorm = SQRT( SUM(var*var) )

  RETURN
END SUBROUTINE com_l2norm
!-----------------------------------------------------------------------
! RMS (root mean square)
!-----------------------------------------------------------------------
SUBROUTINE com_rms(ndim,var,rmsv)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: var(ndim)
  REAL(r_size),INTENT(OUT) :: rmsv

  rmsv = SQRT( SUM(var*var) / REAL(ndim,r_size) )

  RETURN
END SUBROUTINE com_rms
!-----------------------------------------------------------------------
! Lanczos Filter (Low-pass) with cyclic boundary
!-----------------------------------------------------------------------
SUBROUTINE com_filter_lanczos(ndim,fc,var)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: fc    ! critical frequency in [0,pi]
  REAL(r_size),INTENT(INOUT) :: var(ndim)

  INTEGER,PARAMETER :: lresol=10

  REAL(r_size) :: weight(-lresol:lresol)
  REAL(r_size) :: varwk(1-lresol:ndim+lresol)
  REAL(r_size) :: rl,rlresol
  INTEGER :: i,l
!
! Weight
!
  rlresol = REAL(lresol,r_size)
  DO l=-lresol,-1
    rl = REAL(l,r_size)
    weight(l) = SIN(fc*rl) * SIN(pi*rl/rlresol) &
      & * rlresol / pi / rl / pi / rl
  END DO
  DO l=1,lresol
    rl = REAL(l,r_size)
    weight(l) = SIN(fc*rl) * SIN(pi*rl/rlresol) &
      & * rlresol / pi / rl / pi / rl
  END DO
  weight(0) = fc / pi
!
! Cyclic boundary
!
  DO i=0,1-lresol,-1
    varwk(i) = var(ndim+i)
  END DO
  DO i=ndim+1,ndim+lresol
    varwk(i) = var(i-ndim)
  END DO
  varwk(1:ndim) = var(1:ndim)
!
! Filter
!
  var = 0.0d0
  DO i=1,ndim
    DO l=-lresol,lresol
      var(i) = var(i) + weight(l) * varwk(i+l)
    END DO
  END DO

  RETURN
END SUBROUTINE com_filter_lanczos
!-----------------------------------------------------------------------
! RAND (random number with uniform distribution)
!-----------------------------------------------------------------------
SUBROUTINE com_rand(ndim,var)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(OUT) :: var(1:ndim)
  REAL(r_dble) :: genrand_res53
  INTEGER :: idate(8)
  INTEGER :: i,iseed
  LOGICAL,SAVE :: first=.true.

  IF (first) THEN
    CALL DATE_AND_TIME(VALUES=idate)
    iseed = idate(8) + idate(7)*1000
    !iseed = 1 ! for debug, SK 20190425 for LPF to reproduce the same experiments
    CALL init_gen_rand(iseed)
    first=.false.
  END IF

  DO i=1,ndim
    var(i) = genrand_res53()
  END DO

  RETURN
END SUBROUTINE com_rand
!-----------------------------------------------------------------------
SUBROUTINE com_rand_seed(ndim,iseed,var) ! from KK 20200426
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim, iseed
  REAL(r_size),INTENT(OUT) :: var(1:ndim)
  REAL(r_dble) :: genrand_res53
  INTEGER :: idate(8)
  INTEGER :: i, jseed
  LOGICAL,SAVE :: first=.true.

  IF (first) THEN
    !!!print *, first, iseed
    IF( iseed==0 ) THEN
      CALL DATE_AND_TIME(VALUES=idate)
      jseed = idate(8) + idate(7)*1000
    ELSE
      jseed = iseed
    ENDIF
    CALL init_gen_rand(jseed)
    first=.false.
  END IF

  DO i=1,ndim
    var(i) = genrand_res53()
  END DO

  RETURN
END SUBROUTINE com_rand_seed
!-----------------------------------------------------------------------
! RANDN (random number with normal distribution)
!-----------------------------------------------------------------------
SUBROUTINE com_randn(ndim,var)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(OUT) :: var(1:ndim)
  REAL(r_size) :: rnd(2)
  REAL(r_dble) :: genrand_res53
  INTEGER :: idate(8)
  INTEGER :: i,iseed
  LOGICAL,SAVE :: first=.true.

  IF (first) THEN
    CALL DATE_AND_TIME(VALUES=idate)
    iseed = idate(8) + idate(7)*1000
    CALL init_gen_rand(iseed)
    first=.false.
  END IF

  IF( MOD(ndim,2)==0 ) THEN
    DO i=1,ndim/2
      rnd(1) = genrand_res53()
      rnd(2) = genrand_res53()
      var(i*2-1) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
      var(i*2) = sqrt( -2.0d0 * log( rnd(1) ) ) * cos( 2.0d0*pi*rnd(2) )
    END DO
  ELSE
    DO i=1,(ndim-1)/2
      rnd(1) = genrand_res53()
      rnd(2) = genrand_res53()
      var(i*2-1) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
      var(i*2) = sqrt( -2.0d0 * log( rnd(1) ) ) * cos( 2.0d0*pi*rnd(2) )
    END DO
    rnd(1) = genrand_res53()
    rnd(2) = genrand_res53()
    var(ndim) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
  END IF

  RETURN
END SUBROUTINE com_randn
!NO,SOFAR!!-----------------------------------------------------------------------
!NO,SOFAR!SUBROUTINE com_randn_seed(ndim,iseed,var) ! from KK 20200426
!NO,SOFAR!  IMPLICIT NONE
!NO,SOFAR!
!NO,SOFAR!  INTEGER,INTENT(IN) :: ndim, iseed
!NO,SOFAR!  REAL(r_size),INTENT(OUT) :: var(1:ndim)
!NO,SOFAR!  REAL(r_size) :: rnd(2)
!NO,SOFAR!  REAL(r_dble) :: genrand_res53
!NO,SOFAR!  INTEGER :: i
!NO,SOFAR!  LOGICAL,SAVE :: first=.true.
!NO,SOFAR!
!NO,SOFAR!  IF (first) THEN
!NO,SOFAR!    CALL init_gen_rand(iseed)
!NO,SOFAR!    first=.true.
!NO,SOFAR!  END IF
!NO,SOFAR!
!NO,SOFAR!  IF( MOD(ndim,2)==0 ) THEN
!NO,SOFAR!    DO i=1,ndim/2
!NO,SOFAR!      rnd(1) = genrand_res53()
!NO,SOFAR!      rnd(2) = genrand_res53()
!NO,SOFAR!      var(i*2-1) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
!NO,SOFAR!      var(i*2) = sqrt( -2.0d0 * log( rnd(1) ) ) * cos( 2.0d0*pi*rnd(2) )
!NO,SOFAR!    END DO
!NO,SOFAR!  ELSE
!NO,SOFAR!    DO i=1,(ndim-1)/2
!NO,SOFAR!      rnd(1) = genrand_res53()
!NO,SOFAR!      rnd(2) = genrand_res53()
!NO,SOFAR!      var(i*2-1) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
!NO,SOFAR!      var(i*2) = sqrt( -2.0d0 * log( rnd(1) ) ) * cos( 2.0d0*pi*rnd(2) )
!NO,SOFAR!    END DO
!NO,SOFAR!    rnd(1) = genrand_res53()
!NO,SOFAR!    rnd(2) = genrand_res53()
!NO,SOFAR!    var(ndim) = sqrt( -2.0d0 * log( rnd(1) ) ) * sin( 2.0d0*pi*rnd(2) )
!NO,SOFAR!  END IF
!NO,SOFAR!
!NO,SOFAR!  RETURN
!NO,SOFAR!END SUBROUTINE com_randn_seed
!-----------------------------------------------------------------------
! TIMEINC
!-----------------------------------------------------------------------
SUBROUTINE com_timeinc_hr(iy,im,id,ih,incr)
  IMPLICIT NONE

  INTEGER,INTENT(INOUT) :: iy
  INTEGER,INTENT(INOUT) :: im
  INTEGER,INTENT(INOUT) :: id
  INTEGER,INTENT(INOUT) :: ih
  INTEGER,INTENT(IN) :: incr

  ih = ih + incr
  IF(ih>23) THEN
    ih = ih - 24
    id = id + 1
    IF(id==29.AND.im==2.AND.mod(iy,4)/=0) THEN
      id = 1
      im = 3
    ELSE IF(id==30.AND.im==2.AND.mod(iy,4)==0) THEN
      id = 1
      im = 3
    ELSE IF(id==31.AND.(im==4.OR.im==6.OR.im==9.OR.im==11)) THEN
      id = 1
      im = im + 1
    ELSE IF(id==32.AND.(im==1.OR.im==3.OR.im==5.OR.im==7.OR.im==8.OR.im==10)) THEN
      id = 1
      im = im + 1
    ELSE IF(id==32.AND.im==12) THEN
      id = 1
      im = 1
      iy = iy + 1
    END IF
  END IF

  RETURN
END SUBROUTINE com_timeinc_hr
!-----------------------------------------------------------------------
! TIMECONVERSION
!-----------------------------------------------------------------------
SUBROUTINE com_time2ymdh(itime,iy,im,id,ih)
  IMPLICIT NONE
  INTEGER(8),INTENT(IN) :: itime
  INTEGER,INTENT(OUT) :: iy
  INTEGER,INTENT(OUT) :: im
  INTEGER,INTENT(OUT) :: id
  INTEGER,INTENT(OUT) :: ih

  iy = INT(  itime / 1000000 )
  im = INT( (itime-iy*1000000) / 10000 )
  id = INT( (itime-iy*1000000-im*10000) / 100 )
  ih = INT(  itime-iy*1000000-im*10000-id*100 )

  RETURN
END SUBROUTINE com_time2ymdh

SUBROUTINE com_ymdh2time(iy,im,id,ih,itime)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: iy
  INTEGER,INTENT(IN) :: im
  INTEGER,INTENT(IN) :: id
  INTEGER,INTENT(IN) :: ih
  INTEGER(8),INTENT(OUT) :: itime

  itime=iy*1000000+im*10000+id*100+ih

  RETURN
END SUBROUTINE com_ymdh2time
!-----------------------------------------------------------------------
! DISTANCE BETWEEN TWO POINTS (LONa,LATa)-(LONb,LATb)
!-----------------------------------------------------------------------
SUBROUTINE com_distll(ndim,alon,alat,blon,blat,dist)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: ndim
  REAL(r_size),INTENT(IN) :: alon(ndim)
  REAL(r_size),INTENT(IN) :: alat(ndim)
  REAL(r_size),INTENT(IN) :: blon(ndim)
  REAL(r_size),INTENT(IN) :: blat(ndim)
  REAL(r_size),INTENT(OUT) :: dist(ndim)
  REAL(r_size),PARAMETER :: r180=1.0d0/180.0d0
  REAL(r_size) :: lon1,lon2,lat1,lat2
  REAL(r_size) :: cosd(ndim)
  INTEGER :: i

  DO i=1,ndim
    lon1 = alon(i) * pi * r180
    lon2 = blon(i) * pi * r180
    lat1 = alat(i) * pi * r180
    lat2 = blat(i) * pi * r180

    cosd(i) = SIN(lat1)*SIN(lat2) + COS(lat1)*COS(lat2)*COS(lon2-lon1)
    cosd(i) = MIN( 1.d0,cosd(i))
    cosd(i) = MAX(-1.d0,cosd(i))

    dist(i) = ACOS( cosd(i) ) * re
  END DO

  RETURN
END SUBROUTINE com_distll
!-----------------------------------------------------------------------
! DISTANCE BETWEEN TWO POINTS (LONa,LATa)-(LONb,LATb)
!-----------------------------------------------------------------------
SUBROUTINE com_distll_1(alon,alat,blon,blat,dist)
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: alon
  REAL(r_size),INTENT(IN) :: alat
  REAL(r_size),INTENT(IN) :: blon
  REAL(r_size),INTENT(IN) :: blat
  REAL(r_size),INTENT(OUT) :: dist
  REAL(r_size),PARAMETER :: r180=1.0d0/180.0d0
  REAL(r_size) :: lon1,lon2,lat1,lat2
  REAL(r_size) :: cosd

  lon1 = alon * pi * r180
  lon2 = blon * pi * r180
  lat1 = alat * pi * r180
  lat2 = blat * pi * r180

  cosd = SIN(lat1)*SIN(lat2) + COS(lat1)*COS(lat2)*COS(lon2-lon1)
  cosd = MIN( 1.d0,cosd)
  cosd = MAX(-1.d0,cosd)

  dist = ACOS( cosd ) * re

  RETURN
END SUBROUTINE com_distll_1

FUNCTION com_distll_1f(alon,alat,blon,blat) RESULT(dist)
  IMPLICIT NONE
  REAL(r_size) :: alon
  REAL(r_size) :: alat
  REAL(r_size) :: blon
  REAL(r_size) :: blat
  REAL(r_size) :: dist
  REAL(r_size),PARAMETER :: r180=1.0d0/180.0d0
  REAL(r_size) :: lon1,lon2,lat1,lat2
  REAL(r_size) :: cosd

  lon1 = alon * pi * r180
  lon2 = blon * pi * r180
  lat1 = alat * pi * r180
  lat2 = blat * pi * r180

  cosd = SIN(lat1)*SIN(lat2) + COS(lat1)*COS(lat2)*COS(lon2-lon1)
  cosd = MIN( 1.d0,cosd)
  cosd = MAX(-1.d0,cosd)

  dist = ACOS( cosd ) * re

  RETURN
END FUNCTION com_distll_1f
!-----------------------------------------------------------------------
! Cubic spline interpolation
!   [Reference:] Akima, H., 1970: J. ACM, 17, 589-602.
!-----------------------------------------------------------------------
SUBROUTINE com_interp_spline(ndim,x,y,n,x5,y5)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: ndim         ! number of grid points
  REAL(r_size),INTENT(IN) :: x(ndim) ! coordinate
  REAL(r_size),INTENT(IN) :: y(ndim) ! variable
  INTEGER,INTENT(IN) :: n            ! number of targets
  REAL(r_size),INTENT(IN) :: x5(n)   ! target coordinates
  REAL(r_size),INTENT(OUT) :: y5(n)  ! target values
  INTEGER :: i,j,m
  REAL(r_size) :: dydx(5),ddydx(4),t(2),dx21,dx
  REAL(r_size) :: wk

  TGT: DO j=1,n
    DO i=1,ndim
      IF(x5(j) == x(i)) THEN
        y5(j) = y(i)
        CYCLE TGT
      END IF
      IF(x5(j) < x(i)) EXIT
    END DO
!       i-3   i-2   i-1    i    i+1   i+2
!     ---+-----+-----+---*-+-----+-----+---
!dydx       1     2     3     4     5
!ddydx         1     2     3     4
!t                   1     2
    IF(i==2) THEN
      DO m=3,5
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(2) = 2.0d0*dydx(3) - dydx(4)
      dydx(1) = 2.0d0*dydx(2) - dydx(3)
    ELSE IF(i==3) THEN
      DO m=2,5
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(1) = 2.0d0*dydx(2) - dydx(3)
    ELSE IF(i==ndim) THEN
      DO m=1,3
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(4) = 2.0d0*dydx(3) - dydx(2)
      dydx(5) = 2.0d0*dydx(4) - dydx(3)
    ELSE IF(i==ndim-1) THEN
      DO m=1,4
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
      dydx(5) = 2.0d0*dydx(4) - dydx(3)
    ELSE
      DO m=1,5
        dydx(m) = (y(i-3+m)-y(i-4+m)) / (x(i-3+m)-x(i-4+m))
      END DO
    END IF
    DO m=1,4
      ddydx(m) = ABS(dydx(m+1) - dydx(m))
    END DO
    DO m=1,2
      wk = ddydx(m+2) + ddydx(m)
      IF(wk == 0) THEN
        t(m) = 0.0d0
      ELSE
        t(m) = (ddydx(m+2)*dydx(m+1)+ddydx(m)*dydx(m+2))/wk
      END IF
    END DO
    dx21 = x(i)-x(i-1)
    dx = x5(j) - x(i-1)
    y5(j) = y(i-1) &
        & + dx*t(1) &
        & + dx*dx*(3.0d0*dydx(3)-2.0d0*t(1)-t(2))/dx21 &
        & + dx*dx*dx*(t(1)+t(2)-2.0d0*dydx(3))/dx21/dx21
  END DO TGT

  RETURN
END SUBROUTINE com_interp_spline
!-----------------------------------------------------------------------
! (LON,LAT) --> (i,j) conversion
!   [ORIGINAL AUTHOR:] Masaru Kunii
!-----------------------------------------------------------------------
SUBROUTINE com_pos2ij(msw,nx,ny,flon,flat,num_obs,olon,olat,oi,oj)
  IMPLICIT NONE
  ! --- inout variables
  INTEGER,INTENT(IN) :: msw   !MODE SWITCH: 1: fast, 2: accurate
  INTEGER,INTENT(IN) :: nx,ny !number of grid points
  REAL(r_size),INTENT(IN) :: flon(nx,ny),flat(nx,ny) !(lon,lat) at (i,j)
  INTEGER,INTENT(IN) :: num_obs !repetition number of conversion
  REAL(r_size),INTENT(IN) :: olon(num_obs),olat(num_obs) !target (lon,lat)
  REAL(r_size),INTENT(OUT) :: oi(num_obs),oj(num_obs) !target (i,j)
  ! --- local work variables
  LOGICAL,PARAMETER :: detailout = .FALSE.
  INTEGER,PARAMETER :: num_grid_ave = 4  ! fix
  INTEGER :: inum,ix,jy,ip,wk_maxp
  INTEGER :: iorder_we,iorder_sn
  INTEGER :: nxp,nyp
  REAL(r_size),PARAMETER :: miss = -32768
  REAL(r_size),PARAMETER :: max_dist = 2.0e+6
  REAL(r_size) :: rlat_max, rlat_min, rlon_max, rlon_min
  REAL(r_size) :: dist(num_grid_ave)
  REAL(r_size) :: dist_min_x(num_obs, num_grid_ave)
  REAL(r_size) :: dist_min_y(num_obs, num_grid_ave)
  REAL(r_size) :: wk_dist, sum_dist
  REAL(r_size) :: ratio(num_grid_ave)
  IF(detailout) THEN
    WRITE(6,'(A)') '====================================================='
    WRITE(6,'(A)') '      Detailed output of SUBROUTINE com_pos2ij       '
    WRITE(6,'(A)') '====================================================='
  END IF
  ! ================================================================
  !   Check the Order of flon, flat
  ! ================================================================
  iorder_we = 1
  iorder_sn = 1
  IF(flon(1,1) > flon(2,1)) THEN
    iorder_we = -1
  END IF
  IF(flat(1,1) > flat(1,2)) THEN
    iorder_sn = -1
  END IF
  IF(detailout) THEN
    WRITE(6,'(3X,A,I5)') 'Obs Order (WE) :',iorder_we
    WRITE(6,'(3X,A,I5)') 'Obs Order (SN) :',iorder_sn
  END IF
  ! ================================================================
  !  FAST MODE
  ! ================================================================
  IF(msw == 1) THEN
    ! ==============================================================
    !   Surrounding 4 Grid Points Interpolation
    ! ==============================================================
    Obs_Loop_1 : DO inum=1,num_obs
      IF(detailout) WRITE(6,'(A,I5,2F15.5)') '*** START OBS ',inum,olon(inum),olat(inum)
      ! ------------------------------------------------------------
      !    Search Basic Point
      ! ------------------------------------------------------------
      nxp = miss
      nyp = miss
      DO jy=1,ny-1
        DO ix=1,nx-1
          rlon_max = MAXVAL(flon(ix:ix+1, jy:jy+1))
          rlon_min = MINVAL(flon(ix:ix+1, jy:jy+1))
          rlat_max = MAXVAL(flat(ix:ix+1, jy:jy+1))
          rlat_min = MINVAL(flat(ix:ix+1, jy:jy+1))
          IF(rlon_min <= olon(inum) .AND. rlon_max >= olon(inum) .AND. &
           & rlat_min <= olat(inum) .AND. rlat_max >= olat(inum)) THEN
            nxp = ix
            nyp = jy
            EXIT
          END IF
        END DO
      END DO
      IF(detailout) WRITE(6,'(3X,A,2I7)') 'nxp, nyp =',nxp,nyp
      IF(nxp == miss .OR. nyp == miss) THEN
        WRITE(6,'(A)') '!!WARNING(com_pos2ij): obs position cannot be detected'
        oi(inum) = miss
        oj(inum) = miss
        CYCLE Obs_Loop_1
      END IF
      ! ------------------------------------------------------------
      !    Interpolation
      ! ------------------------------------------------------------
      CALL com_distll_1(flon(nxp  ,nyp  ),flat(nxp  ,nyp  ),&
                      & olon(inum),olat(inum),dist(1))
      CALL com_distll_1(flon(nxp+1,nyp  ),flat(nxp+1,nyp  ),&
                      & olon(inum),olat(inum),dist(2))
      CALL com_distll_1(flon(nxp  ,nyp+1),flat(nxp  ,nyp+1),&
                      & olon(inum),olat(inum),dist(3))
      CALL com_distll_1(flon(nxp+1,nyp+1),flat(nxp+1,nyp+1),&
                      & olon(inum),olat(inum),dist(4))
      dist(1:4) = dist(1:4) * 1.D-3
      IF(detailout) WRITE(6,'(3X,A,4F15.5)') 'distance :',dist(1:4)
      sum_dist = dist(1) * dist(1) * dist(2) * dist(2) * dist(3) * dist(3) &
             & + dist(2) * dist(2) * dist(3) * dist(3) * dist(4) * dist(4) &
             & + dist(3) * dist(3) * dist(4) * dist(4) * dist(1) * dist(1) &
             & + dist(4) * dist(4) * dist(1) * dist(1) * dist(2) * dist(2)
      ratio(1) = (dist(2)*dist(2)*dist(3)*dist(3)*dist(4)*dist(4))/sum_dist
      ratio(2) = (dist(3)*dist(3)*dist(4)*dist(4)*dist(1)*dist(1))/sum_dist
      ratio(3) = (dist(4)*dist(4)*dist(1)*dist(1)*dist(2)*dist(2))/sum_dist
      ratio(4) = (dist(1)*dist(1)*dist(2)*dist(2)*dist(3)*dist(3))/sum_dist
      IF(detailout) WRITE(6,'(3X,A,5F15.5)') 'ratio    :',ratio(1:4),SUM(ratio(1:4))
      oi(inum) = ratio(1) *  nxp    + ratio(2) * (nxp+1) &
             & + ratio(3) *  nxp    + ratio(4) * (nxp+1)
      oj(inum) = ratio(1) *  nyp    + ratio(2) *  nyp    &
             & + ratio(3) * (nyp+1) + ratio(4) * (nyp+1)
      IF(detailout) WRITE(6,'(3X,A,2F15.5)') 'position :',oi(inum), oj(inum)

    END DO Obs_Loop_1
  ! ================================================================
  !  ACCURATE MODE
  ! ================================================================
  ELSE IF(msw == 2) THEN
    ! ================================================================
    !   Nearest 4 Grid Points Interpolation
    ! ================================================================
    Obs_Loop_2 : DO inum=1,num_obs
      IF(detailout) WRITE(6,'(A,I5,2F15.5)') '*** START OBS ',inum,olon(inum),olat(inum)
      ! ------------------------------------------------------------
      !    Search 4-Grid Points
      ! ------------------------------------------------------------
      dist(1:num_grid_ave) = 1.D+10
      wk_maxp = num_grid_ave
      DO jy=1,ny
        DO ix=1,nx
          CALL com_distll_1(flon(ix,jy),flat(ix,jy),&
                          & olon(inum) ,olat(inum) ,wk_dist)
          IF(wk_dist > max_dist) CYCLE
          IF(wk_dist < dist(wk_maxp)) THEN
            dist(wk_maxp) = wk_dist
            dist_min_x(inum, wk_maxp) = ix
            dist_min_y(inum, wk_maxp) = jy
            DO ip = 1, num_grid_ave
              IF(dist(ip) == maxval(dist(1:num_grid_ave))) THEN
                wk_maxp = ip
                EXIT
              END IF
            END DO
          END IF
        END DO
      END DO
      IF(detailout) WRITE(6,'(A,4(A,I4,A,I4,A))')  '  Intp Grids : ', &
        & '(', INT(dist_min_x(inum, 1)), ',', INT(dist_min_y(inum, 1)), ') ', &
        & '(', INT(dist_min_x(inum, 2)), ',', INT(dist_min_y(inum, 2)), ') ', &
        & '(', INT(dist_min_x(inum, 3)), ',', INT(dist_min_y(inum, 3)), ') ', &
        & '(', INT(dist_min_x(inum, 4)), ',', INT(dist_min_y(inum, 4)), ') '
      ! ------------------------------------------------------------
      !    Interpolation
      ! ------------------------------------------------------------
      dist(1:num_grid_ave) =  dist(1:num_grid_ave) * 1.0D-3
      sum_dist = dist(1) * dist(1) * dist(2) * dist(2) * dist(3) * dist(3)  &
             & + dist(2) * dist(2) * dist(3) * dist(3) * dist(4) * dist(4)  &
             & + dist(3) * dist(3) * dist(4) * dist(4) * dist(1) * dist(1)  &
             & + dist(4) * dist(4) * dist(1) * dist(1) * dist(2) * dist(2)
      ratio(1) = (dist(2)*dist(2)*dist(3)*dist(3)*dist(4)*dist(4))/sum_dist
      ratio(2) = (dist(3)*dist(3)*dist(4)*dist(4)*dist(1)*dist(1))/sum_dist
      ratio(3) = (dist(4)*dist(4)*dist(1)*dist(1)*dist(2)*dist(2))/sum_dist
      ratio(4) = (dist(1)*dist(1)*dist(2)*dist(2)*dist(3)*dist(3))/sum_dist
      IF(detailout) WRITE(6,'(2X,A,5F15.5)') 'ratio      :',ratio(1:4),SUM(ratio(1:4))
      oi(inum) = SUM(ratio(1:num_grid_ave) * dist_min_x(inum, 1:num_grid_ave))
      oj(inum) = SUM(ratio(1:num_grid_ave) * dist_min_y(inum, 1:num_grid_ave))
      IF(detailout) WRITE(6,'(2X,A,2F15.5)') 'position   :',oi(inum),oj(inum)
    END DO Obs_Loop_2
  END IF

  RETURN
END SUBROUTINE com_pos2ij
!-----------------------------------------------------------------------
! UTC to TAI93
!-----------------------------------------------------------------------
SUBROUTINE com_utc2tai(iy,im,id,ih,imin,sec,tai93)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: iy,im,id,ih,imin
  REAL(r_size),INTENT(IN) :: sec
  REAL(r_size),INTENT(OUT) :: tai93
  REAL(r_size),PARAMETER :: mins = 60.0d0
  REAL(r_size),PARAMETER :: hour = 60.0d0*mins
  REAL(r_size),PARAMETER :: day = 24.0d0*hour
  REAL(r_size),PARAMETER :: year = 365.0d0*day
  INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
  INTEGER :: days,i

  tai93 = REAL(iy-1993,r_size)*year + FLOOR(REAL(iy-1993)/4.0,r_size)*day
  days = id -1
  DO i=1,12
    IF(im > i) days = days + mdays(i)
  END DO
  IF(MOD(iy,4) == 0 .AND. im > 2) days = days + 1 !leap year
  tai93 = tai93 + REAL(days,r_size)*day + REAL(ih,r_size)*hour &
              & + REAL(imin,r_size)*mins + sec
  IF(iy > 1993 .OR. (iy==1993 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1994 .OR. (iy==1994 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1995) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1997 .OR. (iy==1997 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 1998) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 2005) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 2008) tai93 = tai93 + 1.0d0 !leap second
  IF(iy > 2012 .OR. (iy==2012 .AND. im > 6)) tai93 = tai93 + 1.0d0 !leap second

  RETURN
END SUBROUTINE com_utc2tai
!-----------------------------------------------------------------------
! TAI93 to UTC
!-----------------------------------------------------------------------
SUBROUTINE com_tai2utc(tai93,iy,im,id,ih,imin,sec)
  IMPLICIT NONE
  INTEGER,PARAMETER :: n=8 ! number of leap seconds after Jan. 1, 1993
  INTEGER,PARAMETER :: leapsec(n) = (/  15638399,  47174400,  94608001,&
                                  &    141868802, 189302403, 410227204,&
                                  &    504921605, 615254406/)
  REAL(r_size),INTENT(IN) :: tai93
  INTEGER,INTENT(OUT) :: iy,im,id,ih,imin
  REAL(r_size),INTENT(OUT) :: sec
  REAL(r_size),PARAMETER :: mins = 60.0d0
  REAL(r_size),PARAMETER :: hour = 60.0d0*mins
  REAL(r_size),PARAMETER :: day = 24.0d0*hour
  REAL(r_size),PARAMETER :: year = 365.0d0*day
  INTEGER,PARAMETER :: mdays(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
  REAL(r_size) :: wk,tai
  INTEGER :: days,i,leap

  tai = tai93
  sec = 0.0d0
  DO i=1,n
    IF(FLOOR(tai93) == leapsec(i)+1) sec = 60.0d0 + tai93-FLOOR(tai93,r_size)
    IF(FLOOR(tai93) > leapsec(i)) tai = tai -1.0d0
  END DO
  iy = 1993 + FLOOR(tai /year)
  wk = tai - REAL(iy-1993,r_size)*year - FLOOR(REAL(iy-1993)/4.0,r_size)*day
  IF(wk < 0.0d0) THEN
    iy = iy -1
    wk = tai - REAL(iy-1993,r_size)*year - FLOOR(REAL(iy-1993)/4.0,r_size)*day
  END IF
  days = FLOOR(wk/day)
  wk = wk - REAL(days,r_size)*day
  im = 1
  DO i=1,12
    leap = 0
    IF(im == 2 .AND. MOD(iy,4)==0) leap=1
    IF(im == i .AND. days >= mdays(i)+leap) THEN
      im = im + 1
      days = days - mdays(i)-leap
    END IF
  END DO
  id = days +1

  ih = FLOOR(wk/hour)
  wk = wk - REAL(ih,r_size)*hour
  imin = FLOOR(wk/mins)
  IF(sec < 60.0d0) sec = wk - REAL(imin,r_size)*mins

  RETURN
END SUBROUTINE com_tai2utc
!-----------------------------------------------------------------------
! Date and time regulation
!-----------------------------------------------------------------------
SUBROUTINE com_datetime_reg(iy,im,id,ih,imin,isec)
  IMPLICIT NONE
  INTEGER, INTENT(INOUT) :: iy,im,id,ih,imin,isec
  INTEGER :: mdays

  DO WHILE(im <= 0)
    im = im + 12
    iy = iy - 1
  END DO
  DO WHILE(im > 12)
    im = im - 12
    iy = iy + 1
  END DO
  DO WHILE(isec < 0)
    isec = isec + 60
    imin = imin - 1
  END DO
  DO WHILE(isec >= 60)
    isec = isec - 60
    imin = imin + 1
  END DO
  DO WHILE(imin < 0)
    imin = imin + 60
    ih = ih - 1
  END DO
  DO WHILE(imin >= 60)
    imin = imin - 60
    ih = ih + 1
  END DO
  DO WHILE(ih < 0)
    ih = ih + 24
    id = id - 1
  END DO
  DO WHILE(ih >= 24)
    ih = ih - 24
    id = id + 1
  END DO
  DO WHILE(id <= 0)
    im = im - 1
    IF(im <= 0) THEN
      im = im + 12
      iy = iy - 1
    END IF
    CALL com_mdays(iy,im,mdays)
    id = id + mdays
  END DO
  CALL com_mdays(iy,im,mdays)
  DO WHILE(id > mdays)
    id = id - mdays
    im = im + 1
    IF(im > 12) THEN
      im = im - 12
      iy = iy + 1
    END IF
    CALL com_mdays(iy,im,mdays)
  END DO

  RETURN
END SUBROUTINE com_datetime_reg
!-----------------------------------------------------------------------
! Number of days of the month
!-----------------------------------------------------------------------
SUBROUTINE com_mdays(iy,im,mdays)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: iy,im
  INTEGER, INTENT(OUT) :: mdays

  SELECT CASE(im)
  CASE(1,3,5,7,8,10,12)
    mdays = 31
  CASE(4,6,9,11)
    mdays = 30
  CASE(2)
    mdays = 28
    IF(MOD(iy,100) == 0) THEN
      IF(MOD(iy,400) == 0) THEN
        mdays = 29
      END IF
    ELSE IF(MOD(iy,4) == 0) THEN
      mdays = 29
    END IF
  CASE DEFAULT
    WRITE(6,'(A)') '[Error] com_mdays: invalid month.'
    STOP
  END SELECT
END SUBROUTINE com_mdays

!===============================================================================
recursive subroutine quick_sort_asnd(var,init,first,last)
implicit none
  integer :: first, last, i, j, it
  integer :: init(*)
  real(r_size) :: var(*) , x,t

  x = var( (first+last) / 2 )
  i = first  ;  j = last
  do
    do while (var(i) < x)  ;  i=i+1  ;  end do
    do while (x < var(j))  ;  j=j-1  ;  end do
    if (i >= j) exit
      t       = var(i)  ;  var(i)  = var(j)  ;  var(j)  = t
      it      = init(i) ;  init(i) = init(j) ;  init(j) = it
      i       = i + 1   ;  j       = j - 1
  end do
  if (first < i - 1 ) call quick_sort_asnd(var,init, first, i - 1)
  if (j + 1 < last  ) call quick_sort_asnd(var,init, j + 1, last )

  return
end subroutine quick_sort_asnd

!=============================================================================== SK from KK 20200408
!-----------------------------------------------------------------------
! Kullback–Leibler divergence (KLD)     ! KK 20160414
!-----------------------------------------------------------------------
subroutine com_kld(ndim, var1, kld)
  implicit none
  INTEGER, INTENT(IN)      :: ndim
  REAL(r_size),INTENT(IN)  :: var1(ndim)
  REAL(r_size),INTENT(OUT) :: kld
  REAL(r_size) :: hstg(ndim)
  REAL(r_size) :: work1(ndim)
  REAL(r_size) :: mean, var, std
  REAL(r_size) :: alpha, w
  REAL(r_size) :: threshold, x
  REAL(r_size) :: p, q, kld_tmp
  INTEGER :: ic, iclass, class_lmt
  INTEGER :: i

  kld = 0.d0
  work1(:) = var1(:)

  call qsort(ndim, work1)

  !--- calc. variance ---!
  mean = sum(work1(:))/dble(ndim)
  work1(:) = work1(:)-mean
  var = sum(work1(:)**2)/dble(ndim-1)
  if( var==0.0d0 )then
    kld= undef
    return
  endif
  std = sqrt(var)
  work1(:) = work1(:)/std

! do i = 1, ndim
!   print *, i, work1(i)
! end do

  !--- set histogram parameters ---!
  var = 1.d0
  std = 1.d0
  alpha = ndim**(1.d0/3.d0)
  w = 3.5d0*std/alpha

  !--- make histogram ---!
  iclass = 1
  do while(w*iclass+0.5d0*w < 10.d0*std)  !!!!  change 10.d0 - > 20.d0
!   print *, iclass, w*iclass+0.5d0*w, 10.d0*std
    iclass = iclass + 1
  end do
  class_lmt = iclass

  ic = 0
  iclass = 1
  hstg(:) = 0.d0
  i = 1
  do while(i <= ndim)
    threshold = -w*(class_lmt+0.5d0) + w*iclass
    if(work1(i) < threshold) then
      ic = ic + 1
!     print '(I5,I4,I6,2F11.5,F6.0)', ic, iclass, i, work1(i), threshold
    else
      hstg(iclass) = dble(ic)
!     print '(I5,I4,I6,2F11.5,F6.0)', ic, iclass, i, work1(i), threshold, hstg(iclass)
      iclass = iclass + 1
      ic = 0
      i = i - 1
    end if
    i = i + 1
  end do
  hstg(iclass) = dble(ic)
! print '(F8.0,I5)', sum(hstg(:)), iclass

  !--- normalize distribution ---!
  hstg(:) = hstg(:)/ndim

  !--- KL divergence ---!
  do iclass = 1, class_lmt*2+1
    x = w*iclass-w*(class_lmt+1)
    p = hstg(iclass)
    q = dexp(-x**2/(2*var))/dsqrt(2*pi*var)*w
    if(p == 0.d0) then
      kld_tmp = -p * log(q)
    else
      kld_tmp = p * (log(p) - log(q))
    end if
!   if(q == 0.d0) then
!     kld_tmp = p * log(p)
!   else
!     kld_tmp = p * (log(p) - log(q))
!   end if
    kld = kld + kld_tmp
!   print *, iclass, p, q
!   print '(I5,F7.0, F10.5)', iclass, hstg(iclass)*ndim, kld_tmp
  end do
  if(kld <= 0.d0) kld = 0.d0

  return
end subroutine com_KLD
!-----------------------------------------------------------------------
! KLD thresholds
!-----------------------------------------------------------------------
SUBROUTINE kld_threshold(nbv, kld_floor, kld_cap)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: nbv
  REAL(r_size), INTENT(OUT) :: kld_floor, kld_cap
  REAL(r_size) :: kld_tmp

  kld_cap = 0.60d0
! kld_cap = 0.80d0

! select case(nbv)
!   case(:19)
!     kld_tmp = 0.25d0 - (0.25d0 - 0.17d0) / 20 * nbv
!   case(20:39)
!     kld_tmp = 0.17d0 - (0.17d0 - 0.13d0) / (40-20) * (nbv-20)
!   case(40:79)
!     kld_tmp = 0.13d0 - (0.13d0 - 0.09d0) / (80-40) * (nbv-40)
!   case(80:159)
!     kld_tmp = 0.09d0 - (0.09d0 - 0.06d0) / (160-80) * (nbv-80)
!   case(160:319)
!     kld_tmp = 0.06d0 - (0.06d0 - 0.05d0) / (320-160) * (nbv-160)
!   case(320:639)
!     kld_tmp = 0.05d0 - (0.05d0 - 0.03d0) / (640-320) * (nbv-320)
!   case(640:2559)
!     kld_tmp = 0.03d0 - (0.03d0 - 0.02d0) / (2560-640) * (nbv-640)
!   case(2560:)
!     kld_tmp = 0.02d0
! end select

! select case(nbv)
!   case(:19)
!     kld_tmp = 0.25d0 - (0.25d0 - 0.09d0) / 20 * nbv
!   case(20:39)
!     kld_tmp = 0.09d0 - (0.09d0 - 0.07d0) / (40-20) * (nbv-20)
!   case(40:79)
!     kld_tmp = 0.07d0 - (0.07d0 - 0.06d0) / (80-40) * (nbv-40)
!   case(80:159)
!     kld_tmp = 0.06d0 - (0.06d0 - 0.04d0) / (160-80) * (nbv-80)
!   case(160:319)
!     kld_tmp = 0.04d0 - (0.04d0 - 0.03d0) / (320-160) * (nbv-160)
!   case(320:1279)
!     kld_tmp = 0.03d0 - (0.03d0 - 0.02d0) / (1280-320) * (nbv-320)
!   case(1280:)
!     kld_tmp = 0.02d0
! end select

  !--- 75 percentile ---!
! select case(nbv)
!   case(:19)
!     kld_tmp = 0.250d0 - (0.25d0 - 0.086d0) / 20 * nbv
!   case(20:39)
!     kld_tmp = 0.086d0 - (0.086d0 - 0.066d0) / (40-20) * (nbv-20)
!   case(40:79)
!     kld_tmp = 0.066d0 - (0.066d0 - 0.049d0) / (80-40) * (nbv-40)
!   case(80:159)
!     kld_tmp = 0.049d0 - (0.049d0 - 0.034d0) / (160-80) * (nbv-80)
!   case(160:319)
!     kld_tmp = 0.034d0 - (0.034d0 - 0.023d0) / (320-160) * (nbv-160)
!   case(320:639)
!     kld_tmp = 0.023d0 - (0.023d0 - 0.015d0) / (640-320) * (nbv-320)
!   case(640:1279)
!     kld_tmp = 0.015d0 - (0.015d0 - 0.010d0) / (1280-640) * (nbv-640)
!   case(1280:)
!     kld_tmp = 0.010d0
! end select

  !--- 80 percentile ---!
! select case(nbv)
!   case(:19)
!     kld_tmp = 0.250d0 - (0.25d0 - 0.098d0) / 20 * nbv
!   case(20:39)
!     kld_tmp = 0.098d0 - (0.098d0 - 0.072d0) / (40-20) * (nbv-20)
!   case(40:79)
!     kld_tmp = 0.072d0 - (0.072d0 - 0.053d0) / (80-40) * (nbv-40)
!   case(80:159)
!     kld_tmp = 0.053d0 - (0.053d0 - 0.037d0) / (160-80) * (nbv-80)
!   case(160:319)
!     kld_tmp = 0.037d0 - (0.037d0 - 0.024d0) / (320-160) * (nbv-160)
!   case(320:639)
!     kld_tmp = 0.024d0 - (0.024d0 - 0.016d0) / (640-320) * (nbv-320)
!   case(640:1279)
!     kld_tmp = 0.016d0 - (0.016d0 - 0.011d0) / (1280-640) * (nbv-640)
!   case(1280:2559)
!     kld_tmp = 0.011d0 - (0.011d0 - 0.010d0) / (2560-1280) * (nbv-1280)
!   case(2560:)
!     kld_tmp = 0.010d0
! end select

  !--- 85 percentile ---!
! select case(nbv)
!   case(:19)
!     kld_tmp = 0.250d0 - (0.25d0 - 0.109d0) / 20 * nbv
!   case(20:39)
!     kld_tmp = 0.109d0 - (0.109d0 - 0.084d0) / (40-20) * (nbv-20)
!   case(40:79)
!     kld_tmp = 0.084d0 - (0.084d0 - 0.059d0) / (80-40) * (nbv-40)
!   case(80:159)
!     kld_tmp = 0.059d0 - (0.059d0 - 0.040d0) / (160-80) * (nbv-80)
!   case(160:319)
!     kld_tmp = 0.040d0 - (0.040d0 - 0.026d0) / (320-160) * (nbv-160)
!   case(320:639)
!     kld_tmp = 0.026d0 - (0.026d0 - 0.017d0) / (640-320) * (nbv-320)
!   case(640:1279)
!     kld_tmp = 0.017d0 - (0.017d0 - 0.011d0) / (1280-640) * (nbv-640)
!   case(1280:2559)
!     kld_tmp = 0.011d0 - (0.011d0 - 0.010d0) / (2560-1280) * (nbv-1280)
!   case(2560:)
!     kld_tmp = 0.010d0
! end select

  !--- 90 percentile ---!
  select case(nbv)
    case(:19)
      kld_tmp = 0.250d0 - (0.25d0 - 0.125d0) / 20 * nbv
    case(20:39)
      kld_tmp = 0.125d0 - (0.125d0 - 0.096d0) / (40-20) * (nbv-20)
    case(40:79)
      kld_tmp = 0.096d0 - (0.096d0 - 0.066d0) / (80-40) * (nbv-40)
    case(80:159)
      kld_tmp = 0.066d0 - (0.066d0 - 0.044d0) / (160-80) * (nbv-80)
    case(160:319)
      kld_tmp = 0.044d0 - (0.044d0 - 0.029d0) / (320-160) * (nbv-160)
    case(320:639)
      kld_tmp = 0.029d0 - (0.029d0 - 0.018d0) / (640-320) * (nbv-320)
    case(640:1279)
      kld_tmp = 0.018d0 - (0.018d0 - 0.012d0) / (1280-640) * (nbv-640)
    case(1280:2559)
      kld_tmp = 0.012d0 - (0.012d0 - 0.010d0) / (2560-1280) * (nbv-1280)
    case(2560:)
      kld_tmp = 0.010d0
  end select

  !--- 95 percentile ---!
! select case(nbv)
!   case(:19)
!     kld_tmp = 0.250d0 - (0.25d0 - 0.158d0) / 20 * nbv
!   case(20:39)
!     kld_tmp = 0.158d0 - (0.158d0 - 0.118d0) / (40-20) * (nbv-20)
!   case(40:79)
!     kld_tmp = 0.118d0 - (0.118d0 - 0.077d0) / (80-40) * (nbv-40)
!   case(80:159)
!     kld_tmp = 0.077d0 - (0.077d0 - 0.050d0) / (160-80) * (nbv-80)
!   case(160:319)
!     kld_tmp = 0.050d0 - (0.050d0 - 0.032d0) / (320-160) * (nbv-160)
!   case(320:639)
!     kld_tmp = 0.032d0 - (0.032d0 - 0.021d0) / (640-320) * (nbv-320)
!   case(640:1279)
!     kld_tmp = 0.021d0 - (0.021d0 - 0.013d0) / (1280-640) * (nbv-640)
!   case(1280:2559)
!     kld_tmp = 0.013d0 - (0.013d0 - 0.010d0) / (2560-1280) * (nbv-1280)
!   case(2560:)
!     kld_tmp = 0.010d0
! end select

! kld_floor = max(kld_tmp, 0.02d0)
  kld_floor = max(kld_tmp, 0.010d0)

  RETURN
END SUBROUTINE kld_threshold
!-----------------------------------------------------------------------
! Quick sort     ! KK 20171110
!-----------------------------------------------------------------------
recursive subroutine qsort(ndim, var)
  implicit none

  INTEGER, INTENT(IN)        :: ndim
  REAL(r_size),INTENT(INOUT) :: var(ndim)
  INTEGER :: i, imin, imax, is
  REAL(r_size) :: p, it

  if(ndim == 1) return

  p = var(1)
  imin = 1
  imax = ndim
  do while(imin < imax)
    do while(var(imin) < p .and. imin < imax)
      imin = imin + 1
    enddo
    do while(p <= var(imax) .and. imin < imax)
      imax = imax - 1
    enddo
    if(imin < imax)then
      it = var(imax)
      var(imax) = var(imin)
      var(imin) = it
    endif
  enddo
  is = imax - 1
  if(is == 0) is = 1
  call qsort(is,      var(1:is))
  call qsort(ndim-is, var(is+1:ndim))

  return
end subroutine qsort
!-----------------------------------------------------------------------
recursive subroutine iqsort(ndim, var)
  implicit none

  INTEGER, INTENT(IN)    :: ndim
  INTEGER, INTENT(INOUT) :: var(ndim)
  INTEGER :: i, imin, imax, is
  INTEGER :: p, it

  if(ndim == 1) return

  p = var(1)
  imin = 1
  imax = ndim
  do while(imin < imax)
    do while(var(imin) < p .and. imin < imax)
      imin = imin + 1
    enddo
    do while(p <= var(imax) .and. imin < imax)
      imax = imax - 1
    enddo
    if(imin < imax)then
      it = var(imax)
      var(imax) = var(imin)
      var(imin) = it
    endif
  enddo
  is = imax - 1
  if(is == 0) is = 1
  call iqsort(is,      var(1:is))
  call iqsort(ndim-is, var(is+1:ndim))

  return
end subroutine iqsort
!-----------------------------------------------------------------------
recursive subroutine qsort2(ndim,var,r)
  implicit none

  integer, intent(in) :: ndim
  real(8), intent(inout) :: var(ndim)
  integer, intent(inout) :: r(ndim)
  integer :: i,imin,imax,is
  real(8) :: p, it
  integer :: ir

  if(ndim == 1) return
  p = var(1)
  imin = 1
  imax = ndim
  do while(imin < imax)
    do while(var(imin) < p .and. imin < imax)
      imin = imin + 1
    enddo
    do while(p <= var(imax) .and. imin < imax)
      imax = imax - 1
    enddo
    if(imin < imax)then
      it = var(imax)
      ir = r(imax)
      var(imax) = var(imin)
      r(imax) = r(imin)
      var(imin) = it
      r(imin) = ir
    endif
  enddo
  is = imax - 1
  if(is == 0) is = 1
  call qsort2(is, var(1:is), r(1:is))
  call qsort2(ndim-is, var(is + 1:ndim), r(is + 1:ndim))

  return
end subroutine qsort2
!-----------------------------------------------------------------------
recursive subroutine iqsort2(ndim,var,r)
  implicit none

  integer, intent(in) :: ndim
  integer, intent(inout) :: var(ndim)
  integer, intent(inout) :: r(ndim)
  integer :: i,imin,imax,is
  integer :: p, it
  integer :: ir

  if(ndim == 1) return
  p = var(1)
  imin = 1
  imax = ndim
  do while(imin < imax)
    do while(var(imin) < p .and. imin < imax)
      imin = imin + 1
    enddo
    do while(p <= var(imax) .and. imin < imax)
      imax = imax - 1
    enddo
    if(imin < imax)then
      it = var(imax)
      ir = r(imax)
      var(imax) = var(imin)
      r(imax) = r(imin)
      var(imin) = it
      r(imin) = ir
    endif
  enddo
  is = imax - 1
  if(is == 0) is = 1
  call iqsort2(is, var(1:is), r(1:is))
  call iqsort2(ndim-is, var(is + 1:ndim), r(is + 1:ndim))

  return
end subroutine iqsort2
!-----------------------------------------------------------------------
recursive subroutine qsort3(ndim,var,r)
  implicit none

  integer, intent(in) :: ndim
  real(8), intent(inout) :: var(ndim)
  real(8), intent(inout) :: r(ndim)
  integer :: i,imin,imax,is
  real(8) :: p, it, ir

  if(ndim == 1) return
  p = var(1)
  imin = 1
  imax = ndim
  do while(imin < imax)
    do while(var(imin) < p .and. imin < imax)
      imin = imin + 1
    enddo
    do while(p <= var(imax) .and. imin < imax)
      imax = imax - 1
    enddo
    if(imin < imax)then
      it = var(imax)
      ir = r(imax)
      var(imax) = var(imin)
      r(imax) = r(imin)
      var(imin) = it
      r(imin) = ir
    endif
  enddo
  is = imax - 1
  if(is == 0) is = 1
  call qsort3(is, var(1:is), r(1:is))
  call qsort3(ndim-is, var(is + 1:ndim), r(is + 1:ndim))

  return
end subroutine qsort3
END MODULE common


C  --------------------------------
C  CALCUL de la norme d'un vecteur
C  --------------------------------
C
       DOUBLE PRECISION FUNCTION NORM(R,N)
C Calcul de la norme euclidienne du vecteur R, de longueur N
       DIMENSION R(N)
       DOUBLE PRECISION R
       INTEGER N, I
C Valeur provisoire de la norme
       DOUBLE PRECISION S
C Initialion
       S=DFLOAT(0)
C Calcul du produit scalaire
       DO I=1,N
           S=S+R(I)*R(I)
       END DO
C Calcul final de la norme
       NORM=DSQRT(S)
       RETURN
       END
C
C  ---------------------------------------
c  CALCUL du residu B-AX
C  ---------------------------------------
C
       SUBROUTINE RESIDU(A,LDA,X,B,R,N)
C Calcul du residu R=B-A.X, A de dimension NxN
C dimension principale de A = LDA
       INTEGER LDA, N, I, J
       DIMENSION A(LDA,*),X(N),B(N),R(N)
       DOUBLE PRECISION A,X,B,R
C Boucle sur les composantes du vecteur residu
       DO I=1,N
           R(I)=B(I)
           DO J=1,N
               R(I)=R(I)-A(I,J)*X(J)
           END DO
       END DO
       RETURN
       END
C
C  ---------------------------------
C  CALCUL l'erreur max entre deux
C  vecteurs C et CT de taille M
C  ---------------------------------
C

        SUBROUTINE VERIF(M,CT,C)

        INTEGER  M
        double precision  C(M) , CT(M)
        double precision  ERMAX, MAXV, RELER,EPS, ONE
        INTEGER  I
        ONE  = 1.0D0
        EPS  = 1.0D-9
        ERMAX = ABS(CT(1)-C(1))
        MAXV  = ABS(C(1))
           DO  10 I=1,M
             ERMAX = MAX(ABS(CT(I)-C(I)), ERMAX)
             MAXV  = MAX(ABS(C(I)),MAXV)
 10        CONTINUE
        WRITE (6,*) 'Erreur maximum           =',ERMAX
        IF (MAXV.LE.EPS) MAXV = ONE
        RELER = ERMAX/MAXV
        WRITE (6,*) 'Erreur maximum  Relative =',RELER
        RETURN
        END

C
C  -------------------------------------------------
C  Lecture du nom des machines constituant la
C  machine virtuelle
C  -------------------------------------------------
       subroutine read_file(name)
        character*32 name
*
        character*32 machine
        integer i
 5      read(10,1000,END=100) machine
1000    format(a10)
        do 10, i=1,32
           name(i:i)=' '
10      continue
        i=1
20      continue
          if (machine(i:i).ne.' ') then
            name(i:i) = machine(i:i)
            i = i+1
            goto 20
          endif
cnot needed with gfortran        name(i:i)='\0'
        GOTO 500
******* error end of file ***************
*       we restart from beginning of file
100     rewind(10)
        GOTO 5
***********************************
 500    return
        end
C
C*******************************************************
        subroutine secdeb(t)
C****************************************************
        real*8 t,t1
        real*8 ELAPSE8
        EXTERNAL ELAPSE8
*
        t=ELAPSE8(t1)
        return
        end
C*******************************************************
        subroutine secfin(t)
C****************************************************
        real*8 t
        real*8 ELAPSE8, ZERO
        EXTERNAL ELAPSE8
*
        ZERO = 0.0
        t=ELAPSE8(ZERO)-t
        return
        end
*
C*******************************************************
       real*8 function Max(n,x)
C*******************************************************
*
       integer n
       real*8 x(n)
*
       integer i
       Max = x(1)
       do 10, i=2,n
         if ( x(i).gt.Max ) then
           Max = x(i)
         endif
 10    continue
       return
       end
*
C*******************************************************
       real*8 function Min(n,x)
C*******************************************************
*
       integer n
       real*8 x(n)
*
       integer i
       Min = x(1)
       do 10, i=2,n
         if ( x(i).lt.Min ) then
           Min = x(i)
         endif
 10    continue
       return
       end


module nrtype_m

  implicit none

  public

  integer, parameter :: DP = kind(1.0d0)
  integer, parameter :: DPC = kind((1.0d0,1.0d0))
  complex(DPC), parameter :: CMPLX_0 = (0.0_dp,0.0_dp)
  complex(DPC), parameter :: CMPLX_1 = (1.0_dp,0.0_dp)
  complex(DPC), parameter :: CMPLX_I = (0.0_dp,1.0_dp)

end module nrtype_m


! BSD 3-Clause License
!
! Copyright (c) 2020, Fabio Durastante
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
program utiltest
  !! Test of the utilities distributed with the PSFUN library in [[psfun_utils_mod]]
  use psb_base_mod
  use psfun_utils_mod
  implicit none

  ! blacs parameters
  type(psb_ctxt_type)         :: ctxt
  integer(psb_ipk_)           :: iam, np
  ! flags
  integer(psb_ipk_)           :: info
  ! Variables
  real(psb_dpk_)              :: K(2),L,u,sn,cn,dn,result
  real(psb_dpk_), parameter :: coeffs(7) = (/132.0,42.0,14.0,5.0,2.0,1.0,0.0/)
  complex(psb_dpk_)           :: cu,csn,ccn,cdn

  info=psb_success_
  call psb_init(ctxt)
  call psb_info(ctxt,iam,np)

  if (iam < 0) then
    call psb_exit(ctxt) ! This should not happen, but just in case
    stop
  endif
  if(psb_get_errstatus() /= 0) goto 9999

  if( (iam == 0).and.(np > 1) ) then
    write(psb_err_unit, *) "This is a serial example, number of processes is ",np
    goto 9999
  else if( (iam == 0).and.(np == 1)) then
    write(psb_out_unit,*) "Welcome to the utilstest program of PSFUN"
  end if

  ! Test of Horner rule for polynomial evaluation
  write(psb_out_unit,*)
  write(psb_out_unit,'("Polynomial Evaluation")')
  result = horner(coeffs,1.0_psb_dpk_)
  write(psb_out_unit,'("p(1) = ",f17.0," (should be 196)")')result

  ! Test of Elliptic Jacobi Integrals and Functions
  write(psb_out_unit,*)
  write(psb_out_unit,'("Elliptic Integrals and Jacobi Functions")')
  L = 0.5_psb_dpk_
  K = ellipkkp(L)
  write(psb_out_unit,'("L = ",f3.1," K = ",f17.15," Kp = ",f17.15)')L,K(1),K(2)
  write(psb_out_unit,'("L = 0.5 K = 1.588191701877384 Kp = 2.978718299395645 (Control Values)")')
  write(psb_out_unit,'("  Jacobi Elliptic Functions")')
  u = 1.0_psb_dpk_
  L = 0.5_psb_dpk_
  call ellipj(u,L,sn,cn,dn)
  write(psb_out_unit,'("sn = ",f17.15," cn = ",f17.15," dn = ",f17.15)')sn,cn,dn
  write(psb_out_unit,'("sn = 0.838274911024583 cn = 0.545247809300255 dn = 0.984699634947678 (Control Values)")')
  write(psb_out_unit,'("  Jacobi Elliptic Functions (Complex)")')
  cu = cmplx(0.0,0.5_psb_dpk_)
  L = 1.0_psb_dpk_
  call ellipj(cu,L,csn,ccn,cdn)
  write(psb_out_unit,'("sn = (",f3.1,",",f17.15,") cn = (",f17.15,",",f3.1,") dn = (",f17.15,",",f3.1,")")')csn,ccn,cdn
  write(psb_out_unit,'("sn = (0.0,0.521141424070547) cn = (1.127647278133671,0.0) dn = (1.000253555731494,0.0) (Control Values)")')
  call psb_exit(ctxt)
  stop

9999 call psb_error(ctxt)

  stop

end program utiltest


! Calculate PDF of two scalar fields along two axes.

subroutine calc_pdf2d(field1, field2, lo, hi, ng, &
                      num_x_bins, num_y_bins, bin_edges_x, bin_edges_y, bin_count, &
                      bin_x_sum, bin_y_sum)
    use, intrinsic :: iso_c_binding
    implicit none

    ! Assumes the two MultiFabs have the same shape and # of ghost cells.

    integer(c_int), intent(in) :: lo(3), hi(3), ng
    real(c_double), intent(in) :: field1 (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    real(c_double), intent(in) :: field2 (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    integer(c_int), intent(in) :: num_x_bins, num_y_bins
    real(c_double), intent(in) :: bin_edges_x (num_x_bins+1), bin_edges_y (num_y_bins+1)

    integer(c_int), intent(out) :: bin_count (num_x_bins*num_y_bins)
    real(c_double), intent(out) :: bin_x_sum (num_x_bins*num_y_bins), bin_y_sum (num_x_bins*num_y_bins)

    real(c_double) :: x_min, x_max, y_min, y_max
    real(c_double) :: xi, yi

    integer(c_int) :: i, j, k
    integer(c_int) :: bin_index_x, bin_index_y, jj
    integer(c_int) :: num_bins
    integer(c_int) :: ibin

    num_bins = num_x_bins*num_y_bins

    x_min = minval(bin_edges_x)
    x_max = maxval(bin_edges_x)
    y_min = minval(bin_edges_y)
    y_max = maxval(bin_edges_y)

    bin_count (:) = 0
    bin_x_sum (:) = 0.0d0
    bin_y_sum (:) = 0.0d0

    do k = lo(3), hi(3)
      do j = lo(2), hi(2)
        do i = lo(1), hi(1)

          xi = field1(i, j, k, 1)
          yi = field2(i, j, k, 1)

          if (xi < x_min .or. xi > x_max .or. yi < y_min .or. yi > y_max) cycle

          ! Dind the x bin.
          bin_index_x = -1
          do jj = 1, num_x_bins
            if (xi >= bin_edges_x(jj) .and. xi < bin_edges_x(jj+1)) then
                bin_index_x = jj
                exit
            end if
          end do
          ! If we can't find the bin, assume it goes in the last one.
          if (bin_index_x == -1) bin_index_x = num_x_bins

          ! Find the y bin.
          bin_index_y = -1
          do jj = 1, num_y_bins
            if (yi >= bin_edges_y(jj) .and. yi < bin_edges_y(jj+1)) then
                bin_index_y = jj
                exit
            end if
          end do
          ! If we can't find the bin, assume it goes in the last one.
          if (bin_index_y == -1) bin_index_y = num_y_bins

          ! Flatten index into (x, y) array.
          ibin = bin_index_y + ((bin_index_x-1) * num_y_bins)

          bin_count (ibin) = bin_count (ibin) + 1
          bin_x_sum (ibin) = bin_x_sum (ibin) + xi
          bin_y_sum (ibin) = bin_y_sum (ibin) + yi

        end do
      end do
    end do

end subroutine calc_pdf2d


      SUBROUTINE SPCANL(PHISC,ZETASC,DIVSC)
C
C THIS ROUTINE COMPUTES THE SPECTRUM FOR VARIOUS QUANTITIES
C AND PLOTS THEM. CURRENTLY THE CODE DOES SPECTRAL ANALYSIS FOR
C THE HEIGHT AND  KINETIC ENERGY.
C
C CALLED BY: STSWM
C CALLS: AGSETI, AGSETR, ANOTAT, EZXY
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C CONSTANTS
      INCLUDE 'consts.i'
C TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C COMPUTED HEIGHT SPECTRAL COEFFICIENTS
      COMPLEX PHISC(NALP)
C COMPUTED VORTICITY SPECTRAL COEFFICIENTS
      COMPLEX ZETASC(NALP)
C COMPUTED DIVERGENCE SPECTRAL COEFFICIENTS
      COMPLEX DIVSC(NALP)
C
C------ Local Parameters -----------------------------------------------
C
C     SPECIAL VALUE FOR SPECTRUM PLOTS
C
      REAL SPVAL
      PARAMETER (SPVAL=1.0E36)
C
C------ Local Variables ------------------------------------------------
C
C     STORAGE ARRAYS FOR SPECTRUM
C
      REAL PHIG(KK),KEG(KK),WAVE(KK)
C
C     TEMPORARY VARIABLES FOR SPECTRAL ANALYSIS
C
      INTEGER M,N,K,IS,JN,JM
      REAL FAC
      COMPLEX ETASC
C
C     CHARACTER ARRAYS FOR PLOT TITLES
C
      CHARACTER*64 GPH
      CHARACTER*40 XAXIS
      CHARACTER*1 DASH(1)
C
C----- Initialized Variables -------------------------------------------
C
C     FULL LINE GRAPHS
C
      DATA DASH(1) / '$' /
C
C----- Executable Statements -------------------------------------------
C
C     INITIALIZE ARRAYS
C
      DO 100 K=1,KK
         WAVE(K) = REAL(K)
         PHIG(K) = 0.0
         KEG(K) = 0.0
  100 CONTINUE
C
C     ADD MERIDIONAL WAVES ALONG DIAGONALS
C
      DO 120 JN=0,NN
        DO 110 JM=1,LDIAG(JN,1)
C
C       USE SYMMETRY OF M
C
        IF (JM .EQ. 1) THEN
           FAC = 1.0
        ELSE
           FAC = 2.0
        ENDIF
C
C          COMPUTE SPECTRAL INDEX
C
           M = JM - 1
           N = JM - 1 + JN
           IS = LDIAG(JN,2)
C
C          COMPUTE REALTIVE VORTICITY BY SUBTRACTING
C          SPECTRAL CORIOLIS TERM
C
           IF ((N .EQ. 1) .AND. (M .EQ. 0)) THEN
              ETASC = ZETASC(IS+JM) - CORSC1
           ELSEIF ((N .EQ. 1) .AND. (M .EQ. 1)) THEN
              ETASC = ZETASC(IS+JM) - CORSC2
           ELSE
              ETASC = ZETASC(IS+JM)
           ENDIF
C
C          IGNORE GLOBAL MEAN !
C
           IF (N .NE. 0) THEN
              KEG(N) = KEG(N) + FAC *
     $                 (DIVSC(IS+JM)*CONJG(DIVSC(IS+JM)) +
     $                  ETASC*CONJG(ETASC))/(4.0*A2NNP1(N))
              PHIG(N) = PHIG(N) + FAC *
     $                  PHISC(IS+JM)*CONJG(PHISC(IS+JM))*0.5
           ENDIF
  110   CONTINUE
C
  120 CONTINUE
C
C     PRINT RESULTS
C
      WRITE (6,987) NSTEP, TAU
  987 FORMAT (/, ' SPCANL: SPECTRAL ANALYSIS FOR NSTEP = ', I4,
     $           ', TAU = ', 0PF6.2, ' HRS')
C
      DO 200 K=1,KK
         WRITE (6,124) K,PHIG(K),KEG(K)
  124    FORMAT (' WAVE K = ',I4,' PHI/KE AMPLITUDE = ',1PE16.9,
     $           '/',1PE16.9)
C
C        CHECK FOR ZERO VALUES (CAUSES PROBLEMS WITH LOGARITHMIC PLOTS)
C
         IF (PHIG(K) .EQ. 0.0) THEN
            PHIG(K) = SPVAL
         ENDIF
         IF (KEG(K) .EQ. 0.0) THEN
            KEG(K) = SPVAL
         ENDIF
  200 CONTINUE
C
C     LOGARITHMIC SPECTRUM PLOTS AS FUNCTION OF WAVENUMBER
C
      IF (LGPHS) THEN
C
    5    FORMAT(A21,I2,',EXP.',A4,',',A6,',TAU = ',0PF6.2,' HRS$')
C
C        GRAPH AXIS TEXT
C
         CALL AGSETI('LINE/MAXIMUM.', 64)
         CALL AGSETR('X/LOGARITHMIC.', -1.)
         CALL AGSETR('Y/LOGARITHMIC.', -1.)
         XAXIS = 'WAVENUMBER N (LOGARITHMIC)$'
C
C        PLOT HEIGHT ERROR OVER TIME
C
         WRITE(GPH,5) 'PHI SPECTRUM,   TEST ',ICOND,CHEXP,
     $                STRUNC, TAU
C
         CALL ANOTAT(XAXIS,'M^2/S^2 (LOGARITHMIC)$',1,1,0,DASH)
         CALL EZXY(WAVE, PHIG, KK, GPH)
C
         WRITE(GPH,5) 'KE  SPECTRUM,   TEST ',ICOND,CHEXP,
     $                STRUNC, TAU
C
         CALL ANOTAT(XAXIS,'J/KG (LOGARITHMIC)$',1,1,0,DASH)
         CALL EZXY(WAVE, KEG, KK, GPH)
C
         CALL AGSETR('X/LOGARITHMIC.', 0.)
         CALL AGSETR('Y/LOGARITHMIC.', 0.)
C
C     GRAPHICS DONE
C
      ENDIF
C
      RETURN
      END


module fcn_turbine_bc_sine
#include<messenger.h>
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: ZERO,ONE,TWO,THREE,FOUR,FIVE,PI
    use type_point,     only: point_t
    use type_function,  only: function_t
    implicit none

    !>  Sine function in two coordinates
    !!
    !!  \f$ f(t, \vec{x}) = mean + amp*sin(freq_1*coord_1 + freq_2*coord_2 + phase) \f$
    !!
    !!  Function parameters:
    !!
    !!  mean    - Mean values offset
    !!  amp     - Amplitude of the sine function
    !!  freq_1  - Freqeuncy of the first coordinate of the sine function
    !!  freq_2  - Frequency of the second coordinate of the sine function
    !!  coord_1 - First coordinate of the sine function in [x,y,z,t]
    !!  coord_2 - Second coordinate of the sine function in [x,y,z,t]
    !!  phase   - Phase of the sine function
    !!
    !!  @author Mayank Sharma
    !!  @date   8/27/2017
    !!
    !-----------------------------------------------------------------------------------------------------------------
    type,   extends(function_t),    public      :: turbine_bc_sine_f

    contains

        procedure   :: init
        procedure   :: compute

    end type turbine_bc_sine_f
    !*****************************************************************************************************************

contains

    !>
    !!
    !!  @author Mayank Sharma
    !!  @date   8/27/2017
    !!
    !-----------------------------------------------------------------------------------------------------------------
    subroutine init(self)
        class(turbine_bc_sine_f),   intent(inout)       :: self

        !
        ! Set function name
        !
        call self%set_name("turbine_bc_sinusoid")

        !
        ! Set function to defualt settings
        !
        call self%add_option("mean", ONE)
        call self%add_option("amplitude", ONE)
        call self%add_option("frequency_1", TWO*PI)
        call self%add_option("frequency_2", TWO*PI)
        call self%add_option("coordinate_1", ONE)
        call self%add_option("coordinate_2", TWO)
        call self%add_option("phase", ZERO)

    end subroutine init
    !*****************************************************************************************************************

    !>
    !!
    !!  @author Mayank Sharma
    !!  @date   8/27/2017
    !!
    !-----------------------------------------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(turbine_bc_sine_f),   intent(inout)       :: self
        real(rk),                   intent(in)          :: time
        type(point_t),              intent(in)          :: coord

        real(rk)                                        :: val

        real(rk)        :: x,y,z,mean,amp,freq_1,freq_2,coord_1,coord_2, &
                           phase,compute_coord_1,compute_coord_2

        !
        ! Get inputs and function parameters
        !
        x = coord%c1_
        y = coord%c2_
        z = coord%c3_

        mean    = self%get_option_value("mean")
        amp     = self%get_option_value("amplitude")
        freq_1  = self%get_option_value("frequency_1")
        freq_2  = self%get_option_value("frequency_2")
        coord_1 = self%get_option_value("coordinate_1")
        coord_2 = self%get_option_value("coordinate_2")
        phase   = self%get_option_value("phase")

        !
        ! Compute coordinate 1
        !
        if (coord_1 == ONE) then
            compute_coord_1 = x
        else if (coord_1 == TWO) then
            compute_coord_1 = y
        else if (coord_1 == THREE) then
            compute_coord_1 = z
        else if (coord_1 == FOUR) then
            compute_coord_1 = time
        else
            compute_coord_1 = ZERO
        end if

        !
        ! Compute coordinate 2
        !
        if (coord_2 == ONE) then
            compute_coord_2 = x
        else if (coord_2 == TWO) then
            compute_coord_2 = y
        else if (coord_2 == THREE) then
            compute_coord_2 = z
        else if (coord_2 == FOUR) then
            compute_coord_2 = time
        else
            compute_coord_2 = ZERO
        end if

        val = mean + amp*sin(freq_1*compute_coord_1 + freq_2*compute_coord_2 + phase)

    end function compute
    !*****************************************************************************************************************

end module fcn_turbine_bc_sine


      SUBROUTINE PDBSEIG( SOLVER, N, A, IA, JA, DESCA, B, IB, JB, DESCB,
     $                    LAMBDA, X, IX, JX, DESCX, WORK, LWORK, IWORK,
     $                    LIWORK, INFO )
*
      IMPLICIT NONE
      INCLUDE 'solver.f'
*
*     .. Scalar Arguments ..
      INTEGER            SOLVER, N, IA, JA, IB, JB, IX, JX, LWORK,
     $                   LIWORK, INFO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( * ), B( * ), LAMBDA( * ), X( * ), WORK( * )
      INTEGER            DESCA( * ), DESCB( * ), DESCX( * ), IWORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PDBSEIG() computes all eigenvalues and eigenvectors (both right and
*  left) of a 2n-by-2n real matrix
*
*     H = [ A,  B;
*          -B, -A ],
*
*  where both A and B are n-by-n symmetric.
*  In addition, both A+B and A-B are required to be positive definite.
*
*  Only the lower triangular parts of A and B are referenced.
*
*  The structure of H leads to the following properties.
*
*     1) H is diagonalizable with n pairs of real eigenvalues
*        (lambda_i, -lambda_i).
*
*     2) The eigenvectors of H has the block structure
*
*           X = [ X_1, X_2;     Y = [ X_1, -X_2;
*                 X_2, X_1 ],        -X_2,  X_1 ],
*
*        and satisfy that
*
*           X_1**T * X_2 = X_2**T * X_1,
*           X_1**T * X_1 - X_2**T * X_2 = I,
*           Y**T * X = I,
*           H * X = X * diag(lambda, -lambda),
*           Y**T * H = diag(lambda, -lambda) * Y**T.
*
*  On exit, only the positive eigenvalues and the corresponding right
*  eigenvectors are returned.  The eigenvalues are sorted in ascending
*  order.  The eigenvectors are normalized (i.e., X = [ X_1; X_2 ] with
*  X_1**T * X_1 - X_2**T * X_2 = I).
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  This routine requires square block decomposition ( MB_A = NB_A ).
*
*  Arguments
*  =========
*
*  SOLVER  (global input) INTEGER
*          Currently supported solvers:
*             BSE_FULLBSE
*             BSE_TDA
*             BSE_FULLBSE + BSE_PRODUCT
*             BSE_FULLBSE + BSE_SVD
*             BSE_TDA + BSE_LAPACK_HEEVR
*             BSE_TDA + BSE_LAPACK_HEEV
*             BSE_TDA + BSE_LAPACK_HEEVD
*             BSE_TDA + BSE_LAPACK_HEEVX
*
*  N       (global input) INTEGER
*          The number of rows and columns to be operated on, i.e. the
*          order of the distributed submatrices sub( A ) and sub( B ).
*          N >= 0.
*
*  A       (local input) DOUBLE PRECISION pointer into the local memory
*          to an array of dimension (LLD_A, LOCc(JA+N-1)).
*          This array contains the local pieces of the N-by-N Hermitian
*          distributed matrix sub( A ). The leading N-by-N lower
*          triangular part of sub( A ) contains the lower triangular
*          part of the distributed matrix, and its strictly upper
*          triangular part is not referenced.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  B       (local input) DOUBLE PRECISION pointer into the local memory
*          to an array of dimension (LLD_B, LOCc(JB+N-1)).
*          This array contains the local pieces of the N-by-N symmetric
*          distributed matrix sub( B ). The leading N-by-N lower
*          triangular part of sub( B ) contains the lower triangular
*          part of the distributed matrix, and its strictly upper
*          triangular part is not referenced.
*          B is not referenced if TDA is used.
*
*  IB      (global input) INTEGER
*          The row index in the global array B indicating the first
*          row of sub( B ).
*
*  JB      (global input) INTEGER
*          The column index in the global array B indicating the
*          first column of sub( B ).
*
*  DESCB   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix B.
*
*  LAMBDA  (global output) DOUBLE PRECISION array, dimension (N)
*          On normal exit LAMBDA contains the positive eigenvalues of H
*          in ascending order.
*
*  X       (local output) DOUBLE PRECISION array,
*          global dimension (2N, N) for full BSE, and (N, N) for TDA,
*          local dimension ( LLD_X, LOCc(JX+N-1) )
*          On normal exit X contains the normalized right eigenvectors
*          of H corresponding to the positive eigenvalues.
*
*  IX      (global input) INTEGER
*          X's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*          In this version, only IX = JX = 1 is supported.
*
*  JX      (global input) INTEGER
*          X's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*          In this version, only IX = JX = 1 is supported.
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*          DESCX( CTXT_ ) must equal DESCA( CTXT_ )
*
*  WORK    (local workspace/output) DOUBLE PRECISION array,
*          dimension (LWORK)
*          On output, WORK( 1 ) returns the minimal amount of workspace
*          needed to guarantee completion.
*          If the input parameters are incorrect, WORK( 1 ) may also be
*          incorrect.
*
*  LWORK   (local input) INTEGER
*          The length of the workspace array WORK.
*          If LWORK = -1, the LWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the WORK/IWORK array. The required workspace is
*          returned as the first element of WORK/IWORK and no error
*          message is issued by PXERBLA.
*
*  IWORK   (local workspace/output) INTEGER array,
*          dimension (LIWORK)
*          On output, IWORK( 1 ) returns the minimal amount of workspace
*          needed to guarantee completion.
*          If the input parameters are incorrect, IWORK( 1 ) may also be
*          incorrect.
*
*  LIWORK   (local input) INTEGER
*          The length of the workspace array IWORK.
*          If LIWORK = -1, the LIWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          size for the WORK/IWORK array. The required workspace is
*          returned as the first element of WORK/IWORK and no error
*          message is issued by PXERBLA.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*          > 0:  The eigensolver did not converge.
*
*  Alignment requirements
*  ======================
*
*  This subroutine requires square blocks ( i.e., MB_X = NB_X ).
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            ICTXT, NPROW, NPCOL, MYROW, MYCOL, NB,
     $                   LWKOPT, LIWKOPT, LLWORK, LLIWORK, MROWS, MCOLS,
     $                   LLDM, INDM, INDK, INDWORK, INDGAP, INDIFAIL,
     $                   INDICLUSTER, INDIWORK, ITMP1, ITMP2
      DOUBLE PRECISION   T_EMBED, T_SLV
*     ..
*     .. Local Arrays ..
      INTEGER            DESCM( DLEN_ ), DESCK( DLEN_ ), DESCW( DLEN_ )
      DOUBLE PRECISION   DDUM( 3 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, IAND, INT
*     ..
*     .. External Functions ..
      EXTERNAL           NUMROC, MPI_WTIME
      INTEGER            NUMROC
      DOUBLE PRECISION   MPI_WTIME
*     ..
*     .. External Subroutines ..
      EXTERNAL           PDEMBED1, PDBSSOLVER1, PDBSSOLVER1_SVD,
     $                   PDSYEV, PDSYEVD, PDSYEVX, PDSYEVR,
     $                   PXERBLA, BLACS_GRIDINFO, CHK1MAT, DESCSET
!      EXTERNAL           PDLAPRNT
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      IF ( NPROW .EQ. -1 ) THEN
         INFO = -( 600+CTXT_ )
      END IF
*
*     Test the input arguments.
*
      IF ( INFO .EQ. 0 .AND. N .LT. 0 )
     $   INFO = -1
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( N, 2, N, 2, IA, JA, DESCA, 6, INFO )
      IF ( INFO .EQ. 0 )
     $   CALL CHK1MAT( N, 2, N, 2, IB, JB, DESCB, 10, INFO )
c      IF ( INFO .EQ. 0 )
c     $   CALL CHK1MAT( 2*N, 2, N, 2, IX, JX, DESCX, 15, INFO )
      IF ( INFO .EQ. 0 .AND. DESCX( MB_ ) .NE. DESCX( NB_ ) )
     $   INFO = -( 1500+MB_ )
*
*     Compute required workspace.
*
      IF ( INFO .EQ. 0 ) THEN
         LQUERY = LWORK .EQ. -1
         NB = DESCX( NB_ )
*
         IF ( IAND( SOLVER, BSE_OFFDIAG ) .EQ. BSE_FULLBSE ) THEN
            MROWS = NUMROC( N, NB, MYROW, 0, NPROW )
            MCOLS = NUMROC( N, NB, MYCOL, 0, NPCOL )
            LLDM = MAX( 1, MROWS )
            CALL DESCSET( DESCM, N, N, NB, NB, 0, 0, ICTXT, LLDM )
            CALL DESCSET( DESCK, N, N, NB, NB, 0, 0, ICTXT, LLDM )
            INDM = 1
            INDK = INDM + LLDM*MCOLS
            INDWORK = INDK + LLDM*MCOLS
            LLWORK = LWORK - INDWORK + 1
            IF ( IAND( SOLVER, BSE_VARIANT ) .EQ. BSE_PRODUCT ) THEN
               CALL PDBSSOLVER1( N, DDUM, 1, 1, DESCM, DDUM, 1, 1,
     $              DESCK, DDUM, X, IX, JX, DESCX, WORK, -1, IWORK, -1,
     $              INFO )
               LWKOPT = INT( WORK( 1 ) ) + INDWORK - 1
               LIWKOPT = IWORK( 1 )
            ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ. BSE_SVD ) THEN
               CALL PDBSSOLVER1_SVD( N, DDUM, 1, 1, DESCM, DDUM, 1, 1,
     $              DESCK, DDUM, X, IX, JX, DESCX, WORK, -1, INFO )
               LWKOPT = INT( WORK( 1 ) ) + INDWORK - 1
               LIWKOPT = 1
            END IF
         ELSE IF ( IAND( SOLVER, BSE_OFFDIAG ) .EQ. BSE_TDA ) THEN
            CALL DESCSET( DESCW, N, N, NB, NB, DESCX( RSRC_ ),
     $           DESCX( CSRC_ ), ICTXT, DESCX( LLD_ ) )
            IF ( IAND( SOLVER, BSE_VARIANT ) .EQ. BSE_LAPACK_HEEV )
     $           THEN
               CALL PDSYEV( 'V', 'L', N, A, IA, JA, DESCA, LAMBDA,
     $              X, IX, JX, DESCW, WORK, -1, INFO )
               LWKOPT = INT( WORK( 1 ) )
               LIWKOPT = 1
            ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ.
     $           BSE_LAPACK_HEEVD ) THEN
               CALL PDSYEVD( 'V', 'L', N, A, IA, JA, DESCA, LAMBDA,
     $              X, IX, JX, DESCW, WORK, -1, IWORK, -1, INFO )
               LWKOPT = INT( WORK( 1 ) )*10
               LIWKOPT = IWORK( 1 )
            ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ.
     $           BSE_LAPACK_HEEVX ) THEN
               INDGAP = 1
               INDWORK = INDGAP + NPROW*NPCOL
               INDIFAIL = 1
               INDICLUSTER = INDIFAIL + N
               INDIWORK = INDICLUSTER + 2*NPROW*NPCOL
               CALL PDSYEVX( 'V', 'A', 'L', N, A, IA, JA, DESCA,
     $              ZERO, ZERO, 0, 0, ZERO, ITMP1, ITMP2, LAMBDA, -ONE,
     $              X, IX, JX, DESCW, DDUM, -1, IWORK, -1,
     $              IWORK, IWORK, WORK, INFO )
               LWKOPT = INT( DDUM( 1 ) ) + INDWORK - 1
               LIWKOPT = IWORK( 1 ) + INDIWORK - 1
            ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ.
     $           BSE_LAPACK_HEEVR ) THEN
               CALL PDSYEVR( 'V', 'A', 'L', N, A, IA, JA, DESCA,
     $              ZERO, ZERO, 0, 0, ITMP1, ITMP2, LAMBDA,
     $              X, IX, JX, DESCW, DDUM, -1, IWORK, -1, INFO )
               LWKOPT = INT( DDUM( 1 ) )
               LIWKOPT = IWORK( 1 )
            END IF
         END IF
*
         IF ( .NOT. LQUERY ) THEN
            IF ( LWORK .LT. LWKOPT )
     $         INFO = -17
            IF ( INFO .EQ. 0 .AND. LIWORK .LT. LIWKOPT )
     $         INFO = -19
         END IF
      END IF
*
      IF ( INFO .NE. 0 ) THEN
         CALL PXERBLA( ICTXT, 'PDBSEIG', -INFO )
         RETURN
      END IF
*
      WORK( 1 ) = DBLE( LWKOPT )
      IWORK( 1 ) = LIWKOPT
      IF ( LQUERY )
     $   RETURN
*
*     Quick return if possible.
*
      IF ( N .EQ. 0 )
     $   RETURN
*
*     Call the eigensolver.
*
!      IF ( MYROW+MYCOL .EQ. 0 )
!     $   WRITE( *, * ) 'SOLVER = ', SOLVER, ';'
      IF ( IAND( SOLVER, BSE_OFFDIAG ) .EQ. BSE_FULLBSE ) THEN
*
*        Full BSE.
*
         T_EMBED = MPI_WTIME()
         CALL PDEMBED1( N, A, IA, JA, DESCA, B, IB, JB, DESCB,
     $        WORK( INDM ), 1, 1, DESCM, WORK( INDK ), 1, 1, DESCK )
         T_EMBED = MPI_WTIME() - T_EMBED
!         IF ( MYROW+MYCOL .EQ. 0 )
!     $      WRITE( *, * ) 't_embed = ', T_EMBED, ';'
!         CALL PDLAPRNT( 2*N, 2*N, WORK( INDM ), 1, 1, DESCM, 0, 0, 'M',
!     $        6, WORK( INDWORK ) )
!         IF ( MYROW+MYCOL .EQ. 0 )
!     $      WRITE( *, * ) "MM=tril(M)+tril(M)'-diag(diag(M));"
         T_SLV = MPI_WTIME()
         IF ( IAND( SOLVER, BSE_VARIANT ) .EQ. BSE_PRODUCT ) THEN
            CALL PDBSSOLVER1( N, WORK( INDM ), 1, 1, DESCM,
     $           WORK( INDK ), 1, 1, DESCK, LAMBDA,
     $           X, IX, JX, DESCX, WORK( INDWORK ), LLWORK, IWORK,
     $           LIWORK, INFO )
         ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ. BSE_SVD ) THEN
            CALL PDBSSOLVER1_SVD( N, WORK( INDM ), 1, 1, DESCM,
     $           WORK( INDK ), 1, 1, DESCK, LAMBDA,
     $           X, IX, JX, DESCX, WORK( INDWORK ), LLWORK, INFO )
         END IF
         T_SLV = MPI_WTIME() - T_SLV
!         IF ( MYROW+MYCOL .EQ. 0 )
!     $      WRITE( *, * ) 't_slv = ', T_SLV, ';'
*
      ELSE IF ( IAND( SOLVER, BSE_OFFDIAG ) .EQ. BSE_TDA ) THEN
*
*        Tamm--Dancoff approximation (TDA).
*
         IF ( IAND( SOLVER, BSE_VARIANT ) .EQ. BSE_LAPACK_HEEV ) THEN
            CALL PDSYEV( 'V', 'L', N, A, IA, JA, DESCA, LAMBDA,
     $           X, IX, JX, DESCW, WORK, LWORK, INFO )
         ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ.
     $        BSE_LAPACK_HEEVD ) THEN
            CALL PDSYEVD( 'V', 'L', N, A, IA, JA, DESCA, LAMBDA,
     $           X, IX, JX, DESCW, WORK, LWORK, IWORK, LIWORK, INFO )
         ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ.
     $        BSE_LAPACK_HEEVX ) THEN
            LLWORK = LWORK - INDWORK + 1
            LLIWORK = LIWORK - INDIWORK + 1
            CALL PDSYEVX( 'V', 'A', 'L', N, A, IA, JA, DESCA,
     $           ZERO, ZERO, 0, 0, ZERO, ITMP1, ITMP2, LAMBDA, -ONE,
     $           X, IX, JX, DESCW, WORK( INDWORK ), LLWORK,
     $           IWORK( INDIWORK ), LLIWORK, IWORK( INDIFAIL ),
     $           IWORK( INDICLUSTER ), WORK( INDGAP ), INFO )
         ELSE IF ( IAND( SOLVER, BSE_VARIANT ) .EQ.
     $        BSE_LAPACK_HEEVR ) THEN
            CALL PDSYEVR( 'V', 'A', 'L', N, A, IA, JA, DESCA,
     $           ZERO, ZERO, 0, 0, ITMP1, ITMP2, LAMBDA,
     $           X, IX, JX, DESCW, WORK, LWORK, IWORK, LIWORK, INFO )
         END IF
*
      END IF
*
      WORK( 1 ) = DBLE( LWKOPT )
      IWORK( 1 ) = LIWKOPT
*
      RETURN
*
*     End of PDBSEIG().
*
      END


        subroutine idd_random_transf00_inv(x,y,n,albetas,ixs)
        implicit real *8 (a-h,o-z)
        save
        dimension x(*),y(*),albetas(2,*),ixs(*)
c
c       implements one step of the random transform required
c       by routine idd_random_transf0_inv (please see the latter).
c
c
c        implement 2 \times 2 matrices
c
        do 1600 i=1,n
        y(i)=x(i)
 1600 continue
c
        do 1800 i=n-1,1,-1
c
        alpha=albetas(1,i)
        beta=albetas(2,i)
c
        a=y(i)
        b=y(i+1)
c
        y(i)=alpha*a-beta*b
        y(i+1)=beta*a+alpha*b
 1800 continue
c
c        implement the permutation
c
        do 2600 i=1,n
c
        j=ixs(i)
        x(j)=y(i)
 2600 continue
c
        do 2800 i=1,n
c
        y(i)=x(i)
 2800 continue
c
        return
        end
c
c
c
c
c


program ch0516
    ! Initialisation of Physical Constants, Version 2
    implicit none

    real, parameter :: atomic_mass_constant = &
        1.660538921e-27
    real, parameter :: avogadro_constant = &
        6.02214129e23
    real, parameter :: boltzmann_constant = &
        1.3806488e-23
    real, parameter :: electron_mass = &
        9.10938291e-31
    real, parameter :: elementary_charge = &
        1.602176565e-19
    real, parameter :: proton_mass = &
        1.672621777e-27
    real, parameter :: speed_of_light_in_vacuum = &
        299792458.
    real, parameter :: newtonian_constant_of_gravitation = &
        6.67384e-11

    print *, atomic_mass_constant
    print *, avogadro_constant
    print *, boltzmann_constant
    print *, electron_mass
    print *, elementary_charge
    print *, proton_mass
    print *, speed_of_light_in_vacuum
    print *, newtonian_constant_of_gravitation
end program


function frac_lay(top_loc,bot_loc,top_lay,bot_lay)
!
! this function determines the fraction of a location which
! is contained in a layer. it could also be viewed as the
! fraction of "overlap" of the linear location with a layer
! depth slice. it was written assuming that top values are
! less than bottom values
!
implicit none
!
! Dummy arguments
!
real :: bot_lay,bot_loc,top_lay,top_loc
real :: frac_lay
!
! function arguments
!
!
if (top_lay<=top_loc.and.bot_lay>top_loc) then
          ! top location is in layer
  if (bot_lay>=bot_loc) then
              ! bottom location is also in layer
     frac_lay = 1.0
  else
              ! bottom location is below layer, proportion
     frac_lay = (bot_lay-top_loc)/(bot_loc-top_loc)
  end if
else if (top_lay<bot_loc.and.bot_lay>=bot_loc) then
          ! bottom location is in layer
          ! if we are here, top location is not in layer so proportion
  frac_lay = (bot_loc-top_lay)/(bot_loc-top_loc)
else if (top_lay>top_loc.and.bot_lay<bot_loc) then
          ! location completely spans layer
  frac_lay = (bot_lay-top_lay)/(bot_loc-top_loc)
else
          ! location is not in the layer at all
  frac_lay = 0.0
end if
!
end function frac_lay