!***********************************************************************************************************************************
!**                                        S U B R O U T I N E   H E A T  E X C H A N G E                                         **
!***********************************************************************************************************************************

SUBROUTINE HEAT_EXCHANGE
  USE GLOBAL; USE GDAYC; USE SURFHE; USE TVDC; USE SHADEC; USE PREC
  IMPLICIT NONE

! Type declaration
  REAL     :: JDAY, LOCAL
  REAL(R8) :: TSUR
  REAL(R8) :: MPS_TO_MPH,W_M2_TO_BTU_FT2_DAY,FLUX_BR_TO_FLUX_SI,BOWEN_CONSTANT
  REAL(R8) :: DEG_F,DEG_C,BTU_FT2_DAY_TO_W_M2
  REAL(R8) :: STANDARD,HOUR,TAUD,SINAL,A0,TDEW_F,TAIR_F,SRO_BR,WIND_MPH,WIND2M,ACONV,BCONV
  REAL(R8) :: TSTAR,BETA,FW,RA,ETP,EA,ES,TAIRV,DTV,DTVL
  INTEGER :: IDAY,J
  !LOGICAL :: BIRDM

  REAL(R8)  :: r, solarzen, RToD, DToR, solaralt, Uo   ! SW 9/14/2018
  Real      :: directHz, diffuseHz, globalHz
  !REAL      :: albedo, dust, At, Ba, K1, AOD380nm,  AOD500nm
  REAL(R8)  :: B0, B1, BB, Beta, jme
  REAL(R8)  :: A, B, jd, t, LO, M, Mrad, sinM, sin2M, sin3M, c, TLO, v
  REAL(R8)  :: omega, lamda, second, e0, e, tananum, tanadenom, alpha, sint, theta, ep
  REAL(R8)  :: y, sin2LO, cos2LO, sin4LO, Etime, EQT
    real ::         day_decimal,Jdaym   ! ,HOUR
  REAL(R8)  :: Zone, daySavings, hh, mm, ss, timenow
  REAL(R8)  :: solarTimeFix, trueSolarTime, hourangle, harad, csz, zenith, azDenom, azRad
  REAL(R8)  :: azimuth, exoatmElevation, step1, step2, step3, refractionCorrection
  SAVE

! Data declaration

  DATA MPS_TO_MPH          /2.23714D0/, W_M2_TO_BTU_FT2_DAY /7.60796D0/, FLUX_BR_TO_FLUX_SI /0.23659D0/
  DATA BTU_FT2_DAY_TO_W_M2 /0.1314D0/
  DATA BOWEN_CONSTANT      /0.47D0/

  DATA PI/3.14159265358979323846/
  DATA SROCON/1367.00/      !W/m2

  !BIRDM= .FALSE.
  !INQUIRE(FILE='BirdMeeseSR.npt',EXIST=BIRDM)     ! SW 9/19/2018
  !IF(BIRDM)THEN
  !
  !    OPEN(9990,FILE='BirdMeeseSR.npt',STATUS='OLD')
  !    READ(9990,*)
  !    READ(9990,*)ALBEDO
  !    READ(9990,*)
  !    READ(9990,*)DUST
  !    READ(9990,*)
  !    READ(9990,*)ALBEDO
  !    READ(9990,*)
  !    READ(9990,*)AT
  !    READ(9990,*)
  !    READ(9990,*)BA
  !    READ(9990,*)
  !    READ(9990,*)K1
  !    READ(9990,*)
  !    READ(9990,*)AOD380nm
  !    READ(9990,*)
  !    READ(9990,*)AOD500nm
  !    CLOSE(9990)
  !
  !ENDIF

RETURN

!***********************************************************************************************************************************
!**                                            S H O R T  W A V E  R A D I A T I O N                                              **
!***********************************************************************************************************************************

ENTRY SHORT_WAVE_RADIATION (JDAY)
  IF(BIRDM)THEN    ! BIRD/MEESE SHORT WAVE SOLAR FORMULAE    SW 9/14/2018

    RToD = (180.0/PI)
    DToR = (PI/180.0)
    TZ(i)= TZ(i)*-1.0

! Calculates Solar position and radiation from Meeus code, currently set up for clear skies only
    CLOUD=0.0
!    year=yeard(i,k)
    year = 2004
    LEAP_YEAR             = MOD(year,4) == 0
    Jdaym=Jdayd(i,k)+TZ(i)/24.0
    call GREGORIAN_DATE(i,k)

    HOUR  =  (Jdaym-INT(Jdaym))*24
    day_decimal = day + HOUR/24.0

    if(month <= 2)then
     year = year - 1
     month = month + 12
    end if

    A = FLOOR(year/100.0)
    B = 2 - A + FLOOR(A/4)
    jd = FLOOR(365.25*(year+4716.0)) + FLOOR(30.6001*(month+1))+day_decimal + B - 1524.5         ! Eq 7.1, pg 61

! gp (Greg Pellitier) put the year and month back where they belong
    if(month == 13)then
     month = 1
     year = year + 1
    end if
    if(month == 14)then
     month = 2
     year = year + 1
    end if

! time in Julian centuries from epoch J2000.0
      t = (jd-2451545.0)/36525.0                                                               ! Eq 25.1, pg 163
! julian ephemeris millennium
      jme  = t/10.0

! calculate the Geometric Mean Longitude of the Sun, degrees
      LO = 280.46646+t*(36000.76983+0.0003032*t)                                               ! Eq 25.2, pg 163
!      LO = 280.4664567+36000.76982779*t+0.0003032028*(t**2)+(t**3)/49931-(t**4)/15300-(t**5)/2000000 ! Eq 28.2, pg 183, difference with line above is negligible
      DO WHILE(LO > 360 .or. LO < 0)
       If(LO > 360.0) LO = LO - 360
       If(LO < 0.0)   LO = LO + 360
      END DO
! calculate the Geometric Mean Anomaly of the Sun, degrees
      M = 357.52911 + t*(35999.05029-0.0001537*t)                                              ! Eq 25.3, pg 163
! calculate the eccentricity of earth's orbit
      e = 0.016708634 - t*(0.000042037+0.0000001267*t)                                         ! Eq 25.4, pg 163
! calculate the equation of center for the sun, degrees
      Mrad = DToR*M
      sinM = Sin(Mrad)
      sin2M = Sin(2*Mrad)
      sin3M = Sin(3*Mrad)
      c = sinM*(1.914602-t*(0.004817+0.000014*t))+sin2M*(0.019993-0.000101*t)+sin3M*0.000289   ! Between Eq 25.4 and Eq 25.5, pg 164
! calculate the true longitude of the sun, degrees
      TLO = LO + c                                                                             ! Between Eq 25.4 and Eq 25.5, pg 164
! calculate the true anomaly of the sun, degrees
      v = M + c                                                                                ! Between Eq 25.4 and Eq 25.5, pg 164
! calculate the distance to the sun in AU
      r = (1.000001018*(1 - e*e))/(1 + e*Cos(DToR*v))                                          ! Eq 25.5, pg 164
! calculate the apparent longitude of the sun, degrees
      omega = 125.04 - 1934.136*t                                                              ! Between Eq 25.5 and Eq 25.6, pg 164
!      omega  = 125.04452 - 1934.136261*t+0.0020708*(t**2)+(t**3)/45000                        ! Equation on page 144, difference with line above is negligible
      lambda = TLO - 0.00569 - 0.00478*Sin(DToR*omega)                                         ! Between Eq 25.5 and Eq 25.6, pg 164
! calculate the mean obliquity of the ecliptic, degrees
      seconds = 21.448 - t*(46.8150 + t*(0.00059 - 0.001813*t))                                ! Eq 22.2, pg 147
      e0 = 23.0 + (26.0 + (seconds/60.0))/60.0                                                 ! Eq 22.2, pg 147
! calculate the corrected obliquity of the ecliptic, degrees
      ep = e0 + 0.00256 * Cos(DToR*omega)
!      ep = e0 + (9.20/3600.0)*Cos(DToR*omega)+(0.57/3600.0)*cos(DToR*2*LO)                    ! Eq on page 144, still truncated though here in code, difference with line above is negligible

! earth heliocentric latitude, BB, degrees, Equations 9 to 12, NREL/TP-560-34302
      B0   = 280.0*Cos(3.199+84334.662*jme)+102.0*Cos(5.422+5507.553*jme)+  &
              80.0*Cos(3.880+ 5223.690*jme)+ 44.0*Cos(3.700+2352.870*jme)+  &
              32.0*Cos(4.000+ 1577.340*jme)
      B1   =   9.0*Cos(3.900+ 5507.550*jme)+  6.0*Cos(1.730+5223.690*jme)
      BB   = ((B0+B1*jme)/100000000.0)*RToD
! geocentric latitude, Beta, degrees
      Beta = -1.0*BB
! calculate the right ascension of the sun, degrees
      tananum = Cos(DToR*ep) * Sin(DToR*lambda)
!      tananum   = Cos(DToR*ep)*Sin(DToR*lambda)-tan(DToR*Beta)*Sin(DToR*ep)                   ! Eq 13.3 on page 93, difference with line above is negligible
      tanadenom = Cos(DToR*lambda)                                                             ! Eq 13.3 on page 93
! Javascript and FORTRAN use same format, Atan2(Y,X)
      alpha = RtoD*atan2(tananum, tanadenom)                                                   ! Eq 13.3 on page 93

! calculate the declination of the sun, degrees
      sint = Sin(DToR*ep) * Sin(DToR*lambda)
!      sint = Sin(DToR*ep)*Sin(DToR*lambda)*Cos(DToR*Beta)+Cos(DToR*ep)*Sin(DToR*Beta)         ! Eq 13.4 on page 93, difference with line above is negligible
      theta = RToD*Asin(sint)                                                                  ! Eq 13.4 on page 93

! calculate the equation of time, the difference between true solar time
! and mean solar time, in minutes of time
      y = (Tan(DToR*ep/2.0))**2
      sin2LO = Sin(2.0*DToR*LO)
      cos2LO = Cos(2.0*DToR*LO)
      sin4LO = Sin(4.0*DToR*LO)
      Etime = y*sin2LO - 2.0*e*sinM + 4.0*e*y*sinM*cos2LO - 0.5*y*y*sin4LO - 1.25*e*e*sin2M    ! Eq 28.3 on page 185
      EQT = RToD*Etime*4.0

! change sign convention for longitude from negative to positive in western hemisphere
      if(Long(i) < 0.0)then
       Long2(i) = Long(i)*-1.0
      else
       Long2(i) = Long(i)
      end if
      if(Lat(i) > 89.8)  Lat(i) = 89.8
      if(Lat(i) < -89.8) Lat(i) = -89.8

      solarTimeFix = EQT - 4.0*Long2(i) !+ 60.0*TZ(i)  ! in minutes
      trueSolarTime = HOUR*60.0 + solarTimeFix   !in minutes

      if(trueSolarTime > 1440)then
       trueSolarTime = trueSolarTime - 1440
      end if

      hourangle = trueSolarTime/4.0 - 180.0

!Thanks to Louis Schwarzmayr for the next line:
      if(hourangle < -180.0)hourangle = hourangle + 360.0

!Solar zenith (Solar altitude)
      harad = DToR*hourangle
      csz = Sin(DToR*Lat(i))*Sin(DToR*theta) + Cos(DToR*Lat(i))*Cos(DToR*theta)*Cos(harad)
      if(csz > 1.0) Then
       csz = 1.0
      else if(csz < -1.0) Then
       csz = -1.0
      end if
      zenith = RToD*Acos(csz)

!Solar azimuth
      azDenom = Cos(DToR*Lat(i))*Sin(DToR*zenith)
      if(Abs(azDenom) > 0.001)then
       azRad = ((Sin(DToR*Lat(i))*Cos(DToR*zenith)) - Sin(DToR*theta))/azDenom
       if(Abs(azRad) > 1.0)then
        if(azRad < 0.0)then
         azRad = -1.0
        else
         azRad = 1.0
        end if
       end if
       azimuth = 180.0 - RToD*Acos(azRad)
       if(hourangle > 0.0)then
        azimuth = azimuth*-1.0
       end if
      else
       if (Lat(i) > 0.0)then
        azimuth = 180.0
       else
        azimuth = 0.0
       end if
      end if

      if(azimuth < 0.0)then
       azimuth = azimuth + 360.0
      end if

! Correction for the effect of atmospheric refraction, NOAA website (SElev is Solar Altitude)
      SElev = 90.0 - zenith
      if(SElev > 85.0)then
       RC = 0.0
      else
       Te = Tan(DToR*SElev)
       if(SElev > 5.0 .and. SElev <= 85.0)   RC = (58.1/Te - 0.07/(Te**3) + 0.000086/(Te**5))/3600.0
       if(SElev > -0.575 .and. SElev <= 5.0) RC = (1735-518.2*SElev+103.4*SElev**2-12.79*SElev**3+0.711*SElev**4)/3600.0
       if(SElev < -0.575)                    RC = (-20.774/Te)/3600.0
      end if

       solarzen     = zenith - RC                    ! solar zenith, corrected, degrees
       solarazimuth = azimuth                        ! solar azimuth, degrees
       solaralt     = 90.0 - solarzen                ! solar altitude, degrees
       solarzen     = solarzen*DToR                  ! solar zenith, radians

       !Call Ozone(i,k,Jdaym)
          if(Lat(i) >= 0.0)then
      A = 150.0; C = 40.0; F = -30.000; H = 3.0; B = 1.28
      if(Long(i) >= 0.0)then
       P = 20.0
      else
       P =  0.0
      end if
    else
      A = 100.0; C = 30.0; F = 152.625; H = 2.0; B = 1.50; P = -75.0
    end if
! D converts the number of days to a fraction part of 360 degrees, in degrees
!    D  = 360.0/365.25, 0.98562628
! Uo is calculated in atm-cm
    Uo  = (235+(A+C*Sin(DToR*0.9856*(int(Jdaym)+F))+20.0*Sin(DToR*H*(Long(i)+P)))*(sin(DToR*B*Lat(i))**2))/1000.0
       !Call BirdModel(i,k,Jdaym)
       ! Atmospheric Pressure
     P         = 1013
! Ratio of forward-scattered irradiance to the total scattered, see SERI pages 8 & 9
!     Ba        = 0.84
! Constant used in Bird Model associated with aerosol absorptance, see SERI pages 7 & 9
!     K1        = 0.10
! Used same albdeo from other code for Methods 1 to 3
!     albedo    = 0.10
! NREL solar constant of 1367 W/m^2
!     SROCON    = 1367.00
! Bras/TVA (Io=Wo(sin(solaralt))/r2, Equation 2.9 on page 26) adjustment of ETR normal to beam for earth sun distance
     birdETR   = SROCON/r**2
! broadband aerosol optical depth from surface in a vertical path (broadband turbidity)
     tauA      = 0.2758*AOD380nm + 0.35*AOD500nm
!     tauA      = 0.05
    if(RToD*solarzen < 89.0)then
! Relative Optical Air Mass, SERI, pg 8
     AM      = (((288-0.0065*Elev(i))/288)**5.256)/(Sin(DToR*solaralt)+0.1500*(solaralt+3.885)**-1.253)                    ! Equation 23, optical air mass
! Pressure corrected air mass
     AMP       = AM*P/1013
! Total amount of ozone in a slanted path (cm)
     Xo        = Uo*AM
! Amount of Precipitable water in a vertical column  from surface (cm), used 1.50 cm for Mt Vernon, range from MLS and USS models 1.42 to 2.93
     Uw        = exp(-0.0592+0.06912*DP(i,k))                                                                                ! Equation 27, mean hourly precipitable water content, cm
! Total amount of precipitable water in a slanted path (cm)
     Xw        = Uw*AM
! Transmittance of Rayleigh Scattering, SERI, pg 8
     TR        = Exp(-0.0903*(AMP**0.84)*(1+AMP-AMP**1.01))
! Transmittance of ozone absorptance, SERI, pg 8
     Toh       = 1-0.1611*Xo*(1+139.48*Xo)**-0.3035-0.002715*Xo/(1+0.044*Xo+0.0003*Xo**2)
! Transmittance of absorptance of uniformly mixed gases (carbon dioxide and oxygen)
     TUM       = Exp(-0.0127*AMP**0.26)
! Transmittance of water vapor absoptance (1-aw)
     Tw        = 1-2.4959*Xw/((1 + 79.034*Xw)**0.6828+6.385*Xw)
! Transmittance of aerosol aborptance and scattering
     TA        = Exp(-(tauA**0.873)*(1+tauA-tauA**0.7088)*AM**0.9108)
! Transmittance of aerosol aborptance
     TAA       = 1-K1*(1-AM+AM**1.06)*(1-TA)
! Sky, or atmospheric, albedo
     rs        = 0.0685+(1-Ba)*(1-(TA/TAA))
! Direct solar irradiance on a horizontal ground surface (W/m^2)
     if(RToD*solarzen < 90.0)then
      directHz = birdETR*Cos(solarzen)*0.9662*TA*Tw*TUM*Toh*TR
     else
      directHz = 0.0
     end if
! Solar irradiance on a horizontal surface from atmospheric scattering (W/m2)
     numI      = 0.5*(1-TR)+ Ba * (1-(TA/TAA))
     denI      = 1-AM+AM**1.02
     Ias       = birdETR*Cos(solarzen)*0.79*Toh*TUM*Tw*TAA*(numI/DenI)
   else
     AM = 0.0; TR = 0.0; Toh = 0.0; TUM = 0.0; Tw = 0.0; TA = 0.0; TAA = 0.0; rs = 0.0; Id = 0.0; Ias = 0.0; AMP = 0.0
     Xw = 0.0; Xo = 0.0; mp = 0.0
   end if

!global radiation on a horizontal ground surface (W/m^2)
   if(AM > 0.0)then
    globalHz   = (directHz+Ias)/(1-albedo*rs)
   else
    globalHz   = 0.0
   end if

!diffuse radiation on a horizontal ground surface (W/m^2)
   diffuseHz = globalHz - directHz
       SRON4(i,k)   = globalHz
       TZ(i)= TZ(i)*-1.0

  ELSE
  LOCAL    =  LONGIT(JW)
  STANDARD =  15.0*INT(LONGIT(JW)/15.0)
  HOUR     = (JDAY-INT(JDAY))*24.0
  IDAY     =  JDAY-((INT(JDAY/365))*365)
  IDAY     =  IDAY+INT(INT(JDAY/365)/4)
  TAUD     = (2.*PI*(IDAY-1))/365.
  EQTNEW   =  0.170*SIN(4.*PI*(IDAY-80)/373.)-0.129*SIN(2.*PI*(IDAY-8)/355.)
  HH(JW)   =  0.261799*(HOUR-(LOCAL-STANDARD)*0.0666667+EQTNEW-12.0)
  DECL(JW) =  0.006918-0.399912*COS(TAUD)+0.070257*SIN(TAUD)-0.006758*COS(2.*TAUD)+0.000907*SIN(2.*TAUD)-0.002697*COS(3.*TAUD)        &
              +0.001480*SIN(3.*TAUD)
  SINAL    =  SIN(LAT(JW)*.0174533)*SIN(DECL(JW))+COS(LAT(JW)*.0174533)*COS(DECL(JW))*COS(HH(JW))
  A00(JW)  =  57.2957795*ASIN(SINAL)
  A0       =  A00(JW)
  IF (A0 > 0.0) THEN
    SRON(JW) = (1.0-0.0065*CLOUD(JW)**2)*24.0*(2.044*A0+0.1296*A0**2-1.941E-3*A0**3+7.591E-6*A0**4)*BTU_FT2_DAY_TO_W_M2
  ELSE
    SRON(JW) = 0.0
  END IF
  ENDIF
RETURN

!***********************************************************************************************************************************
!**                                          E Q U I L I B R I U M  T E M P E R A T U R E                                         **
!***********************************************************************************************************************************

ENTRY EQUILIBRIUM_TEMPERATURE

! British units

  TDEW_F   = DEG_F(TDEW(JW))
  TAIR_F   = DEG_F(TAIR(JW))
  SRO_BR   = SRON(JW)*W_M2_TO_BTU_FT2_DAY*SHADE(I)
  WIND_MPH = WIND(JW)*WSC(I)*MPS_TO_MPH
  WIND2M   = WIND_MPH*DLOG(2.0D0/Z0(JW))/DLOG(WINDH(JW)/Z0(JW))+NONZERO     ! SW 11/28/07  old version z0=0.003
  ACONV    = W_M2_TO_BTU_FT2_DAY
  IF (CFW(JW) == 1.0) BCONV = 3.401062
  IF (CFW(JW) == 2.0) BCONV = 1.520411

! Equilibrium temperature and heat exchange coefficient

  ET(I)   =  TDEW_F
  TSTAR   = (ET(I)+TDEW_F)*0.5
  BETA    =  0.255-(8.5E-3*TSTAR)+(2.04E-4*TSTAR*TSTAR)
  FW      =  ACONV*AFW(JW)+BCONV*BFW(JW)*WIND2M**CFW(JW)
  CSHE(I) =  15.7+(0.26+BETA)*FW
  RA      =  3.1872E-08*(TAIR_F+459.67)**4
  ETP     = (SRO_BR+RA-1801.0)/CSHE(I)+(CSHE(I)-15.7)*(0.26*TAIR_F+BETA*TDEW_F)/(CSHE(I)*(0.26+BETA))
  J       =  0
  DO WHILE (ABS(ETP-ET(I)) > 0.05 .AND. J < 10)
    ET(I)   =  ETP
    TSTAR   = (ET(I)+TDEW_F)*0.5
    BETA    =  0.255-(8.5E-3*TSTAR)+(2.04E-4*TSTAR*TSTAR)
    CSHE(I) =  15.7+(0.26+BETA)*FW
    ETP     = (SRO_BR+RA-1801.0)/CSHE(I)+(CSHE(I)-15.7)*(0.26*TAIR_F+BETA*TDEW_F)/(CSHE(I)*(0.26+BETA))
    J       =  J+1
  END DO

! SI units

  ET(I)   = DEG_C(ET(I))
  CSHE(I) = CSHE(I)*FLUX_BR_TO_FLUX_SI/RHOWCP
RETURN

!***********************************************************************************************************************************
!**                                                   S U R F A C E   T E R M S                                                   **
!***********************************************************************************************************************************

ENTRY SURFACE_TERMS (TSUR)

! Partial water vapor pressure of air (mm hg)

!  EA = EXP(2.3026*(9.5*TDEW(JW)/(TDEW(JW)+265.5)+0.6609))         ! SW 6/10/2011
!  IF (TDEW(JW) > 0.0) EA = EXP(2.3026*(7.5*TDEW(JW)/(TDEW(JW)+237.3)+0.6609))
  EA = DEXP(2.3026D0*(7.5D0*TDEW(JW)/(TDEW(JW)+237.3D0)+0.6609D0))

! Partial water vapor pressure at the water surface

  IF(TSUR<0.0)THEN
  ES = DEXP(2.3026D0*(9.5D0*TSUR/(TSUR+265.5D0)+0.6609D0))
  ELSE
  ES = DEXP(2.3026D0*(7.5D0*TSUR/(TSUR+237.3D0)+0.6609D0))
  ENDIF

! Wind function

  IF (RH_EVAP(JW)) THEN
    TAIRV = (TAIR(JW)+273.0D0)/(1.0D0-0.378D0*EA/760.0D0)
    DTV   = (TSUR+273.0D0)/(1.0D0-0.378D0*ES/760.0D0)-TAIRV
    DTVL  =  0.0084D0*WIND2(I)**3
    IF (DTV < DTVL) DTV = DTVL
    FW = (3.59D0*DTV**0.3333D0+4.26D0*WIND2(I))
  ELSE
    FW = AFW(JW)+BFW(JW)*WIND2(I)**CFW(JW)
  END IF

! Evaporative flux

  RE(I) = FW*(ES-EA)
  !IF(RE(I) < 0.0)RE(I)=0.0     ! SW 6/22/2016  SHOULD WE USE THIS AS AN ANALOG FOR CONDENSATION WHEN LESS THAN 0? TVA(1972) SUGGESTS YOU CAN - SEE SECTION 4 AND 5 but Ryan, Harleman suggest setting RE=0 if less than zero since the condensation coefficients are unknown...

! Conductive flux

  RC(I) = FW*BOWEN_CONSTANT*(TSUR-TAIR(JW))

! Back radiation flux

  RB(I) = 5.51D-8*(TSUR+273.15D0)**4
  RETURN
END SUBROUTINE HEAT_EXCHANGE

! Function declaration

   REAL(R8) FUNCTION DEG_F(X)
   USE PREC
   REAL(R8) :: X
   DEG_F =  X*1.8+32.0
   END FUNCTION DEG_F
   REAL(R8) FUNCTION DEG_C(X)
   USE PREC
   REAL(R8) :: X
   DEG_C = (X-32.0)*5.0/9.0
   END FUNCTION DEG_C


module micro_params

use grid, only: nzm

implicit none

!  Microphysics stuff:

! Densities of hydrometeors

real, parameter :: rhor = 1000. ! Density of water, kg/m3
real, parameter :: rhos = 100.  ! Density of snow, kg/m3
real, parameter :: rhog = 400.  ! Density of graupel, kg/m3
!real, parameter :: rhog = 917.  ! hail - Lin 1983

! Temperatures limits for various hydrometeors

real, parameter :: tbgmin = 253.16    ! Minimum temperature for cloud water., K
real, parameter :: tbgmax = 273.16    ! Maximum temperature for cloud ice, K
real, parameter :: tprmin = 268.16    ! Minimum temperature for rain, K
real, parameter :: tprmax = 283.16    ! Maximum temperature for snow+graupel, K
real, parameter :: tgrmin = 223.16    ! Minimum temperature for snow, K
real, parameter :: tgrmax = 283.16    ! Maximum temperature for graupel, K

! Terminal velocity coefficients

real, parameter :: a_rain = 842. ! Coeff.for rain term vel
real, parameter :: b_rain = 0.8  ! Fall speed exponent for rain
real, parameter :: a_snow = 4.84 ! Coeff.for snow term vel
real, parameter :: b_snow = 0.25 ! Fall speed exponent for snow
!real, parameter :: a_grau = 40.7! Krueger (1994) ! Coef. for graupel term vel
real, parameter :: a_grau = 94.5 ! Lin (1983) (rhog=400)
!real, parameter :: a_grau = 127.94! Lin (1983) (rhog=917)
real, parameter :: b_grau = 0.5  ! Fall speed exponent for graupel

! Autoconversion

real, parameter :: qcw0 = 1.e-3      ! Threshold for water autoconversion, g/g
real, parameter :: qci0 = 1.e-4     ! Threshold for ice autoconversion, g/g
real, parameter :: alphaelq = 1.e-3  ! autoconversion of cloud water rate coef
real, parameter :: betaelq = 1.e-3   ! autoconversion of cloud ice rate coef

! Accretion

real, parameter :: erccoef = 1.0   ! Rain/Cloud water collection efficiency
real, parameter :: esccoef = 1.0   ! Snow/Cloud water collection efficiency
real, parameter :: esicoef = 0.1   ! Snow/cloud ice collection efficiency
real, parameter :: egccoef = 1.0   ! Graupel/Cloud water collection efficiency
real, parameter :: egicoef = 0.1   ! Graupel/Cloud ice collection efficiency

! Interseption parameters for exponential size spectra

real, parameter :: nzeror = 8.e6   ! Intercept coeff. for rain
real, parameter :: nzeros = 3.e6   ! Intersept coeff. for snow
real, parameter :: nzerog = 4.e6   ! Intersept coeff. for graupel
!real, parameter :: nzerog = 4.e4   ! hail - Lin 1993

real, parameter :: qp_threshold = 1.e-12 ! minimal rain/snow water content

! Misc. microphysics variables

real*4 gam3       ! Gamma function of 3
real*4 gams1      ! Gamma function of (3 + b_snow)
real*4 gams2      ! Gamma function of (5 + b_snow)/2
real*4 gams3      ! Gamma function of (4 + b_snow)
real*4 gamg1      ! Gamma function of (3 + b_grau)
real*4 gamg2      ! Gamma function of (5 + b_grau)/2
real*4 gamg3      ! Gamma function of (4 + b_grau)
real*4 gamr1      ! Gamma function of (3 + b_rain)
real*4 gamr2      ! Gamma function of (5 + b_rain)/2
real*4 gamr3      ! Gamma function of (4 + b_rain)

real accrsc(nzm),accrsi(nzm),accrrc(nzm),coefice(nzm)
real accrgc(nzm),accrgi(nzm)
real evaps1(nzm),evaps2(nzm),evapr1(nzm),evapr2(nzm)
real evapg1(nzm),evapg2(nzm)

real a_bg, a_pr, a_gr

!bloss: These parameters are used in MICRO_M2005 cloud optics routines.
real, parameter :: rho_snow = rhos, rho_water = rhor, rho_cloud_ice = 917.

end module micro_params


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   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.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Test_Statistics_mod

    use Statistics_mod
    use Err_mod, only: Err_type
    use Test_mod, only: Test_type
    implicit none

    private
    public :: test_Statistics

    type(Test_type) :: Test

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

contains

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

    subroutine test_Statistics()
        implicit none
        Test = Test_type(moduleName=MODULE_NAME)
        call test_doSortedKS2()
        call Test%finalize()
    end subroutine test_Statistics

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

    subroutine test_doSortedKS2()

        use Constants_mod, only: RK, IK
        use Sort_mod, only: sortAscending

        implicit none
        integer, parameter      :: NDATA = 50_IK
        real(RK) :: StdNormRnd1(NDATA) =    [ 0.537667139546100_RK &
                                            , 1.83388501459509_RK &
                                            , -2.25884686100365_RK &
                                            , 0.862173320368121_RK &
                                            , 0.318765239858981_RK &
                                            , -1.30768829630527_RK &
                                            , -0.433592022305684_RK &
                                            , 0.342624466538650_RK &
                                            , 3.57839693972576_RK &
                                            , 2.76943702988488_RK &
                                            , -1.34988694015652_RK &
                                            , 3.03492346633185_RK &
                                            , 0.725404224946106_RK &
                                            , -0.0630548731896562_RK &
                                            , 0.714742903826096_RK &
                                            , -0.204966058299775_RK &
                                            , -0.124144348216312_RK &
                                            , 1.48969760778547_RK &
                                            , 1.40903448980048_RK &
                                            , 1.41719241342961_RK &
                                            , 0.671497133608081_RK &
                                            , -1.20748692268504_RK &
                                            , 0.717238651328839_RK &
                                            , 1.63023528916473_RK &
                                            , 0.488893770311789_RK &
                                            , 1.03469300991786_RK &
                                            , 0.726885133383238_RK &
                                            , -0.303440924786016_RK &
                                            , 0.293871467096658_RK &
                                            , -0.787282803758638_RK &
                                            , 0.888395631757642_RK &
                                            , -1.14707010696915_RK &
                                            , -1.06887045816803_RK &
                                            , -0.809498694424876_RK &
                                            , -2.94428416199490_RK &
                                            , 1.43838029281510_RK &
                                            , 0.325190539456198_RK &
                                            , -0.754928319169703_RK &
                                            , 1.37029854009523_RK &
                                            , -1.71151641885370_RK &
                                            , -0.102242446085491_RK &
                                            , -0.241447041607358_RK &
                                            , 0.319206739165502_RK &
                                            , 0.312858596637428_RK &
                                            , -0.864879917324457_RK &
                                            , -0.0300512961962686_RK &
                                            , -0.164879019209038_RK &
                                            , 0.627707287528727_RK &
                                            , 1.09326566903948_RK &
                                            , 1.10927329761440_RK &
                                            ]
        real(RK) :: StdNormRnd2(NDATA) =    [ -0.863652821988714_RK &
                                            , 0.0773590911304249_RK &
                                            , -1.21411704361541_RK &
                                            , -1.11350074148676_RK &
                                            , -0.00684932810334806_RK &
                                            , 1.53263030828475_RK &
                                            , -0.769665913753682_RK &
                                            , 0.371378812760058_RK &
                                            , -0.225584402271252_RK &
                                            , 1.11735613881447_RK &
                                            , -1.08906429505224_RK &
                                            , 0.0325574641649735_RK &
                                            , 0.552527021112224_RK &
                                            , 1.10061021788087_RK &
                                            , 1.54421189550395_RK &
                                            , 0.0859311331754255_RK &
                                            , -1.49159031063761_RK &
                                            , -0.742301837259857_RK &
                                            , -1.06158173331999_RK &
                                            , 2.35045722400204_RK &
                                            , -0.615601881466894_RK &
                                            , 0.748076783703985_RK &
                                            , -0.192418510588264_RK &
                                            , 0.888610425420721_RK &
                                            , -0.764849236567874_RK &
                                            , -1.40226896933876_RK &
                                            , -1.42237592509150_RK &
                                            , 0.488193909859941_RK &
                                            , -0.177375156618825_RK &
                                            , -0.196053487807333_RK &
                                            , 1.41931015064255_RK &
                                            , 0.291584373984183_RK &
                                            , 0.197811053464361_RK &
                                            , 1.58769908997406_RK &
                                            , -0.804465956349547_RK &
                                            , 0.696624415849607_RK &
                                            , 0.835088165072682_RK &
                                            , -0.243715140377952_RK &
                                            , 0.215670086403744_RK &
                                            , -1.16584393148205_RK &
                                            , -1.14795277889859_RK &
                                            , 0.104874716016494_RK &
                                            , 0.722254032225002_RK &
                                            , 2.58549125261624_RK &
                                            , -0.666890670701386_RK &
                                            , 0.187331024578940_RK &
                                            , -0.0824944253709554_RK &
                                            , -1.93302291785099_RK &
                                            , -0.438966153934773_RK &
                                            , -1.79467884145512_RK &
                                            ]
        real(RK), parameter     :: REFERENCE_PROB_KS = 0.056045859714425_RK
        real(RK), parameter     :: REFERENCE_STAT_KS = 0.260000000000000_RK
        real(RK)                :: difference, statKS, probKS
        type(Err_type)          :: Err

        if (Test%Image%isFirst) call Test%testing("doSortedKS2()")

        call sortAscending( np = NDATA, Point = StdNormRnd1, Err = Err )
        if (Err%occurred) then; Test%assertion = .false.; call Test%verify(); end if

        call sortAscending( np = NDATA, Point = StdNormRnd2, Err = Err )
        if (Err%occurred) then; Test%assertion = .false.; call Test%verify(); end if

        call doSortedKS2( np1 = NDATA &
                        , np2 = NDATA &
                        , SortedPoint1 = StdNormRnd1 &
                        , SortedPoint2 = StdNormRnd2 &
                        , statKS = statKS &
                        , probKS = probKS &
                        )

        difference = 2 * abs(REFERENCE_PROB_KS - probKS) / (REFERENCE_PROB_KS + probKS)
        if (Test%isDebugMode .and. Test%Image%isFirst) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "REFERENCE_PROB_KS, probKS, relative-difference:", REFERENCE_PROB_KS, probKS, difference
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        Test%assertion = difference < 1.e-7_RK
        call Test%verify()

        difference = 2 * abs(REFERENCE_STAT_KS - statKS) / (REFERENCE_STAT_KS + statKS)
        if (Test%isDebugMode .and. Test%Image%isFirst) then
            write(Test%outputUnit,"(*(g0,:,', '))")
            write(Test%outputUnit,"(*(g0,:,', '))") "REFERENCE_STAT_KS, statKS, relative-difference:", REFERENCE_STAT_KS, statKS, difference
            write(Test%outputUnit,"(*(g0,:,', '))")
        end if
        Test%assertion = difference < 1.e-7_RK
        call Test%verify()

        !call Test%skipping()

    end subroutine test_doSortedKS2

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

end module Test_Statistics_mod


module korc_units
  !! @note Module with subroutines that calculate the characteristic
  !! scales in the simulation used in the normalization and
  !! nondimensionalization of the simulation variables. @endnote
  use korc_types
  use korc_constants
  use korc_input

  IMPLICIT NONE

  PUBLIC :: compute_charcs_plasma_params,&
       normalize_variables

CONTAINS

subroutine compute_charcs_plasma_params(params,spp,F)
  !! @note Subroutine that calculates characteristic scales of
  !! the current KORC simulation. @endnote
  !! Normalization and non-dimensionalization of the variables and equations
  !! of motion allows us to solve them more accurately by reducing truncation
  !! erros when performing operations that combine small and large numbers.
  !!
  !! For normalizing and obtaining the non-dimensional form of the variables
  !! and equations solved in KORC we use characteristic scales calculated with
  !! the input data of each KORC simulation.
  !!

  !!
Characteristic scales in KORC

  !!
Characteristic scale		Symbol		        Value				Description

  !!
Velocity 	\(v_{ch}\)		\(c\)			 Speed of light
  !!
Time 		\(t_{ch}\)		\(\Omega^{-1} = m_{ch}/q_{ch}B_{ch}\) 	 Inverse of electron cyclotron frequency
  !!
Relativistic time \(t_{r,ch}\)	\(\Omega_r^{-1} = \gamma m_{ch}/q_{ch}B_{ch}\) 	 Inverse of relativistic electron cyclotron frequency
  !!
Length 	\(l_{ch}\)		\(v_{ch}t_{ch}\)		--
  !!
Mass 		\(m_{ch}\)		\(m_e\)			 Electron mass
  !!
Charge 	\(q_{ch}\)		\(e\)			 Absolute value of electron charge
  !!
Momentum       \(p_{ch}\)	        \(m_{ch}v_{ch}\) 	         --
  !!
Magnetic field \(B_{ch}\)		\(B_0\)		         Magnetic field at the magnetic axis
  !!
Electric field \(E_{ch}\)		\(v_{ch}B_{ch}\)		 --
  !!
Energy 	\(\mathcal{E}_{ch}\)\(m_{ch}v_{ch}^2\)		--
  !!
Temperature 	\(T_{ch}\)		\(m_{ch}v_{ch}^2\)		 Temperature given in Joules.
  !!
Density 	\(n_{ch}\)		\(l_{ch}^{-3}\)		--
  !!
Magnetic moment 	\(\mu_{ch}\)\(m_{ch}v_{ch}^2/B_{ch}\)	--
  !!
Pressure 	\(P_{ch}\)		--		                --
  !!

  !! With these characteristic scales we can write the dimensionless
  !! form of all the equations. For example, the Lorentz force for a
  !! charged particle \(q\), mass \(m\), and momentum
  !! \(\mathbf{p}=\gamma m \mathbf{v}\) can be written as:
  !!
  !! $$\frac{d \mathbf{p}'}{dt'} = q'\left[ \mathbf{E}' +
  !! \frac{\mathbf{p}'}{\gamma m'}\times \mathbf{B}' \right],$$
  !!
  !! where \(\mathbf{p}' = \mathbf{p}/p_{ch}\), \(t' = t/t_{ch}\),
  !! \(q' = q/q_{ch}\), \(m' = m/m_{ch}\), \(\mathbf{E}' = \mathbf{E}/E_{ch}\),
  !! and \(\mathbf{B}'=\mathbf{B}/B_{ch}\).
  !! @todo Characteristic pressure needs to be defined.
  TYPE(KORC_PARAMS), INTENT(INOUT) 				:: params
    !! Core KORC simulation parameters.
  TYPE(SPECIES), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)       :: spp
    !! An instance of KORC's derived type SPECIES containing all the
    !! information of different electron species. See [[korc_types]].
  TYPE(FIELDS), INTENT(IN) 					:: F
    !! An instance of KORC's derived type FIELDS containing all the
    !! information about the fields used in the simulation.
    !! See [[korc_types]] and [[korc_fields]].
  INTEGER 							:: ii
    !! Index of the spp array containing the mass, electric charge
    !! and corresponding cyclotron frequency used to derived some characteristic scales.

  params%cpp%velocity = C_C
  params%cpp%Bo = ABS(F%Bo)
  params%cpp%Eo = ABS(params%cpp%velocity*params%cpp%Bo)

  ! Non-relativistic cyclotron frequency
  spp(:)%wc = ( ABS(spp(:)%q)/spp(:)%m )*params%cpp%Bo

  ! Relativistic cyclotron frequency
  spp(:)%wc_r =  ABS(spp(:)%q)*params%cpp%Bo/( spp(:)%go*spp(:)%m )

  ii = MAXLOC(spp(:)%wc,1) ! Index to maximum cyclotron frequency
  params%cpp%time = 1.0_rp/spp(ii)%wc

  ii = MAXLOC(spp(:)%wc_r,1) ! Index to maximum relativistic cyclotron frequency
  params%cpp%time_r = 1.0_rp/spp(ii)%wc_r

  params%cpp%mass = C_ME
  params%cpp%charge = C_E
  params%cpp%length = params%cpp%velocity*params%cpp%time
  params%cpp%energy = params%cpp%mass*params%cpp%velocity**2

  params%cpp%density = 1.0_rp/params%cpp%length**3
  params%cpp%pressure = 0.0_rp
  params%cpp%temperature = params%cpp%energy
end subroutine compute_charcs_plasma_params

subroutine normalize_variables(params,spp,F,P)
  !! @note Subroutine that normalizes the simulation variables with
  !! the previously computed characteristic scales. @endnote
  TYPE(KORC_PARAMS), INTENT(INOUT) 				:: params
    !! Core KORC simulation parameters.
  TYPE(SPECIES), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)       :: spp
    !! An instance of KORC's derived type SPECIES containing all
    !! the information of different electron species. See [[korc_types]].
  TYPE(FIELDS), INTENT(INOUT) 					:: F
    !! @param[in,out] F An instance of KORC's derived type FIELDS
    !! containing all the information about the fields used in the simulation.
    !! See [[korc_types]] and [[korc_fields]].
  TYPE(PROFILES), INTENT(INOUT) 				:: P
    !! @param[in,out] P An instance of KORC's derived type PROFILES containing all the information about the plasma profiles used in
!! the simulation. See korc_types.f90 and korc_profiles.f90.
  INTEGER 							:: ii
    !! @param ii Interator of spp array.

  !	Normalize params variables
  params%dt = params%dt/params%cpp%time
  params%simulation_time = params%simulation_time/params%cpp%time
  params%snapshot_frequency = params%snapshot_frequency/params%cpp%time
  params%minimum_particle_energy = params%minimum_particle_energy/params%cpp%energy
  params%init_time=params%init_time/params%cpp%time

  !	Normalize particle variables
  do ii=1_idef,size(spp)
     spp(ii)%q = spp(ii)%q/params%cpp%charge
     spp(ii)%m = spp(ii)%m/params%cpp%mass
     spp(ii)%Eo = spp(ii)%Eo/params%cpp%energy
     spp(ii)%Eo_lims = spp(ii)%Eo_lims/params%cpp%energy
     spp(ii)%wc = spp(ii)%wc*params%cpp%time
     spp(ii)%wc_r = spp(ii)%wc_r*params%cpp%time
     spp(ii)%vars%X = spp(ii)%vars%X/params%cpp%length
     spp(ii)%vars%V = spp(ii)%vars%V/params%cpp%velocity
     spp(ii)%vars%Rgc = spp(ii)%vars%Rgc/params%cpp%length

     spp(ii)%Ro = spp(ii)%Ro/params%cpp%length
     spp(ii)%Zo = spp(ii)%Zo/params%cpp%length
     spp(ii)%r_inner = spp(ii)%r_inner/params%cpp%length
     spp(ii)%r_outter = spp(ii)%r_outter/params%cpp%length
     spp(ii)%sigmaR = spp(ii)%sigmaR/params%cpp%length
     spp(ii)%sigmaZ = spp(ii)%sigmaZ/params%cpp%length
     spp(ii)%falloff_rate = spp(ii)%falloff_rate*params%cpp%length
     spp(ii)%Xtrace = spp(ii)%Xtrace/params%cpp%length
     spp(ii)%Spong_b = spp(ii)%Spong_b/params%cpp%length
     spp(ii)%Spong_w = spp(ii)%Spong_w/params%cpp%length
     spp(ii)%dR = spp(ii)%dR/params%cpp%length
     spp(ii)%dZ = spp(ii)%dZ/params%cpp%length

  end do

  !	Normalize electromagnetic fields and profiles
  F%Bo = F%Bo/params%cpp%Bo
  F%Eo = F%Eo/params%cpp%Eo
  F%Ro = F%Ro/params%cpp%length
  F%Zo = F%Zo/params%cpp%length
  F%E_dyn = F%E_dyn/params%cpp%Eo
  F%E_pulse=F%E_pulse/params%cpp%time
  F%E_width=F%E_width/params%cpp%time
  F%t0_2x1t=F%t0_2x1t/params%cpp%time
  F%circumradius=F%circumradius/params%cpp%length

  P%a = P%a/params%cpp%length
  P%R0 = P%R0/params%cpp%length
  P%Z0 = P%Z0/params%cpp%length
  P%R0_RE = P%R0_RE/params%cpp%length
  P%Z0_RE = P%Z0_RE/params%cpp%length
  P%neo = P%neo/params%cpp%density
  P%n_ne = P%n_ne/params%cpp%density
  P%n_shelf = P%n_shelf/params%cpp%density
  P%Teo = P%Teo/params%cpp%temperature
  P%n_REr0=P%n_REr0/params%cpp%length
  P%n_tauion=P%n_tauion/params%cpp%time
  P%n_tauin=P%n_tauin/params%cpp%time
  P%n_tauout=P%n_tauout/params%cpp%time
  P%n_shelfdelay=P%n_shelfdelay/params%cpp%time
  P%n_lamfront=P%n_lamfront/params%cpp%length
  P%n_lamback=P%n_lamback/params%cpp%length
  P%n_lamshelf=P%n_lamshelf/params%cpp%length

  if (params%profile_model .EQ. 'ANALYTICAL') then

     if (params%field_eval.eq.'interp') then
        if (ALLOCATED(P%X%R)) P%X%R = P%X%R/params%cpp%length
        if (ALLOCATED(P%X%Z)) P%X%Z = P%X%Z/params%cpp%length

        if (ALLOCATED(P%ne_2D)) P%ne_2D = P%ne_2D/params%cpp%density
        if (ALLOCATED(P%Te_2D)) P%Te_2D = P%Te_2D/params%cpp%temperature
     end if

  else if (params%profile_model(1:8) .EQ. 'EXTERNAL') then

     if (ALLOCATED(P%X%R)) P%X%R = P%X%R/params%cpp%length
     if (ALLOCATED(P%X%Z)) P%X%Z = P%X%Z/params%cpp%length

     if (ALLOCATED(P%ne_2D)) P%ne_2D = P%ne_2D/params%cpp%density
     if (ALLOCATED(P%Te_2D)) P%Te_2D = P%Te_2D/params%cpp%temperature

     if (ALLOCATED(P%ne_3D)) P%ne_3D = P%ne_3D/params%cpp%density
     if (ALLOCATED(P%Te_3D)) P%Te_3D = P%Te_3D/params%cpp%temperature

     if (params%profile_model(10:10).eq.'H') then
        if (ALLOCATED(P%nRE_2D)) P%nRE_2D = P%nRE_2D/params%cpp%density
        if (ALLOCATED(P%nAr0_2D)) P%nAr0_2D = P%nAr0_2D/params%cpp%density
        if (ALLOCATED(P%nAr1_2D)) P%nAr1_2D = P%nAr1_2D/params%cpp%density
        if (ALLOCATED(P%nAr2_2D)) P%nAr2_2D = P%nAr2_2D/params%cpp%density
        if (ALLOCATED(P%nAr3_2D)) P%nAr3_2D = P%nAr3_2D/params%cpp%density
        if (ALLOCATED(P%nD_2D)) P%nD_2D = P%nD_2D/params%cpp%density
        if (ALLOCATED(P%nD1_2D)) P%nD1_2D = P%nD1_2D/params%cpp%density
     endif

  end if

  if (params%field_model(1:10) .EQ. 'ANALYTICAL') then
     F%AB%Bo = F%AB%Bo/params%cpp%Bo
     F%AB%a = F%AB%a/params%cpp%length
     F%AB%Ro = F%AB%Ro/params%cpp%length
     F%AB%lambda = F%AB%lambda/params%cpp%length
     F%AB%Bpo = F%AB%Bpo/params%cpp%Bo

     if (params%field_eval.eq.'interp') then
        if (ALLOCATED(F%B_2D%R)) F%B_2D%R = F%B_2D%R/params%cpp%Bo
        if (ALLOCATED(F%B_2D%PHI)) F%B_2D%PHI = F%B_2D%PHI/params%cpp%Bo
        if (ALLOCATED(F%B_2D%Z)) F%B_2D%Z = F%B_2D%Z/params%cpp%Bo

        if (ALLOCATED(F%E_2D%R)) F%E_2D%R = F%E_2D%R/params%cpp%Eo
        if (ALLOCATED(F%E_2D%PHI)) F%E_2D%PHI = F%E_2D%PHI/params%cpp%Eo
        if (ALLOCATED(F%E_2D%Z)) F%E_2D%Z = F%E_2D%Z/params%cpp%Eo

        if (ALLOCATED(F%B_3D%R)) F%B_3D%R = F%B_3D%R/params%cpp%Bo
        if (ALLOCATED(F%B_3D%PHI)) F%B_3D%PHI = F%B_3D%PHI/params%cpp%Bo
        if (ALLOCATED(F%B_3D%Z)) F%B_3D%Z = F%B_3D%Z/params%cpp%Bo

        if (ALLOCATED(F%E_3D%R)) F%E_3D%R = F%E_3D%R/params%cpp%Eo
        if (ALLOCATED(F%E_3D%PHI)) F%E_3D%PHI = F%E_3D%PHI/params%cpp%Eo
        if (ALLOCATED(F%E_3D%Z)) F%E_3D%Z = F%E_3D%Z/params%cpp%Eo

        if (ALLOCATED(F%PSIp)) F%PSIp = F%PSIp/ &
             (params%cpp%Bo*params%cpp%length**2)
        F%PSIP_min = F%PSIP_min/ &
             (params%cpp%Bo*params%cpp%length**2)
        if (.not.params%field_model.eq.'M3D_C1') then
           F%PSIp_lim = F%PSIp_lim/ &
                (params%cpp%Bo*params%cpp%length**2)
        end if

        F%X%R = F%X%R/params%cpp%length
        ! Nothing to do for the PHI component
        F%X%Z = F%X%Z/params%cpp%length

        if (params%orbit_model(3:5).eq.'pre') then
           if (ALLOCATED(F%gradB_2D%R)) F%gradB_2D%R = F%gradB_2D%R/ &
                (params%cpp%Bo/params%cpp%length)
           if (ALLOCATED(F%gradB_2D%PHI)) F%gradB_2D%PHI = F%gradB_2D%PHI/ &
                (params%cpp%Bo/params%cpp%length)
           if (ALLOCATED(F%gradB_2D%Z)) F%gradB_2D%Z = F%gradB_2D%Z/ &
                (params%cpp%Bo/params%cpp%length)

           if (ALLOCATED(F%curlb_2D%R)) F%curlb_2D%R = F%curlb_2D%R/ &
                (1./params%cpp%length)
           if (ALLOCATED(F%curlb_2D%PHI)) F%curlb_2D%PHI = F%curlb_2D%PHI/ &
                (1./params%cpp%length)
           if (ALLOCATED(F%curlb_2D%Z)) F%curlb_2D%Z = F%curlb_2D%Z/ &
                (1./params%cpp%length)

           if (ALLOCATED(F%gradB_3D%R)) F%gradB_3D%R = F%gradB_3D%R/ &
                (params%cpp%Bo/params%cpp%length)
           if (ALLOCATED(F%gradB_3D%PHI)) F%gradB_3D%PHI = F%gradB_3D%PHI/ &
                (params%cpp%Bo/params%cpp%length)
           if (ALLOCATED(F%gradB_3D%Z)) F%gradB_3D%Z = F%gradB_3D%Z/ &
                (params%cpp%Bo/params%cpp%length)

           if (ALLOCATED(F%curlb_3D%R)) F%curlb_3D%R = F%curlb_3D%R/ &
                (1./params%cpp%length)
           if (ALLOCATED(F%curlb_3D%PHI)) F%curlb_3D%PHI = F%curlb_3D%PHI/ &
                (1./params%cpp%length)
           if (ALLOCATED(F%curlb_3D%Z)) F%curlb_3D%Z = F%curlb_3D%Z/ &
                (1./params%cpp%length)
        end if

     end if

  else if (params%field_model(1:8) .EQ. 'EXTERNAL') then
     if (ALLOCATED(F%B_3D%R)) F%B_3D%R = F%B_3D%R/params%cpp%Bo
     if (ALLOCATED(F%B_3D%PHI)) F%B_3D%PHI = F%B_3D%PHI/params%cpp%Bo
     if (ALLOCATED(F%B_3D%Z)) F%B_3D%Z = F%B_3D%Z/params%cpp%Bo

     if (ALLOCATED(F%E_3D%R)) F%E_3D%R = F%E_3D%R/params%cpp%Eo
     if (ALLOCATED(F%E_3D%PHI)) F%E_3D%PHI = F%E_3D%PHI/params%cpp%Eo
     if (ALLOCATED(F%E_3D%Z)) F%E_3D%Z = F%E_3D%Z/params%cpp%Eo

     if (ALLOCATED(F%PSIp)) F%PSIp = F%PSIp/(params%cpp%Bo*params%cpp%length**2)
     if (ALLOCATED(F%PSIp3D)) F%PSIp3D = F%PSIp3D/ &
          (params%cpp%Bo*params%cpp%length**2)
     F%PSIP_min = F%PSIP_min/(params%cpp%Bo*params%cpp%length**2)
     F%PSIp_lim = F%PSIp_lim/(params%cpp%Bo*params%cpp%length**2)

     if (ALLOCATED(F%B_2D%R)) F%B_2D%R = F%B_2D%R/params%cpp%Bo
     if (ALLOCATED(F%B_2D%PHI)) F%B_2D%PHI = F%B_2D%PHI/params%cpp%Bo
     if (ALLOCATED(F%B_2D%Z)) F%B_2D%Z = F%B_2D%Z/params%cpp%Bo

     if (ALLOCATED(F%E_2D%R)) F%E_2D%R = F%E_2D%R/params%cpp%Eo
     if (ALLOCATED(F%E_2D%PHI)) F%E_2D%PHI = F%E_2D%PHI/params%cpp%Eo
     if (ALLOCATED(F%E_2D%Z)) F%E_2D%Z = F%E_2D%Z/params%cpp%Eo

     if (params%orbit_model(3:5).eq.'pre') then
        if (ALLOCATED(F%gradB_2D%R)) F%gradB_2D%R = F%gradB_2D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%gradB_2D%PHI)) F%gradB_2D%PHI = F%gradB_2D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%gradB_2D%Z)) F%gradB_2D%Z = F%gradB_2D%Z/ &
             (params%cpp%Bo/params%cpp%length)

        if (ALLOCATED(F%curlb_2D%R)) F%curlb_2D%R = F%curlb_2D%R/ &
             (1./params%cpp%length)
        if (ALLOCATED(F%curlb_2D%PHI)) F%curlb_2D%PHI = F%curlb_2D%PHI/ &
             (1./params%cpp%length)
        if (ALLOCATED(F%curlb_2D%Z)) F%curlb_2D%Z = F%curlb_2D%Z/ &
             (1./params%cpp%length)

        if (ALLOCATED(F%gradB_3D%R)) F%gradB_3D%R = F%gradB_3D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%gradB_3D%PHI)) F%gradB_3D%PHI = F%gradB_3D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%gradB_3D%Z)) F%gradB_3D%Z = F%gradB_3D%Z/ &
             (params%cpp%Bo/params%cpp%length)

        if (ALLOCATED(F%curlb_3D%R)) F%curlb_3D%R = F%curlb_3D%R/ &
             (1./params%cpp%length)
        if (ALLOCATED(F%curlb_3D%PHI)) F%curlb_3D%PHI = F%curlb_3D%PHI/ &
             (1./params%cpp%length)
        if (ALLOCATED(F%curlb_3D%Z)) F%curlb_3D%Z = F%curlb_3D%Z/ &
             (1./params%cpp%length)
     end if

     if (F%dBfield) then

        if (ALLOCATED(F%dBdR_2D%R)) F%dBdR_2D%R = F%dBdR_2D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdR_2D%PHI)) F%dBdR_2D%PHI = F%dBdR_2D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdR_2D%Z)) F%dBdR_2D%Z = F%dBdR_2D%Z/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdPHI_2D%R)) F%dBdPHI_2D%R = F%dBdPHI_2D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdPHI_2D%PHI)) F%dBdPHI_2D%PHI = F%dBdPHI_2D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdPHI_2D%Z)) F%dBdPHI_2D%Z = F%dBdPHI_2D%Z/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdZ_2D%R)) F%dBdZ_2D%R = F%dBdZ_2D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdZ_2D%PHI)) F%dBdZ_2D%PHI = F%dBdZ_2D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdZ_2D%Z)) F%dBdZ_2D%Z = F%dBdZ_2D%Z/ &
             (params%cpp%Bo/params%cpp%length)

        if (ALLOCATED(F%dBdR_3D%R)) F%dBdR_3D%R = F%dBdR_3D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdR_3D%PHI)) F%dBdR_3D%PHI = F%dBdR_3D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdR_3D%Z)) F%dBdR_3D%Z = F%dBdR_3D%Z/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdPHI_3D%R)) F%dBdPHI_3D%R = F%dBdPHI_3D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdPHI_3D%PHI)) F%dBdPHI_3D%PHI = F%dBdPHI_3D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdPHI_3D%Z)) F%dBdPHI_3D%Z = F%dBdPHI_3D%Z/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdZ_3D%R)) F%dBdZ_3D%R = F%dBdZ_3D%R/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdZ_3D%PHI)) F%dBdZ_3D%PHI = F%dBdZ_3D%PHI/ &
             (params%cpp%Bo/params%cpp%length)
        if (ALLOCATED(F%dBdZ_3D%Z)) F%dBdZ_3D%Z = F%dBdZ_3D%Z/ &
             (params%cpp%Bo/params%cpp%length)

     end if

     if (F%B1field) then

        if (params%field_model(10:13).eq.'MARS') then

           if (ALLOCATED(F%B1Re_2D%R)) F%B1Re_2D%R = F%B1Re_2D%R/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Re_2D%PHI)) F%B1Re_2D%PHI = F%B1Re_2D%PHI/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Re_2D%Z)) F%B1Re_2D%Z = F%B1Re_2D%Z/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Im_2D%R)) F%B1Im_2D%R = F%B1Im_2D%R/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Im_2D%PHI)) F%B1Im_2D%PHI = F%B1Im_2D%PHI/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Im_2D%Z)) F%B1Im_2D%Z = F%B1Im_2D%Z/ &
                params%cpp%Bo

        else if (params%field_model(10:14).eq.'AORSA') then

           if (ALLOCATED(F%B1Re_2DX%X)) F%B1Re_2DX%X = F%B1Re_2DX%X/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Re_2DX%Y)) F%B1Re_2DX%Y = F%B1Re_2DX%Y/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Re_2DX%Z)) F%B1Re_2DX%Z = F%B1Re_2DX%Z/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Im_2DX%X)) F%B1Im_2DX%X = F%B1Im_2DX%X/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Im_2DX%Y)) F%B1Im_2DX%Y = F%B1Im_2DX%Y/ &
                params%cpp%Bo
           if (ALLOCATED(F%B1Im_2DX%Z)) F%B1Im_2DX%Z = F%B1Im_2DX%Z/ &
                params%cpp%Bo

        endif
     end if

     if (F%E1field) then

        if (ALLOCATED(F%E1Re_2DX%X)) F%E1Re_2DX%X = F%E1Re_2DX%X/ &
             params%cpp%Eo
        if (ALLOCATED(F%E1Re_2DX%Y)) F%E1Re_2DX%Y = F%E1Re_2DX%Y/ &
             params%cpp%Eo
        if (ALLOCATED(F%E1Re_2DX%Z)) F%E1Re_2DX%Z = F%E1Re_2DX%Z/ &
             params%cpp%Eo
        if (ALLOCATED(F%E1Im_2DX%X)) F%E1Im_2DX%X = F%E1Im_2DX%X/ &
             params%cpp%Eo
        if (ALLOCATED(F%E1Im_2DX%Y)) F%E1Im_2DX%Y = F%E1Im_2DX%Y/ &
             params%cpp%Eo
        if (ALLOCATED(F%E1Im_2DX%Z)) F%E1Im_2DX%Z = F%E1Im_2DX%Z/ &
             params%cpp%Eo

     end if

     F%X%R = F%X%R/params%cpp%length
     ! Nothing to do for the PHI component
     F%X%Z = F%X%Z/params%cpp%length

     if (F%Dim2x1t) then
        F%X%PHI=F%X%PHI/params%cpp%time
     end if

!     end if
  end if
end subroutine normalize_variables

end module korc_units


! { dg-do compile }
! { dg-options "-O1 -fdump-tree-optimized" }
!
! PR middle-end/57073
! See also PR 57073
!
real function f(k)
  integer, value :: k
  f = (-1.0)**k
end

! { dg-final { scan-tree-dump-not "__builtin_powif"  "optimized" } }
! { dg-final { scan-tree-dump "powi_cond_\[0-9\] = k_\[0-9\]\\(D\\) & 1;"  "optimized" } }
! { dg-final { scan-tree-dump "powi_\[0-9\] = powi_cond_\[0-9\] \\? -1.0e\\+0 : 1.0e\\+0;"  "optimized" } }


! chk_round_io --
!     Check: does the compiler support the ROUND/SIGN specifiers?
!
program chk_round_io
    implicit none

    real    :: value

    write( *, '(a)' )    'Writing the number 1.5 with ROUND and SIGN specifiers'

    value = 1.5

    write( *, '(a,f10.4)', sign  = 'plus' ) '    Value (+ expected):   ', value
    write( *, '(a,f10.0)', round = 'up' )   '    Value (rounded up):   ', value
    write( *, '(a,f10.0)', round = 'down' ) '    Value (rounded down): ', value
    write( *, '(a,f10.0)' )                 '    Value (no rounding):  ', value

    value = -1.5
    write( *, '(a)' )    'Writing the number -1.5 with ROUND specifiers'
    write( *, '(a,f10.0)', round = 'up' )   '    Value (rounded up):   ', value
    write( *, '(a,f10.0)', round = 'up' )   '    Value (rounded down): ', value
    write( *, '(a,f10.0)' )                 '    Value (no rounding):  ', value

end program chk_round_io


! { dg-do compile }
! { dg-options "-fcoarray=single" }
! PR 53824 - this used to ICE.
! Original test case by Vladimír Fuka
program Jac
 implicit none

 integer,parameter:: KND=KIND(1.0)

 type Domain
  real(KND),dimension(:,:,:),allocatable:: A,B
  integer :: n=64,niter=20000,blockit=1000
  integer :: starti,endi
  integer :: startj,endj
  integer :: startk,endk
  integer,dimension(:),allocatable :: startsi,startsj,startsk
  integer,dimension(:),allocatable :: endsi,endsj,endsk
 end type

 type(Domain),allocatable :: D[:,:,:]
! real(KND),codimension[*] :: sumA,sumB,diffAB
 integer i,j,k,ncom
 integer nims,nxims,nyims,nzims
 integer im,iim,jim,kim
 character(20):: ch

 nims = num_images()
 nxims = nint(nims**(1./3.))
 nyims = nint(nims**(1./3.))
 nzims = nims / (nxims*nyims)

 im = this_image()
 if (im==1) write(*,*) "n: [",nxims,nyims,nzims,"]"

 kim = (im-1) / (nxims*nyims) + 1
 jim = ((im-1) - (kim-1)*(nxims*nyims)) / nxims + 1
 iim = (im-1) - (kim-1)*(nxims*nyims) - (jim-1)*(nxims) + 1

 write (*,*) im,"[",iim,jim,kim,"]"

 allocate(D[nxims,nyims,*])

 ncom=command_argument_count()
 if (command_argument_count() >=2) then
  call get_command_argument(1,value=ch)
  read (ch,*) D%n
  call get_command_argument(2,value=ch)
  read (ch,*) D%niter
  call get_command_argument(3,value=ch)
  read (ch,*) D%blockit
 end if

 allocate(D%startsi(nxims))
 allocate(D%startsj(nyims))
 allocate(D%startsk(nzims))
 allocate(D%endsi(nxims))
 allocate(D%endsj(nyims))
 allocate(D%endsk(nzims))

 D%startsi(1) = 1
 do i=2,nxims
   D%startsi(i) = D%startsi(i-1) + D%n/nxims
 end do
 D%endsi(nxims) = D%n
 D%endsi(1:nxims-1) = D%startsi(2:nxims) - 1

 D%startsj(1) = 1
 do j=2,nyims
   D%startsj(j) = D%startsj(j-1) + D%n/nyims
 end do
 D%endsj(nyims) = D%n
 D%endsj(1:nyims-1) = D%startsj(2:nyims) - 1

 D%startsk(1) = 1
 do k=2,nzims
   D%startsk(k) = D%startsk(k-1) + D%n/nzims
 end do
 D%endsk(nzims) = D%n
 D%endsk(1:nzims-1) = D%startsk(2:nzims) - 1

 D%starti = D%startsi(iim)
 D%endi = D%endsi(iim)
 D%startj = D%startsj(jim)
 D%endj = D%endsj(jim)
 D%startk = D%startsk(kim)
 D%endk = D%endsk(kim)

 write(*,*) D%startsi,D%endsi
 write(*,*) D%startsj,D%endsj
 write(*,*) D%startsk,D%endsk

 !$hmpp JacKernel allocate, args[A,B].size={0:D%n+1,0:D%n+1,0:D%n+1}
 allocate(D%A(D%starti-1:D%endi+1,D%startj-1:D%endj+1,D%startk-1:D%endk+1),&
  D%B(D%starti-1:D%endi+1,D%startj-1:D%endj+1,D%startk-1:D%endk+1))
end program Jac


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! 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.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
!
!////////////////////////////////////////////////////////////////////////
!
!      CurveInterpolantClass.f
!      Created: 2007-06-12 15:37:20 -0400
!      By: David Kopriva
!
!      Contains:
!         ALGORITHM 96: CurveInterpolant (Class)
!         ALGORITHM 97: CurveInterpolantProcedures
!            SUBROUTINE ConstructCurveInterpolant( this, N, nodes, values)
!            SUBROUTINE EvaluateAt( this, atLocation, givingResult )
!            SUBROUTINE DerivativeAt( this, atLocation, givingResult )
!
!      this version is modified so that the curves are defined in 3-space, (x,y,z). 6/5/15, 3:46 PM
!
!////////////////////////////////////////////////////////////////////////
!
      MODULE CurveInterpolantClass
      USE PolynomialInterpolationModule
      IMPLICIT NONE
!
!---------------------------------------------------------------------
! This module defines a class that creates a curve from an interpolant
!---------------------------------------------------------------------
!
      TYPE CurveInterpolant
         INTEGER                    :: numberOfNodes
         REAL(KIND=RP), ALLOCATABLE :: nodes(:)
         REAL(KIND=RP), ALLOCATABLE :: values(:,:)
         REAL(KIND=RP), ALLOCATABLE :: bWeights(:)
      END TYPE CurveInterpolant
!
!     --------
!     Generics
!     --------
!
      INTERFACE Construct
         MODULE PROCEDURE ConstructCurveInterpolant
      END INTERFACE Construct
      INTERFACE Destruct
         MODULE PROCEDURE DestructCurveInterpolant
      END INTERFACE Destruct
!
!     ========
      CONTAINS
!     ========
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE ConstructCurveInterpolant( this, N, nodes, values)
!
!-------------------------------------------------------------------
! Constructor pfor a curve interpolant
!-------------------------------------------------------------------
!
         TYPE(CurveInterpolant)         , INTENT(OUT) :: this
         INTEGER                        , INTENT(IN)  :: N
         REAL(KIND=RP), DIMENSION(0:N)  , INTENT(IN)  :: nodes
         REAL(KIND=RP), DIMENSION(0:N,3), INTENT(IN)  :: values

         ALLOCATE( this%nodes(0:N) )
         ALLOCATE( this%values(0:N,3) )
         ALLOCATE( this%bWeights(0:N) )

         this%numberOfNodes = N
         this%nodes         = nodes
         this%values        = values
         CALL BarycentricWeights( N, nodes, this%bWeights )

      END SUBROUTINE ConstructCurveInterpolant
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE SetValues( this, values )
!
!-------------------------------------------------------------------
! Constructor pfor a curve interpolant
!-------------------------------------------------------------------
!
         TYPE(CurveInterpolant)        , INTENT(INOUT) :: this
         REAL(KIND=RP), DIMENSION(0:,:), INTENT(IN)  :: values

         this%values        = values

      END SUBROUTINE SetValues
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE DestructCurveInterpolant( this )
         TYPE(CurveInterpolant)       :: this
         IF(ALLOCATED(this%nodes))     DEALLOCATE( this%nodes )
         IF(ALLOCATED(this%values))    DEALLOCATE( this%values )
         IF(ALLOCATED(this%bWeights))  DEALLOCATE( this%bWeights )
      END SUBROUTINE DestructCurveInterpolant
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE EvaluateAt( this, atLocation, givingResult )
!
!     -------------------------------------------------------------------
!     Evaluate the interpolant of this at s returning v
!     -------------------------------------------------------------------
!
         TYPE(CurveInterpolant), INTENT(IN)  :: this
         REAL(KIND=RP)         , INTENT(IN)  :: atLocation
         REAL(KIND=RP)         , INTENT(OUT) :: givingResult(3)

         givingResult(1) = LagrangeInterpolation( atLocation, this%numberOfNodes, &
                           this%nodes, this%values(:,1), this%bWeights)
         givingResult(2) = LagrangeInterpolation( atLocation, this%numberOfNodes, &
                           this%nodes, this%values(:,2), this%bWeights)
         givingResult(3) = LagrangeInterpolation( atLocation, this%numberOfNodes, &
                           this%nodes, this%values(:,3), this%bWeights)

      END SUBROUTINE EvaluateAt
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE DerivativeAt( this, atLocation, givingResult )
!
!     -------------------------------------------------------------------
!     Evaluate the derivative of the interpolant of this at atLocation
!     returning givingResult.
!     -------------------------------------------------------------------
!
         TYPE(CurveInterpolant), INTENT(IN)  :: this
         REAL(KIND=RP)         , INTENT(IN)  :: atLocation
         REAL(KIND=RP)         , INTENT(OUT) :: givingResult(3)

         givingResult(1) = LagrangeInterpolantDerivative( atLocation, this%numberOfNodes, &
                           this%nodes, this%values(:,1), this%bWeights)
         givingResult(2) = LagrangeInterpolantDerivative( atLocation, this%numberOfNodes, &
                           this%nodes, this%values(:,2), this%bWeights)
         givingResult(3) = LagrangeInterpolantDerivative( atLocation, this%numberOfNodes, &
                           this%nodes, this%values(:,3), this%bWeights)

      END SUBROUTINE DerivativeAt

      END MODULE CurveInterpolantClass


      DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF,
     $                                        LDAF, WORK )
*
*     -- LAPACK routine (version 3.2.1)                                 --
*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
*     -- Jason Riedy of Univ. of California Berkeley.                 --
*     -- April 2009                                                   --
*
*     -- LAPACK is a software package provided by Univ. of Tennessee, --
*     -- Univ. of California Berkeley and NAG Ltd.                    --
*
      IMPLICIT NONE
*     ..
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            NCOLS, LDA, LDAF
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLA_PORPVGRW computes the reciprocal pivot growth factor
*  norm(A)/norm(U). The "max absolute element" norm is used. If this is
*  much less than 1, the stability of the LU factorization of the
*  (equilibrated) matrix A could be poor. This also means that the
*  solution X, estimated condition numbers, and error bounds could be
*  unreliable.
*
*  Arguments
*  =========
*
*     UPLO    (input) CHARACTER*1
*       = 'U':  Upper triangle of A is stored;
*       = 'L':  Lower triangle of A is stored.
*
*     NCOLS   (input) INTEGER
*     The number of columns of the matrix A. NCOLS >= 0.
*
*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*     On entry, the N-by-N matrix A.
*
*     LDA     (input) INTEGER
*     The leading dimension of the array A.  LDA >= max(1,N).
*
*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
*     The triangular factor U or L from the Cholesky factorization
*     A = U**T*U or A = L*L**T, as computed by DPOTRF.
*
*     LDAF    (input) INTEGER
*     The leading dimension of the array AF.  LDAF >= max(1,N).
*
*     WORK    (input) DOUBLE PRECISION array, dimension (2*N)
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   AMAX, UMAX, RPVGRW
      LOGICAL            UPPER
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. External Functions ..
      EXTERNAL           LSAME, DLASET
      LOGICAL            LSAME
*     ..
*     .. Executable Statements ..
*
      UPPER = LSAME( 'Upper', UPLO )
*
*     DPOTRF will have factored only the NCOLSxNCOLS leading minor, so
*     we restrict the growth search to that minor and use only the first
*     2*NCOLS workspace entries.
*
      RPVGRW = 1.0D+0
      DO I = 1, 2*NCOLS
         WORK( I ) = 0.0D+0
      END DO
*
*     Find the max magnitude entry of each column.
*
      IF ( UPPER ) THEN
         DO J = 1, NCOLS
            DO I = 1, J
               WORK( NCOLS+J ) =
     $              MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) )
            END DO
         END DO
      ELSE
         DO J = 1, NCOLS
            DO I = J, NCOLS
               WORK( NCOLS+J ) =
     $              MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) )
            END DO
         END DO
      END IF
*
*     Now find the max magnitude entry of each column of the factor in
*     AF.  No pivoting, so no permutations.
*
      IF ( LSAME( 'Upper', UPLO ) ) THEN
         DO J = 1, NCOLS
            DO I = 1, J
               WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) )
            END DO
         END DO
      ELSE
         DO J = 1, NCOLS
            DO I = J, NCOLS
               WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) )
            END DO
         END DO
      END IF
*
*     Compute the *inverse* of the max element growth factor.  Dividing
*     by zero would imply the largest entry of the factor's column is
*     zero.  Than can happen when either the column of A is zero or
*     massive pivots made the factor underflow to zero.  Neither counts
*     as growth in itself, so simply ignore terms with zero
*     denominators.
*
      IF ( LSAME( 'Upper', UPLO ) ) THEN
         DO I = 1, NCOLS
            UMAX = WORK( I )
            AMAX = WORK( NCOLS+I )
            IF ( UMAX /= 0.0D+0 ) THEN
               RPVGRW = MIN( AMAX / UMAX, RPVGRW )
            END IF
         END DO
      ELSE
         DO I = 1, NCOLS
            UMAX = WORK( I )
            AMAX = WORK( NCOLS+I )
            IF ( UMAX /= 0.0D+0 ) THEN
               RPVGRW = MIN( AMAX / UMAX, RPVGRW )
            END IF
         END DO
      END IF

      DLA_PORPVGRW = RPVGRW
      END FUNCTION


!> Version: experimental
!>
!> The specification of this module is available [here](../page/specs/stdlib_kinds.html).
module stdlib_kinds
  use iso_fortran_env, only: int8, int16, int32, int64
  use iso_c_binding, only: c_bool
  implicit none
  private
  public :: sp, dp, xdp, qp, int8, int16, int32, int64, lk, c_bool

  !> Single precision real numbers
  integer, parameter :: sp = selected_real_kind(6)

  !> Double precision real numbers
  integer, parameter :: dp = selected_real_kind(15)

  !> Extended double precision real numbers
  integer, parameter :: xdp = -1

  !> Quadruple precision real numbers
  integer, parameter :: qp = -1

  !> Default logical kind parameter
  integer, parameter :: lk = kind(.true.)

end module stdlib_kinds


! Copyright (c) 2015 Alex Kramer <alkramer@phys.ksu.edu>
! See the LICENSE.txt file in the top-level directory of this distribution

! Global variables
! Note: This is a program-independent module
module globvars
  implicit none

  ! Double precision type / formatting
  integer, parameter :: dp = kind(0.d0)
  real(dp), parameter :: eps_dp = epsilon(1.0_dp)
  character(*), parameter :: dp_format = "(es25.16e3)"
  character(*), parameter :: dp_format_raw = "es25.16e3"

  ! Numerical constants
  real(dp), parameter :: pi = 4.0_dp * atan(1.0_dp)
  real(dp), parameter :: sqrt_pi = sqrt(pi)
  real(dp), parameter :: tau = 2.0_dp * pi
  real(dp), parameter :: e = exp(1.0_dp)
  complex(dp), parameter :: j = (0.0_dp, 1.0_dp)

end module globvars


      integer(8) function i8elsum(ivec,nelmnt)
*
* Sum of elements of integer vector IVEC
* Explicit integer(8) version
*
      implicit none

      integer(8), intent(in) ::
     &   nelmnt, ivec(nelmnt)

      integer(8) ::
     &   isum, ielmnt
*
      isum = 0
      do ielmnt = 1, nelmnt
        isum = isum + ivec(ielmnt)
      end do
*
      i8elsum = isum
*
      return
      end


program real32_vs_real64
    use, intrinsic :: iso_fortran_env, only : error_unit, I8 => INT64, &
        SP => REAL32, DP => REAL64
    implicit none
    integer(kind=I8) :: nr_values
    real(kind=SP), dimension(:), allocatable :: x_sp, y_sp
    real(kind=SP), parameter :: alpha_sp = 0.5_SP
    real(kind=DP), dimension(:), allocatable :: x_dp, y_dp
    real(kind=DP), parameter :: alpha_dp = 0.5_DP
    real :: start_time, end_time
    integer :: status

    call get_argument(nr_values)

    ! double precison
    allocate (x_dp(nr_values), y_dp(nr_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate x_dp/y_dp'
        stop 1
    end if
    call random_number(x_dp)
    call random_number(y_dp)

    call cpu_time(start_time)
    x_dp = alpha_dp*x_dp + y_dp
    call cpu_time(end_time)
    print '(A, F12.6)', 'double precision: ', end_time - start_time
    print '(A, F25.15)', '    result: ', sum(x_dp)
    deallocate (x_dp, y_dp)

    ! mixed precision
    allocate (x_sp(nr_values), y_dp(nr_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate x_sp/y_dp'
        stop 1
    end if
    call random_number(x_sp)
    call random_number(y_dp)

    call cpu_time(start_time)
    x_sp = alpha_dp*x_sp + y_dp
    call cpu_time(end_time)
    print '(A, F12.6)', 'mixed precision: ', end_time - start_time
    print '(A, F15.6)', '    result: ', sum(x_sp)
    deallocate (x_sp, y_dp)

    ! mixed precision with conversion
    allocate (x_sp(nr_values), y_dp(nr_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate x_sp/y_dp'
        stop 1
    end if
    call random_number(x_sp)
    call random_number(y_dp)

    call cpu_time(start_time)
    x_sp = alpha_sp*x_sp + real(y_dp, kind=kind(x_sp))
    call cpu_time(end_time)
    print '(A, F12.6)', 'mixed precision with conversion: ', end_time - start_time
    print '(A, F15.6)', '    result: ', sum(x_sp)
    deallocate (x_sp, y_dp)

    ! single precision, double constant
    allocate (x_sp(nr_values), y_sp(nr_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate x_sp/y_sp'
        stop 1
    end if
    call random_number(x_sp)
    call random_number(y_sp)

    call cpu_time(start_time)
    x_sp = alpha_dp*x_sp + y_sp
    call cpu_time(end_time)
    print '(A, F12.6)', 'single precision, double constant: ', end_time - start_time
    print '(A, F15.6)', '    result: ', sum(x_sp)
    deallocate (x_sp, y_sp)

    ! single precision
    allocate (x_sp(nr_values), y_sp(nr_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate x_sp/y_sp'
        stop 1
    end if
    call random_number(x_sp)
    call random_number(y_sp)

    call cpu_time(start_time)
    x_sp = alpha_sp*x_sp + y_sp
    call cpu_time(end_time)
    print '(A, F12.6)', 'single precision: ', end_time - start_time
    print '(A, F15.6)', '    result: ', sum(x_sp)
    deallocate (x_sp, y_sp)

contains

    subroutine get_argument(nr_values)
        implicit none
        integer(Kind=I8), intent(out) :: nr_values
        character(len=1024) :: buffer, msg
        integer :: status

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') 'error: expect number of values'
            stop 2
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iomsg=msg, iostat=status) nr_values
        if (status /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
            stop 3
        end if
    end subroutine get_argument

end program real32_vs_real64


*> \brief \b SCASUM
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SCASUM(N,CX,INCX)
*
*       .. Scalar Arguments ..
*       INTEGER INCX,N
*       ..
*       .. Array Arguments ..
*       COMPLEX CX(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    SCASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and
*>    returns a single precision result.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2015
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>     jack dongarra, linpack, 3/11/78.
*>     modified 3/93 to return if incx .le. 0.
*>     modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
*  =====================================================================
      REAL FUNCTION SCASUM(N,CX,INCX)
*
*  -- Reference BLAS level1 routine (version 3.6.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      COMPLEX CX(*)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL STEMP
      INTEGER I,NINCX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS,AIMAG,REAL
*     ..
      SCASUM = 0.0e0
      STEMP = 0.0e0
      IF (N.LE.0 .OR. INCX.LE.0) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         DO I = 1,N
            STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         NINCX = N*INCX
         DO I = 1,NINCX,INCX
            STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
         END DO
      END IF
      SCASUM = STEMP
      RETURN
      END


MODULE Variaveis_Solvers_P

   USE ClassMatrizA

   IMPLICIT NONE

   !----------------------GERAL------------------------------------------------------
   INTEGER :: Nx, Ny, Tn
   DOUBLE PRECISION :: tol
   DOUBLE PRECISION :: norma_L2
   DOUBLE PRECISION :: Lx, Ly
   DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: normas_L2
   DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: u, f
   DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE :: bp
   INTEGER :: verbose
   !----------------------GERAL------------------------------------------------------

   !----------------------MULTIGRID GAUSS-SEIDEL-------------------------------------
   INTEGER :: ite_down, ite_up
   INTEGER :: max_ciclos_V
   INTEGER :: Levels
   INTEGER, DIMENSION(:, :), ALLOCATABLE :: lv_if
   INTEGER, DIMENSION(:),   ALLOCATABLE :: lv_nx, lv_ny
   !----------------------MULTIGRID GAUSS-SEIDEL-------------------------------------

   TYPE ( MatrizA ), DIMENSION(:), ALLOCATABLE :: A

END MODULE Variaveis_Solvers_P


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  function rmsfit  --  rms deviation for paired atoms  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "rmsfit" computes the rms fit of two coordinate sets
c
c
      function rmsfit (x1,y1,z1,x2,y2,z2)
      implicit none
      include 'sizes.i'
      include 'align.i'
      integer i,i1,i2
      real*8 rmsfit,rmsterm
      real*8 xr,yr,zr,dist2
      real*8 weigh,norm
      real*8 x1(*),x2(*)
      real*8 y1(*),y2(*)
      real*8 z1(*),z2(*)
c
c
c     compute the rms fit over superimposed atom pairs
c
      rmsfit = 0.0d0
      norm = 0.0d0
      do i = 1, nfit
         i1 = ifit(1,i)
         i2 = ifit(2,i)
         weigh = wfit(i)
         xr = x1(i1) - x2(i2)
         yr = y1(i1) - y2(i2)
         zr = z1(i1) - z2(i2)
         dist2 = xr**2 + yr**2 + zr**2
         norm = norm + weigh
         rmsterm = dist2 * weigh
         rmsfit = rmsfit + rmsterm
      end do
      rmsfit = sqrt(rmsfit/norm)
      return
      end


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!  Tightly-packed RQZ iteration for complex Hessenberg pairs with
!  aggressive early deflation
! ___________________________________________________________________
module z_RQZtp
  use u_parameters
  use u_activeparts
  use z_memorymgmt
  use z_setpoles
  use z_swappoles
  use z_computepoles
  use z_deflations
  use z_aed
  use z_RQZ

  implicit none
  private
  public z_RQZm

contains
  subroutine z_RQZm(A,B, compAB, strtidx, stpidx, Q, compQ, qcol, &
                     Z, compZ, zcol, alpha, beta)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Implements the tightly-packed shift complex-valued RQZ method
  ! with aggressive early deflation
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       complex double array [INOUT]
  !           Matrix in upper Hessenberg form on entrance.
  !           On exit, the part defined by strtidx and stpidx is
  !           in upper triangular form and is equivalent with A
  !           if compAB is true.
  !
  ! B       complex double array [INOUT]
  !           Matrix in upper Hessenberg form on entrance.
  !           On exit, the part defined by strtidx and stpidx is
  !           in upper triangular form and is equivalent with B
  !           if compAB is true.
  !
  ! compAB  boolean       [IN]
  !           If true, the equivalences are applied to (A,B) such
  !           that the output triangular pair is equivalent to
  !           the input pair. If not, the output is not
  !           equivalent but the eigenvalues of the original pair
  !           are available on the diagonal.
  !
  ! strtidx integer     [IN]
  !           Start index of part of the matrix pencil that needs
  !           to be reduced to Schur form. Provide '0' if start is
  !           the beginning of the pencil.
  !
  ! stpidx  integer     [IN]
  !           Stop index of the part of the matrix pencil that needs
  !           to be reduced to Schur form. Provide N (matrix size) if
  !           stop is the end of the pencil. The strt and stp parameters
  !           need to satisfy:
  !               0 <= strtidx < stpidx <= N
  !
  ! Q       complex double array [INOUT]
  !           Unitary matrix containing the left Schur
  !           vectors. The number of columns of Q should be at least
  !           stpidx-strtidx. The Q array is not initialized in this routine.
  !
  ! compQ   boolean       [IN]
  !           If true, the left Schur vectors are computed.
  !
  ! qcol    integer       [IN]
  !           Column index from whereon the equivalence transformations
  !           are applied. If they should be applied from the beginning
  !           of the Q array, qcol needs to be set to 1. If qcol > 1, then
  !           the Q array should have at least qcol+stpidx-strtidx-1 columns.
  !
  ! Z       complex double array [INOUT]
  !           Unitary matrix containing the right Schur
  !           vectors. The number of columns of Z should be at least
  !           stp-strt. The Z array is not initialized in this routine.
  !
  ! compZ   boolean       [IN]
  !           If true, the right Schur vectors are computed.
  !
  ! zcol    integer       [IN]
  !           Column index from whereon the equivalence transformations
  !           are applied. If they should be applied from the beginning
  !           of the Z array, zcol needs to be set to 1. If zcol > 1, then
  !           the Z array should have at least zcol+stpidx-strtidx-1 columns.
  !
  ! alpha   complex double array [OUT]
  !           Array of length stpidx-strtidx containing the numerators for
  !           the generalized eigenvalues
  !
  ! beta    complex double array [OUT]
  !           Array of length stpidx-strtidx containing the denominators
  !           for the generalized eigenvalues
  !
  ! On successful completion of the routine the following equivalences hold:
  !   A(out) = Q^* A(in) Z
  !   B(out) = Q^* B(in) Z
  !___________________________________________________________________________
  ! last edit: September 4, 2018

    complex(kind=dp), intent(inout)   ::  A(:,:), B(:,:), Q(:,:), Z(:,:)
    logical, intent(in)               ::  compAB, compQ, compZ
    integer, intent(in)               ::  strtidx, stpidx, qcol, zcol
    complex(kind=dp), intent(out)     ::  alpha(:), beta(:)

    ! Internal variables
    type(tAp), pointer                :: apHead, apCurrent, apTotal
    integer                           :: i, j, N, nit, nswaps, qci, zci, mi, &
                                         mc, ki, kc, wei, wec, wsc, wsi, LDAB, &
                                         LDQ,LDQM, LDZ, LDZM, LDC, LDR
    integer,pointer                   :: cstrt, cstp
    logical                           :: problemsolved, defl

    external ZGEMM

    ! Initialize variables

    ! apHead stores the active parts throughout the iteration
    call tApInit(apHead,strt=strtidx,stp=stpidx)
    ! apTotal stores the active part at the start and is never modified
    call tApInit(apTotal,strt=strtidx,stp=stpidx)
    ! Q and Z indices
    qci = qcol-strtidx
    zci = zcol-strtidx
    ! Tightly-packed settings and memory
    call z_getSettings(stpidx-strtidx,mi,ki,wei,wsi)
    mc = mi
    kc = ki
    wec = wei
    wsc = wsi
    ! Leading dimensions
    call z_getLeadingDim(LDAB,A)
    call z_getLeadingDim(LDQ,Q)
    call z_getLeadingDim(LDZ,Z)
    N = max(LDAB,LDQ,LDZ)
    ! Allocate memory for swapping and deflation
    if (wei .gt. 1) then
      call z_allocateAedMem(wei,N)
    end if
    call z_allocateSwapMem(mi+ki-1,N)
    ! Leading dimensions
    call z_getLeadingDim(LDZM,ZM)
    call z_getLeadingDim(LDC,CuM)
    call z_getLeadingDim(LDR,RuM)
    call z_getLeadingDim(LDQM,QM)
    !Performance tracking
    nit = 0
    nswaps = 0
    problemsolved = .false.

    ! Start of main program
    do while (.not. problemsolved)
    ! Main loop is repeated until no active parts are left
    apCurrent => apHead
    do
    ! Loop over all active parts
      call tApGet(apCurrent,cstrt,cstp)
      call z_getSettings(cstp-cstrt,mc,kc,wec,wsc)
      if (mc .eq. 1) then
        ! Use the single shift implementation
        QM = czero
        do i=1, cstp-cstrt
          QM(i,i) = cone
        end do
        ZM = czero
        do i=1, cstp-cstrt
          ZM(i,i) = cone
        end do
        call z_RQZ1(A, B, compAB, cstrt, cstp, QM, .true., 1, ZM, .true., 1,&
                    alpha, beta)
        ! Update the remainder of the pencil
        if (compAB) then
          ! Row update A
          call ZGEMM('C','N',cstp-cstrt,stpidx-cstp,cstp-cstrt,cone,&
                     QM(1,1),LDQM,A(cstrt+1,cstp+1),LDAB,czero,RuM(1,1),LDR)
          A(cstrt+1:cstp,cstp+1:stpidx) = RuM(1:cstp-cstrt,1:stpidx-cstp)
          ! Row update B
          call ZGEMM('C','N',cstp-cstrt,stpidx-cstp,cstp-cstrt,cone,&
                     QM(1,1),LDQM,B(cstrt+1,cstp+1),LDAB,czero,RuM(1,1),LDR)
          B(cstrt+1:cstp,cstp+1:stpidx) = RuM(1:cstp-cstrt,1:stpidx-cstp)
          if (cstrt .gt. 0) then
            ! Column update A
            call ZGEMM('N','N',cstrt-strtidx,cstp-cstrt,cstp-cstrt,cone,&
                      A(strtidx+1,cstrt+1),LDAB,ZM(1,1),LDZM,czero,CuM(1,1),LDC)
            A(strtidx+1:cstrt,cstrt+1:cstp) = CuM(1:cstrt-strtidx,1:cstp-cstrt)
            ! Column update B
            call ZGEMM('N','N',cstrt-strtidx,cstp-cstrt,cstp-cstrt,cone,&
                      B(strtidx+1,cstrt+1),LDAB,ZM(1,1),LDZM,czero,CuM(1,1),LDC)
            B(strtidx+1:cstrt,cstrt+1:cstp) = CuM(1:cstrt-strtidx,1:cstp-cstrt)
          end if
        end if

        if (compQ) then
          call ZGEMM('N','N',LDQ,cstp-cstrt,cstp-cstrt,cone,&
                     Q(1,qci+cstrt),LDQ,QM(1,1),LDQM,czero,CuM,LDC)
          Q(1:LDQ,qci+cstrt:qci+cstp-1) = CuM(1:LDQ,1:cstp-cstrt)
        end if

        if (compZ) then
          call ZGEMM('N','N',LDZ,cstp-cstrt,cstp-cstrt,cone,&
                     Z(1,zci+cstrt),LDZ,ZM(1,1),LDZM,czero,CuM,LDC)
          Z(1:LDZ,zci+cstrt:zci+cstp-1) = CuM(1:LDZ,1:cstp-cstrt)
        end if
        ! Not an active part anymore, remove from list
        if (.not. (associated(tApPrevious(apCurrent)))) then
          ! apCurrent is the head, update head
          apHead => tApNext(apCurrent) ! can be null(), no issue
        end if
        ! Delete and restart
        call tApDelete(apCurrent)
        apCurrent => apHead
      else
        ! Use the Tightly-packed implementation on the current active part
        ! check for deflation at front
        call z_start_aed(defl, wsc, A, B, compAB, apCurrent, apTotal, &
                         Q, compQ, qci+cstrt, Z, compZ, zci+cstrt)
        if (cstp - cstrt .gt. mc) then
          ! Compute the shifts as the eigenvalues of the trailing mcxmc block
          ! Create copy (we do not want to change the pencil here)
          QM(1:mc,1:mc) = A(cstp-mc+1:cstp,cstp-mc+1:cstp)
          ZM(1:mc,1:mc) = B(cstp-mc+1:cstp,cstp-mc+1:cstp)
          call z_RQZ1(QM, ZM, .false., 0, mc, Q, .false., 1, Z, .false., 1, &
                      alpha, beta)
          ! Introduce the mc shifts
          call z_set_first_m_poles(alpha(1:mc),beta(1:mc),A,B,compAB,apCurrent,&
                                   apTotal,Q,compQ,qci+cstrt,Z,compZ,zci+cstrt)
          ! Check again for regular deflation at front
          call z_check_start_deflation(defl,A,B,compAB,apCurrent,apTotal,&
                                       Q,compQ,qci+cstrt)
          ! Deflations along subdiagonal:
          call z_check_interior_deflations(defl,A, B, apCurrent)
          ! apCurrent is updated; consequently cstrt, and cstp
          if (defl) then
            ! Make sure that we're handling the correct range
            call tApGet(apCurrent,cstrt,cstp)
          end if

          if (cstp - cstrt .gt. mc) then
            nit = nit + mc
            ! Chase
            ! Take as many steps of size kc as possible
            j = 0
            do i = cstrt+1, cstp-mc-kc, kc
              call z_swapmk(i, mc, kc,A, B, compAB, apCurrent, apTotal, &
                            Q, compQ, qci+i, Z, compZ, zci+i-1)
              nswaps = nswaps + (mc*kc)
              j = j + 1
            end do
            ! Take the remaining steps
            i = cstp-cstrt-mc-(j*kc)-2
            call z_swapmk(cstrt+(j*kc)+1, mc,i ,A, B, compAB, apCurrent,&
                          apTotal, Q, compQ, qci+cstrt+(j*kc)+1,&
                          Z, compZ, zci+cstrt+(j*kc))
            nswaps = nswaps + (mc*i)

            ! Check for deflations at the end
            call z_stop_aed(defl, wec, A, B, compAB, apCurrent, apTotal, &
                            Q, compQ, qci+cstp-wec, Z, compZ, zci+cstp-wec-1)
            ! Compute mc poles as the eigenvalues of the leading mcxmc block
            ! Create copy (we do not want to change the pencil here)
            QM(1:mc,1:mc) = A(cstrt+1:cstrt+mc,cstrt+1:cstrt+mc)
            ZM(1:mc,1:mc) = B(cstrt+1:cstrt+mc,cstrt+1:cstrt+mc)
            call z_RQZ1(QM, ZM, .false., 0, mc, Q, .false., 1, Z, .false., 1, &
                        alpha, beta)
            ! Introduce the mc poles
            call z_set_last_m_poles(alpha(1:mc),beta(1:mc),A,B,compAB,&
                            apCurrent,apTotal,Q,compQ,cstp-mc+1,Z,compZ,cstp-mc)
          end if
        end if
      end if

      ! Check for exit condition
      if (associated(tApNext(apCurrent))) then
        apCurrent => tApNext(apCurrent) ! Set the next one
      else
        exit ! Exit this loop over the active parts
      end if
  ! end of loop over active parts
  end do

  ! Check if entire problem is solved
  call tApGet(apHead,cstrt,cstp)
  if (.not. (associated(cstrt) .or. associated(cstp))) then
    problemsolved = .true.
  end if

  ! end of main loop
  end do

  ! return results
  do i = 1,stpidx-strtidx
    alpha(i) = A(i+strtidx,i+strtidx)
    beta(i) = B(i+strtidx,i+strtidx)
  end do

  ! free everything
  apCurrent => null()
  call tApFree(apHead)
  call tApFree(apTotal)

  call z_deallocateSwapMem
  call z_deallocateAedMem

  end subroutine

  subroutine z_getSettings(N,m,k,we,ws)
  ! Settings for tightly-packed chasing and aggressive
  ! deflation at the start and end
  !___________________________________________________________________________
    integer, intent(in)             ::  N
    integer, intent(out)            ::  m, k, we, ws

    if (N .lt. ssth) then
      k = 1
      m = 1
      we = 1
      ws = 1
    elseif (N .lt. 60) then
      k = 4
      m = 4
      we = 6
      ws = 2
    elseif (N .lt. 180) then
      k = 10
      m = 10
      we = 12
      ws = 4
    elseif (N .lt. 1001) then
      k = 32
      m = 32
      we = 34
      ws = 6
    elseif (N .lt. 3000) then
      k = 64
      m = 64
      we = 66
      ws = 12
    elseif (N .lt. 6000) then
      k = 128
      m = 128
      we = 130
      ws = 20
    else
      k = 256
      m = 256
      we = 266
      ws = 28
    end if
  end subroutine
end module


c
c -------------------------------------------------------------
c
      subroutine vrm(qr,ql,rx,ixmin,ixmax,iflip,msize)

      implicit double precision (a-h,o-z)
      include "cuserdt.i"
      dimension qr(4,msize),ql(4,msize)
      dimension rx(4,msize)
      dimension rhor(msize),ur(msize),pr(msize),utr(msize)
      dimension rhol(msize),ul(msize),pl(msize),utl(msize)

c
c     # van Leer vector Riemann solver
c     # Given primitive variables, compute
c     # conserved variables at interface by solving riemann problem
c     # only solve neighboring vertical interfaces
c
c      iflip = 1 indicates the normal velocity is in
c                qr(k,2) and the tangential in qr(k,3)
c            = 0 indicates the reverse.
c   done so a single riemann solver can be used for both columns and rows.
c
      if (ixmax .gt. msize) then
         write(6,*)" need to increase msize in vrm to ", ixmax
         stop
      endif

      inorm = 3 - iflip
      itan  = 2 + iflip

      do 10 k = ixmin, ixmax
         rhor(k) = qr(1,k)
         ur(k)   = qr(inorm,k)
         utr(k)  = qr(itan,k)
         pr(k)   = qr(4,k)
         rhol(k) = ql(1,k)
         ul(k)   = ql(inorm,k)
         utl(k)  = ql(itan,k)
         pl(k)   = ql(4,k)
  10     continue
c
      do 20 k = ixmin, ixmax

        orhor = 1.d0/rhor(k)
        unr   = ur(k)
        utanr = utr(k)

        orhol = 1.d0/rhol(k)
        unl   = ul(k)
        utanl = utl(k)

        cl2 = gamma*pl(k)*orhol
        cr2 = gamma*pr(k)*orhor
        cl = sqrt(cl2)
        cr = sqrt(cr2)

        odenom = .5d0/(gamma*gamma-1.d0)

        if (unl .ge. cl) then   ! completely supersonic in left state
          fl_rho     = rhol(k)*unl
          fl_thisMom = rhol(k)*unl*unl + pl(k)
          fl_tanMom  = rhol(k)*unl*utanl
          etot       = .5d0*rhol(k)*(unl*unl+utanl*utanl) + pl(k)/gamma1
          fl_rhoE    = unl*(etot + pl(k))
        else if (unl > -cl) then  ! subsonic left state (either in or out)
          f1l = gamma1*unl + 2.d0*cl
          fplus  = rhol(k) * .25d0 * (unl+cl)*(unl+cl)/cl
          fl_rho = fplus
          fl_thisMom = fplus * f1l /gamma
          fl_tanMom  = fplus * utanl
          fl_rhoE    = fplus * (utanl*utanl*.5d0 +  f1l*f1l*odenom)
        else
          fl_rho     = 0.d0
          fl_thisMom = 0.d0
          fl_tanMom  = 0.d0
          fl_rhoE    = 0.d0
        endif

        if (unr .le. -cr) then   ! completely supersonic in right state
          fr_rho     = rhor(k)*unr
          fr_thisMom = rhor(k)*unr*unr + pr(k)
          fr_tanMom  = rhor(k)*unr*utanr
          etot       = .5d0*rhor(k)*(unr*unr+utanr*utanr) + pr(k)/gamma1
          fr_rhoE    = unr*(etot + pr(k))
        else if (unr < cr) then  ! subsonoic right state (either in or out)
          f1r = gamma1*unr - 2.d0*cr
          fminus = -rhor(k)*.25d0 * (unr-cr)*(unr-cr)/cr
          fr_rho  = fminus
          fr_thisMom = fminus*f1r /gamma
          fr_tanMom  = fminus * utanr
          fr_rhoE    = fminus * (utanr*utanr*.5d0 + f1r*f1r*odenom)
        else
          fr_rho     = 0.d0
          fr_thisMom = 0.d0
          fr_tanMom  = 0.d0
          fr_rhoE    = 0.d0
        endif

         rx(1,k)     = fl_rho + fr_rho
         rx(inorm,k) = fl_thisMom + fr_thisMom
         rx(itan,k)  = fl_tanMom  + fr_tanMom
         rx(4,k)     = fl_rhoE + fr_rhoE

 20   continue

c
       return
       end


	PROGRAM EPSTEST
C
C	TEST SMALL EPSILON APPROX TO DISERSION RELATION, STERO-CASSINI NB P.84
C
	COMPLEX ROOT(3)
	REAL POLY(40)
C
	DATA TPAR /.15E-4/
	DATA WRSAVE,XKSAVE /1.0014,7.13/
	DATA VGP0 /-1./
	DATA WCYCL /.0062/
C	DATA ANG /11.1/
	DATA ANG /0./
c
	XK = 1.
	RATIO = 1.1
	XK = XK*RATIO
	I = 1
C	DO I = 1,5
	  XK =XK/RATIO
C	  USE CUBIC, COLD PLASMA
	  A = -XK**2
	  B = (XK**2 - WCYCL**2)/4.
	  C = ((WCYCL*XK*SIND(ANG))**2)/8.
	  EPS = .005
	  RATEPS = 1.1
	  EPS = EPS/RATEPS
	  DO J = 1,60
	     EPS = EPS*RATEPS
	     POLY(I) = EPS**3 + A*EPS**2 + B*EPS + C
	     WRITE(27,1026) EPS,POLY(I)
	  ENDDO
C	  CALL CUBIC(A,B,C,ROOT)
C	  PRINT*,'ROOTS',ROOT
C	  PRINT*,'XK,A,B,C',XK,A,B,C
C	  WRITE(26,1026) XK,ROOT
 1026	FORMAT(F6.3,6E12.3)
C	ENDDO
	STOP
	END