!> \file eos.f90
!! \BRIEF
!> Module with EOS-80/TEOS-10 conversion subroutines
MODULE meos
CONTAINS

#if USE_PRECISION == 2
#   define SGLE(x)    (x)
#else
#   define SGLE(x)    REAL(x)
#endif

SUBROUTINE sa2sp_chem(SA, TA, DIC, NO3, SIOH4, N, SP)
! sa2sp_chem:             From Absolute to Practical Salinity
!
! Description:
!      Convert from Absolute (SA) to Practical Salinity (SP), as 1D arrays,
!       based on Total Alkalinity, Dissolved Inorganic Carbon and Nitrate and
!      Silicate concentrations.
!
! Input:
!       SA: Absolute Salinity in g/kg
!       TA: Total Alkalinity, in mol/kg
!      DIC: Dissolved Inorganic Carbone concentration in mol/kg
!      NO3: Total Nitrate concentration in mol/kg
!    SIOH4: Total Silicate concentration in mol/kg
!        N: Size of input and output 1D arrays
!
! Details:
!      Convert from Absolute (SA) to Practical Salinity (SP) from carbon
!      system parameters and ion concentration which most affect water
!      density anomalies (nitrate and silicate).
!
! Output:
!       SP: Practical Salinity (in psu)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      R. Pawlowicz, D. G. Wright, and F. J. Millero, 2011: The
!      effects of biogeochemical processes on oceanic conductivity/
!      salinity/density relationships and the characterization of real
!      seawater
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      sp2sa_chem does the reverse
!      sa2sp_geo
!
! Examples:
!         ! Calculate the practical salinity of a sample with Absolute Salinity of 35 g/kg,
!         ! Total Alkalinity of 0.00234 mol/kg, DIC of 0.00202 mol/kg, zero Nitrate and Silicate
!         CALL sa2sp_chem(35, 2340, 0.2020, 0, 0, 1, SP)
!

USE msingledouble
USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !>  SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: SA
  !>  TA: Total Alkalinity, in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: TA
  !> DIC: Dissolved Inorganic Carbone concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: DIC
  !> NO3: Total Nitrate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: NO3
  !> SIOH4: Total Silicate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SIOH4

! Output variables:
  !>  SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(out),    DIMENSION(N) :: SP

  ! Reverse conversion (SA from SP) follows this equation :
  !  SP = 1/r * (SA - sa_anomaly)
  !    with
  !        r = 35.16504 / 35
  !  SP = 1/r * (SA - 55.6 * (TA - x*SP) - 4.7 * (DIC - y*SP) - nutrients)
  !    with
  !       x  = 0.00230 / 35
  !       y  = 0.00208 / 35
  !       nutrients = 38.9 * NO3 + 50.7 * SIOH4
  !
  !  SP * (1 - 55.6 * x/r - 4.7 * y/r) = 1/r * (SA - 55.6 * TA - 4.7 * DIC - nutrients)
  !
  !  SP * (1 - 55.6 * 0.00230 / 35.16504 - 4.7 * 0.00208 / 35.16504) = ....
  !
  !  SP * 0.9960854303 = 1/r * (SA - 55.6 * TA - 4.7 * DIC - nutrients)
  !
  !  SP = 0.999218211671 * (SA - 55.6 * TA - 4.7 * DIC - nutrients)

  INTEGER :: i

  DO i = 1, N
     SP(i) = 0.999218211671 * (SA(i) - 55.6 * TA(i) - 4.7 * DIC(i) - 38.9 * NO3(i) - 50.7 * SIOH4(i))
  ENDDO

END SUBROUTINE

SUBROUTINE sa2sp_geo(SA, N, SP, P, lon, lat)
! sa2sp_geo:         From Absolute to Practical Salinity
!
! Description:
!      Convert from Absolute (SA) to Practical Salinity (SP) based on
!      depth (pressure) and geographic location.
!
! Input:
!       SA: Absolute Salinity in g/kg
!        N: Size of input and output 1D arrays
!        P: Sea water pressure in dbar (optional, default = 0)
!      lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!      lat: Latitude, optional, in decimal degrees [-90 ... 90]
!
! Details:
!      This subroutine is almost an alias of subroutine gsw_sp_from_sa
!      from gsw package on which it relies. The difference is in
!      that pressure and location are optional and that input/output are
!      vectors instead of scalars.
!      If location is not given or incomplete (either longitude or latitude missing),
!      an arbitrary location is chosen: the mid equatorial atlantic ocean. Note that
!      this implies an error on computed SP up to 0.02 psu
!
! Output:
!       SP: Practical Salinity (psu)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      sp2sa_geo does the reverse
!      sa2sp_chem
!
! Examples:
!         ! Calculate the practical salinity of a sample whose absolute Salinity is 35,
!         ! depth is 10 dbar and location is 188 degrees East and 4 degrees North.
!         CALL sa2sp_geo(35, 1, SP, 10, 188, 4)
!

USE msingledouble
USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: SA
  !> P: Sea water pressure in dbar (optional, default = 0)
!!!f2py real(8) intent(in), optional, dimension(n) :: p = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: P
!f2py optional :: p = 0.0
!
  !> lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!!!f2py real(8) intent(in), optional, dimension(n) :: lon = -25.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lon
!f2py optional :: lon = -25.0
  !> lat: Latitude, optional, in decimal degrees [-90 ... 90]
!!!f2py real(8) intent(in), optional, dimension(n) :: lat = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lat
!f2py optional :: lat = 0.0

! Output variables:
  !> SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(out),    DIMENSION(N) :: SP

  ! Default latitude and longitude
  REAL(kind=r8) :: def_lat, def_lon
  INTEGER :: i

  IF (PRESENT(lat) .AND. PRESENT(lon)) THEN
     IF (PRESENT(P)) THEN
        DO i = 1, N
           SP(i) = SGLE(gsw_sp_from_sa(DBLE(SA(i)),DBLE(P(i)),DBLE(lon(i)),DBLE(lat(i))))
        ENDDO
     ELSE
        DO i = 1, N
           SP(i) = SGLE(gsw_sp_from_sa(DBLE(SA(i)), 0.0d0, DBLE(lon(i)),DBLE(lat(i))))
        ENDDO
     ENDIF
  ELSE
     def_lat = 0.0
     def_lon = -25
     IF (PRESENT(P)) THEN
        DO i = 1, N
           SP(i) = SGLE(gsw_sp_from_sa(DBLE(SA(i)), DBLE(P(i)), def_lon, def_lat))
        ENDDO
     ELSE
        DO i = 1, N
           SP(i) = SGLE(gsw_sp_from_sa(DBLE(SA(i)), 0.0d0, def_lon, def_lat))
        ENDDO
     ENDIF
  ENDIF

END SUBROUTINE

SUBROUTINE sp2sa_chem(SP, TA, DIC, NO3, SIOH4, N, SA)
! sp2sa_chem :           From Practical to Absolute Salinity
!
! Description:
!      Convert from Practical (SP) to Absolute Salinity (SA) based on
!      Total Alkalinity, Dissolved Inorganic Carbon and Nitrate and
!      Silicate concentrations.
!
! Input:
!       SP: Practical Salinity on the practical salinity scale
!       TA: Total Alkalinity, in mol/kg
!      DIC: Dissolved Inorganic Carbone concentration in mol/kg
!      NO3: Total Nitrate concentration in mol/kg
!    SIOH4: Total Silicate concentration in mol/kg
!
! Details:
!      Convert from Practical (SP) to Absolute Salinity (SA) from carbon
!      system parameters and ion concentration which most affect water
!      density anomalies (nitrate and silicate).
!
! Output:
!       SA: Absolute Salinity (g/kg)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      R. Pawlowicz, D. G. Wright, and F. J. Millero, 2011: The
!      effects of biogeochemical processes on oceanic conductivity/
!      salinity/density relationships and the characterization of real
!      seawater
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      sa2sp_chem does the reverse
!      sp2sa_geo
!
! Examples:
!         ! Calculate the absolute salinity of a sample with practical Salinity of 35,
!         ! Total Alkalinity of 0.00234 mol/kg and DIC of 0.00202 mol/kg
!         sp2sa_chem(35, 0.00234, 0.00202, 1, SA)
!

USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct
USE msingledouble

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !>  SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SP
  !>  TA: Total Alkalinity, in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: TA
  !> DIC: Dissolved Inorganic Carbone concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: DIC
  !> NO3: Total Nitrate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: NO3
  !> SIOH4: Total Silicate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SIOH4

! Output variables:
  !>  SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: SA

  REAL(kind=r8) :: DIC_stdsw, TA_stdsw
  REAL(kind=r8) :: SR, sal_anomaly
  INTEGER :: i

  ! This function is made of two parts :
  !   1) conversion from Practical to Reference Salinity (major part)
  !   2) conversion from Reference to Absolute Salinity (Absolute Anomaly, minor part)
  !

  DO i = 1, N
    ! DIC and TA values of standard sea water
    TA_stdsw  = 2300.e-6 * SP(i) /35
    DIC_stdsw = 2080.e-6 * SP(i) /35

    ! Absolute salinity anomaly (g/kg)
    sal_anomaly = 55.6 * (TA(i) - TA_stdsw) + 4.7 * (DIC(i) - DIC_stdsw) + 38.9 * NO3(i) + 50.7 * SIOH4(i)

    SR = SP(i) * 35.16504 / 35
    SA(i) = SR + sal_anomaly
  ENDDO

END SUBROUTINE

SUBROUTINE sp2sa_geo(SP, N, SA, P, lon, lat)
! sp2sa_geo:         From Practical to Absolute Salinity
!
! Description:
!      Convert from Practical (SP) to Absolute Salinity (SA) based on
!      depth (pressure) and geographic location.
!
! Input:
!       SP: Practical Salinity on the practical salinity scale
!        P: Sea water pressure in dbar, optional, default = 0
!      lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!      lat: Latitude, optional, in decimal degrees [-90 ... 90]
!
! Details:
!      This subroutine is almost an alias of subroutine gsw_sa_from_sp of
!      from gsw package on which it relies. The difference is in
!      that pressure and location are optional and that input/output are
!      vectors instead of scalars.
!      If location is not given or incomplete (either longitude or latitude missing),
!      an arbitrary location is chosen: the mid equatorial atlantic ocean. Note that
!      this implies an error on computed SA up to 0.02 g/kg
!
! Output:
!       SA: Absolute Salinity (g/kg)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      sa2sp_geo does the reverse
!      sp2sa_chem
!
! Examples:
!         ! Calculate the absolute salinity of a sample whose practical Salinity is 35,
!         ! depth is 10 dbar and location is 188 degrees East and 4 degrees North.
!         CALL sp2sa_geo(35, 1, SA, 10, 188, 4)

USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct
USE msingledouble

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SP
  !> P: Sea water pressure in dbar (optional, default = 0)
!!!f2py real(8) intent(in), optional, dimension(n) :: p = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: P
!f2py optional :: p = 0.0
  !> lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!!!f2py real(8) intent(in), optional, dimension(n) :: lon = -25.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lon
!f2py optional :: lon = -25.0
  !> lat: Latitude, optional, in decimal degrees [-90 ... 90]
!!!f2py real(8) intent(in), optional, dimension(n) :: lat = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lat
!f2py optional :: lat = -25.0

! Output variables:
  !>  SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: SA

  ! Default latitude and longitude
  REAL(kind=r8) :: def_lat, def_lon
  INTEGER :: i

  IF (PRESENT(lat) .AND. PRESENT(lon)) THEN
     IF (PRESENT(P)) THEN
        DO i = 1, N
           SA(i) = SGLE(gsw_sa_from_sp(DBLE(SP(i)), DBLE(P(i)), DBLE(lon(i)), DBLE(lat(i))))
        ENDDO
     ELSE
        DO i = 1, N
           SA(i) = SGLE(gsw_sa_from_sp(DBLE(SP(i)), 0.0d0, DBLE(lon(i)), DBLE(lat(i))))
        ENDDO
     ENDIF
  ELSE
     def_lat = 0
     def_lon = -25
     IF (PRESENT(P)) THEN
        DO i = 1, N
           SA(i) = SGLE(gsw_sa_from_sp(DBLE(SP(i)), DBLE(P(i)), def_lon, def_lat))
        ENDDO
     ELSE
        DO i = 1, N
           SA(i) = SGLE(gsw_sa_from_sp(DBLE(SP(i)), 0.0d0, def_lon, def_lat))
        ENDDO
     ENDIF
  ENDIF

END SUBROUTINE

SUBROUTINE teos2eos_chem(SA, CVT, P, TA, DIC, NO3, SIOH4, N, T, SP)
! teos2eos_chem:      Convert temperature and salinity from TEOS-10 to EOS-80
!
! Description:
!      Convert conservative temperature to in-situ temperature and
!      Absolute Salinity (SA) to Practical Salinity (SP). Salinity
!      conversion depends on Total Alkalinity, Dissolved Inorganic Carbon
!      and Nitrate and Silicate concentrations.
!
! Input:
!       SA: Absolute Salinity in g/kg
!      CvT: Conservative Temperature in degrees C
!        P: Sea water pressure in dbar
!       TA: Total Alkalinity, in µmol/kg
!      DIC: Dissolved Inorganic Carbone concentration in µmol/kg
!      NO3: Total Nitrate concentration in µmol/kg
!    SIOH4: Total Silicate concentration in µmol/kg
!
! Details:
!      Conversion from Absolute (SA) to Practical Salinity (SP) depends
!      on carbon system parameters and ion concentration which most
!      affect water density anomalies.
!
! Output:
!        T: in situ Temperature (deg C)
!       SP: Practical Salinity (psu)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      R. Pawlowicz, D. G. Wright, and F. J. Millero, 2011: The
!      effects of biogeochemical processes on oceanic conductivity/
!      salinity/density relationships and the characterization of real
!      seawater
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      eos2teos_chem does the reverse, teos2eos_geo, sa2sp_cham
!      package GSW for Fortran
!
! Examples:
!         ! Calculate in-situ Temperature and practical salinity of a sample with
!         ! Absolute Salinity of 35 g/kg, Conservative Temperature of 18 deg C,
!         ! at 0 dbar and Total Alkalinity of 0.00234 mol/kg and DIC of 0.00202 mol/kg,
!         ! zero Nitrate and Silicate
!         CALL teos2eos_chem(35, 18, 0, 0.00234, 0.00202, 0, 0, 1, T, SP)
!

USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct
USE msingledouble

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> CvT: Conservative Temperature (deg C)
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: CvT
  !> SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: SA
  !>  P: Sea water pressure in dbar
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: P
  !> TA: Total Alkalinity, in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: TA
  !> DIC: Dissolved Inorganic Carbone concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: DIC
  !> NO3: Total Nitrate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: NO3
  !> SIOH4: Total Silicate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SIOH4

! Output variables:
  !> SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(out),    DIMENSION(N) :: SP
  !>  T: in-situ temperature in deg. C
  REAL(kind=rx), INTENT(out),    DIMENSION(N) :: T

  INTEGER :: i

  ! convert temperature
  DO i = 1, N
     T(i) = SGLE(gsw_t_from_ct (DBLE(SA(i)), DBLE(CvT(i)), DBLE(P(i))))
  ENDDO

  ! convert salinity
  CALL sa2sp_chem (SA, TA, DIC, NO3, SIOH4, N, SP)

END SUBROUTINE

SUBROUTINE teos2eos_geo(SA, CvT, P, N, T, SP, lon, lat)
! teos2eos_geo:       Convert temperature and salinity from TEOS-10 to EOS-80
!
! Description:
!      Convert conservative temperature to in-situ temperature and
!      Absolute Salinity (SA) to Practical Salinity (SP). Salinity
!      conversion depends on depth and geographic location.
!
! Input:
!       SA: Absolute Salinity in g/kg
!      CvT: Conservative Temperature in degrees C
!        P: Sea water pressure in dbar
!      lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!      lat: Latitude, optional, in decimal degrees [-90 ... 90]
!
! Details:
!      Conversion from Absolute (SA) to Practical Salinity (SP) depends
!      on water density anomaly which is correlated with Silicate
!      concentration. This function relies on silicate concentration
!      taken from WOA (World Ocean Atlas) to evaluate density anomaly.
!
! Output:
!        T: in situ Temperature (deg C)
!       SP: Practical Salinity (psu)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      eos2teos_geo does the reverse, teos2eos_chem, sa2sp_geo
!      package GSW for Fortran
!
! Examples:
!         ! Calculate insitu Temperature and practical salinity of a sample with
!         ! Absolute Salinity of 35 g/kg, Conservative Temperature of 18 deg C,
!         ! depth is 10 dbar and location is 188 degrees East and 4 degrees North.
!         CALL teos2eos_geo(35, 18, 10, 1, T, SP, 188, 4)
!

USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct
USE msingledouble

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> CvT: Conservative Temperature (deg C)
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: CvT
  !> SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: SA
  !> P: Sea water pressure in dbar (optional, default = 0)
!!!f2py real(8) intent(in), optional, dimension(n) :: p = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: P
!f2py optional :: p = 0.0
  !> lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!!!f2py real(8) intent(in), optional, dimension(n) :: lon = -25.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lon
!f2py optional :: lon = -25.0
  !> lat: Latitude, optional, in decimal degrees [-90 ... 90]
!!!f2py real(8) intent(in), optional, dimension(n) :: lat = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lat
!f2py optional :: lat = 0.0

! Output variables:
  !> SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(out),    DIMENSION(N) :: SP
  !>  T: in-situ temperature in deg. C
  REAL(kind=rx), INTENT(out),    DIMENSION(N) :: T

  INTEGER :: i

  ! convert temperature
  DO i = 1, N
     T(i) = SGLE(gsw_t_from_ct (DBLE(SA(i)), DBLE(CvT(i)), DBLE(P(i))))
  ENDDO
  ! convert salinity
  IF (PRESENT(lat) .AND. PRESENT(lon)) THEN
     CALL sa2sp_geo(SA, N, SP, P, lon, lat)
  ELSE
     CALL sa2sp_geo(SA, N, SP, P)
  ENDIF

END SUBROUTINE

SUBROUTINE eos2teos_geo(SP, T, P, N, CvT, SA, lon, lat)
! eos2teos_geo:        Convert temperature and salinity from EOS-80 to TEOS-10
!
! Description:
!      Convert in-situ to Conservative temperature and Practical (SP) to
!      Absolute Salinity (SA), AS 1d ARRAYS.
!      Salinity conversion depends on depth and geographic location.
!
! Input:
!       SP: Practical Salinity on the practical salinity scale
!        T: in-situ temperature in deg. C
!        P: Sea water pressure in dbar
!      lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!      lat: Latitude, optional, in decimal degrees [-90 ... 90]
!        N: Size of input and output 1D arrays
!
! Details:
!      Conversion from Practical (SP) to Absolute Salinity (SA) depends
!      on water density anomaly which is correlated with Silicate
!      concentration. This function relies on silicate concentration
!      taken from WOA (World Ocean Atlas) to evaluate density anomaly.
!
! Output:
!       CVT: Conservative Temperature (deg C)
!       SA: Absolute Salinity (g/kg)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      teos2eos_geo does the reverse, eos2teos_chem, sp2sa_geo
!      package GSW for Fortran
!
! Examples:
!         ! Calculate Conservative Temperature and Absolute Salinity of a sample with
!         ! Practical Salinity of 35 psu, in-situ Temperature of 18 deg C,
!         ! depth is 10 dbar and location is 188 degrees East and 4 degrees North.
!         call eos2teos_geo(35, 18, 10, 188, 4, 1, CvT, SA)
!
USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct
USE msingledouble

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !> SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SP
  !> T: in-situ temperature in deg. C
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: T
  !> P: Sea water pressure in dbar (optional, default = 0)
!!!f2py real(8) intent(in), optional, dimension(n) :: p = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: P
!f2py optional :: p = 0.0
  !> lon: Longitude, optional, in decimal degrees [ 0 ... +360 ] or [ -180 ... +180 ]
!!!f2py real(8) intent(in), optional, dimension(n) :: lon = -25.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lon
!f2py optional :: lon = -25.0
  !> lat: Latitude, optional, in decimal degrees [-90 ... 90]
!!!f2py real(8) intent(in), optional, dimension(n) :: lat = 0.0
  REAL(kind=rx), OPTIONAL, INTENT(in),    DIMENSION(N) :: lat
!f2py optional :: lat = 0.0

! Output variables:
  !> CvT: Conservative Temperature (deg C)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: CvT
  !> SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: SA

  INTEGER :: i

  ! convert salinity
  IF (PRESENT(lat) .AND. PRESENT(lon)) THEN
     CALL sp2sa_geo(SP, N, SA, P, lon, lat)
  ELSE
     CALL sp2sa_geo(SP, N, SA, P)
  ENDIF
  ! convert temperature
  DO i = 1, N
     CvT(i) = SGLE(gsw_ct_from_t (DBLE(SA(i)), DBLE(T(i)), DBLE(P(i))))
  ENDDO
END SUBROUTINE

SUBROUTINE eos2teos_chem(SP, T, P, TA, DIC, NO3, SIOH4, N, CvT, SA)
! eos2teos_chem.Rd
! Convert temperature and salinity from EOS-80 to TEOS-10
!
! Description:
!      Convert in-situ to Conservative temperature and Practical (SP)
!      to Absolute Salinity (SA), as 1D arrays
!      Salinity conversion depends on Total Alkalinity, Dissolved Inorganic Carbon
!      and Nitrate and Silicate concentrations.
!
! Usage:
!      call eos2teos_chem(SP, T, P, TA, DIC, NO3, SIOH4, N, CvT, SA)
!
! Input: all 1D arrays of length N
!       SP: Practical Salinity on the practical salinity scale
!        T: in-situ temperature in deg. C
!        P: Sea water pressure in dbar
!       TA: Total Alkalinity, in mol/kg
!      DIC: Dissolved Inorganic Carbone concentration in mol/kg
!      NO3: Total Nitrate concentration in mol/kg
!    SIOH4: Total Silicate concentration in mol/kg
!        N: Size of input and output 1D arrays
!
! Details:
!      Conversion from Practical (SP) to Absolute Salinity (SA) depends
!      on carbon system parameters and ion concentration which most
!      affect water density anomalies.
!
! Output: all 1D arrays of length N
!       CvT: Conservative Temperature (deg C)
!       SA: Absolute Salinity (g/kg)
!
! Author(s):
!      Jean-Marie Epitalon
!
! References:
!      TEOS-10 web site: http://www.teos-10.org/
!
!      What every oceanographer needs to know about TEOS-10 (The TEOS-10
!      Primer) by Rich Pawlowicz (on TEOS-10 web site)
!
!      R. Pawlowicz, D. G. Wright, and F. J. Millero, 2011: The
!      effects of biogeochemical processes on oceanic conductivity/
!      salinity/density relationships and the characterization of real
!      seawater
!
!      T. J. McDougall, D. R. Jackett, F. J. Millero, R. Pawlowicz,
!      and P. M. Barker, 2012: Algorithm for estimating
!      Absolute Salinity
!
! See Also:
!      teos2eos_chem does the reverse, eos2teos_geo, sp2sa_chem
!      package GSW for Fortran
!
! Examples:
!         ! Calculate Conservative Temperature and Absolute Salinity of a sample with
!         ! Practical Salinity of 35 psu, in-situ Temperature of 18 deg C,
!         ! at 0 dbar and Total Alkalinity of 0.00234 mol/kg and DIC of 0.00202 mol/kg
!         ! zero Nitrate and Silicate
!         call eos2teos_chem(35, 18, 0, 0.00234, 0.00202, 0, 0, 1, CvT, SA)
!

USE gsw_mod_toolbox, only: gsw_sp_from_sa, gsw_sa_from_sp, gsw_ct_from_t, gsw_t_from_ct
USE msingledouble

IMPLICIT NONE

! Input variables:
  !> N: number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N
  !>  SP: Practical Salinity on the practical salinity scale
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SP
  !>   T: in-situ temperature in deg. C
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: T
  !>   P: Sea water pressure in dbar
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: P
  !>  TA: Total Alkalinity, in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: TA
  !> DIC: Dissolved Inorganic Carbone concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: DIC
  !> NO3: Total Nitrate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: NO3
  !> SIOH4: Total Silicate concentration in mol/kg
  REAL(kind=rx), INTENT(in),    DIMENSION(N) :: SIOH4

! Output variables:
  !> CvT: Conservative Temperature (deg C)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: CvT
  !> SA: Absolute Salinity (g/kg)
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: SA

  INTEGER :: i

  ! convert salinity
  CALL sp2sa_chem (SP, TA, DIC, NO3, SIOH4, N, SA)
  ! convert temperature
  DO i = 1, N
     CvT(i) = SGLE(gsw_ct_from_t (DBLE(SA(i)), DBLE(T(i)), DBLE(P(i))))
  ENDDO
END SUBROUTINE

END MODULE meos


module xbt_adjust

  use oda_types_mod, only : ocean_profile_type, missing_value

  implicit none

  real, parameter :: s1=0.30731408,s2=6.707e-9,s3=-8.1899e-5,sa=3.227,&
                     sb=-2.17e-4
  real, parameter :: t1=0.29585798,t2=1.002e-9,t3=-3.1658e-5,ta=3.426,&
       tb=-4.7e-4

contains

subroutine xbt_drop_rate_adjust(station)

  type(ocean_profile_type), intent(inout) :: station

  integer :: k
  real :: dpth_orig, dpth_new,tdrop
  integer :: fix_depth

  if (.not. station%accepted) return

  fix_depth = int(station%fix_depth)
  select case(fix_depth)
  case(-1)
      return
  case(0)
      return
  case(1)
! use Hanawa et al (1994) drop rate correction
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             dpth_new = (1.0417*dpth_orig) - (75.096*(1.0-((1.0-(0.0002063*dpth_orig)))**0.5))
             station%depth(k)=dpth_new
         endif
      enddo
      station%fix_depth=-1.0
  case (2)
! use Kizu et al (2005) correction
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             if (dpth_orig .le. 250.0) then
                 dpth_new = dpth_orig*0.9572
             else if (dpth_orig .le. 500.) then
                 dpth_new = dpth_orig*0.9565
             else if (dpth_orig .le. 750.0) then
                 dpth_new = dpth_orig*0.9558
             else if (dpth_orig .le. 1000.) then
                 dpth_new = dpth_orig*0.9550
             else if (dpth_orig .le. 1250.0) then
                 dpth_new = dpth_orig*0.9542
             else if (dpth_orig .le. 1500.0) then
                 dpth_new = dpth_orig*0.9533
             else
                 dpth_new = dpth_orig*0.9524
             endif
             station%depth(k)=dpth_new
         endif
      enddo
      station%fix_depth=-1.0
  case(103)
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             tdrop=(s1*dpth_orig + s2) - s3
             dpth_new = sa*tdrop + sb*tdrop*tdrop
             station%depth(k)=dpth_new
         endif
      enddo
      station%fix_depth=-1.0
  case(104)
      do k=1,station%levels
         dpth_orig = station%depth(k)
         if (dpth_orig .ne. missing_value) then
             tdrop=(t1*dpth_orig + t2) - t3
             dpth_new = ta*tdrop + tb*tdrop*tdrop
             station%depth(k)=dpth_new
         endif
      enddo
      station%fix_depth=-1.0
  end select

  return
end subroutine xbt_drop_rate_adjust

end module xbt_adjust


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine umat_undo_nlgeom_lin_iso_el(amat,iel,iint,kode,
     &        elconloc,emec,emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,
     &        dtime,time,ttime,icmd,ielas,mi,nstate_,xstateini,xstate,
     &        stre,stiff,iorien,pgauss,orab,eloc,nlgeom_undo)
!
!     calculates stiffness and stresses for a linear elastic isotropic
!     material with special modification of the strain tensor
!
!     The strain tensor that enters the routine is the Lagrange strain
!     tensor. This tensor is modified into an infinitesimal strain tensor
!     for large rotations. Application: singular stress/strain field at a
!     crack tip
!
!     Procedure: from the deformation gradient F the rotation is
!                removed to yield U=R^(-1).F
!                The resulting field U is linearized
!                E=((U-I)+(U-I)^T)/2 and subsequently
!                used to calculate the stresses by a
!                linear elastic isotropic relationship
!
!
!     icmd=3: calculates stress at mechanical strain
!     else: calculates stress at mechanical strain and the stiffness
!           matrix
!
!     INPUT:
!
!     amat               material name
!     iel                element number
!     iint               integration point number
!
!     kode               material type (-100-#of constants entered
!                        under *USER MATERIAL): can be used for materials
!                        with varying number of constants
!
!     elconloc(21)       user defined constants defined by the keyword
!                        card *USER MATERIAL (max. 21, actual # =
!                        -kode-100), interpolated for the
!                        actual temperature t1l
!
!     emec(6)            Lagrange mechanical strain tensor (component order:
!                        11,22,33,12,13,23) at the end of the increment
!                        (thermal strains are subtracted)
!     emec0(6)           Lagrange mechanical strain tensor at the start of the
!                        increment (thermal strains are subtracted)
!     beta(6)            residual stress tensor (the stress entered under
!                        the keyword *INITIAL CONDITIONS,TYPE=STRESS)
!
!     xokl(3,3)          deformation gradient at the start of the increment
!     voj                Jacobian at the start of the increment
!     xkl(3,3)           deformation gradient at the end of the increment
!     vj                 Jacobian at the end of the increment
!
!     ithermal           0: no thermal effects are taken into account
!                        >0: thermal effects are taken into account (triggered
!                        by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE)
!     t1l                temperature at the end of the increment
!     dtime              time length of the increment
!     time               step time at the end of the current increment
!     ttime              total time at the start of the current step
!
!     icmd               not equal to 3: calculate stress and stiffness
!                        3: calculate only stress
!     ielas              0: no elastic iteration: irreversible effects
!                        are allowed
!                        1: elastic iteration, i.e. no irreversible
!                           deformation allowed
!
!     mi(1)              max. # of integration points per element in the
!                        model
!     nstate_            max. # of state variables in the model
!
!     xstateini(nstate_,mi(1),# of elements)
!                        state variables at the start of the increment
!     xstate(nstate_,mi(1),# of elements)
!                        state variables at the end of the increment
!
!     stre(6)            Piola-Kirchhoff stress of the second kind
!                        at the start of the increment
!
!     iorien             number of the local coordinate axis system
!                        in the integration point at stake (takes the value
!                        0 if no local system applies)
!     pgauss(3)          global coordinates of the integration point
!     orab(7,*)          description of all local coordinate systems.
!                        If a local coordinate system applies the global
!                        tensors can be obtained by premultiplying the local
!                        tensors with skl(3,3). skl is  determined by calling
!                        the subroutine transformatrix:
!                        call transformatrix(orab(1,iorien),pgauss,skl)
!     eloc(6)            Lagrange total strain tensor (component order:
!                        11,22,33,12,13,23) at the end of the increment
!                        (thermal strains are subtracted)
!
!
!     OUTPUT:
!
!     xstate(nstate_,mi(1),# of elements)
!                        updated state variables at the end of the increment
!     stre(6)            Piola-Kirchhoff stress of the second kind at the
!                        end of the increment
!     stiff(21):         consistent tangent stiffness matrix in the material
!                        frame of reference at the end of the increment. In
!                        other words: the derivative of the PK2 stress with
!                        respect to the Lagrangian strain tensor. The matrix
!                        is supposed to be symmetric, only the upper half is
!                        to be given in the same order as for a fully
!                        anisotropic elastic material (*ELASTIC,TYPE=ANISO).
!                        Notice that the matrix is an integral part of the
!                        fourth order material tensor, i.e. the Voigt notation
!                        is not used.
!     emec(6)            linear mechanical strain tensor for large
!                        rotations (component order:
!                        11,22,33,12,13,23) at the end of the increment
!                        (thermal strains are subtracted)
!     eloc(6)            linear total strain tensor for large
!                        rotations (component order:
!                        11,22,33,12,13,23) at the end of the increment
!     nlgeom_undo        0: Lagrange strain goes out
!                        1: linear strain for large rotations goes out
!
      implicit none
!
      character*80 amat
!
      integer ithermal(*),icmd,kode,ielas,iel,iint,nstate_,mi(*),iorien,
     &  i,j,k,nlgeom_undo,n,matz,ier
!
      real*8 elconloc(*),stiff(21),emec(6),emec0(6),beta(6),stre(6),
     &  vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*),
     &  time,ttime,ukl(3,3),ca(3,3),elag(3,3),elin(3,3),
     &  xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*),
     &  e,un,al,um,am1,am2,eme1(6),eloc(6),w(3),z(3,3),fv1(3),
     &  fv2(3),v1,v2,v3,c(6),c2(6),dd,d(6),u(6),ur(3,3)
!
      d=(/1.d0,1.d0,1.d0,0.d0,0.d0,0.d0/)
!
      nlgeom_undo=1
!
!     calculate the rotationless linearized strain
!
!     a) calculating the Cauchy-Green tensor C=F^T.F
!
      do i=1,3
         do j=1,3
            ca(i,j)=0.d0
            do k=1,3
               ca(i,j)=ca(i,j)+xkl(k,i)*xkl(k,j)
            enddo
         enddo
      enddo
c      write(*,*) 'umat_undo..xkl',xkl(1,1),xkl(1,2),xkl(1,3)
c      write(*,*) 'umat_undo..xkl',xkl(2,1),xkl(2,2),xkl(2,3)
c      write(*,*) 'umat_undo..xkl',xkl(3,1),xkl(3,2),xkl(3,3)
c      write(*,*) 'umat_undo..ca',ca(1,1)
!
!     b) calculating the principal stretches
!
      n=3
      matz=1
!
      call rs(n,n,ca,w,matz,z,fv1,fv2,ier)
!
      if(ier.ne.0) then
         write(*,*) '
     & *ERROR calculating the eigenvalues/vectors in '
         write(*,*) '       umat_undo_nlgeom_lin_iso_el'
         call exit(201)
      endif
      w(1)=dsqrt(w(1))
      w(2)=dsqrt(w(2))
      w(3)=dsqrt(w(3))
!
!     c) calculating the invariants of U
!
      v1=w(1)+w(2)+w(3)
      v2=w(1)*w(2)+w(2)*w(3)+w(3)*w(1)
      v3=w(1)*w(2)*w(3)
c      write(*,*) 'umat_undo..v1,v2,v3',v1,v2,v3
!
!     d) storing C as vector
!
      c(1)=ca(1,1)
      c(2)=ca(2,2)
      c(3)=ca(3,3)
      c(4)=ca(1,2)
      c(5)=ca(1,3)
      c(6)=ca(2,3)
!
!     e) calculating C.C
!
      c2(1)=c(1)*c(1)+c(4)*c(4)+c(5)*c(5)
      c2(2)=c(4)*c(4)+c(2)*c(2)+c(6)*c(6)
      c2(3)=c(5)*c(5)+c(6)*c(6)+c(3)*c(3)
      c2(4)=c(1)*c(4)+c(4)*c(2)+c(5)*c(6)
      c2(5)=c(1)*c(5)+c(4)*c(6)+c(5)*c(3)
      c2(6)=c(4)*c(5)+c(2)*c(6)+c(6)*c(3)
!
!     f) calculating the right stretch tensor U
!        (cf. Simo and Hughes, Computational Inelasticity)
!
      dd=v1*v2-v3
      do i=1,6
         u(i)=(-c2(i)+(v1*v1-v2)*c(i)+v1*v3*d(i))/dd
      enddo
!
!     g) storing U as matrix (U=R^(-1).F)
!
      ur(1,1)=u(1)
      ur(2,2)=u(2)
      ur(3,3)=u(3)
      ur(1,2)=u(4)
      ur(1,3)=u(5)
      ur(2,3)=u(6)
      ur(2,1)=u(4)
      ur(3,1)=u(5)
      ur(3,2)=u(6)
c      write(*,*) 'umat_undo..ur',ur(1,1),ur(1,2),ur(1,3)
c      write(*,*) 'umat_undo..ur',ur(2,1),ur(2,2),ur(2,3)
c      write(*,*) 'umat_undo..ur',ur(3,1),ur(3,2),ur(3,3)
!
!     i) calculating the rotationless displacement gradient u_k,l
!        = (U-I)
!
      do i=1,3
         do j=1,3
            ukl(i,j)=ur(i,j)
         enddo
         ukl(i,i)=ukl(i,i)-1.d0
      enddo
!
!     j) calculating the total rotationless linearized strain
!        ((U-I)+(U-I)^T)/2
!
      do i=1,3
         do j=i,3
            elin(i,j)=(ukl(i,j)+ukl(j,i))/2.d0
         enddo
      enddo
c      write(*,*) 'umat_undo..elin',elin(1,1)
!
!     k) calculating the mechanical rotationless linearized strain =
!        total rotationless linearized strain -
!        (total Lagrange strain - mechanical Lagrange strain)
!
      emec(1)=elin(1,1)-eloc(1)+emec(1)
      emec(2)=elin(2,2)-eloc(2)+emec(2)
      emec(3)=elin(3,3)-eloc(3)+emec(3)
      emec(4)=elin(1,2)-eloc(4)+emec(4)
      emec(5)=elin(1,3)-eloc(5)+emec(5)
      emec(6)=elin(2,3)-eloc(6)+emec(6)
!
      eloc(1)=elin(1,1)
      eloc(2)=elin(2,2)
      eloc(3)=elin(3,3)
      eloc(4)=elin(1,2)
      eloc(5)=elin(1,3)
      eloc(6)=elin(2,3)
!
      do i=1,6
         write(*,*) 'umat...lin_el',time,iel,iint,eloc(i),stre(i)
      enddo
c      write(*,*) 'umat_undo..eloc',eloc(1)
!
!     calculating the stresses
!
      e=elconloc(1)
      un=elconloc(2)
      al=un*e/(1.d0+un)/(1.d0-2.d0*un)
      um=e/2.d0/(1.d0+un)
      am1=al+2.d0*um
      am2=2.d0*um
!
      stre(1)=am1*emec(1)+al*(emec(2)+emec(3))-beta(1)
      stre(2)=am1*emec(2)+al*(emec(1)+emec(3))-beta(2)
      stre(3)=am1*emec(3)+al*(emec(1)+emec(2))-beta(3)
      stre(4)=am2*emec(4)-beta(4)
      stre(5)=am2*emec(5)-beta(5)
      stre(6)=am2*emec(6)-beta(6)
c      write(*,*) 'umat_undo..stre',stre(1)
!
c      do i=1,6
c         write(*,*) 'umat...lin_el',time,iel,iint,eloc(i),stre(i)
c      enddo
!
      if(icmd.ne.3) then
!
!        calculating the stiffness matrix
!
         stiff(1)=al+2.d0*um
         stiff(2)=al
         stiff(3)=al+2.d0*um
         stiff(4)=al
         stiff(5)=al
         stiff(6)=al+2.d0*um
         stiff(7)=0.d0
         stiff(8)=0.d0
         stiff(9)=0.d0
         stiff(10)=um
         stiff(11)=0.d0
         stiff(12)=0.d0
         stiff(13)=0.d0
         stiff(14)=0.d0
         stiff(15)=um
         stiff(16)=0.d0
         stiff(17)=0.d0
         stiff(18)=0.d0
         stiff(19)=0.d0
         stiff(20)=0.d0
         stiff(21)=um
      endif
!
      return
      end


SUBROUTINE CALC_K0Y1Y2(M, N, K0, y1, y2, a, b, r, ABD, &
                       u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                       v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry, &
                       w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: M, N
    REAL*8, INTENT(IN) :: y1, y2, a, b, r
    REAL*8, INTENT(IN) :: ABD(6, 6)
    REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
    REAL*8, INTENT(IN) :: v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry
    REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8, INTENT(OUT) :: K0(3*M*N, 3*M*N)

    INTEGER row, col, i, j, k, l
    REAL*8 A11, A12, A16, A22, A26, A66
    REAL*8 B11, B12, B16, B22, B26, B66
    REAL*8 D11, D12, D16, D22, D26, D66
    REAL*8 eta1, eta2

    REAL*8 fAufBu, fAufBuxi, fAuxifBu, fAuxifBuxi, fAufBv, fAufBvxi
    REAL*8 fAuxifBv, fAuxifBvxi, fAuxifBwxixi, fAuxifBw, fAufBwxixi
    REAL*8 fAuxifBwxi, fAufBw, fAufBwxi, fAvfBuxi, fAvxifBuxi, fAvfBu
    REAL*8 fAvxifBu, fAvfBv, fAvfBvxi, fAvxifBv, fAvxifBvxi, fAvfBwxixi
    REAL*8 fAvxifBwxixi, fAvfBw, fAvfBwxi, fAvxifBw, fAvxifBwxi
    REAL*8 fAwxixifBuxi, fAwfBuxi, fAwxifBuxi, fAwxixifBu, fAwfBu
    REAL*8 fAwxifBu, fAwxixifBv, fAwxixifBvxi, fAwfBv, fAwfBvxi, fAwxifBv
    REAL*8 fAwxifBvxi, fAwxixifBwxixi, fAwfBwxixi, fAwxixifBw
    REAL*8 fAwxifBwxixi, fAwxixifBwxi, fAwfBw, fAwfBwxi, fAwxifBw
    REAL*8 fAwxifBwxi
    REAL*8 gAugBu, gAugBueta, gAuetagBu, gAuetagBueta, gAugBv, gAugBveta
    REAL*8 gAuetagBv, gAuetagBveta, gAuetagBwetaeta, gAuetagBw
    REAL*8 gAugBwetaeta, gAuetagBweta, gAugBw, gAugBweta, gAvgBueta
    REAL*8 gAvetagBueta, gAvgBu, gAvetagBu, gAvgBv, gAvgBveta, gAvetagBv
    REAL*8 gAvetagBveta, gAvgBwetaeta, gAvetagBwetaeta, gAvgBw, gAvgBweta
    REAL*8 gAvetagBw, gAvetagBweta, gAwetaetagBueta, gAwgBueta
    REAL*8 gAwetagBueta, gAwetaetagBu, gAwgBu, gAwetagBu, gAwetaetagBv
    REAL*8 gAwetaetagBveta, gAwgBv, gAwgBveta, gAwetagBv, gAwetagBveta
    REAL*8 gAwetaetagBwetaeta, gAwgBwetaeta, gAwetaetagBw
    REAL*8 gAwetagBwetaeta, gAwetaetagBweta, gAwgBw, gAwgBweta, gAwetagBw
    REAL*8 gAwetagBweta

    A11 = ABD(1, 1)
    A12 = ABD(1, 2)
    A16 = ABD(1, 3)
    A22 = ABD(2, 2)
    A26 = ABD(2, 3)
    A66 = ABD(3, 3)

    B11 = ABD(1, 4)
    B12 = ABD(1, 5)
    B16 = ABD(1, 6)
    B22 = ABD(2, 5)
    B26 = ABD(2, 6)
    B66 = ABD(3, 6)

    D11 = ABD(4, 4)
    D12 = ABD(4, 5)
    D16 = ABD(4, 6)
    D22 = ABD(5, 5)
    D26 = ABD(5, 6)
    D66 = ABD(6, 6)

    eta1 = 2*y1/b - 1.
    eta2 = 2*y2/b - 1.

    DO j=1, N
        DO l=1, N

            CALL integral_ff_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, u1ty, u1ry, u2ty, u2ry, gAugBu)
            CALL integral_ffxi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, u1ty, u1ry, u2ty, u2ry, gAugBueta)
            CALL integral_ffxi_12(eta1, eta2, l, j, u1ty, u1ry, u2ty, u2ry, u1ty, u1ry, u2ty, u2ry, gAuetagBu)
            CALL integral_fxifxi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, u1ty, u1ry, u2ty, u2ry, gAuetagBueta)
            CALL integral_ff_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, v1ty, v1ry, v2ty, v2ry, gAugBv)
            CALL integral_ffxi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, v1ty, v1ry, v2ty, v2ry, gAugBveta)
            CALL integral_ffxi_12(eta1, eta2, l, j, v1ty, v1ry, v2ty, v2ry, u1ty, u1ry, u2ty, u2ry, gAuetagBv)
            CALL integral_fxifxi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, v1ty, v1ry, v2ty, v2ry, gAuetagBveta)
            CALL integral_fxifxixi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAuetagBwetaeta)
            CALL integral_ffxi_12(eta1, eta2, l, j, w1ty, w1ry, w2ty, w2ry, u1ty, u1ry, u2ty, u2ry, gAuetagBw)
            CALL integral_ffxixi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAugBwetaeta)
            CALL integral_fxifxi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAuetagBweta)
            CALL integral_ff_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAugBw)
            CALL integral_ffxi_12(eta1, eta2, j, l, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAugBweta)
            CALL integral_ffxi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, u1ty, u1ry, u2ty, u2ry, gAvgBueta)
            CALL integral_fxifxi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, u1ty, u1ry, u2ty, u2ry, gAvetagBueta)
            CALL integral_ff_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, u1ty, u1ry, u2ty, u2ry, gAvgBu)
            CALL integral_ffxi_12(eta1, eta2, l, j, u1ty, u1ry, u2ty, u2ry, v1ty, v1ry, v2ty, v2ry, gAvetagBu)
            CALL integral_ff_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, v1ty, v1ry, v2ty, v2ry, gAvgBv)
            CALL integral_ffxi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, v1ty, v1ry, v2ty, v2ry, gAvgBveta)
            CALL integral_ffxi_12(eta1, eta2, l, j, v1ty, v1ry, v2ty, v2ry, v1ty, v1ry, v2ty, v2ry, gAvetagBv)
            CALL integral_fxifxi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, v1ty, v1ry, v2ty, v2ry, gAvetagBveta)
            CALL integral_ffxixi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAvgBwetaeta)
            CALL integral_fxifxixi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAvetagBwetaeta)
            CALL integral_ff_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAvgBw)
            CALL integral_ffxi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAvgBweta)
            CALL integral_ffxi_12(eta1, eta2, l, j, w1ty, w1ry, w2ty, w2ry, v1ty, v1ry, v2ty, v2ry, gAvetagBw)
            CALL integral_fxifxi_12(eta1, eta2, j, l, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAvetagBweta)
            CALL integral_fxifxixi_12(eta1, eta2, l, j, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBueta)
            CALL integral_ffxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, u1ty, u1ry, u2ty, u2ry, gAwgBueta)
            CALL integral_fxifxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, u1ty, u1ry, u2ty, u2ry, gAwetagBueta)
            CALL integral_ffxixi_12(eta1, eta2, l, j, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBu)
            CALL integral_ff_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, u1ty, u1ry, u2ty, u2ry, gAwgBu)
            CALL integral_ffxi_12(eta1, eta2, l, j, u1ty, u1ry, u2ty, u2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBu)
            CALL integral_ffxixi_12(eta1, eta2, l, j, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBv)
            CALL integral_fxifxixi_12(eta1, eta2, l, j, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBveta)
            CALL integral_ff_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, v1ty, v1ry, v2ty, v2ry, gAwgBv)
            CALL integral_ffxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, v1ty, v1ry, v2ty, v2ry, gAwgBveta)
            CALL integral_ffxi_12(eta1, eta2, l, j, v1ty, v1ry, v2ty, v2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBv)
            CALL integral_fxifxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, v1ty, v1ry, v2ty, v2ry, gAwetagBveta)
            CALL integral_fxixifxixi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBwetaeta)
            CALL integral_ffxixi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBwetaeta)
            CALL integral_ffxixi_12(eta1, eta2, l, j, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBw)
            CALL integral_fxifxixi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBwetaeta)
            CALL integral_fxifxixi_12(eta1, eta2, l, j, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBweta)
            CALL integral_ff_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBw)
            CALL integral_ffxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBweta)
            CALL integral_ffxi_12(eta1, eta2, l, j, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBw)
            CALL integral_fxifxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBweta)

            DO i=1, M
                DO k=1, M

                    row = 3*((j-1)*M + (i-1)) + 1
                    col = 3*((l-1)*M + (k-1)) + 1

                    IF (row > col) THEN
                        CYCLE
                    END IF

                    CALL integral_ff(i, k, u1tx, u1rx, u2tx, u2rx, u1tx, u1rx, u2tx, u2rx, fAufBu)
                    CALL integral_ffxi(i, k, u1tx, u1rx, u2tx, u2rx, u1tx, u1rx, u2tx, u2rx, fAufBuxi)
                    CALL integral_ffxi(k, i, u1tx, u1rx, u2tx, u2rx, u1tx, u1rx, u2tx, u2rx, fAuxifBu)
                    CALL integral_fxifxi(i, k, u1tx, u1rx, u2tx, u2rx, u1tx, u1rx, u2tx, u2rx, fAuxifBuxi)
                    CALL integral_ff(i, k, u1tx, u1rx, u2tx, u2rx, v1tx, v1rx, v2tx, v2rx, fAufBv)
                    CALL integral_ffxi(i, k, u1tx, u1rx, u2tx, u2rx, v1tx, v1rx, v2tx, v2rx, fAufBvxi)
                    CALL integral_ffxi(k, i, v1tx, v1rx, v2tx, v2rx, u1tx, u1rx, u2tx, u2rx, fAuxifBv)
                    CALL integral_fxifxi(i, k, u1tx, u1rx, u2tx, u2rx, v1tx, v1rx, v2tx, v2rx, fAuxifBvxi)
                    CALL integral_fxifxixi(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAuxifBwxixi)
                    CALL integral_ffxi(k, i, w1tx, w1rx, w2tx, w2rx, u1tx, u1rx, u2tx, u2rx, fAuxifBw)
                    CALL integral_ffxixi(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAufBwxixi)
                    CALL integral_fxifxi(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAuxifBwxi)
                    CALL integral_ff(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAufBw)
                    CALL integral_ffxi(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAufBwxi)
                    CALL integral_ffxi(i, k, v1tx, v1rx, v2tx, v2rx, u1tx, u1rx, u2tx, u2rx, fAvfBuxi)
                    CALL integral_fxifxi(i, k, v1tx, v1rx, v2tx, v2rx, u1tx, u1rx, u2tx, u2rx, fAvxifBuxi)
                    CALL integral_ff(i, k, v1tx, v1rx, v2tx, v2rx, u1tx, u1rx, u2tx, u2rx, fAvfBu)
                    CALL integral_ffxi(k, i, u1tx, u1rx, u2tx, u2rx, v1tx, v1rx, v2tx, v2rx, fAvxifBu)
                    CALL integral_ff(i, k, v1tx, v1rx, v2tx, v2rx, v1tx, v1rx, v2tx, v2rx, fAvfBv)
                    CALL integral_ffxi(i, k, v1tx, v1rx, v2tx, v2rx, v1tx, v1rx, v2tx, v2rx, fAvfBvxi)
                    CALL integral_ffxi(k, i, v1tx, v1rx, v2tx, v2rx, v1tx, v1rx, v2tx, v2rx, fAvxifBv)
                    CALL integral_fxifxi(i, k, v1tx, v1rx, v2tx, v2rx, v1tx, v1rx, v2tx, v2rx, fAvxifBvxi)
                    CALL integral_ffxixi(i, k, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAvfBwxixi)
                    CALL integral_fxifxixi(i, k, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAvxifBwxixi)
                    CALL integral_ff(i, k, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAvfBw)
                    CALL integral_ffxi(i, k, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAvfBwxi)
                    CALL integral_ffxi(k, i, w1tx, w1rx, w2tx, w2rx, v1tx, v1rx, v2tx, v2rx, fAvxifBw)
                    CALL integral_fxifxi(i, k, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAvxifBwxi)
                    CALL integral_fxifxixi(k, i, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBuxi)
                    CALL integral_ffxi(i, k, w1tx, w1rx, w2tx, w2rx, u1tx, u1rx, u2tx, u2rx, fAwfBuxi)
                    CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, u1tx, u1rx, u2tx, u2rx, fAwxifBuxi)
                    CALL integral_ffxixi(k, i, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBu)
                    CALL integral_ff(i, k, w1tx, w1rx, w2tx, w2rx, u1tx, u1rx, u2tx, u2rx, fAwfBu)
                    CALL integral_ffxi(k, i, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBu)
                    CALL integral_ffxixi(k, i, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBv)
                    CALL integral_fxifxixi(k, i, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBvxi)
                    CALL integral_ff(i, k, w1tx, w1rx, w2tx, w2rx, v1tx, v1rx, v2tx, v2rx, fAwfBv)
                    CALL integral_ffxi(i, k, w1tx, w1rx, w2tx, w2rx, v1tx, v1rx, v2tx, v2rx, fAwfBvxi)
                    CALL integral_ffxi(k, i, v1tx, v1rx, v2tx, v2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBv)
                    CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, v1tx, v1rx, v2tx, v2rx, fAwxifBvxi)
                    CALL integral_fxixifxixi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBwxixi)
                    CALL integral_ffxixi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBwxixi)
                    CALL integral_ffxixi(k, i, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBw)
                    CALL integral_fxifxixi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxixi)
                    CALL integral_fxifxixi(k, i, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBwxi)
                    CALL integral_ff(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBw)
                    CALL integral_ffxi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBwxi)
                    CALL integral_ffxi(k, i, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBw)
                    CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxi)

                    K0(row+0, col+0) = K0(row+0, col+0) + A11*b*fAuxifBuxi*gAugBu/a + A16*(fAufBuxi*gAuetagBu + fAuxifBu*gAugBueta) + A66*a*fAufBu*gAuetagBueta/b
                    K0(row+0, col+1) = K0(row+0, col+1) + A12*fAuxifBv*gAugBveta + A16*b*fAuxifBvxi*gAugBv/a + A26*a*fAufBv*gAuetagBveta/b + A66*fAufBvxi*gAuetagBv
                    K0(row+0, col+2) = K0(row+0, col+2) + 0.5*A12*b*fAuxifBw*gAugBw/r + 0.5*A26*a*fAufBw*gAuetagBw/r - 2*B11*b*fAuxifBwxixi*gAugBw/(a*a) - 2*B12*fAuxifBw*gAugBwetaeta/b - 2*B16*(fAufBwxixi*gAuetagBw + 2*fAuxifBwxi*gAugBweta)/a - 2*B26*a*fAufBw*gAuetagBwetaeta/(b*b) - 4*B66*fAufBwxi*gAuetagBweta/b
                    K0(row+1, col+0) = K0(row+1, col+0) + A12*fAvfBuxi*gAvetagBu + A16*b*fAvxifBuxi*gAvgBu/a + A26*a*fAvfBu*gAvetagBueta/b + A66*fAvxifBu*gAvgBueta
                    K0(row+1, col+1) = K0(row+1, col+1) + A22*a*fAvfBv*gAvetagBveta/b + A26*(fAvfBvxi*gAvetagBv + fAvxifBv*gAvgBveta) + A66*b*fAvxifBvxi*gAvgBv/a
                    K0(row+1, col+2) = K0(row+1, col+2) + 0.5*A22*a*fAvfBw*gAvetagBw/r + 0.5*A26*b*fAvxifBw*gAvgBw/r - 2*B12*fAvfBwxixi*gAvetagBw/a - 2*B16*b*fAvxifBwxixi*gAvgBw/(a*a) - 2*B22*a*fAvfBw*gAvetagBwetaeta/(b*b) - 2*B26*(2*fAvfBwxi*gAvetagBweta + fAvxifBw*gAvgBwetaeta)/b - 4*B66*fAvxifBwxi*gAvgBweta/a
                    K0(row+2, col+0) = K0(row+2, col+0) + 0.5*A12*b*fAwfBuxi*gAwgBu/r + 0.5*A26*a*fAwfBu*gAwgBueta/r - 2*B11*b*fAwxixifBuxi*gAwgBu/(a*a) - 2*B12*fAwfBuxi*gAwetaetagBu/b - 2*B16*(2*fAwxifBuxi*gAwetagBu + fAwxixifBu*gAwgBueta)/a - 2*B26*a*fAwfBu*gAwetaetagBueta/(b*b) - 4*B66*fAwxifBu*gAwetagBueta/b
                    K0(row+2, col+1) = K0(row+2, col+1) + 0.5*A22*a*fAwfBv*gAwgBveta/r + 0.5*A26*b*fAwfBvxi*gAwgBv/r - 2*B12*fAwxixifBv*gAwgBveta/a - 2*B16*b*fAwxixifBvxi*gAwgBv/(a*a) - 2*B22*a*fAwfBv*gAwetaetagBveta/(b*b) - 2*B26*(fAwfBvxi*gAwetaetagBv + 2*fAwxifBv*gAwetagBveta)/b - 4*B66*fAwxifBvxi*gAwetagBv/a
                    K0(row+2, col+2) = K0(row+2, col+2) + 0.25*A22*a*b*fAwfBw*gAwgBw/(r*r) - B12*b*gAwgBw*(fAwfBwxixi + fAwxixifBw)/(a*r) - B22*a*fAwfBw*(gAwgBwetaeta + gAwetaetagBw)/(b*r) - 2*B26*(fAwfBwxi*gAwgBweta + fAwxifBw*gAwetagBw)/r + 4*D11*b*fAwxixifBwxixi*gAwgBw/(a*a*a) + 4*D12*(fAwfBwxixi*gAwetaetagBw + fAwxixifBw*gAwgBwetaeta)/(a*b) + 8*D16*(fAwxifBwxixi*gAwetagBw + fAwxixifBwxi*gAwgBweta)/(a*a) + 4*D22*a*fAwfBw*gAwetaetagBwetaeta/(b*b*b) + 8*D26*(fAwfBwxi*gAwetaetagBweta + fAwxifBw*gAwetagBwetaeta)/(b*b) + 16*D66*fAwxifBwxi*gAwetagBweta/(a*b)

                END DO
            END DO
        END DO
    END DO
END SUBROUTINE

SUBROUTINE CALC_KG0Y1Y2(M, N, KG0, y1, y2, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: M, N
    REAL*8, INTENT(IN) :: y1, y2, a, b, Nxx, Nyy, Nxy
    REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8, INTENT(OUT) :: KG0(3*M*N, 3*M*N)

    INTEGER row, col, i, j, k, l
    REAL*8 eta1, eta2

    REAL*8 fAwfBw, fAwfBwxi, fAwxifBw, fAwxifBwxi
    REAL*8 gAwgBw, gAwgBweta, gAwetagBw, gAwetagBweta

    eta1 = 2*y1/b - 1.
    eta2 = 2*y2/b - 1.

    DO j=1, N
        DO l=1, N

            CALL integral_ff_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBw)
            CALL integral_ffxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBweta)
            CALL integral_ffxi_12(eta1, eta2, l, j, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBw)
            CALL integral_fxifxi_12(eta1, eta2, j, l, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBweta)

            DO i=1, M
                DO k=1, M

                    row = 3*((j-1)*M + (i-1)) + 1
                    col = 3*((l-1)*M + (k-1)) + 1

                    IF (row > col) THEN
                        CYCLE
                    END IF

                    CALL integral_ff(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBw)
                    CALL integral_ffxi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBwxi)
                    CALL integral_ffxi(k, i, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBw)
                    CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxi)

                    KG0(row+2, col+2) = KG0(row+2, col+2) + Nxx*b*fAwxifBwxi*gAwgBw/a + Nxy*(fAwfBwxi*gAwetagBw + fAwxifBw*gAwgBweta) + Nyy*a*fAwfBw*gAwetagBweta/b

                END DO
            END DO
        END DO
    END DO
END SUBROUTINE

SUBROUTINE CALC_K0F(M, N, K0F, ys, a, b, bf, df, &
                    E1, F1, S1, Jxx, &
                    u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                    w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: M, N
    REAL*8, INTENT(IN) :: ys, a, b, bf, df
    REAL*8, INTENT(IN) :: E1, F1, S1, Jxx
    REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
    REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8, INTENT(OUT) :: K0F(3*M*N, 3*M*N)

    INTEGER row, col, i, j, k, l

    REAL*8 fAuxifBuxi, fAuxifBwxixi, fAuxifBwxi, fAwxixifBuxi
    REAL*8 fAwxifBuxi, fAwxifBwxi, fAwxifBwxixi, fAwxixifBwxi
    REAL*8 fAwxixifBwxixi
    REAL*8 gAu, gBu, gAw, gBw, gAweta, gBweta
    REAL*8 eta

    eta = 2*ys/b - 1.

    DO i=1, M
        DO k=1, M

            CALL integral_fxifxi(i, k, u1tx, u1rx, u2tx, u2rx, u1tx, u1rx, u2tx, u2rx, fAuxifBuxi)
            CALL integral_fxifxixi(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAuxifBwxixi)
            CALL integral_fxifxi(i, k, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAuxifBwxi)
            CALL integral_fxifxixi(k, i, u1tx, u1rx, u2tx, u2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBuxi)
            CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, u1tx, u1rx, u2tx, u2rx, fAwxifBuxi)
            CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxi)
            CALL integral_fxifxixi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxixi)
            CALL integral_fxifxixi(k, i, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBwxi)
            CALL integral_fxixifxixi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBwxixi)

            DO j=1, N

                CALL calc_f(j, eta, u1ty, u1ry, u2ty, u2ry, gAu)
                CALL calc_f(j, eta, w1ty, w1ry, w2ty, w2ry, gAw)
                CALL calc_fxi(j, eta, w1ty, w1ry, w2ty, w2ry, gAweta)

                DO l=1, N

                    row = 3*((j-1)*M + (i-1)) + 1
                    col = 3*((l-1)*M + (k-1)) + 1

                    IF (row > col) THEN
                        CYCLE
                    END IF

                    CALL calc_f(l, eta, u1ty, u1ry, u2ty, u2ry, gBu)
                    CALL calc_f(l, eta, w1ty, w1ry, w2ty, w2ry, gBw)
                    CALL calc_fxi(l, eta, w1ty, w1ry, w2ty, w2ry, gBweta)

                    K0F(row+0, col+0) = K0F(row+0, col+0) + 2*E1*bf*fAuxifBuxi*gAu*gBu/a
                    K0F(row+0, col+2) = K0F(row+0, col+2) + 0.5*a*bf*(8*E1*df*fAuxifBwxixi*gAu*gBw/(a*a*a) - 8*S1*fAuxifBwxi*gAu*gBweta/((a*a)*b))
                    K0F(row+2, col+0) = K0F(row+2, col+0) + bf*gBu*(4*E1*df*fAwxixifBuxi*gAw/(a*a) - 4*S1*fAwxifBuxi*gAweta/(a*b))
                    K0F(row+2, col+2) = K0F(row+2, col+2) + 0.5*a*bf*(-4*gBweta*(-4*Jxx*fAwxifBwxi*gAweta/(a*b) + 4*S1*df*fAwxixifBwxi*gAw/(a*a))/(a*b) - 4*gBw*(4*S1*df*fAwxifBwxixi*gAweta/(a*b) + fAwxixifBwxixi*gAw*(-4*E1*(df*df) - 4*F1)/(a*a))/(a*a))

                END DO
            END DO
        END DO
    END DO
END SUBROUTINE

SUBROUTINE CALC_KG0F(M, N, KG0F, ys, Fx, a, b, bf, df, &
                     u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                     w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: M, N
    REAL*8, INTENT(IN) :: ys, Fx, a, b, bf, df
    REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
    REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8, INTENT(OUT) :: KG0F(3*M*N, 3*M*N)

    INTEGER row, col, i, j, k, l

    REAL*8 fAwxifBwxi, gAw, gBw
    REAL*8 eta

    eta = 2*ys/b - 1.

    DO i=1, M
        DO k=1, M

            CALL integral_fxifxi(i, k, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxi)

            DO j=1, N

                CALL calc_f(j, eta, w1ty, w1ry, w2ty, w2ry, gAw)

                DO l=1, N

                    row = 3*((j-1)*M + (i-1)) + 1
                    col = 3*((l-1)*M + (k-1)) + 1

                    IF (row > col) THEN
                        CYCLE
                    END IF

                    CALL calc_f(l, eta, w1ty, w1ry, w2ty, w2ry, gBw)

                    KG0F(row+2, col+2) = KG0F(row+2, col+2) + 2*Fx*fAwxifBwxi*gAw*gBw/a

                END DO
            END DO
        END DO
    END DO
END SUBROUTINE


      subroutine block_a(x,p1,p2,p3,p4,r1,r2,r3)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This block corresponds to the reduced diagram
c
c            *P4     *P3    * P2
c           *      *       *
c     *********************
c     MV_r3  MV_r2  MV_r1  *
c                           * P1 (missing)
c
c     the whole momentum p1 is fixed to reproduce MV_r1, MV_r2, MV_r3
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
      include '../../../SubProcesses/phasespace.inc'
c
c     argument
c
      integer p1,p2,p3,p4,r1,r2,r3
c
c     local
c
      INTEGER IDUM
      DATA IDUM/0/
      SAVE IDUM
      double precision jac_loc
      double precision b,c,rho,sign_root,jac_factor,dem
      double precision p1x_ti,p1x_E1,p1y_ti,p1y_E1,p1z_ti,p1z_E1
      double precision invjac
      real rand
      double precision p1x,p1y,p1z,p2x,p2y,p2z,p3x,p3y,p3z,p4x,p4y,p4z
      double precision E1,E2,E3,E4
      double precision Ma(3),Mc(3),MinvB(3,3),detB
      integer nu
      double precision x(20)
c
c     global
c
      double precision momenta(0:3,-max_branches:2*max_particles)  ! records the momenta of external/intermediate legs     (MG order)
      double precision mvir2(-max_branches:2*max_particles)        ! records the sq invariant masses of intermediate particles (MG order)
      common /to_diagram_kin/ momenta, mvir2
      double precision Etot,pztot,misspx,misspy
      common /to_missingP/Etot,pztot,misspx,misspy
      double precision              S,X1,X2,PSWGT,JAC
      common /PHASESPACE/ S,X1,X2,PSWGT,JAC
c
c     external
c
      double precision pt, phi,dot
      external pt,phi,dot
      REAL XRAN1
      EXTERNAL XRAN1
c---
c Begin code
c---
c
c      write(*,*) 'P2', (momenta(nu,p2),nu=0,3)
c      write(*,*) 'P3', (momenta(nu,p3),nu=0,3)
c      write(*,*) 'P4', (momenta(nu,p4),nu=0,3)
c      write(*,*) 'mvir2',r1,mvir2(r1)
c      write(*,*) 'mvir2',r2,mvir2(r2)
c      write(*,*) 'mvir2',r3,mvir2(r3)
c      write(*,*) 'mvir2 -4',mvir2(-4)
c      pause
      p2x=momenta(1,p2)
      p3x=momenta(1,p3)
      p4x=momenta(1,p4)
      p2y=momenta(2,p2)
      p3y=momenta(2,p3)
      p4y=momenta(2,p4)
      p2z=momenta(3,p2)
      p3z=momenta(3,p3)
      p4z=momenta(3,p4)
      E2=momenta(0,p2)
      E3=momenta(0,p3)
      E4=momenta(0,p4)

c     Express the change of variables as
c       | a1 |   | b11 b12 b13| | P1x |   | C1 |
c       | a2 | = | b21 b22 b23| | P1y | + | C2 | E1
c       | a3 |   | b31 b32 b33| | P1z | + | C3 |

      Ma(1)=mvir2(r1)-mvir2(p1)-mvir2(p2)
      Ma(2)=mvir2(r2)-mvir2(r1)-mvir2(p3)
     & -2d0*dot(momenta(0,p2),momenta(0,p3))
      Ma(3)=mvir2(r3)-mvir2(r2)-mvir2(p4)
     & -2d0*dot(momenta(0,p2),momenta(0,p4))
     & -2d0*dot(momenta(0,p3),momenta(0,p4))
c
      detB=8d0*(p2z*p3y*p4x-p2y*p3z*p4x-p2z*p3x*p4y+p2x*p3z*p4y
     & + p2y*p3x*p4z - p2x*p3y*p4z)
c
      MinvB(1,1)=(-4d0*p3z*p4y + 4d0*p3y*p4z)/detB
      MinvB(1,2)=(4d0*p2z*p4y - 4d0*p2y*p4z)/detB
      MinvB(1,3)=(-4d0*p2z*p3y + 4d0*p2y*p3z)/detB
      MinvB(2,1)=(4d0*p3z*p4x - 4d0*p3x*p4z)/detB
      MinvB(2,2)=(-4d0*p2z*p4x + 4d0*p2x*p4z)/detB
      MinvB(2,3)=(4d0*p2z*p3x - 4d0*p2x*p3z)/detB
      MinvB(3,1)=(-4d0*p3y*p4x + 4d0*p3x*p4y)/detB
      MinvB(3,2)=(4d0*p2y*p4x - 4d0*p2x*p4y)/detB
      MinvB(3,3)=(-4d0*p2y*p3x + 4d0*p2x*p3y)/detB
c
      Mc(1)=2d0*momenta(0,p2)
      Mc(2)=2d0*momenta(0,p3)
      Mc(3)=2d0*momenta(0,p4)
c
c     Inverse the system
c       | p1x |   | p1x_ti+p1x_E1*E1 |
c       | p1y | = | p1y_ti+p1y_E1*E1 |
c       | p1z |   | p1z_ti+p1z_E1*E1 |
c
      P1x_ti=MinvB(1,1)*Ma(1)+MinvB(1,2)*Ma(2)+MinvB(1,3)*Ma(3)
      P1y_ti=MinvB(2,1)*Ma(1)+MinvB(2,2)*Ma(2)+MinvB(2,3)*Ma(3)
      P1z_ti=MinvB(3,1)*Ma(1)+MinvB(3,2)*Ma(2)+MinvB(3,3)*Ma(3)
c
      p1x_E1=-MinvB(1,1)*Mc(1)-MinvB(1,2)*Mc(2)-MinvB(1,3)*Mc(3)
      p1y_E1=-MinvB(2,1)*Mc(1)-MinvB(2,2)*Mc(2)-MinvB(2,3)*Mc(3)
      p1z_E1=-MinvB(3,1)*Mc(1)-MinvB(3,2)*Mc(2)-MinvB(3,3)*Mc(3)
c
c     solve the mass shell equation
c
c     E1^2-|P1|^2=m_1^2   <=>   E1^2-b*E1+c=0
c
      jac_factor=1d0
      dem=1d0-P1x_E1**2-P1y_E1**2-P1z_E1**2

      if (dabs(dem).lt.0.0001d0) then
        momenta(0,p1)=-(P1x_ti**2+P1y_ti**2+P1z_ti**2+mvir2(p1))/
     &  (2d0*P1x_ti*P1x_E1+2d0*P1y_ti*P1y_E1+2d0*P1z_ti*P1z_E1)
        if  (momenta(0,p1).lt.0d0) then
          jac=-1d0
          return
        endif
        jac_factor=1d0
      else
        b=-(2d0*P1x_ti*P1x_E1+2d0*P1y_ti*P1y_E1+2d0*P1z_ti*P1z_E1)/dem
        c=-(P1x_ti**2+P1y_ti**2+P1z_ti**2+mvir2(p1))/dem
        rho=b**2-4d0*c

        if (rho.eq.0d0.and.b.lt.0d0) then   ! 1 sol
          momenta(0,p1)=-b/2d0
          jac_factor=1d0
        elseif (rho.gt.b**2)then ! 1 sol
          momenta(0,p1)=(-b+dsqrt(rho))/2d0
          jac_factor=1d0
        elseif (rho.gt.0d0.and.dsqrt(rho).lt.(-b)) then   ! 2 sol
          sign_root=1d0
c          call ntuple(rand,0.0,1.0,p1)
           rand=xran1(IDUM)
          if (rand.gt.0.5) sign_root=-1.0d0
          momenta(0,p1)=(-b+sign_root*dsqrt(rho))/2d0
          jac_factor=2d0
        else                                ! 0 sol
          momenta(0,p1)=-1d0
          jac=-1d0
          return
        endif
      endif
c
c     fill the momentum p1
c
      E1=momenta(0,p1)
      momenta(1,p1)=p1x_ti+p1x_E1*E1
      momenta(2,p1)=p1y_ti+p1y_E1*E1
      momenta(3,p1)=p1z_ti+p1z_E1*E1
      p1x=momenta(1,p1)
      p1y=momenta(2,p1)
      p1z=momenta(3,p1)
c      normP1sq=p1x**2+p1y**2+p1z**2
c      sin_theta_miss=dsqrt(1d0-(p1x**2+p1y**2)/normP1sq)
c
c     fill the momenta r1,r2,r3
c
      do nu=0,3
      momenta(nu,r1)=momenta(nu,p1)+momenta(nu,p2)
      momenta(nu,r2)=momenta(nu,r1)+momenta(nu,p3)
      momenta(nu,r3)=momenta(nu,r2)+momenta(nu,p4)
      enddo
c
c     compute missing momentum
c
       misspx=misspx-momenta(1,p1)
       misspy=misspy-momenta(2,p1)
       Etot=Etot+momenta(0,p1)
       pztot=pztot+momenta(3,p1)
c
c     compute the jacobian:
c
c      jac_loc=jac_loc*sin_theta_miss*normP1sq       ! PS weight for the initial set of variable
                   !  the factor 2*E1 has been removed since it factorizes with the factor 2E1 in the PS param.
c
      invjac=-16*(E4*(p1z*p2y*p3x - p1y*p2z*p3x -
     -        p1z*p2x*p3y + p1x*p2z*p3y + p1y*p2x*p3z - p1x*p2y*p3z)
     -      + E2*p1z*p3y*p4x - E1*p2z*p3y*p4x - E2*p1y*p3z*p4x +
     -     E1*p2y*p3z*p4x - E2*p1z*p3x*p4y + E1*p2z*p3x*p4y +
     -     E2*p1x*p3z*p4y - E1*p2x*p3z*p4y +
     -     (E2*p1y*p3x - E1*p2y*p3x - E2*p1x*p3y + E1*p2x*p3y)*p4z +
     -     E3*(-(p1z*p2y*p4x) + p1y*p2z*p4x + p1z*p2x*p4y -
     -        p1x*p2z*p4y - p1y*p2x*p4z + p1x*p2y*p4z))

      jac_loc=jac_factor/dabs(invjac)
      jac=jac*jac_loc

      return
      end


    program demo_count
    implicit none
    integer, dimension(2,3) :: a, b
    logical, dimension(2,3) :: mymask
          a = reshape( [ 1, 2, 3, 4, 5, 6 ], [ 2, 3 ])
          b = reshape( [ 0, 7, 3, 4, 5, 8 ], [ 2, 3 ])
          print '(3i3)', a(1,:)
          print '(3i3)', a(2,:)
          print *
          print '(3i3)', b(1,:)
          print '(3i3)', b(2,:)
          print *
          mymask = a.ne.b
          print '(3l3)', mymask(1,:)
          print '(3l3)', mymask(2,:)
          print *
          print '(3i3)', count(mymask)
          print *
          print '(3i3)', count(mymask, 1)
          print *
          print '(3i3)', count(mymask, 2)
    end program demo_count


      module moduleExample_1_mod
      implicit none
!
!     Here are subroutines and functions for my program.
!
      CONTAINS
!
      subroutine print_matrix(matrix)
!
!     This subroutine prints a square matrix whose dimension is less than 6.
!
      implicit none
      real,dimension(:,:),intent(in)::matrix
      integer::i
!
!     Print the matrix.
!
 1000 Format(f10.5,4x,f10.5,4x,f10.5,4x,f10.5,4x,f10.5,4x,f10.5)
      do i = 1,Size(matrix,1)
        write(*,1000) matrix(i,:)
      endDo
!
      return
      end subroutine print_matrix
!
      end module moduleExample_1_mod

      program moduleExample_1
!
!     This is an example program demonstrating some uses of modules.
!
      USE moduleExample_1_mod
      implicit none
      real,dimension(5,5)::matrixA,matrixB,matrixC
!
!     Fill matrixA and matrixB with random numbers.
!
      call random_number(matrixA)
      call random_number(matrixB)
      write(*,*)' Matrix A:'
      write(*,*) matrixA
      write(*,*)' Here is Matrix A:'
      call print_matrix(matrixA)
      write(*,*)' Here is Matrix B:'
      call print_matrix(matrixB)
!
      end program moduleExample_1


c     program DRSFRENL
c>> 2001-05-25 DRSFRENL Krogh -- Added comma to format.
c>> 1996-06-18 DRSFRENL Krogh Minor changes in formats for C conversion.
c>> 1996-01-29 DRSFRENL WV Snyder Corrected formats
c>> 1994-10-19 DRSFRENL Krogh  Changes to use M77CON
c>> 1993-02-25 DRSFRENL CLL. Minor edits.  Deleted Format statements.
c>> 1992-03-18 DRSFRENL WV Snyder Corrected failure to call SFRENS
c>> 1992-03-18 DRSFRENL CLL Minor edits.
c>> 1992-02-03 DRSFRENL WV Snyder JPL Original code.
c
c     Demonstration driver for Fresnel Integrals functions.
c
c     ------------------------------------------------------------------
c--S replaces "?": DR?FRENL, ?FRENC, ?FRENS, ?FRENG, ?FRENF
c     ------------------------------------------------------------------
      real             X, YC, YF, YG, YS
      real             SFRENC, SFRENF, SFRENG, SFRENS
      external SFRENC, SFRENF, SFRENG, SFRENS
      integer I
c
      print '(11x,''X'',9x,''C(x)'',11x,''S(x)'',11x,''g(x)'',11x,
     *   ''f(x)'')'
      do 30 I = -12, 12
         X = 0.5 * I
         YC = SFRENC(X)
         YS = SFRENS(X)
         YG = SFRENG(X)
         YF = SFRENF(X)
         print '(1p,5e15.07)', X, YC, YS, YG, YF
30    continue
      stop
      end


!***************************************************************
!*          Sorting an array with the Shell method             *
!* ----------------------------------------------------------- *
!* REFERENCE:                                                  *
!*      "NUMERICAL RECIPES by W.H. Press, B.P. Flannery,       *
!*       S.A. Teukolsky and W.T. Vetterling, Cambridge         *
!*       University Press, 1986".                              *
!* ----------------------------------------------------------- *
!***************************************************************
subroutine SORT2(A, MAX_VALUE, N)

integer N, MAX_VALUE
real    A(MAX_VALUE)     !Table to be sorted

! call sorting subroutine
  call SHELL(N,A)

  return

end

!*****************************************************
!* Sorts an array ARR of length N in ascending order *
!*            by the Shell-Mezgar method             *
!* ------------------------------------------------- *
!* INPUTS:                                           *
!*            N          size of table ARR           *
!*          ARR          table to be sorted          *
!* OUTPUT:                                           *
!*            ARR   table sorted in ascending order  *
!*                                                   *
!* NOTE: The Shell method is a N^3/2 routine and can *
!*       be used for relatively large arrays.        *
!*****************************************************
subroutine SHELL(N,ARR)
parameter(ALN2I=1./0.69314718,TINY=1.E-5)
  real ARR(N)
  LOGNB2=INT(ALOG(FLOAT(N))*ALN2I+TINY)
  m=n
  do nn=1,LOGNB2
    m=m/2; k=n-m
    do j=1,k
      i=j
10    continue
      l=i+m
      if(ARR(l).LT.ARR(i)) then
        t=ARR(i)
        ARR(i)=ARR(l)
        ARR(l)=t
        i=i-m
        if(i.GE.1) GOTO 10
      end if
    end do
  end do
  return
end

!write table of size N to standard output
subroutine TWRIT(N,ARR)
real ARR(N)
  print *,' '
  WRITE(*,10) (ARR(I),I=1,N)
  return
10 FORMAT(10F6.1)
end

!end of file sort2.f90


subroutine mbvab2(a,b,c,n1,n2)

!-----------------------------------------------------------------------
!
! This routine evaluates the matrix-vector product A = B^t C, where
! A -> R(n1), B -> Mat(n2,n1), C -> R(n2)
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: n1,n2
  real(rp),    intent(in)  :: b(n2,n1),c(n2)
  real(rp),    intent(out) :: a(n1)
  integer(ip)              :: i,k

  do i=1,n1
     a(i)=0.0_rp
     do k=1,n2
        a(i)=a(i)+b(k,i)*c(k)
     end do
  end do

end subroutine mbvab2


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!
!     center of gravity of the projection of the vertices for
!     visibility purposes
!     exact integration for one triangle: routine cubtri
!     if the surfaces are far enough away, one-point integration
!     is used
!
      subroutine postview(ntr,sideload,nelemload,kontri,ntri,nloadtr,
     &     tenv,adview,auview,area,fenv,jqrad,irowrad,nzsrad)
!
      implicit none
!
!     change following line if nlabel is increased
!
      character*20 sideload(*)
!
      integer ntr,iptri,irowrad(*),jqrad(*),nzsrad,nloadtr(*),
     &   nelemload(2,*),i,j,ntri,kontri(4,*)
!
      real*8 area(*),fenv(*),auview(*),adview(*),tenv(*),pi,
     &  totarea
!
      pi=4.d0*datan(1.d0)
!
!     division through total area and through pi
!
      iptri=1
      do i=1,ntr
         totarea=0.d0
         do
            if(iptri.gt.ntri) exit
            if(kontri(4,iptri).ne.i) exit
            totarea=totarea+area(iptri)
            iptri=iptri+1
         enddo
c
c         if(i.lt.ntr) then
c            do j=iptri(i),iptri(i+1)-1
c               totarea=totarea+area(j)
c            enddo
c         else
c            do j=iptri(i),ntri
c               totarea=totarea+area(j)
c            enddo
c         endif
         totarea=totarea*pi
!
!     auxiliary field
!
         fenv(i)=totarea
      enddo
!
!     diagonal entries
!
      do i=1,ntr
         adview(i)=adview(i)/fenv(i)
      enddo
!
!     lower triangular entries
!
      do i=1,nzsrad
         auview(i)=auview(i)/fenv(irowrad(i))
      enddo
!
!     upper triangular entries
!
      do i=1,ntr
         do j=nzsrad+jqrad(i),nzsrad+jqrad(i+1)-1
            auview(j)=auview(j)/fenv(i)
         enddo
      enddo
!
!     checking whether the sum of the viewfactors does not
!     exceed 1 (summing the rows of the viewfactor matrix)
!
!     diagonal entries
!
      do i=1,ntr
         fenv(i)=adview(i)
      enddo
!
!     lower triangular entries

      do i=1,nzsrad
         fenv(irowrad(i))=fenv(irowrad(i))+auview(i)
      enddo
!
!     upper triangular entries
!
      do i=1,ntr
         do j=nzsrad+jqrad(i),nzsrad+jqrad(i+1)-1
            fenv(i)=fenv(i)+auview(j)
         enddo
      enddo
!
!     if fenv exceeds 1 or if the user explicitly asked
!     for a scaling to 1 (negative environmental temperature)
!     -> scale to 1 (only if fenv exceeds 0)
!
!     diagonal entries
!
      do i=1,ntr
         if((fenv(i).gt.0.d0).and.
     &        ((fenv(i).gt.1.d0).or.(tenv(i).lt.0)))
     &        adview(i)=adview(i)/fenv(i)
      enddo
!
!     lower triangular entries
!
      do i=1,nzsrad
         if((fenv(irowrad(i)).gt.0.d0).and.
     &        ((fenv(irowrad(i)).gt.1.d0).or.(tenv(irowrad(i)).lt.0)))
     &        auview(i)=auview(i)/fenv(irowrad(i))
      enddo
!
!     upper triangular entries
!
      do i=1,ntr
         if((fenv(i).gt.0.d0).and.
     &        ((fenv(i).gt.1.d0).or.(tenv(i).lt.0))) then
            do j=nzsrad+jqrad(i),nzsrad+jqrad(i+1)-1
               auview(j)=auview(j)/fenv(i)
            enddo
         endif
      enddo
!
!     updating fenv accordingly
!
      do i=1,ntr
         if((fenv(i).gt.1.d0).or.(tenv(i).lt.0)) then
            if(fenv(i).gt.0.d0) then
               fenv(i)=1.d0
            else
               write(*,*) '*WARNING in radmatrix: viewfactors'
               write(*,*) '         for 3D-face''',
     &              sideload(nloadtr(i)),''''
               write(*,*) '         of element',
     &              nelemload(1,nloadtr(i))
               write(*,*) '         cannot be scaled since they are'
               write(*,*) '         all zero'
               write(*,*)
            endif
         endif
c         write(*,*) 'postview ',i,nelemload(1,nloadtr(i)),
c     &        sideload(nloadtr(i)),fenv(i)
         fenv(i)=1.d0-fenv(i)
      enddo
!
      return
      end


!--------------------------------------------------------------
! This program is designed for try FORTRAN's Output Format
!--------------------------------------------------------------
! Author: Yang Yang
! Date: 2017/04/05
!--------------------------------------------------------------
!--------------------------------------------------------------

!--------------------------------------------------------------
PROGRAM MAIN
IMPLICIT NONE
! program parameters
INTEGER,PARAMETER:: M = 4, N = 4

! vars in main function
REAL*8 :: A(M,N)
INTEGER i,j

! Define value of array A
DO j = 1,N
  DO i = 1,M
       A(i,j) = (i-1)*N + j + 1.D-2
  END DO
END DO

! Output array to file by calling subroutine
CALL dataOutput(A,M,N)

END PROGRAM MAIN
!--------------------------------------------------------------
!--------------------------------------------------------------

!--------------------------------------------------------------
SUBROUTINE dataOutput(A,M,N)
IMPLICIT NONE

CHARACTER(len=20),PARAMETER:: outputFileName = 'result.txt'   ! Output file name
! Subroutine's input vars
INTEGER M,N
REAL*8 A(M,N)

! Subroutine's locaL vars
INTEGER i,j,ierror
CHARACTER(len=100) M_Temp
WRITE(M_Temp,*) M

! Open OutputFile
OPEN(unit = 10, file = TRIM(outputFileName), IOSTAT = ierror)
IF (ierror.EQ.0) THEN
  PRINT*, 'File result.txt successfully opened!...'
END IF

! Output data to file
DO i = 1,M
  DO j = 1,N
        WRITE(10,100) A(i,j)
  END DO
  WRITE(10,200)
END DO

100 FORMAT(1x,ES24.15,\)          ! Write data to file without enter
200 FORMAT(/)                     ! Wirte enter to file
! Close Output File
CLOSE(10)

END SUBROUTINE dataOutput
!--------------------------------------------------------------
!--------------------------------------------------------------


!*==ddot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DDOT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,INCY,N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION DX(*),DY(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    DDOT forms the dot product of two vectors.
!>    uses unrolled loops for increments equal to one.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] DX
!> \verbatim
!>          DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of DX
!> \endverbatim
!>
!> \param[in] DY
!> \verbatim
!>          DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>         storage spacing between elements of DY
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup double_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      DOUBLE PRECISION FUNCTION DDOT(N,Dx,Incx,Dy,Incy)
      IMPLICIT NONE
!*--DDOT86
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      INTEGER Incx , Incy , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Dx(*) , Dy(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      DOUBLE PRECISION dtemp
      INTEGER i , ix , iy , m , mp1
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MOD
!     ..
      DDOT = 0.0D0
      dtemp = 0.0D0
      IF ( N<=0 ) RETURN
      IF ( Incx==1 .AND. Incy==1 ) THEN
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
         m = MOD(N,5)
         IF ( m/=0 ) THEN
            DO i = 1 , m
               dtemp = dtemp + Dx(i)*Dy(i)
            ENDDO
            IF ( N<5 ) THEN
               DDOT = dtemp
               RETURN
            ENDIF
         ENDIF
         mp1 = m + 1
         DO i = mp1 , N , 5
            dtemp = dtemp + Dx(i)*Dy(i) + Dx(i+1)*Dy(i+1) + Dx(i+2)     &
     &              *Dy(i+2) + Dx(i+3)*Dy(i+3) + Dx(i+4)*Dy(i+4)
         ENDDO
      ELSE
!
!        code for unequal increments or equal increments
!          not equal to 1
!
         ix = 1
         iy = 1
         IF ( Incx<0 ) ix = (-N+1)*Incx + 1
         IF ( Incy<0 ) iy = (-N+1)*Incy + 1
         DO i = 1 , N
            dtemp = dtemp + Dx(ix)*Dy(iy)
            ix = ix + Incx
            iy = iy + Incy
         ENDDO
      ENDIF
      DDOT = dtemp
      END FUNCTION DDOT


program test_general_wbv
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', ubw: ', I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  type(error_info) :: error
  integer(kind=int32) :: na, lbwa, ubwa, j
  real(kind=dp), parameter :: tol=1e-14, c=1.5
  !
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z, a1_z
  type(d_wbv), allocatable :: wbv_d
  type(z_wbv), allocatable :: wbv_z

  call initialize_errors

  ! test one
  print *
  print *, "--------------------------------"
  print *
  print *, "Real WBV Decomposition Tests"
  print *

  na=40
  lbwa=5; ubwa=3
  wbv_d=d_random_wbv(na,lbwa,ubwa,error=error)
  a_d=general(wbv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  wbv_d=wbv(a_d,lbwa+1,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(wbv_d,error)
  test_name="Random Real WBV;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw,&
       ubwa,wbv_d%ubw,t0,t1,c*tol,error)

  na=50
  lbwa=13; ubwa=3
  wbv_d=d_random_wbv(na,[ (lbwa-1, j=1,na-lbwa-1), (lbwa, j=na-lbwa,na) ], &
       [ (ubwa, j=1,na) ], error=error )
  a_d=general(wbv_d,error)
  a1_d=a_d
  wbv_d=wbv(a_d,lbwa+1,ubwa+1,tol,error)
  call cpu_time(t0)
  a0_d = general(wbv_d,error)
  call cpu_time(t1)
  test_name="Random Real Square Termination WBV;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wbv_d%lbw,&
       ubwa,wbv_d%ubw,t0,t1,c*tol,error)

  !
  ! Complex WBV test
  !
  print *
  print *, "--------------------------------"
  print *
  print *, "Complex WBV Decomposition Tests"
  print *

  na=40
  lbwa=5; ubwa=3
  wbv_z=z_random_wbv(na,lbwa,ubwa,error=error)
  a_z=general(wbv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  wbv_z=wbv(a_z, lbwa+1, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(wbv_z,error)
  test_name="Random Complex WBV;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)

  na=50
  lbwa=13; ubwa=3
  wbv_z=z_random_wbv(na,[ (lbwa-1, j=1,na-lbwa-1), (lbwa, j=na-lbwa,na) ], &
       [ (ubwa, j=1,na) ], error=error )
  a_z=general(wbv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  wbv_z=wbv(a_z,lbwa+1,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z = general(wbv_z,error)
  test_name="Random Complex Square Termination WBV;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wbv_z%lbw, &
       ubwa,wbv_z%ubw,t0,t1,c*tol,error)
  print *

contains

  subroutine d_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_general_wbv


      program fixture
         use, intrinsic :: iso_fortran_env, only: wp => real64
         use json_module
         type(json_core) :: json
         type(json_value), pointer :: root
         double precision y(9), x(6), ac(6, 9), a(6, 9)
         data((ac(i, j), i=1, 6), j=1, 9)/-0.054877470000,&
        & 0.250141320000, 0.618243290000, -0.172623500000,&
        & -2.223900270000, -1.26361440000,&
        &  0.358728900000, -0.011045480000, -0.940649160000,&
        & -0.115825320000, -0.814968710000,&
        &  0.24226350000,&
        &  -1.425098390000, 0.365941120000, 0.248412650000,&
        &  0.065288180000, 0.019156390000,&
        &  0.25733840000, -0.649010080000,&
        &  -0.119168760000, 0.664135700000, 1.100969100000,&
        &  0.143771480000, -0.11775360000,&
        &  -0.912068370000, -1.437586240000, -0.797089530000,&
        &  1.254083110000, 0.772142190000, -0.21951560000,&
        &  -0.424810280000, -0.418980100000, 0.996986860000,&
        &  -0.275778030000, 1.256018820000, 0.64667440000,&
        &  1.299312300000, -0.873262110000, 0.008370960000,&
        &  -0.880871720000,&
        &  0.596259020000, 0.11971760000,&
        &  -0.282173880000, 1.455988400000, 0.229019590000, 0.99654393000,&
        &  0.78185918000, -0.7767766000,&
        &  -0.61598991000, 0.04658030000, -1.130385780000, 0.576718780000,&
        &  -1.28074943000, 1.6254473000/
         data(x(i), i=1, 6)/0.10330280, 0.62787610, 0.09179221, 0.10161032, 0.33920221, 0.93821373/
         data(y(i), i=1, 9)/0.823443247, 0.615896282, 0.502300758, 0.008093905, 0.222554779,&
         &0.787857479, 0.874444904, 0.613885907, 0.617612043/
         call json%initialize()
         call json%create_array(root, '')

         a = ac
         call addcase(root, '0', 3, 4, 1.5_08, x, 2, y, 2, a, 6)

         a = ac
         call addcase(root, '1', 3, 4, 1.5_08, x, -2, y, -2, a, 6)

         a = ac
         call addcase(root, '2', 3, 4, 0.0_08, x, -2, y, -2, a, 6)

         call print(root)
      contains
         subroutine addcase(root, ncase, m, n, alpha, x, incx, y, incy, a, lda)
            type(json_core) :: json
            type(json_value), pointer :: root, case, array
            external dger
            character(len=*) ncase
            integer m, n, kl, ku, lda, incx, incy
            double precision alpha, beta, y(9), x(6), a(lda, n)
            call json%create_object(case, '')
            call json%add(root, case)
            call json%add(case, 'm', m)
            call json%add(case, 'n', n)
            call json%add(case, 'alpha', alpha)
            call json%create_array(array, 'a')
            do j = 1, 9
               do i = 1, 6
                  call json%add(array, '', a(i, j))
               enddo
            enddo
            call json%add(case, array)
            nullify (array)
            call json%add(case, 'lda', lda)
            call json%add(case, 'x', x)
            call json%add(case, 'incx', incx)
            call json%add(case, 'y', y)
            call json%add(case, 'incy', incy)
            call dger(m, n, alpha, x, incx, y, incy, a, lda)
            call json%create_array(array, 'expect')
            do j = 1, 9
               do i = 1, 6
                  call json%add(array, '', a(i, j))
               enddo
            enddo
            call json%add(case, array)
            nullify (array)
            nullify (case)
         end subroutine addcase

         subroutine print(root)
            use, intrinsic :: iso_fortran_env, only: real64
            use json_module, CK => json_CK, CK => json_CK
            implicit none
            type(json_core) :: json
            type(json_value), pointer :: root
            logical :: status_ok
            character(kind=CK, len=:), allocatable :: error_msg
            call json%print(root, './tests/fixtures/level2/ger.json')
            call json%destroy(root)
            if (json%failed()) then
               call json%check_for_errors(status_ok, error_msg)
               write (*, *) 'Error: '//error_msg
               call json%clear_exceptions()
               call json%destroy(root)
            end if
         end subroutine print
      end


      SUBROUTINE mpmul(w,u,v,n,m)
      INTEGER m,n,NMAX
      CHARACTER*1 w(n+m),u(n),v(m)
      DOUBLE PRECISION RX
      PARAMETER (NMAX=8192,RX=256.D0)
CU    USES drealft
      INTEGER j,mn,nn
      DOUBLE PRECISION cy,t,a(NMAX),b(NMAX)
      mn=max(m,n)
      nn=1
1     if(nn.lt.mn) then
        nn=nn+nn
      goto 1
      endif
      nn=nn+nn
      if(nn.gt.NMAX)pause 'NMAX too small in fftmul'
      do 11 j=1,n
        a(j)=ichar(u(j))
11    continue
      do 12 j=n+1,nn
        a(j)=0.D0
12    continue
      do 13 j=1,m
        b(j)=ichar(v(j))
13    continue
      do 14 j=m+1,nn
        b(j)=0.D0
14    continue
      call drealft(a,nn,1)
      call drealft(b,nn,1)
      b(1)=b(1)*a(1)
      b(2)=b(2)*a(2)
      do 15 j=3,nn,2
        t=b(j)
        b(j)=t*a(j)-b(j+1)*a(j+1)
        b(j+1)=t*a(j+1)+b(j+1)*a(j)
15    continue
      call drealft(b,nn,-1)
      cy=0.
      do 16 j=nn,1,-1
        t=b(j)/(nn/2)+cy+0.5D0
        b(j)=mod(t,RX)
        cy=int(t/RX)
16    continue
      if (cy.ge.RX) pause 'cannot happen in fftmul'
      w(1)=char(int(cy))
      do 17 j=2,n+m
        w(j)=char(int(b(j-1)))
17    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/mpmul.for