MODULE m_gfc

! ----------------------------------------------------------------------
! MODULE: m_gfc.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for the subroutines that read the gravity field model data
! (parameters and spherical harmonic coefficients)
!
! Subroutines contained within this module:
! - gfc1.f90: Static gravity field models
! - gfc2.f90: Time-variable gravity field models
! ----------------------------------------------------------------------
! Author :  Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:  24 October 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE gfc1 (gfmfilename, n_trunc, sigma_shc, GM_gfc, ae_gfc, Nmax_gfc, tide_gfc, Cnm, Snm, sCnm, sSnm)

! ----------------------------------------------------------------------
! SUBROUTINE: gfc1.f90
! ----------------------------------------------------------------------
! Purpose:
!  Read gravity field model's .gfc data file in the ICGEM (International
!  Centre for Global Earth Models) format
! ----------------------------------------------------------------------
! Input arguments:
! - gfmfilename:  Data file name of the global Earth gravity field
!                             model in ICGEM format
! - n_trunc:      Degree truncation limit in reading the Spherical
!                       Harmonic Coefficients (SHC)
!                 Set equal to -1 for reading all the SHC
! - sigma_shc:          Set to any value or 0 for reading or not the
!                       coefficients errors (sigmaC and sigmaS)
!
! Output arguments:
! - GM_gfc:             Earth gravity constant (m^3/sec^2)
! - ae_gfc:             Radius  (meters)
! - Nmax_gfc:           Gravity model's maximum degree
! - tide_gfc:           Gravity model's tide system: zero_tide or tide_free
! - Cnm:          Normalized spherical harmonics coefficients C (dynamic allocatable array)
! - Snm:          Normalized spherical harmonics coefficients S (dynamic allocatable array)
! - sCnm:               Errors (variances) of C spherical harmonics coefficients (dynamic allocatable array)
! - sSnm:               Errors (variances) of S spherical harmonics coefficients (dynamic allocatable array)
! ----------------------------------------------------------------------
! Remark:
!  Cnm and Snm arrays are formed into lower triangular matrices.
!  Coefficient Cnm corresponds to the matrix element Cnm(n+1,m+1)
! ----------------------------------------------------------------------
! Author :  Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:  September 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 24 October 2017:
!   The subroutine has been modified in order to use advantages of Fortran 2003 in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
!      USE mdl_gfc
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int2), INTENT(IN) :: n_trunc
      INTEGER (KIND = prec_int2), INTENT(IN) :: sigma_shc
      CHARACTER (*), INTENT(IN) :: gfmfilename
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: GM_gfc, ae_gfc
      INTEGER (KIND = prec_int8), INTENT(OUT) :: Nmax_gfc
      CHARACTER (LEN=50), INTENT(OUT) :: tide_gfc
        ! Dynamic Allocatable arrays
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: Cnm
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: Snm
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: sCnm
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: sSnm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: i
!       , read_i
      INTEGER (KIND = prec_int2) :: UNIT_IN, ios
      INTEGER (KIND = prec_int2) :: ios_line, ios_key, ios_data
!       INTEGER (KIND = prec_int2) :: space_i
      INTEGER (KIND = prec_int2) :: AllocateStatus
      CHARACTER (LEN=7) :: Format1, Format2, Format3
      CHARACTER (LEN=500) :: line_ith
      CHARACTER (LEN=150) :: word1_ln, word_i
      INTEGER (KIND = prec_int8) :: n_ith, m_ith, n_limit
      REAL (KIND = prec_q) :: Cnm_i, Snm_i, sCnm_i, sSnm_i
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      UNIT_IN = 9
      Format1 = '(A)'
      Format2 = '(F)'
      Format3 = '(I100)'
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Open .gfc file
      OPEN (UNIT = UNIT_IN, FILE = TRIM (gfmfilename), IOSTAT = ios)
      IF (ios /= 0) THEN
         PRINT *, "Error in opening file:", gfmfilename
         PRINT *, "OPEN IOSTAT=", ios
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read Head of .gfc file
! ----------------------------------------------------------------------
      i = 0
      DO
           READ (UNIT=UNIT_IN,FMT=Format1,IOSTAT=ios_line) line_ith
           i = i + 1
!          PRINT *, "READ Line (i,ios):", i, ios_line
! ----------------------------------------------------------------------
! 1st Word of Line ith
           READ (line_ith, * , IOSTAT=ios_data) word1_ln  ! 1st word
! ----------------------------------------------------------------------
! Header Start
         IF (word1_ln == "begin_of_head") THEN
!            PRINT *, "Begin of Head"
         END IF
! Header End
         IF (word1_ln == "end_of_head") THEN
!            PRINT *, "End of Head"
            EXIT
         END IF
! ----------------------------------------------------------------------
! Keywords for Gravity Field Model parameters
         IF (word1_ln == "earth_gravity_constant") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, GM_gfc
         END IF
         IF (word1_ln == "radius") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, ae_gfc
         END IF
         IF (word1_ln == "max_degree") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, Nmax_gfc
         END IF
         IF (word1_ln == "tide_system") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, tide_gfc
         END IF
! ----------------------------------------------------------------------
      END DO
! ----------------------------------------------------------------------
!       PRINT *, "GM_gfc =", GM_gfc
!       PRINT *, "ae_gfc =", ae_gfc
!       PRINT *, "Nmax_gfc =", Nmax_gfc
!       PRINT *, "tide_gfc :", tide_gfc

! ----------------------------------------------------------------------
      IF (n_trunc < 0) THEN
         n_limit = Nmax_gfc
      ELSE
         n_limit = n_trunc
      END IF
! ----------------------------------------------------------------------
!      PRINT *, "n_limit=", n_limit

! ----------------------------------------------------------------------
! Allocatable arrays
! ----------------------------------------------------------------------
      ALLOCATE (Cnm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: Cnm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF
      Cnm = 0.0D0

      ALLOCATE (Snm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: Snm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF
      Snm = 0.0D0

      IF (sigma_shc /= 0) THEN

      ALLOCATE (sCnm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: sCnm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF
      sCnm = 0.0D0

      ALLOCATE (sSnm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: sSnm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF
      sSnm = 0.0D0

      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read Spherical Harmonic Coefficients of .gfc file
! ----------------------------------------------------------------------
!      i = 0
      DO
           READ (UNIT=UNIT_IN,FMT=Format1,IOSTAT=ios_line) line_ith
           i = i + 1
!          PRINT *, "READ Line (i,ios):", i, ios_line
! ----------------------------------------------------------------------
! End of file
         IF (ios_line < 0) THEN
!            PRINT *, "End of file, i=", i
            EXIT
         END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 1st Word of Line ith
           READ (line_ith, * , IOSTAT=ios_data) word1_ln  ! 1st word
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Data
         IF (word1_ln == "gfc" .OR. word1_ln == "gfct") THEN
              READ (line_ith, * , IOSTAT=ios_data) word_i, n_ith, m_ith, Cnm_i, Snm_i, sCnm_i, sSnm_i
!             PRINT *, "n", n_ith
!             PRINT *, "m", m_ith
!             PRINT *, "Cnm", Cnm_i
!             PRINT *, "Snm", Snm_i
!             PRINT *, "sCnm", sCnm_i
!             PRINT *, "sSnm", sSnm_i
            IF (n_ith <= n_limit) THEN
               Cnm(n_ith+1,m_ith+1) = Cnm_i
               Snm(n_ith+1,m_ith+1) = Snm_i
               IF (sigma_shc /= 0) THEN
                  sCnm(n_ith+1,m_ith+1) = sCnm_i
                  sSnm(n_ith+1,m_ith+1) = sSnm_i
               END IF
            END IF
         END IF
! ----------------------------------------------------------------------
      END DO
! ----------------------------------------------------------------------

      CLOSE (UNIT=UNIT_IN)

END SUBROUTINE

SUBROUTINE gfc2 (gfmfilename,n_trunc,sigma_shc, mjd_t, Ntv_trunc, GM_gfc, ae_gfc, Nmax_gfc, tide_gfc, Cnm, Snm, sCnm, sSnm)

! ----------------------------------------------------------------------
! SUBROUTINE: gfc2.f90
! ----------------------------------------------------------------------
! Purpose:
!  Read gravity field model's .gfc data file including the time-variable
!  coefficients (icgem format)
! ----------------------------------------------------------------------
! Input arguments:
! - gfmfilename:        Data file name of the global Earth gravity field model in ICGEM format
! - n_trunc:            Degree truncation limit for the Spherical Harmonic Coefficients (SHC)
!                       (set to negative values for reading all SHC)
! - sigma_shc:          Set to any value or 0 for reading or not the
!                       coefficients errors (sigmaC and sigmaS)
! - mjd_t:                    Modified Julian Day Number of the input epoch
!                                   including the fraction of the day. Time-variable
!                                   coefficients are computed at this epoch.
! - Ntv_trunc > 0       Degree truncation limit for the time-variable SHC
!   Ntv_trunc = 0       Read the static part only ignoring the time-variable SHC
!   Ntv_trunc < 0       Read the time-variable SHC up to the maximum degree
!
! Output arguments:
! - GM_gfc:             Earth gravity constant (m^3/sec^2)
! - ae_gfc:             Radius  (meters)
! - Nmax_gfc:           Gravity model's maximum degree
! - tide_gfc:           Gravity model's tide system: zero_tide or tide_free
! - Cnm:          Normalized spherical harmonics coefficients C (dynamic allocatable array)
! - Snm:          Normalized spherical harmonics coefficients S (dynamic allocatable array)
! - sCnm:               Errors (variances) of C spherical harmonics coefficients (dynamic allocatable array)
! - sSnm:               Errors (variances) of S spherical harmonics coefficients (dynamic allocatable array)
! ----------------------------------------------------------------------
! Remark:
!  Cnm and Snm arrays are formed into lower triangular matrices.
!  Coefficient Cnm corresponds to the matrix element Cnm(n+1,m+1)
! ----------------------------------------------------------------------
! Author :  Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:  January 2016
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 25 October 2017:
!   The subroutine has been modified in order to use advantages of Fortran 2003 in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
!      USE mdl_gfc
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int2), INTENT(IN) :: n_trunc, Ntv_trunc
      INTEGER (KIND = prec_int2), INTENT(IN) :: sigma_shc
      CHARACTER (*), INTENT(IN) :: gfmfilename
      REAL (KIND = prec_q), INTENT(IN) :: mjd_t
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: GM_gfc, ae_gfc
      INTEGER (KIND = prec_int8), INTENT(OUT) :: Nmax_gfc
      CHARACTER (LEN=50), INTENT(OUT) :: tide_gfc
        ! Dynamic Allocatable arrays
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: Cnm
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: Snm
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: sCnm
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: sSnm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: i
!       , read_i
      INTEGER (KIND = prec_int2) :: UNIT_IN, ios
      INTEGER (KIND = prec_int2) :: ios_line, ios_key, ios_data
!       INTEGER (KIND = prec_int2) :: space_i
      INTEGER (KIND = prec_int2) :: AllocateStatus
      CHARACTER (LEN=7) :: Format1, Format2, Format3
      CHARACTER (LEN=500) :: line_ith
      CHARACTER (LEN=150) :: word1_ln, word_i, t0
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: n_ith, m_ith, n_limit, Nmax_tv, n_i,m_i
      REAL (KIND = prec_q) :: Cnm_i, Snm_i, sCnm_i, sSnm_i
      REAL (KIND = prec_q) :: Cnm_t0, Snm_t0,sCnm_t0, sSnm_t0
      REAL (KIND = prec_q) :: Cnm_trend, Snm_trend, sCnm_trend, sSnm_trend
      REAL (KIND = prec_q) :: Cnm_acos, Snm_acos, sCnm_acos, sSnm_acos
      REAL (KIND = prec_q) :: Cnm_asin, Snm_asin, sCnm_asin, sSnm_asin
      REAL (KIND = prec_q) :: T_days, period, delta_t
! ----------------------------------------------------------------------
      INTEGER Y_t0, M_t0, D_t0, J_flag
      DOUBLE PRECISION DJM0, mjd_t0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      UNIT_IN = 9
      Format1 = '(A)'
      Format2 = '(F)'
      Format3 = '(I100)'
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Open .gfc file
      OPEN (UNIT = UNIT_IN, FILE = TRIM (gfmfilename), IOSTAT = ios)
      IF (ios /= 0) THEN
         PRINT *, "Error in opening file:", gfmfilename
         PRINT *, "OPEN IOSTAT=", ios
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read Head of .gfc file
! ----------------------------------------------------------------------
      i = 0
      DO
           READ (UNIT=UNIT_IN,FMT=Format1,IOSTAT=ios_line) line_ith
           i = i + 1
!          PRINT *, "READ Line (i,ios):", i, ios_line
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 1st Word of Line ith
           READ (line_ith, * , IOSTAT=ios_data) word1_ln  ! 1st word
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Header Start
         IF (word1_ln == "begin_of_head") THEN
!            PRINT *, "Begin of Head"
         END IF
! Header End
         IF (word1_ln == "end_of_head") THEN
!            PRINT *, "End of Head"
            EXIT
         END IF
! ----------------------------------------------------------------------
! Keywords for Gravity Field Model parameters
         IF (word1_ln == "earth_gravity_constant") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, GM_gfc
         END IF
         IF (word1_ln == "radius") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, ae_gfc
         END IF
         IF (word1_ln == "max_degree") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, Nmax_gfc
         END IF
         IF (word1_ln == "tide_system") THEN
              READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, tide_gfc
         END IF
! ----------------------------------------------------------------------
      END DO
! ----------------------------------------------------------------------
       !PRINT *, "GM_gfc =", GM_gfc
       !PRINT *, "ae_gfc =", ae_gfc
       !PRINT *, "Nmax_gfc =", Nmax_gfc
       !PRINT *, "tide_gfc : ", tide_gfc

! ----------------------------------------------------------------------
      IF (n_trunc < 0) THEN
         n_limit = Nmax_gfc
      ELSE
         n_limit = n_trunc
      END IF

      IF (Ntv_trunc < 0) THEN
         Nmax_tv = n_limit
      ELSE
         Nmax_tv = Ntv_trunc
      END IF

      IF (Ntv_trunc > n_limit) THEN
         Nmax_tv = n_limit
      END IF
! ----------------------------------------------------------------------
!      PRINT *, "n_limit, Nmax_tv", n_limit, Nmax_tv

! ----------------------------------------------------------------------
! Allocatable arrays
! ----------------------------------------------------------------------
      ALLOCATE (Cnm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: Cnm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF

      ALLOCATE (Snm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: Snm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF

      IF (sigma_shc /= 0) THEN

      ALLOCATE (sCnm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: sCnm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF

      ALLOCATE (sSnm(n_limit+1,n_limit+1), STAT = AllocateStatus)
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE gfc1 in m_gfc.f03"
         PRINT *, "Error: Allocatable Array: sSnm, Nmax =", n_limit
!         STOP "*** Not enough memory ***"
      END IF

      sCnm = 0.0D0
      sSnm = 0.0D0
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Set the Cnm,Snm triangular matrices to zero matrices
! ----------------------------------------------------------------------
      DO n_i = 0 , n_limit
            DO m_i = 0 , n_limit
                  Cnm (n_i+1,m_i+1) = 0D0
                  Snm (n_i+1,m_i+1) = 0D0
            END DO
      END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read Spherical Harmonic Coefficients of .gfc file
! ----------------------------------------------------------------------
!      i = 0
      DO
           READ (UNIT=UNIT_IN,FMT=Format1,IOSTAT=ios_line) line_ith
           i = i + 1
!          PRINT *, "READ Line (i,ios):", i, ios_line
! ----------------------------------------------------------------------
! End of file
         IF (ios_line < 0) THEN
!            PRINT *, "End of file, i=", i
            EXIT
         END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 1st Word of Line ith
           READ (line_ith, * , IOSTAT=ios_data) word1_ln  ! 1st word
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Data
! ----------------------------------------------------------------------
! Static gravity field coefficients
         IF (word1_ln == "gfc") THEN
              READ (line_ith, * , IOSTAT=ios_data) word_i, n_ith, m_ith, Cnm_i, Snm_i, sCnm_i, sSnm_i
            IF (n_ith <= n_limit) THEN
               Cnm(n_ith+1,m_ith+1) = Cnm_i
               Snm(n_ith+1,m_ith+1) = Snm_i
               IF (sigma_shc /= 0) THEN
                  sCnm(n_ith+1,m_ith+1) = sCnm_i
                  sSnm(n_ith+1,m_ith+1) = sSnm_i
               END IF
            END IF
! ----------------------------------------------------------------------
! Time-variable gravity field coefficients
         ELSE IF (word1_ln == "gfct") THEN
                  ! gfct
              READ (line_ith,FMT= *, IOSTAT=ios_data) word_i, n_ith, m_ith, Cnm_t0, Snm_t0, sCnm_t0, sSnm_t0, t0
      !PRINT *, "Line:", i , TRIM (word_i), n_ith, m_ith
      !PRINT *, "Line:", i, TRIM (t0)
                  ! Read next (3) lines for "trend,acos,asin" coefficients
                  ! Trend
              READ (UNIT=UNIT_IN,FMT= *,IOSTAT=ios_line) word_i, n_ith, m_ith, Cnm_trend, Snm_trend, sCnm_trend, sSnm_trend
              i = i + 1
      !PRINT *, "Line:", i, TRIM (word_i), n_ith, m_ith
                  ! acos
              READ (UNIT=UNIT_IN,FMT= *,IOSTAT=ios_line) word_i, n_ith, m_ith, Cnm_acos, Snm_acos, sCnm_acos, sSnm_acos, period
              i = i + 1
      !PRINT *, "Line:", i, TRIM (word_i), n_ith, m_ith
                  ! asin
              READ (UNIT=UNIT_IN,FMT= *,IOSTAT=ios_line) word_i, n_ith, m_ith, Cnm_asin, Snm_asin, sCnm_asin, sSnm_asin, period
              i = i + 1
      !PRINT *, "Line:", i, TRIM (word_i), n_ith, m_ith
! ----------------------------------------------------------------------
! Compute Cnm,Snm at the input epoch
            IF (n_ith <= Nmax_tv) THEN
! ----------------------------------------------------------------------
                        !delta_t = (t_ys - t0_ys) / period
                        T_days = period * 365.25D0
                        read( t0(1:4), * ) Y_t0
                        read( t0(5:6), * ) M_t0
                        read( t0(7:8), * ) D_t0
                        CALL iau_CAL2JD ( Y_t0, M_t0, D_t0, DJM0, mjd_t0, J_flag )
                        !PRINT *, "MJD t0", mjd_t0, TRIM (t0)
                        delta_t = (mjd_t - mjd_t0) / T_days
! ----------------------------------------------------------------------
! V(t) = gfct + trnd * (t-t0)/T + acos*cos( 2pi * (t-t0)/T ) + asin*sin( 2pi * (t-t0)/T )
                        Cnm_i = Cnm_t0 + Cnm_trend * delta_t &
                                       + Cnm_acos * cos(2.0D0 * PI_global * delta_t) &
                                       + Cnm_asin * sin(2.0D0 * PI_global * delta_t)
                        Snm_i = Snm_t0 + Snm_trend * delta_t &
                                       + Snm_acos * cos(2.0D0 * PI_global * delta_t) &
                                             + Snm_asin * sin(2.0D0 * PI_global * delta_t)
! ----------------------------------------------------------------------
            ELSE IF (n_ith > Nmax_tv .AND. n_ith <= n_limit) THEN
                        Cnm_i = Cnm_t0
                        Snm_i = Snm_t0
            END IF
! ----------------------------------------------------------------------
            IF (n_ith <= n_limit) THEN
               Cnm(n_ith+1,m_ith+1) = Cnm_i
               Snm(n_ith+1,m_ith+1) = Snm_i
               IF (sigma_shc /= 0) THEN
                  sCnm(n_ith+1,m_ith+1) = sCnm_i
                  sSnm(n_ith+1,m_ith+1) = sSnm_i
               END IF
               !PRINT *,"n,m", n_ith, m_ith
               !PRINT *,"Cnm,Snm", Cnm_i, Snm_i
            END IF
! ----------------------------------------------------------------------
         END IF
! ----------------------------------------------------------------------
!             PRINT *, "n", n_ith
!             PRINT *, "m", m_ith
!             PRINT *, "Cnm", Cnm_i
!             PRINT *, "Snm", Snm_i
!             PRINT *, "sCnm", sCnm_i
!             PRINT *, "sSnm", sSnm_i
! ----------------------------------------------------------------------
      END DO
! ----------------------------------------------------------------------

      CLOSE (UNIT=UNIT_IN)

END SUBROUTINE

End


!	Sort integer array a in ascending order.
recursive subroutine sort(a)
implicit none
interface
	subroutine partition(a,pivot)
!	Array to sort is a.
	  integer, intent(in out)::a(:)
!	Pivot is the pivot point.
	  integer, intent(out) :: pivot
	end subroutine partition
end interface
  integer, intent(in out) :: a(:)
!	pivot is pivot point.
  integer :: pivot

  if(size(a) > 1) then
!	partition is used to select pivot point
	call partition(a, pivot)
!	Sort part of a below pivot.
	call sort(a(:pivot-1))
!	Sort part of a above pivot.
	call sort(a(pivot:))
  endif
end subroutine sort
!	Find pivot point.
subroutine partition(a, pivot)
!	Array to sort is a.
  integer, intent(in out)::a(:)
!	Pivot is the pivot point.
  integer, intent(out) :: pivot
!	lower is lower bound and upper is upper bound for pivot.
!	a values below pivot must not exceed x.  a values above
!	pivot must not be less than x.
  integer :: lower, upper
!	The pivot value is x.  Hold is used to store value to be exchanged.
  integer :: hold,x
  x = a(size(a)/2)
!	The pivot cannot be less than 0.
  lower= 0
!	The pivot cannot exceed size(a).
  upper= size(a) + 1

  do
!	Drop upper by 1 for new upper bound on pivot.
     upper = upper-1
     do
!	If a(upper)<=x, then pivot does not exceed upper.
        if (a(upper) <= x) exit
!	Drop upper by 1 because pivot must be less than upper.
        upper = upper-1
     end do
!	Now check on lower bound.
     lower = lower+1
     do
        if (a(lower) >= x) exit
!	Increase lower by 1.
        lower = lower+1
     end do
     if (lower < upper) then
!	Exchange a(lower) and a(upper).
        hold = a(lower)
        a(lower) = a(upper)
        a(upper) = hold
     else
		if (lower == upper) then
			pivot = upper+1
			return
		else
			pivot = lower
			return
		endif
     endif
  end do

end subroutine partition


program main
  implicit none
  integer, parameter :: n = 5
  double precision :: a(n, n), norm
  integer :: i, j
  double precision :: dlange
  do j = 1, n
     do i = 1, n
        a(i, j) = n - 0.253D0 * max(i-1, j-1)
     end do
  end do
  print *, "Matrix A: ", n, n
  do j = 1, n
     print *, a(1:n, j)
  end do

  norm = dlange('F', n, n, a, n)
  print *, "norm =", norm
end program main


*DECK CDOTC
      COMPLEX FUNCTION CDOTC (N, CX, INCX, CY, INCY)
C***BEGIN PROLOGUE  CDOTC
C***PURPOSE  Dot product of two complex vectors using the complex
C            conjugate of the first vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A4
C***TYPE      COMPLEX (CDOTC-C)
C***KEYWORDS  BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       CX  complex vector with N elements
C     INCX  storage spacing between elements of CX
C       CY  complex vector with N elements
C     INCY  storage spacing between elements of CY
C
C     --Output--
C    CDOTC  complex result (zero if N .LE. 0)
C
C     Returns the dot product of complex CX and CY, using CONJUGATE(CX)
C     CDOTC = SUM for I = 0 to N-1 of CONJ(CX(LX+I*INCX))*CY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CDOTC
      COMPLEX CX(*),CY(*)
C***FIRST EXECUTABLE STATEMENT  CDOTC
      CDOTC = (0.0,0.0)
      IF (N .LE. 0) RETURN
      IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
C
C     Code for unequal or nonpositive increments.
C
      KX = 1
      KY = 1
      IF (INCX .LT. 0) KX = 1+(1-N)*INCX
      IF (INCY .LT. 0) KY = 1+(1-N)*INCY
      DO 10 I = 1,N
        CDOTC = CDOTC + CONJG(CX(KX))*CY(KY)
        KX = KX + INCX
        KY = KY + INCY
   10 CONTINUE
      RETURN
C
C     Code for equal, positive increments.
C
   20 NS = N*INCX
      DO 30 I = 1,NS,INCX
      CDOTC = CDOTC + CONJG(CX(I))*CY(I)
   30 CONTINUE
      RETURN
      END


      PROGRAM xzrhqr
C     driver for routine zrhqr
      INTEGER M,MP1,NTRY
      PARAMETER(M=4,MP1=M+1,NTRY=21)
      INTEGER i
      REAL a(MP1),rtr(M),rti(M)
      DATA a/-1.0,0.0,0.0,0.0,1.0/
      write(*,'(/1x,a)') 'Roots of polynomial x^4-1'
      write(*,'(/1x,t16,a,t29,a/)') 'Real','Complex'
      call zrhqr(a,M,rtr,rti)
      do 11 i=1,M
        write(*,'(1x,i5,2f15.6)') i,rtr(i),rti(i)
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xzrhqr.for


      program leapyear
      integer y, leap

c     leap year algo

      write (*,*) "Enter year numb"
      read (*, '(I4)') y

      leap = 0
      if (mod(y,4) .EQ. 0) then
         if (mod(y, 100) .NE. 0) then
            leap = 1
         endif
      elseif (mod(y, 400) .EQ. 0) then
         leap = 1
      endif

      write (*,*) "Year ", y, " is a leap: ", leap
      stop
      end


PROGRAM main

  USE mo_kind,     ONLY: dp, sp, i8
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_template, ONLY: mean, PI_sp, PI_dp

  IMPLICIT NONE

  REAL(dp), DIMENSION(10) :: dat
  REAL(sp), DIMENSION(10) :: sat

  real(sp) :: stmp
  real(dp) :: dtmp

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_template.f90'

  ! Double precision
  dat = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  isgood = .true.
  dtmp = mean(dat)
  isgood = isgood .and. (nint(10._dp*dtmp) == 55)
  dtmp = mean(dat(1:9))
  isgood = isgood .and. (nint(10._dp*dtmp) == 50)
  dtmp = mean(dat, mask=( abs(dat-10._dp) .gt. tiny(1.0_dp) ))
  isgood = isgood .and. (nint(10._dp*dtmp) == 50)

  isgood = isgood .and. (nint(1e15_dp*PI_dp,i8) == 3141592653589793_i8)

  if (isgood) then
     write(*,*) 'mo_template double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_template double precision ', color('failed!', c_red)
  endif

  ! Double precision
  sat = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  isgood = .true.
  stmp = mean(sat)
  isgood = isgood .and. (nint(10._sp*stmp) == 55)
  stmp = mean(sat(1:9))
  isgood = isgood .and. (nint(10._sp*stmp) == 50)
  stmp = mean(sat, mask=( abs(sat-10._sp) .gt. tiny(1.0_sp) ))
  isgood = isgood .and. (nint(10._sp*stmp) == 50)

  isgood = isgood .and. (nint(1e6_sp*PI_sp) == 3141593)

  if (isgood) then
     write(*,*) 'mo_template single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_template single precision ', color('failed!', c_red)
  endif

END PROGRAM main


  program Convert
  implicit none
  ! -----------------------------------------------Declare
  real*4 tempC, tempF, FACTOR
  integer*2 ZERO_SHIFT
  parameter (ZERO_SHIFT = 32, FACTOR = 5./9.)
  ! -----------------------------------------------Input
  print*, "Enter the temperature in Fahrenheit ..."
  read*, tempF
  ! -----------------------------------------------Compute
  tempC = FACTOR * (tempF - ZERO_SHIFT)
  ! -----------------------------------------------Output
  print*, "The corresponding Centigrade temperature is "
  print*, tempC, " degrees."
  end


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
cc
      program testfft
      implicit none
c
      integer i,ier,iflag,j,k1,k2,lused,lw,mx,ms,mt,n1,n2,nj,nk
      parameter (mx=256*256)
      parameter (lw=1000 000)
      real*8 xj(mx),yj(mx)
      real *8 sk(mx),tk(mx)
      real*8 err,pi,eps,salg,ealg
      real*8 fw(0:lw-1)
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16 cj(mx),cj0(mx),cj1(mx)
      complex*16 fk0(mx),fk1(mx)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
c
      n1 = 36
      n2 = 40
      ms = 32
      mt = 30
      nj = n1*n2
      do k1 = -n1/2, (n1-1)/2
         do k2 = -n2/2, (n2-1)/2
            j = (k2+n2/2+1) + (k1+n1/2)*n2
            xj(j) = pi*dcos(-pi*k1/n1)
            yj(j) = pi*dcos(-pi*k2/n2)
            cj(j) = dcmplx(dsin(pi*j/n1),dcos(pi*j/n2))
         enddo
      enddo
c
c     -----------------------
c     start tests
c     -----------------------
c
      iflag = 1
      print*,'Starting 2D testing: ', ' nj =',nj, ' ms,mt =',ms,mt
      do i = 1,4
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         if (i.eq.4) eps=1d-16
c extended/quad precision tests
         if (i.eq.5) eps=1d-20
         if (i.eq.6) eps=1d-24
         if (i.eq.7) eps=1d-28
         if (i.eq.8) eps=1d-32
	 print*,' '
	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 2D Type 1 method
c     -----------------------
c
         call dirft2d1(nj,xj,yj,cj,iflag,ms,mt,fk0)
         call nufft2d1(nj,xj,yj,cj,iflag,eps,ms,mt,fk1,fw,lw,lused,ier)
         call errcomp(fk0,fk1,ms*mt,err)
         print *, ' iflag = ',iflag
         print *, ' ier = ',ier
         print *, ' meomory used = ',lused
         call errcomp(fk0,fk1,ms*mt,err)
         print *, ' type 1 err = ',err
c
c     -----------------------
c      call 2D Type 2 method
c     -----------------------
         call dirft2d2(nj,xj,yj,cj0,iflag,ms,mt,fk0)
         call nufft2d2(nj,xj,yj,cj1,iflag,eps,ms,mt,fk1,
     1                 fw,lw,lused,ier)
         print *, ' ier = ',ier
         print *, ' meomory used = ',lused
         call errcomp(cj0,cj1,nj,err)
         print *, ' type 1 err = ',err
c
c     -----------------------
c      call 2D Type3 method
c     -----------------------
         nk = ms*mt
         do k1 = 1, nk
            sk(k1) = 64*(dcos(k1*pi/nk))
            tk(k1) = 48*(dsin(-pi/2+k1*pi/nk))
         enddo

         call dirft2d3(nj,xj,yj,cj,iflag, nk,sk,tk,fk0)
         call nufft2d3(nj,xj,yj,cj,iflag,eps,nk,sk,tk,fk1,
     1                 fw,lw,lused,ier)
c
         print *, ' ier = ',ier
         print *, ' meomory used = ',lused
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 1 err = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*16 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


module mod_band_types
  use mod_prec
  use mod_rotation
  use mod_utility
  implicit none
  ! Routines for working with compact representations of banded
  ! matrices.  A banded matrix $A=[a_{jk}]$ with $a_{jk}=0$ for
  ! $k-j>s$ and $k-j < -r$ is stored in one of two ways: In the first
  ! format, elements of $A$ are stored in a matrix $B$ with columns
  ! aligned with those of $A$ and $a_{j,k}=b_{j-k+s+1,k}$. Thus each
  ! row of $B$ corresponds to a diagonal of $A$ and $B$ can be chosen
  ! to be $(r+s+1)\times n$.  Routines working with this format are
  ! given the tag `_bc`. In the second format, $B$ has rows aligned
  ! with those of $A$ and $a_{j,k}=b_{j,k-j+r+1}$.  In this case, each
  ! column of $B$ corresponds to a diagonal of $A$ and $B$ can be
  ! chosen to be $n\times (r+s+1)$.  Routines working with this format
  ! are given the tag `_br`.  The module provides routines for getting
  ! and setting elements $a_{jk}$ of a matrix $A$ stored in this
  ! format; for applying applying rotations in a truncated manner
  ! corresponding to $j$-leading or $j$-trailing transformations; for
  ! printing band matrices in a readable format; and for converting
  ! between different storage formats.

  private

  public :: get_el_bc, d_get_el_bc, z_get_el_bc, &
       set_el_bc, d_set_el_bc, z_set_el_bc, &
       get_el_br, d_get_el_br, z_get_el_br, &
       set_el_br, d_set_el_br, z_set_el_br

  public :: bc_to_general, d_bc_to_general, z_bc_to_general, &
       br_to_general, d_br_to_general, z_br_to_general

  public :: print_bc, d_print_bc, z_print_bc, &
       print_br, d_print_br, z_print_br, &
       print_abs_bc, d_print_abs_bc, z_print_abs_bc, &
       print_abs_br, d_print_abs_br, z_print_abs_br

  public :: f_rotation_times_tbc, f_d_rotation_times_tbc, &
       f_z_rotation_times_tbc, f_tbc_times_rotation, f_d_tbc_times_rotation, &
       f_z_tbc_times_rotation, f_tbr_times_rotation, f_d_tbr_times_rotation, &
       f_z_tbr_times_rotation, f_rotation_times_tbr, f_d_rotation_times_tbr, &
       f_z_rotation_times_tbr

  public :: rotation_times_tbc, d_rotation_times_tbc, z_rotation_times_tbc, &
       tbc_times_rotation, d_tbc_times_rotation, z_tbc_times_rotation, &
       tbr_times_rotation, d_tbr_times_rotation, z_tbr_times_rotation, &
       rotation_times_tbr, d_rotation_times_tbr, z_rotation_times_tbr

  public :: bc_to_br, d_bc_to_br, z_bc_to_br, &
       br_to_bc, d_br_to_bc, z_br_to_bc

  public :: extract_diagonals_bc, d_extract_diagonals_bc, &
       z_extract_diagonals_bc, extract_diagonals_br, d_extract_diagonals_br, &
       z_extract_diagonals_br

  public :: truncate_profile_bc, d_truncate_profile_bc, z_truncate_profile_bc, &
       truncate_profile_br, d_truncate_profile_br, z_truncate_profile_br

  public :: d_band_norm_bc, z_band_norm_bc, band_norm_bc, &
       d_band_norm_br, z_band_norm_br, band_norm_br

  interface get_el_bc
     module procedure d_get_el_bc, z_get_el_bc
  end interface get_el_bc

  interface set_el_bc
     module procedure d_set_el_bc, z_set_el_bc
  end interface set_el_bc

  interface get_el_br
     module procedure d_get_el_br, z_get_el_br
  end interface get_el_br

  interface set_el_br
     module procedure d_set_el_br, z_set_el_br
  end interface set_el_br

  ! to general

  interface bc_to_general
     module procedure d_bc_to_general, z_bc_to_general
  end interface bc_to_general

  interface br_to_general
     module procedure d_br_to_general, z_br_to_general
  end interface br_to_general

  ! printing

  interface print_bc
     module procedure d_print_bc, z_print_bc
  end interface print_bc

  interface print_br
     module procedure d_print_br, z_print_br
  end interface print_br

  interface print_abs_bc
     module procedure d_print_abs_bc, z_print_abs_bc
  end interface print_abs_bc

  interface print_abs_br
     module procedure d_print_abs_br, z_print_abs_br
  end interface print_abs_br

  ! rotations

  interface f_rotation_times_tbc
     module procedure f_d_rotation_times_tbc, f_z_rotation_times_tbc
  end interface f_rotation_times_tbc

  interface f_tbc_times_rotation
     module procedure f_d_tbc_times_rotation, f_z_tbc_times_rotation
  end interface f_tbc_times_rotation

  interface f_tbr_times_rotation
     module procedure f_d_tbr_times_rotation, f_z_tbr_times_rotation
  end interface f_tbr_times_rotation

  interface f_rotation_times_tbr
     module procedure f_d_rotation_times_tbr, f_z_rotation_times_tbr
  end interface f_rotation_times_tbr

  interface rotation_times_tbc
     module procedure d_rotation_times_tbc, z_rotation_times_tbc
  end interface rotation_times_tbc

  interface tbc_times_rotation
     module procedure d_tbc_times_rotation, z_tbc_times_rotation
  end interface tbc_times_rotation

  interface tbr_times_rotation
     module procedure d_tbr_times_rotation, z_tbr_times_rotation
  end interface tbr_times_rotation

  interface rotation_times_tbr
     module procedure d_rotation_times_tbr, z_rotation_times_tbr
  end interface rotation_times_tbr

  ! conversions

  interface bc_to_br
     module procedure d_bc_to_br, z_bc_to_br
  end interface bc_to_br

  interface br_to_bc
     module procedure d_br_to_bc, z_br_to_bc
  end interface br_to_bc

  interface extract_diagonals_br
     module procedure d_extract_diagonals_br, z_extract_diagonals_br
  end interface extract_diagonals_br

  interface extract_diagonals_bc
     module procedure d_extract_diagonals_bc, z_extract_diagonals_bc
  end interface extract_diagonals_bc

  interface truncate_profile_bc
     module procedure d_truncate_profile_bc, z_truncate_profile_bc
  end interface truncate_profile_bc

  interface truncate_profile_br
     module procedure d_truncate_profile_br, z_truncate_profile_br
  end interface truncate_profile_br

  interface band_norm_bc
     module procedure d_band_norm_bc, z_band_norm_bc
  end interface band_norm_bc

  interface band_norm_br
     module procedure d_band_norm_br, z_band_norm_br
  end interface band_norm_br

contains

  ! Get and set functions for band row and band column.

  real(kind=dp) function d_get_el_bc(bc,ubw,j,k) result(x)
    real(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw,j,k
    !
    x=bc(j-k+ubw+1,k)
  end function d_get_el_bc

  complex(kind=dp) function z_get_el_bc(bc,ubw,j,k) result(x)
    complex(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw,j,k
    !
    x=bc(j-k+ubw+1,k)
  end function z_get_el_bc

  subroutine d_set_el_bc(bc,ubw,j,k,x)
    real(kind=dp), dimension(:,:), intent(inout) :: bc
    integer(kind=int32), intent(in) :: ubw,j,k
    real(kind=dp), intent(in) :: x
    !
    bc(j-k+ubw+1,k) = x
  end subroutine d_set_el_bc

  subroutine z_set_el_bc(bc,ubw,j,k,x)
    complex(kind=dp), dimension(:,:), intent(inout) :: bc
    integer(kind=int32), intent(in) :: ubw,j,k
    complex(kind=dp), intent(in) :: x
    !
    bc(j-k+ubw+1,k) = x
  end subroutine z_set_el_bc

  real(kind=dp) function d_get_el_br(br,lbw,j,k) result(x)
    real(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: lbw,j,k
    !
    x=br(j,k-j+lbw+1)
  end function d_get_el_br

  complex(kind=dp) function z_get_el_br(br,lbw,j,k) result(x)
    complex(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: lbw,j,k
    !
    x=br(j,k-j+lbw+1)
  end function z_get_el_br

  subroutine d_set_el_br(br,lbw,j,k,x)
    real(kind=dp), dimension(:,:), intent(inout) :: br
    integer(kind=int32), intent(in) :: lbw,j,k
    real(kind=dp), intent(in) :: x
    !
    br(j,k-j+lbw+1)=x
  end subroutine d_set_el_br

  subroutine z_set_el_br(br,lbw,j,k,x)
    complex(kind=dp), dimension(:,:), intent(inout) :: br
    integer(kind=int32), intent(in) :: lbw,j,k
    complex(kind=dp), intent(in) :: x
    !
    br(j,k-j+lbw+1)=x
  end subroutine z_set_el_br

  ! band to general

  subroutine d_bc_to_general(bc,lbw,ubw,a)
    real(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw, lbw
    real(kind=dp), dimension(:,:), intent(out) :: a
    !
    integer(kind=int32) :: d, n, k
    a=0.0_dp
    n=size(bc,2)
    do d=1,ubw+1
       do k=ubw-d+2,n
          a(d+k-ubw-1,k)=bc(d,k)
       end do
    end do
    do d=ubw+2, ubw+lbw+1
       do k=1,n-d+ubw+1
          a(d+k-ubw-1,k)=bc(d,k)
       end do
    end do
  end subroutine d_bc_to_general

  subroutine z_bc_to_general(bc,lbw,ubw,a)
    complex(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw, lbw
    complex(kind=dp), dimension(:,:), intent(out) :: a
    !
    integer(kind=int32) :: d, n, k
    a=(0.0_dp,0.0_dp)
    n=size(bc,2)
    do d=1,ubw+1
       do k=ubw-d+2,n
          a(d+k-ubw-1,k)=bc(d,k)
       end do
    end do
    do d=ubw+2, ubw+lbw+1
       do k=1,n-d+ubw+1
          a(d+k-ubw-1,k)=bc(d,k)
       end do
    end do
  end subroutine z_bc_to_general

  subroutine d_br_to_general(br,lbw,ubw,a)
    real(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: ubw, lbw
    real(kind=dp), dimension(:,:), intent(out) :: a
    !
    integer(kind=int32) :: d, n, j
    a=0.0_dp
    n=size(br,1)
    do d=1,lbw+1
       do j=lbw-d+2, n
          a(j,d+j-lbw-1)=br(j,d)
       end do
    end do
    do d=lbw+2,ubw+lbw+1
       do j=1, n-d+lbw+1
          a(j,d+j-lbw-1)=br(j,d)
       end do
    end do
  end subroutine d_br_to_general

  subroutine z_br_to_general(br,lbw,ubw,a)
    complex(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: ubw, lbw
    complex(kind=dp), dimension(:,:), intent(out) :: a
    !
    integer(kind=int32) :: d, n, j
    a=(0.0_dp,0.0_dp)
    n=size(br,1)
    do d=1,lbw+1
       do j=lbw-d+2, n
          a(j,d+j-lbw-1)=br(j,d)
       end do
    end do
    do d=lbw+2,ubw+lbw+1
       do j=1, n-d+lbw+1
          a(j,d+j-lbw-1)=br(j,d)
       end do
    end do
  end subroutine z_br_to_general

  ! printing

  subroutine d_print_bc(bc,lbw,ubw)
    real(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    real(kind=dp), dimension(size(bc,2),size(bc,2)) :: a
    call d_bc_to_general(bc,lbw,ubw,a)
    call print_matrix(a)
  end subroutine d_print_bc

  subroutine z_print_bc(bc,lbw,ubw)
    complex(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    complex(kind=dp), dimension(size(bc,2),size(bc,2)) :: a
    call z_bc_to_general(bc,lbw,ubw,a)
    call print_matrix(a)
  end subroutine z_print_bc

  subroutine d_print_br(br,lbw,ubw)
    real(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    real(kind=dp), dimension(size(br,1),size(br,1)) :: a
    call d_br_to_general(br,lbw,ubw,a)
    call print_matrix(a)
  end subroutine d_print_br

  subroutine z_print_br(br,lbw,ubw)
    complex(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    complex(kind=dp), dimension(size(br,1),size(br,1)) :: a
    call z_br_to_general(br,lbw,ubw,a)
    call print_matrix(a)
  end subroutine z_print_br

  ! abs print

  subroutine d_print_abs_bc(bc,lbw,ubw)
    real(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    real(kind=dp), dimension(size(bc,2),size(bc,2)) :: a
    call d_bc_to_general(bc,lbw,ubw,a)
    call print_matrix(abs(a))
  end subroutine d_print_abs_bc

  subroutine z_print_abs_bc(bc,lbw,ubw)
    complex(kind=dp), dimension(:,:), intent(in) :: bc
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    complex(kind=dp), dimension(size(bc,2),size(bc,2)) :: a
    call z_bc_to_general(bc,lbw,ubw,a)
    call print_matrix(abs(a))
  end subroutine z_print_abs_bc

  subroutine d_print_abs_br(br,lbw,ubw)
    real(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    real(kind=dp), dimension(size(br,1),size(br,1)) :: a
    call d_br_to_general(br,lbw,ubw,a)
    call print_matrix(abs(a))
  end subroutine d_print_abs_br

  subroutine z_print_abs_br(br,lbw,ubw)
    complex(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: ubw, lbw
    !
    complex(kind=dp), dimension(size(br,1),size(br,1)) :: a
    call z_br_to_general(br,lbw,ubw,a)
    call print_matrix(abs(a))
  end subroutine z_print_abs_br

  ! Rotations applied to band matrices.
  !
  ! In applying rotations to a band matrix:
  !
  ! Column k has nonzeros in rows [max(k-ubw,1),min(k+lbw,m)]
  ! Column k+1 has nonzeros in rows [max(k-ubw+1,1),min(k+1+lbw,m)]
  ! A rotation acting from the right in columns k and k+1
  ! acts on the intersection of these row sets: [max(k-ubw+1,1),min(k+1+lbw,m)].
  !
  ! Row j has nonzeros in columns [max(1,j-lbw), min(j+ubw,n)]
  ! Row j+1 has nonzeros in columns [max(1,j+1-lbw), min(j+1+ubw,n)]
  ! A rotation acting on rows j and j+1 acts on the intersection:
  ! [max(1,j+1-lbw),min(n,j+ubw)]

  ! Rotations for band matrices with aligned columns
  !
  ! Rotation times truncated band matrix with aligned columns.
  ! First l and last p columns are not modified.

  subroutine f_d_rotation_times_tbc(c,s,b,n,lbw,ubw,l,p,j)
    real(kind=dp), dimension(:,:), intent(inout) :: b
    real(kind=dp), intent(in) :: c, s
    integer(kind=int32), intent(in) :: j,n, ubw,lbw, l, p
    !
    real(kind=dp) :: tmp
    integer(kind=int32) :: k, k0, k1, d
    ! first and last columns operated on, given by the
    ! intersection of [l+1,n-p] and [max(1,j+1-lbw),min(n,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(n-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(n-p,j+ubw)
    ! loop over relevant columns in b.
    do k=k0,k1
       d=j-k+ubw+1
       tmp = b(d,k)
       b(d,k)=c*tmp - s*b(d+1,k)
       b(d+1,k) = s*tmp + c*b(d+1,k)
    end do
  end subroutine f_d_rotation_times_tbc

  subroutine d_rotation_times_tbc(r,b,n,lbw,ubw,l,p,j)
    real(kind=dp), dimension(:,:), intent(inout) :: b
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j,n, ubw,lbw, l, p
    !
    real(kind=dp) :: c, s, tmp
    integer(kind=int32) :: k, k0, k1, d
    c=r%cosine; s=r%sine
    ! first and last columns operated on, given by the
    ! intersection of [l+1,n-p] and [max(1,j+1-lbw),min(n,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(n-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(n-p,j+ubw)
    ! loop over relevant columns in b.
    do k=k0,k1
       d=j-k+ubw+1
       tmp = b(d,k)
       b(d,k)=c*tmp - s*b(d+1,k)
       b(d+1,k) = s*tmp + c*b(d+1,k)
    end do
  end subroutine d_rotation_times_tbc

  ! Rotation times truncated band matrix with aligned columns.
  ! First l and last p columns are not modified.
  subroutine f_z_rotation_times_tbc(c,s,b,n,lbw,ubw,l,p,j)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    complex(kind=dp), intent(in) :: s
    real(kind=dp), intent(in) :: c
    integer(kind=int32), intent(in) :: j,n, ubw,lbw, l, p
    !
    complex(kind=dp) :: tmp
    integer(kind=int32) :: k, k0, k1, d
    ! first and last columns operated on, given by the
    ! intersection of [l+1,n-p] and [max(1,j+1-lbw),min(n,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(n-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(n-p,j+ubw)
    ! loop over relevant columns in b.
    do k=k0,k1
       d=j-k+ubw+1
       tmp = b(d,k)
       b(d,k)=c*tmp - conjg(s)*b(d+1,k)
       b(d+1,k) = s*tmp + c*b(d+1,k)
    end do
  end subroutine f_z_rotation_times_tbc

  ! Rotation times truncated band matrix with aligned columns.
  ! First l and last p columns are not modified.
  subroutine z_rotation_times_tbc(r,b,n,lbw,ubw,l,p,j)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j,n, ubw,lbw, l, p
    !
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    integer(kind=int32) :: k, k0, k1, d
    c=r%cosine; s=r%sine
    ! first and last columns operated on, given by the
    ! intersection of [l+1,n-p] and [max(1,j+1-lbw),min(n,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(n-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(n-p,j+ubw)
    ! loop over relevant columns in b.
    do k=k0,k1
       d=j-k+ubw+1
       tmp = b(d,k)
       b(d,k)=c*tmp - conjg(s)*b(d+1,k)
       b(d+1,k) = s*tmp + c*b(d+1,k)
    end do
  end subroutine z_rotation_times_tbc

  ! apply a rotation to columns k and k+1 of a truncated band matrix with
  ! aligned columns. first l and last p rows are not modified.
  subroutine f_d_tbc_times_rotation(b,n,lbw,ubw,l,p,c,s,k)
    real(kind=dp), dimension(:,:), intent(inout) :: b
    real(kind=dp), intent(in) :: c, s
    integer(kind=int32), intent(in) :: k,n, ubw,lbw, l, p
    !
    real(kind=dp) :: tmp
    integer(kind=int32) :: d, j0, j1, j
    ! first and last rows operated on are given by the intersection
    ! of [l+1,n-p] with [max(k-ubw+1,1),min(k+lbw,n)] which is
    ! [max(l+1,k-ubw+1),min(k+lbw,n-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,n-p)
    do j=j0,j1
       d=j-k+ubw+1
       tmp=b(d,k)
       b(d,k)=c*tmp+s*b(d-1,k+1)
       b(d-1,k+1)=-s*tmp+c*b(d-1,k+1)
    end do
  end subroutine f_d_tbc_times_rotation

  ! apply a rotation to columns k and k+1 of a truncated band matrix with
  ! aligned columns. first l and last p rows are not modified.
  subroutine d_tbc_times_rotation(b,n,lbw,ubw,l,p,r,k)
    real(kind=dp), dimension(:,:), intent(inout) :: b
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k,n, ubw,lbw, l, p
    !
    real(kind=dp) :: c, s, tmp
    integer(kind=int32) :: d, j0, j1, j
    c=r%cosine; s=r%sine
    ! first and last rows operated on are given by the intersection
    ! of [l+1,n-p] with [max(k-ubw+1,1),min(k+lbw,n)] which is
    ! [max(l+1,k-ubw+1),min(k+lbw,n-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,n-p)
    do j=j0,j1
       d=j-k+ubw+1
       tmp=b(d,k)
       b(d,k)=c*tmp+s*b(d-1,k+1)
       b(d-1,k+1)=-s*tmp+c*b(d-1,k+1)
    end do
  end subroutine d_tbc_times_rotation

  subroutine f_z_tbc_times_rotation(b,n,lbw,ubw,l,p,c,s,k)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    complex(kind=dp), intent(in) :: s
    real(kind=dp), intent(in) :: c
    integer(kind=int32), intent(in) :: k,n, ubw,lbw, l, p
    !
    complex(kind=dp) :: tmp
    integer(kind=int32) :: d, j0, j1, j
    ! first and last rows operated on are given by the intersection
    ! of [l+1,n-p] with [max(k-ubw+1,1),min(k+lbw,n)] which is
    ! [max(l+1,k-ubw+1),min(k+lbw,n-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,n-p)
    do j=j0,j1
       d=j-k+ubw+1
       tmp=b(d,k)
       b(d,k)=c*tmp+s*b(d-1,k+1)
       b(d-1,k+1)=-conjg(s)*tmp+c*b(d-1,k+1)
    end do
  end subroutine f_z_tbc_times_rotation

  subroutine z_tbc_times_rotation(b,n,lbw,ubw,l,p,r,k)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k,n, ubw,lbw, l, p
    !
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    integer(kind=int32) :: d, j0, j1, j
    c=r%cosine; s=r%sine
    ! first and last rows operated on are given by the intersection
    ! of [l+1,n-p] with [max(k-ubw+1,1),min(k+lbw,n)] which is
    ! [max(l+1,k-ubw+1),min(k+lbw,n-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,n-p)
    do j=j0,j1
       d=j-k+ubw+1
       tmp=b(d,k)
       b(d,k)=c*tmp+s*b(d-1,k+1)
       b(d-1,k+1)=-conjg(s)*tmp+c*b(d-1,k+1)
    end do
  end subroutine z_tbc_times_rotation

  ! rotations for band matrices with aligned rows.
  !
  ! apply a rotation to columns k and k+1 of a truncated band matrix with
  ! aligned rows. The rotation is not applied to the first l or last p rows.
  subroutine f_d_tbr_times_rotation(b,m,lbw,ubw,l,p,c,s,k)
    real(kind=dp), dimension(:, :), intent(inout) :: b
    real(kind=dp), intent(in) :: c, s
    integer(kind=int32), intent(in) :: k,m, ubw,lbw, l,p
    !
    real(kind=dp) :: tmp
    integer(kind=int32) :: j, j0, j1, d
    ! first and last rows operated on are given by
    ! the intersection of [l+1,m-p] and [max(k-ubw+1,1),min(k+lbw,m)]
    ! which is [max(l+1,k-ubw+1), min(k+lbw,m-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,m-p)
    do j=j0,j1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp+s*b(j,d+1)
       b(j,d+1)=-s*tmp+c*b(j,d+1)
    end do
  end subroutine f_d_tbr_times_rotation

  ! apply a rotation to columns k and k+1 of a truncated band matrix with
  ! aligned rows. The rotation is not applied to the first l or last p rows.
  subroutine d_tbr_times_rotation(b,m,lbw,ubw,l,p,r,k)
    real(kind=dp), dimension(:, :), intent(inout) :: b
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k,m, ubw,lbw, l,p
    !
    real(kind=dp) :: c, s, tmp
    integer(kind=int32) :: j, j0, j1, d
    c=r%cosine; s=r%sine
    ! first and last rows operated on are given by
    ! the intersection of [l+1,m-p] and [max(k-ubw+1,1),min(k+lbw,m)]
    ! which is [max(l+1,k-ubw+1), min(k+lbw,m-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,m-p)
    do j=j0,j1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp+s*b(j,d+1)
       b(j,d+1)=-s*tmp+c*b(j,d+1)
    end do
  end subroutine d_tbr_times_rotation

  subroutine f_z_tbr_times_rotation(b,m,lbw,ubw,l,p,c,s,k)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    complex(kind=dp), intent(in) :: s
    real(kind=dp), intent(in) :: c
    integer(kind=int32), intent(in) :: k,m, ubw,lbw, l, p
    !
    complex(kind=dp) :: tmp
    integer(kind=int32) :: j, j0, j1, d
    ! first and last rows operated on are given by
    ! the intersection of [l+1,m-p] and [max(k-ubw+1,1),min(k+lbw,m)]
    ! which is [max(l+1,k-ubw+1), min(k+lbw,m-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,m-p)
    do j=j0,j1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp+s*b(j,d+1)
       b(j,d+1)=-conjg(s)*tmp+c*b(j,d+1)
    end do
  end subroutine f_z_tbr_times_rotation

  subroutine z_tbr_times_rotation(b,m,lbw,ubw,l,p,r,k)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: k,m, ubw,lbw, l, p
    !
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    integer(kind=int32) :: j, j0, j1, d
    c=r%cosine; s=r%sine
    ! first and last rows operated on are given by
    ! the intersection of [l+1,m-p] and [max(k-ubw+1,1),min(k+lbw,m)]
    ! which is [max(l+1,k-ubw+1), min(k+lbw,m-p)]
    j0=max(l+1,k-ubw+1)
    j1=min(k+lbw,m-p)
    do j=j0,j1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp+s*b(j,d+1)
       b(j,d+1)=-conjg(s)*tmp+c*b(j,d+1)
    end do
  end subroutine z_tbr_times_rotation

  ! A rotation times a truncated band matrix with aligned rows.  The
  ! rotation is not applied to the first l or last p columns.
  subroutine f_d_rotation_times_tbr(c,s,b,m,lbw,ubw,l,p,j)
    real(kind=dp), dimension(:,:), intent(inout) :: b
    real(kind=dp), intent(in) :: c, s
    integer(kind=int32), intent(in) :: j,m, ubw,lbw, l, p
    !
    real(kind=dp) :: tmp
    integer(kind=int32) :: d, k0,k1,k
    ! first and last columns operated on, given by the
    ! intersection of [l+1,m-p] and [max(1,j+1-lbw),min(m,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(m-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(m-p,j+ubw)
    do k=k0,k1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp-s*b(j+1,d-1)
       b(j+1,d-1)=s*tmp+c*b(j+1,d-1)
    end do
  end subroutine f_d_rotation_times_tbr

  ! A rotation times a truncated band matrix with aligned rows.  The
  ! rotation is not applied to the first l or last p columns.
  subroutine d_rotation_times_tbr(r,b,m,lbw,ubw,l,p,j)
    real(kind=dp), dimension(:,:), intent(inout) :: b
    type(d_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j,m, ubw,lbw, l, p
    !
    real(kind=dp) :: c, s, tmp
    integer(kind=int32) :: d, k0,k1,k
    c=r%cosine; s=r%sine
    ! first and last columns operated on, given by the
    ! intersection of [l+1,m-p] and [max(1,j+1-lbw),min(m,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(m-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(m-p,j+ubw)
    do k=k0,k1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp-s*b(j+1,d-1)
       b(j+1,d-1)=s*tmp+c*b(j+1,d-1)
    end do
  end subroutine d_rotation_times_tbr

  subroutine f_z_rotation_times_tbr(c,s,b,m,lbw,ubw,l,p,j)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    complex(kind=dp), intent(in) :: s
    real(kind=dp), intent(in) :: c
    integer(kind=int32), intent(in) :: j,m, ubw,lbw, l,p
    !
    complex(kind=dp) :: tmp
    integer(kind=int32) :: d, k0,k1,k
    ! first and last columns operated on, given by the
    ! intersection of [l+1,m-p] and [max(1,j+1-lbw),min(m,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(m-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(m-p,j+ubw)
    do k=k0,k1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp-conjg(s)*b(j+1,d-1)
       b(j+1,d-1)=s*tmp+c*b(j+1,d-1)
    end do
  end subroutine f_z_rotation_times_tbr

  subroutine z_rotation_times_tbr(r,b,m,lbw,ubw,l,p,j)
    complex(kind=dp), dimension(:,:), intent(inout) :: b
    type(z_rotation), intent(in) :: r
    integer(kind=int32), intent(in) :: j,m, ubw,lbw, l,p
    !
    complex(kind=dp) :: s, tmp
    real(kind=dp) :: c
    integer(kind=int32) :: d, k0,k1,k
    c=r%cosine; s=r%sine
    ! first and last columns operated on, given by the
    ! intersection of [l+1,m-p] and [max(1,j+1-lbw),min(m,j+ubw)]
    ! which is [maxl+1,max(1,j+1-lbw)), min(m-p,min(n,j+ubw))]
    k0=max(l+1,j+1-lbw)
    k1=min(m-p,j+ubw)
    do k=k0,k1
       d=k-j+lbw+1
       tmp=b(j,d)
       b(j,d)=c*tmp-conjg(s)*b(j+1,d-1)
       b(j+1,d-1)=s*tmp+c*b(j+1,d-1)
    end do
  end subroutine z_rotation_times_tbr

  subroutine d_bc_to_br(bc,br,lbw,ubw)
    real(kind=dp), dimension(:,:), intent(in) :: bc
    real(kind=dp), dimension(:,:), intent(out) :: br
    integer(kind=int32), intent(in) :: lbw, ubw

    integer(kind=int32) :: d, j, n
    n=size(bc,2)
    do d=1,lbw+1
       do j=1,n-lbw+d-1
          br(lbw-d+j+1,d)=bc(ubw+lbw+2-d,j)
       end do
    end do
    do d=lbw+2,lbw+ubw+1
       do j=1,n-d+lbw+1
          br(j,d)=bc(ubw+lbw+2-d,j+d-lbw-1)
       end do
    end do
  end subroutine d_bc_to_br

  subroutine z_bc_to_br(bc,br,lbw,ubw)
    complex(kind=dp), dimension(:,:), intent(in) :: bc
    complex(kind=dp), dimension(:,:), intent(out) :: br
    integer(kind=int32), intent(in) :: lbw, ubw

    integer(kind=int32) :: d, j, n
    n=size(bc,2)
    do d=1,lbw+1
       do j=1,n-lbw+d-1
          br(lbw-d+j+1,d)=bc(ubw+lbw+2-d,j)
       end do
    end do
    do d=lbw+2,lbw+ubw+1
       do j=1,n-d+lbw+1
          br(j,d)=bc(ubw+lbw+2-d,j+d-lbw-1)
       end do
    end do
  end subroutine z_bc_to_br

  subroutine d_br_to_bc(br,bc,lbw,ubw)
    real(kind=dp), dimension(:,:), intent(out) :: bc
    real(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: lbw, ubw

    integer(kind=int32) :: d, j, n

    n=size(bc,2)
    do d=1,lbw+1
       do j=1,n-lbw+d-1
          bc(ubw+lbw+2-d,j)=br(lbw-d+j+1,d)
       end do
    end do
    do d=lbw+2,lbw+ubw+1
       do j=1,n-d+lbw+1
          bc(ubw+lbw+2-d,j+d-lbw-1)=br(j,d)
       end do
    end do
  end subroutine d_br_to_bc

  subroutine z_br_to_bc(br,bc,lbw,ubw)
    complex(kind=dp), dimension(:,:), intent(out) :: bc
    complex(kind=dp), dimension(:,:), intent(in) :: br
    integer(kind=int32), intent(in) :: lbw, ubw

    integer(kind=int32) :: d, j, n
    n=size(bc,2)
    do d=1,lbw+1
       do j=1,n-lbw+d-1
          bc(ubw+lbw+2-d,j)=br(lbw-d+j+1,d)
       end do
    end do
    do d=lbw+2,lbw+ubw+1
       do j=1,n-d+lbw+1
          bc(ubw+lbw+2-d,j+d-lbw-1)=br(j,d)
       end do
    end do
  end subroutine z_br_to_bc

  subroutine d_extract_diagonals_bc(a, n, b, lbw, ubw, lbwmax, ubwmax)
    real(kind=dp), target, dimension(n,n), intent(in) :: a
    real(kind=dp), dimension(lbwmax+ubwmax+1,n), intent(out) :: b
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax
    !
    integer(kind=int32) :: k, d
    ! put diagonals in b
    b=0.0_dp
    do d=1,ubw+1
       do k=ubw-d+2,n
          b(d,k) = a(d+k-ubw-1,k)
       end do
    end do
    do d=ubw+2, ubw+lbw+1
       do k=1,n-d+ubw+1
          b(d,k) = a(d+k-ubw-1,k)
       end do
    end do
  end subroutine d_extract_diagonals_bc

  subroutine z_extract_diagonals_bc(a, n, b, lbw, ubw, lbwmax, ubwmax)
    complex(kind=dp), target, dimension(n,n), intent(in) :: a
    complex(kind=dp), dimension(lbwmax+ubwmax+1,n), intent(out) :: b
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax
    !
    integer(kind=int32) :: k, d
    ! put diagonals in b
    b=0.0_dp
    do d=1,ubw+1
       do k=ubw-d+2,n
          b(d,k) = a(d+k-ubw-1,k)
       end do
    end do
    do d=ubw+2, ubw+lbw+1
       do k=1,n-d+ubw+1
          b(d,k) = a(d+k-ubw-1,k)
       end do
    end do
  end subroutine z_extract_diagonals_bc

  subroutine d_extract_diagonals_br(a, n, b, lbw, ubw, lbwmax, ubwmax)
    real(kind=dp), target, dimension(n,n), intent(in) :: a
    real(kind=dp), dimension(n,lbwmax+ubwmax+1), intent(out) :: b
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax
    !
    integer(kind=int32) :: j, d
    ! put diagonals in b
    b=0.0_dp
    do d=1,lbw+1
       do j=lbw-d+2, n
          b(j,d)=a(j,d+j-lbw-1)
       end do
    end do
    do d=lbw+2,ubw+lbw+1
       do j=1, n-d+lbw+1
          b(j,d)=a(j,d+j-lbw-1)
       end do
    end do
  end subroutine d_extract_diagonals_br

  subroutine z_extract_diagonals_br(a, n, b, lbw, ubw, lbwmax, ubwmax)
    complex(kind=dp), target, dimension(n,n), intent(in) :: a
    complex(kind=dp), dimension(n,lbwmax+ubwmax+1), intent(out) :: b
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax
    !
    integer(kind=int32) :: j, d
    ! put diagonals in b
    b=0.0_dp
    do d=1,lbw+1
       do j=lbw-d+2, n
          b(j,d)=a(j,d+j-lbw-1)
       end do
    end do
    do d=lbw+2,ubw+lbw+1
       do j=1, n-d+lbw+1
          b(j,d)=a(j,d+j-lbw-1)
       end do
    end do
  end subroutine z_extract_diagonals_br

  ! Impose a particular upper and lower variable bandwidth on a band
  ! matrix.  Used for generating random band matrices for tests.
  subroutine d_truncate_profile_br(br,n,lbw,lbwmax,ubwmax,lower,upper)
    real(kind=dp), dimension(n,lbwmax+ubwmax+1), intent(inout) :: br
    integer(kind=int32), intent(in) :: n, lbw, lbwmax, ubwmax
    integer(kind=int32), dimension(n), intent(in), optional :: lower, upper

    integer(kind=int32) :: j

    if (present(upper)) then
       do j=1,n
          br(j,lbw+2+upper(j):lbwmax+ubwmax+1) = 0.0_dp
       end do
    end if

    if (present(lower)) then
       do j=1,n
          br(j,1:lbw-lower(j)) = 0.0_dp
       end do
    end if

  end subroutine d_truncate_profile_br

  subroutine z_truncate_profile_br(br,n,lbw,lbwmax,ubwmax,lower,upper)
    complex(kind=dp), dimension(n,lbwmax+ubwmax+1), intent(inout) :: br
    integer(kind=int32), intent(in) :: n, lbw, lbwmax, ubwmax
    integer(kind=int32), dimension(n), intent(in), optional :: lower, upper

    integer(kind=int32) :: j

    if (present(upper)) then
       do j=1,n
          br(j,lbw+2+upper(j):lbwmax+ubwmax+1) = (0.0_dp,0.0_dp)
       end do
    end if

    if (present(lower)) then
       do j=1,n
          br(j,1:lbw-lower(j)) = (0.0_dp,0.0_dp)
       end do
    end if
  end subroutine z_truncate_profile_br

  subroutine d_truncate_profile_bc(bc,n,ubw,lbwmax,ubwmax,lower,upper)
    real(kind=dp), dimension(lbwmax+ubwmax+1,n), intent(inout) :: bc
    integer(kind=int32), intent(in) :: n, ubw, lbwmax, ubwmax
    integer(kind=int32), dimension(n), intent(in), optional :: lower, upper

    integer(kind=int32) :: j

    if (present(upper)) then
       do j=1,n
          bc(1:ubw-upper(j),j)=0.0_dp
       end do
    end if

    if (present(lower)) then
       do j=1,n
          bc(ubw+2+lower(j):lbwmax+ubwmax+1,j)=0.0_dp
       end do
    end if

  end subroutine d_truncate_profile_bc

  subroutine z_truncate_profile_bc(bc,n,ubw,lbwmax,ubwmax,lower,upper)
    complex(kind=dp), dimension(lbwmax+ubwmax+1,n), intent(inout) :: bc
    integer(kind=int32), intent(in) :: n, ubw, lbwmax, ubwmax
    integer(kind=int32), dimension(n), intent(in), optional :: lower, upper

    integer(kind=int32) :: j

    if (present(upper)) then
       do j=1,n
          bc(1:ubw-upper(j),j)=(0.0_dp,0.0_dp)
       end do
    end if

    if (present(lower)) then
       do j=1,n
          bc(ubw+2+lower(j):lbwmax+ubwmax+1,j)=(0.0_dp,0.0_dp)
       end do
    end if

  end subroutine z_truncate_profile_bc

  real(kind=dp) function d_band_norm_bc(bc,n,lbw,ubw,lbwmax, &
       ubwmax,d0,d1) result(x)
    real(kind=dp), dimension(lbwmax+ubwmax+1,n), intent(in) :: bc
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax, d0, d1

    integer(kind=int32) :: k,l,l0,l1
    real(kind=dp) :: y, tmp

    l0 = ubw+1-d1
    l1 = ubw+1-d0

    y=0.0_dp
    ! maxabs for the specified band.
    do l=max(1,l0),min(ubw+1,l1)
       do k=ubw-l+2,n
          tmp=abs(bc(l,k))
          if (tmp > y) y=tmp
       end do
    end do
    do l=max(l0,ubw+2), min(ubw+lbw+1,l1)
       do k=1,n-l+ubw+1
          tmp=abs(bc(l,k))
          if (tmp > y) y=tmp
       end do
    end do
    x=0.0_dp;
    if (y==0.0_dp) return
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    y=1.0_dp/y
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do l=max(1,l0),min(ubw+1,l1)
          do k=ubw-l+2,n
             tmp=bc(l,k)*y
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,ubw+2), min(ubw+lbw+1,l1)
          do k=1,n-l+ubw+1
             tmp=bc(l,k)*y
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)/y
    else
       do l=max(1,l0),min(ubw+1,l1)
          do k=ubw-l+2,n
             tmp=bc(l,k)
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,ubw+2), min(ubw+lbw+1,l1)
          do k=1,n-l+ubw+1
             tmp=bc(l,k)
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)
    end if
  end function d_band_norm_bc

  real(kind=dp) function z_band_norm_bc(bc,n,lbw,ubw,lbwmax, &
       ubwmax,d0,d1) result(x)
    complex(kind=dp), dimension(lbwmax+ubwmax+1,n), intent(in) :: bc
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax, d0, d1

    integer(kind=int32) :: k,l,l0,l1
    real(kind=dp) :: y, tmp

    l0 = ubw+1-d1
    l1 = ubw+1-d0

    y=0.0_dp
    ! maxabs for the specified band.
    do l=max(1,l0),min(ubw+1,l1)
       do k=ubw-l+2,n
          tmp=abs(bc(l,k))
          if (tmp > y) y=tmp
       end do
    end do
    do l=max(l0,ubw+2), min(ubw+lbw+1,l1)
       do k=1,n-l+ubw+1
          tmp=abs(bc(l,k))
          if (tmp > y) y=tmp
       end do
    end do

    x=0.0_dp;
    if (y==0.0_dp) return
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    y=1.0_dp/y
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do l=max(1,l0),min(ubw+1,l1)
          do k=ubw-l+2,n
             tmp=abs(bc(l,k)*y)
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,ubw+2), min(ubw+lbw+1,l1)
          do k=1,n-l+ubw+1
             tmp=abs(bc(l,k)*y)
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)/y
    else
       do l=max(1,l0),min(ubw+1,l1)
          do k=ubw-l+2,n
             tmp=abs(bc(l,k))
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,ubw+2), min(ubw+lbw+1,l1)
          do k=1,n-l+ubw+1
             tmp=abs(bc(l,k))
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)
    end if
  end function z_band_norm_bc

  real(kind=dp) function d_band_norm_br(br,n,lbw,ubw,lbwmax, &
       ubwmax,d0,d1) result(x)
    real(kind=dp), dimension(n,lbwmax+ubwmax+1), intent(in) :: br
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax, d0, d1

    integer(kind=int32) :: j,l,l0,l1
    real(kind=dp) :: y, tmp

    l0 = d0+lbw+1
    l1 = d1+lbw+1

    y=0.0_dp
    ! maxabs for the specified band.

    do l=max(1,l0),min(lbw+1,l1)
       do j=lbw-l+2,n
          tmp=abs(br(j,l))
          if (tmp > y) y=tmp
       end do
    end do
    do l=max(l0,lbw+2), min(ubw+lbw+1,l1)
       do j=1,n-l+lbw+1
          tmp=abs(br(j,l))
          if (tmp > y) y=tmp
       end do
    end do

    x=0.0_dp;
    if (y==0.0_dp) return
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    y=1.0_dp/y
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do l=max(1,l0),min(lbw+1,l1)
          do j=lbw-l+2,n
             tmp=br(j,l)*y
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,lbw+2), min(ubw+lbw+1,l1)
          do j=1,n-l+lbw+1
             tmp=br(j,l)*y
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)/y
    else
       do l=max(1,l0),min(lbw+1,l1)
          do j=lbw-l+2,n
             tmp=br(j,l)
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,lbw+2), min(ubw+lbw+1,l1)
          do j=1,n-l+lbw+1
             tmp=br(j,l)
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)
    end if
  end function d_band_norm_br

  real(kind=dp) function z_band_norm_br(br,n,lbw,ubw,lbwmax, &
       ubwmax,d0,d1) result(x)
    complex(kind=dp), dimension(n,lbwmax+ubwmax+1), intent(in) :: br
    integer(kind=int32), intent(in) :: n, lbw, ubw, lbwmax, ubwmax, d0, d1

    integer(kind=int32) :: j,l,l0,l1
    real(kind=dp) :: y, tmp

    l0 = d0+lbw+1
    l1 = d1+lbw+1

    y=0.0_dp
    ! maxabs for the specified band.
    do l=max(1,l0),min(lbw+1,l1)
       do j=lbw-l+2,n
          tmp=abs(br(j,l))
          if (tmp > y) y=tmp
       end do
    end do
    do l=max(l0,lbw+2), min(ubw+lbw+1,l1)
       do j=1,n-l+lbw+1
          tmp=abs(br(j,l))
          if (tmp > y) y=tmp
       end do
    end do

    x=0.0_dp;
    if (y==0.0_dp) return
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    y=1.0_dp/y
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do l=max(1,l0),min(lbw+1,l1)
          do j=lbw-l+2,n
             tmp=abs(br(j,l)*y)
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,lbw+2), min(ubw+lbw+1,l1)
          do j=1,n-l+lbw+1
             tmp=abs(br(j,l)*y)
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)/y
    else
       do l=max(1,l0),min(lbw+1,l1)
          do j=lbw-l+2,n
             tmp=abs(br(j,l))
             x=x+tmp*tmp
          end do
       end do
       do l=max(l0,lbw+2), min(ubw+lbw+1,l1)
          do j=1,n-l+lbw+1
             tmp=abs(br(j,l))
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)
    end if
  end function z_band_norm_br

end module mod_band_types


!*==drotg.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DROTG
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE DROTG(DA,DB,C,S)
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION C,DA,DB,S
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    DROTG construct givens plane rotation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] DA
!> \verbatim
!>          DA is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in,out] DB
!> \verbatim
!>          DB is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is DOUBLE PRECISION
!> \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.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DROTG(Da,Db,C,S)
      IMPLICIT NONE
!*--DROTG73
!
!  -- 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 ..
      DOUBLE PRECISION C , Da , Db , S
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      DOUBLE PRECISION r , roe , scale , z
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DABS , DSIGN , DSQRT
!     ..
      scale = DABS(Da) + DABS(Db)
      IF ( scale==0.0D0 ) THEN
         C = 1.0D0
         S = 0.0D0
         r = 0.0D0
         z = 0.0D0
      ELSE
         roe = Db
         IF ( DABS(Da)>DABS(Db) ) roe = Da
         r = scale*DSQRT((Da/scale)**2+(Db/scale)**2)
         r = DSIGN(1.0D0,roe)*r
         C = Da/r
         S = Db/r
         z = 1.0D0
         IF ( DABS(Da)>DABS(Db) ) z = S
         IF ( DABS(Db)>=DABS(Da) .AND. C/=0.0D0 ) z = 1.0D0/C
      ENDIF
      Da = r
      Db = z
      END SUBROUTINE DROTG


! { dg-do compile { target i?86-*-* x86_64-*-* } }
! { dg-options "-O2 -w" }
C fconc64.F, from CERNLIB (simplified)

      FUNCTION DFCONC(X,TAU,M)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16 WGAMMA,WLOGAM
      COMPLEX*16 CGM,CLG,CRG,I,A,B,C,TI,R,RR,U(0:3),V(0:3),W(19)
      LOGICAL LM0,LM1,LTA
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'RFCONC/DFCONC')
      DIMENSION T(7),H(9),S(5),P(11),D(-1:6)
      PARAMETER (PI  = 3.14159 26535 89793 24D+0)
      PARAMETER (RPI = 1.77245 38509 05516 03D+0)
      PARAMETER (I = (0,1))
      PARAMETER (Z1 = 1, HF = Z1/2, TH = 1+HF, C1 = Z1/10, C2 = Z1/5)
      PARAMETER (RPH = 2/PI, RPW = 2/RPI, TW = 20, NMAX = 200)
      DATA EPS /1D-14/
      ASSIGN 1 TO JP
      GO TO 20
    1 ASSIGN 2 TO JP
      GO TO 20
    2 IF(LM1) FC=2*FC/SQRT(1-X1)
      GO TO 99
   12 ASSIGN 3 TO JP
      GO TO 20
    3 IF(LM1) FC=SIGN(HF,1-X)*(TAU**2+HF**2)*SQRT(ABS(X**2-1))*FC
      GO TO 99
   13 ASSIGN 4 TO JP
      GO TO 20
    4 R1=EXP((TI-HF)*LOG(X+X)+CLG(1+TI)-CLG((TH-FM)+TI))*
     1        R*((HF-FM)+TI)/TI
      FC=RPW*R1
      IF(LM1) FC=FC/SQRT(1-X1)
      GO TO 99
   20 IF(LTA) THEN
       IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
      ELSE
       W(1)=X1*A*B/C
       R=1+W(1)
       DO 23 N = 1,NMAX
       RR=R
       W(1)=W(1)*X1*(A+FN)*(B+FN)/((C+FN)*(FN+1))
       IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
   23  CONTINUE
      END IF
   99 DFCONC=FC
      RETURN
  101 FORMAT('ILLEGAL ARGUMENT(S)  X = ',D15.8,' TAU = ',D15.8,
     1       ' M = ',I3)
  102 FORMAT('CONVERGENCE PROBLEM FOR HYPERGEOMETRIC FUNCTION, X = ',
     1        D15.8)
      END


    MODULE cdf_poisson_mod
! ----------------------------------------------------------------------

!                             cdf_poisson_mod

!                             *=*=*=*=*=*=*=*
!  -  SUBROUTINE CDF_POISSON(WHICH, CUM, CCUM, S, LAMBDA, STATUS,
!                            CHECK_INPUT )
!  -  REAL (dpkind) FUNCTION CUM_POISSON(S, LAMBDA, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_POISSON(S, LAMBDA, STATUS, CHECK_INPUT)
!  -  FUNCTION INV_POISSON(CUM, CCUM, LAMBDA, STATUS, CHECK_INPUT)

!                             The Distribution
!                             ================

!    The density of the Poisson distribution (probability of observing S
!    events) is:
!                                 S
!                           LAMBDA
!                           ------- exp(-LAMBDA)
!                             S!

!   The Poisson distribution is extended to non-integer values of S using
!   the relation between the cumulative distribution function of the
!   Poisson distribution and the gamma distribution.

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    arguments is to be calculated.
!  Input Range: [ 1:3 ]
!     1.  CUM and CCUM
!     2.  S
!     3.  LAMBDA
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the Poisson distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the Poisson
!    distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: S. The upper limit of summation of the Poisson
!    density. The lower limit is 0.
!  Range: [ 0:10^100 ]
!  - REAL (dpkind) :: LAMBDA. The mean of the Poisson distribution.
!    Range: [ 10^-10:10^100 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Posible values:
!      0 Problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 X outside range
!     -5 MEAN outside range
!     -6 SD outside range
!      3 CUM + CCUM is not nearly one
!     10 could not solve cdf_gamma in local_cum_poisson
!    -50 Answer (if any) is BELOW the LOWER bound on range
!     50 Answer (if any) is ABOVE the UPPER bound on range
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and .TRUE.
!    input argument values are not checked for validity.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_poisson, cdf_poisson, cum_poisson, inv_poisson
! ..
    CONTAINS

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

      FUNCTION ccum_poisson(s,lambda,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_poisson
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: lambda, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_poisson(which=1,ccum=ccum_poisson,s=s,lambda=lambda, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_poisson

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

      SUBROUTINE cdf_poisson(which,cum,ccum,s,lambda,status,check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE cdf_gamma_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: lambda, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
! .. Local Scalars ..
        REAL (dpkind) :: local_ccum, local_cum, s_p_1
        LOGICAL :: has_status, local_check_input
! ..
! .. Intrinsic Functions ..
        INTRINSIC MAX, PRESENT
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

! Check that at least one of cum, ccum is present in the calling list

        CALL check_complements(cum,ccum,the_poisson%name,'cum','ccum', &
          local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = s
        params(4) = lambda

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_poisson,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF
        END IF

!++++++++++++++++++++++++++++++++++++++++++++++++++
! Compute the Answers
!++++++++++++++++++++++++++++++++++++++++++++++++++

        SELECT CASE (which)

        CASE (1)
! Calculate cum and ccum

          CALL cdf_gamma(1,local_ccum,local_cum,x=lambda,shape=s+one, &
            scale=one,status=status,check_input=.FALSE.)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)
! Calculate s

          CALL cdf_gamma(3,local_ccum,local_cum,x=lambda,shape=s_p_1, &
            scale=one,status=status,check_input=.FALSE.)

          s = MAX(s_p_1-one,zero)

        CASE (3)
! Calculate lambda

          CALL cdf_gamma(2,local_ccum,local_cum,x=lambda,shape=s+one, &
            scale=one,status=status,check_input=.FALSE.)

        END SELECT

        RETURN

      END SUBROUTINE cdf_poisson

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

      FUNCTION cum_poisson(s,lambda,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_poisson
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: lambda, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_poisson(which=1,cum=cum_poisson,s=s,lambda=lambda, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_poisson

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

      FUNCTION inv_poisson(cum,ccum,lambda,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_poisson
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL, INTENT (IN) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: lambda
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_poisson(which=2,cum=cum,ccum=ccum,s=inv_poisson, &
          lambda=lambda,status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_poisson

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

    END MODULE cdf_poisson_mod


subroutine lst_comp_norm ( &
     lo, hi, &
     soln, s_l1, s_h1, &
     exac, e_l1, e_h1, &
     mask, m_l1, m_h1, &
     volb, v_l1, v_h1, &
     norm2, norm0, volume, nsoln)

  implicit none

  integer, intent(in) :: lo(1), hi(1)
  integer, intent(in) :: nsoln
  integer, intent(in) :: s_l1, s_h1
  integer, intent(in) :: e_l1, e_h1
  integer, intent(in) :: m_l1, m_h1
  integer, intent(in) :: v_l1, v_h1
  double precision, intent(inout) :: norm2(0:nsoln-1), norm0(0:nsoln-1), volume
  double precision, intent(in) :: soln(s_l1:s_h1, 0:nsoln-1)
  double precision, intent(in) :: exac(e_l1:e_h1)
  double precision, intent(in) :: mask(m_l1:m_h1)
  double precision, intent(in) :: volb(v_l1:v_h1)

  integer :: i, isoln
  double precision :: error

  do i = lo(1), hi(1)
     if (mask(i) .gt. 0.d0) then
        volume = volume + volb(i)

        do isoln = 0, nsoln-1
           error = soln(i,isoln)-exac(i)
           norm2(isoln) = norm2(isoln) + error**2 * volb(i)
           norm0(isoln) = max(norm0(isoln), abs(error))
        end do
     end if
  end do

end subroutine lst_comp_norm