program bm_ge_tests
use g_elimination
use utils

implicit none

!---------------
! Variables
!---------------

integer :: i,j,k,l,m,n,o,ub,lb,ms,pad
real(wp) :: multiplier
real(wp), allocatable :: b(:), x(:), y(:), A(:,:)
type(col), allocatable :: Row(:)
integer :: passed_tests, total_tests

!---------------
! Logic
!---------------
passed_tests = 0
total_tests = 0

! -------
! Test 1
! -------
! ub -> upper band
! lb -> lower band
ub = 2
lb = 4
! Square matrix size
ms = 6

allocate(b(ms))
allocate(x(ms))
allocate(Row(ms))

m = ub
o = -1
do i = 1, ms
  if ( i <= lb+1 ) then
    o = o + 1
  elseif ( i > ms-ub ) then
    m = m - 1
  end if
  allocate(Row(i)%col(m+o+1))
end do

Row(1)%Col = [15, 7, 7]
Row(2)%Col = [2, 7, 1, 2]
Row(3)%Col = [5, 1, 15, 2, 1]
Row(4)%Col = [3, 2, 3, 14, 1, 2]
Row(5)%Col = [1, 3, 2, 4, 12, 3]
Row(6)%Col = [2, 3, 1, 5, 13]
b = [2, 1, 2, 4, 2, 6]

call test_elimination(Row, b, ms, ub, lb, total_tests, passed_tests)

deallocate(b)
deallocate(x)
m = ub
o = -1
do i = 1, ms
  if ( i <= lb+1 ) then
    o = o + 1
  elseif ( i > ms-ub ) then
    m = m - 1
  end if
  deallocate(Row(i)%col)
end do
deallocate(Row)

! -------
! Test 2
! -------
! ub -> upper band
! lb -> lower band
ub = 4
lb = 1
! Square matrix size
ms = 8

allocate(b(ms))
allocate(x(ms))
allocate(Row(ms))

m = ub
o = -1
do i = 1, ms
  if ( i <= lb+1 ) then
    o = o + 1
  elseif ( i > ms-ub ) then
    m = m - 1
  end if
  allocate(Row(i)%col(m+o+1))
end do

Row(1)%Col = [25, 7, 7, 1, 9]
Row(2)%Col = [2, 20, 1, 2, 4, 1]
Row(3)%Col = [5, 15, 2, 1, 3, 1]
Row(4)%Col = [3, 14, 1, 2, 2, 4]
Row(5)%Col = [4, 22, 3, 5, 1]
Row(6)%Col = [2, 33, 1, 5]
Row(7)%Col = [2, 11, 1]
Row(8)%Col = [2, 10]
b = [2, 2, 2, 4, 2, 6, 7, 10]

call test_elimination(Row, b, ms, ub, lb, total_tests, passed_tests)

deallocate(b)
deallocate(x)
m = ub
o = -1
do i = 1, ms
  if ( i <= lb+1 ) then
    o = o + 1
  elseif ( i > ms-ub ) then
    m = m - 1
  end if
  deallocate(Row(i)%col)
end do
deallocate(Row)

! -------
! Test 3
! -------
! ub -> upper band
! lb -> lower band
ub = 3
lb = 3
! Square matrix size
ms = 9

allocate(b(ms))
allocate(x(ms))
allocate(Row(ms))

m = ub
o = -1
do i = 1, ms
  if ( i <= lb+1 ) then
    o = o + 1
  elseif ( i > ms-ub ) then
    m = m - 1
  end if
  allocate(Row(i)%col(m+o+1))
end do

Row(1)%Col = [0.18750, 0.10078,-0.04688,-0.00234]
Row(2)%Col = [0.10078, 0.24380,-0.03287,-0.05625,-0.00234]
Row(3)%Col = [-0.04688,-0.03287, 0.18750,-0.03522,-0.05625,-0.00234]
Row(4)%Col = [-0.00234,-0.05625,-0.03522, 0.18750,-0.03522,-0.05625,-0.00234]
Row(5)%Col = [-0.00234,-0.05625,-0.03522, 0.18750,-0.03522,-0.05625,-0.00234]
Row(6)%Col = [-0.00234,-0.05625,-0.03522, 0.18750,-0.03522,-0.05625,-0.00234]
Row(7)%Col = [-0.00234,-0.05625,-0.03522, 0.18750,-0.03287,-0.04688]
Row(8)%Col = [-0.00234,-0.05625,-0.03287, 0.24380, 0.10078]
Row(9)%Col = [-0.00234,-0.04688, 0.10078, 0.18750]

b = [-3.18305,-11.48596,-8.04394,6.70978,14.98292,6.70978,-8.04394,-11.48596,-3.18305]

call test_elimination(Row, b, ms, ub, lb, total_tests, passed_tests)

deallocate(b)
deallocate(x)
do i = 1, ms
  if ( i <= lb+1 ) then
    o = o + 1
  elseif ( i > ms-ub ) then
    m = m - 1
  end if
  deallocate(Row(i)%col)
end do
deallocate(Row)

contains

	subroutine test_elimination(Row,b,ms,ub,lb,total_tests,passed_tests)
		integer, intent(in) :: ub,lb,ms
    integer, intent(inout) :: total_tests,passed_tests
		type(col), allocatable, intent(inout) :: Row(:)
		real(wp), allocatable, intent(inout) :: b(:)
		integer :: i,j,k,l,m,n,pad
		real(wp), allocatable :: c(:), x(:), y(:), A(:,:)
    logical :: passed

    passed = .true.

		allocate(x(size(b)))
		allocate(c(size(b)))
		c(1:) = b(1:)
		allocate(A(ms,ms))
		allocate(y(ms))
		pad = 0
		k = 0
		do i = 1, ms
			k = 0
			if ( i <= lb+1 ) then
				do j = 1, size(Row(i)%col)
					k = k + 1
					A(i,k) = Row(i)%Col(j)
				end do
				do j = 1, ms - size(Row(i)%col)
					k = k + 1
					A(i,k) =  0.0
				end do
			else
				pad = pad + 1
				do j = 1, pad
					k = k + 1
					A(i,k) =  0.0
				end do
				do j = 1, size(Row(i)%col)
					k = k + 1
					A(i,k) =  Row(i)%Col(j)
				end do
				do j = pad+size(Row(i)%col), ms-1
					k = k + 1
					A(i,k) =  0.0
				end do
			end if
		end do

		write(*,*) "--- TEST BEGIN ---"
    write(*,'(A,I10)') "Test number ", total_tests+1
		write(*,*)
		write(*,*) "--- BANDED Matrix ---"
		write(*,*) "--- Before Gaussian ---"
		call pprint_band(Row,lb,ub)
		write(*,*) "--- b ---"
		write(*,fmt="(F10.5, 3X)") b
		call gaussian_elimination_banded(Row,x,b,lb,ub)
		write(*,*)
		write(*,*) "--- After Gaussian ---"
		call pprint_band(Row,lb,ub)
		write(*,*) "--- b ---"
		write(*,fmt="(F10.5, 3X)") b
		write(*,*) "--- x ---"
		write(*,fmt="(F10.5, 3X)") x
		write(*,*)
		write(*,*) "--- REGULAR Matrix ---"
		write(*,*) "--- Before Gaussian ---"

		call pprint_mat(A)
		write(*,*) "--- b ---"
		write(*,fmt="(F10.5, 3X)") c
		call gaussian_elimination(A, y, c)
		write(*,*) "--- After Gaussian ---"
		call pprint_mat(A)
		write(*,*) "--- b ---"
		write(*,fmt="(F10.5, 3X)") c
		write(*,*) "--- x ---"
		write(*,fmt="(F10.5, 3X)") y
		write(*,*)
		write(*,*)

    ! Test matrix values
    pad = 0
		k = 0
		do i = 1, ms
			k = 0
			if ( i <= lb+1 ) then
				do j = 1, size(Row(i)%col)
					k = k + 1
          if ( .not. close(A(i,k),Row(i)%Col(j),1.0_wp*1e-3) ) then
            passed = .false.
          end if
				end do
				do j = 1, ms - size(Row(i)%col)
					k = k + 1
				end do
			else
				pad = pad + 1
				do j = 1, pad
					k = k + 1
					A(i,k) =  0.0
				end do
				do j = 1, size(Row(i)%col)
					k = k + 1
          if ( .not. close(A(i,k),Row(i)%Col(j),1.0_wp*1e-3) ) then
            passed = .false.
          end if
				end do
				do j = pad+size(Row(i)%col), ms-1
					k = k + 1
				end do
			end if
		end do
    if ( .not. passed ) then
      write(*,*) "!Error on the banded matrix!"
    end if

    ! Test results
    do i = 1, size(Row)
      if ( .not. close(y(i),x(i),1.0_wp*1e-3) ) then
        passed = .false.
      end if
    end do
    if ( .not. passed ) then
      write(*,*) "!Error on the solution!"
    end if

    if ( passed ) then
      passed_tests = passed_tests + 1
      write(*,*) "Test passed"
    else
      write(*,*) "!-----------!"
      write(*,*) "!Test failed!"
      write(*,*) "!-----------!"
    end if
    total_tests = total_tests + 1
    write(*,*)
    write(*,'(A)') "!------------------------!"
		write(*,'(A,I10)') " Total tests: ", total_tests
		write(*,'(A,I10)') " Tests passed:", passed_tests
    write(*,'(A)') "!------------------------!"
    write(*,*)
    write(*,*)
	end subroutine test_elimination

end program bm_ge_tests


      PROGRAM FIR100

!***********************************************************************
!* 100 Hz Finite Impulse Response Filter Program
!*
!* FIR100 performs 100 Hz finite impulse response filtering of a
!* UDS file containing a digitized time series.  FIR100 is general
!* purpose in nature, but is used primarily to filter side impacted
!* thoracic and pelvic signals.
!*
!* The program filters a signal using a four step process.  First,
!* FIR100 uses a four-pole, zero-phase Butterworth filter with a
!* 300 Hz cutoff.  This is done to prevent aliasing in the next step,
!* subsampling to a 1600 Hz sampling rate.  After the anti-aliasing
!* filter, the signal is subsampled to exactly 1600 Hz (time
!* between data samples = .000625 seconds). This is the required
!* sampling rate for FIR100 to filter to the correct frequencies.
!* At the user's option, any bias in the signal is next removed.
!* Finally, the finite impulse response filter is applied to
!* the signal, and the signal is output in UDS format.
!*
!* The resulting passband frequency is 100 Hz, the cutoff
!* frequency is 136 Hz, the stopband frequency is 189 Hz, the
!* passband ripple is 0.0225 dB, and the stopband gain is -50 dB.
!*
!* FIR100 started out life as the BIOPROC, and is the functional
!* equivalent of BIOPROC.
!*
!* The BIAS, IIRFIL, and FIRF16 subroutines were coded by M.R.
!* Neale of VRTC.
!*
!* Programmers:
!*   H. C. Gabler,  8/1/87  Initial Release
!*   J. H. Marcus, M. R. Neale
!*
!* Language: Fortran
!*
!* Date: 2003/07/18
!***********************************************************************

      ! Headers
      INCLUDE 'uds_str.fi'
      INCLUDE 'uds_fxn.fi'
      INCLUDE 'file.fi'

      ! Variables ______________________________________________________

      RECORD /UDS_Y/  U
      RECORD /UDS_CONTROL/  C
      RECORD /FILE/  HIT, REPORT, OUTPUT_LIST

      LOGICAL ALL_BATCH, NO_BATCH, NO_INCR, ONE_PASS, NEW_HIT, EOF,
     & BATCH, REMOVE_BIAS

      INTEGER NUM_ARGS, MAX_ARGS, IOS, IOS_W, I

      PARAMETER ( MAX_ARGS = 12 )

      REAL S(NFP_L-25:NLP_U+25)

      CHARACTER CL_ARG(0:MAX_ARGS)*255, PROG_NAME*8,
     & TEMPLATE_STR*255, DIR_OUT*255,
     & FILE_NAME*255, OUT_FILE*255, DEF_FILE*255,
     & PROMPT*79,
     & REM_BIAS_CL, REM_BIAS

      ! Initializations
      PROG_NAME = 'FIR100'
      CALL FILE_INIT( HIT )
      CALL GET_CL( CL_ARG, NUM_ARGS, MAX_ARGS )
      CALL FIR100_CL( CL_ARG, NUM_ARGS, PROG_NAME, REM_BIAS_CL )
      CALL PROC_CL( CL_ARG, NUM_ARGS, PROG_NAME, TEMPLATE_STR,
     & ALL_BATCH, NO_BATCH, NO_INCR, REPORT, OUTPUT_LIST, DIR_OUT,
     & ONE_PASS, .TRUE., .TRUE. )
      PROMPT = 'UDS file name/template/hitlist?'
      PROMPT(74:) = '[done]'
      CALL UDS_CONTROL_INIT( C )
      C.CHANFORM = 'Y' ! Only accept Y-series file input

      WRITE( *, '(//25X,A//)' ) '**  FIR 100 Hz Filtering  **'

      ! Read the file name/template/hitlist
  100 CALL FILE_PROMPT( TEMPLATE_STR, PROMPT, DIR_OUT,
     & ONE_PASS, HIT, NEW_HIT, FILE_NAME, EOF )
      IF ( ( FILE_NAME .EQ. ' ' ) .OR. ( EOF ) ) GO TO 199 ! Done

      ! Batch setup
      CALL BAT_SET( ALL_BATCH, NO_BATCH, NEW_HIT, HIT, BATCH )

      ! Batch prompts
      IF ( ( NEW_HIT ) .AND. ( BATCH ) ) THEN

        ! Ask about bias removal
  101   IF ( REM_BIAS_CL .EQ. ' ' ) THEN
          WRITE( *, '(/A,54X,A/'' >> '',$)' )
     &       ' Remove bias?   (Y/N)', '[Yes]'
          READ( *, '(A)', IOSTAT=IOS ) REM_BIAS
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          CALL STR_UP( REM_BIAS )
          IF ( .NOT. ANY_CHARS( REM_BIAS, ' YN' ) ) THEN
            WRITE( *, * ) '*** Invalid response'
            GO TO 101
          END IF
          IF ( REM_BIAS .EQ. ' ' ) REM_BIAS = 'Y'
        ELSE
          REM_BIAS = REM_BIAS_CL
        END IF
        IF ( ANY_CHARS( REM_BIAS, ' Y' ) ) THEN
          REMOVE_BIAS = .TRUE.
        ELSE
          REMOVE_BIAS = .FALSE.
        END IF

      END IF

      ! Read UDS file
      CALL REP_COLS( REPORT )
      CALL UDS_GET( FILE_NAME, U, C, REPORT, IOS )
      IF ( IOS .NE. 0 ) GO TO 190

      ! Check file fields
      IF ( ( U.CURTYP .NE. 'TIME SERIES' ) .OR.
     & ( U.XTYP .NE. 'TIME' ) .OR.
     & ( U.XUNITS .NE. 'SECONDS' ) )
     & CALL MSG_WRITE( '*** WARNING - Not a time series file',
     & REPORT )
      IF ( ( U.NFP .GT. 0 ) .OR. ( U.NLP .LE. 0 ) ) CALL MSG_WRITE(
     & '*** WARNING - Nonstandard x-axis span', REPORT )
      IF ( U.DEL .LE. 0. ) THEN
        CALL MSG_WRITE(
     &     '*** ERROR - Non-positive file x-axis step value', REPORT )
        GO TO 190
      END IF

      IF ( .NOT. BATCH ) THEN ! Interactive prompts

        ! Show file info
        WRITE( *, '(/5X,2A/5X,A,F9.3,A/5X,A,F9.3,A)', IOSTAT=IOS_W )
     &     ' Sensor Attachment: ', U.SENATT,
     &     ' Prefilter Frequency:  ', U.PREF, ' (Hz)',
     &     ' Cutoff Frequency:     ', U.FCUT, ' (Hz)'

        ! Ask about bias removal
  102   IF ( REM_BIAS_CL .EQ. ' ' ) THEN
          WRITE( *, '(/A,54X,A/'' >> '',$)' )
     &       ' Remove bias?   (Y/N)', '[Yes]'
          READ( *, '(A)', END=190 ) REM_BIAS
          CALL STR_UP( REM_BIAS )
          IF ( .NOT. ANY_CHARS( REM_BIAS, ' YN' ) ) THEN
            WRITE( *, * ) '*** Invalid response'
            GO TO 102
          END IF
          IF ( REM_BIAS .EQ. ' ' ) REM_BIAS = 'Y'
        ELSE
          REM_BIAS = REM_BIAS_CL
        END IF
        IF ( ANY_CHARS( REM_BIAS, ' Y' ) ) THEN
          REMOVE_BIAS = .TRUE.
        ELSE
          REMOVE_BIAS = .FALSE.
        END IF

      END IF

      ! Perform FIR100 filtering
      CALL FIR100_S( U.Y, S, NFP_L, NLP_U, U.NFP, U.NLP, U.DEL,
     & REMOVE_BIAS, IOS )
      IF ( IOS .NE. 0 ) THEN
        CALL MSG_WRITE( '*** Filtering failed', REPORT )
        GO TO 190
      END IF

      ! Prepare output fields
      U.STATUS = 'FILTERED'
      U.HIC = 0.
      U.T1 = 0.
      U.T2 = 0.
      U.HICDTUP = 0.
      U.CLIP3M = 0.
      U.CSI = 0.
      U.FCUT = 100.
      U.FSTP = 189.
      IF ( ( ( U.FCOR .GT. 0. ) .AND. ( U.FSTP .GT. U.FCOR ) ) .OR.
     & ( ( U.PREF .GT. 0. ) .AND. ( U.FSTP .GT. .5*U.PREF ) ) ) THEN
        CALL MSG_WRITE( '*** WARNING - Filter causes overlap '//
     &     'distortion with previous filtering', REPORT )
        U.STATUS = 'DISTORTED'
      END IF
      U.FCOR = 100.
      U.CD1 = 'FIR100 Filtered'

      ! Set default output file name
      OUT_FILE = FILE_NAME
      CALL FN_EXTRACT( OUT_FILE )
      CALL FN_FLAG( OUT_FILE, 'fd', 2, I )
      CALL ADD_PATH( DIR_OUT, OUT_FILE )
      IF ( .NOT. NO_INCR ) CALL FN_INCR( OUT_FILE )
      CALL FN_NAME_EXTRACT( OUT_FILE )
      DEF_FILE = OUT_FILE

      ! Set the output UDS file name
      IF ( .NOT. BATCH ) THEN
  120   WRITE( *, '(/A/3A/'' >> '',$)' )
     &     ' Output UDS file name?',
     &     ' [', DEF_FILE(:L_TRIM(DEF_FILE)), ']'
        READ( *, '(A)', END=190 ) OUT_FILE
        IF ( OUT_FILE .EQ. ' ' ) THEN ! Use default file name
          OUT_FILE = DEF_FILE
        ELSE ! Check file name validity
          CALL ADD_PATH( DIR_OUT, OUT_FILE )
          IF ( .NOT. FN_VALID( OUT_FILE ) ) THEN
            WRITE( *, * ) '*** Invalid file name'
            GO TO 120
          END IF
        END IF
      ELSE ! Batch
        OUT_FILE = DEF_FILE
      END IF

      ! Write the output UDS file
      CALL UDS_PUT( OUT_FILE, U, C, REPORT, OUTPUT_LIST,
     & DIR_OUT, .TRUE., IOS )

      ! Loop for next file
  190 WRITE( *, '(80(''_''))' )
      GO TO 100

      ! Clean up and stop
  199 CALL CLEAN_UP( HIT, REPORT, OUTPUT_LIST, DIR_OUT )

      END

      SUBROUTINE FIR100_CL( CL_ARG, NUM_ARGS, PROG_NAME, REM_BIAS_CL )

!***********************************************************************
!* Processes the Program-Specific Command Line Arguments
!***********************************************************************

      ! Arguments ______________________________________________________

      CHARACTER*(*) CL_ARG(0:*) ! Command line argument array

      INTEGER NUM_ARGS ! Number of arguments

      CHARACTER*(*) PROG_NAME ! Program name

      CHARACTER REM_BIAS_CL ! Indicates whether to remove bias

      ! Variables ______________________________________________________

      INTEGER I, NS

      CHARACTER ARG*255, C

      ! Process command line arguments
      REM_BIAS_CL = ' '
      DO I = 1, NUM_ARGS
        CALL STR_UPCASE( ARG, CL_ARG(I) )
        C = ARG(1:1)
        IF ( ( C .EQ. '-' ) .OR. ( C .EQ. '/' ) ) THEN
          NS = 2
        ELSE
          NS = 1
        END IF
        IF ( ( ARG(NS:) .EQ. '?' ) .OR.
     &     ( ARG(NS:) .EQ. '??' ) .OR.
     &     ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line syntax
          CALL SYNTAX_CL( PROG_NAME )
          WRITE( *, '(10X,A)' ) '[[NO_]BIAS]'
          IF ( ( ARG(NS:) .EQ. '??' ) .OR.
     &       ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line help
            CALL HELP_CL( PROG_NAME )
            WRITE( *, '(10X,A/10X,A)' )
     &         'BIAS :  Remove signal bias',
     &         'NO_BIAS :  Don''t remove signal bias'
          END IF
          STOP ' '
        ELSE IF ( ARG(NS:) .EQ. 'BIAS' ) THEN
          REM_BIAS_CL = 'Y'
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:) .EQ. 'NO_BIAS' ) .OR.
     &     ( ARG(NS:) .EQ. 'NOBIAS' ) ) THEN
          REM_BIAS_CL = 'N'
          CL_ARG(I) = ' '
        END IF
      END DO

      RETURN
      END


SUBROUTINE sedbal(upstream)

!Till: computationally irrelevant: outcommented unused vars
!2012-09-14

! Till: computationally irrelevant: minor changes to improve compiler compatibility
! 2011-04-29

! Code converted using TO_F90 by Alan Miller
! Date: 2005-08-23  Time: 12:57:31

use common_h
use time_h
use reservoir_h
use routing_h
use hymo_h

IMPLICIT NONE

INTEGER, INTENT(IN OUT)                  :: upstream
INTEGER :: k,g,l,nbrsteps !i,
real:: dummy

real :: wat_dens,sed_dens,delta,grav,visc
real :: overflow_rate,diam_equiv,frac_finer,trap_eff
real :: frretent,frrelease !frcum,
real :: cumfrsed_in(n_sed_class),cumfrsed_out(n_sed_class),lower_limit(n_sed_class)
real :: par_a,par_b,par_c
real :: interv(200),setveloc(200),upper_diam(200),lower_diam(200),mean_diam(200),frfiner(200)
real :: frfiner_out(200),cumfrrelease(200)
real :: par_x(200),par_y(200) !,par_z(200)

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
REAL :: tempres(step,upstream)

! -----------------------------------------------------------------------

if (res_qout(step,upstream)/=0.) then
!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
  tempres(step,upstream)=20.

! density of water and density of natural sediments (kg/m3)
  wat_dens=1.*1000.
  sed_dens=2.65*1000.

! specific gravity of sediments in water (-)
  delta=(sed_dens-wat_dens)/wat_dens

! gravitacional acceleration (m2/s)
  grav=9.807

! kinematic viscosity (m2/s)
  visc=(1.14-0.031*(tempres(step,upstream)-15.)+  &
      0.00068*((tempres(step,upstream)-15.)**2.))*1.e-6

! Overflow rate  Vc (m/s)
  overflow_rate=res_qout(step,upstream)/damareaact(upstream)
!  overflow_rate=0.00032

! calculation of the corresponding equivalent diameter (mm)
  par_a=1.09*(delta)*grav
  par_b=-(overflow_rate**2)
  par_c=-27.9*overflow_rate*visc

  diam_equiv=1000.*(-par_b+sqrt(((par_b)**2.)-4.*par_a*par_c))/(2.*par_a)
!if (t==2004 .and. step<100) write(*,'(2I4,10F15.6)') step,id_subbas_extern(upstream),res_qout(step,upstream),damareaact(upstream),overflow_rate
!if (t==2004 .and. step<100) write(*,'(2I4,10F15.6)') step,id_subbas_extern(upstream),par_a,par_b,par_c,diam_equiv
!if (t==2004 .and. step<100) pause
! affluent grain size distribution (-)
  dummy=0.
  DO g=1,n_sed_class
    dummy=dummy+frsediment_in(upstream,g)
    cumfrsed_in(g)=dummy
!write(*,*)g,cumfrsed_in(g)
  enddo

! lower limits of particle size class intervalls (mm)
  lower_limit(1)=upper_limit(1)/2.
  DO g=2,n_sed_class
    lower_limit(g)=upper_limit(g-1)
  enddo
!write(*,*)g,(lower_limit(g),g=1,n_sed_class)

! fraction of particles smaller than equivalent diameter (-)
  DO g=1,n_sed_class
    if (diam_equiv>=lower_limit(g) .and. diam_equiv<=upper_limit(g) .and. g>1) then
      frac_finer=cumfrsed_in(g-1)+(cumfrsed_in(g)-cumfrsed_in(g-1))* &
		(log10(diam_equiv)-log10(lower_limit(g)))/ &
		(log10(upper_limit(g))-log10(lower_limit(g)))
	  exit
	else if (diam_equiv>=lower_limit(1) .and. diam_equiv<=upper_limit(1)) then
      frac_finer=cumfrsed_in(g)* &
		(log10(diam_equiv)-log10(lower_limit(g)))/ &
		(log10(upper_limit(g))-log10(lower_limit(g)))
	  exit
	else if (diam_equiv<lower_limit(1)) then
	  frac_finer=0.
	else if (diam_equiv>upper_limit(n_sed_class)) then
	  frac_finer=1.
	endif
  enddo

  DO g=1,n_sed_class
!write(*,'(I3,5F10.6)')g,frac_finer,cumfrsed_in(g),diam_equiv,lower_limit(g),upper_limit(g)
  enddo
!write(*,*)frac_finer,diam_equiv,lower_limit(1)

  if (frac_finer == 1. .or. frac_finer == 0.) then
    trap_eff=1.-frac_finer
	if (frac_finer == 1.) then
      DO g=1,n_sed_class
	    frsediment_out(upstream,g)=frsediment_in(upstream,g)
	  enddo
	else
      DO g=1,n_sed_class
	    frsediment_out(upstream,g)=0.
	  enddo
    endif
  else
    dummy=0.
    DO g=1,n_sed_class
      if (diam_equiv>=lower_limit(g)) then
	    dummy=dummy+1.
	  else
	    exit
	  endif
	enddo
    nbrsteps=int(10.*dummy)
	lower_diam(1)=lower_limit(1)
!	interv=frac_finer/nbrsteps
    k=0
    DO g=1,n_sed_class
	  if (g>1) then
	    if (frac_finer>=cumfrsed_in(g)) &
		  dummy=(cumfrsed_in(g)-cumfrsed_in(g-1))/10.
	    if (frac_finer<cumfrsed_in(g) .and. frac_finer>cumfrsed_in(g-1)) &
		  dummy=(frac_finer-cumfrsed_in(g-1))/10.
	    if (frac_finer<cumfrsed_in(g) .and. frac_finer<cumfrsed_in(g-1)) exit
	  else
		if (frac_finer>=cumfrsed_in(g)) &
		  dummy=cumfrsed_in(g)/10.
	    if (frac_finer<cumfrsed_in(g)) &
		  dummy=frac_finer/10.
	  endif

      do l=1,10
	    k=k+1
	    interv(k)=dummy
	  enddo
	enddo
    DO k=1,nbrsteps
	  if (k>1) frfiner(k)=frfiner(k-1)+interv(k)
	  if (k==1) frfiner(k)=interv(k)
	enddo
    DO k=1,nbrsteps
!	  frfiner(k)=k*interv
      DO g=1,n_sed_class
        if (frfiner(k)<=cumfrsed_in(1)) then
          upper_diam(k)=10.**(log10(lower_limit(g))+((log10(upper_limit(g))-log10(lower_limit(g)))* &
			frfiner(k)/cumfrsed_in(g)))
		  exit
		else if (frfiner(k)<=cumfrsed_in(g)) then
          upper_diam(k)=10.**(log10(lower_limit(g))+((log10(upper_limit(g))-log10(lower_limit(g)))* &
			(frfiner(k)-cumfrsed_in(g-1))/(cumfrsed_in(g)-cumfrsed_in(g-1))))
		  exit
	    endif
	  enddo
!write(*,'(I3,4F10.6)')k,interv(k),frfiner(k),upper_diam(k)
	enddo

    DO k=2,nbrsteps
	  lower_diam(k)=upper_diam(k-1)
	enddo

	frretent=0.
	frrelease=0.
    DO k=1,nbrsteps
	  mean_diam(k)=sqrt(lower_diam(k)*upper_diam(k))
! settling velocity (m/s)
      setveloc(k)=SQRT((13.95*visc/(mean_diam(k)/1000.))**2.+(1.09*  &
        (delta)*9.807*(mean_diam(k)/1000.)))-(13.95*visc/(mean_diam(k)/1000.))
	  par_x(k)=(setveloc(k)/overflow_rate)*interv(k)
	  par_y(k)=(1.-(setveloc(k)/overflow_rate))*interv(k)
!	  par_x(k)=(setveloc(k)/overflow_rate)*interv
!	  par_y(k)=(1-(setveloc(k)/overflow_rate))*interv
      frretent=frretent+par_x(k)
      frrelease=frrelease+par_y(k)
!write(*,'(I3,6F12.8)')k,mean_diam(k),lower_diam(k),upper_diam(k),setveloc(k),par_x(k),par_y(k)
!write(*,'(I3,6F12.8)')k,mean_diam(k),setveloc(k),par_x(k),par_y(k),frretent,frrelease
	enddo

	trap_eff=(1.-frac_finer)+frretent

	dummy=0.
    DO k=1,nbrsteps
	  frfiner_out(k)=par_y(k)/frrelease
	  dummy=dummy+frfiner_out(k)
	  cumfrrelease(k)=dummy
!write(*,'(I3,4F12.8)')k,upper_diam(k),frfiner_out(k),cumfrrelease(k),trap_eff
	enddo

    DO g=1,n_sed_class
	  if (upper_limit(g)>upper_diam(nbrsteps)) then
	    cumfrsed_out(g)=1.
	  else
	    do k=1,nbrsteps
	      if (upper_limit(g)>=lower_diam(k) .and. upper_limit(g)<=upper_diam(k) .and. k>1) then
            cumfrsed_out(g)=cumfrrelease(k-1)+(cumfrrelease(k)-cumfrrelease(k-1))* &
				(log10(upper_limit(g))-log10(lower_diam(k)))/ &
				(log10(upper_diam(k))-log10(lower_diam(k)))
	        exit
		  else if (upper_limit(g)>=lower_diam(1) .and. upper_limit(g)<=upper_diam(1)) then
            cumfrsed_out(g)=cumfrrelease(k)* &
				(log10(upper_limit(g))-log10(lower_diam(k)))/ &
				(log10(upper_diam(k))-log10(lower_diam(k)))
	        exit
		  endif
		enddo
	  endif
	  if (g==1) frsediment_out(upstream,g)=cumfrsed_out(g)
	  if (g>1) frsediment_out(upstream,g)=cumfrsed_out(g)-cumfrsed_out(g-1)

!write(*,'(I3,2F12.8)')g,frsediment_out(upstream,g),cumfrsed_out(g)
	enddo
  endif
  sed_outflow(step,upstream)=sed_inflow(step,upstream)*(1.-trap_eff)
else
  sed_outflow(step,upstream)=0.
endif

if (t==tstart .and. step==1) cum_sedimentation(upstream)=0.
IF (t>tstart .and. t== damyear(upstream) .and. step==1) cum_sedimentation(upstream)=0.
sedimentation(step,upstream)=max(sed_inflow(step,upstream)-sed_outflow(step,upstream),0.)
cum_sedimentation(upstream)=cum_sedimentation(upstream)+sedimentation(step,upstream)
!sed_susp(step,upstream)=0.

! storage capacity reduction (m3)
decstorcap(step,upstream)=sedimentation(step,upstream)/dry_dens(upstream)

!write(*,'(3I4,2F15.1)')t,d,upstream,sedimentation(step,upstream),cum_sedimentation(upstream)

!write(*,'(3I4,4F15.1)')t,d,upstream,sed_inflow(step,upstream),sed_outflow(step,upstream),sedimentation(step,upstream),sed_susp(step,upstream)

!if (d==2)stop

RETURN
END SUBROUTINE sedbal


module utils
    use type_def

    implicit none

    contains

    subroutine message_display(str_in)
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !>  A warpper for print message in fix format
    !
        implicit none
        character (len = 20), intent(in) :: str_in
        write(6, *) "==========================="
        write(6, *) str_in
        write(6, *) "==========================="

        return
    end subroutine message_display

    function distance(lon1, lat1, lon2, lat2)
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !> This function is for compute distance between two points
    !
        implicit none

        real, parameter :: R_e = 6371
        real, intent(in) :: lon1, lat1, lon2, lat2
        real :: distance
        real :: dlon, dlat
        real :: a, b
        dlon = lon2 - lon1
        dlat = lat2 - lat1
        a = SIN(dlat / 2)**2 + COS(lat1) * COS(lat2) * SIN(dlon / 2)**2
        b = 2 * ATAN2(SQRT(a), SQRT(1 - a))
        distance = R_e * b * 1000

        return
    end function distance

    function centered_diff(input, i, j, lon, lat, nx, ny, xyflags)
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !> This function is for compute centered_diff
    !
        implicit none

        integer, intent(in)  :: i, j, nx, ny, xyflags
        real, dimension(ny), intent(in) :: lat
        real, dimension(nx), intent(in) :: lon
        real, dimension(ny, nx), intent(in)  :: input
        real :: ds
        real :: centered_diff

        IF (xyflags .eq. 1) THEN
            ! Y direction
            ds = distance(lon(i), lat(j + 1), lon(i), lat(j - 1))
            centered_diff = (input(j + 1, i) - input(j - 1, i)) / (ds)
        ELSEIF (xyflags .eq. 0) THEN
            ! X direction
            ds = distance(lon(i + 1), lat(j), lon(i - 1), lat(j))
            centered_diff = (input(j, i + 1) - input(j, i - 1)) / (ds)
        ELSE
            call message_display("Wrong Arg input xyflags must be 0 for x , 1 for y")
        END IF

        return
    end function centered_diff

    function forward_diff(input, i, j, lon, lat, nx, ny, xyflags)
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !> This function is for compute forward_diff
    !
        implicit none

        integer, intent(in)  :: i, j, nx, ny, xyflags
        real, dimension(ny), intent(in) :: lat
        real, dimension(nx), intent(in) :: lon
        real, dimension(ny, nx), intent(in)  :: input
        real :: ds
        real :: forward_diff

        IF (xyflags .eq. 1) THEN
            ! Y direction
            ds = distance(lon(i), lat(j), lon(i), lat(j + 1))
            forward_diff = (input(j + 1, i) - input(j, i)) / (ds)
        ELSEIF (xyflags .eq. 0) THEN
            ! X direction
            ds = distance(lon(i), lat(j), lon(i + 1), lat(j))
            forward_diff = (input(j, i + 1) - input(j, i)) / (ds)
        ELSE
            call message_display("Wrong Arg input xyflags must be 0 for x , 1 for y")
        END IF

        return
    end function forward_diff

    function backward_diff(input, i, j, lon, lat, nx, ny, xyflags)
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !> This function is for compute backward_diff
    !
        implicit none

        integer, intent(in)  :: i, j, nx, ny, xyflags
        real, dimension(ny), intent(in) :: lat
        real, dimension(nx), intent(in) :: lon
        real, dimension(ny, nx), intent(in)  :: input
        real :: ds
        real :: backward_diff

        IF (xyflags .eq. 1) THEN
            ! Y direction
            ds = distance(lon(i), lat(j - 1), lon(i), lat(j))
            backward_diff = (input(j, i) - input(j - 1, i)) / (ds)
        ELSEIF (xyflags .eq. 0) THEN
            ! X direction
            ds = distance(lon(i), lat(j), lon(i - 1), lat(j))
            backward_diff = (input(j, i) - input(j, i - 1)) / (ds)
        ELSE
            call message_display("Wrong Arg input xyflags must be 0 for x , 1 for y")
        END IF

        return
    end function backward_diff

    function horizontal_diff(source, lon, lat, nx, ny, xyflags) result(diff)
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !> This function is for compute backward_diff
    !
        implicit none
        integer, intent(in)  :: nx, ny, xyflags
        integer :: i, j
        real, dimension(ny), intent(in) :: lat
        real, dimension(nx), intent(in) :: lon
        real, dimension(ny, nx), intent(in)  :: source
        real, dimension(ny, nx)  :: diff

        !$OMP PARALLEL DO
        do i = 1, nx
            do j = 1, ny
                if (i .eq. 0 .and. j .eq. 0) then
                    diff(j, i) = forward_diff(source, i, j, lon, lat, nx, ny, xyflags)

                else if (i .eq. nx .and. j .eq. ny) then
                    diff(j, i) = backward_diff(source, i, j, lon, lat, nx, ny, xyflags)

                else if (i .eq. nx .and. j .eq. 0) then
                    if (xyflags .eq. 0) then
                        diff(j, i) = backward_diff(source, i, j, lon, lat, nx, ny, xyflags)
                    elseif (xyflags .eq. 1) then
                        diff(j, i) = forward_diff(source, i, j, lon, lat, nx, ny, xyflags)
                    end if

                else if (i .eq. 0 .and. j .eq. ny) then
                    if (xyflags .eq. 0) then
                        diff(j, i) = forward_diff(source, i, j, lon, lat, nx, ny, xyflags)
                    elseif (xyflags .eq. 1) then
                        diff(j, i) = backward_diff(source, i, j, lon, lat, nx, ny, xyflags)
                    end if

                else
                        diff(j, i) = centered_diff(source, i, j, lon, lat, nx, ny, xyflags)
                end if
            end do
        end do
        !$OMP END PARALLEL DO

        return
    end function horizontal_diff

end module

module solver
    use type_def
    use utils
    implicit none
    integer, parameter :: X_AXIS = 0, Y_AXIS = 1
    integer, parameter :: g = 9.8, H = 8000
    real, parameter :: omega = 7.292e-5

    contains

    subroutine Matsuno(u, v, Z, u_next, v_next, Z_next, lon, lat, nx, ny)
        implicit none
        integer, intent(in)  :: nx, ny
        integer :: i, j
        real :: dt, f
        real, dimension(ny), intent(in) :: lat
        real, dimension(nx), intent(in) :: lon
        real, dimension(ny, nx), intent(in)  :: Z, u, v
        real, dimension(ny, nx) :: u_next, v_next, Z_next
        real, dimension(ny, nx) :: u_star, v_star, Z_star
        real, dimension(ny, nx) :: u_diff_x, u_diff_y, Z_diff_x, Z_diff_y, v_diff_x, v_diff_y
        real, dimension(ny, nx) :: u_star_diff_x, u_star_diff_y, Z_star_diff_x, Z_star_diff_y, v_star_diff_x, v_star_diff_y

        u_diff_x = horizontal_diff(u, lon, lat, nx, ny, X_AXIS)
        u_diff_y = horizontal_diff(u, lon, lat, nx, ny, Y_AXIS)
        v_diff_x = horizontal_diff(v, lon, lat, nx, ny, X_AXIS)
        v_diff_y = horizontal_diff(v, lon, lat, nx, ny, Y_AXIS)
        Z_diff_x = horizontal_diff(Z, lon, lat, nx, ny, X_AXIS)
        Z_diff_y = horizontal_diff(Z, lon, lat, nx, ny, Y_AXIS)

        u_star = u + dt * (-u *  u_diff_x - v * u_diff_y - g * Z_diff_x + f * v)
        v_star = v + dt * (-u *  v_diff_x - v * v_diff_y - g * Z_diff_x - f * u)
        Z_star = Z + dt * (-u *  Z_diff_x - v * Z_diff_y - H * (u_diff_x + v_diff_y))

        u_star_diff_x = horizontal_diff(u_star, lon, lat, nx, ny, X_AXIS)
        u_star_diff_y = horizontal_diff(u_star, lon, lat, nx, ny, Y_AXIS)
        v_star_diff_x = horizontal_diff(v_star, lon, lat, nx, ny, X_AXIS)
        v_star_diff_y = horizontal_diff(v_star, lon, lat, nx, ny, Y_AXIS)
        Z_star_diff_x = horizontal_diff(Z_star, lon, lat, nx, ny, X_AXIS)
        Z_star_diff_y = horizontal_diff(Z_star, lon, lat, nx, ny, Y_AXIS)

        u_next = u + dt * (-u_star * u_star_diff_x - v * u_star_diff_y - g * Z_diff_x + f * v)
        v_next = v + dt * (-u_star * v_star_diff_x - v * v_star_diff_y - g * Z_diff_x + f * v)
        Z_next = Z + dt * (-u *  Z_star_diff_x - v * Z_star_diff_y - H * (u_diff_x + v_diff_y))

        return
    end subroutine Matsuno

    subroutine Leapfrog(u, v, Z, u_pre, v_pre, Z_pre, u_next, v_next, Z_next, lon, lat, nx, ny)
        implicit none
        integer, intent(in)  :: nx, ny
        integer :: i, j
        real :: dt, f
        real, dimension(ny), intent(in) :: lat
        real, dimension(nx), intent(in) :: lon
        real, dimension(ny, nx), intent(in) :: Z, u, v
        real, dimension(ny, nx), intent(in) :: u_pre, v_pre, Z_pre
        real, dimension(ny, nx) :: u_next, v_next, Z_next
        real, dimension(ny, nx) :: u_diff_x, u_diff_y, Z_diff_x, Z_diff_y, v_diff_x, v_diff_y

        u_diff_x = horizontal_diff(u, lon, lat, nx, ny, X_AXIS)
        u_diff_y = horizontal_diff(u, lon, lat, nx, ny, Y_AXIS)
        v_diff_x = horizontal_diff(v, lon, lat, nx, ny, X_AXIS)
        v_diff_y = horizontal_diff(v, lon, lat, nx, ny, Y_AXIS)
        Z_diff_x = horizontal_diff(Z, lon, lat, nx, ny, X_AXIS)
        Z_diff_y = horizontal_diff(Z, lon, lat, nx, ny, Y_AXIS)

        u_next = u_pre + 2 * dt * (-u * u_diff_x - v * u_diff_y - g * Z_diff_x + f * v)
        v_next = v_pre + 2 * dt * (-u * v_diff_x - v * v_diff_y - g * Z_diff_x - f * u)
        Z_next = Z_pre + 2 * dt * (-u * Z_diff_x - v * Z_diff_y - H * (u_diff_x + v_diff_y))

        return
    end subroutine

end module solver

module io
    use netcdf
    use utils
    implicit none

    character (len = *), parameter :: IN_FILE_NAME = "hgt_location_selected.nc"
    character (len = *), parameter :: OUT_FILE_NAME = "geo_wind.nc"
    integer :: ncid, hgtid, lonid, latid, uid, vid
    integer :: y_dimid, x_dimid
    integer(kind=1) :: ierr

    contains

end module io

module type_def
    implicit none

    integer, parameter :: nx = 33,ny = 23
    integer :: nt = 1000

    type element
    !meteorological elements
        real, dimension(ny, nx) :: Z = 0, u = 0, v = 0
    end type element

    type grid
    !meteorological elements
        real, dimension(ny) :: lat
        real, dimension(nx) :: lon
    end type grid

end module

program simple_model
    !
    !>\ Author : Fanghe Zhao
    !>\ Date : 10/2018
    !>\ Details:
    !>  This Program is for compute geostrophic wind use ECMWF data
    !
    use utils
    use solver
    use io
    use type_def

    implicit none

    ! Var Defination
    integer :: i, j
    real :: dx = 1, dy = 1, dt = 1
    real :: f

    type(grid), target :: coor
    type(element), target :: ele_pre, ele, ele_next

    real, dimension(:, :), pointer :: Z, u, v
    real, dimension(:, :), pointer :: Z_next, u_next, v_next
    real, dimension(:, :), pointer :: Z_pre, u_pre, v_pre
    real, dimension(:), pointer :: lat
    real, dimension(:), pointer :: lon

    ! pointer assignment
    Z => ele%Z
    u => ele%u
    v => ele%v
    Z_next => ele_next%Z
    u_next => ele_next%u
    v_next => ele_next%v
    Z_pre => ele_pre%Z
    u_pre => ele_pre%u
    v_pre => ele_pre%v
    lon => coor%lon
    lat => coor%lat

    do i = 1, nt
        if (i .eq. 1) then
            call Matsuno(u, v, Z, u_next, v_next, Z_next, lon, lat, nx, ny)
            !update_var
            ele = ele_next
        else
            call Leapfrog(u, v, Z, u_pre, v_pre, Z_pre, u_next, v_next, Z_next, lon, lat, nx, ny)
            !update_var
            ele_pre = ele
            ele = ele_next
        end if
    end do

end program simple_model


*DECK DCBRT
      DOUBLE PRECISION FUNCTION DCBRT (X)
C***BEGIN PROLOGUE  DCBRT
C***PURPOSE  Compute the cube root.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C2
C***TYPE      DOUBLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C)
C***KEYWORDS  CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DCBRT(X) calculates the double precision cube root for
C double precision argument X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9PAK, D9UPAK
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DCBRT
      DOUBLE PRECISION X, CBRT2(5), Y, CBRTSQ,  D9PAK, D1MACH
      SAVE CBRT2, NITER
      DATA CBRT2(1) / 0.6299605249 4743658238 3605303639 11 D0 /
      DATA CBRT2(2) / 0.7937005259 8409973737 5852819636 15 D0 /
      DATA CBRT2(3) / 1.0 D0 /
      DATA CBRT2(4) / 1.2599210498 9487316476 7210607278 23 D0 /
      DATA CBRT2(5) / 1.5874010519 6819947475 1705639272 31 D0 /
      DATA NITER / 0 /
C***FIRST EXECUTABLE STATEMENT  DCBRT
      IF (NITER.EQ.0) NITER = 1.443*LOG(-.106*LOG(0.1*REAL(D1MACH(3)))
     1  ) + 1.0
C
      DCBRT = 0.D0
      IF (X.EQ.0.D0) RETURN
C
      CALL D9UPAK (ABS(X), Y, N)
      IXPNT = N/3
      IREM = N - 3*IXPNT + 3
C
C THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED
C TO POLYNOMIAL FORM.  THE APPROX IS NEARLY BEST IN THE SENSE OF
C RELATIVE ERROR WITH 4.085 DIGITS ACCURACY.
C
      Z = Y
      DCBRT = .439581E0 + Z*(.928549E0 + Z*(-.512653E0 + Z*.144586E0))
C
      DO 10 ITER=1,NITER
        CBRTSQ = DCBRT*DCBRT
        DCBRT = DCBRT + (Y-DCBRT*CBRTSQ)/(3.D0*CBRTSQ)
 10   CONTINUE
C
      DCBRT = D9PAK (CBRT2(IREM)*SIGN(DCBRT,X), IXPNT)
      RETURN
C
      END


! { dg-do compile }
program matmul_bounds_1
  implicit none
  real, dimension(3,2) :: a
  real, dimension(2,3) :: b
  real, dimension(3,2) :: rab
  real, dimension(2,2) :: rok
  real, dimension(2) :: rv
  real, dimension(3) :: rw
  real, dimension(3) :: x
  real, dimension(2) :: y
  a = 1
  b = 2
  x = 3
  y = 4
  ! These tests should throw an error
  rab = matmul(a,b) ! { dg-error "Different shape" }
  rv = matmul(a,y) ! { dg-error "Different shape" }
  rv = matmul(x,b) ! { dg-error "Different shape" }
  ! These are ok.
  rw = matmul(a,y)
  rv = matmul(x,a)
  rok = matmul(b,a)
end program matmul_bounds_1


*DECK DHFTI
      SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H,
     +   G, IP)
C***BEGIN PROLOGUE  DHFTI
C***PURPOSE  Solve a least squares problem for banded matrices using
C            sequential accumulation of rows of the data matrix.
C            Exactly one right-hand side vector is permitted.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      DOUBLE PRECISION (HFTI-S, DHFTI-D)
C***KEYWORDS  CURVE FITTING, LEAST SQUARES
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N)
C
C     This subroutine solves a linear least squares problem or a set of
C     linear least squares problems having the same matrix but different
C     right-side vectors.  The problem data consists of an M by N matrix
C     A, an M by NB matrix B, and an absolute tolerance parameter TAU
C     whose usage is described below.  The NB column vectors of B
C     represent right-side vectors for NB distinct linear least squares
C     problems.
C
C     This set of problems can also be written as the matrix least
C     squares problem
C
C                       AX = B,
C
C     where X is the N by NB solution matrix.
C
C     Note that if B is the M by M identity matrix, then X will be the
C     pseudo-inverse of A.
C
C     This subroutine first transforms the augmented matrix (A B) to a
C     matrix (R C) using premultiplying Householder transformations with
C     column interchanges.  All subdiagonal elements in the matrix R are
C     zero and its diagonal elements satisfy
C
C                       ABS(R(I,I)).GE.ABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, where
C
C                       L = MIN(M,N).
C
C     The subroutine will compute an integer, KRANK, equal to the number
C     of diagonal terms of R that exceed TAU in magnitude. Then a
C     solution of minimum Euclidean length is computed using the first
C     KRANK rows of (R C).
C
C     To be specific we suggest that the user consider an easily
C     computable matrix norm, such as, the maximum of all column sums of
C     magnitudes.
C
C     Now if the relative uncertainty of B is EPS, (norm of uncertainty/
C     norm of B), it is suggested that TAU be set approximately equal to
C     EPS*(norm of A).
C
C     The user must dimension all arrays appearing in the call list..
C     A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N).  This
C     permits the solution of a range of problems in the same array
C     space.
C
C     The entire set of parameters for DHFTI are
C
C     INPUT.. All TYPE REAL variables are DOUBLE PRECISION
C
C     A(*,*),MDA,M,N    The array A(*,*) initially contains the M by N
C                       matrix A of the least squares problem AX = B.
C                       The first dimensioning parameter of the array
C                       A(*,*) is MDA, which must satisfy MDA.GE.M
C                       Either M.GE.N or M.LT.N is permitted.  There
C                       is no restriction on the rank of A.  The
C                       condition MDA.LT.M is considered an error.
C
C     B(*),MDB,NB       If NB = 0 the subroutine will perform the
C                       orthogonal decomposition but will make no
C                       references to the array B(*).  If NB.GT.0
C                       the array B(*) must initially contain the M by
C                       NB matrix B of the least squares problem AX =
C                       B.  If NB.GE.2 the array B(*) must be doubly
C                       subscripted with first dimensioning parameter
C                       MDB.GE.MAX(M,N).  If NB = 1 the array B(*) may
C                       be either doubly or singly subscripted.  In
C                       the latter case the value of MDB is arbitrary
C                       but it should be set to some valid integer
C                       value such as MDB = M.
C
C                       The condition of NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       is considered an error.
C
C     TAU               Absolute tolerance parameter provided by user
C                       for pseudorank determination.
C
C     H(*),G(*),IP(*)   Arrays of working space used by DHFTI.
C
C     OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION
C
C     A(*,*)            The contents of the array A(*,*) will be
C                       modified by the subroutine. These contents
C                       are not generally required by the user.
C
C     B(*)              On return the array B(*) will contain the N by
C                       NB solution matrix X.
C
C     KRANK             Set by the subroutine to indicate the
C                       pseudorank of A.
C
C     RNORM(*)          On return, RNORM(J) will contain the Euclidean
C                       norm of the residual vector for the problem
C                       defined by the J-th column vector of the array
C                       B(*,*) for J = 1,...,NB.
C
C     H(*),G(*)         On return these arrays respectively contain
C                       elements of the pre- and post-multiplying
C                       Householder transformations used to compute
C                       the minimum Euclidean length solution.
C
C     IP(*)             Array in which the subroutine records indices
C                       describing the permutation of column vectors.
C                       The contents of arrays H(*),G(*) and IP(*)
C                       are not generally required by the user.
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 14.
C***ROUTINES CALLED  D1MACH, DH12, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   901005  Replace usage of DDIFF with usage of D1MACH.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DHFTI
      INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L,
     *     LDIAG, LMAX, M, MDA, MDB, N, NB, NERR
      DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR,
     *     G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP
      DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*)
      SAVE RELEPS
      DATA RELEPS /0.D0/
C     BEGIN BLOCK PERMITTING ...EXITS TO 360
C***FIRST EXECUTABLE STATEMENT  DHFTI
         IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4)
         SZERO = 0.0D0
         DZERO = 0.0D0
         FACTOR = 0.001D0
C
         K = 0
         LDIAG = MIN(M,N)
         IF (LDIAG .LE. 0) GO TO 350
C           BEGIN BLOCK PERMITTING ...EXITS TO 130
C              BEGIN BLOCK PERMITTING ...EXITS TO 120
                  IF (MDA .GE. M) GO TO 10
                     NERR = 1
                     IOPT = 2
                     CALL XERMSG ('SLATEC', 'DHFTI',
     +                  'MDA.LT.M, PROBABLE ERROR.',
     +                  NERR, IOPT)
C     ...............EXIT
                     GO TO 360
   10             CONTINUE
C
                  IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20
                     NERR = 2
                     IOPT = 2
                     CALL XERMSG ('SLATEC', 'DHFTI',
     +                  'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.',
     +                  NERR, IOPT)
C     ...............EXIT
                     GO TO 360
   20             CONTINUE
C
                  DO 100 J = 1, LDIAG
C                    BEGIN BLOCK PERMITTING ...EXITS TO 70
                        IF (J .EQ. 1) GO TO 40
C
C                           UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C                          ..
                           LMAX = J
                           DO 30 L = J, N
                              H(L) = H(L) - A(J-1,L)**2
                              IF (H(L) .GT. H(LMAX)) LMAX = L
   30                      CONTINUE
C                    ......EXIT
                           IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70
   40                   CONTINUE
C
C                        COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C                       ..
                        LMAX = J
                        DO 60 L = J, N
                           H(L) = 0.0D0
                           DO 50 I = J, M
                              H(L) = H(L) + A(I,L)**2
   50                      CONTINUE
                           IF (H(L) .GT. H(LMAX)) LMAX = L
   60                   CONTINUE
                        HMAX = H(LMAX)
   70                CONTINUE
C                    ..
C                     LMAX HAS BEEN DETERMINED
C
C                     DO COLUMN INTERCHANGES IF NEEDED.
C                    ..
                     IP(J) = LMAX
                     IF (IP(J) .EQ. J) GO TO 90
                        DO 80 I = 1, M
                           TMP = A(I,J)
                           A(I,J) = A(I,LMAX)
                           A(I,LMAX) = TMP
   80                   CONTINUE
                        H(LMAX) = H(J)
   90                CONTINUE
C
C                     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A
C                     AND B.
C                    ..
                     CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,
     *                         N-J)
                     CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
  100             CONTINUE
C
C                  DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE,
C                  TAU.
C                 ..
                  DO 110 J = 1, LDIAG
C              ......EXIT
                     IF (ABS(A(J,J)) .LE. TAU) GO TO 120
  110             CONTINUE
                  K = LDIAG
C           ......EXIT
                  GO TO 130
  120          CONTINUE
               K = J - 1
  130       CONTINUE
            KP1 = K + 1
C
C           COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
            IF (NB .LT. 1) GO TO 170
            DO 160 JB = 1, NB
               TMP = SZERO
               IF (M .LT. KP1) GO TO 150
               DO 140 I = KP1, M
                  TMP = TMP + B(I,JB)**2
  140          CONTINUE
  150          CONTINUE
               RNORM(JB) = SQRT(TMP)
  160       CONTINUE
  170       CONTINUE
C           SPECIAL FOR PSEUDORANK = 0
            IF (K .GT. 0) GO TO 210
               IF (NB .LT. 1) GO TO 200
               DO 190 JB = 1, NB
                  DO 180 I = 1, N
                     B(I,JB) = SZERO
  180             CONTINUE
  190          CONTINUE
  200          CONTINUE
            GO TO 340
  210       CONTINUE
C
C               IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C               DECOMPOSITION OF FIRST K ROWS.
C              ..
               IF (K .EQ. N) GO TO 230
                  DO 220 II = 1, K
                     I = KP1 - II
                     CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  220             CONTINUE
  230          CONTINUE
C
C
               IF (NB .LT. 1) GO TO 330
               DO 320 JB = 1, NB
C
C                  SOLVE THE K BY K TRIANGULAR SYSTEM.
C                 ..
                  DO 260 L = 1, K
                     SM = DZERO
                     I = KP1 - L
                     IP1 = I + 1
                     IF (K .LT. IP1) GO TO 250
                     DO 240 J = IP1, K
                        SM = SM + A(I,J)*B(J,JB)
  240                CONTINUE
  250                CONTINUE
                     SM1 = SM
                     B(I,JB) = (B(I,JB) - SM1)/A(I,I)
  260             CONTINUE
C
C                  COMPLETE COMPUTATION OF SOLUTION VECTOR.
C                 ..
                  IF (K .EQ. N) GO TO 290
                     DO 270 J = KP1, N
                        B(J,JB) = SZERO
  270                CONTINUE
                     DO 280 I = 1, K
                        CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,
     *                            MDB,1)
  280                CONTINUE
  290             CONTINUE
C
C                   RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C                   COLUMN INTERCHANGES.
C                 ..
                  DO 310 JJ = 1, LDIAG
                     J = LDIAG + 1 - JJ
                     IF (IP(J) .EQ. J) GO TO 300
                        L = IP(J)
                        TMP = B(L,JB)
                        B(L,JB) = B(J,JB)
                        B(J,JB) = TMP
  300                CONTINUE
  310             CONTINUE
  320          CONTINUE
  330          CONTINUE
  340       CONTINUE
  350    CONTINUE
C        ..
C         THE SOLUTION VECTORS, X, ARE NOW
C         IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
         KRANK = K
  360 CONTINUE
      RETURN
      END


program plottest
    use Util
    use PlotLib
    implicit none

    integer :: m, n, k, i, j
    double precision, dimension(:), allocatable :: x, y, z

    DEBUG_MODE = .TRUE.

    m = 3
    n = 2
    k = 100

    allocate(x(k))
    allocate(y(k))
    allocate(z(k))

    x(:) = (/(i, i=1, k)/) / 100.0D0
    y(:) = (/(2 * x(j), j=1, k)/)
    z(:) = (/(x(j) * x(j), j=1, k)/)

    call begin_plot(fname='plottest')
    call subplots(m, n)

    do i=1, m
        do j=1,n
            call subplot(i, j, x, y, k)
            call subplot(i, j, x, z, k)
            call subplot_config(i, j, title='subplot ('//STR(i)//','//STR(j)//')', &
            xlabel='t', ylabel='z', grid=.TRUE.)
        end do
    end do

    call render_plot()

    deallocate(x, y, z)

    stop
end program plottest


*DECK E1
      FUNCTION E1 (X)
C***BEGIN PROLOGUE  E1
C***PURPOSE  Compute the exponential integral E1(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (E1-S, DE1-D)
C***KEYWORDS  E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C E1 calculates the single precision exponential integral, E1(X), for
C positive single precision argument X and the Cauchy principal value
C for negative X.  If principal values are used everywhere, then, for
C all X,
C
C    E1(X) = -Ei(-X)
C or
C    Ei(X) = -E1(-X).
C
C
C Series for AE11       on the interval -1.00000D-01 to  0.
C                                        with weighted error   1.76E-17
C                                         log weighted error  16.75
C                               significant figures required  15.70
C                                    decimal places required  17.55
C
C
C Series for AE12       on the interval -2.50000D-01 to -1.00000D-01
C                                        with weighted error   5.83E-17
C                                         log weighted error  16.23
C                               significant figures required  15.76
C                                    decimal places required  16.93
C
C
C Series for E11        on the interval -4.00000D+00 to -1.00000D+00
C                                        with weighted error   1.08E-18
C                                         log weighted error  17.97
C                               significant figures required  19.02
C                                    decimal places required  18.61
C
C
C Series for E12        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   3.15E-18
C                                         log weighted error  17.50
C                        approx significant figures required  15.8
C                                    decimal places required  18.10
C
C
C Series for AE13       on the interval  2.50000D-01 to  1.00000D+00
C                                        with weighted error   2.34E-17
C                                         log weighted error  16.63
C                               significant figures required  16.14
C                                    decimal places required  17.33
C
C
C Series for AE14       on the interval  0.          to  2.50000D-01
C                                        with weighted error   5.41E-17
C                                         log weighted error  16.27
C                               significant figures required  15.38
C                                    decimal places required  16.97
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891115  Modified prologue description.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  E1
      DIMENSION AE11CS(39), AE12CS(25), E11CS(19), E12CS(16),
     1  AE13CS(25), AE14CS(26)
      LOGICAL FIRST
      SAVE AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS,
     1 NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, FIRST
      DATA AE11CS( 1) /    .1215032397 1606579E0 /
      DATA AE11CS( 2) /   -.0650887785 13550150E0 /
      DATA AE11CS( 3) /    .0048976513 57459670E0 /
      DATA AE11CS( 4) /   -.0006492378 43027216E0 /
      DATA AE11CS( 5) /    .0000938404 34587471E0 /
      DATA AE11CS( 6) /    .0000004202 36380882E0 /
      DATA AE11CS( 7) /   -.0000081133 74735904E0 /
      DATA AE11CS( 8) /    .0000028042 47688663E0 /
      DATA AE11CS( 9) /    .0000000564 87164441E0 /
      DATA AE11CS(10) /   -.0000003448 09174450E0 /
      DATA AE11CS(11) /    .0000000582 09273578E0 /
      DATA AE11CS(12) /    .0000000387 11426349E0 /
      DATA AE11CS(13) /   -.0000000124 53235014E0 /
      DATA AE11CS(14) /   -.0000000051 18504888E0 /
      DATA AE11CS(15) /    .0000000021 48771527E0 /
      DATA AE11CS(16) /    .0000000008 68459898E0 /
      DATA AE11CS(17) /   -.0000000003 43650105E0 /
      DATA AE11CS(18) /   -.0000000001 79796603E0 /
      DATA AE11CS(19) /    .0000000000 47442060E0 /
      DATA AE11CS(20) /    .0000000000 40423282E0 /
      DATA AE11CS(21) /   -.0000000000 03543928E0 /
      DATA AE11CS(22) /   -.0000000000 08853444E0 /
      DATA AE11CS(23) /   -.0000000000 00960151E0 /
      DATA AE11CS(24) /    .0000000000 01692921E0 /
      DATA AE11CS(25) /    .0000000000 00607990E0 /
      DATA AE11CS(26) /   -.0000000000 00224338E0 /
      DATA AE11CS(27) /   -.0000000000 00200327E0 /
      DATA AE11CS(28) /   -.0000000000 00006246E0 /
      DATA AE11CS(29) /    .0000000000 00045571E0 /
      DATA AE11CS(30) /    .0000000000 00016383E0 /
      DATA AE11CS(31) /   -.0000000000 00005561E0 /
      DATA AE11CS(32) /   -.0000000000 00006074E0 /
      DATA AE11CS(33) /   -.0000000000 00000862E0 /
      DATA AE11CS(34) /    .0000000000 00001223E0 /
      DATA AE11CS(35) /    .0000000000 00000716E0 /
      DATA AE11CS(36) /   -.0000000000 00000024E0 /
      DATA AE11CS(37) /   -.0000000000 00000201E0 /
      DATA AE11CS(38) /   -.0000000000 00000082E0 /
      DATA AE11CS(39) /    .0000000000 00000017E0 /
      DATA AE12CS( 1) /    .5824174951 3472674E0 /
      DATA AE12CS( 2) /   -.1583488509 0578275E0 /
      DATA AE12CS( 3) /   -.0067642755 90323141E0 /
      DATA AE12CS( 4) /    .0051258439 50185725E0 /
      DATA AE12CS( 5) /    .0004352324 92169391E0 /
      DATA AE12CS( 6) /   -.0001436133 66305483E0 /
      DATA AE12CS( 7) /   -.0000418013 20556301E0 /
      DATA AE12CS( 8) /   -.0000027133 95758640E0 /
      DATA AE12CS( 9) /    .0000011513 81913647E0 /
      DATA AE12CS(10) /    .0000004206 50022012E0 /
      DATA AE12CS(11) /    .0000000665 81901391E0 /
      DATA AE12CS(12) /    .0000000006 62143777E0 /
      DATA AE12CS(13) /   -.0000000028 44104870E0 /
      DATA AE12CS(14) /   -.0000000009 40724197E0 /
      DATA AE12CS(15) /   -.0000000001 77476602E0 /
      DATA AE12CS(16) /   -.0000000000 15830222E0 /
      DATA AE12CS(17) /    .0000000000 02905732E0 /
      DATA AE12CS(18) /    .0000000000 01769356E0 /
      DATA AE12CS(19) /    .0000000000 00492735E0 /
      DATA AE12CS(20) /    .0000000000 00093709E0 /
      DATA AE12CS(21) /    .0000000000 00010707E0 /
      DATA AE12CS(22) /   -.0000000000 00000537E0 /
      DATA AE12CS(23) /   -.0000000000 00000716E0 /
      DATA AE12CS(24) /   -.0000000000 00000244E0 /
      DATA AE12CS(25) /   -.0000000000 00000058E0 /
      DATA E11CS( 1) / -16.1134616555 71494026E0 /
      DATA E11CS( 2) /   7.7940727787 426802769E0 /
      DATA E11CS( 3) /  -1.9554058188 631419507E0 /
      DATA E11CS( 4) /    .3733729386 6277945612E0 /
      DATA E11CS( 5) /   -.0569250319 1092901938E0 /
      DATA E11CS( 6) /    .0072110777 6966009185E0 /
      DATA E11CS( 7) /   -.0007810490 1449841593E0 /
      DATA E11CS( 8) /    .0000738809 3356262168E0 /
      DATA E11CS( 9) /   -.0000062028 6187580820E0 /
      DATA E11CS(10) /    .0000004681 6002303176E0 /
      DATA E11CS(11) /   -.0000000320 9288853329E0 /
      DATA E11CS(12) /    .0000000020 1519974874E0 /
      DATA E11CS(13) /   -.0000000001 1673686816E0 /
      DATA E11CS(14) /    .0000000000 0627627066E0 /
      DATA E11CS(15) /   -.0000000000 0031481541E0 /
      DATA E11CS(16) /    .0000000000 0001479904E0 /
      DATA E11CS(17) /   -.0000000000 0000065457E0 /
      DATA E11CS(18) /    .0000000000 0000002733E0 /
      DATA E11CS(19) /   -.0000000000 0000000108E0 /
      DATA E12CS( 1) /  -0.0373902147 92202795E0 /
      DATA E12CS( 2) /   0.0427239860 62209577E0 /
      DATA E12CS( 3) /   -.1303182079 849700544E0 /
      DATA E12CS( 4) /    .0144191240 2469889073E0 /
      DATA E12CS( 5) /   -.0013461707 8051068022E0 /
      DATA E12CS( 6) /    .0001073102 9253063780E0 /
      DATA E12CS( 7) /   -.0000074299 9951611943E0 /
      DATA E12CS( 8) /    .0000004537 7325690753E0 /
      DATA E12CS( 9) /   -.0000000247 6417211390E0 /
      DATA E12CS(10) /    .0000000012 2076581374E0 /
      DATA E12CS(11) /   -.0000000000 5485141480E0 /
      DATA E12CS(12) /    .0000000000 0226362142E0 /
      DATA E12CS(13) /   -.0000000000 0008635897E0 /
      DATA E12CS(14) /    .0000000000 0000306291E0 /
      DATA E12CS(15) /   -.0000000000 0000010148E0 /
      DATA E12CS(16) /    .0000000000 0000000315E0 /
      DATA AE13CS( 1) /   -.6057732466 4060346E0 /
      DATA AE13CS( 2) /   -.1125352434 8366090E0 /
      DATA AE13CS( 3) /    .0134322662 47902779E0 /
      DATA AE13CS( 4) /   -.0019268451 87381145E0 /
      DATA AE13CS( 5) /    .0003091183 37720603E0 /
      DATA AE13CS( 6) /   -.0000535641 32129618E0 /
      DATA AE13CS( 7) /    .0000098278 12880247E0 /
      DATA AE13CS( 8) /   -.0000018853 68984916E0 /
      DATA AE13CS( 9) /    .0000003749 43193568E0 /
      DATA AE13CS(10) /   -.0000000768 23455870E0 /
      DATA AE13CS(11) /    .0000000161 43270567E0 /
      DATA AE13CS(12) /   -.0000000034 66802211E0 /
      DATA AE13CS(13) /    .0000000007 58754209E0 /
      DATA AE13CS(14) /   -.0000000001 68864333E0 /
      DATA AE13CS(15) /    .0000000000 38145706E0 /
      DATA AE13CS(16) /   -.0000000000 08733026E0 /
      DATA AE13CS(17) /    .0000000000 02023672E0 /
      DATA AE13CS(18) /   -.0000000000 00474132E0 /
      DATA AE13CS(19) /    .0000000000 00112211E0 /
      DATA AE13CS(20) /   -.0000000000 00026804E0 /
      DATA AE13CS(21) /    .0000000000 00006457E0 /
      DATA AE13CS(22) /   -.0000000000 00001568E0 /
      DATA AE13CS(23) /    .0000000000 00000383E0 /
      DATA AE13CS(24) /   -.0000000000 00000094E0 /
      DATA AE13CS(25) /    .0000000000 00000023E0 /
      DATA AE14CS( 1) /   -.1892918000 753017E0 /
      DATA AE14CS( 2) /   -.0864811785 5259871E0 /
      DATA AE14CS( 3) /    .0072241015 4374659E0 /
      DATA AE14CS( 4) /   -.0008097559 4575573E0 /
      DATA AE14CS( 5) /    .0001099913 4432661E0 /
      DATA AE14CS( 6) /   -.0000171733 2998937E0 /
      DATA AE14CS( 7) /    .0000029856 2751447E0 /
      DATA AE14CS( 8) /   -.0000005659 6491457E0 /
      DATA AE14CS( 9) /    .0000001152 6808397E0 /
      DATA AE14CS(10) /   -.0000000249 5030440E0 /
      DATA AE14CS(11) /    .0000000056 9232420E0 /
      DATA AE14CS(12) /   -.0000000013 5995766E0 /
      DATA AE14CS(13) /    .0000000003 3846628E0 /
      DATA AE14CS(14) /   -.0000000000 8737853E0 /
      DATA AE14CS(15) /    .0000000000 2331588E0 /
      DATA AE14CS(16) /   -.0000000000 0641148E0 /
      DATA AE14CS(17) /    .0000000000 0181224E0 /
      DATA AE14CS(18) /   -.0000000000 0052538E0 /
      DATA AE14CS(19) /    .0000000000 0015592E0 /
      DATA AE14CS(20) /   -.0000000000 0004729E0 /
      DATA AE14CS(21) /    .0000000000 0001463E0 /
      DATA AE14CS(22) /   -.0000000000 0000461E0 /
      DATA AE14CS(23) /    .0000000000 0000148E0 /
      DATA AE14CS(24) /   -.0000000000 0000048E0 /
      DATA AE14CS(25) /    .0000000000 0000016E0 /
      DATA AE14CS(26) /   -.0000000000 0000005E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  E1
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NTAE11 = INITS (AE11CS, 39, ETA)
         NTAE12 = INITS (AE12CS, 25, ETA)
         NTE11 = INITS (E11CS, 19, ETA)
         NTE12 = INITS (E12CS, 16, ETA)
         NTAE13 = INITS (AE13CS, 25, ETA)
         NTAE14 = INITS (AE14CS, 26, ETA)
C
         XMAXT = -LOG (R1MACH(1))
         XMAX = XMAXT - LOG(XMAXT)
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GT.(-10.)) GO TO 20
C
C E1(X) = -EI(-X) FOR X .LE. -10.
C
      E1 = EXP(-X)/X * (1.+CSEVL (20./X+1., AE11CS, NTAE11))
      RETURN
C
 20   IF (X.GT.(-4.0)) GO TO 30
C
C E1(X) = -EI(-X) FOR -10. .LT. X .LE. -4.
C
      E1 = EXP(-X)/X * (1.+CSEVL ((40./X+7.)/3., AE12CS, NTAE12))
      RETURN
C
 30   IF (X.GT.(-1.0)) GO TO 40
C
C E1(X) = -EI(-X) FOR -4. .LT. X .LE. -1.
C
      E1 = -LOG(ABS(X)) + CSEVL ((2.*X+5.)/3., E11CS, NTE11)
      RETURN
C
 40   IF (X.GT.1.) GO TO 50
      IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'E1', 'X IS 0', 2, 2)
C
C E1(X) = -EI(-X) FOR -1. .LT. X .LE. 1.,  X .NE. 0.
C
      E1 = (-LOG(ABS(X)) - 0.6875 + X) + CSEVL (X, E12CS, NTE12)
      RETURN
C
 50   IF (X.GT.4.) GO TO 60
C
C E1(X) = -EI(-X) FOR 1. .LT. X .LE. 4.
C
      E1 = EXP(-X)/X * (1.+CSEVL ((8./X-5.)/3., AE13CS, NTAE13))
      RETURN
C
 60   IF (X.GT.XMAX) GO TO 70
C
C E1(X) = -EI(-X) FOR 4. .LT. X .LE. XMAX
C
      E1 = EXP(-X)/X * (1. + CSEVL (8./X-1., AE14CS, NTAE14))
      RETURN
C
C E1(X) = -EI(-X) FOR X .GT. XMAX
C
 70   CALL XERMSG ('SLATEC', 'E1', 'X SO BIG E1 UNDERFLOWS', 1, 1)
      E1 = 0.
      RETURN
C
      END


      subroutine calcopacities
c******************************************************************************
c     This routine calculates the line absorption coefficient and the line
c     opacity at wavelength *wave* for all lines in the spectrum
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Linex.com'
      include 'Dummy.com'
      include 'Stokes.com'
      real*8 voigt_val, faraday_voigt_val,voigt_x,voigt_y, sqrtpi
      complex Z, humlicek, w4

c*****compute the total line opacity at each depth

      sqrtpi = 1.772453851
      do i=1,ntau
         phi_opacity(i,1) = 0.0
         phi_opacity(i,2) = 0.0
         phi_opacity(i,3) = 0.0
         psi_opacity(i,1) = 0.0
         psi_opacity(i,2) = 0.0
         psi_opacity(i,3) = 0.0
         do j=lim1,lim2
            voigt_x = (wave-wave1(j))/(wave1(j)*dopp(j,i)/2.997929d10)
            voigt_y = a(j,i)
            Z = cmplx(voigt_x, voigt_y)
            humlicek = w4(Z)
            voigt_val = REAL(humlicek,8)/sqrtpi
            faraday_voigt_val = AIMAG(humlicek)/sqrtpi
            phi_opacity(i,int(deltamj(j)+2))=phi_opacity(i,
     .               int(deltamj(j)+2))+ kapnu0(j,i)*voigt_val
            psi_opacity(i,int(deltamj(j)+2)) = psi_opacity(i,
     .               int(deltamj(j)+2))+ kapnu0(j,i)*faraday_voigt_val
         enddo

c*****do the same for the strong lines
         if (dostrong .gt. 0) then
            do j=nlines+1,nlines+nstrong
               voigt_x =(wave-wave1(j))/(wave1(j)*dopp(j,i)/2.997929d10)
               voigt_y = a(j,i)
               Z = cmplx(voigt_x, voigt_y)
               humlicek = w4(Z)
               voigt_val = REAL(humlicek,8)/sqrtpi
               faraday_voigt_val = REAL(AIMAG(humlicek)/sqrtpi,8)
               phi_opacity(i,int(deltamj(j)+2))=phi_opacity(i,
     .                  int(deltamj(j)+2))+kapnu0(j,i)*voigt_val
               psi_opacity(i,int(deltamj(j)+2))=psi_opacity(i,
     .                  int(deltamj(j)+2))+kapnu0(j,i)*faraday_voigt_val
            enddo
         endif
      enddo

      return
      end


      subroutine ire_restx(ctfm,ctfmp,n_a1,n_alpha,n_b1,n_beta,n_ipsi,n_
     &rpsi,nm1_a1,nm1_b1,nm1_ipsi,nm1_rpsi,np1_a1,np1_b1,np1_ipsi,np1_rp
     &si,octfmp,Nx,ht,hx,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_b1(Nx)
      real*8 n_beta(Nx)
      real*8 n_ipsi(Nx)
      real*8 n_rpsi(Nx)
      real*8 nm1_a1(Nx)
      real*8 nm1_b1(Nx)
      real*8 nm1_ipsi(Nx)
      real*8 nm1_rpsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_b1(Nx)
      real*8 np1_ipsi(Nx)
      real*8 np1_rpsi(Nx)
      real*8 octfmp(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = (-0.5000000000000000D0 / n_alpha(i) ** 2 / n_b1(i) / n_a1(i)
     #* (-0.1D1 * nm1_a1(i) + np1_a1(i)) / ht * (-0.1D1 * n_b1(i - 1) +
     #n_b1(i + 1)) / hx + 0.5000000000000000D0 / n_alpha(i) ** 3 / n_b1(
     #i) * (-0.1D1 * nm1_b1(i) + np1_b1(i)) / ht * (n_alpha(i - 1) - 0.1
     #D1 * n_alpha(i + 1)) / hx + (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) /
     # hx / n_b1(i) / n_alpha(i) ** 2 * n_beta(i) * octfmp(i) + 0.250000
     #0000000000D0 / n_alpha(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rpsi(
     #i + 1)) / hx * (-0.1D1 * nm1_rpsi(i) + np1_rpsi(i)) / ht - 0.25000
     #00000000000D0 / n_alpha(i) ** 2 * (n_ipsi(i - 1) - 0.1D1 * n_ipsi(
     #i + 1)) / hx * (-0.1D1 * nm1_ipsi(i) + np1_ipsi(i)) / ht + 0.50000
     #00000000000D0 / n_alpha(i) ** 2 / n_b1(i) * (nm1_b1(i - 1) - 0.1D1
     # * nm1_b1(i + 1) - 0.1D1 * np1_b1(i - 1) + np1_b1(i + 1)) / hx / h
     #t) / ctfmp(i) + (-0.5000000000000000D0 / n_alpha(i) ** 2 / n_b1(i)
     # / n_a1(i) * n_beta(i) * (n_a1(i - 1) - 0.1D1 * n_a1(i + 1)) / hx
     #** 2 * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) - 0.5000000000000000D0
     # / n_alpha(i) ** 3 / n_b1(i) * n_beta(i) * (n_alpha(i - 1) - 0.1D1
     # * n_alpha(i + 1)) / hx ** 2 * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)
     #) - 0.2500000000000000D0 / n_alpha(i) ** 2 * n_beta(i) * (-0.1D1 *
     # n_rpsi(i - 1) + n_rpsi(i + 1)) ** 2 / hx ** 2 - 0.250000000000000
     #0D0 / n_alpha(i) ** 2 * n_beta(i) * (n_ipsi(i - 1) - 0.1D1 * n_ips
     #i(i + 1)) ** 2 / hx ** 2 + 0.2D1 / n_alpha(i) ** 2 / n_b1(i) * n_b
     #eta(i) * (-0.1D1 * n_b1(i - 1) + 0.2D1 * n_b1(i) - 0.1D1 * n_b1(i
     #+ 1)) / hx ** 2) / ctfmp(i) ** 2 + (-0.1D1 * (-0.1D1 * nm1_a1(i) +
     # np1_a1(i)) / ht / n_alpha(i) ** 2 / n_a1(i) + 0.1D1 / n_alpha(i)
     #** 2 / n_b1(i) * (-0.1D1 * nm1_b1(i) + np1_b1(i)) / ht + (-0.1D1 *
     # (n_a1(i - 1) - 0.1D1 * n_a1(i + 1)) / hx / n_alpha(i) ** 2 / n_a1
     #(i) * n_beta(i) - 0.1D1 * (n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)
     #) / hx / n_alpha(i) ** 3 * n_beta(i) - 0.2D1 * (-0.1D1 * n_b1(i -
     #1) + n_b1(i + 1)) / hx / n_alpha(i) ** 2 / n_b1(i) * n_beta(i)) /
     #ctfmp(i)) / ctfm(i)
      res(i)=qb
      end do
      END


program main
    use mpi
    implicit none
    integer :: ntasks, id, rc
    integer, allocatable :: status(:)
    integer :: i, n, clock
    integer, allocatable :: seed(:)
    real(8) :: x

    ! initialize the MPI environment
    call MPI_INIT(rc)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, rc)
    call MPI_COMM_RANK(MPI_COMM_WORLD, id, rc)
    allocate(status(MPI_STATUS_SIZE))

    ! initialize the random number for different processes
    if (id == 0) then
        call SYSTEM_CLOCK(clock)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
        do i = 1, ntasks - 1
            call RANDOM_NUMBER(x)
            clock = clock + Int(x * 1000000)
            call MPI_SEND(clock, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, rc)
        end do
    else
        call MPI_RECV(clock, 1, MPI_INTEGER, 0, id, MPI_COMM_WORLD, status, rc)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
    end if

    call RANDOM_NUMBER(x)
    write(*,*) x

    ! done with MPI
    call MPI_FINALIZE(rc)
end program main


! { dg-do  run }
program main
  implicit none
  integer :: i
  integer, parameter, dimension(3,3) :: a = &
       reshape([1,2,3,4,5,6,7,8,9], shape(a))
  integer, dimension(3,3) :: b
  integer, parameter, dimension(3,4,5) :: c = &
       reshape([(i**2,i=1,3*4*5)],shape(c))
  integer, dimension(3,4,5) :: d
  integer, dimension(4,5), parameter :: sh1 =&
       reshape([(i**3-12*i**2,i=1,4*5)],shape(sh1))
  integer, dimension(3,5), parameter :: sh2 = &
       reshape([(i**3-7*i**2,i=1,3*5)], shape(sh2))
  integer, dimension(3,4), parameter :: sh3 = &
       reshape([(i**3-3*i**2,i=1,3*4)], shape(sh3))
  integer, parameter, dimension(3,4,5) :: c1 = cshift(c,shift=sh1,dim=1)
  integer, parameter, dimension(3,4,5) :: c2 = cshift(c,shift=sh2,dim=2)
  integer, parameter, dimension(3,4,5) :: c3 = cshift(c,shift=sh3,dim=3)

  b = a
  if (any(cshift(a,1) /= cshift(b,1))) STOP 1
  if (any(cshift(a,2) /= cshift(b,2))) STOP 2
  if (any(cshift(a,1,dim=2) /= cshift(b,1,dim=2))) STOP 3
  d = c
  if (any(cshift(c,1) /= cshift(d,1))) STOP 4
  if (any(cshift(c,2) /= cshift(d,2))) STOP 5
  if (any(cshift(c,3) /= cshift(d,3))) STOP 6

  if (any(cshift(c,1,dim=2) /= cshift(d,1,dim=2))) STOP 7
  if (any(cshift(c,2,dim=2) /= cshift(d,2,dim=2))) STOP 8
  if (any(cshift(c,3,dim=3) /= cshift(d,3,dim=3))) STOP 9

  if (any(cshift(d,shift=sh1,dim=1) /= c1)) STOP 10
  if (any(cshift(d,shift=sh2,dim=2) /= c2)) STOP 11
  if (any(cshift(d,shift=sh3,dim=3) /= c3)) STOP 12
end program main


module mod_rgrd2u
    use mod_rgrd1u
    implicit none

contains
    !

    ! Code converted using TO_F90 by Alan Miller
    ! Date: 2013-09-18  Time: 12:23:04

    ! ... file rgrd2u.f

    !     this file contains documentation followed by fortran code for
    !     subroutine rgrd2u and additional subroutines.

    ! ... author

    !     John C. Adams (NCAR 1999)

    ! ... subroutine rgrd2u(nx,ny,p,mx,my,q,intpol,w,lw,iw,liw,ier)

    ! ... purpose

    !     subroutine rgrd2u interpolates the nx by ny array p onto
    !     the mx by my array q.  linear or cubic interpolation is
    !     used in each direction (see aargumentintpol).  it is assumed
    !     that p and q are values on uniform nx by ny and mx by my grids
    !     superimposed on the same rectangle (INCLUDING BOUNDARIES).
    !     if p and q are values on nonuniform orthogonal grids and/or
    !     if the grid on which q is defined lies within the p grid
    !     then subroutine rgrd2 (see file rgrd2.f) should be used.

    ! ... language

    !     coded in portable FORTRAN77 and FORTRAN90

    ! ... test program

    !     file trgrd2u.f on regridpack includes a test program for subroutine rgrd2u

    ! ... method

    !     linear or cubic interpolation (see intpol) is used in each
    !     direction for which the q grid is not a subgrid of the p grid.
    !     [the mx (my) uniform grid is a subgrid of the nx (ny) uniform
    !     grid if and only if mx-1 (my-1) divides nx-1 (ny-1)].
    !     values are set directly without (the need for) interpolation
    !     in subgrid directions.

    ! ... required files

    !     file rgrd1u.f must be loaded with rgrd2u.f.  it includes
    !     subroutines called by the routines in rgrd2u.f

    ! ... efficiency

    !     inner most loops in regridpack software vectorize.  If
    !     the arguments mx,my (see below) have different values, optimal
    !     vectorization will be achieved if mx > my.

    ! *** input arguments ***

    ! ... nx

    !     the integer first dimension of p.  nx > 1 if intpol(1) = 1 or
    !     nx > 3 if intpol(1) = 3 is required (see ier = 2).

    ! ... ny

    !     the integer second dimension of p.  ny > 1 if intpol(2) = 1 or
    !     ny > 3 if intpol(2) = 3 is required (see ier = 2).

    ! ... p

    !     a real (kind=8) nx by ny array of given values

    ! ... mx

    !     the integer first dimension of q.  mx > 1 is required (see ier = 1)

    ! ... my

    !     the integer second dimension of q. my > 1 is required (see ier = 1)

    ! ... intpol

    !     an integer vector of dimension 2 which sets linear or cubic
    !     interpolation in each of the x,y directions as follows:

    !        intpol(1) = 1 sets linear interpolation in the x direction
    !        intpol(1) = 3 sets cubic interpolation in the x direction.

    !        intpol(2) = 1 sets linear interpolation in the y direction
    !        intpol(2) = 3 sets cubic interpolation in the y direction.

    !     values other than 1 or 3 in intpol are not allowed (ier = 3).

    ! ... w

    !     a real (kind=8) work space of length at least lw which must be provided in the
    !     routine calling rgrd2u

    ! ... lw

    !     the integer length of the work space w.

    !          let lwx = 1 if mx-1 divides nx-1; otherwise
    !          let lwx =   mx if intpol(1) = 1 or
    !          let lwx = 4*mx if intpol(1) = 3

    !          let lwy = 0 if my-1 divides ny-1; otherwise
    !          let lwy = 2*mx+my if intpol(2) = 1 or
    !          let lwy = 4*(mx+my)  if intpol(2) = 3

    !     then lw must be greater than or equal to lwx+lwy

    ! ... iw

    !     an integer work space of length at least liw which must be provided in the
    !     routine calling rgrd2u

    ! ... liw

    !     the integer length of the integer work space iw.  liw must be greater than
    !     or equal to mx+my.

    ! *** output arguments ***

    ! ... q

    !     a real (kind=8) mx by my array of values which are interpolated from p.

    ! ... ier

    !     an integer error flag set as follows:

    !     ier = 0 if no errors in input arguments are detected

    !     ier = 1 if  min0(mx,my) < 2

    !     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
    !                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3.

    !     ier = 3 if intpol(1) or intpol(2) is not equal to 1 or 3

    !     ier = 4 if lw or liw is to small (insufficient work space)

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

    !     end of rgrd2u documentation, fortran code follows:

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

    SUBROUTINE rgrd2u(nx,ny,p,mx,my,q,intpol,w,lw,iw,liw,ier)

    !     two dimensional linear or cubic interpolation of p onto q
    !     assuming p and q lie on nx by ny and and mx by my uniform  grids
    !     which subdivide the same rectangle (including boundaries)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    real (kind=8), INTENT(IN)                :: p(nx,ny)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    real (kind=8), INTENT(OUT)               :: q(mx,my)
    INTEGER, INTENT(IN)                      :: intpol(2)
    real (kind=8), INTENT(INOUT)             :: w(lw)
    INTEGER, INTENT(IN)                      :: lw
    INTEGER, INTENT(INOUT)                   :: iw(liw)
    INTEGER, INTENT(IN)                      :: liw
    INTEGER, INTENT(OUT)                     :: ier

    INTEGER :: inmx,jnmy,isubx,jsuby,lwx,lwy,jy
    INTEGER :: j2,j3,j4,j5,j6,j7,j8,j9,i2,i3,i4,i5

    !     check input aarguments

    ier = 1

    !     check mx,my

    IF (MIN0(mx,my) < 2) RETURN

    !     check intpol

    ier = 3
    IF (intpol(1) /= 1 .AND. intpol(1) /= 3) RETURN
    IF (intpol(2) /= 1 .AND. intpol(2) /= 3) RETURN

    !     check nx,ny

    ier = 2
    IF (intpol(1) == 1 .AND. nx < 2) RETURN
    IF (intpol(1) == 3 .AND. nx < 4) RETURN
    IF (intpol(2) == 1 .AND. ny < 2) RETURN
    IF (intpol(2) == 3 .AND. ny < 4) RETURN

    !     set subgrid indicators

    inmx = (nx-1)/(mx-1)
    jnmy = (ny-1)/(my-1)
    isubx = nx - inmx*(mx-1)
    jsuby = ny - jnmy*(my-1)

    !     check work space length input

    ier = 4
    lwx = 1
    lwy = 0
    IF (isubx /= 1) THEN
      IF (intpol(1) == 1) THEN
        lwx = mx
      ELSE
        lwx = mx
      END IF
    END IF
    IF (jsuby /= 1) THEN
      IF (intpol(2) == 1) THEN
        lwy = (my+2*mx)
      ELSE
        lwy = 4*(mx+my)
      END IF
    END IF
    IF (lw < lwx+lwy) RETURN
    IF (liw < mx+my) RETURN

    !     input arguments o.k.

    ier = 0
    jy = mx+1

    !     preset work space pointers

    j2 = 1
    j3 = j2
    j4 = j3
    j5 = j4
    j6 = j5
    j7 = j6
    j8 = j7
    j9 = j8
    i2 = j9
    i3 = i2
    i4 = i3
    i5 = i4

    IF (intpol(2) == 1) THEN

    !     linearly interpolate in y

      IF (jsuby /= 1) THEN
        j2 = 1
        j3 = j2
        j4 = j3+my
        j5 = j4
        j6 = j5
        j7 = j6
        j8 = j7+mx
        j9 = j8+mx

    !     set y interpolation indices and scales and linearly interpolate

        CALL linmxu(ny,my,iw(jy),w(j3))
        i2 = j9
      END IF

    !     set work space portion and indices which depend on x interpolation

      IF (isubx /= 1) THEN
        IF (intpol(1) == 1) THEN
          i3 = i2
          i4 = i3
          i5 = i4
          CALL linmxu(nx,mx,iw,w(i3))
        ELSE
          i3 = i2+mx
          i4 = i3+mx
          i5 = i4+mx
          CALL cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
        END IF
      END IF
      CALL lint2u(nx,ny,p,mx,my,q,intpol,iw(jy),w(j3),w(j7),  &
          w(j8),iw,w(i2),w(i3),w(i4),w(i5),inmx,jnmy,isubx,jsuby)
      RETURN

    ELSE

    !     cubically interpolate in y, set indice pointers

      IF (jsuby /= 1) THEN
        j2 = 1
        j3 = j2+my
        j4 = j3+my
        j5 = j4+my
        j6 = j5+my
        j7 = j6+mx
        j8 = j7+mx
        j9 = j8+mx

    !     set y interpolation indices and scales and cubically interpolate in y

        CALL cubnmxu(ny,my,iw(jy),w(j2),w(j3),w(j4),w(j5))
        i2 =  j9+mx
      END IF

    !     set work space portion and indices which depend on x interpolation

      IF (isubx /= 1) THEN
        IF (intpol(1) == 1) THEN
          i3 = i2
          i4 = i3
          i5 = i4
          CALL linmxu(nx,mx,iw,w(i3))
        ELSE
          i3 = i2+mx
          i4 = i3+mx
          i5 = i4+mx
          CALL cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
        END IF
      END IF
      CALL cubt2u(nx,ny,p,mx,my,q,intpol,iw(jy),w(j2),w(j3),w(j4),  &
          w(j5),w(j6),w(j7),w(j8),w(j9),iw,w(i2),w(i3),w(i4),w(i5),  &
          inmx,jnmy,isubx,jsuby)
      RETURN
    END IF
    END SUBROUTINE rgrd2u

    SUBROUTINE lint2u(nx,ny,p,mx,my,q,intpol,jy,dy,pj,pjp,ix,dxm,dx,  &
        dxp,dxpp,inmx,jnmy,isubx,jsuby)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    real (kind=8), INTENT(IN)                :: p(nx,ny)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    real (kind=8), INTENT(OUT)               :: q(mx,my)
    INTEGER, INTENT(IN)                      :: intpol(2)
    INTEGER, INTENT(IN)                      :: jy(my)
    real (kind=8), INTENT(IN)                :: dy(my)
    real (kind=8), INTENT(OUT)               :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)
    INTEGER, INTENT(IN OUT)                  :: inmx
    INTEGER, INTENT(IN)                      :: jnmy
    INTEGER, INTENT(IN OUT)                  :: isubx
    INTEGER, INTENT(IN)                      :: jsuby

    INTEGER :: j,jj,ii,jsave

    !     linearly interpolate p onto q in y

    IF (intpol(1) == 1) THEN

    !     linear in x

      IF (jsuby == 1) THEN

    !     my grid is subset of ny grid

        DO jj=1,my
          j = jnmy*(jj-1)+1
          CALL lint1u(nx,p(1,j),mx,q(1,jj),ix,dx,inmx,isubx)
        END DO
        RETURN
      END IF

      jsave = -1
      DO jj=1,my
        j = jy(jj)
        IF (j == jsave) THEN

    !     pointer has not moved, no interpolation in pj,pjp necessary

        ELSE IF (j == jsave+1) THEN
          DO ii=1,mx
            pj(ii) = pjp(ii)
          END DO
          CALL lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
        ELSE
          CALL lint1u(nx,p(1,j),mx,pj,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
        END IF

    !     update pointer

        jsave = j
        DO ii=1,mx
          q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
        END DO
      END DO

      RETURN

    ELSE

    !     cubic in x

      IF (jsuby == 1) THEN

    !     my grid is subset of ny grid

        DO jj=1,my
          j = jnmy*(jj-1)+1
          CALL cubt1u(nx,p(1,j),mx,q(1,jj),ix,dxm,dx,dxp,dxpp, inmx,isubx)
        END DO
        RETURN
      END IF

      jsave = -1
      DO jj=1,my
        j = jy(jj)
        IF (j == jsave) THEN

    !     no interpolation in pj,pjp necessary

        ELSE IF (j == jsave+1) THEN
          DO ii=1,mx
            pj(ii) = pjp(ii)
          END DO
          CALL cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
        ELSE
          CALL cubt1u(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
        END IF

    !     update  pointer

        jsave = j
        DO ii=1,mx
          q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
        END DO
      END DO
      RETURN

    END IF

    END SUBROUTINE lint2u

    SUBROUTINE cubt2u(nx,ny,p,mx,my,q,intpol,jy,dym,dy,dyp,dypp,  &
        pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,inmx,jnmy,isubx,jsuby)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    real (kind=8), INTENT(IN)                :: p(nx,ny)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    real (kind=8), INTENT(OUT)               :: q(mx,my)
    INTEGER, INTENT(IN)                      :: intpol(2)
    INTEGER, INTENT(IN)                      :: jy(my)
    real (kind=8), INTENT(IN)                :: dym(my)
    real (kind=8), INTENT(IN)                :: dy(my)
    real (kind=8), INTENT(IN OUT)            :: dyp(my)
    real (kind=8), INTENT(IN OUT)            :: dypp(my)
    real (kind=8), INTENT(OUT)               :: pjm(mx)
    real (kind=8), INTENT(IN OUT)            :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    real (kind=8), INTENT(IN OUT)            :: pjpp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)
    INTEGER, INTENT(IN OUT)                  :: inmx
    INTEGER, INTENT(IN)                      :: jnmy
    INTEGER, INTENT(IN OUT)                  :: isubx
    INTEGER, INTENT(IN)                      :: jsuby

    INTEGER :: j,jj,ii,jsave

    !     cubically interpolate p onto q in y

    IF (intpol(1) == 1) THEN

    !     linear in x

      IF (jsuby == 1) THEN

    !     my grid is subset of ny grid

        DO jj=1,my
          j = jnmy*(jj-1)+1
          CALL lint1u(nx,p(1,j),mx,q(1,jj),ix,dx,inmx,isubx)
        END DO
        RETURN
      END IF

      jsave = -3
      DO jj=1,my
        j = jy(jj)

    !     load pjm,pj,pjp,pjpp

        IF (j == jsave) THEN
    !     no updates or x interpolation necessary
        ELSE IF (j == jsave+1) THEN
          DO ii=1,mx
            pjm(ii) = pj(ii)
            pj(ii) = pjp(ii)
            pjp(ii) = pjpp(ii)
          END DO
          CALL lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
        ELSE IF (j == jsave+2) THEN
          DO ii=1,mx
            pjm(ii) = pjp(ii)
            pj(ii) = pjpp(ii)
          END DO
          CALL lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
        ELSE IF (j == jsave+3) THEN
          DO ii=1,mx
            pjm(ii) = pjpp(ii)
          END DO
          CALL lint1u(nx,p(1,j),mx,pj,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
        ELSE
    !     load all four (no updates)
          CALL lint1u(nx,p(1,j-1),mx,pjm,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j),mx,pj,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
          CALL lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
        END IF

    !     update pointer

        jsave = j
        DO ii=1,mx
          q(ii,jj) = dym(jj)*pjm(ii) + dy(jj)*pj(ii) +  &
              dyp(jj)*pjp(ii) + dypp(jj)*pjpp(ii)
        END DO
      END DO
      RETURN

    ELSE

    !     cubic in x

      IF (jsuby == 1) THEN

    !     my grid is subset of ny grid

        DO jj=1,my
          j = jnmy*(jj-1)+1
          CALL cubt1u(nx,p(1,j),mx,q(1,jj),ix,dxm,dx,dxp,dxpp, inmx,isubx)
        END DO
        RETURN
      END IF

      jsave = -3
      DO jj=1,my
        j = jy(jj)

    !     load pjm,pj,pjp,pjpp

        IF (j == jsave) THEN
    !     no updates or x interpolation necessary
        ELSE IF (j == jsave+1) THEN
          DO ii=1,mx
            pjm(ii) = pj(ii)
            pj(ii) = pjp(ii)
            pjp(ii) = pjpp(ii)
          END DO
          CALL cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
        ELSE IF (j == jsave+2) THEN
          DO ii=1,mx
            pjm(ii) = pjp(ii)
            pj(ii) = pjpp(ii)
          END DO
          CALL cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
        ELSE IF (j == jsave+3) THEN
          DO ii=1,mx
            pjm(ii) = pjpp(ii)
          END DO
          CALL cubt1u(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
        ELSE
    !     load all four (no updates)
          CALL cubt1u(nx,p(1,j-1),mx,pjm,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
          CALL cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp, inmx,isubx)
        END IF

    !     update pointer

        jsave = j
        DO ii=1,mx
          q(ii,jj) = dym(jj)*pjm(ii) + dy(jj)*pj(ii) +  &
              dyp(jj)*pjp(ii) + dypp(jj)*pjpp(ii)
        END DO
      END DO
      RETURN

    END IF

    END SUBROUTINE cubt2u
end module